Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_bc.F @ 3567

Last change on this file since 3567 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 102.3 KB

Rev	Line
[2759]	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_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 )
	1433
	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.
	1437	! (JD July 2000)
	1438
	1439	IMPLICIT NONE
	1440
	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
	1447
	1448
	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
	1453
	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
	1458
	1459	periodic_x = config_flags%periodic_x
	1460
	1461	variable = variable_in
	1462
	1463	IF (variable == 'U') variable = 'u'
	1464	IF (variable == 'V') variable = 'v'
	1465	IF (variable == 'M') variable = 'm'
	1466	IF (variable == 'H') variable = 'h'
	1467
	1468	ibs = ids
	1469	ibe = ide-1
	1470	itf = min(ite,ide-1)
	1471	jbs = jds
	1472	jbe = jde-1
	1473	jtf = min(jte,jde-1)
	1474	ktf = kde-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
	1481
	1482	IF (jts - jbs .lt. spec_zone) THEN
	1483	! Y-start boundary
	1484	DO j = jts, min(jtf,jbs+spec_zone-1)
	1485	b_dist = j - jbs
	1486	b_limit = b_dist
	1487	IF(periodic_x)b_limit = 0
	1488	DO k = kts, ktf
	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)
	1491	ENDDO
	1492	ENDDO
	1493	ENDDO
	1494	ENDIF
	1495	IF (jbe - jtf .lt. spec_zone) THEN
	1496	! Y-end boundary
	1497	DO j = max(jts,jbe-spec_zone+1), jtf
	1498	b_dist = jbe - j
	1499	b_limit = b_dist
	1500	IF(periodic_x)b_limit = 0
	1501	DO k = kts, ktf
	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)
	1504	ENDDO
	1505	ENDDO
	1506	ENDDO
	1507	ENDIF
	1508
	1509	IF(.NOT.periodic_x)THEN
	1510	IF (its - ibs .lt. spec_zone) THEN
	1511	! X-start boundary
	1512	DO i = its, min(itf,ibs+spec_zone-1)
	1513	b_dist = i - ibs
	1514	DO k = kts, ktf
	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)
	1517	ENDDO
	1518	ENDDO
	1519	ENDDO
	1520	ENDIF
	1521
	1522	IF (ibe - itf .lt. spec_zone) THEN
	1523	! X-end boundary
	1524	DO i = max(its,ibe-spec_zone+1), itf
	1525	b_dist = ibe - i
	1526	DO k = kts, ktf
	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)
	1529	ENDDO
	1530	ENDDO
	1531	ENDDO
	1532	ENDIF
	1533	ENDIF
	1534
	1535	END SUBROUTINE spec_bdyfield
	1536	!------------------------------------------------------------------------
	1537
	1538	SUBROUTINE spec_bdyupdate( field, &
	1539	field_tend, dt, &
	1540	variable_in, config_flags, &
	1541	spec_zone, &
	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 )
	1546
	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.
	1549	! (JD August 2000)
	1550
	1551	IMPLICIT NONE
	1552
	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
	1560
	1561
	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
	1565
	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
	1570
	1571	periodic_x = config_flags%periodic_x
	1572
	1573	variable = variable_in
	1574
	1575	IF (variable == 'U') variable = 'u'
	1576	IF (variable == 'V') variable = 'v'
	1577	IF (variable == 'M') variable = 'm'
	1578	IF (variable == 'H') variable = 'h'
	1579
	1580	ibs = ids
	1581	ibe = ide-1
	1582	itf = min(ite,ide-1)
	1583	jbs = jds
	1584	jbe = jde-1
	1585	jtf = min(jte,jde-1)
	1586	ktf = kde-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
	1593
	1594	IF (jts - jbs .lt. spec_zone) THEN
	1595	! Y-start boundary
	1596	DO j = jts, min(jtf,jbs+spec_zone-1)
	1597	b_dist = j - jbs
	1598	b_limit = b_dist
	1599	IF(periodic_x)b_limit = 0
	1600	DO k = kts, ktf
	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)
	1603	ENDDO
	1604	ENDDO
	1605	ENDDO
	1606	ENDIF
	1607	IF (jbe - jtf .lt. spec_zone) THEN
	1608	! Y-end boundary
	1609	DO j = max(jts,jbe-spec_zone+1), jtf
	1610	b_dist = jbe - j
	1611	b_limit = b_dist
	1612	IF(periodic_x)b_limit = 0
	1613	DO k = kts, ktf
	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)
	1616	ENDDO
	1617	ENDDO
	1618	ENDDO
	1619	ENDIF
	1620
	1621	IF(.NOT.periodic_x)THEN
	1622	IF (its - ibs .lt. spec_zone) THEN
	1623	! X-start boundary
	1624	DO i = its, min(itf,ibs+spec_zone-1)
	1625	b_dist = i - ibs
	1626	DO k = kts, ktf
	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)
	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	field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
	1641	ENDDO
	1642	ENDDO
	1643	ENDDO
	1644	ENDIF
	1645	ENDIF
	1646
	1647	END SUBROUTINE spec_bdyupdate
	1648	!------------------------------------------------------------------------
	1649
	1650	SUBROUTINE zero_grad_bdy ( field, &
	1651	variable_in, config_flags, &
	1652	spec_zone, &
	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 )
	1657
	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.
	1660	! (JD August 2000)
	1661
	1662	IMPLICIT NONE
	1663
	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
	1670
	1671
	1672	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
	1673	TYPE( grid_config_rec_type ) config_flags
	1674
	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
	1679
	1680	periodic_x = config_flags%periodic_x
	1681
	1682	variable = variable_in
	1683
	1684	IF (variable == 'U') variable = 'u'
	1685	IF (variable == 'V') variable = 'v'
	1686
	1687	ibs = ids
	1688	ibe = ide-1
	1689	itf = min(ite,ide-1)
	1690	jbs = jds
	1691	jbe = jde-1
	1692	jtf = min(jte,jde-1)
	1693	ktf = kde-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
	1699
	1700	IF (jts - jbs .lt. spec_zone) THEN
	1701	! Y-start boundary
	1702	DO j = jts, min(jtf,jbs+spec_zone-1)
	1703	b_dist = j - jbs
	1704	b_limit = b_dist
	1705	IF(periodic_x)b_limit = 0
	1706	DO k = kts, ktf
	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)
	1712	ENDDO
	1713	ENDDO
	1714	ENDDO
	1715	ENDIF
	1716	IF (jbe - jtf .lt. spec_zone) THEN
	1717	! Y-end boundary
	1718	DO j = max(jts,jbe-spec_zone+1), jtf
	1719	b_dist = jbe - j
	1720	b_limit = b_dist
	1721	IF(periodic_x)b_limit = 0
	1722	DO k = kts, ktf
	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)
	1728	ENDDO
	1729	ENDDO
	1730	ENDDO
	1731	ENDIF
	1732
	1733	IF(.NOT.periodic_x)THEN
	1734	IF (its - ibs .lt. spec_zone) THEN
	1735	! X-start boundary
	1736	DO i = its, min(itf,ibs+spec_zone-1)
	1737	b_dist = i - ibs
	1738	DO k = kts, ktf
	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)
	1743	ENDDO
	1744	ENDDO
	1745	ENDDO
	1746	ENDIF
	1747
	1748	IF (ibe - itf .lt. spec_zone) THEN
	1749	! X-end boundary
	1750	DO i = max(its,ibe-spec_zone+1), itf
	1751	b_dist = ibe - i
	1752	DO k = kts, ktf
	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)
	1757	ENDDO
	1758	ENDDO
	1759	ENDDO
	1760	ENDIF
	1761	ENDIF
	1762
	1763	END SUBROUTINE zero_grad_bdy
	1764	!------------------------------------------------------------------------
	1765
	1766	SUBROUTINE flow_dep_bdy ( field, &
	1767	u, v, config_flags, &
	1768	spec_zone, &
	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 )
	1773
	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.
	1778	! (JD August 2000)
	1779
	1780	IMPLICIT NONE
	1781
	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
	1787
	1788
	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
	1793
	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
	1797
	1798	periodic_x = config_flags%periodic_x
	1799
	1800	ibs = ids
	1801	ibe = ide-1
	1802	itf = min(ite,ide-1)
	1803	jbs = jds
	1804	jbe = jde-1
	1805	jtf = min(jte,jde-1)
	1806	ktf = kde-1
	1807
	1808	IF (jts - jbs .lt. spec_zone) THEN
	1809	! Y-start boundary
	1810	DO j = jts, min(jtf,jbs+spec_zone-1)
	1811	b_dist = j - jbs
	1812	b_limit = b_dist
	1813	IF(periodic_x)b_limit = 0
	1814	DO k = kts, ktf
	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)
	1821	ELSE
	1822	field(i,k,j) = 0.
	1823	ENDIF
	1824	ENDDO
	1825	ENDDO
	1826	ENDDO
	1827	ENDIF
	1828	IF (jbe - jtf .lt. spec_zone) THEN
	1829	! Y-end boundary
	1830	DO j = max(jts,jbe-spec_zone+1), jtf
	1831	b_dist = jbe - j
	1832	b_limit = b_dist
	1833	IF(periodic_x)b_limit = 0
	1834	DO k = kts, ktf
	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)
	1841	ELSE
	1842	field(i,k,j) = 0.
	1843	ENDIF
	1844	ENDDO
	1845	ENDDO
	1846	ENDDO
	1847	ENDIF
	1848
	1849	IF(.NOT.periodic_x)THEN
	1850	IF (its - ibs .lt. spec_zone) THEN
	1851	! X-start boundary
	1852	DO i = its, min(itf,ibs+spec_zone-1)
	1853	b_dist = i - ibs
	1854	DO k = kts, ktf
	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)
	1860	ELSE
	1861	field(i,k,j) = 0.
	1862	ENDIF
	1863	ENDDO
	1864	ENDDO
	1865	ENDDO
	1866	ENDIF
	1867
	1868	IF (ibe - itf .lt. spec_zone) THEN
	1869	! X-end boundary
	1870	DO i = max(its,ibe-spec_zone+1), itf
	1871	b_dist = ibe - i
	1872	DO k = kts, ktf
	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)
	1878	ELSE
	1879	field(i,k,j) = 0.
	1880	ENDIF
	1881	ENDDO
	1882	ENDDO
	1883	ENDDO
	1884	ENDIF
	1885	ENDIF
	1886
	1887	END SUBROUTINE flow_dep_bdy
	1888
	1889	!------------------------------------------------------------------------------
	1890
	1891	SUBROUTINE stuff_bdy_new ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
	1892	char_stagger , &
	1893	spec_bdy_width , &
	1894	ids, ide, jds, jde, kds, kde , &
	1895	ims, ime, jms, jme, kms, kme , &
	1896	its, ite, jts, jte, kts, kte )
	1897
	1898	! This routine puts the data in the 3d arrays into the proper locations
	1899	! for the lateral boundary arrays.
	1900
	1901	USE module_state_description
	1902
	1903	IMPLICIT NONE
	1904
	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
	1913
	1914	INTEGER :: i , ii , j , jj , k
	1915
	1916	! There are four lateral boundary locations that are stored.
	1917
	1918	! X start boundary
	1919
	1920	IF ( char_stagger .EQ. 'W' ) THEN
	1921	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	1922	DO k = kds , kde
	1923	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
	1924	space_bdy_xs(j,k,i) = data3d(i,k,j)
	1925	END DO
	1926	END DO
	1927	END DO
	1928	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	1929	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	1930	DO k = kds , kde
	1931	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
	1932	space_bdy_xs(j,k,i) = data3d(i,k,j)
	1933	END DO
	1934	END DO
	1935	END DO
	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)
	1941	END DO
	1942	END DO
	1943	END DO
	1944	ELSE
	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)
	1949	END DO
	1950	END DO
	1951	END DO
	1952	END IF
	1953
	1954	! X end boundary
	1955
	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
	1960	ii = ide - i + 1
	1961	space_bdy_xe(j,k,ii) = data3d(i,k,j)
	1962	END DO
	1963	END DO
	1964	END DO
	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
	1969	ii = ide - i
	1970	space_bdy_xe(j,k,ii) = data3d(i,k,j)
	1971	END DO
	1972	END DO
	1973	END DO
	1974	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	1975	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	1976	DO k = kds , kde
	1977	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	1978	ii = ide - i
	1979	space_bdy_xe(j,k,ii) = data3d(i,k,j)
	1980	END DO
	1981	END DO
	1982	END DO
	1983	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	1984	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	1985	DO k = kds , kde
	1986	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	1987	ii = ide - i
	1988	space_bdy_xe(j,k,ii) = data3d(i,k,j)
	1989	END DO
	1990	END DO
	1991	END DO
	1992	ELSE
	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
	1996	ii = ide - i
	1997	space_bdy_xe(j,k,ii) = data3d(i,k,j)
	1998	END DO
	1999	END DO
	2000	END DO
	2001	END IF
	2002
	2003	! Y start boundary
	2004
	2005	IF ( char_stagger .EQ. 'W' ) THEN
	2006	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2007	DO k = kds , kde
	2008	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2009	space_bdy_ys(i,k,j) = data3d(i,k,j)
	2010	END DO
	2011	END DO
	2012	END DO
	2013	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2014	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2015	DO k = kds , kde
	2016	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2017	space_bdy_ys(i,k,j) = data3d(i,k,j)
	2018	END DO
	2019	END DO
	2020	END DO
	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)
	2026	END DO
	2027	END DO
	2028	END DO
	2029	ELSE
	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)
	2034	END DO
	2035	END DO
	2036	END DO
	2037	END IF
	2038
	2039	! Y end boundary
	2040
	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)
	2045	jj = jde - j + 1
	2046	space_bdy_ye(i,k,jj) = data3d(i,k,j)
	2047	END DO
	2048	END DO
	2049	END DO
	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)
	2054	jj = jde - j
	2055	space_bdy_ye(i,k,jj) = data3d(i,k,j)
	2056	END DO
	2057	END DO
	2058	END DO
	2059	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2060	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2061	DO k = kds , kde
	2062	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2063	jj = jde - j
	2064	space_bdy_ye(i,k,jj) = data3d(i,k,j)
	2065	END DO
	2066	END DO
	2067	END DO
	2068	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2069	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2070	DO k = kds , kde
	2071	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2072	jj = jde - j
	2073	space_bdy_ye(i,k,jj) = data3d(i,k,j)
	2074	END DO
	2075	END DO
	2076	END DO
	2077	ELSE
	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)
	2081	jj = jde - j
	2082	space_bdy_ye(i,k,jj) = data3d(i,k,j)
	2083	END DO
	2084	END DO
	2085	END DO
	2086	END IF
	2087
	2088	END SUBROUTINE stuff_bdy_new
	2089
	2090	SUBROUTINE stuff_bdytend_new ( data3dnew , data3dold , time_diff , &
	2091	space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
	2092	char_stagger , &
	2093	spec_bdy_width , &
	2094	ids, ide, jds, jde, kds, kde , &
	2095	ims, ime, jms, jme, kms, kme , &
	2096	its, ite, jts, jte, kts, kte )
	2097
	2098	! This routine puts the tendency data into the proper locations
	2099	! for the lateral boundary arrays.
	2100
	2101	USE module_state_description
	2102
	2103	IMPLICIT NONE
	2104
	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
	2114
	2115	INTEGER :: i , ii , j , jj , k
	2116
	2117	! There are four lateral boundary locations that are stored.
	2118
	2119	! X start boundary
	2120
	2121	IF ( char_stagger .EQ. 'W' ) THEN
	2122	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2123	DO k = kds , kde
	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
	2126	END DO
	2127	END DO
	2128	END DO
	2129	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2130	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2131	DO k = kds , kde
	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
	2134	END DO
	2135	END DO
	2136	END DO
	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
	2142	END DO
	2143	END DO
	2144	END DO
	2145	ELSE
	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
	2150	END DO
	2151	END DO
	2152	END DO
	2153	END IF
	2154
	2155	! X end boundary
	2156
	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
	2161	ii = ide - i + 1
	2162	space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2163	END DO
	2164	END DO
	2165	END DO
	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
	2170	ii = ide - i
	2171	space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2172	END DO
	2173	END DO
	2174	END DO
	2175	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2176	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2177	DO k = kds , kde
	2178	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2179	ii = ide - i
	2180	space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2181	END DO
	2182	END DO
	2183	END DO
	2184	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2185	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2186	DO k = kds , kde
	2187	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2188	ii = ide - i
	2189	space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2190	END DO
	2191	END DO
	2192	END DO
	2193	ELSE
	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
	2197	ii = ide - i
	2198	space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2199	END DO
	2200	END DO
	2201	END DO
	2202	END IF
	2203
	2204	! Y start boundary
	2205
	2206	IF ( char_stagger .EQ. 'W' ) THEN
	2207	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2208	DO k = kds , kde
	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
	2211	END DO
	2212	END DO
	2213	END DO
	2214	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2215	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2216	DO k = kds , kde
	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
	2219	END DO
	2220	END DO
	2221	END DO
	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
	2227	END DO
	2228	END DO
	2229	END DO
	2230	ELSE
	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
	2235	END DO
	2236	END DO
	2237	END DO
	2238	END IF
	2239
	2240	! Y end boundary
	2241
	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)
	2246	jj = jde - j + 1
	2247	space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2248	END DO
	2249	END DO
	2250	END DO
	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)
	2255	jj = jde - j
	2256	space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2257	END DO
	2258	END DO
	2259	END DO
	2260	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2261	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2262	DO k = kds , kde
	2263	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2264	jj = jde - j
	2265	space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2266	END DO
	2267	END DO
	2268	END DO
	2269	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2270	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2271	DO k = kds , kde
	2272	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2273	jj = jde - j
	2274	space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2275	END DO
	2276	END DO
	2277	END DO
	2278	ELSE
	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)
	2282	jj = jde - j
	2283	space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
	2284	END DO
	2285	END DO
	2286	END DO
	2287	END IF
	2288
	2289	END SUBROUTINE stuff_bdytend_new
	2290
	2291	!--- old versions for use with modules that use the old bdy data structures ---
	2292
	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 )
	2298
	2299	! This routine puts the data in the 3d arrays into the proper locations
	2300	! for the lateral boundary arrays.
	2301
	2302	USE module_state_description
	2303
	2304	IMPLICIT NONE
	2305
	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
	2313
	2314	INTEGER :: i , ii , j , jj , k
	2315
	2316	! There are four lateral boundary locations that are stored.
	2317
	2318	! X start boundary
	2319
	2320	IF ( char_stagger .EQ. 'W' ) THEN
	2321	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2322	DO k = kds , kde
	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)
	2325	END DO
	2326	END DO
	2327	END DO
	2328	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2329	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2330	DO k = kds , kde
	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)
	2333	END DO
	2334	END DO
	2335	END DO
	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)
	2341	END DO
	2342	END DO
	2343	END DO
	2344	ELSE
	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)
	2349	END DO
	2350	END DO
	2351	END DO
	2352	END IF
	2353
	2354	! X end boundary
	2355
	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
	2360	ii = ide - i + 1
	2361	space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
	2362	END DO
	2363	END DO
	2364	END DO
	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
	2369	ii = ide - i
	2370	space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
	2371	END DO
	2372	END DO
	2373	END DO
	2374	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2375	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2376	DO k = kds , kde
	2377	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2378	ii = ide - i
	2379	space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
	2380	END DO
	2381	END DO
	2382	END DO
	2383	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2384	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2385	DO k = kds , kde
	2386	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2387	ii = ide - i
	2388	space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
	2389	END DO
	2390	END DO
	2391	END DO
	2392	ELSE
	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
	2396	ii = ide - i
	2397	space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
	2398	END DO
	2399	END DO
	2400	END DO
	2401	END IF
	2402
	2403	! Y start boundary
	2404
	2405	IF ( char_stagger .EQ. 'W' ) THEN
	2406	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2407	DO k = kds , kde
	2408	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2409	space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
	2410	END DO
	2411	END DO
	2412	END DO
	2413	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2414	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2415	DO k = kds , kde
	2416	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2417	space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
	2418	END DO
	2419	END DO
	2420	END DO
	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)
	2426	END DO
	2427	END DO
	2428	END DO
	2429	ELSE
	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)
	2434	END DO
	2435	END DO
	2436	END DO
	2437	END IF
	2438
	2439	! Y end boundary
	2440
	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)
	2445	jj = jde - j + 1
	2446	space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
	2447	END DO
	2448	END DO
	2449	END DO
	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)
	2454	jj = jde - j
	2455	space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
	2456	END DO
	2457	END DO
	2458	END DO
	2459	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2460	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2461	DO k = kds , kde
	2462	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2463	jj = jde - j
	2464	space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
	2465	END DO
	2466	END DO
	2467	END DO
	2468	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2469	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2470	DO k = kds , kde
	2471	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2472	jj = jde - j
	2473	space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
	2474	END DO
	2475	END DO
	2476	END DO
	2477	ELSE
	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)
	2481	jj = jde - j
	2482	space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
	2483	END DO
	2484	END DO
	2485	END DO
	2486	END IF
	2487
	2488	END SUBROUTINE stuff_bdy_old
	2489
	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 )
	2495
	2496	! This routine puts the tendency data into the proper locations
	2497	! for the lateral boundary arrays.
	2498
	2499	USE module_state_description
	2500
	2501	IMPLICIT NONE
	2502
	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
	2512
	2513	INTEGER :: i , ii , j , jj , k
	2514
	2515	! There are four lateral boundary locations that are stored.
	2516
	2517	! X start boundary
	2518
	2519	IF ( char_stagger .EQ. 'W' ) THEN
	2520	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2521	DO k = kds , kde
	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
	2525	END DO
	2526	END DO
	2527	END DO
	2528	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2529	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2530	DO k = kds , kde
	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
	2534	END DO
	2535	END DO
	2536	END DO
	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
	2543	END DO
	2544	END DO
	2545	END DO
	2546	ELSE
	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
	2552	END DO
	2553	END DO
	2554	END DO
	2555	END IF
	2556
	2557	! X end boundary
	2558
	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
	2563	ii = ide - i + 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
	2566	END DO
	2567	END DO
	2568	END DO
	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
	2573	ii = ide - i
	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
	2576	END DO
	2577	END DO
	2578	END DO
	2579	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2580	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2581	DO k = kds , kde
	2582	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2583	ii = ide - i
	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
	2586	END DO
	2587	END DO
	2588	END DO
	2589	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2590	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2591	DO k = kds , kde
	2592	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2593	ii = ide - i
	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
	2596	END DO
	2597	END DO
	2598	END DO
	2599	ELSE
	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
	2603	ii = ide - i
	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
	2606	END DO
	2607	END DO
	2608	END DO
	2609	END IF
	2610
	2611	! Y start boundary
	2612
	2613	IF ( char_stagger .EQ. 'W' ) THEN
	2614	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2615	DO k = kds , kde
	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
	2619	END DO
	2620	END DO
	2621	END DO
	2622	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2623	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
	2624	DO k = kds , kde
	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
	2628	END DO
	2629	END DO
	2630	END DO
	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
	2637	END DO
	2638	END DO
	2639	END DO
	2640	ELSE
	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
	2646	END DO
	2647	END DO
	2648	END DO
	2649	END IF
	2650
	2651	! Y end boundary
	2652
	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)
	2657	jj = jde - j + 1
	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
	2660	END DO
	2661	END DO
	2662	END DO
	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)
	2667	jj = jde - j
	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
	2670	END DO
	2671	END DO
	2672	END DO
	2673	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2674	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2675	DO k = kds , kde
	2676	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2677	jj = jde - j
	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
	2680	END DO
	2681	END DO
	2682	END DO
	2683	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2684	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2685	DO k = kds , kde
	2686	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2687	jj = jde - j
	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
	2690	END DO
	2691	END DO
	2692	END DO
	2693	ELSE
	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)
	2697	jj = jde - j
	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
	2700	END DO
	2701	END DO
	2702	END DO
	2703	END IF
	2704
	2705	END SUBROUTINE stuff_bdytend_old
	2706
	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 )
	2713
	2714	! This routine puts the data in the 3d arrays into the proper locations
	2715	! for the lateral boundary arrays.
	2716
	2717	USE module_state_description
	2718
	2719	IMPLICIT NONE
	2720
	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
	2731
	2732	INTEGER :: i , ii , j , jj , k
	2733
	2734	! There are four lateral boundary locations that are stored.
	2735
	2736	! X start boundary
	2737
	2738	IF ( char_stagger .EQ. 'W' ) THEN
	2739	DO k = kds , kde
	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)
	2743	END DO
	2744	END DO
	2745	END DO
	2746	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2747	DO k = kds , kde
	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)
	2751	END DO
	2752	END DO
	2753	END DO
	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)
	2759	END DO
	2760	END DO
	2761	END DO
	2762	ELSE
	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)
	2767	END DO
	2768	END DO
	2769	END DO
	2770	END IF
	2771
	2772	! X end boundary
	2773
	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
	2778	ii = ide - i + 1
	2779	space_bdy_xe(j,k,ii) = data3d(i,j,k)
	2780	END DO
	2781	END DO
	2782	END DO
	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
	2787	ii = ide - i
	2788	space_bdy_xe(j,k,ii) = data3d(i,j,k)
	2789	END DO
	2790	END DO
	2791	END DO
	2792	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2793	DO k = kds , kde
	2794	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2795	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2796	ii = ide - i
	2797	space_bdy_xe(j,k,ii) = data3d(i,j,k)
	2798	END DO
	2799	END DO
	2800	END DO
	2801	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2802	DO k = kds , kde
	2803	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	2804	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	2805	ii = ide - i
	2806	space_bdy_xe(j,k,ii) = data3d(i,j,k)
	2807	END DO
	2808	END DO
	2809	END DO
	2810	ELSE
	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
	2814	ii = ide - i
	2815	space_bdy_xe(j,k,ii) = data3d(i,j,k)
	2816	END DO
	2817	END DO
	2818	END DO
	2819	END IF
	2820
	2821	! Y start boundary
	2822
	2823	IF ( char_stagger .EQ. 'W' ) THEN
	2824	DO k = kds , kde
	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)
	2828	END DO
	2829	END DO
	2830	END DO
	2831	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2832	DO k = kds , kde
	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)
	2836	END DO
	2837	END DO
	2838	END DO
	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)
	2844	END DO
	2845	END DO
	2846	END DO
	2847	ELSE
	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)
	2852	END DO
	2853	END DO
	2854	END DO
	2855	END IF
	2856
	2857	! Y end boundary
	2858
	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)
	2863	jj = jde - j + 1
	2864	space_bdy_ye(i,k,jj) = data3d(i,j,k)
	2865	END DO
	2866	END DO
	2867	END DO
	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)
	2872	jj = jde - j
	2873	space_bdy_ye(i,k,jj) = data3d(i,j,k)
	2874	END DO
	2875	END DO
	2876	END DO
	2877	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	2878	DO k = kds , kde
	2879	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2880	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2881	jj = jde - j
	2882	space_bdy_ye(i,k,jj) = data3d(i,j,k)
	2883	END DO
	2884	END DO
	2885	END DO
	2886	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2887	DO k = kds , kde
	2888	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	2889	DO i = MAX(ids,its) , MIN(ide-1,ite)
	2890	jj = jde - j
	2891	space_bdy_ye(i,k,jj) = data3d(i,j,k)
	2892	END DO
	2893	END DO
	2894	END DO
	2895	ELSE
	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)
	2899	jj = jde - j
	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)
	2903	! endif
	2904
	2905	END DO
	2906	END DO
	2907	END DO
	2908	END IF
	2909
	2910	END SUBROUTINE stuff_bdy_ijk
	2911
	2912	SUBROUTINE stuff_bdytend_ijk ( data3dnew , data3dold , time_diff , &
	2913	space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
	2914	char_stagger , &
	2915	spec_bdy_width , &
	2916	ids, ide, jds, jde, kds, kde , &
	2917	ims, ime, jms, jme, kms, kme , &
	2918	its, ite, jts, jte, kts, kte )
	2919
	2920	! This routine puts the tendency data into the proper locations
	2921	! for the lateral boundary arrays.
	2922
	2923	USE module_state_description
	2924
	2925	IMPLICIT NONE
	2926
	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
	2935
	2936	CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
	2937	REAL , INTENT(IN) :: time_diff ! seconds
	2938
	2939	INTEGER :: i , ii , j , jj , k
	2940
	2941	! There are four lateral boundary locations that are stored.
	2942
	2943	! X start boundary
	2944
	2945	IF ( char_stagger .EQ. 'W' ) THEN
	2946	DO k = kds , kde
	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
	2950	END DO
	2951	END DO
	2952	END DO
	2953	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	2954	DO k = kds , kde
	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
	2958	END DO
	2959	END DO
	2960	END DO
	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
	2966	END DO
	2967	END DO
	2968	END DO
	2969	ELSE
	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
	2974	END DO
	2975	END DO
	2976	END DO
	2977	END IF
	2978
	2979	! X end boundary
	2980
	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
	2985	ii = ide - i + 1
	2986	space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	2987	END DO
	2988	END DO
	2989	END DO
	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
	2994	ii = ide - i
	2995	space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	2996	END DO
	2997	END DO
	2998	END DO
	2999	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	3000	DO k = kds , kde
	3001	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	3002	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	3003	ii = ide - i
	3004	space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3005	END DO
	3006	END DO
	3007	END DO
	3008	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	3009	DO k = kds , kde
	3010	DO j = MAX(jds,jts) , MIN(jde-1,jte)
	3011	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
	3012	ii = ide - i
	3013	space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3014	END DO
	3015	END DO
	3016	END DO
	3017	ELSE
	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
	3021	ii = ide - i
	3022	space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3023	END DO
	3024	END DO
	3025	END DO
	3026	END IF
	3027
	3028	! Y start boundary
	3029
	3030	IF ( char_stagger .EQ. 'W' ) THEN
	3031	DO k = kds , kde
	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
	3035	END DO
	3036	END DO
	3037	END DO
	3038	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	3039	DO k = kds , kde
	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
	3043	END DO
	3044	END DO
	3045	END DO
	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
	3051	END DO
	3052	END DO
	3053	END DO
	3054	ELSE
	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
	3059	END DO
	3060	END DO
	3061	END DO
	3062	END IF
	3063
	3064	! Y end boundary
	3065
	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)
	3070	jj = jde - j + 1
	3071	space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3072	END DO
	3073	END DO
	3074	END DO
	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)
	3079	jj = jde - j
	3080	space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3081	END DO
	3082	END DO
	3083	END DO
	3084	ELSE IF ( char_stagger .EQ. 'W' ) THEN
	3085	DO k = kds , kde
	3086	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	3087	DO i = MAX(ids,its) , MIN(ide-1,ite)
	3088	jj = jde - j
	3089	space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3090	END DO
	3091	END DO
	3092	END DO
	3093	ELSE IF ( char_stagger .EQ. 'M' ) THEN
	3094	DO k = kds , kde
	3095	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
	3096	DO i = MAX(ids,its) , MIN(ide-1,ite)
	3097	jj = jde - j
	3098	space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
	3099	END DO
	3100	END DO
	3101	END DO
	3102	ELSE
	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)
	3106	jj = jde - j
	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)
	3110	! endif
	3111	END DO
	3112	END DO
	3113	END DO
	3114	END IF
	3115
	3116	END SUBROUTINE stuff_bdytend_ijk
	3117
	3118	END MODULE module_bc
	3119
	3120	SUBROUTINE get_bdyzone_x ( bzx )
	3121	USE module_bc
	3122	IMPLICIT NONE
	3123	INTEGER bzx
	3124	bzx = bdyzone_x
	3125	END SUBROUTINE get_bdyzone_x
	3126
	3127	SUBROUTINE get_bdyzone_y ( bzy)
	3128	USE module_bc
	3129	IMPLICIT NONE
	3130	INTEGER bzy
	3131	bzy = bdyzone_y
	3132	END SUBROUTINE get_bdyzone_y
	3133
	3134	SUBROUTINE get_bdyzone ( bz)
	3135	USE module_bc
	3136	IMPLICIT NONE
	3137	INTEGER bz
	3138	bz = bdyzone
	3139	END SUBROUTINE get_bdyzone

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format