module_bc.F
References to this file elsewhere.
1 !WRF:MODEL_LAYER:BOUNDARY
2 !
3
4 MODULE module_bc
5
6 USE module_configure
7 USE module_wrf_error
8 IMPLICIT NONE
9
10 ! TYPE bcs
11 !
12 ! LOGICAL :: periodic_x
13 ! LOGICAL :: symmetric_xs
14 ! LOGICAL :: symmetric_xe
15 ! LOGICAL :: open_xs
16 ! LOGICAL :: open_xe
17 ! LOGICAL :: periodic_y
18 ! LOGICAL :: symmetric_ys
19 ! LOGICAL :: symmetric_ye
20 ! LOGICAL :: open_ys
21 ! LOGICAL :: open_ye
22 ! LOGICAL :: nested
23 ! LOGICAL :: specified
24 ! LOGICAL :: top_radiation
25 !
26 ! END TYPE bcs
27
28 ! set the bdyzone. We are hardwiring this here and we'll
29 ! decide later where it should be set and stored
30
31 INTEGER, PARAMETER :: bdyzone = 4
32 INTEGER, PARAMETER :: bdyzone_x = bdyzone
33 INTEGER, PARAMETER :: bdyzone_y = bdyzone
34
35 INTERFACE stuff_bdy
36 MODULE PROCEDURE stuff_bdy_new , stuff_bdy_old
37 END INTERFACE
38
39 INTERFACE stuff_bdytend
40 MODULE PROCEDURE stuff_bdytend_new , stuff_bdytend_old
41 END INTERFACE
42
43 CONTAINS
44
45 SUBROUTINE boundary_condition_check ( config_flags, bzone, error, gn )
46
47 ! this routine checks the boundary condition logicals
48 ! to make sure that the boundary conditions are not over
49 ! or under specified. The routine also checks that the
50 ! boundary zone is sufficiently sized for the specified
51 ! boundary conditions
52
53 IMPLICIT NONE
54
55 TYPE( grid_config_rec_type ) config_flags
56
57 INTEGER, INTENT(IN ) :: bzone, gn
58 INTEGER, INTENT(INOUT) :: error
59
60 ! local variables
61
62 INTEGER :: xs_bc, xe_bc, ys_bc, ye_bc, bzone_min
63 INTEGER :: nprocx, nprocy
64
65 CALL wrf_debug( 100 , ' checking boundary conditions for grid ' )
66
67 error = 0
68 xs_bc = 0
69 xe_bc = 0
70 ys_bc = 0
71 ye_bc = 0
72
73 ! sum the number of conditions specified for each lateral boundary.
74 ! obviously, this number should be 1
75
76 IF( config_flags%periodic_x ) THEN
77 xs_bc = xs_bc+1
78 xe_bc = xe_bc+1
79 ENDIF
80
81 IF( config_flags%periodic_y ) THEN
82 ys_bc = ys_bc+1
83 ye_bc = ye_bc+1
84 ENDIF
85
86 IF( config_flags%symmetric_xs ) xs_bc = xs_bc + 1
87 IF( config_flags%symmetric_xe ) xe_bc = xe_bc + 1
88 IF( config_flags%open_xs ) xs_bc = xs_bc + 1
89 IF( config_flags%open_xe ) xe_bc = xe_bc + 1
90
91
92 IF( config_flags%symmetric_ys ) ys_bc = ys_bc + 1
93 IF( config_flags%symmetric_ye ) ye_bc = ye_bc + 1
94 IF( config_flags%open_ys ) ys_bc = ys_bc + 1
95 IF( config_flags%open_ye ) ye_bc = ye_bc + 1
96
97 IF( config_flags%nested ) THEN
98 xs_bc = xs_bc + 1
99 xe_bc = xe_bc + 1
100 ys_bc = ys_bc + 1
101 ye_bc = ye_bc + 1
102 ENDIF
103
104 IF( config_flags%specified ) THEN
105 IF( .NOT. config_flags%periodic_x)xs_bc = xs_bc + 1
106 IF( .NOT. config_flags%periodic_x)xe_bc = xe_bc + 1
107 ys_bc = ys_bc + 1
108 ye_bc = ye_bc + 1
109 ENDIF
110
111 IF( config_flags%polar ) THEN
112 ys_bc = ys_bc + 1
113 ye_bc = ye_bc + 1
114 ENDIF
115
116 ! check the number of conditions for each boundary
117
118 IF( (xs_bc /= 1) .or. &
119 (xe_bc /= 1) .or. &
120 (ys_bc /= 1) .or. &
121 (ye_bc /= 1) ) THEN
122
123 error = 1
124
125 write( wrf_err_message ,*) ' *** Error in boundary condition specification '
126 CALL wrf_message ( wrf_err_message )
127 write( wrf_err_message ,*) ' boundary conditions at xs ', xs_bc
128 CALL wrf_message ( wrf_err_message )
129 write( wrf_err_message ,*) ' boundary conditions at xe ', xe_bc
130 CALL wrf_message ( wrf_err_message )
131 write( wrf_err_message ,*) ' boundary conditions at ys ', ys_bc
132 CALL wrf_message ( wrf_err_message )
133 write( wrf_err_message ,*) ' boundary conditions at ye ', ye_bc
134 CALL wrf_message ( wrf_err_message )
135 write( wrf_err_message ,*) ' boundary conditions logicals are '
136 CALL wrf_message ( wrf_err_message )
137 write( wrf_err_message ,*) ' periodic_x ',config_flags%periodic_x
138 CALL wrf_message ( wrf_err_message )
139 write( wrf_err_message ,*) ' periodic_y ',config_flags%periodic_y
140 CALL wrf_message ( wrf_err_message )
141 write( wrf_err_message ,*) ' symmetric_xs ',config_flags%symmetric_xs
142 CALL wrf_message ( wrf_err_message )
143 write( wrf_err_message ,*) ' symmetric_xe ',config_flags%symmetric_xe
144 CALL wrf_message ( wrf_err_message )
145 write( wrf_err_message ,*) ' symmetric_ys ',config_flags%symmetric_ys
146 CALL wrf_message ( wrf_err_message )
147 write( wrf_err_message ,*) ' symmetric_ye ',config_flags%symmetric_ye
148 CALL wrf_message ( wrf_err_message )
149 write( wrf_err_message ,*) ' open_xs ',config_flags%open_xs
150 CALL wrf_message ( wrf_err_message )
151 write( wrf_err_message ,*) ' open_xe ',config_flags%open_xe
152 CALL wrf_message ( wrf_err_message )
153 write( wrf_err_message ,*) ' open_ys ',config_flags%open_ys
154 CALL wrf_message ( wrf_err_message )
155 write( wrf_err_message ,*) ' open_ye ',config_flags%open_ye
156 CALL wrf_message ( wrf_err_message )
157 write( wrf_err_message ,*) ' polar ',config_flags%polar
158 CALL wrf_message ( wrf_err_message )
159 write( wrf_err_message ,*) ' nested ',config_flags%nested
160 CALL wrf_message ( wrf_err_message )
161 write( wrf_err_message ,*) ' specified ',config_flags%specified
162 CALL wrf_message ( wrf_err_message )
163 CALL wrf_error_fatal( ' *** Error in boundary condition specification ' )
164
165 ENDIF
166
167 ! now check to see if boundary zone size is sufficient.
168 ! we could have the necessary boundary zone size be returned
169 ! to the calling routine.
170
171 IF( config_flags%periodic_x .or. &
172 config_flags%periodic_y .or. &
173 config_flags%symmetric_xs .or. &
174 config_flags%symmetric_xe .or. &
175 config_flags%symmetric_ys .or. &
176 config_flags%symmetric_ye ) THEN
177
178 bzone_min = MAX( 1, &
179 (config_flags%h_mom_adv_order+1)/2, &
180 (config_flags%h_sca_adv_order+1)/2 )
181
182 IF( bzone < bzone_min) THEN
183
184 error = 2
185 WRITE ( wrf_err_message , * ) ' boundary zone not large enough '
186 CALL wrf_message ( wrf_err_message )
187 WRITE ( wrf_err_message , * ) ' boundary zone specified ',bzone
188 CALL wrf_message ( wrf_err_message )
189 WRITE ( wrf_err_message , * ) ' minimum boundary zone needed ',bzone_min
190 CALL wrf_error_fatal ( wrf_err_message )
191
192 ENDIF
193 ENDIF
194
195 CALL wrf_debug ( 100 , ' boundary conditions OK for grid ' )
196
197 END subroutine boundary_condition_check
198
199 !--------------------------------------------------------------------------
200 SUBROUTINE set_physical_bc2d( dat, variable_in, &
201 config_flags, &
202 ids,ide, jds,jde, & ! domain dims
203 ims,ime, jms,jme, & ! memory dims
204 ips,ipe, jps,jpe, & ! patch dims
205 its,ite, jts,jte )
206
207 ! This subroutine sets the data in the boundary region, by direct
208 ! assignment if possible, for periodic and symmetric (wall)
209 ! boundary conditions. Currently, we are only doing 1 variable
210 ! at a time - lots of overhead, so maybe this routine can be easily
211 ! inlined later or we could pass multiple variables -
212 ! would probably want a largestep and smallstep version.
213
214 ! 15 Jan 99, Dave
215 ! Modified the incoming its,ite,jts,jte to truly be the tile size.
216 ! This required modifying the loop limits when the "istag" or "jstag"
217 ! is used, as this is only required at the end of the domain.
218
219 IMPLICIT NONE
220
221 INTEGER, INTENT(IN ) :: ids,ide, jds,jde
222 INTEGER, INTENT(IN ) :: ims,ime, jms,jme
223 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe
224 INTEGER, INTENT(IN ) :: its,ite, jts,jte
225 CHARACTER, INTENT(IN ) :: variable_in
226
227 CHARACTER :: variable
228
229 REAL, DIMENSION( ims:ime , jms:jme ) :: dat
230 TYPE( grid_config_rec_type ) config_flags
231
232 INTEGER :: i, j, istag, jstag, itime
233
234 LOGICAL :: debug, open_bc_copy
235
236 !------------
237
238 debug = .false.
239
240 open_bc_copy = .false.
241
242 variable = variable_in
243 IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
244 variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
245 ENDIF
246 IF ((variable == 'u') .or. (variable == 'v') .or. &
247 (variable == 'w') .or. (variable == 't') .or. &
248 (variable == 'x') .or. (variable == 'y') .or. &
249 (variable == 'r') .or. (variable == 'p') ) open_bc_copy = .true.
250
251 ! begin, first set a staggering variable
252
253 istag = -1
254 jstag = -1
255
256 IF ((variable == 'u') .or. (variable == 'x')) istag = 0
257 IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
258
259 if(debug) then
260 write(6,*) ' in bc2d, var is ',variable, istag, jstag
261 write(6,*) ' b.cs are ', &
262 config_flags%periodic_x, &
263 config_flags%periodic_y
264 end if
265
266
267
268 ! periodic conditions.
269 ! note, patch must cover full range in periodic dir, or else
270 ! its intra-patch communication that is handled elsewheres.
271 ! symmetry conditions can always be handled here, because no
272 ! outside patch communication is needed
273
274 periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
275 IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if east and west both on-processor
276 IF ( its == ids ) THEN
277
278 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
279 DO i = 0,-(bdyzone-1),-1
280 dat(ids+i-1,j) = dat(ide+i-1,j)
281 ENDDO
282 ENDDO
283
284 ENDIF
285
286 IF ( ite == ide ) THEN
287
288 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
289 !! DO i = 1 , bdyzone
290 DO i = -istag , bdyzone
291 dat(ide+i+istag,j) = dat(ids+i+istag,j)
292 ENDDO
293 ENDDO
294
295 ENDIF
296 ENDIF
297
298 ELSE
299
300 symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
301 ( its == ids ) ) THEN
302
303 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
304
305 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
306 DO i = 1, bdyzone
307 dat(ids-i,j) = dat(ids+i-1,j) ! here, dat(0) = dat(1), etc
308 ENDDO ! symmetry about dat(0.5) (u=0 pt)
309 ENDDO
310
311 ELSE
312
313 IF( variable == 'u' ) THEN
314
315 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
316 DO i = 0, bdyzone-1
317 dat(ids-i,j) = - dat(ids+i,j) ! here, u(0) = - u(2), etc
318 ENDDO ! normal b.c symmetry at u(1)
319 ENDDO
320
321 ELSE
322
323 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
324 DO i = 0, bdyzone-1
325 dat(ids-i,j) = dat(ids+i,j) ! here, phi(0) = phi(2), etc
326 ENDDO ! normal b.c symmetry at phi(1)
327 ENDDO
328
329 END IF
330
331 ENDIF
332
333 ENDIF symmetry_xs
334
335
336 ! now the symmetry boundary at xe
337
338 symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
339 ( ite == ide ) ) THEN
340
341 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
342
343 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
344 DO i = 1, bdyzone
345 dat(ide+i-1,j) = dat(ide-i,j) ! sym. about dat(ide-0.5)
346 ENDDO
347 ENDDO
348
349 ELSE
350
351 IF (variable == 'u' ) THEN
352
353 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
354 DO i = 0, bdyzone-1
355 dat(ide+i,j) = - dat(ide-i,j) ! u(ide+1) = - u(ide-1), etc.
356 ENDDO
357 ENDDO
358
359
360 ELSE
361
362 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
363 DO i = 0, bdyzone-1
364 dat(ide+i,j) = dat(ide-i,j) ! phi(ide+1) = phi(ide-1), etc.
365 ENDDO
366 ENDDO
367
368 END IF
369
370 END IF
371
372 END IF symmetry_xe
373
374
375 ! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
376
377 open_xs: IF( ( config_flags%open_xs .or. &
378 config_flags%specified .or. &
379 config_flags%nested ) .and. &
380 ( its == ids ) .and. open_bc_copy ) THEN
381
382 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
383 dat(ids-1,j) = dat(ids,j) ! here, dat(0) = dat(1)
384 dat(ids-2,j) = dat(ids,j)
385 dat(ids-3,j) = dat(ids,j)
386 ENDDO
387
388 ENDIF open_xs
389
390
391 ! now the open boundary copy at xe
392
393 open_xe: IF( ( config_flags%open_xe .or. &
394 config_flags%specified .or. &
395 config_flags%nested ) .and. &
396 ( ite == ide ) .and. open_bc_copy ) THEN
397
398 IF ( variable /= 'u' .and. variable /= 'x') THEN
399
400 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
401 dat(ide ,j) = dat(ide-1,j)
402 dat(ide+1,j) = dat(ide-1,j)
403 dat(ide+2,j) = dat(ide-1,j)
404 ENDDO
405
406 ELSE
407
408 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
409 dat(ide+1,j) = dat(ide,j)
410 dat(ide+2,j) = dat(ide,j)
411 dat(ide+3,j) = dat(ide,j)
412 ENDDO
413
414 END IF
415
416 END IF open_xe
417
418 ! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
419
420 END IF periodicity_x
421
422 ! same procedure in y
423
424 periodicity_y: IF( ( config_flags%periodic_y ) ) THEN
425 IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test of both north and south on processor
426
427 IF( jts == jds ) then
428
429 DO j = 0, -(bdyzone-1), -1
430 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
431 dat(i,jds+j-1) = dat(i,jde+j-1)
432 ENDDO
433 ENDDO
434
435 END IF
436
437 IF( jte == jde ) then
438
439 DO j = -jstag, bdyzone
440 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
441 dat(i,jde+j+jstag) = dat(i,jds+j+jstag)
442 ENDDO
443 ENDDO
444
445 END IF
446
447 END IF
448
449 ELSE
450
451 symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
452 ( jts == jds) ) THEN
453
454 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
455
456 DO j = 1, bdyzone
457 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
458 dat(i,jds-j) = dat(i,jds+j-1)
459 ENDDO
460 ENDDO
461
462 ELSE
463
464 IF (variable == 'v') THEN
465
466 DO j = 1, bdyzone
467 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
468 dat(i,jds-j) = - dat(i,jds+j)
469 ENDDO
470 ENDDO
471
472 ELSE
473
474 DO j = 1, bdyzone
475 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
476 dat(i,jds-j) = dat(i,jds+j)
477 ENDDO
478 ENDDO
479
480 END IF
481
482 ENDIF
483
484 ENDIF symmetry_ys
485
486 ! now the symmetry boundary at ye
487
488 symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
489 ( jte == jde ) ) THEN
490
491 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
492
493 DO j = 1, bdyzone
494 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
495 dat(i,jde+j-1) = dat(i,jde-j)
496 ENDDO
497 ENDDO
498
499 ELSE
500
501 IF (variable == 'v' ) THEN
502
503 DO j = 1, bdyzone
504 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
505 dat(i,jde+j) = - dat(i,jde-j) ! bugfix: changed jds on rhs to jde , JM 20020410
506 ENDDO
507 ENDDO
508
509 ELSE
510
511 DO j = 1, bdyzone
512 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
513 dat(i,jde+j) = dat(i,jde-j)
514 ENDDO
515 ENDDO
516
517 END IF
518
519 ENDIF
520
521 END IF symmetry_ye
522
523 ! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
524
525 open_ys: IF( ( config_flags%open_ys .or. &
526 config_flags%polar .or. &
527 config_flags%specified .or. &
528 config_flags%nested ) .and. &
529 ( jts == jds) .and. open_bc_copy ) THEN
530
531 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
532 dat(i,jds-1) = dat(i,jds)
533 dat(i,jds-2) = dat(i,jds)
534 dat(i,jds-3) = dat(i,jds)
535 ENDDO
536
537 ENDIF open_ys
538
539 ! now the open boundary copy at ye
540
541 open_ye: IF( ( config_flags%open_ye .or. &
542 config_flags%polar .or. &
543 config_flags%specified .or. &
544 config_flags%nested ) .and. &
545 ( jte == jde ) .and. open_bc_copy ) THEN
546
547 IF (variable /= 'v' .and. variable /= 'y' ) THEN
548
549 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
550 dat(i,jde ) = dat(i,jde-1)
551 dat(i,jde+1) = dat(i,jde-1)
552 dat(i,jde+2) = dat(i,jde-1)
553 ENDDO
554
555 ELSE
556
557 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
558 dat(i,jde+1) = dat(i,jde)
559 dat(i,jde+2) = dat(i,jde)
560 dat(i,jde+3) = dat(i,jde)
561 ENDDO
562
563 ENDIF
564
565 END IF open_ye
566
567 ! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
568
569 END IF periodicity_y
570
571 ! fix corners for doubly periodic domains
572
573 IF ( config_flags%periodic_x .and. config_flags%periodic_y &
574 .and. (ids == ips) .and. (ide == ipe) &
575 .and. (jds == jps) .and. (jde == jpe) ) THEN
576
577 IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
578 DO j = 0, -(bdyzone-1), -1
579 DO i = 0, -(bdyzone-1), -1
580 dat(ids+i-1,jds+j-1) = dat(ide+i-1,jde+j-1)
581 ENDDO
582 ENDDO
583 END IF
584
585 IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
586 DO j = 0, -(bdyzone-1), -1
587 DO i = 1, bdyzone
588 dat(ide+i+istag,jds+j-1) = dat(ids+i+istag,jde+j-1)
589 ENDDO
590 ENDDO
591 END IF
592
593 IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
594 DO j = 1, bdyzone
595 DO i = 1, bdyzone
596 dat(ide+i+istag,jde+j+jstag) = dat(ids+i+istag,jds+j+jstag)
597 ENDDO
598 ENDDO
599 END IF
600
601 IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
602 DO j = 1, bdyzone
603 DO i = 0, -(bdyzone-1), -1
604 dat(ids+i-1,jde+j+jstag) = dat(ide+i-1,jds+j+jstag)
605 ENDDO
606 ENDDO
607 END IF
608
609 END IF
610
611 END SUBROUTINE set_physical_bc2d
612
613 !-----------------------------------
614
615 SUBROUTINE set_physical_bc3d( dat, variable_in, &
616 config_flags, &
617 ids,ide, jds,jde, kds,kde, & ! domain dims
618 ims,ime, jms,jme, kms,kme, & ! memory dims
619 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
620 its,ite, jts,jte, kts,kte )
621
622 ! This subroutine sets the data in the boundary region, by direct
623 ! assignment if possible, for periodic and symmetric (wall)
624 ! boundary conditions. Currently, we are only doing 1 variable
625 ! at a time - lots of overhead, so maybe this routine can be easily
626 ! inlined later or we could pass multiple variables -
627 ! would probably want a largestep and smallstep version.
628
629 ! 15 Jan 99, Dave
630 ! Modified the incoming its,ite,jts,jte to truly be the tile size.
631 ! This required modifying the loop limits when the "istag" or "jstag"
632 ! is used, as this is only required at the end of the domain.
633
634 IMPLICIT NONE
635
636 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
637 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
638 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
639 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
640 CHARACTER, INTENT(IN ) :: variable_in
641
642 CHARACTER :: variable
643
644 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: dat
645 TYPE( grid_config_rec_type ) config_flags
646
647 INTEGER :: i, j, k, istag, jstag, itime, k_end
648
649 LOGICAL :: debug, open_bc_copy
650
651 !------------
652
653 debug = .false.
654
655 open_bc_copy = .false.
656
657 variable = variable_in
658 IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
659 variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
660 ENDIF
661
662 IF ((variable == 'u') .or. (variable == 'v') .or. &
663 (variable == 'w') .or. (variable == 't') .or. &
664 (variable == 'd') .or. (variable == 'e') .or. &
665 (variable == 'x') .or. (variable == 'y') .or. &
666 (variable == 'f') .or. (variable == 'r') .or. &
667 (variable == 'p') ) open_bc_copy = .true.
668
669 ! begin, first set a staggering variable
670
671 istag = -1
672 jstag = -1
673 k_end = max(1,min(kde-1,kte))
674
675
676 IF ((variable == 'u') .or. (variable == 'x')) istag = 0
677 IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
678 IF ((variable == 'd') .or. (variable == 'xy')) then
679 istag = 0
680 jstag = 0
681 ENDIF
682 IF ((variable == 'e') ) then
683 istag = 0
684 k_end = min(kde,kte)
685 ENDIF
686
687 IF ((variable == 'f') ) then
688 jstag = 0
689 k_end = min(kde,kte)
690 ENDIF
691
692 IF ( variable == 'w') k_end = min(kde,kte)
693
694 ! k_end = kte
695
696 if(debug) then
697 write(6,*) ' in bc, var is ',variable, istag, jstag, kte, k_end
698 write(6,*) ' b.cs are ', &
699 config_flags%periodic_x, &
700 config_flags%periodic_y
701 end if
702
703
704
705 ! periodic conditions.
706 ! note, patch must cover full range in periodic dir, or else
707 ! its intra-patch communication that is handled elsewheres.
708 ! symmetry conditions can always be handled here, because no
709 ! outside patch communication is needed
710
711 periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
712
713 IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if both east and west on-processor
714 IF ( its == ids ) THEN
715
716 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
717 DO k = kts, k_end
718 DO i = 0,-(bdyzone-1),-1
719 dat(ids+i-1,k,j) = dat(ide+i-1,k,j)
720 ENDDO
721 ENDDO
722 ENDDO
723
724 ENDIF
725
726
727 IF ( ite == ide ) THEN
728
729 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
730 DO k = kts, k_end
731 DO i = -istag , bdyzone
732 dat(ide+i+istag,k,j) = dat(ids+i+istag,k,j)
733 ENDDO
734 ENDDO
735 ENDDO
736
737 ENDIF
738
739 ENDIF
740
741 ELSE
742
743 symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
744 ( its == ids ) ) THEN
745
746 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
747
748 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
749 DO k = kts, k_end
750 DO i = 1, bdyzone
751 dat(ids-i,k,j) = dat(ids+i-1,k,j) ! here, dat(0) = dat(1), etc
752 ENDDO ! symmetry about dat(0.5) (u = 0 pt)
753 ENDDO
754 ENDDO
755
756 ELSE
757
758 IF ( variable == 'u' ) THEN
759
760 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
761 DO k = kts, k_end
762 DO i = 1, bdyzone
763 dat(ids-i,k,j) = - dat(ids+i,k,j) ! here, u(0) = - u(2), etc
764 ENDDO ! normal b.c symmetry at u(1)
765 ENDDO
766 ENDDO
767
768 ELSE
769
770 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
771 DO k = kts, k_end
772 DO i = 1, bdyzone
773 dat(ids-i,k,j) = dat(ids+i,k,j) ! here, phi(0) = phi(2), etc
774 ENDDO ! normal b.c symmetry at phi(1)
775 ENDDO
776 ENDDO
777
778 END IF
779
780 ENDIF
781
782 ENDIF symmetry_xs
783
784
785 ! now the symmetry boundary at xe
786
787 symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
788 ( ite == ide ) ) THEN
789
790 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
791
792 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
793 DO k = kts, k_end
794 DO i = 1, bdyzone
795 dat(ide+i-1,k,j) = dat(ide-i,k,j) ! sym. about dat(ide-0.5)
796 ENDDO
797 ENDDO
798 ENDDO
799
800 ELSE
801
802 IF (variable == 'u') THEN
803
804 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
805 DO k = kts, k_end
806 DO i = 1, bdyzone
807 dat(ide+i,k,j) = - dat(ide-i,k,j) ! u(ide+1) = - u(ide-1), etc.
808 ENDDO
809 ENDDO
810 ENDDO
811
812 ELSE
813
814 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
815 DO k = kts, k_end
816 DO i = 1, bdyzone
817 dat(ide+i,k,j) = dat(ide-i,k,j) ! phi(ide+1) = - phi(ide-1), etc.
818 ENDDO
819 ENDDO
820 ENDDO
821
822 END IF
823
824 END IF
825
826 END IF symmetry_xe
827
828 ! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
829
830 open_xs: IF( ( config_flags%open_xs .or. &
831 config_flags%specified .or. &
832 config_flags%nested ) .and. &
833 ( its == ids ) .and. open_bc_copy ) THEN
834
835 DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
836 DO k = kts, k_end
837 dat(ids-1,k,j) = dat(ids,k,j) ! here, dat(0) = dat(1), etc
838 dat(ids-2,k,j) = dat(ids,k,j)
839 dat(ids-3,k,j) = dat(ids,k,j)
840 ENDDO
841 ENDDO
842
843 ENDIF open_xs
844
845
846 ! now the open_xe boundary copy
847
848 open_xe: IF( ( config_flags%open_xe .or. &
849 config_flags%specified .or. &
850 config_flags%nested ) .and. &
851 ( ite == ide ) .and. open_bc_copy ) THEN
852
853 IF (variable /= 'u' .and. variable /= 'x' ) THEN
854
855 DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
856 DO k = kts, k_end
857 dat(ide ,k,j) = dat(ide-1,k,j)
858 dat(ide+1,k,j) = dat(ide-1,k,j)
859 dat(ide+2,k,j) = dat(ide-1,k,j)
860 ENDDO
861 ENDDO
862
863 ELSE
864
865 !!!!!!! I am not sure about this one! JM 20020402
866 DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone
867 DO k = kts, k_end
868 dat(ide+1,k,j) = dat(ide,k,j)
869 dat(ide+2,k,j) = dat(ide,k,j)
870 dat(ide+3,k,j) = dat(ide,k,j)
871 ENDDO
872 ENDDO
873
874 END IF
875
876 END IF open_xe
877
878 ! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
879
880 END IF periodicity_x
881
882 ! same procedure in y
883
884 periodicity_y: IF( ( config_flags%periodic_y ) ) THEN
885 IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test if both north and south on processor
886 IF( jts == jds ) then
887
888 DO j = 0, -(bdyzone-1), -1
889 DO k = kts, k_end
890 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
891 dat(i,k,jds+j-1) = dat(i,k,jde+j-1)
892 ENDDO
893 ENDDO
894 ENDDO
895
896 END IF
897
898 IF( jte == jde ) then
899
900 DO j = -jstag, bdyzone
901 DO k = kts, k_end
902 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
903 dat(i,k,jde+j+jstag) = dat(i,k,jds+j+jstag)
904 ENDDO
905 ENDDO
906 ENDDO
907
908 END IF
909
910 END IF
911
912 ELSE
913
914 symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
915 ( jts == jds) ) THEN
916
917 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
918
919 DO j = 1, bdyzone
920 DO k = kts, k_end
921 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
922 dat(i,k,jds-j) = dat(i,k,jds+j-1)
923 ENDDO
924 ENDDO
925 ENDDO
926
927 ELSE
928
929 IF (variable == 'v') THEN
930
931 DO j = 1, bdyzone
932 DO k = kts, k_end
933 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
934 dat(i,k,jds-j) = - dat(i,k,jds+j)
935 ENDDO
936 ENDDO
937 ENDDO
938
939 ELSE
940
941 DO j = 1, bdyzone
942 DO k = kts, k_end
943 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
944 dat(i,k,jds-j) = dat(i,k,jds+j)
945 ENDDO
946 ENDDO
947 ENDDO
948
949 END IF
950
951 ENDIF
952
953 ENDIF symmetry_ys
954
955 ! now the symmetry boundary at ye
956
957 symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
958 ( jte == jde ) ) THEN
959
960 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
961
962 DO j = 1, bdyzone
963 DO k = kts, k_end
964 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
965 dat(i,k,jde+j-1) = dat(i,k,jde-j)
966 ENDDO
967 ENDDO
968 ENDDO
969
970 ELSE
971
972 IF ( variable == 'v' ) THEN
973
974 DO j = 1, bdyzone
975 DO k = kts, k_end
976 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
977 dat(i,k,jde+j) = - dat(i,k,jde-j)
978 ENDDO
979 ENDDO
980 ENDDO
981
982 ELSE
983
984 DO j = 1, bdyzone
985 DO k = kts, k_end
986 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
987 dat(i,k,jde+j) = dat(i,k,jde-j)
988 ENDDO
989 ENDDO
990 ENDDO
991
992 END IF
993
994 ENDIF
995
996 END IF symmetry_ye
997
998 ! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
999
1000 open_ys: IF( ( config_flags%open_ys .or. &
1001 config_flags%polar .or. &
1002 config_flags%specified .or. &
1003 config_flags%nested ) .and. &
1004 ( jts == jds) .and. open_bc_copy ) THEN
1005
1006 DO k = kts, k_end
1007 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1008 dat(i,k,jds-1) = dat(i,k,jds)
1009 dat(i,k,jds-2) = dat(i,k,jds)
1010 dat(i,k,jds-3) = dat(i,k,jds)
1011 ENDDO
1012 ENDDO
1013
1014 ENDIF open_ys
1015
1016 ! now the open boundary copy at ye
1017
1018 open_ye: IF( ( config_flags%open_ye .or. &
1019 config_flags%polar .or. &
1020 config_flags%specified .or. &
1021 config_flags%nested ) .and. &
1022 ( jte == jde ) .and. open_bc_copy ) THEN
1023
1024 IF (variable /= 'v' .and. variable /= 'y' ) THEN
1025
1026 DO k = kts, k_end
1027 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1028 dat(i,k,jde ) = dat(i,k,jde-1)
1029 dat(i,k,jde+1) = dat(i,k,jde-1)
1030 dat(i,k,jde+2) = dat(i,k,jde-1)
1031 ENDDO
1032 ENDDO
1033
1034 ELSE
1035
1036 DO k = kts, k_end
1037 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1038 dat(i,k,jde+1) = dat(i,k,jde)
1039 dat(i,k,jde+2) = dat(i,k,jde)
1040 dat(i,k,jde+3) = dat(i,k,jde)
1041 ENDDO
1042 ENDDO
1043
1044 ENDIF
1045
1046 END IF open_ye
1047
1048 ! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
1049
1050 END IF periodicity_y
1051
1052 ! fix corners for doubly periodic domains
1053
1054 IF ( config_flags%periodic_x .and. config_flags%periodic_y &
1055 .and. (ids == ips) .and. (ide == ipe) &
1056 .and. (jds == jps) .and. (jde == jpe) ) THEN
1057
1058 IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
1059 DO j = 0, -(bdyzone-1), -1
1060 DO k = kts, k_end
1061 DO i = 0, -(bdyzone-1), -1
1062 dat(ids+i-1,k,jds+j-1) = dat(ide+i-1,k,jde+j-1)
1063 ENDDO
1064 ENDDO
1065 ENDDO
1066 END IF
1067
1068 IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
1069 DO j = 0, -(bdyzone-1), -1
1070 DO k = kts, k_end
1071 DO i = 1, bdyzone
1072 dat(ide+i+istag,k,jds+j-1) = dat(ids+i+istag,k,jde+j-1)
1073 ENDDO
1074 ENDDO
1075 ENDDO
1076 END IF
1077
1078 IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
1079 DO j = 1, bdyzone
1080 DO k = kts, k_end
1081 DO i = 1, bdyzone
1082 dat(ide+i+istag,k,jde+j+jstag) = dat(ids+i+istag,k,jds+j+jstag)
1083 ENDDO
1084 ENDDO
1085 ENDDO
1086 END IF
1087
1088 IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
1089 DO j = 1, bdyzone
1090 DO k = kts, k_end
1091 DO i = 0, -(bdyzone-1), -1
1092 dat(ids+i-1,k,jde+j+jstag) = dat(ide+i-1,k,jds+j+jstag)
1093 ENDDO
1094 ENDDO
1095 ENDDO
1096 END IF
1097
1098 END IF
1099
1100 END SUBROUTINE set_physical_bc3d
1101
1102 SUBROUTINE init_module_bc
1103 END SUBROUTINE init_module_bc
1104
1105 !------------------------------------------------------------------------
1106 SUBROUTINE relax_bdytend ( field, field_tend, &
1107 field_bdy_xs, field_bdy_xe, &
1108 field_bdy_ys, field_bdy_ye, &
1109 field_bdy_tend_xs, field_bdy_tend_xe, &
1110 field_bdy_tend_ys, field_bdy_tend_ye, &
1111 variable_in, config_flags, &
1112 spec_bdy_width, spec_zone, relax_zone, &
1113 dtbc, fcx, gcx, &
1114 ids,ide, jds,jde, kds,kde, & ! domain dims
1115 ims,ime, jms,jme, kms,kme, & ! memory dims
1116 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1117 its,ite, jts,jte, kts,kte )
1118
1119 ! This subroutine adds the tendencies in the boundary relaxation region, for specified
1120 ! boundary conditions.
1121 ! spec_bdy_width is only used to dimension the boundary arrays.
1122 ! relax_zone is the inner edge of the boundary relaxation zone treated here.
1123 ! spec_zone is the width of the outer specified b.c.s that are not changed here.
1124 ! (JD July 2000)
1125
1126 IMPLICIT NONE
1127
1128 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1129 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1130 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1131 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1132 INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone
1133 REAL, INTENT(IN ) :: dtbc
1134 CHARACTER, INTENT(IN ) :: variable_in
1135
1136
1137 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field
1138 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend
1139 REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_xs, field_bdy_xe
1140 REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_ys, field_bdy_ye
1141 REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_xs, field_bdy_tend_xe
1142 REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_ys, field_bdy_tend_ye
1143 REAL, DIMENSION( spec_bdy_width ), INTENT(IN ) :: fcx, gcx
1144 TYPE( grid_config_rec_type ) config_flags
1145
1146 CHARACTER :: variable
1147 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1
1148 INTEGER :: b_dist, b_limit
1149 REAL :: fls0, fls1, fls2, fls3, fls4
1150 LOGICAL :: periodic_x
1151
1152 periodic_x = config_flags%periodic_x
1153 variable = variable_in
1154
1155 IF (variable == 'U') variable = 'u'
1156 IF (variable == 'V') variable = 'v'
1157 IF (variable == 'M') variable = 'm'
1158 IF (variable == 'H') variable = 'h'
1159
1160 ibs = ids
1161 ibe = ide-1
1162 itf = min(ite,ide-1)
1163 jbs = jds
1164 jbe = jde-1
1165 jtf = min(jte,jde-1)
1166 ktf = kde-1
1167 IF (variable == 'u') ibe = ide
1168 IF (variable == 'u') itf = min(ite,ide)
1169 IF (variable == 'v') jbe = jde
1170 IF (variable == 'v') jtf = min(jte,jde)
1171 IF (variable == 'm') ktf = kte
1172 IF (variable == 'h') ktf = kte
1173
1174 IF (jts - jbs .lt. relax_zone) THEN
1175 ! Y-start boundary
1176 DO j = max(jts,jbs+spec_zone), min(jtf,jbs+relax_zone-1)
1177 b_dist = j - jbs
1178 b_limit = b_dist
1179 IF(periodic_x)b_limit = 0
1180 DO k = kts, ktf
1181 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1182 im1 = max(i-1,ibs)
1183 ip1 = min(i+1,ibe)
1184 fls0 = field_bdy_ys(i, k, b_dist+1) &
1185 + dtbc * field_bdy_tend_ys(i, k, b_dist+1) &
1186 - field(i,k,j)
1187 fls1 = field_bdy_ys(im1, k, b_dist+1) &
1188 + dtbc * field_bdy_tend_ys(im1, k, b_dist+1) &
1189 - field(im1,k,j)
1190 fls2 = field_bdy_ys(ip1, k, b_dist+1) &
1191 + dtbc * field_bdy_tend_ys(ip1, k, b_dist+1) &
1192 - field(ip1,k,j)
1193 fls3 = field_bdy_ys(i, k, b_dist) &
1194 + dtbc * field_bdy_tend_ys(i, k, b_dist) &
1195 - field(i,k,j-1)
1196 fls4 = field_bdy_ys(i, k, b_dist+2) &
1197 + dtbc * field_bdy_tend_ys(i, k, b_dist+2) &
1198 - field(i,k,j+1)
1199 field_tend(i,k,j) = field_tend(i,k,j) &
1200 + fcx(b_dist+1)*fls0 &
1201 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1202 ENDDO
1203 ENDDO
1204 ENDDO
1205 ENDIF
1206
1207 IF (jbe - jtf .lt. relax_zone) THEN
1208 ! Y-end boundary
1209 DO j = max(jts,jbe-relax_zone+1), min(jtf,jbe-spec_zone)
1210 b_dist = jbe - j
1211 b_limit = b_dist
1212 IF(periodic_x)b_limit = 0
1213 DO k = kts, ktf
1214 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1215 im1 = max(i-1,ibs)
1216 ip1 = min(i+1,ibe)
1217 fls0 = field_bdy_ye(i, k, b_dist+1) &
1218 + dtbc * field_bdy_tend_ye(i, k, b_dist+1) &
1219 - field(i,k,j)
1220 fls1 = field_bdy_ye(im1, k, b_dist+1) &
1221 + dtbc * field_bdy_tend_ye(im1, k, b_dist+1) &
1222 - field(im1,k,j)
1223 fls2 = field_bdy_ye(ip1, k, b_dist+1) &
1224 + dtbc * field_bdy_tend_ye(ip1, k, b_dist+1) &
1225 - field(ip1,k,j)
1226 fls3 = field_bdy_ye(i, k, b_dist) &
1227 + dtbc * field_bdy_tend_ye(i, k, b_dist) &
1228 - field(i,k,j+1)
1229 fls4 = field_bdy_ye(i, k, b_dist+2) &
1230 + dtbc * field_bdy_tend_ye(i, k, b_dist+2) &
1231 - field(i,k,j-1)
1232 field_tend(i,k,j) = field_tend(i,k,j) &
1233 + fcx(b_dist+1)*fls0 &
1234 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1235
1236 ENDDO
1237 ENDDO
1238 ENDDO
1239 ENDIF
1240
1241 IF(.NOT.periodic_x)THEN
1242 IF (its - ibs .lt. relax_zone) THEN
1243 ! X-start boundary
1244 DO i = max(its,ibs+spec_zone), min(itf,ibs+relax_zone-1)
1245 b_dist = i - ibs
1246 DO k = kts, ktf
1247 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1248 fls0 = field_bdy_xs(j, k, b_dist+1) &
1249 + dtbc * field_bdy_tend_xs(j, k, b_dist+1) &
1250 - field(i,k,j)
1251 fls1 = field_bdy_xs(j-1, k, b_dist+1) &
1252 + dtbc * field_bdy_tend_xs(j-1, k, b_dist+1) &
1253 - field(i,k,j-1)
1254 fls2 = field_bdy_xs(j+1, k, b_dist+1) &
1255 + dtbc * field_bdy_tend_xs(j+1, k, b_dist+1) &
1256 - field(i,k,j+1)
1257 fls3 = field_bdy_xs(j, k, b_dist) &
1258 + dtbc * field_bdy_tend_xs(j, k, b_dist) &
1259 - field(i-1,k,j)
1260 fls4 = field_bdy_xs(j, k, b_dist+2) &
1261 + dtbc * field_bdy_tend_xs(j, k, b_dist+2) &
1262 - field(i+1,k,j)
1263 field_tend(i,k,j) = field_tend(i,k,j) &
1264 + fcx(b_dist+1)*fls0 &
1265 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1266
1267 ENDDO
1268 ENDDO
1269 ENDDO
1270 ENDIF
1271
1272 IF (ibe - itf .lt. relax_zone) THEN
1273 ! X-end boundary
1274 DO i = max(its,ibe-relax_zone+1), min(itf,ibe-spec_zone)
1275 b_dist = ibe - i
1276 DO k = kts, ktf
1277 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1278 fls0 = field_bdy_xe(j, k, b_dist+1) &
1279 + dtbc * field_bdy_tend_xe(j, k, b_dist+1) &
1280 - field(i,k,j)
1281 fls1 = field_bdy_xe(j-1, k, b_dist+1) &
1282 + dtbc * field_bdy_tend_xe(j-1, k, b_dist+1) &
1283 - field(i,k,j-1)
1284 fls2 = field_bdy_xe(j+1, k, b_dist+1) &
1285 + dtbc * field_bdy_tend_xe(j+1, k, b_dist+1) &
1286 - field(i,k,j+1)
1287 fls3 = field_bdy_xe(j, k, b_dist) &
1288 + dtbc * field_bdy_tend_xe(j, k, b_dist) &
1289 - field(i+1,k,j)
1290 fls4 = field_bdy_xe(j, k, b_dist+2) &
1291 + dtbc * field_bdy_tend_xe(j, k, b_dist+2) &
1292 - field(i-1,k,j)
1293 field_tend(i,k,j) = field_tend(i,k,j) &
1294 + fcx(b_dist+1)*fls0 &
1295 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1296 ENDDO
1297 ENDDO
1298 ENDDO
1299 ENDIF
1300 ENDIF
1301
1302
1303 END SUBROUTINE relax_bdytend
1304 !------------------------------------------------------------------------
1305
1306 SUBROUTINE spec_bdytend ( field_tend, &
1307 field_bdy_xs, field_bdy_xe, &
1308 field_bdy_ys, field_bdy_ye, &
1309 field_bdy_tend_xs, field_bdy_tend_xe, &
1310 field_bdy_tend_ys, field_bdy_tend_ye, &
1311 variable_in, config_flags, &
1312 spec_bdy_width, spec_zone, &
1313 ids,ide, jds,jde, kds,kde, & ! domain dims
1314 ims,ime, jms,jme, kms,kme, & ! memory dims
1315 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1316 its,ite, jts,jte, kts,kte )
1317
1318 ! This subroutine sets the tendencies in the boundary specified region.
1319 ! spec_bdy_width is only used to dimension the boundary arrays.
1320 ! spec_zone is the width of the outer specified b.c.s that are set here.
1321 ! (JD July 2000)
1322
1323 IMPLICIT NONE
1324
1325 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1326 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1327 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1328 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1329 INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone
1330 CHARACTER, INTENT(IN ) :: variable_in
1331
1332
1333 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT ) :: field_tend
1334 REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_xs, field_bdy_xe
1335 REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_ys, field_bdy_ye
1336 REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_xs, field_bdy_tend_xe
1337 REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_ys, field_bdy_tend_ye
1338 TYPE( grid_config_rec_type ) config_flags
1339
1340 CHARACTER :: variable
1341 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1342 INTEGER :: b_dist, b_limit
1343 LOGICAL :: periodic_x
1344
1345 periodic_x = config_flags%periodic_x
1346
1347 variable = variable_in
1348
1349 IF (variable == 'U') variable = 'u'
1350 IF (variable == 'V') variable = 'v'
1351 IF (variable == 'M') variable = 'm'
1352 IF (variable == 'H') variable = 'h'
1353
1354 ibs = ids
1355 ibe = ide-1
1356 itf = min(ite,ide-1)
1357 jbs = jds
1358 jbe = jde-1
1359 jtf = min(jte,jde-1)
1360 ktf = kde-1
1361 IF (variable == 'u') ibe = ide
1362 IF (variable == 'u') itf = min(ite,ide)
1363 IF (variable == 'v') jbe = jde
1364 IF (variable == 'v') jtf = min(jte,jde)
1365 IF (variable == 'm') ktf = kte
1366 IF (variable == 'h') ktf = kte
1367
1368 IF (jts - jbs .lt. spec_zone) THEN
1369 ! Y-start boundary
1370 DO j = jts, min(jtf,jbs+spec_zone-1)
1371 b_dist = j - jbs
1372 b_limit = b_dist
1373 IF(periodic_x)b_limit = 0
1374 DO k = kts, ktf
1375 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1376 field_tend(i,k,j) = field_bdy_tend_ys(i, k, b_dist+1)
1377 ENDDO
1378 ENDDO
1379 ENDDO
1380 ENDIF
1381 IF (jbe - jtf .lt. spec_zone) THEN
1382 ! Y-end boundary
1383 DO j = max(jts,jbe-spec_zone+1), jtf
1384 b_dist = jbe - j
1385 b_limit = b_dist
1386 IF(periodic_x)b_limit = 0
1387 DO k = kts, ktf
1388 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1389 field_tend(i,k,j) = field_bdy_tend_ye(i, k, b_dist+1)
1390 ENDDO
1391 ENDDO
1392 ENDDO
1393 ENDIF
1394
1395 IF(.NOT.periodic_x)THEN
1396 IF (its - ibs .lt. spec_zone) THEN
1397 ! X-start boundary
1398 DO i = its, min(itf,ibs+spec_zone-1)
1399 b_dist = i - ibs
1400 DO k = kts, ktf
1401 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1402 field_tend(i,k,j) = field_bdy_tend_xs(j, k, b_dist+1)
1403 ENDDO
1404 ENDDO
1405 ENDDO
1406 ENDIF
1407
1408 IF (ibe - itf .lt. spec_zone) THEN
1409 ! X-end boundary
1410 DO i = max(its,ibe-spec_zone+1), itf
1411 b_dist = ibe - i
1412 DO k = kts, ktf
1413 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1414 field_tend(i,k,j) = field_bdy_tend_xe(j, k, b_dist+1)
1415 ENDDO
1416 ENDDO
1417 ENDDO
1418 ENDIF
1419 ENDIF
1420
1421 END SUBROUTINE spec_bdytend
1422 !------------------------------------------------------------------------
1423
1424 SUBROUTINE spec_bdyupdate( field, &
1425 field_tend, dt, &
1426 variable_in, config_flags, &
1427 spec_zone, &
1428 ids,ide, jds,jde, kds,kde, & ! domain dims
1429 ims,ime, jms,jme, kms,kme, & ! memory dims
1430 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1431 its,ite, jts,jte, kts,kte )
1432
1433 ! This subroutine adds the tendencies in the boundary specified region.
1434 ! spec_zone is the width of the outer specified b.c.s that are set here.
1435 ! (JD August 2000)
1436
1437 IMPLICIT NONE
1438
1439 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1440 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1441 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1442 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1443 INTEGER, INTENT(IN ) :: spec_zone
1444 CHARACTER, INTENT(IN ) :: variable_in
1445 REAL, INTENT(IN ) :: dt
1446
1447
1448 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1449 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend
1450 TYPE( grid_config_rec_type ) config_flags
1451
1452 CHARACTER :: variable
1453 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1454 INTEGER :: b_dist, b_limit
1455 LOGICAL :: periodic_x
1456
1457 periodic_x = config_flags%periodic_x
1458
1459 variable = variable_in
1460
1461 IF (variable == 'U') variable = 'u'
1462 IF (variable == 'V') variable = 'v'
1463 IF (variable == 'M') variable = 'm'
1464 IF (variable == 'H') variable = 'h'
1465
1466 ibs = ids
1467 ibe = ide-1
1468 itf = min(ite,ide-1)
1469 jbs = jds
1470 jbe = jde-1
1471 jtf = min(jte,jde-1)
1472 ktf = kde-1
1473 IF (variable == 'u') ibe = ide
1474 IF (variable == 'u') itf = min(ite,ide)
1475 IF (variable == 'v') jbe = jde
1476 IF (variable == 'v') jtf = min(jte,jde)
1477 IF (variable == 'm') ktf = kte
1478 IF (variable == 'h') ktf = kte
1479
1480 IF (jts - jbs .lt. spec_zone) THEN
1481 ! Y-start boundary
1482 DO j = jts, min(jtf,jbs+spec_zone-1)
1483 b_dist = j - jbs
1484 b_limit = b_dist
1485 IF(periodic_x)b_limit = 0
1486 DO k = kts, ktf
1487 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1488 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1489 ENDDO
1490 ENDDO
1491 ENDDO
1492 ENDIF
1493 IF (jbe - jtf .lt. spec_zone) THEN
1494 ! Y-end boundary
1495 DO j = max(jts,jbe-spec_zone+1), jtf
1496 b_dist = jbe - j
1497 b_limit = b_dist
1498 IF(periodic_x)b_limit = 0
1499 DO k = kts, ktf
1500 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1501 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1502 ENDDO
1503 ENDDO
1504 ENDDO
1505 ENDIF
1506
1507 IF(.NOT.periodic_x)THEN
1508 IF (its - ibs .lt. spec_zone) THEN
1509 ! X-start boundary
1510 DO i = its, min(itf,ibs+spec_zone-1)
1511 b_dist = i - ibs
1512 DO k = kts, ktf
1513 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1514 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1515 ENDDO
1516 ENDDO
1517 ENDDO
1518 ENDIF
1519
1520 IF (ibe - itf .lt. spec_zone) THEN
1521 ! X-end boundary
1522 DO i = max(its,ibe-spec_zone+1), itf
1523 b_dist = ibe - i
1524 DO k = kts, ktf
1525 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1526 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1527 ENDDO
1528 ENDDO
1529 ENDDO
1530 ENDIF
1531 ENDIF
1532
1533 END SUBROUTINE spec_bdyupdate
1534 !------------------------------------------------------------------------
1535
1536 SUBROUTINE zero_grad_bdy ( field, &
1537 variable_in, config_flags, &
1538 spec_zone, &
1539 ids,ide, jds,jde, kds,kde, & ! domain dims
1540 ims,ime, jms,jme, kms,kme, & ! memory dims
1541 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1542 its,ite, jts,jte, kts,kte )
1543
1544 ! This subroutine sets zero gradient conditions in the boundary specified region.
1545 ! spec_zone is the width of the outer specified b.c.s that are set here.
1546 ! (JD August 2000)
1547
1548 IMPLICIT NONE
1549
1550 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1551 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1552 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1553 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1554 INTEGER, INTENT(IN ) :: spec_zone
1555 CHARACTER, INTENT(IN ) :: variable_in
1556
1557
1558 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1559 TYPE( grid_config_rec_type ) config_flags
1560
1561 CHARACTER :: variable
1562 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1563 INTEGER :: b_dist, b_limit
1564 LOGICAL :: periodic_x
1565
1566 periodic_x = config_flags%periodic_x
1567
1568 variable = variable_in
1569
1570 IF (variable == 'U') variable = 'u'
1571 IF (variable == 'V') variable = 'v'
1572
1573 ibs = ids
1574 ibe = ide-1
1575 itf = min(ite,ide-1)
1576 jbs = jds
1577 jbe = jde-1
1578 jtf = min(jte,jde-1)
1579 ktf = kde-1
1580 IF (variable == 'u') ibe = ide
1581 IF (variable == 'u') itf = min(ite,ide)
1582 IF (variable == 'v') jbe = jde
1583 IF (variable == 'v') jtf = min(jte,jde)
1584 IF (variable == 'w') ktf = kde
1585
1586 IF (jts - jbs .lt. spec_zone) THEN
1587 ! Y-start boundary
1588 DO j = jts, min(jtf,jbs+spec_zone-1)
1589 b_dist = j - jbs
1590 b_limit = b_dist
1591 IF(periodic_x)b_limit = 0
1592 DO k = kts, ktf
1593 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1594 i_inner = max(i,ibs+spec_zone)
1595 i_inner = min(i_inner,ibe-spec_zone)
1596 IF(periodic_x)i_inner = i
1597 field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1598 ENDDO
1599 ENDDO
1600 ENDDO
1601 ENDIF
1602 IF (jbe - jtf .lt. spec_zone) THEN
1603 ! Y-end boundary
1604 DO j = max(jts,jbe-spec_zone+1), jtf
1605 b_dist = jbe - j
1606 b_limit = b_dist
1607 IF(periodic_x)b_limit = 0
1608 DO k = kts, ktf
1609 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1610 i_inner = max(i,ibs+spec_zone)
1611 i_inner = min(i_inner,ibe-spec_zone)
1612 IF(periodic_x)i_inner = i
1613 field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1614 ENDDO
1615 ENDDO
1616 ENDDO
1617 ENDIF
1618
1619 IF(.NOT.periodic_x)THEN
1620 IF (its - ibs .lt. spec_zone) THEN
1621 ! X-start boundary
1622 DO i = its, min(itf,ibs+spec_zone-1)
1623 b_dist = i - ibs
1624 DO k = kts, ktf
1625 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1626 j_inner = max(j,jbs+spec_zone)
1627 j_inner = min(j_inner,jbe-spec_zone)
1628 field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1629 ENDDO
1630 ENDDO
1631 ENDDO
1632 ENDIF
1633
1634 IF (ibe - itf .lt. spec_zone) THEN
1635 ! X-end boundary
1636 DO i = max(its,ibe-spec_zone+1), itf
1637 b_dist = ibe - i
1638 DO k = kts, ktf
1639 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1640 j_inner = max(j,jbs+spec_zone)
1641 j_inner = min(j_inner,jbe-spec_zone)
1642 field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1643 ENDDO
1644 ENDDO
1645 ENDDO
1646 ENDIF
1647 ENDIF
1648
1649 END SUBROUTINE zero_grad_bdy
1650 !------------------------------------------------------------------------
1651
1652 SUBROUTINE flow_dep_bdy ( field, &
1653 u, v, config_flags, &
1654 spec_zone, &
1655 ids,ide, jds,jde, kds,kde, & ! domain dims
1656 ims,ime, jms,jme, kms,kme, & ! memory dims
1657 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1658 its,ite, jts,jte, kts,kte )
1659
1660 ! This subroutine sets zero gradient conditions for outflow and zero value
1661 ! for inflow in the boundary specified region. Note that field must be unstaggered.
1662 ! The velocities, u and v, will only be used to check their sign (coupled vels OK)
1663 ! spec_zone is the width of the outer specified b.c.s that are set here.
1664 ! (JD August 2000)
1665
1666 IMPLICIT NONE
1667
1668 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1669 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1670 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1671 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1672 INTEGER, INTENT(IN ) :: spec_zone
1673
1674
1675 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1676 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u
1677 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v
1678 TYPE( grid_config_rec_type ) config_flags
1679
1680 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1681 INTEGER :: b_dist, b_limit
1682 LOGICAL :: periodic_x
1683
1684 periodic_x = config_flags%periodic_x
1685
1686 ibs = ids
1687 ibe = ide-1
1688 itf = min(ite,ide-1)
1689 jbs = jds
1690 jbe = jde-1
1691 jtf = min(jte,jde-1)
1692 ktf = kde-1
1693
1694 IF (jts - jbs .lt. spec_zone) THEN
1695 ! Y-start boundary
1696 DO j = jts, min(jtf,jbs+spec_zone-1)
1697 b_dist = j - jbs
1698 b_limit = b_dist
1699 IF(periodic_x)b_limit = 0
1700 DO k = kts, ktf
1701 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1702 i_inner = max(i,ibs+spec_zone)
1703 i_inner = min(i_inner,ibe-spec_zone)
1704 IF(periodic_x)i_inner = i
1705 IF(v(i,k,j) .lt. 0.)THEN
1706 field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1707 ELSE
1708 field(i,k,j) = 0.
1709 ENDIF
1710 ENDDO
1711 ENDDO
1712 ENDDO
1713 ENDIF
1714 IF (jbe - jtf .lt. spec_zone) THEN
1715 ! Y-end boundary
1716 DO j = max(jts,jbe-spec_zone+1), jtf
1717 b_dist = jbe - j
1718 b_limit = b_dist
1719 IF(periodic_x)b_limit = 0
1720 DO k = kts, ktf
1721 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1722 i_inner = max(i,ibs+spec_zone)
1723 i_inner = min(i_inner,ibe-spec_zone)
1724 IF(periodic_x)i_inner = i
1725 IF(v(i,k,j+1) .gt. 0.)THEN
1726 field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1727 ELSE
1728 field(i,k,j) = 0.
1729 ENDIF
1730 ENDDO
1731 ENDDO
1732 ENDDO
1733 ENDIF
1734
1735 IF(.NOT.periodic_x)THEN
1736 IF (its - ibs .lt. spec_zone) THEN
1737 ! X-start boundary
1738 DO i = its, min(itf,ibs+spec_zone-1)
1739 b_dist = i - ibs
1740 DO k = kts, ktf
1741 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1742 j_inner = max(j,jbs+spec_zone)
1743 j_inner = min(j_inner,jbe-spec_zone)
1744 IF(u(i,k,j) .lt. 0.)THEN
1745 field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1746 ELSE
1747 field(i,k,j) = 0.
1748 ENDIF
1749 ENDDO
1750 ENDDO
1751 ENDDO
1752 ENDIF
1753
1754 IF (ibe - itf .lt. spec_zone) THEN
1755 ! X-end boundary
1756 DO i = max(its,ibe-spec_zone+1), itf
1757 b_dist = ibe - i
1758 DO k = kts, ktf
1759 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1760 j_inner = max(j,jbs+spec_zone)
1761 j_inner = min(j_inner,jbe-spec_zone)
1762 IF(u(i+1,k,j) .gt. 0.)THEN
1763 field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1764 ELSE
1765 field(i,k,j) = 0.
1766 ENDIF
1767 ENDDO
1768 ENDDO
1769 ENDDO
1770 ENDIF
1771 ENDIF
1772
1773 END SUBROUTINE flow_dep_bdy
1774
1775 !------------------------------------------------------------------------------
1776
1777 SUBROUTINE stuff_bdy_new ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
1778 char_stagger , &
1779 spec_bdy_width , &
1780 ids, ide, jds, jde, kds, kde , &
1781 ims, ime, jms, jme, kms, kme , &
1782 its, ite, jts, jte, kts, kte )
1783
1784 ! This routine puts the data in the 3d arrays into the proper locations
1785 ! for the lateral boundary arrays.
1786
1787 USE module_state_description
1788
1789 IMPLICIT NONE
1790
1791 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1792 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1793 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1794 INTEGER , INTENT(IN) :: spec_bdy_width
1795 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
1796 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
1797 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
1798 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1799
1800 INTEGER :: i , ii , j , jj , k
1801
1802 ! There are four lateral boundary locations that are stored.
1803
1804 ! X start boundary
1805
1806 IF ( char_stagger .EQ. 'W' ) THEN
1807 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1808 DO k = kds , kde
1809 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1810 space_bdy_xs(j,k,i) = data3d(i,k,j)
1811 END DO
1812 END DO
1813 END DO
1814 ELSE IF ( char_stagger .EQ. 'M' ) THEN
1815 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1816 DO k = kds , kde
1817 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1818 space_bdy_xs(j,k,i) = data3d(i,k,j)
1819 END DO
1820 END DO
1821 END DO
1822 ELSE IF ( char_stagger .EQ. 'V' ) THEN
1823 DO j = MAX(jds,jts) , MIN(jde,jte)
1824 DO k = kds , kde - 1
1825 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1826 space_bdy_xs(j,k,i) = data3d(i,k,j)
1827 END DO
1828 END DO
1829 END DO
1830 ELSE
1831 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1832 DO k = kds , kde - 1
1833 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1834 space_bdy_xs(j,k,i) = data3d(i,k,j)
1835 END DO
1836 END DO
1837 END DO
1838 END IF
1839
1840 ! X end boundary
1841
1842 IF ( char_stagger .EQ. 'U' ) THEN
1843 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1844 DO k = kds , kde - 1
1845 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1846 ii = ide - i + 1
1847 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1848 END DO
1849 END DO
1850 END DO
1851 ELSE IF ( char_stagger .EQ. 'V' ) THEN
1852 DO j = MAX(jds,jts) , MIN(jde,jte)
1853 DO k = kds , kde - 1
1854 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1855 ii = ide - i
1856 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1857 END DO
1858 END DO
1859 END DO
1860 ELSE IF ( char_stagger .EQ. 'W' ) THEN
1861 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1862 DO k = kds , kde
1863 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1864 ii = ide - i
1865 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1866 END DO
1867 END DO
1868 END DO
1869 ELSE IF ( char_stagger .EQ. 'M' ) THEN
1870 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1871 DO k = kds , kde
1872 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1873 ii = ide - i
1874 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1875 END DO
1876 END DO
1877 END DO
1878 ELSE
1879 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1880 DO k = kds , kde - 1
1881 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1882 ii = ide - i
1883 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1884 END DO
1885 END DO
1886 END DO
1887 END IF
1888
1889 ! Y start boundary
1890
1891 IF ( char_stagger .EQ. 'W' ) THEN
1892 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1893 DO k = kds , kde
1894 DO i = MAX(ids,its) , MIN(ide-1,ite)
1895 space_bdy_ys(i,k,j) = data3d(i,k,j)
1896 END DO
1897 END DO
1898 END DO
1899 ELSE IF ( char_stagger .EQ. 'M' ) THEN
1900 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1901 DO k = kds , kde
1902 DO i = MAX(ids,its) , MIN(ide-1,ite)
1903 space_bdy_ys(i,k,j) = data3d(i,k,j)
1904 END DO
1905 END DO
1906 END DO
1907 ELSE IF ( char_stagger .EQ. 'U' ) THEN
1908 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1909 DO k = kds , kde - 1
1910 DO i = MAX(ids,its) , MIN(ide,ite)
1911 space_bdy_ys(i,k,j) = data3d(i,k,j)
1912 END DO
1913 END DO
1914 END DO
1915 ELSE
1916 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1917 DO k = kds , kde - 1
1918 DO i = MAX(ids,its) , MIN(ide-1,ite)
1919 space_bdy_ys(i,k,j) = data3d(i,k,j)
1920 END DO
1921 END DO
1922 END DO
1923 END IF
1924
1925 ! Y end boundary
1926
1927 IF ( char_stagger .EQ. 'V' ) THEN
1928 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
1929 DO k = kds , kde - 1
1930 DO i = MAX(ids,its) , MIN(ide-1,ite)
1931 jj = jde - j + 1
1932 space_bdy_ye(i,k,jj) = data3d(i,k,j)
1933 END DO
1934 END DO
1935 END DO
1936 ELSE IF ( char_stagger .EQ. 'U' ) THEN
1937 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1938 DO k = kds , kde - 1
1939 DO i = MAX(ids,its) , MIN(ide,ite)
1940 jj = jde - j
1941 space_bdy_ye(i,k,jj) = data3d(i,k,j)
1942 END DO
1943 END DO
1944 END DO
1945 ELSE IF ( char_stagger .EQ. 'W' ) THEN
1946 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1947 DO k = kds , kde
1948 DO i = MAX(ids,its) , MIN(ide-1,ite)
1949 jj = jde - j
1950 space_bdy_ye(i,k,jj) = data3d(i,k,j)
1951 END DO
1952 END DO
1953 END DO
1954 ELSE IF ( char_stagger .EQ. 'M' ) THEN
1955 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1956 DO k = kds , kde
1957 DO i = MAX(ids,its) , MIN(ide-1,ite)
1958 jj = jde - j
1959 space_bdy_ye(i,k,jj) = data3d(i,k,j)
1960 END DO
1961 END DO
1962 END DO
1963 ELSE
1964 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1965 DO k = kds , kde - 1
1966 DO i = MAX(ids,its) , MIN(ide-1,ite)
1967 jj = jde - j
1968 space_bdy_ye(i,k,jj) = data3d(i,k,j)
1969 END DO
1970 END DO
1971 END DO
1972 END IF
1973
1974 END SUBROUTINE stuff_bdy_new
1975
1976 SUBROUTINE stuff_bdytend_new ( data3dnew , data3dold , time_diff , &
1977 space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
1978 char_stagger , &
1979 spec_bdy_width , &
1980 ids, ide, jds, jde, kds, kde , &
1981 ims, ime, jms, jme, kms, kme , &
1982 its, ite, jts, jte, kts, kte )
1983
1984 ! This routine puts the tendency data into the proper locations
1985 ! for the lateral boundary arrays.
1986
1987 USE module_state_description
1988
1989 IMPLICIT NONE
1990
1991 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1992 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1993 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1994 INTEGER , INTENT(IN) :: spec_bdy_width
1995 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
1996 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
1997 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
1998 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1999 REAL , INTENT(IN) :: time_diff ! seconds
2000
2001 INTEGER :: i , ii , j , jj , k
2002
2003 ! There are four lateral boundary locations that are stored.
2004
2005 ! X start boundary
2006
2007 IF ( char_stagger .EQ. 'W' ) THEN
2008 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2009 DO k = kds , kde
2010 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2011 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2012 END DO
2013 END DO
2014 END DO
2015 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2016 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2017 DO k = kds , kde
2018 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2019 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2020 END DO
2021 END DO
2022 END DO
2023 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2024 DO j = MAX(jds,jts) , MIN(jde,jte)
2025 DO k = kds , kde - 1
2026 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2027 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2028 END DO
2029 END DO
2030 END DO
2031 ELSE
2032 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2033 DO k = kds , kde - 1
2034 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2035 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2036 END DO
2037 END DO
2038 END DO
2039 END IF
2040
2041 ! X end boundary
2042
2043 IF ( char_stagger .EQ. 'U' ) THEN
2044 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2045 DO k = kds , kde - 1
2046 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2047 ii = ide - i + 1
2048 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2049 END DO
2050 END DO
2051 END DO
2052 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2053 DO j = MAX(jds,jts) , MIN(jde,jte)
2054 DO k = kds , kde - 1
2055 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2056 ii = ide - i
2057 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2058 END DO
2059 END DO
2060 END DO
2061 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2062 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2063 DO k = kds , kde
2064 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2065 ii = ide - i
2066 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2067 END DO
2068 END DO
2069 END DO
2070 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2071 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2072 DO k = kds , kde
2073 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2074 ii = ide - i
2075 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2076 END DO
2077 END DO
2078 END DO
2079 ELSE
2080 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2081 DO k = kds , kde - 1
2082 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2083 ii = ide - i
2084 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2085 END DO
2086 END DO
2087 END DO
2088 END IF
2089
2090 ! Y start boundary
2091
2092 IF ( char_stagger .EQ. 'W' ) THEN
2093 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2094 DO k = kds , kde
2095 DO i = MAX(ids,its) , MIN(ide-1,ite)
2096 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2097 END DO
2098 END DO
2099 END DO
2100 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2101 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2102 DO k = kds , kde
2103 DO i = MAX(ids,its) , MIN(ide-1,ite)
2104 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2105 END DO
2106 END DO
2107 END DO
2108 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2109 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2110 DO k = kds , kde - 1
2111 DO i = MAX(ids,its) , MIN(ide,ite)
2112 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2113 END DO
2114 END DO
2115 END DO
2116 ELSE
2117 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2118 DO k = kds , kde - 1
2119 DO i = MAX(ids,its) , MIN(ide-1,ite)
2120 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2121 END DO
2122 END DO
2123 END DO
2124 END IF
2125
2126 ! Y end boundary
2127
2128 IF ( char_stagger .EQ. 'V' ) THEN
2129 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2130 DO k = kds , kde - 1
2131 DO i = MAX(ids,its) , MIN(ide-1,ite)
2132 jj = jde - j + 1
2133 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2134 END DO
2135 END DO
2136 END DO
2137 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2138 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2139 DO k = kds , kde - 1
2140 DO i = MAX(ids,its) , MIN(ide,ite)
2141 jj = jde - j
2142 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2143 END DO
2144 END DO
2145 END DO
2146 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2147 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2148 DO k = kds , kde
2149 DO i = MAX(ids,its) , MIN(ide-1,ite)
2150 jj = jde - j
2151 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2152 END DO
2153 END DO
2154 END DO
2155 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2156 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2157 DO k = kds , kde
2158 DO i = MAX(ids,its) , MIN(ide-1,ite)
2159 jj = jde - j
2160 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2161 END DO
2162 END DO
2163 END DO
2164 ELSE
2165 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2166 DO k = kds , kde - 1
2167 DO i = MAX(ids,its) , MIN(ide-1,ite)
2168 jj = jde - j
2169 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2170 END DO
2171 END DO
2172 END DO
2173 END IF
2174
2175 END SUBROUTINE stuff_bdytend_new
2176
2177 !--- old versions for use with modules that use the old bdy data structures ---
2178
2179 SUBROUTINE stuff_bdy_old ( data3d , space_bdy , char_stagger , &
2180 ijds , ijde , spec_bdy_width , &
2181 ids, ide, jds, jde, kds, kde , &
2182 ims, ime, jms, jme, kms, kme , &
2183 its, ite, jts, jte, kts, kte )
2184
2185 ! This routine puts the data in the 3d arrays into the proper locations
2186 ! for the lateral boundary arrays.
2187
2188 USE module_state_description
2189
2190 IMPLICIT NONE
2191
2192 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2193 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2194 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2195 INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
2196 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
2197 REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy
2198 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2199
2200 INTEGER :: i , ii , j , jj , k
2201
2202 ! There are four lateral boundary locations that are stored.
2203
2204 ! X start boundary
2205
2206 IF ( char_stagger .EQ. 'W' ) THEN
2207 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2208 DO k = kds , kde
2209 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2210 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2211 END DO
2212 END DO
2213 END DO
2214 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2215 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2216 DO k = kds , kde
2217 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2218 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2219 END DO
2220 END DO
2221 END DO
2222 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2223 DO j = MAX(jds,jts) , MIN(jde,jte)
2224 DO k = kds , kde - 1
2225 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2226 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2227 END DO
2228 END DO
2229 END DO
2230 ELSE
2231 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2232 DO k = kds , kde - 1
2233 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2234 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2235 END DO
2236 END DO
2237 END DO
2238 END IF
2239
2240 ! X end boundary
2241
2242 IF ( char_stagger .EQ. 'U' ) THEN
2243 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2244 DO k = kds , kde - 1
2245 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2246 ii = ide - i + 1
2247 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2248 END DO
2249 END DO
2250 END DO
2251 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2252 DO j = MAX(jds,jts) , MIN(jde,jte)
2253 DO k = kds , kde - 1
2254 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2255 ii = ide - i
2256 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2257 END DO
2258 END DO
2259 END DO
2260 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2261 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2262 DO k = kds , kde
2263 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2264 ii = ide - i
2265 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2266 END DO
2267 END DO
2268 END DO
2269 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2270 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2271 DO k = kds , kde
2272 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2273 ii = ide - i
2274 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2275 END DO
2276 END DO
2277 END DO
2278 ELSE
2279 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2280 DO k = kds , kde - 1
2281 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2282 ii = ide - i
2283 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2284 END DO
2285 END DO
2286 END DO
2287 END IF
2288
2289 ! Y start boundary
2290
2291 IF ( char_stagger .EQ. 'W' ) THEN
2292 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2293 DO k = kds , kde
2294 DO i = MAX(ids,its) , MIN(ide-1,ite)
2295 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2296 END DO
2297 END DO
2298 END DO
2299 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2300 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2301 DO k = kds , kde
2302 DO i = MAX(ids,its) , MIN(ide-1,ite)
2303 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2304 END DO
2305 END DO
2306 END DO
2307 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2308 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2309 DO k = kds , kde - 1
2310 DO i = MAX(ids,its) , MIN(ide,ite)
2311 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2312 END DO
2313 END DO
2314 END DO
2315 ELSE
2316 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2317 DO k = kds , kde - 1
2318 DO i = MAX(ids,its) , MIN(ide-1,ite)
2319 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2320 END DO
2321 END DO
2322 END DO
2323 END IF
2324
2325 ! Y end boundary
2326
2327 IF ( char_stagger .EQ. 'V' ) THEN
2328 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2329 DO k = kds , kde - 1
2330 DO i = MAX(ids,its) , MIN(ide-1,ite)
2331 jj = jde - j + 1
2332 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2333 END DO
2334 END DO
2335 END DO
2336 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2337 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2338 DO k = kds , kde - 1
2339 DO i = MAX(ids,its) , MIN(ide,ite)
2340 jj = jde - j
2341 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2342 END DO
2343 END DO
2344 END DO
2345 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2346 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2347 DO k = kds , kde
2348 DO i = MAX(ids,its) , MIN(ide-1,ite)
2349 jj = jde - j
2350 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2351 END DO
2352 END DO
2353 END DO
2354 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2355 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2356 DO k = kds , kde
2357 DO i = MAX(ids,its) , MIN(ide-1,ite)
2358 jj = jde - j
2359 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2360 END DO
2361 END DO
2362 END DO
2363 ELSE
2364 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2365 DO k = kds , kde - 1
2366 DO i = MAX(ids,its) , MIN(ide-1,ite)
2367 jj = jde - j
2368 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2369 END DO
2370 END DO
2371 END DO
2372 END IF
2373
2374 END SUBROUTINE stuff_bdy_old
2375
2376 SUBROUTINE stuff_bdytend_old ( data3dnew , data3dold , time_diff , space_bdy , char_stagger , &
2377 ijds , ijde , spec_bdy_width , &
2378 ids, ide, jds, jde, kds, kde , &
2379 ims, ime, jms, jme, kms, kme , &
2380 its, ite, jts, jte, kts, kte )
2381
2382 ! This routine puts the tendency data into the proper locations
2383 ! for the lateral boundary arrays.
2384
2385 USE module_state_description
2386
2387 IMPLICIT NONE
2388
2389 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2390 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2391 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2392 INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
2393 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2394 ! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
2395 REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy
2396 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2397 REAL , INTENT(IN) :: time_diff ! seconds
2398
2399 INTEGER :: i , ii , j , jj , k
2400
2401 ! There are four lateral boundary locations that are stored.
2402
2403 ! X start boundary
2404
2405 IF ( char_stagger .EQ. 'W' ) THEN
2406 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2407 DO k = kds , kde
2408 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2409 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2410 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2411 END DO
2412 END DO
2413 END DO
2414 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2415 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2416 DO k = kds , kde
2417 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2418 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2419 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2420 END DO
2421 END DO
2422 END DO
2423 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2424 DO j = MAX(jds,jts) , MIN(jde,jte)
2425 DO k = kds , kde - 1
2426 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2427 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2428 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2429 END DO
2430 END DO
2431 END DO
2432 ELSE
2433 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2434 DO k = kds , kde - 1
2435 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2436 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2437 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2438 END DO
2439 END DO
2440 END DO
2441 END IF
2442
2443 ! X end boundary
2444
2445 IF ( char_stagger .EQ. 'U' ) THEN
2446 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2447 DO k = kds , kde - 1
2448 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2449 ii = ide - i + 1
2450 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2451 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2452 END DO
2453 END DO
2454 END DO
2455 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2456 DO j = MAX(jds,jts) , MIN(jde,jte)
2457 DO k = kds , kde - 1
2458 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2459 ii = ide - i
2460 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2461 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2462 END DO
2463 END DO
2464 END DO
2465 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2466 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2467 DO k = kds , kde
2468 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2469 ii = ide - i
2470 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2471 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2472 END DO
2473 END DO
2474 END DO
2475 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2476 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2477 DO k = kds , kde
2478 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2479 ii = ide - i
2480 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2481 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2482 END DO
2483 END DO
2484 END DO
2485 ELSE
2486 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2487 DO k = kds , kde - 1
2488 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2489 ii = ide - i
2490 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2491 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2492 END DO
2493 END DO
2494 END DO
2495 END IF
2496
2497 ! Y start boundary
2498
2499 IF ( char_stagger .EQ. 'W' ) THEN
2500 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2501 DO k = kds , kde
2502 DO i = MAX(ids,its) , MIN(ide-1,ite)
2503 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2504 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2505 END DO
2506 END DO
2507 END DO
2508 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2509 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2510 DO k = kds , kde
2511 DO i = MAX(ids,its) , MIN(ide-1,ite)
2512 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2513 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2514 END DO
2515 END DO
2516 END DO
2517 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2518 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2519 DO k = kds , kde - 1
2520 DO i = MAX(ids,its) , MIN(ide,ite)
2521 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2522 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2523 END DO
2524 END DO
2525 END DO
2526 ELSE
2527 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2528 DO k = kds , kde - 1
2529 DO i = MAX(ids,its) , MIN(ide-1,ite)
2530 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2531 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2532 END DO
2533 END DO
2534 END DO
2535 END IF
2536
2537 ! Y end boundary
2538
2539 IF ( char_stagger .EQ. 'V' ) THEN
2540 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2541 DO k = kds , kde - 1
2542 DO i = MAX(ids,its) , MIN(ide-1,ite)
2543 jj = jde - j + 1
2544 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2545 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2546 END DO
2547 END DO
2548 END DO
2549 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2550 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2551 DO k = kds , kde - 1
2552 DO i = MAX(ids,its) , MIN(ide,ite)
2553 jj = jde - j
2554 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2555 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2556 END DO
2557 END DO
2558 END DO
2559 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2560 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2561 DO k = kds , kde
2562 DO i = MAX(ids,its) , MIN(ide-1,ite)
2563 jj = jde - j
2564 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2565 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2566 END DO
2567 END DO
2568 END DO
2569 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2570 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2571 DO k = kds , kde
2572 DO i = MAX(ids,its) , MIN(ide-1,ite)
2573 jj = jde - j
2574 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2575 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2576 END DO
2577 END DO
2578 END DO
2579 ELSE
2580 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2581 DO k = kds , kde - 1
2582 DO i = MAX(ids,its) , MIN(ide-1,ite)
2583 jj = jde - j
2584 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2585 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2586 END DO
2587 END DO
2588 END DO
2589 END IF
2590
2591 END SUBROUTINE stuff_bdytend_old
2592
2593 SUBROUTINE stuff_bdy_ijk ( data3d , space_bdy_xs, space_bdy_xe, &
2594 space_bdy_ys, space_bdy_ye, &
2595 char_stagger , spec_bdy_width, &
2596 ids, ide, jds, jde, kds, kde , &
2597 ims, ime, jms, jme, kms, kme , &
2598 its, ite, jts, jte, kts, kte )
2599
2600 ! This routine puts the data in the 3d arrays into the proper locations
2601 ! for the lateral boundary arrays.
2602
2603 USE module_state_description
2604
2605 IMPLICIT NONE
2606
2607 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2608 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2609 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2610 INTEGER , INTENT(IN) :: spec_bdy_width
2611 REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: data3d
2612 ! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
2613 ! REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4,1) , INTENT(OUT) :: space_bdy
2614 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2615 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2616 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2617
2618 INTEGER :: i , ii , j , jj , k
2619
2620 ! There are four lateral boundary locations that are stored.
2621
2622 ! X start boundary
2623
2624 IF ( char_stagger .EQ. 'W' ) THEN
2625 DO k = kds , kde
2626 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2627 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2628 space_bdy_xs(j,k,i) = data3d(i,j,k)
2629 END DO
2630 END DO
2631 END DO
2632 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2633 DO k = kds , kde
2634 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2635 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2636 space_bdy_xs(j,k,i) = data3d(i,j,k)
2637 END DO
2638 END DO
2639 END DO
2640 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2641 DO k = kds , kde - 1
2642 DO j = MAX(jds,jts) , MIN(jde,jte)
2643 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2644 space_bdy_xs(j,k,i) = data3d(i,j,k)
2645 END DO
2646 END DO
2647 END DO
2648 ELSE
2649 DO k = kds , kde - 1
2650 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2651 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2652 space_bdy_xs(j,k,i) = data3d(i,j,k)
2653 END DO
2654 END DO
2655 END DO
2656 END IF
2657
2658 ! X end boundary
2659
2660 IF ( char_stagger .EQ. 'U' ) THEN
2661 DO k = kds , kde - 1
2662 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2663 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2664 ii = ide - i + 1
2665 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2666 END DO
2667 END DO
2668 END DO
2669 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2670 DO k = kds , kde - 1
2671 DO j = MAX(jds,jts) , MIN(jde,jte)
2672 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2673 ii = ide - i
2674 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2675 END DO
2676 END DO
2677 END DO
2678 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2679 DO k = kds , kde
2680 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2681 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2682 ii = ide - i
2683 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2684 END DO
2685 END DO
2686 END DO
2687 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2688 DO k = kds , kde
2689 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2690 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2691 ii = ide - i
2692 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2693 END DO
2694 END DO
2695 END DO
2696 ELSE
2697 DO k = kds , kde - 1
2698 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2699 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2700 ii = ide - i
2701 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2702 END DO
2703 END DO
2704 END DO
2705 END IF
2706
2707 ! Y start boundary
2708
2709 IF ( char_stagger .EQ. 'W' ) THEN
2710 DO k = kds , kde
2711 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2712 DO i = MAX(ids,its) , MIN(ide-1,ite)
2713 space_bdy_ys(i,k,j) = data3d(i,j,k)
2714 END DO
2715 END DO
2716 END DO
2717 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2718 DO k = kds , kde
2719 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2720 DO i = MAX(ids,its) , MIN(ide-1,ite)
2721 space_bdy_ys(i,k,j) = data3d(i,j,k)
2722 END DO
2723 END DO
2724 END DO
2725 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2726 DO k = kds , kde - 1
2727 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2728 DO i = MAX(ids,its) , MIN(ide,ite)
2729 space_bdy_ys(i,k,j) = data3d(i,j,k)
2730 END DO
2731 END DO
2732 END DO
2733 ELSE
2734 DO k = kds , kde - 1
2735 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2736 DO i = MAX(ids,its) , MIN(ide-1,ite)
2737 space_bdy_ys(i,k,j) = data3d(i,j,k)
2738 END DO
2739 END DO
2740 END DO
2741 END IF
2742
2743 ! Y end boundary
2744
2745 IF ( char_stagger .EQ. 'V' ) THEN
2746 DO k = kds , kde - 1
2747 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2748 DO i = MAX(ids,its) , MIN(ide-1,ite)
2749 jj = jde - j + 1
2750 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2751 END DO
2752 END DO
2753 END DO
2754 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2755 DO k = kds , kde - 1
2756 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2757 DO i = MAX(ids,its) , MIN(ide,ite)
2758 jj = jde - j
2759 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2760 END DO
2761 END DO
2762 END DO
2763 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2764 DO k = kds , kde
2765 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2766 DO i = MAX(ids,its) , MIN(ide-1,ite)
2767 jj = jde - j
2768 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2769 END DO
2770 END DO
2771 END DO
2772 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2773 DO k = kds , kde
2774 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2775 DO i = MAX(ids,its) , MIN(ide-1,ite)
2776 jj = jde - j
2777 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2778 END DO
2779 END DO
2780 END DO
2781 ELSE
2782 DO k = kds , kde - 1
2783 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2784 DO i = MAX(ids,its) , MIN(ide-1,ite)
2785 jj = jde - j
2786 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2787 ! if (K .eq. 54 .and. I .eq. 369) then
2788 ! write(0,*) 'N bound i,k,jj,P_YEB,data3d,space_bdy: ', i,k,jj,P_YEB,data3d(I,j,k),space_bdy(i,k,jj,P_YEB,1)
2789 ! endif
2790
2791 END DO
2792 END DO
2793 END DO
2794 END IF
2795
2796 END SUBROUTINE stuff_bdy_ijk
2797
2798 SUBROUTINE stuff_bdytend_ijk ( data3dnew , data3dold , time_diff , &
2799 space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
2800 char_stagger , &
2801 spec_bdy_width , &
2802 ids, ide, jds, jde, kds, kde , &
2803 ims, ime, jms, jme, kms, kme , &
2804 its, ite, jts, jte, kts, kte )
2805
2806 ! This routine puts the tendency data into the proper locations
2807 ! for the lateral boundary arrays.
2808
2809 USE module_state_description
2810
2811 IMPLICIT NONE
2812
2813 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2814 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2815 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2816 INTEGER , INTENT(IN) :: spec_bdy_width
2817 ! REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2818 REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: data3dnew , data3dold
2819 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2820 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2821
2822 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2823 REAL , INTENT(IN) :: time_diff ! seconds
2824
2825 INTEGER :: i , ii , j , jj , k
2826
2827 ! There are four lateral boundary locations that are stored.
2828
2829 ! X start boundary
2830
2831 IF ( char_stagger .EQ. 'W' ) THEN
2832 DO k = kds , kde
2833 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2834 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2835 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2836 END DO
2837 END DO
2838 END DO
2839 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2840 DO k = kds , kde
2841 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2842 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2843 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2844 END DO
2845 END DO
2846 END DO
2847 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2848 DO k = kds , kde - 1
2849 DO j = MAX(jds,jts) , MIN(jde,jte)
2850 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2851 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2852 END DO
2853 END DO
2854 END DO
2855 ELSE
2856 DO k = kds , kde - 1
2857 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2858 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2859 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2860 END DO
2861 END DO
2862 END DO
2863 END IF
2864
2865 ! X end boundary
2866
2867 IF ( char_stagger .EQ. 'U' ) THEN
2868 DO k = kds , kde - 1
2869 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2870 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2871 ii = ide - i + 1
2872 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2873 END DO
2874 END DO
2875 END DO
2876 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2877 DO k = kds , kde - 1
2878 DO j = MAX(jds,jts) , MIN(jde,jte)
2879 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2880 ii = ide - i
2881 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2882 END DO
2883 END DO
2884 END DO
2885 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2886 DO k = kds , kde
2887 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2888 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2889 ii = ide - i
2890 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2891 END DO
2892 END DO
2893 END DO
2894 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2895 DO k = kds , kde
2896 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2897 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2898 ii = ide - i
2899 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2900 END DO
2901 END DO
2902 END DO
2903 ELSE
2904 DO k = kds , kde - 1
2905 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2906 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2907 ii = ide - i
2908 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2909 END DO
2910 END DO
2911 END DO
2912 END IF
2913
2914 ! Y start boundary
2915
2916 IF ( char_stagger .EQ. 'W' ) THEN
2917 DO k = kds , kde
2918 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2919 DO i = MAX(ids,its) , MIN(ide-1,ite)
2920 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2921 END DO
2922 END DO
2923 END DO
2924 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2925 DO k = kds , kde
2926 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2927 DO i = MAX(ids,its) , MIN(ide-1,ite)
2928 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2929 END DO
2930 END DO
2931 END DO
2932 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2933 DO k = kds , kde - 1
2934 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2935 DO i = MAX(ids,its) , MIN(ide,ite)
2936 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2937 END DO
2938 END DO
2939 END DO
2940 ELSE
2941 DO k = kds , kde - 1
2942 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2943 DO i = MAX(ids,its) , MIN(ide-1,ite)
2944 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2945 END DO
2946 END DO
2947 END DO
2948 END IF
2949
2950 ! Y end boundary
2951
2952 IF ( char_stagger .EQ. 'V' ) THEN
2953 DO k = kds , kde - 1
2954 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2955 DO i = MAX(ids,its) , MIN(ide-1,ite)
2956 jj = jde - j + 1
2957 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2958 END DO
2959 END DO
2960 END DO
2961 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2962 DO k = kds , kde - 1
2963 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2964 DO i = MAX(ids,its) , MIN(ide,ite)
2965 jj = jde - j
2966 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2967 END DO
2968 END DO
2969 END DO
2970 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2971 DO k = kds , kde
2972 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2973 DO i = MAX(ids,its) , MIN(ide-1,ite)
2974 jj = jde - j
2975 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2976 END DO
2977 END DO
2978 END DO
2979 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2980 DO k = kds , kde
2981 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2982 DO i = MAX(ids,its) , MIN(ide-1,ite)
2983 jj = jde - j
2984 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2985 END DO
2986 END DO
2987 END DO
2988 ELSE
2989 DO k = kds , kde - 1
2990 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2991 DO i = MAX(ids,its) , MIN(ide-1,ite)
2992 jj = jde - j
2993 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2994 ! if (K .eq. 54 .and. I .eq. 369) then
2995 ! write(0,*) 'N bound i,k,jj,data3dnew,data3dold: ', i,k,jj,data3dnew(I,j,k),data3dold(i,j,k)
2996 ! endif
2997 END DO
2998 END DO
2999 END DO
3000 END IF
3001
3002 END SUBROUTINE stuff_bdytend_ijk
3003
3004 END MODULE module_bc
3005
3006 SUBROUTINE get_bdyzone_x ( bzx )
3007 USE module_bc
3008 IMPLICIT NONE
3009 INTEGER bzx
3010 bzx = bdyzone_x
3011 END SUBROUTINE get_bdyzone_x
3012
3013 SUBROUTINE get_bdyzone_y ( bzy)
3014 USE module_bc
3015 IMPLICIT NONE
3016 INTEGER bzy
3017 bzy = bdyzone_y
3018 END SUBROUTINE get_bdyzone_y
3019
3020 SUBROUTINE get_bdyzone ( bz)
3021 USE module_bc
3022 IMPLICIT NONE
3023 INTEGER bz
3024 bz = bdyzone
3025 END SUBROUTINE get_bdyzone