1 !WRF:MODEL_LAYER:BOUNDARY
12 ! LOGICAL :: periodic_x
13 ! LOGICAL :: symmetric_xs
14 ! LOGICAL :: symmetric_xe
17 ! LOGICAL :: periodic_y
18 ! LOGICAL :: symmetric_ys
19 ! LOGICAL :: symmetric_ye
23 ! LOGICAL :: specified
24 ! LOGICAL :: top_radiation
28 ! set the bdyzone. We are hardwiring this here and we'll
29 ! decide later where it should be set and stored
31 INTEGER, PARAMETER :: bdyzone = 4
32 INTEGER, PARAMETER :: bdyzone_x = bdyzone
33 INTEGER, PARAMETER :: bdyzone_y = bdyzone
36 MODULE PROCEDURE stuff_bdy_new , stuff_bdy_old
39 INTERFACE stuff_bdytend
40 MODULE PROCEDURE stuff_bdytend_new , stuff_bdytend_old
45 SUBROUTINE boundary_condition_check ( config_flags, bzone, error, gn )
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
55 TYPE( grid_config_rec_type ) config_flags
57 INTEGER, INTENT(IN ) :: bzone, gn
58 INTEGER, INTENT(INOUT) :: error
62 INTEGER :: xs_bc, xe_bc, ys_bc, ye_bc, bzone_min
63 INTEGER :: nprocx, nprocy
65 CALL wrf_debug( 100 , ' checking boundary conditions for grid ' )
73 ! sum the number of conditions specified for each lateral boundary.
74 ! obviously, this number should be 1
76 IF( config_flags%periodic_x ) THEN
81 IF( config_flags%periodic_y ) THEN
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
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
97 IF( config_flags%nested ) THEN
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
111 IF( config_flags%polar ) THEN
116 ! check the number of conditions for each boundary
118 IF( (xs_bc /= 1) .or. &
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 ' )
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.
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
178 bzone_min = MAX( 1, &
179 (config_flags%h_mom_adv_order+1)/2, &
180 (config_flags%h_sca_adv_order+1)/2 )
182 IF( bzone < bzone_min) THEN
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 )
195 CALL wrf_debug ( 100 , ' boundary conditions OK for grid ' )
197 END subroutine boundary_condition_check
199 !--------------------------------------------------------------------------
200 SUBROUTINE set_physical_bc2d( dat, variable_in, &
202 ids,ide, jds,jde, & ! domain dims
203 ims,ime, jms,jme, & ! memory dims
204 ips,ipe, jps,jpe, & ! patch dims
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.
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.
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
227 CHARACTER :: variable
229 REAL, DIMENSION( ims:ime , jms:jme ) :: dat
230 TYPE( grid_config_rec_type ) config_flags
232 INTEGER :: i, j, istag, jstag, itime
234 LOGICAL :: debug, open_bc_copy
240 open_bc_copy = .false.
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') )
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.
251 ! begin, first set a staggering variable
256 IF ((variable == 'u') .or. (variable == 'x')) istag = 0
257 IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
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
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
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
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)
286 IF ( ite == ide ) THEN
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)
300 symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
301 ( its == ids ) ) THEN
303 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
305 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
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)
313 IF( variable == 'u' ) THEN
315 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
317 dat(ids-i,j) = - dat(ids+i,j) ! here, u(0) = - u(2), etc
318 ENDDO ! normal b.c symmetry at u(1)
323 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
325 dat(ids-i,j) = dat(ids+i,j) ! here, phi(0) = phi(2), etc
326 ENDDO ! normal b.c symmetry at phi(1)
336 ! now the symmetry boundary at xe
338 symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
339 ( ite == ide ) ) THEN
341 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
343 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
345 dat(ide+i-1,j) = dat(ide-i,j) ! sym. about dat(ide-0.5)
351 IF (variable == 'u' ) THEN
353 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
355 dat(ide+i,j) = - dat(ide-i,j) ! u(ide+1) = - u(ide-1), etc.
362 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
364 dat(ide+i,j) = dat(ide-i,j) ! phi(ide+1) = phi(ide-1), etc.
375 ! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
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
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)
391 ! now the open boundary copy at xe
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
398 IF ( variable /= 'u' .and. variable /= 'x') THEN
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)
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)
418 ! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
422 ! same procedure in y
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
427 IF( jts == jds ) then
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)
437 IF( jte == jde ) then
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)
451 symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
454 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
457 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
458 dat(i,jds-j) = dat(i,jds+j-1)
464 IF (variable == 'v') THEN
467 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
468 dat(i,jds-j) = - dat(i,jds+j)
475 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
476 dat(i,jds-j) = dat(i,jds+j)
486 ! now the symmetry boundary at ye
488 symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
489 ( jte == jde ) ) THEN
491 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
494 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
495 dat(i,jde+j-1) = dat(i,jde-j)
501 IF (variable == 'v' ) THEN
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
512 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
513 dat(i,jde+j) = dat(i,jde-j)
523 ! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
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
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)
539 ! now the open boundary copy at ye
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
547 IF (variable /= 'v' .and. variable /= 'y' ) THEN
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)
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)
567 ! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
571 ! fix corners for doubly periodic domains
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
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)
585 IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
586 DO j = 0, -(bdyzone-1), -1
588 dat(ide+i+istag,jds+j-1) = dat(ids+i+istag,jde+j-1)
593 IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
596 dat(ide+i+istag,jde+j+jstag) = dat(ids+i+istag,jds+j+jstag)
601 IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
603 DO i = 0, -(bdyzone-1), -1
604 dat(ids+i-1,jde+j+jstag) = dat(ide+i-1,jds+j+jstag)
611 END SUBROUTINE set_physical_bc2d
613 !-----------------------------------
615 SUBROUTINE set_physical_bc3d( dat, variable_in, &
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 )
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.
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.
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
642 CHARACTER :: variable
644 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: dat
645 TYPE( grid_config_rec_type ) config_flags
647 INTEGER :: i, j, k, istag, jstag, itime, k_end
649 LOGICAL :: debug, open_bc_copy
655 open_bc_copy = .false.
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') )
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.
669 ! begin, first set a staggering variable
673 k_end = max(1,min(kde-1,kte))
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
682 IF ((variable == 'e') ) then
687 IF ((variable == 'f') ) then
692 IF ( variable == 'w') k_end = min(kde,kte)
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
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
711 periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
713 IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if both east and west on-processor
714 IF ( its == ids ) THEN
716 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
718 DO i = 0,-(bdyzone-1),-1
719 dat(ids+i-1,k,j) = dat(ide+i-1,k,j)
727 IF ( ite == ide ) THEN
729 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
731 DO i = -istag , bdyzone
732 dat(ide+i+istag,k,j) = dat(ids+i+istag,k,j)
743 symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
744 ( its == ids ) ) THEN
746 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
748 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
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)
758 IF ( variable == 'u' ) THEN
760 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
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)
770 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
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)
785 ! now the symmetry boundary at xe
787 symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
788 ( ite == ide ) ) THEN
790 IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
792 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
795 dat(ide+i-1,k,j) = dat(ide-i,k,j) ! sym. about dat(ide-0.5)
802 IF (variable == 'u') THEN
804 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
807 dat(ide+i,k,j) = - dat(ide-i,k,j) ! u(ide+1) = - u(ide-1), etc.
814 DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
817 dat(ide+i,k,j) = dat(ide-i,k,j) ! phi(ide+1) = - phi(ide-1), etc.
828 ! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
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
835 DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
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)
846 ! now the open_xe boundary copy
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
853 IF (variable /= 'u' .and. variable /= 'x' ) THEN
855 DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
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)
865 !!!!!!! I am not sure about this one! JM 20020402
866 DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone
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)
878 ! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
882 ! same procedure in y
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
888 DO j = 0, -(bdyzone-1), -1
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)
898 IF( jte == jde ) then
900 DO j = -jstag, bdyzone
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)
914 symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
917 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
921 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
922 dat(i,k,jds-j) = dat(i,k,jds+j-1)
929 IF (variable == 'v') THEN
933 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
934 dat(i,k,jds-j) = - dat(i,k,jds+j)
943 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
944 dat(i,k,jds-j) = dat(i,k,jds+j)
955 ! now the symmetry boundary at ye
957 symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
958 ( jte == jde ) ) THEN
960 IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
964 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
965 dat(i,k,jde+j-1) = dat(i,k,jde-j)
972 IF ( variable == 'v' ) THEN
976 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
977 dat(i,k,jde+j) = - dat(i,k,jde-j)
986 DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
987 dat(i,k,jde+j) = dat(i,k,jde-j)
998 ! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
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
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)
1016 ! now the open boundary copy at ye
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
1024 IF (variable /= 'v' .and. variable /= 'y' ) THEN
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)
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)
1048 ! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
1050 END IF periodicity_y
1052 ! fix corners for doubly periodic domains
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
1058 IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
1059 DO j = 0, -(bdyzone-1), -1
1061 DO i = 0, -(bdyzone-1), -1
1062 dat(ids+i-1,k,jds+j-1) = dat(ide+i-1,k,jde+j-1)
1068 IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
1069 DO j = 0, -(bdyzone-1), -1
1072 dat(ide+i+istag,k,jds+j-1) = dat(ids+i+istag,k,jde+j-1)
1078 IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
1082 dat(ide+i+istag,k,jde+j+jstag) = dat(ids+i+istag,k,jds+j+jstag)
1088 IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
1091 DO i = 0, -(bdyzone-1), -1
1092 dat(ids+i-1,k,jde+j+jstag) = dat(ide+i-1,k,jds+j+jstag)
1100 END SUBROUTINE set_physical_bc3d
1102 SUBROUTINE init_module_bc
1103 END SUBROUTINE init_module_bc
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, &
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 )
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.
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
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
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
1152 periodic_x = config_flags%periodic_x
1153 variable = variable_in
1155 IF (variable == 'U') variable = 'u'
1156 IF (variable == 'V') variable = 'v'
1157 IF (variable == 'M') variable = 'm'
1158 IF (variable == 'H') variable = 'h'
1162 itf = min(ite,ide-1)
1165 jtf = min(jte,jde-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
1174 IF (jts - jbs .lt. relax_zone) THEN
1176 DO j = max(jts,jbs+spec_zone), min(jtf,jbs+relax_zone-1)
1179 IF(periodic_x)b_limit = 0
1181 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1184 fls0 = field_bdy_ys(i, k, b_dist+1) &
1185 + dtbc * field_bdy_tend_ys(i, k, b_dist+1) &
1187 fls1 = field_bdy_ys(im1, k, b_dist+1) &
1188 + dtbc * field_bdy_tend_ys(im1, k, b_dist+1) &
1190 fls2 = field_bdy_ys(ip1, k, b_dist+1) &
1191 + dtbc * field_bdy_tend_ys(ip1, k, b_dist+1) &
1193 fls3 = field_bdy_ys(i, k, b_dist) &
1194 + dtbc * field_bdy_tend_ys(i, k, b_dist) &
1196 fls4 = field_bdy_ys(i, k, b_dist+2) &
1197 + dtbc * field_bdy_tend_ys(i, k, b_dist+2) &
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)
1207 IF (jbe - jtf .lt. relax_zone) THEN
1209 DO j = max(jts,jbe-relax_zone+1), min(jtf,jbe-spec_zone)
1212 IF(periodic_x)b_limit = 0
1214 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1217 fls0 = field_bdy_ye(i, k, b_dist+1) &
1218 + dtbc * field_bdy_tend_ye(i, k, b_dist+1) &
1220 fls1 = field_bdy_ye(im1, k, b_dist+1) &
1221 + dtbc * field_bdy_tend_ye(im1, k, b_dist+1) &
1223 fls2 = field_bdy_ye(ip1, k, b_dist+1) &
1224 + dtbc * field_bdy_tend_ye(ip1, k, b_dist+1) &
1226 fls3 = field_bdy_ye(i, k, b_dist) &
1227 + dtbc * field_bdy_tend_ye(i, k, b_dist) &
1229 fls4 = field_bdy_ye(i, k, b_dist+2) &
1230 + dtbc * field_bdy_tend_ye(i, k, b_dist+2) &
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)
1241 IF(.NOT.periodic_x)THEN
1242 IF (its - ibs .lt. relax_zone) THEN
1244 DO i = max(its,ibs+spec_zone), min(itf,ibs+relax_zone-1)
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) &
1251 fls1 = field_bdy_xs(j-1, k, b_dist+1) &
1252 + dtbc * field_bdy_tend_xs(j-1, k, b_dist+1) &
1254 fls2 = field_bdy_xs(j+1, k, b_dist+1) &
1255 + dtbc * field_bdy_tend_xs(j+1, k, b_dist+1) &
1257 fls3 = field_bdy_xs(j, k, b_dist) &
1258 + dtbc * field_bdy_tend_xs(j, k, b_dist) &
1260 fls4 = field_bdy_xs(j, k, b_dist+2) &
1261 + dtbc * field_bdy_tend_xs(j, k, b_dist+2) &
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)
1272 IF (ibe - itf .lt. relax_zone) THEN
1274 DO i = max(its,ibe-relax_zone+1), min(itf,ibe-spec_zone)
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) &
1281 fls1 = field_bdy_xe(j-1, k, b_dist+1) &
1282 + dtbc * field_bdy_tend_xe(j-1, k, b_dist+1) &
1284 fls2 = field_bdy_xe(j+1, k, b_dist+1) &
1285 + dtbc * field_bdy_tend_xe(j+1, k, b_dist+1) &
1287 fls3 = field_bdy_xe(j, k, b_dist) &
1288 + dtbc * field_bdy_tend_xe(j, k, b_dist) &
1290 fls4 = field_bdy_xe(j, k, b_dist+2) &
1291 + dtbc * field_bdy_tend_xe(j, k, b_dist+2) &
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)
1303 END SUBROUTINE relax_bdytend
1304 !------------------------------------------------------------------------
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 )
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.
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
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
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
1345 periodic_x = config_flags%periodic_x
1347 variable = variable_in
1349 IF (variable == 'U') variable = 'u'
1350 IF (variable == 'V') variable = 'v'
1351 IF (variable == 'M') variable = 'm'
1352 IF (variable == 'H') variable = 'h'
1356 itf = min(ite,ide-1)
1359 jtf = min(jte,jde-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
1368 IF (jts - jbs .lt. spec_zone) THEN
1370 DO j = jts, min(jtf,jbs+spec_zone-1)
1373 IF(periodic_x)b_limit = 0
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)
1381 IF (jbe - jtf .lt. spec_zone) THEN
1383 DO j = max(jts,jbe-spec_zone+1), jtf
1386 IF(periodic_x)b_limit = 0
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)
1395 IF(.NOT.periodic_x)THEN
1396 IF (its - ibs .lt. spec_zone) THEN
1398 DO i = its, min(itf,ibs+spec_zone-1)
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)
1408 IF (ibe - itf .lt. spec_zone) THEN
1410 DO i = max(its,ibe-spec_zone+1), itf
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)
1421 END SUBROUTINE spec_bdytend
1422 !------------------------------------------------------------------------
1424 SUBROUTINE spec_bdyfield ( field, &
1425 field_bdy_xs, field_bdy_xe, &
1426 field_bdy_ys, field_bdy_ye, &
1427 variable_in, config_flags, &
1428 spec_bdy_width, spec_zone, &
1429 ids,ide, jds,jde, kds,kde, & ! domain dims
1430 ims,ime, jms,jme, kms,kme, & ! memory dims
1431 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1432 its,ite, jts,jte, kts,kte )
1434 ! This subroutine sets the tendencies in the boundary specified region.
1435 ! spec_bdy_width is only used to dimension the boundary arrays.
1436 ! spec_zone is the width of the outer specified b.c.s that are set here.
1441 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1442 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1443 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1444 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1445 INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone
1446 CHARACTER, INTENT(IN ) :: variable_in
1449 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT ) :: field
1450 REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_xs, field_bdy_xe
1451 REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_ys, field_bdy_ye
1452 TYPE( grid_config_rec_type ) config_flags
1454 CHARACTER :: variable
1455 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1456 INTEGER :: b_dist, b_limit
1457 LOGICAL :: periodic_x
1459 periodic_x = config_flags%periodic_x
1461 variable = variable_in
1463 IF (variable == 'U') variable = 'u'
1464 IF (variable == 'V') variable = 'v'
1465 IF (variable == 'M') variable = 'm'
1466 IF (variable == 'H') variable = 'h'
1470 itf = min(ite,ide-1)
1473 jtf = min(jte,jde-1)
1475 IF (variable == 'u') ibe = ide
1476 IF (variable == 'u') itf = min(ite,ide)
1477 IF (variable == 'v') jbe = jde
1478 IF (variable == 'v') jtf = min(jte,jde)
1479 IF (variable == 'm') ktf = kte
1480 IF (variable == 'h') ktf = kte
1482 IF (jts - jbs .lt. spec_zone) THEN
1484 DO j = jts, min(jtf,jbs+spec_zone-1)
1487 IF(periodic_x)b_limit = 0
1489 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1490 field(i,k,j) = field_bdy_ys(i, k, b_dist+1)
1495 IF (jbe - jtf .lt. spec_zone) THEN
1497 DO j = max(jts,jbe-spec_zone+1), jtf
1500 IF(periodic_x)b_limit = 0
1502 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1503 field(i,k,j) = field_bdy_ye(i, k, b_dist+1)
1509 IF(.NOT.periodic_x)THEN
1510 IF (its - ibs .lt. spec_zone) THEN
1512 DO i = its, min(itf,ibs+spec_zone-1)
1515 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1516 field(i,k,j) = field_bdy_xs(j, k, b_dist+1)
1522 IF (ibe - itf .lt. spec_zone) THEN
1524 DO i = max(its,ibe-spec_zone+1), itf
1527 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1528 field(i,k,j) = field_bdy_xe(j, k, b_dist+1)
1535 END SUBROUTINE spec_bdyfield
1536 !------------------------------------------------------------------------
1538 SUBROUTINE spec_bdyupdate( field, &
1540 variable_in, config_flags, &
1542 ids,ide, jds,jde, kds,kde, & ! domain dims
1543 ims,ime, jms,jme, kms,kme, & ! memory dims
1544 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1545 its,ite, jts,jte, kts,kte )
1547 ! This subroutine adds the tendencies in the boundary specified region.
1548 ! spec_zone is the width of the outer specified b.c.s that are set here.
1553 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1554 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1555 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1556 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1557 INTEGER, INTENT(IN ) :: spec_zone
1558 CHARACTER, INTENT(IN ) :: variable_in
1559 REAL, INTENT(IN ) :: dt
1562 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1563 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend
1564 TYPE( grid_config_rec_type ) config_flags
1566 CHARACTER :: variable
1567 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1568 INTEGER :: b_dist, b_limit
1569 LOGICAL :: periodic_x
1571 periodic_x = config_flags%periodic_x
1573 variable = variable_in
1575 IF (variable == 'U') variable = 'u'
1576 IF (variable == 'V') variable = 'v'
1577 IF (variable == 'M') variable = 'm'
1578 IF (variable == 'H') variable = 'h'
1582 itf = min(ite,ide-1)
1585 jtf = min(jte,jde-1)
1587 IF (variable == 'u') ibe = ide
1588 IF (variable == 'u') itf = min(ite,ide)
1589 IF (variable == 'v') jbe = jde
1590 IF (variable == 'v') jtf = min(jte,jde)
1591 IF (variable == 'm') ktf = kte
1592 IF (variable == 'h') ktf = kte
1594 IF (jts - jbs .lt. spec_zone) THEN
1596 DO j = jts, min(jtf,jbs+spec_zone-1)
1599 IF(periodic_x)b_limit = 0
1601 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1602 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1607 IF (jbe - jtf .lt. spec_zone) THEN
1609 DO j = max(jts,jbe-spec_zone+1), jtf
1612 IF(periodic_x)b_limit = 0
1614 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1615 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1621 IF(.NOT.periodic_x)THEN
1622 IF (its - ibs .lt. spec_zone) THEN
1624 DO i = its, min(itf,ibs+spec_zone-1)
1627 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1628 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1634 IF (ibe - itf .lt. spec_zone) THEN
1636 DO i = max(its,ibe-spec_zone+1), itf
1639 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1640 field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1647 END SUBROUTINE spec_bdyupdate
1648 !------------------------------------------------------------------------
1650 SUBROUTINE zero_grad_bdy ( field, &
1651 variable_in, config_flags, &
1653 ids,ide, jds,jde, kds,kde, & ! domain dims
1654 ims,ime, jms,jme, kms,kme, & ! memory dims
1655 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1656 its,ite, jts,jte, kts,kte )
1658 ! This subroutine sets zero gradient conditions in the boundary specified region.
1659 ! spec_zone is the width of the outer specified b.c.s that are set here.
1664 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1665 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1666 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1667 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1668 INTEGER, INTENT(IN ) :: spec_zone
1669 CHARACTER, INTENT(IN ) :: variable_in
1672 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1673 TYPE( grid_config_rec_type ) config_flags
1675 CHARACTER :: variable
1676 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1677 INTEGER :: b_dist, b_limit
1678 LOGICAL :: periodic_x
1680 periodic_x = config_flags%periodic_x
1682 variable = variable_in
1684 IF (variable == 'U') variable = 'u'
1685 IF (variable == 'V') variable = 'v'
1689 itf = min(ite,ide-1)
1692 jtf = min(jte,jde-1)
1694 IF (variable == 'u') ibe = ide
1695 IF (variable == 'u') itf = min(ite,ide)
1696 IF (variable == 'v') jbe = jde
1697 IF (variable == 'v') jtf = min(jte,jde)
1698 IF (variable == 'w') ktf = kde
1700 IF (jts - jbs .lt. spec_zone) THEN
1702 DO j = jts, min(jtf,jbs+spec_zone-1)
1705 IF(periodic_x)b_limit = 0
1707 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1708 i_inner = max(i,ibs+spec_zone)
1709 i_inner = min(i_inner,ibe-spec_zone)
1710 IF(periodic_x)i_inner = i
1711 field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1716 IF (jbe - jtf .lt. spec_zone) THEN
1718 DO j = max(jts,jbe-spec_zone+1), jtf
1721 IF(periodic_x)b_limit = 0
1723 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1724 i_inner = max(i,ibs+spec_zone)
1725 i_inner = min(i_inner,ibe-spec_zone)
1726 IF(periodic_x)i_inner = i
1727 field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1733 IF(.NOT.periodic_x)THEN
1734 IF (its - ibs .lt. spec_zone) THEN
1736 DO i = its, min(itf,ibs+spec_zone-1)
1739 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1740 j_inner = max(j,jbs+spec_zone)
1741 j_inner = min(j_inner,jbe-spec_zone)
1742 field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1748 IF (ibe - itf .lt. spec_zone) THEN
1750 DO i = max(its,ibe-spec_zone+1), itf
1753 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1754 j_inner = max(j,jbs+spec_zone)
1755 j_inner = min(j_inner,jbe-spec_zone)
1756 field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1763 END SUBROUTINE zero_grad_bdy
1764 !------------------------------------------------------------------------
1766 SUBROUTINE flow_dep_bdy ( field, &
1767 u, v, config_flags, &
1769 ids,ide, jds,jde, kds,kde, & ! domain dims
1770 ims,ime, jms,jme, kms,kme, & ! memory dims
1771 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1772 its,ite, jts,jte, kts,kte )
1774 ! This subroutine sets zero gradient conditions for outflow and zero value
1775 ! for inflow in the boundary specified region. Note that field must be unstaggered.
1776 ! The velocities, u and v, will only be used to check their sign (coupled vels OK)
1777 ! spec_zone is the width of the outer specified b.c.s that are set here.
1782 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1783 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1784 INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1785 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1786 INTEGER, INTENT(IN ) :: spec_zone
1789 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1790 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u
1791 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v
1792 TYPE( grid_config_rec_type ) config_flags
1794 INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1795 INTEGER :: b_dist, b_limit
1796 LOGICAL :: periodic_x
1798 periodic_x = config_flags%periodic_x
1802 itf = min(ite,ide-1)
1805 jtf = min(jte,jde-1)
1808 IF (jts - jbs .lt. spec_zone) THEN
1810 DO j = jts, min(jtf,jbs+spec_zone-1)
1813 IF(periodic_x)b_limit = 0
1815 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1816 i_inner = max(i,ibs+spec_zone)
1817 i_inner = min(i_inner,ibe-spec_zone)
1818 IF(periodic_x)i_inner = i
1819 IF(v(i,k,j) .lt. 0.)THEN
1820 field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1828 IF (jbe - jtf .lt. spec_zone) THEN
1830 DO j = max(jts,jbe-spec_zone+1), jtf
1833 IF(periodic_x)b_limit = 0
1835 DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1836 i_inner = max(i,ibs+spec_zone)
1837 i_inner = min(i_inner,ibe-spec_zone)
1838 IF(periodic_x)i_inner = i
1839 IF(v(i,k,j+1) .gt. 0.)THEN
1840 field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1849 IF(.NOT.periodic_x)THEN
1850 IF (its - ibs .lt. spec_zone) THEN
1852 DO i = its, min(itf,ibs+spec_zone-1)
1855 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1856 j_inner = max(j,jbs+spec_zone)
1857 j_inner = min(j_inner,jbe-spec_zone)
1858 IF(u(i,k,j) .lt. 0.)THEN
1859 field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1868 IF (ibe - itf .lt. spec_zone) THEN
1870 DO i = max(its,ibe-spec_zone+1), itf
1873 DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1874 j_inner = max(j,jbs+spec_zone)
1875 j_inner = min(j_inner,jbe-spec_zone)
1876 IF(u(i+1,k,j) .gt. 0.)THEN
1877 field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1887 END SUBROUTINE flow_dep_bdy
1889 !------------------------------------------------------------------------------
1891 SUBROUTINE stuff_bdy_new ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
1894 ids, ide, jds, jde, kds, kde , &
1895 ims, ime, jms, jme, kms, kme , &
1896 its, ite, jts, jte, kts, kte )
1898 ! This routine puts the data in the 3d arrays into the proper locations
1899 ! for the lateral boundary arrays.
1901 USE module_state_description
1905 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1906 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1907 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1908 INTEGER , INTENT(IN) :: spec_bdy_width
1909 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
1910 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
1911 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
1912 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1914 INTEGER :: i , ii , j , jj , k
1916 ! There are four lateral boundary locations that are stored.
1920 IF ( char_stagger .EQ. 'W' ) THEN
1921 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1923 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1924 space_bdy_xs(j,k,i) = data3d(i,k,j)
1928 ELSE IF ( char_stagger .EQ. 'M' ) THEN
1929 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1931 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1932 space_bdy_xs(j,k,i) = data3d(i,k,j)
1936 ELSE IF ( char_stagger .EQ. 'V' ) THEN
1937 DO j = MAX(jds,jts) , MIN(jde,jte)
1938 DO k = kds , kde - 1
1939 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1940 space_bdy_xs(j,k,i) = data3d(i,k,j)
1945 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1946 DO k = kds , kde - 1
1947 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1948 space_bdy_xs(j,k,i) = data3d(i,k,j)
1956 IF ( char_stagger .EQ. 'U' ) THEN
1957 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1958 DO k = kds , kde - 1
1959 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1961 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1965 ELSE IF ( char_stagger .EQ. 'V' ) THEN
1966 DO j = MAX(jds,jts) , MIN(jde,jte)
1967 DO k = kds , kde - 1
1968 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1970 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1974 ELSE IF ( char_stagger .EQ. 'W' ) THEN
1975 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1977 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1979 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1983 ELSE IF ( char_stagger .EQ. 'M' ) THEN
1984 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1986 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1988 space_bdy_xe(j,k,ii) = data3d(i,k,j)
1993 DO j = MAX(jds,jts) , MIN(jde-1,jte)
1994 DO k = kds , kde - 1
1995 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1997 space_bdy_xe(j,k,ii) = data3d(i,k,j)
2005 IF ( char_stagger .EQ. 'W' ) THEN
2006 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2008 DO i = MAX(ids,its) , MIN(ide-1,ite)
2009 space_bdy_ys(i,k,j) = data3d(i,k,j)
2013 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2014 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2016 DO i = MAX(ids,its) , MIN(ide-1,ite)
2017 space_bdy_ys(i,k,j) = data3d(i,k,j)
2021 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2022 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2023 DO k = kds , kde - 1
2024 DO i = MAX(ids,its) , MIN(ide,ite)
2025 space_bdy_ys(i,k,j) = data3d(i,k,j)
2030 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2031 DO k = kds , kde - 1
2032 DO i = MAX(ids,its) , MIN(ide-1,ite)
2033 space_bdy_ys(i,k,j) = data3d(i,k,j)
2041 IF ( char_stagger .EQ. 'V' ) THEN
2042 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2043 DO k = kds , kde - 1
2044 DO i = MAX(ids,its) , MIN(ide-1,ite)
2046 space_bdy_ye(i,k,jj) = data3d(i,k,j)
2050 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2051 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2052 DO k = kds , kde - 1
2053 DO i = MAX(ids,its) , MIN(ide,ite)
2055 space_bdy_ye(i,k,jj) = data3d(i,k,j)
2059 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2060 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2062 DO i = MAX(ids,its) , MIN(ide-1,ite)
2064 space_bdy_ye(i,k,jj) = data3d(i,k,j)
2068 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2069 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2071 DO i = MAX(ids,its) , MIN(ide-1,ite)
2073 space_bdy_ye(i,k,jj) = data3d(i,k,j)
2078 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2079 DO k = kds , kde - 1
2080 DO i = MAX(ids,its) , MIN(ide-1,ite)
2082 space_bdy_ye(i,k,jj) = data3d(i,k,j)
2088 END SUBROUTINE stuff_bdy_new
2090 SUBROUTINE stuff_bdytend_new ( data3dnew , data3dold , time_diff , &
2091 space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
2094 ids, ide, jds, jde, kds, kde , &
2095 ims, ime, jms, jme, kms, kme , &
2096 its, ite, jts, jte, kts, kte )
2098 ! This routine puts the tendency data into the proper locations
2099 ! for the lateral boundary arrays.
2101 USE module_state_description
2105 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2106 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2107 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2108 INTEGER , INTENT(IN) :: spec_bdy_width
2109 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2110 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2111 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2112 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2113 REAL , INTENT(IN) :: time_diff ! seconds
2115 INTEGER :: i , ii , j , jj , k
2117 ! There are four lateral boundary locations that are stored.
2121 IF ( char_stagger .EQ. 'W' ) THEN
2122 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2124 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2125 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2129 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2130 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2132 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2133 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2137 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2138 DO j = MAX(jds,jts) , MIN(jde,jte)
2139 DO k = kds , kde - 1
2140 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2141 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2146 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2147 DO k = kds , kde - 1
2148 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2149 space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2157 IF ( char_stagger .EQ. 'U' ) THEN
2158 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2159 DO k = kds , kde - 1
2160 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2162 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2166 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2167 DO j = MAX(jds,jts) , MIN(jde,jte)
2168 DO k = kds , kde - 1
2169 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2171 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2175 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2176 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2178 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2180 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2184 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2185 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2187 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2189 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2194 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2195 DO k = kds , kde - 1
2196 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2198 space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2206 IF ( char_stagger .EQ. 'W' ) THEN
2207 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2209 DO i = MAX(ids,its) , MIN(ide-1,ite)
2210 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2214 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2215 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2217 DO i = MAX(ids,its) , MIN(ide-1,ite)
2218 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2222 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2223 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2224 DO k = kds , kde - 1
2225 DO i = MAX(ids,its) , MIN(ide,ite)
2226 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2231 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2232 DO k = kds , kde - 1
2233 DO i = MAX(ids,its) , MIN(ide-1,ite)
2234 space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2242 IF ( char_stagger .EQ. 'V' ) THEN
2243 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2244 DO k = kds , kde - 1
2245 DO i = MAX(ids,its) , MIN(ide-1,ite)
2247 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2251 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2252 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2253 DO k = kds , kde - 1
2254 DO i = MAX(ids,its) , MIN(ide,ite)
2256 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2260 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2261 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2263 DO i = MAX(ids,its) , MIN(ide-1,ite)
2265 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2269 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2270 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2272 DO i = MAX(ids,its) , MIN(ide-1,ite)
2274 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2279 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2280 DO k = kds , kde - 1
2281 DO i = MAX(ids,its) , MIN(ide-1,ite)
2283 space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2289 END SUBROUTINE stuff_bdytend_new
2291 !--- old versions for use with modules that use the old bdy data structures ---
2293 SUBROUTINE stuff_bdy_old ( data3d , space_bdy , char_stagger , &
2294 ijds , ijde , spec_bdy_width , &
2295 ids, ide, jds, jde, kds, kde , &
2296 ims, ime, jms, jme, kms, kme , &
2297 its, ite, jts, jte, kts, kte )
2299 ! This routine puts the data in the 3d arrays into the proper locations
2300 ! for the lateral boundary arrays.
2302 USE module_state_description
2306 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2307 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2308 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2309 INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
2310 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
2311 REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy
2312 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2314 INTEGER :: i , ii , j , jj , k
2316 ! There are four lateral boundary locations that are stored.
2320 IF ( char_stagger .EQ. 'W' ) THEN
2321 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2323 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2324 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2328 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2329 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2331 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2332 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2336 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2337 DO j = MAX(jds,jts) , MIN(jde,jte)
2338 DO k = kds , kde - 1
2339 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2340 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2345 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2346 DO k = kds , kde - 1
2347 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2348 space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2356 IF ( char_stagger .EQ. 'U' ) THEN
2357 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2358 DO k = kds , kde - 1
2359 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2361 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2365 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2366 DO j = MAX(jds,jts) , MIN(jde,jte)
2367 DO k = kds , kde - 1
2368 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2370 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2374 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2375 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2377 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2379 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2383 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2384 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2386 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2388 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2393 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2394 DO k = kds , kde - 1
2395 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2397 space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2405 IF ( char_stagger .EQ. 'W' ) THEN
2406 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2408 DO i = MAX(ids,its) , MIN(ide-1,ite)
2409 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2413 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2414 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2416 DO i = MAX(ids,its) , MIN(ide-1,ite)
2417 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2421 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2422 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2423 DO k = kds , kde - 1
2424 DO i = MAX(ids,its) , MIN(ide,ite)
2425 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2430 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2431 DO k = kds , kde - 1
2432 DO i = MAX(ids,its) , MIN(ide-1,ite)
2433 space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2441 IF ( char_stagger .EQ. 'V' ) THEN
2442 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2443 DO k = kds , kde - 1
2444 DO i = MAX(ids,its) , MIN(ide-1,ite)
2446 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2450 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2451 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2452 DO k = kds , kde - 1
2453 DO i = MAX(ids,its) , MIN(ide,ite)
2455 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2459 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2460 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2462 DO i = MAX(ids,its) , MIN(ide-1,ite)
2464 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2468 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2469 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2471 DO i = MAX(ids,its) , MIN(ide-1,ite)
2473 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2478 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2479 DO k = kds , kde - 1
2480 DO i = MAX(ids,its) , MIN(ide-1,ite)
2482 space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2488 END SUBROUTINE stuff_bdy_old
2490 SUBROUTINE stuff_bdytend_old ( data3dnew , data3dold , time_diff , space_bdy , char_stagger , &
2491 ijds , ijde , spec_bdy_width , &
2492 ids, ide, jds, jde, kds, kde , &
2493 ims, ime, jms, jme, kms, kme , &
2494 its, ite, jts, jte, kts, kte )
2496 ! This routine puts the tendency data into the proper locations
2497 ! for the lateral boundary arrays.
2499 USE module_state_description
2503 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2504 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2505 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2506 INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
2507 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2508 ! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
2509 REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy
2510 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2511 REAL , INTENT(IN) :: time_diff ! seconds
2513 INTEGER :: i , ii , j , jj , k
2515 ! There are four lateral boundary locations that are stored.
2519 IF ( char_stagger .EQ. 'W' ) THEN
2520 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2522 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2523 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2524 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2528 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2529 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2531 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2532 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2533 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2537 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2538 DO j = MAX(jds,jts) , MIN(jde,jte)
2539 DO k = kds , kde - 1
2540 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2541 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2542 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2547 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2548 DO k = kds , kde - 1
2549 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2550 space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2551 ! space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2559 IF ( char_stagger .EQ. 'U' ) THEN
2560 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2561 DO k = kds , kde - 1
2562 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2564 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2565 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2569 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2570 DO j = MAX(jds,jts) , MIN(jde,jte)
2571 DO k = kds , kde - 1
2572 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2574 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2575 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2579 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2580 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2582 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2584 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2585 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2589 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2590 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2592 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2594 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2595 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2600 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2601 DO k = kds , kde - 1
2602 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2604 space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2605 ! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2613 IF ( char_stagger .EQ. 'W' ) THEN
2614 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2616 DO i = MAX(ids,its) , MIN(ide-1,ite)
2617 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2618 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2622 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2623 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2625 DO i = MAX(ids,its) , MIN(ide-1,ite)
2626 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2627 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2631 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2632 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2633 DO k = kds , kde - 1
2634 DO i = MAX(ids,its) , MIN(ide,ite)
2635 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2636 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2641 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2642 DO k = kds , kde - 1
2643 DO i = MAX(ids,its) , MIN(ide-1,ite)
2644 space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2645 ! space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2653 IF ( char_stagger .EQ. 'V' ) THEN
2654 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2655 DO k = kds , kde - 1
2656 DO i = MAX(ids,its) , MIN(ide-1,ite)
2658 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2659 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2663 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2664 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2665 DO k = kds , kde - 1
2666 DO i = MAX(ids,its) , MIN(ide,ite)
2668 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2669 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2673 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2674 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2676 DO i = MAX(ids,its) , MIN(ide-1,ite)
2678 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2679 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2683 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2684 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2686 DO i = MAX(ids,its) , MIN(ide-1,ite)
2688 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2689 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2694 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2695 DO k = kds , kde - 1
2696 DO i = MAX(ids,its) , MIN(ide-1,ite)
2698 space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2699 ! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2705 END SUBROUTINE stuff_bdytend_old
2707 SUBROUTINE stuff_bdy_ijk ( data3d , space_bdy_xs, space_bdy_xe, &
2708 space_bdy_ys, space_bdy_ye, &
2709 char_stagger , spec_bdy_width, &
2710 ids, ide, jds, jde, kds, kde , &
2711 ims, ime, jms, jme, kms, kme , &
2712 its, ite, jts, jte, kts, kte )
2714 ! This routine puts the data in the 3d arrays into the proper locations
2715 ! for the lateral boundary arrays.
2717 USE module_state_description
2721 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2722 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2723 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2724 INTEGER , INTENT(IN) :: spec_bdy_width
2725 REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: data3d
2726 ! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
2727 ! REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4,1) , INTENT(OUT) :: space_bdy
2728 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2729 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2730 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2732 INTEGER :: i , ii , j , jj , k
2734 ! There are four lateral boundary locations that are stored.
2738 IF ( char_stagger .EQ. 'W' ) THEN
2740 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2741 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2742 space_bdy_xs(j,k,i) = data3d(i,j,k)
2746 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2748 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2749 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2750 space_bdy_xs(j,k,i) = data3d(i,j,k)
2754 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2755 DO k = kds , kde - 1
2756 DO j = MAX(jds,jts) , MIN(jde,jte)
2757 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2758 space_bdy_xs(j,k,i) = data3d(i,j,k)
2763 DO k = kds , kde - 1
2764 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2765 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2766 space_bdy_xs(j,k,i) = data3d(i,j,k)
2774 IF ( char_stagger .EQ. 'U' ) THEN
2775 DO k = kds , kde - 1
2776 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2777 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2779 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2783 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2784 DO k = kds , kde - 1
2785 DO j = MAX(jds,jts) , MIN(jde,jte)
2786 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2788 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2792 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2794 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2795 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2797 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2801 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2803 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2804 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2806 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2811 DO k = kds , kde - 1
2812 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2813 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2815 space_bdy_xe(j,k,ii) = data3d(i,j,k)
2823 IF ( char_stagger .EQ. 'W' ) THEN
2825 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2826 DO i = MAX(ids,its) , MIN(ide-1,ite)
2827 space_bdy_ys(i,k,j) = data3d(i,j,k)
2831 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2833 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2834 DO i = MAX(ids,its) , MIN(ide-1,ite)
2835 space_bdy_ys(i,k,j) = data3d(i,j,k)
2839 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2840 DO k = kds , kde - 1
2841 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2842 DO i = MAX(ids,its) , MIN(ide,ite)
2843 space_bdy_ys(i,k,j) = data3d(i,j,k)
2848 DO k = kds , kde - 1
2849 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2850 DO i = MAX(ids,its) , MIN(ide-1,ite)
2851 space_bdy_ys(i,k,j) = data3d(i,j,k)
2859 IF ( char_stagger .EQ. 'V' ) THEN
2860 DO k = kds , kde - 1
2861 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2862 DO i = MAX(ids,its) , MIN(ide-1,ite)
2864 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2868 ELSE IF ( char_stagger .EQ. 'U' ) THEN
2869 DO k = kds , kde - 1
2870 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2871 DO i = MAX(ids,its) , MIN(ide,ite)
2873 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2877 ELSE IF ( char_stagger .EQ. 'W' ) THEN
2879 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2880 DO i = MAX(ids,its) , MIN(ide-1,ite)
2882 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2886 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2888 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2889 DO i = MAX(ids,its) , MIN(ide-1,ite)
2891 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2896 DO k = kds , kde - 1
2897 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2898 DO i = MAX(ids,its) , MIN(ide-1,ite)
2900 space_bdy_ye(i,k,jj) = data3d(i,j,k)
2901 ! if (K .eq. 54 .and. I .eq. 369) then
2902 ! 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)
2910 END SUBROUTINE stuff_bdy_ijk
2912 SUBROUTINE stuff_bdytend_ijk ( data3dnew , data3dold , time_diff , &
2913 space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
2916 ids, ide, jds, jde, kds, kde , &
2917 ims, ime, jms, jme, kms, kme , &
2918 its, ite, jts, jte, kts, kte )
2920 ! This routine puts the tendency data into the proper locations
2921 ! for the lateral boundary arrays.
2923 USE module_state_description
2927 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2928 INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2929 INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2930 INTEGER , INTENT(IN) :: spec_bdy_width
2931 ! REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2932 REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: data3dnew , data3dold
2933 REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2934 REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2936 CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2937 REAL , INTENT(IN) :: time_diff ! seconds
2939 INTEGER :: i , ii , j , jj , k
2941 ! There are four lateral boundary locations that are stored.
2945 IF ( char_stagger .EQ. 'W' ) THEN
2947 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2948 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2949 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2953 ELSE IF ( char_stagger .EQ. 'M' ) THEN
2955 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2956 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2957 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2961 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2962 DO k = kds , kde - 1
2963 DO j = MAX(jds,jts) , MIN(jde,jte)
2964 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2965 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2970 DO k = kds , kde - 1
2971 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2972 DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2973 space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2981 IF ( char_stagger .EQ. 'U' ) THEN
2982 DO k = kds , kde - 1
2983 DO j = MAX(jds,jts) , MIN(jde-1,jte)
2984 DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2986 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2990 ELSE IF ( char_stagger .EQ. 'V' ) THEN
2991 DO k = kds , kde - 1
2992 DO j = MAX(jds,jts) , MIN(jde,jte)
2993 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2995 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2999 ELSE IF ( char_stagger .EQ. 'W' ) THEN
3001 DO j = MAX(jds,jts) , MIN(jde-1,jte)
3002 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
3004 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3008 ELSE IF ( char_stagger .EQ. 'M' ) THEN
3010 DO j = MAX(jds,jts) , MIN(jde-1,jte)
3011 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
3013 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3018 DO k = kds , kde - 1
3019 DO j = MAX(jds,jts) , MIN(jde-1,jte)
3020 DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
3022 space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3030 IF ( char_stagger .EQ. 'W' ) THEN
3032 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3033 DO i = MAX(ids,its) , MIN(ide-1,ite)
3034 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3038 ELSE IF ( char_stagger .EQ. 'M' ) THEN
3040 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3041 DO i = MAX(ids,its) , MIN(ide-1,ite)
3042 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3046 ELSE IF ( char_stagger .EQ. 'U' ) THEN
3047 DO k = kds , kde - 1
3048 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3049 DO i = MAX(ids,its) , MIN(ide,ite)
3050 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3055 DO k = kds , kde - 1
3056 DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3057 DO i = MAX(ids,its) , MIN(ide-1,ite)
3058 space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3066 IF ( char_stagger .EQ. 'V' ) THEN
3067 DO k = kds , kde - 1
3068 DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
3069 DO i = MAX(ids,its) , MIN(ide-1,ite)
3071 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3075 ELSE IF ( char_stagger .EQ. 'U' ) THEN
3076 DO k = kds , kde - 1
3077 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3078 DO i = MAX(ids,its) , MIN(ide,ite)
3080 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3084 ELSE IF ( char_stagger .EQ. 'W' ) THEN
3086 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3087 DO i = MAX(ids,its) , MIN(ide-1,ite)
3089 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3093 ELSE IF ( char_stagger .EQ. 'M' ) THEN
3095 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3096 DO i = MAX(ids,its) , MIN(ide-1,ite)
3098 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3103 DO k = kds , kde - 1
3104 DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3105 DO i = MAX(ids,its) , MIN(ide-1,ite)
3107 space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3108 ! if (K .eq. 54 .and. I .eq. 369) then
3109 ! write(0,*) 'N bound i,k,jj,data3dnew,data3dold: ', i,k,jj,data3dnew(I,j,k),data3dold(i,j,k)
3116 END SUBROUTINE stuff_bdytend_ijk
3118 END MODULE module_bc
3120 SUBROUTINE get_bdyzone_x ( bzx )
3125 END SUBROUTINE get_bdyzone_x
3127 SUBROUTINE get_bdyzone_y ( bzy)
3132 END SUBROUTINE get_bdyzone_y
3134 SUBROUTINE get_bdyzone ( bz)
3139 END SUBROUTINE get_bdyzone