Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_bc.F @ 3567

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

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

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

Download in other formats:

Original Format