Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_bc.F @ 409

Last change on this file since 409 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 109.3 KB

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

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

Download in other formats:

Original Format