Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_bc.F @ 3553

Last change on this file since 3553 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 72.3 KB

Line
1	!WRF:MODEL_LAYER:BOUNDARY
2	!
3	MODULE module_bc
4
5	USE module_configure
6	USE module_wrf_error
7	IMPLICIT NONE
8
9	! TYPE bcs
10	!
11	! LOGICAL :: periodic_x
12	! LOGICAL :: symmetric_xs
13	! LOGICAL :: symmetric_xe
14	! LOGICAL :: open_xs
15	! LOGICAL :: open_xe
16	! LOGICAL :: periodic_y
17	! LOGICAL :: symmetric_ys
18	! LOGICAL :: symmetric_ye
19	! LOGICAL :: open_ys
20	! LOGICAL :: open_ye
21	! LOGICAL :: nested
22	! LOGICAL :: specified
23	! LOGICAL :: top_radiation
24	!
25	! END TYPE bcs
26
27	! set the bdyzone. We are hardwiring this here and we'll
28	! decide later where it should be set and stored
29
30	INTEGER, PARAMETER :: bdyzone = 4
31	INTEGER, PARAMETER :: bdyzone_x = bdyzone
32	INTEGER, PARAMETER :: bdyzone_y = bdyzone
33
34	CONTAINS
35
36	SUBROUTINE boundary_condition_check ( config_flags, bzone, error, gn )
37
38	! this routine checks the boundary condition logicals
39	! to make sure that the boundary conditions are not over
40	! or under specified. The routine also checks that the
41	! boundary zone is sufficiently sized for the specified
42	! boundary conditions
43
44	IMPLICIT NONE
45
46	TYPE( grid_config_rec_type ) config_flags
47
48	INTEGER, INTENT(IN ) :: bzone, gn
49	INTEGER, INTENT(INOUT) :: error
50
51	! local variables
52
53	INTEGER :: xs_bc, xe_bc, ys_bc, ye_bc, bzone_min
54	INTEGER :: nprocx, nprocy
55
56	CALL wrf_debug( 100 , ' checking boundary conditions for grid ' )
57
58	error = 0
59	xs_bc = 0
60	xe_bc = 0
61	ys_bc = 0
62	ye_bc = 0
63
64	! sum the number of conditions specified for each lateral boundary.
65	! obviously, this number should be 1
66
67	IF( config_flags%periodic_x ) THEN
68	xs_bc = xs_bc+1
69	xe_bc = xe_bc+1
70	ENDIF
71
72	IF( config_flags%periodic_y ) THEN
73	ys_bc = ys_bc+1
74	ye_bc = ye_bc+1
75	ENDIF
76
77	IF( config_flags%symmetric_xs ) xs_bc = xs_bc + 1
78	IF( config_flags%symmetric_xe ) xe_bc = xe_bc + 1
79	IF( config_flags%open_xs ) xs_bc = xs_bc + 1
80	IF( config_flags%open_xe ) xe_bc = xe_bc + 1
81
82
83	IF( config_flags%symmetric_ys ) ys_bc = ys_bc + 1
84	IF( config_flags%symmetric_ye ) ye_bc = ye_bc + 1
85	IF( config_flags%open_ys ) ys_bc = ys_bc + 1
86	IF( config_flags%open_ye ) ye_bc = ye_bc + 1
87
88	IF( config_flags%nested ) THEN
89	xs_bc = xs_bc + 1
90	xe_bc = xe_bc + 1
91	ys_bc = ys_bc + 1
92	ye_bc = ye_bc + 1
93	ENDIF
94
95	IF( config_flags%specified ) THEN
96	IF( .NOT. config_flags%periodic_x)xs_bc = xs_bc + 1
97	IF( .NOT. config_flags%periodic_x)xe_bc = xe_bc + 1
98	ys_bc = ys_bc + 1
99	ye_bc = ye_bc + 1
100	ENDIF
101
102	! check the number of conditions for each boundary
103
104	IF( (xs_bc /= 1) .or. &
105	(xe_bc /= 1) .or. &
106	(ys_bc /= 1) .or. &
107	(ye_bc /= 1) ) THEN
108
109	error = 1
110
111	write( wrf_err_message ,) ' ** Error in boundary condition specification '
112	CALL wrf_message ( wrf_err_message )
113	write( wrf_err_message ,*) ' boundary conditions at xs ', xs_bc
114	CALL wrf_message ( wrf_err_message )
115	write( wrf_err_message ,*) ' boundary conditions at xe ', xe_bc
116	CALL wrf_message ( wrf_err_message )
117	write( wrf_err_message ,*) ' boundary conditions at ys ', ys_bc
118	CALL wrf_message ( wrf_err_message )
119	write( wrf_err_message ,*) ' boundary conditions at ye ', ye_bc
120	CALL wrf_message ( wrf_err_message )
121	write( wrf_err_message ,*) ' boundary conditions logicals are '
122	CALL wrf_message ( wrf_err_message )
123	write( wrf_err_message ,*) ' periodic_x ',config_flags%periodic_x
124	CALL wrf_message ( wrf_err_message )
125	write( wrf_err_message ,*) ' periodic_y ',config_flags%periodic_y
126	CALL wrf_message ( wrf_err_message )
127	write( wrf_err_message ,*) ' symmetric_xs ',config_flags%symmetric_xs
128	CALL wrf_message ( wrf_err_message )
129	write( wrf_err_message ,*) ' symmetric_xe ',config_flags%symmetric_xe
130	CALL wrf_message ( wrf_err_message )
131	write( wrf_err_message ,*) ' symmetric_ys ',config_flags%symmetric_ys
132	CALL wrf_message ( wrf_err_message )
133	write( wrf_err_message ,*) ' symmetric_ye ',config_flags%symmetric_ye
134	CALL wrf_message ( wrf_err_message )
135	write( wrf_err_message ,*) ' open_xs ',config_flags%open_xs
136	CALL wrf_message ( wrf_err_message )
137	write( wrf_err_message ,*) ' open_xe ',config_flags%open_xe
138	CALL wrf_message ( wrf_err_message )
139	write( wrf_err_message ,*) ' open_ys ',config_flags%open_ys
140	CALL wrf_message ( wrf_err_message )
141	write( wrf_err_message ,*) ' open_ye ',config_flags%open_ye
142	CALL wrf_message ( wrf_err_message )
143	write( wrf_err_message ,*) ' nested ',config_flags%nested
144	CALL wrf_message ( wrf_err_message )
145	write( wrf_err_message ,*) ' specified ',config_flags%specified
146	CALL wrf_error_fatal( ' *** Error in boundary condition specification ' )
147
148	ENDIF
149
150	! now check to see if boundary zone size is sufficient.
151	! we could have the necessary boundary zone size be returned
152	! to the calling routine.
153
154	IF( config_flags%periodic_x .or. &
155	config_flags%periodic_y .or. &
156	config_flags%symmetric_xs .or. &
157	config_flags%symmetric_xe .or. &
158	config_flags%symmetric_ys .or. &
159	config_flags%symmetric_ye ) THEN
160
161	bzone_min = MAX( 1, &
162	(config_flags%h_mom_adv_order+1)/2, &
163	(config_flags%h_sca_adv_order+1)/2 )
164
165	IF( bzone < bzone_min) THEN
166
167	error = 2
168	WRITE ( wrf_err_message , * ) ' boundary zone not large enough '
169	CALL wrf_message ( wrf_err_message )
170	WRITE ( wrf_err_message , * ) ' boundary zone specified ',bzone
171	CALL wrf_message ( wrf_err_message )
172	WRITE ( wrf_err_message , * ) ' minimum boundary zone needed ',bzone_min
173	CALL wrf_error_fatal ( wrf_err_message )
174
175	ENDIF
176	ENDIF
177
178	#ifdef RSL_LITE
179	! add a check so that people do not try to specify peridic boundaries
180	! if they have compiled with RSL_LITE. It does not support periodic bcs
181	CALL wrf_get_nprocx( nprocx )
182	#if 0
183	IF ( nprocx .GT. 1 .AND. config_flags%periodic_x ) THEN
184	WRITE ( wrf_err_message , * ) 'RSL_LITE does not support periodic boundaries for decomposed X-dimension'
185	CALL wrf_message ( TRIM( wrf_err_message ) )
186	ENDIF
187	#endif
188	CALL wrf_get_nprocy( nprocy )
189	IF ( nprocy .GT. 1 .AND. config_flags%periodic_y ) THEN
190	WRITE ( wrf_err_message , * ) 'RSL_LITE does not support periodic boundaries for decomposed Y-dimension'
191	CALL wrf_message ( TRIM( wrf_err_message ) )
192	ENDIF
193	#if 0
194	IF ( (nprocy .GT. 1 .AND. config_flags%periodic_y) .OR. (nprocx .GT. 1 .AND. config_flags%periodic_x) ) THEN
195	CALL wrf_error_fatal ( 'Inappropriate selection of periodic bcs detected in boundary_condition_check' )
196	ENDIF
197	#endif
198	#endif
199
200	CALL wrf_debug ( 100 , ' boundary conditions OK for grid ' )
201
202	END subroutine boundary_condition_check
203
204	!--------------------------------------------------------------------------
205	SUBROUTINE set_physical_bc2d( data, variable_in, &
206	config_flags, &
207	ids,ide, jds,jde, & ! domain dims
208	ims,ime, jms,jme, & ! memory dims
209	ips,ipe, jps,jpe, & ! patch dims
210	its,ite, jts,jte )
211
212	! This subroutine sets the data in the boundary region, by direct
213	! assignment if possible, for periodic and symmetric (wall)
214	! boundary conditions. Currently, we are only doing 1 variable
215	! at a time - lots of overhead, so maybe this routine can be easily
216	! inlined later or we could pass multiple variables -
217	! would probably want a largestep and smallstep version.
218
219	! 15 Jan 99, Dave
220	! Modified the incoming its,ite,jts,jte to truly be the tile size.
221	! This required modifying the loop limits when the "istag" or "jstag"
222	! is used, as this is only required at the end of the domain.
223
224	IMPLICIT NONE
225
226	INTEGER, INTENT(IN ) :: ids,ide, jds,jde
227	INTEGER, INTENT(IN ) :: ims,ime, jms,jme
228	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe
229	INTEGER, INTENT(IN ) :: its,ite, jts,jte
230	CHARACTER, INTENT(IN ) :: variable_in
231
232	CHARACTER :: variable
233
234	REAL, DIMENSION( ims:ime , jms:jme ) :: data
235	TYPE( grid_config_rec_type ) config_flags
236
237	INTEGER :: i, j, istag, jstag, itime
238
239	LOGICAL :: debug, open_bc_copy
240
241	!------------
242
243	debug = .false.
244
245	open_bc_copy = .false.
246
247	variable = variable_in
248	IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
249	variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
250	ENDIF
251	IF ((variable == 'u') .or. (variable == 'v') .or. &
252	(variable == 'w') .or. (variable == 't') .or. &
253	(variable == 'x') .or. (variable == 'y') .or. &
254	(variable == 'r') .or. (variable == 'p') ) open_bc_copy = .true.
255
256	! begin, first set a staggering variable
257
258	istag = -1
259	jstag = -1
260
261	IF ((variable == 'u') .or. (variable == 'x')) istag = 0
262	IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
263
264	if(debug) then
265	write(6,*) ' in bc2d, var is ',variable, istag, jstag
266	write(6,*) ' b.cs are ', &
267	config_flags%periodic_x, &
268	config_flags%periodic_y
269	end if
270
271
272
273	! periodic conditions.
274	! note, patch must cover full range in periodic dir, or else
275	! its intra-patch communication that is handled elsewheres.
276	! symmetry conditions can always be handled here, because no
277	! outside patch communication is needed
278
279	periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
280	IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if east and west both on-processor
281	IF ( its == ids ) THEN
282
283	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
284	DO i = 0,-(bdyzone-1),-1
285	data(ids+i-1,j) = data(ide+i-1,j)
286	ENDDO
287	ENDDO
288
289	ENDIF
290
291	IF ( ite == ide ) THEN
292
293	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
294	!! DO i = 1 , bdyzone
295	DO i = -istag , bdyzone
296	data(ide+i+istag,j) = data(ids+i+istag,j)
297	ENDDO
298	ENDDO
299
300	ENDIF
301	ENDIF
302
303	ELSE
304
305	symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
306	( its == ids ) ) THEN
307
308	IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
309
310	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
311	DO i = 1, bdyzone
312	data(ids-i,j) = data(ids+i-1,j) ! here, data(0) = data(1), etc
313	ENDDO ! symmetry about data(0.5) (u=0 pt)
314	ENDDO
315
316	ELSE
317
318	IF( variable == 'u' ) THEN
319
320	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
321	DO i = 0, bdyzone-1
322	data(ids-i,j) = - data(ids+i,j) ! here, u(0) = - u(2), etc
323	ENDDO ! normal b.c symmetry at u(1)
324	ENDDO
325
326	ELSE
327
328	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
329	DO i = 0, bdyzone-1
330	data(ids-i,j) = data(ids+i,j) ! here, phi(0) = phi(2), etc
331	ENDDO ! normal b.c symmetry at phi(1)
332	ENDDO
333
334	END IF
335
336	ENDIF
337
338	ENDIF symmetry_xs
339
340
341	! now the symmetry boundary at xe
342
343	symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
344	( ite == ide ) ) THEN
345
346	IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
347
348	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
349	DO i = 1, bdyzone
350	data(ide+i-1,j) = data(ide-i,j) ! sym. about data(ide-0.5)
351	ENDDO
352	ENDDO
353
354	ELSE
355
356	IF (variable == 'u' ) THEN
357
358	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
359	DO i = 0, bdyzone-1
360	data(ide+i,j) = - data(ide-i,j) ! u(ide+1) = - u(ide-1), etc.
361	ENDDO
362	ENDDO
363
364
365	ELSE
366
367	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
368	DO i = 0, bdyzone-1
369	data(ide+i,j) = data(ide-i,j) ! phi(ide+1) = phi(ide-1), etc.
370	ENDDO
371	ENDDO
372
373	END IF
374
375	END IF
376
377	END IF symmetry_xe
378
379
380	! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
381
382	open_xs: IF( ( config_flags%open_xs .or. &
383	config_flags%specified .or. &
384	config_flags%nested ) .and. &
385	( its == ids ) .and. open_bc_copy ) THEN
386
387	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
388	data(ids-1,j) = data(ids,j) ! here, data(0) = data(1)
389	data(ids-2,j) = data(ids,j)
390	data(ids-3,j) = data(ids,j)
391	ENDDO
392
393	ENDIF open_xs
394
395
396	! now the open boundary copy at xe
397
398	open_xe: IF( ( config_flags%open_xe .or. &
399	config_flags%specified .or. &
400	config_flags%nested ) .and. &
401	( ite == ide ) .and. open_bc_copy ) THEN
402
403	IF ( variable /= 'u' .and. variable /= 'x') THEN
404
405	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
406	data(ide ,j) = data(ide-1,j)
407	data(ide+1,j) = data(ide-1,j)
408	data(ide+2,j) = data(ide-1,j)
409	ENDDO
410
411	ELSE
412
413	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
414	data(ide+1,j) = data(ide,j)
415	data(ide+2,j) = data(ide,j)
416	data(ide+3,j) = data(ide,j)
417	ENDDO
418
419	END IF
420
421	END IF open_xe
422
423	! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
424
425	END IF periodicity_x
426
427	! same procedure in y
428
429	periodicity_y: IF( ( config_flags%periodic_y ) ) THEN
430	IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test of both north and south on processor
431
432	IF( jts == jds ) then
433
434	DO j = 0, -(bdyzone-1), -1
435	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
436	data(i,jds+j-1) = data(i,jde+j-1)
437	ENDDO
438	ENDDO
439
440	END IF
441
442	IF( jte == jde ) then
443
444	DO j = -jstag, bdyzone
445	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
446	data(i,jde+j+jstag) = data(i,jds+j+jstag)
447	ENDDO
448	ENDDO
449
450	END IF
451
452	END IF
453
454	ELSE
455
456	symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
457	( jts == jds) ) THEN
458
459	IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
460
461	DO j = 1, bdyzone
462	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
463	data(i,jds-j) = data(i,jds+j-1)
464	ENDDO
465	ENDDO
466
467	ELSE
468
469	IF (variable == 'v') THEN
470
471	DO j = 1, bdyzone
472	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
473	data(i,jds-j) = - data(i,jds+j)
474	ENDDO
475	ENDDO
476
477	ELSE
478
479	DO j = 1, bdyzone
480	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
481	data(i,jds-j) = data(i,jds+j)
482	ENDDO
483	ENDDO
484
485	END IF
486
487	ENDIF
488
489	ENDIF symmetry_ys
490
491	! now the symmetry boundary at ye
492
493	symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
494	( jte == jde ) ) THEN
495
496	IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
497
498	DO j = 1, bdyzone
499	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
500	data(i,jde+j-1) = data(i,jde-j)
501	ENDDO
502	ENDDO
503
504	ELSE
505
506	IF (variable == 'v' ) THEN
507
508	DO j = 1, bdyzone
509	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
510	data(i,jde+j) = - data(i,jde-j) ! bugfix: changed jds on rhs to jde , JM 20020410
511	ENDDO
512	ENDDO
513
514	ELSE
515
516	DO j = 1, bdyzone
517	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
518	data(i,jde+j) = data(i,jde-j)
519	ENDDO
520	ENDDO
521
522	END IF
523
524	ENDIF
525
526	END IF symmetry_ye
527
528	! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
529
530	open_ys: IF( ( config_flags%open_ys .or. &
531	config_flags%specified .or. &
532	config_flags%nested ) .and. &
533	( jts == jds) .and. open_bc_copy ) THEN
534
535	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
536	data(i,jds-1) = data(i,jds)
537	data(i,jds-2) = data(i,jds)
538	data(i,jds-3) = data(i,jds)
539	ENDDO
540
541	ENDIF open_ys
542
543	! now the open boundary copy at ye
544
545	open_ye: IF( ( config_flags%open_ye .or. &
546	config_flags%specified .or. &
547	config_flags%nested ) .and. &
548	( jte == jde ) .and. open_bc_copy ) THEN
549
550	IF (variable /= 'v' .and. variable /= 'y' ) THEN
551
552	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
553	data(i,jde ) = data(i,jde-1)
554	data(i,jde+1) = data(i,jde-1)
555	data(i,jde+2) = data(i,jde-1)
556	ENDDO
557
558	ELSE
559
560	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
561	data(i,jde+1) = data(i,jde)
562	data(i,jde+2) = data(i,jde)
563	data(i,jde+3) = data(i,jde)
564	ENDDO
565
566	ENDIF
567
568	END IF open_ye
569
570	! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
571
572	END IF periodicity_y
573
574	! fix corners for doubly periodic domains
575
576	IF ( config_flags%periodic_x .and. config_flags%periodic_y &
577	.and. (ids == ips) .and. (ide == ipe) &
578	.and. (jds == jps) .and. (jde == jpe) ) THEN
579
580	IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
581	DO j = 0, -(bdyzone-1), -1
582	DO i = 0, -(bdyzone-1), -1
583	data(ids+i-1,jds+j-1) = data(ide+i-1,jde+j-1)
584	ENDDO
585	ENDDO
586	END IF
587
588	IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
589	DO j = 0, -(bdyzone-1), -1
590	DO i = 1, bdyzone
591	data(ide+i+istag,jds+j-1) = data(ids+i+istag,jde+j-1)
592	ENDDO
593	ENDDO
594	END IF
595
596	IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
597	DO j = 1, bdyzone
598	DO i = 1, bdyzone
599	data(ide+i+istag,jde+j+jstag) = data(ids+i+istag,jds+j+jstag)
600	ENDDO
601	ENDDO
602	END IF
603
604	IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
605	DO j = 1, bdyzone
606	DO i = 0, -(bdyzone-1), -1
607	data(ids+i-1,jde+j+jstag) = data(ide+i-1,jds+j+jstag)
608	ENDDO
609	ENDDO
610	END IF
611
612	END IF
613
614	END SUBROUTINE set_physical_bc2d
615
616	!-----------------------------------
617
618	SUBROUTINE set_physical_bc3d( data, variable_in, &
619	config_flags, &
620	ids,ide, jds,jde, kds,kde, & ! domain dims
621	ims,ime, jms,jme, kms,kme, & ! memory dims
622	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
623	its,ite, jts,jte, kts,kte )
624
625	! This subroutine sets the data in the boundary region, by direct
626	! assignment if possible, for periodic and symmetric (wall)
627	! boundary conditions. Currently, we are only doing 1 variable
628	! at a time - lots of overhead, so maybe this routine can be easily
629	! inlined later or we could pass multiple variables -
630	! would probably want a largestep and smallstep version.
631
632	! 15 Jan 99, Dave
633	! Modified the incoming its,ite,jts,jte to truly be the tile size.
634	! This required modifying the loop limits when the "istag" or "jstag"
635	! is used, as this is only required at the end of the domain.
636
637	IMPLICIT NONE
638
639	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
640	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
641	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
642	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
643	CHARACTER, INTENT(IN ) :: variable_in
644
645	CHARACTER :: variable
646
647	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: data
648	TYPE( grid_config_rec_type ) config_flags
649
650	INTEGER :: i, j, k, istag, jstag, itime, k_end
651
652	LOGICAL :: debug, open_bc_copy
653
654	!------------
655
656	debug = .false.
657
658	open_bc_copy = .false.
659
660	variable = variable_in
661	IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
662	variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
663	ENDIF
664
665	IF ((variable == 'u') .or. (variable == 'v') .or. &
666	(variable == 'w') .or. (variable == 't') .or. &
667	(variable == 'd') .or. (variable == 'e') .or. &
668	(variable == 'x') .or. (variable == 'y') .or. &
669	(variable == 'f') .or. (variable == 'r') .or. &
670	(variable == 'p') ) open_bc_copy = .true.
671
672	! begin, first set a staggering variable
673
674	istag = -1
675	jstag = -1
676	k_end = max(1,min(kde-1,kte))
677
678
679	IF ((variable == 'u') .or. (variable == 'x')) istag = 0
680	IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
681	IF ((variable == 'd') .or. (variable == 'xy')) then
682	istag = 0
683	jstag = 0
684	ENDIF
685	IF ((variable == 'e') ) then
686	istag = 0
687	k_end = min(kde,kte)
688	ENDIF
689
690	IF ((variable == 'f') ) then
691	jstag = 0
692	k_end = min(kde,kte)
693	ENDIF
694
695	IF ( variable == 'w') k_end = min(kde,kte)
696
697	! k_end = kte
698
699	if(debug) then
700	write(6,*) ' in bc, var is ',variable, istag, jstag, kte, k_end
701	write(6,*) ' b.cs are ', &
702	config_flags%periodic_x, &
703	config_flags%periodic_y
704	end if
705
706
707
708	! periodic conditions.
709	! note, patch must cover full range in periodic dir, or else
710	! its intra-patch communication that is handled elsewheres.
711	! symmetry conditions can always be handled here, because no
712	! outside patch communication is needed
713
714	periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
715
716	IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if both east and west on-processor
717	IF ( its == ids ) THEN
718
719	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
720	DO k = kts, k_end
721	DO i = 0,-(bdyzone-1),-1
722	data(ids+i-1,k,j) = data(ide+i-1,k,j)
723	ENDDO
724	ENDDO
725	ENDDO
726
727	ENDIF
728
729
730	IF ( ite == ide ) THEN
731
732	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
733	DO k = kts, k_end
734	DO i = -istag , bdyzone
735	data(ide+i+istag,k,j) = data(ids+i+istag,k,j)
736	ENDDO
737	ENDDO
738	ENDDO
739
740	ENDIF
741
742	ENDIF
743
744	ELSE
745
746	symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
747	( its == ids ) ) THEN
748
749	IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
750
751	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
752	DO k = kts, k_end
753	DO i = 1, bdyzone
754	data(ids-i,k,j) = data(ids+i-1,k,j) ! here, data(0) = data(1), etc
755	ENDDO ! symmetry about data(0.5) (u = 0 pt)
756	ENDDO
757	ENDDO
758
759	ELSE
760
761	IF ( variable == 'u' ) THEN
762
763	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
764	DO k = kts, k_end
765	DO i = 1, bdyzone
766	data(ids-i,k,j) = - data(ids+i,k,j) ! here, u(0) = - u(2), etc
767	ENDDO ! normal b.c symmetry at u(1)
768	ENDDO
769	ENDDO
770
771	ELSE
772
773	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
774	DO k = kts, k_end
775	DO i = 1, bdyzone
776	data(ids-i,k,j) = data(ids+i,k,j) ! here, phi(0) = phi(2), etc
777	ENDDO ! normal b.c symmetry at phi(1)
778	ENDDO
779	ENDDO
780
781	END IF
782
783	ENDIF
784
785	ENDIF symmetry_xs
786
787
788	! now the symmetry boundary at xe
789
790	symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
791	( ite == ide ) ) THEN
792
793	IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
794
795	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
796	DO k = kts, k_end
797	DO i = 1, bdyzone
798	data(ide+i-1,k,j) = data(ide-i,k,j) ! sym. about data(ide-0.5)
799	ENDDO
800	ENDDO
801	ENDDO
802
803	ELSE
804
805	IF (variable == 'u') THEN
806
807	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
808	DO k = kts, k_end
809	DO i = 1, bdyzone
810	data(ide+i,k,j) = - data(ide-i,k,j) ! u(ide+1) = - u(ide-1), etc.
811	ENDDO
812	ENDDO
813	ENDDO
814
815	ELSE
816
817	DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
818	DO k = kts, k_end
819	DO i = 1, bdyzone
820	data(ide+i,k,j) = data(ide-i,k,j) ! phi(ide+1) = - phi(ide-1), etc.
821	ENDDO
822	ENDDO
823	ENDDO
824
825	END IF
826
827	END IF
828
829	END IF symmetry_xe
830
831	! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
832
833	open_xs: IF( ( config_flags%open_xs .or. &
834	config_flags%specified .or. &
835	config_flags%nested ) .and. &
836	( its == ids ) .and. open_bc_copy ) THEN
837
838	DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
839	DO k = kts, k_end
840	data(ids-1,k,j) = data(ids,k,j) ! here, data(0) = data(1), etc
841	data(ids-2,k,j) = data(ids,k,j)
842	data(ids-3,k,j) = data(ids,k,j)
843	ENDDO
844	ENDDO
845
846	ENDIF open_xs
847
848
849	! now the open_xe boundary copy
850
851	open_xe: IF( ( config_flags%open_xe .or. &
852	config_flags%specified .or. &
853	config_flags%nested ) .and. &
854	( ite == ide ) .and. open_bc_copy ) THEN
855
856	IF (variable /= 'u' .and. variable /= 'x' ) THEN
857
858	DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
859	DO k = kts, k_end
860	data(ide ,k,j) = data(ide-1,k,j)
861	data(ide+1,k,j) = data(ide-1,k,j)
862	data(ide+2,k,j) = data(ide-1,k,j)
863	ENDDO
864	ENDDO
865
866	ELSE
867
868	!!!!!!! I am not sure about this one! JM 20020402
869	DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone
870	DO k = kts, k_end
871	data(ide+1,k,j) = data(ide,k,j)
872	data(ide+2,k,j) = data(ide,k,j)
873	data(ide+3,k,j) = data(ide,k,j)
874	ENDDO
875	ENDDO
876
877	END IF
878
879	END IF open_xe
880
881	! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
882
883	END IF periodicity_x
884
885	! same procedure in y
886
887	periodicity_y: IF( ( config_flags%periodic_y ) ) THEN
888	IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test if both north and south on processor
889	IF( jts == jds ) then
890
891	DO j = 0, -(bdyzone-1), -1
892	DO k = kts, k_end
893	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
894	data(i,k,jds+j-1) = data(i,k,jde+j-1)
895	ENDDO
896	ENDDO
897	ENDDO
898
899	END IF
900
901	IF( jte == jde ) then
902
903	DO j = -jstag, bdyzone
904	DO k = kts, k_end
905	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
906	data(i,k,jde+j+jstag) = data(i,k,jds+j+jstag)
907	ENDDO
908	ENDDO
909	ENDDO
910
911	END IF
912
913	END IF
914
915	ELSE
916
917	symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
918	( jts == jds) ) THEN
919
920	IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
921
922	DO j = 1, bdyzone
923	DO k = kts, k_end
924	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
925	data(i,k,jds-j) = data(i,k,jds+j-1)
926	ENDDO
927	ENDDO
928	ENDDO
929
930	ELSE
931
932	IF (variable == 'v') THEN
933
934	DO j = 1, bdyzone
935	DO k = kts, k_end
936	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
937	data(i,k,jds-j) = - data(i,k,jds+j)
938	ENDDO
939	ENDDO
940	ENDDO
941
942	ELSE
943
944	DO j = 1, bdyzone
945	DO k = kts, k_end
946	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
947	data(i,k,jds-j) = data(i,k,jds+j)
948	ENDDO
949	ENDDO
950	ENDDO
951
952	END IF
953
954	ENDIF
955
956	ENDIF symmetry_ys
957
958	! now the symmetry boundary at ye
959
960	symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
961	( jte == jde ) ) THEN
962
963	IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
964
965	DO j = 1, bdyzone
966	DO k = kts, k_end
967	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
968	data(i,k,jde+j-1) = data(i,k,jde-j)
969	ENDDO
970	ENDDO
971	ENDDO
972
973	ELSE
974
975	IF ( variable == 'v' ) THEN
976
977	DO j = 1, bdyzone
978	DO k = kts, k_end
979	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
980	data(i,k,jde+j) = - data(i,k,jde-j)
981	ENDDO
982	ENDDO
983	ENDDO
984
985	ELSE
986
987	DO j = 1, bdyzone
988	DO k = kts, k_end
989	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
990	data(i,k,jde+j) = data(i,k,jde-j)
991	ENDDO
992	ENDDO
993	ENDDO
994
995	END IF
996
997	ENDIF
998
999	END IF symmetry_ye
1000
1001	! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
1002
1003	open_ys: IF( ( config_flags%open_ys .or. &
1004	config_flags%specified .or. &
1005	config_flags%nested ) .and. &
1006	( jts == jds) .and. open_bc_copy ) THEN
1007
1008	DO k = kts, k_end
1009	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1010	data(i,k,jds-1) = data(i,k,jds)
1011	data(i,k,jds-2) = data(i,k,jds)
1012	data(i,k,jds-3) = data(i,k,jds)
1013	ENDDO
1014	ENDDO
1015
1016	ENDIF open_ys
1017
1018	! now the open boundary copy at ye
1019
1020	open_ye: IF( ( config_flags%open_ye .or. &
1021	config_flags%specified .or. &
1022	config_flags%nested ) .and. &
1023	( jte == jde ) .and. open_bc_copy ) THEN
1024
1025	IF (variable /= 'v' .and. variable /= 'y' ) THEN
1026
1027	DO k = kts, k_end
1028	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1029	data(i,k,jde ) = data(i,k,jde-1)
1030	data(i,k,jde+1) = data(i,k,jde-1)
1031	data(i,k,jde+2) = data(i,k,jde-1)
1032	ENDDO
1033	ENDDO
1034
1035	ELSE
1036
1037	DO k = kts, k_end
1038	DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1039	data(i,k,jde+1) = data(i,k,jde)
1040	data(i,k,jde+2) = data(i,k,jde)
1041	data(i,k,jde+3) = data(i,k,jde)
1042	ENDDO
1043	ENDDO
1044
1045	ENDIF
1046
1047	END IF open_ye
1048
1049	! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
1050
1051	END IF periodicity_y
1052
1053	! fix corners for doubly periodic domains
1054
1055	IF ( config_flags%periodic_x .and. config_flags%periodic_y &
1056	.and. (ids == ips) .and. (ide == ipe) &
1057	.and. (jds == jps) .and. (jde == jpe) ) THEN
1058
1059	IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
1060	DO j = 0, -(bdyzone-1), -1
1061	DO k = kts, k_end
1062	DO i = 0, -(bdyzone-1), -1
1063	data(ids+i-1,k,jds+j-1) = data(ide+i-1,k,jde+j-1)
1064	ENDDO
1065	ENDDO
1066	ENDDO
1067	END IF
1068
1069	IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
1070	DO j = 0, -(bdyzone-1), -1
1071	DO k = kts, k_end
1072	DO i = 1, bdyzone
1073	data(ide+i+istag,k,jds+j-1) = data(ids+i+istag,k,jde+j-1)
1074	ENDDO
1075	ENDDO
1076	ENDDO
1077	END IF
1078
1079	IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
1080	DO j = 1, bdyzone
1081	DO k = kts, k_end
1082	DO i = 1, bdyzone
1083	data(ide+i+istag,k,jde+j+jstag) = data(ids+i+istag,k,jds+j+jstag)
1084	ENDDO
1085	ENDDO
1086	ENDDO
1087	END IF
1088
1089	IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
1090	DO j = 1, bdyzone
1091	DO k = kts, k_end
1092	DO i = 0, -(bdyzone-1), -1
1093	data(ids+i-1,k,jde+j+jstag) = data(ide+i-1,k,jds+j+jstag)
1094	ENDDO
1095	ENDDO
1096	ENDDO
1097	END IF
1098
1099	END IF
1100
1101	END SUBROUTINE set_physical_bc3d
1102
1103	SUBROUTINE init_module_bc
1104	END SUBROUTINE init_module_bc
1105
1106	!------------------------------------------------------------------------
1107
1108	SUBROUTINE relax_bdytend ( field, field_tend, &
1109	field_bdy, field_bdy_tend, &
1110	! field_xbdy, field_ybdy, &
1111	variable_in, config_flags, &
1112	spec_bdy_width, spec_zone, relax_zone, &
1113	dtbc, fcx, gcx, &
1114	ijds, ijde, & ! min/max(id,jd)
1115	ids,ide, jds,jde, kds,kde, & ! domain dims
1116	ims,ime, jms,jme, kms,kme, & ! memory dims
1117	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1118	its,ite, jts,jte, kts,kte )
1119
1120	! This subroutine adds the tendencies in the boundary relaxation region, for specified
1121	! boundary conditions.
1122	! spec_bdy_width is only used to dimension the boundary arrays.
1123	! relax_zone is the inner edge of the boundary relaxation zone treated here.
1124	! spec_zone is the width of the outer specified b.c.s that are not changed here.
1125	! (JD July 2000)
1126
1127	IMPLICIT NONE
1128
1129	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1130	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1131	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1132	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1133	INTEGER, INTENT(IN ) :: ijds,ijde
1134	INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone
1135	REAL, INTENT(IN ) :: dtbc
1136	CHARACTER, INTENT(IN ) :: variable_in
1137
1138
1139	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field
1140	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend
1141	REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: field_bdy
1142	REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: field_bdy_tend
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(i, k, b_dist+1, P_YSB) &
1185	+ dtbc * field_bdy_tend(i, k, b_dist+1, P_YSB) &
1186	- field(i,k,j)
1187	fls1 = field_bdy(im1, k, b_dist+1, P_YSB) &
1188	+ dtbc * field_bdy_tend(im1, k, b_dist+1, P_YSB) &
1189	- field(im1,k,j)
1190	fls2 = field_bdy(ip1, k, b_dist+1, P_YSB) &
1191	+ dtbc * field_bdy_tend(ip1, k, b_dist+1, P_YSB) &
1192	- field(ip1,k,j)
1193	fls3 = field_bdy(i, k, b_dist, P_YSB) &
1194	+ dtbc * field_bdy_tend(i, k, b_dist, P_YSB) &
1195	- field(i,k,j-1)
1196	fls4 = field_bdy(i, k, b_dist+2, P_YSB) &
1197	+ dtbc * field_bdy_tend(i, k, b_dist+2, P_YSB) &
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(i, k, b_dist+1, P_YEB) &
1218	+ dtbc * field_bdy_tend(i, k, b_dist+1, P_YEB) &
1219	- field(i,k,j)
1220	fls1 = field_bdy(im1, k, b_dist+1, P_YEB) &
1221	+ dtbc * field_bdy_tend(im1, k, b_dist+1, P_YEB) &
1222	- field(im1,k,j)
1223	fls2 = field_bdy(ip1, k, b_dist+1, P_YEB) &
1224	+ dtbc * field_bdy_tend(ip1, k, b_dist+1, P_YEB) &
1225	- field(ip1,k,j)
1226	fls3 = field_bdy(i, k, b_dist, P_YEB) &
1227	+ dtbc * field_bdy_tend(i, k, b_dist, P_YEB) &
1228	- field(i,k,j+1)
1229	fls4 = field_bdy(i, k, b_dist+2, P_YEB) &
1230	+ dtbc * field_bdy_tend(i, k, b_dist+2, P_YEB) &
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(j, k, b_dist+1, P_XSB) &
1249	+ dtbc * field_bdy_tend(j, k, b_dist+1, P_XSB) &
1250	- field(i,k,j)
1251	fls1 = field_bdy(j-1, k, b_dist+1, P_XSB) &
1252	+ dtbc * field_bdy_tend(j-1, k, b_dist+1, P_XSB) &
1253	- field(i,k,j-1)
1254	fls2 = field_bdy(j+1, k, b_dist+1, P_XSB) &
1255	+ dtbc * field_bdy_tend(j+1, k, b_dist+1, P_XSB) &
1256	- field(i,k,j+1)
1257	fls3 = field_bdy(j, k, b_dist, P_XSB) &
1258	+ dtbc * field_bdy_tend(j, k, b_dist, P_XSB) &
1259	- field(i-1,k,j)
1260	fls4 = field_bdy(j, k, b_dist+2, P_XSB) &
1261	+ dtbc * field_bdy_tend(j, k, b_dist+2, P_XSB) &
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(j, k, b_dist+1, P_XEB) &
1279	+ dtbc * field_bdy_tend(j, k, b_dist+1, P_XEB) &
1280	- field(i,k,j)
1281	fls1 = field_bdy(j-1, k, b_dist+1, P_XEB) &
1282	+ dtbc * field_bdy_tend(j-1, k, b_dist+1, P_XEB) &
1283	- field(i,k,j-1)
1284	fls2 = field_bdy(j+1, k, b_dist+1, P_XEB) &
1285	+ dtbc * field_bdy_tend(j+1, k, b_dist+1, P_XEB) &
1286	- field(i,k,j+1)
1287	fls3 = field_bdy(j, k, b_dist, P_XEB) &
1288	+ dtbc * field_bdy_tend(j, k, b_dist, P_XEB) &
1289	- field(i+1,k,j)
1290	fls4 = field_bdy(j, k, b_dist+2, P_XEB) &
1291	+ dtbc * field_bdy_tend(j, k, b_dist+2, P_XEB) &
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, field_bdy_tend, &
1308	variable_in, config_flags, &
1309	spec_bdy_width, spec_zone, &
1310	ijds, ijde, & ! min/max(id,jd)
1311	ids,ide, jds,jde, kds,kde, & ! domain dims
1312	ims,ime, jms,jme, kms,kme, & ! memory dims
1313	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1314	its,ite, jts,jte, kts,kte )
1315
1316	! This subroutine sets the tendencies in the boundary specified region.
1317	! spec_bdy_width is only used to dimension the boundary arrays.
1318	! spec_zone is the width of the outer specified b.c.s that are set here.
1319	! (JD July 2000)
1320
1321	IMPLICIT NONE
1322
1323	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1324	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1325	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1326	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1327	INTEGER, INTENT(IN ) :: ijds,ijde
1328	INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone
1329	CHARACTER, INTENT(IN ) :: variable_in
1330
1331
1332	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT ) :: field_tend
1333	REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: field_bdy
1334	REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: field_bdy_tend
1335	! REAL, DIMENSION( jms:jme , kms:kme , spec_bdy_width, 4 ), INTENT(IN ) :: field_xbdy
1336	! REAL, DIMENSION( ims:ime , kms:kme , spec_bdy_width, 4 ), INTENT(IN ) :: field_ybdy
1337	TYPE( grid_config_rec_type ) config_flags
1338
1339	CHARACTER :: variable
1340	INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1341	INTEGER :: b_dist, b_limit
1342	LOGICAL :: periodic_x
1343
1344	periodic_x = config_flags%periodic_x
1345
1346	variable = variable_in
1347
1348	IF (variable == 'U') variable = 'u'
1349	IF (variable == 'V') variable = 'v'
1350	IF (variable == 'M') variable = 'm'
1351	IF (variable == 'H') variable = 'h'
1352
1353	ibs = ids
1354	ibe = ide-1
1355	itf = min(ite,ide-1)
1356	jbs = jds
1357	jbe = jde-1
1358	jtf = min(jte,jde-1)
1359	ktf = kde-1
1360	IF (variable == 'u') ibe = ide
1361	IF (variable == 'u') itf = min(ite,ide)
1362	IF (variable == 'v') jbe = jde
1363	IF (variable == 'v') jtf = min(jte,jde)
1364	IF (variable == 'm') ktf = kte
1365	IF (variable == 'h') ktf = kte
1366
1367	IF (jts - jbs .lt. spec_zone) THEN
1368	! Y-start boundary
1369	DO j = jts, min(jtf,jbs+spec_zone-1)
1370	b_dist = j - jbs
1371	b_limit = b_dist
1372	IF(periodic_x)b_limit = 0
1373	DO k = kts, ktf
1374	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1375	field_tend(i,k,j) = field_bdy_tend(i, k, b_dist+1, P_YSB)
1376	! field_tend(i,k,j) = field_ybdy(i, k, b_dist+1, P_SBT)
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(i, k, b_dist+1, P_YEB)
1390	! field_tend(i,k,j) = field_ybdy(i, k, b_dist+1, P_EBT)
1391	ENDDO
1392	ENDDO
1393	ENDDO
1394	ENDIF
1395
1396	IF(.NOT.periodic_x)THEN
1397	IF (its - ibs .lt. spec_zone) THEN
1398	! X-start boundary
1399	DO i = its, min(itf,ibs+spec_zone-1)
1400	b_dist = i - ibs
1401	DO k = kts, ktf
1402	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1403	field_tend(i,k,j) = field_bdy_tend(j, k, b_dist+1, P_XSB)
1404	! field_tend(i,k,j) = field_xbdy(i, k, b_dist+1, P_SBT)
1405	ENDDO
1406	ENDDO
1407	ENDDO
1408	ENDIF
1409
1410	IF (ibe - itf .lt. spec_zone) THEN
1411	! X-end boundary
1412	DO i = max(its,ibe-spec_zone+1), itf
1413	b_dist = ibe - i
1414	DO k = kts, ktf
1415	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1416	field_tend(i,k,j) = field_bdy_tend(j, k, b_dist+1, P_XEB)
1417	! field_tend(i,k,j) = field_xbdy(i, k, b_dist+1, P_EBT)
1418	ENDDO
1419	ENDDO
1420	ENDDO
1421	ENDIF
1422	ENDIF
1423
1424	END SUBROUTINE spec_bdytend
1425	!------------------------------------------------------------------------
1426
1427	SUBROUTINE spec_bdyupdate( field, &
1428	field_tend, dt, &
1429	variable_in, config_flags, &
1430	spec_zone, &
1431	ids,ide, jds,jde, kds,kde, & ! domain dims
1432	ims,ime, jms,jme, kms,kme, & ! memory dims
1433	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1434	its,ite, jts,jte, kts,kte )
1435
1436	! This subroutine adds the tendencies in the boundary specified region.
1437	! spec_zone is the width of the outer specified b.c.s that are set here.
1438	! (JD August 2000)
1439
1440	IMPLICIT NONE
1441
1442	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1443	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1444	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1445	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1446	INTEGER, INTENT(IN ) :: spec_zone
1447	CHARACTER, INTENT(IN ) :: variable_in
1448	REAL, INTENT(IN ) :: dt
1449
1450
1451	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1452	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend
1453	TYPE( grid_config_rec_type ) config_flags
1454
1455	CHARACTER :: variable
1456	INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1457	INTEGER :: b_dist, b_limit
1458	LOGICAL :: periodic_x
1459
1460	periodic_x = config_flags%periodic_x
1461
1462	variable = variable_in
1463
1464	IF (variable == 'U') variable = 'u'
1465	IF (variable == 'V') variable = 'v'
1466	IF (variable == 'M') variable = 'm'
1467	IF (variable == 'H') variable = 'h'
1468
1469	ibs = ids
1470	ibe = ide-1
1471	itf = min(ite,ide-1)
1472	jbs = jds
1473	jbe = jde-1
1474	jtf = min(jte,jde-1)
1475	ktf = kde-1
1476	IF (variable == 'u') ibe = ide
1477	IF (variable == 'u') itf = min(ite,ide)
1478	IF (variable == 'v') jbe = jde
1479	IF (variable == 'v') jtf = min(jte,jde)
1480	IF (variable == 'm') ktf = kte
1481	IF (variable == 'h') ktf = kte
1482
1483	IF (jts - jbs .lt. spec_zone) THEN
1484	! Y-start boundary
1485	DO j = jts, min(jtf,jbs+spec_zone-1)
1486	b_dist = j - jbs
1487	b_limit = b_dist
1488	IF(periodic_x)b_limit = 0
1489	DO k = kts, ktf
1490	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1491	field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1492	ENDDO
1493	ENDDO
1494	ENDDO
1495	ENDIF
1496	IF (jbe - jtf .lt. spec_zone) THEN
1497	! Y-end boundary
1498	DO j = max(jts,jbe-spec_zone+1), jtf
1499	b_dist = jbe - j
1500	b_limit = b_dist
1501	IF(periodic_x)b_limit = 0
1502	DO k = kts, ktf
1503	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1504	field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1505	ENDDO
1506	ENDDO
1507	ENDDO
1508	ENDIF
1509
1510	IF(.NOT.periodic_x)THEN
1511	IF (its - ibs .lt. spec_zone) THEN
1512	! X-start boundary
1513	DO i = its, min(itf,ibs+spec_zone-1)
1514	b_dist = i - ibs
1515	DO k = kts, ktf
1516	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1517	field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1518	ENDDO
1519	ENDDO
1520	ENDDO
1521	ENDIF
1522
1523	IF (ibe - itf .lt. spec_zone) THEN
1524	! X-end boundary
1525	DO i = max(its,ibe-spec_zone+1), itf
1526	b_dist = ibe - i
1527	DO k = kts, ktf
1528	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1529	field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1530	ENDDO
1531	ENDDO
1532	ENDDO
1533	ENDIF
1534	ENDIF
1535
1536	END SUBROUTINE spec_bdyupdate
1537	!------------------------------------------------------------------------
1538
1539	SUBROUTINE zero_grad_bdy ( field, &
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 sets zero gradient conditions 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
1560
1561	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1562	TYPE( grid_config_rec_type ) config_flags
1563
1564	CHARACTER :: variable
1565	INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1566	INTEGER :: b_dist, b_limit
1567	LOGICAL :: periodic_x
1568
1569	periodic_x = config_flags%periodic_x
1570
1571	variable = variable_in
1572
1573	IF (variable == 'U') variable = 'u'
1574	IF (variable == 'V') variable = 'v'
1575
1576	ibs = ids
1577	ibe = ide-1
1578	itf = min(ite,ide-1)
1579	jbs = jds
1580	jbe = jde-1
1581	jtf = min(jte,jde-1)
1582	ktf = kde-1
1583	IF (variable == 'u') ibe = ide
1584	IF (variable == 'u') itf = min(ite,ide)
1585	IF (variable == 'v') jbe = jde
1586	IF (variable == 'v') jtf = min(jte,jde)
1587	IF (variable == 'w') ktf = kde
1588
1589	IF (jts - jbs .lt. spec_zone) THEN
1590	! Y-start boundary
1591	DO j = jts, min(jtf,jbs+spec_zone-1)
1592	b_dist = j - jbs
1593	b_limit = b_dist
1594	IF(periodic_x)b_limit = 0
1595	DO k = kts, ktf
1596	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1597	i_inner = max(i,ibs+spec_zone)
1598	i_inner = min(i_inner,ibe-spec_zone)
1599	IF(periodic_x)i_inner = i
1600	field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1601	ENDDO
1602	ENDDO
1603	ENDDO
1604	ENDIF
1605	IF (jbe - jtf .lt. spec_zone) THEN
1606	! Y-end boundary
1607	DO j = max(jts,jbe-spec_zone+1), jtf
1608	b_dist = jbe - j
1609	b_limit = b_dist
1610	IF(periodic_x)b_limit = 0
1611	DO k = kts, ktf
1612	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1613	i_inner = max(i,ibs+spec_zone)
1614	i_inner = min(i_inner,ibe-spec_zone)
1615	IF(periodic_x)i_inner = i
1616	field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1617	ENDDO
1618	ENDDO
1619	ENDDO
1620	ENDIF
1621
1622	IF(.NOT.periodic_x)THEN
1623	IF (its - ibs .lt. spec_zone) THEN
1624	! X-start boundary
1625	DO i = its, min(itf,ibs+spec_zone-1)
1626	b_dist = i - ibs
1627	DO k = kts, ktf
1628	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1629	j_inner = max(j,jbs+spec_zone)
1630	j_inner = min(j_inner,jbe-spec_zone)
1631	field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1632	ENDDO
1633	ENDDO
1634	ENDDO
1635	ENDIF
1636
1637	IF (ibe - itf .lt. spec_zone) THEN
1638	! X-end boundary
1639	DO i = max(its,ibe-spec_zone+1), itf
1640	b_dist = ibe - i
1641	DO k = kts, ktf
1642	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1643	j_inner = max(j,jbs+spec_zone)
1644	j_inner = min(j_inner,jbe-spec_zone)
1645	field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1646	ENDDO
1647	ENDDO
1648	ENDDO
1649	ENDIF
1650	ENDIF
1651
1652	END SUBROUTINE zero_grad_bdy
1653	!------------------------------------------------------------------------
1654
1655	SUBROUTINE flow_dep_bdy ( field, &
1656	u, v, config_flags, &
1657	spec_zone, &
1658	ids,ide, jds,jde, kds,kde, & ! domain dims
1659	ims,ime, jms,jme, kms,kme, & ! memory dims
1660	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
1661	its,ite, jts,jte, kts,kte )
1662
1663	! This subroutine sets zero gradient conditions for outflow and zero value
1664	! for inflow in the boundary specified region. Note that field must be unstaggered.
1665	! The velocities, u and v, will only be used to check their sign (coupled vels OK)
1666	! spec_zone is the width of the outer specified b.c.s that are set here.
1667	! (JD August 2000)
1668
1669	IMPLICIT NONE
1670
1671	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
1672	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
1673	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
1674	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
1675	INTEGER, INTENT(IN ) :: spec_zone
1676
1677
1678	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1679	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u
1680	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v
1681	TYPE( grid_config_rec_type ) config_flags
1682
1683	INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1684	INTEGER :: b_dist, b_limit
1685	LOGICAL :: periodic_x
1686
1687	periodic_x = config_flags%periodic_x
1688
1689	ibs = ids
1690	ibe = ide-1
1691	itf = min(ite,ide-1)
1692	jbs = jds
1693	jbe = jde-1
1694	jtf = min(jte,jde-1)
1695	ktf = kde-1
1696
1697	IF (jts - jbs .lt. spec_zone) THEN
1698	! Y-start boundary
1699	DO j = jts, min(jtf,jbs+spec_zone-1)
1700	b_dist = j - jbs
1701	b_limit = b_dist
1702	IF(periodic_x)b_limit = 0
1703	DO k = kts, ktf
1704	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1705	i_inner = max(i,ibs+spec_zone)
1706	i_inner = min(i_inner,ibe-spec_zone)
1707	IF(periodic_x)i_inner = i
1708	IF(v(i,k,j) .lt. 0.)THEN
1709	field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1710	ELSE
1711	field(i,k,j) = 0.
1712	ENDIF
1713	ENDDO
1714	ENDDO
1715	ENDDO
1716	ENDIF
1717	IF (jbe - jtf .lt. spec_zone) THEN
1718	! Y-end boundary
1719	DO j = max(jts,jbe-spec_zone+1), jtf
1720	b_dist = jbe - j
1721	b_limit = b_dist
1722	IF(periodic_x)b_limit = 0
1723	DO k = kts, ktf
1724	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1725	i_inner = max(i,ibs+spec_zone)
1726	i_inner = min(i_inner,ibe-spec_zone)
1727	IF(periodic_x)i_inner = i
1728	IF(v(i,k,j+1) .gt. 0.)THEN
1729	field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1730	ELSE
1731	field(i,k,j) = 0.
1732	ENDIF
1733	ENDDO
1734	ENDDO
1735	ENDDO
1736	ENDIF
1737
1738	IF(.NOT.periodic_x)THEN
1739	IF (its - ibs .lt. spec_zone) THEN
1740	! X-start boundary
1741	DO i = its, min(itf,ibs+spec_zone-1)
1742	b_dist = i - ibs
1743	DO k = kts, ktf
1744	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1745	j_inner = max(j,jbs+spec_zone)
1746	j_inner = min(j_inner,jbe-spec_zone)
1747	IF(u(i,k,j) .lt. 0.)THEN
1748	field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1749	ELSE
1750	field(i,k,j) = 0.
1751	ENDIF
1752	ENDDO
1753	ENDDO
1754	ENDDO
1755	ENDIF
1756
1757	IF (ibe - itf .lt. spec_zone) THEN
1758	! X-end boundary
1759	DO i = max(its,ibe-spec_zone+1), itf
1760	b_dist = ibe - i
1761	DO k = kts, ktf
1762	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1763	j_inner = max(j,jbs+spec_zone)
1764	j_inner = min(j_inner,jbe-spec_zone)
1765	IF(u(i+1,k,j) .gt. 0.)THEN
1766	field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1767	ELSE
1768	field(i,k,j) = 0.
1769	ENDIF
1770	ENDDO
1771	ENDDO
1772	ENDDO
1773	ENDIF
1774	ENDIF
1775
1776	END SUBROUTINE flow_dep_bdy
1777
1778	!------------------------------------------------------------------------------
1779
1780	SUBROUTINE stuff_bdy ( data3d , space_bdy , char_stagger , &
1781	ijds , ijde , spec_bdy_width , &
1782	ids, ide, jds, jde, kds, kde , &
1783	ims, ime, jms, jme, kms, kme , &
1784	its, ite, jts, jte, kts, kte )
1785
1786	! This routine puts the data in the 3d arrays into the proper locations
1787	! for the lateral boundary arrays.
1788
1789	USE module_state_description
1790
1791	IMPLICIT NONE
1792
1793	INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1794	INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1795	INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1796	INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
1797	REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
1798	! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
1799	REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4,1) , INTENT(OUT) :: space_bdy
1800	CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1801
1802	INTEGER :: i , ii , j , jj , k
1803
1804	! There are four lateral boundary locations that are stored.
1805
1806	! X start boundary
1807
1808	IF ( char_stagger .EQ. 'W' ) THEN
1809	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1810	DO k = kds , kde
1811	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1812	space_bdy(j,k,i,P_XSB,1) = data3d(i,k,j)
1813	END DO
1814	END DO
1815	END DO
1816	ELSE IF ( char_stagger .EQ. 'M' ) THEN
1817	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1818	DO k = kds , kde
1819	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1820	space_bdy(j,k,i,P_XSB,1) = data3d(i,k,j)
1821	END DO
1822	END DO
1823	END DO
1824	ELSE IF ( char_stagger .EQ. 'V' ) THEN
1825	DO j = MAX(jds,jts) , MIN(jde,jte)
1826	DO k = kds , kde - 1
1827	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1828	space_bdy(j,k,i,P_XSB,1) = data3d(i,k,j)
1829	END DO
1830	END DO
1831	END DO
1832	ELSE
1833	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1834	DO k = kds , kde - 1
1835	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1836	space_bdy(j,k,i,P_XSB,1) = data3d(i,k,j)
1837	END DO
1838	END DO
1839	END DO
1840	END IF
1841
1842	! X end boundary
1843
1844	IF ( char_stagger .EQ. 'U' ) THEN
1845	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1846	DO k = kds , kde - 1
1847	DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1848	ii = ide - i + 1
1849	space_bdy(j,k,ii,P_XEB,1) = data3d(i,k,j)
1850	END DO
1851	END DO
1852	END DO
1853	ELSE IF ( char_stagger .EQ. 'V' ) THEN
1854	DO j = MAX(jds,jts) , MIN(jde,jte)
1855	DO k = kds , kde - 1
1856	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1857	ii = ide - i
1858	space_bdy(j,k,ii,P_XEB,1) = data3d(i,k,j)
1859	END DO
1860	END DO
1861	END DO
1862	ELSE IF ( char_stagger .EQ. 'W' ) THEN
1863	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1864	DO k = kds , kde
1865	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1866	ii = ide - i
1867	space_bdy(j,k,ii,P_XEB,1) = data3d(i,k,j)
1868	END DO
1869	END DO
1870	END DO
1871	ELSE IF ( char_stagger .EQ. 'M' ) THEN
1872	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1873	DO k = kds , kde
1874	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1875	ii = ide - i
1876	space_bdy(j,k,ii,P_XEB,1) = data3d(i,k,j)
1877	END DO
1878	END DO
1879	END DO
1880	ELSE
1881	DO j = MAX(jds,jts) , MIN(jde-1,jte)
1882	DO k = kds , kde - 1
1883	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1884	ii = ide - i
1885	space_bdy(j,k,ii,P_XEB,1) = data3d(i,k,j)
1886	END DO
1887	END DO
1888	END DO
1889	END IF
1890
1891	! Y start boundary
1892
1893	IF ( char_stagger .EQ. 'W' ) THEN
1894	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1895	DO k = kds , kde
1896	DO i = MAX(ids,its) , MIN(ide-1,ite)
1897	space_bdy(i,k,j,P_YSB,1) = data3d(i,k,j)
1898	END DO
1899	END DO
1900	END DO
1901	ELSE IF ( char_stagger .EQ. 'M' ) THEN
1902	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1903	DO k = kds , kde
1904	DO i = MAX(ids,its) , MIN(ide-1,ite)
1905	space_bdy(i,k,j,P_YSB,1) = data3d(i,k,j)
1906	END DO
1907	END DO
1908	END DO
1909	ELSE IF ( char_stagger .EQ. 'U' ) THEN
1910	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1911	DO k = kds , kde - 1
1912	DO i = MAX(ids,its) , MIN(ide,ite)
1913	space_bdy(i,k,j,P_YSB,1) = data3d(i,k,j)
1914	END DO
1915	END DO
1916	END DO
1917	ELSE
1918	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1919	DO k = kds , kde - 1
1920	DO i = MAX(ids,its) , MIN(ide-1,ite)
1921	space_bdy(i,k,j,P_YSB,1) = data3d(i,k,j)
1922	END DO
1923	END DO
1924	END DO
1925	END IF
1926
1927	! Y end boundary
1928
1929	IF ( char_stagger .EQ. 'V' ) THEN
1930	DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
1931	DO k = kds , kde - 1
1932	DO i = MAX(ids,its) , MIN(ide-1,ite)
1933	jj = jde - j + 1
1934	space_bdy(i,k,jj,P_YEB,1) = data3d(i,k,j)
1935	END DO
1936	END DO
1937	END DO
1938	ELSE IF ( char_stagger .EQ. 'U' ) THEN
1939	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1940	DO k = kds , kde - 1
1941	DO i = MAX(ids,its) , MIN(ide,ite)
1942	jj = jde - j
1943	space_bdy(i,k,jj,P_YEB,1) = data3d(i,k,j)
1944	END DO
1945	END DO
1946	END DO
1947	ELSE IF ( char_stagger .EQ. 'W' ) THEN
1948	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1949	DO k = kds , kde
1950	DO i = MAX(ids,its) , MIN(ide-1,ite)
1951	jj = jde - j
1952	space_bdy(i,k,jj,P_YEB,1) = data3d(i,k,j)
1953	END DO
1954	END DO
1955	END DO
1956	ELSE IF ( char_stagger .EQ. 'M' ) THEN
1957	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1958	DO k = kds , kde
1959	DO i = MAX(ids,its) , MIN(ide-1,ite)
1960	jj = jde - j
1961	space_bdy(i,k,jj,P_YEB,1) = data3d(i,k,j)
1962	END DO
1963	END DO
1964	END DO
1965	ELSE
1966	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1967	DO k = kds , kde - 1
1968	DO i = MAX(ids,its) , MIN(ide-1,ite)
1969	jj = jde - j
1970	space_bdy(i,k,jj,P_YEB,1) = data3d(i,k,j)
1971	END DO
1972	END DO
1973	END DO
1974	END IF
1975
1976	END SUBROUTINE stuff_bdy
1977
1978	SUBROUTINE stuff_bdytend ( data3dnew , data3dold , time_diff , space_bdy , char_stagger , &
1979	ijds , ijde , spec_bdy_width , &
1980	ids, ide, jds, jde, kds, kde , &
1981	ims, ime, jms, jme, kms, kme , &
1982	its, ite, jts, jte, kts, kte )
1983
1984	! This routine puts the tendency data into the proper locations
1985	! for the lateral boundary arrays.
1986
1987	USE module_state_description
1988
1989	IMPLICIT NONE
1990
1991	INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1992	INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1993	INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1994	INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
1995	REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
1996	! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
1997	REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4,1) , INTENT(OUT) :: space_bdy
1998	CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1999	REAL , INTENT(IN) :: time_diff ! seconds
2000
2001	INTEGER :: i , ii , j , jj , k
2002
2003	! There are four lateral boundary locations that are stored.
2004
2005	! X start boundary
2006
2007	IF ( char_stagger .EQ. 'W' ) THEN
2008	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2009	DO k = kds , kde
2010	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2011	space_bdy(j,k,i,P_XSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2012	! space_bdy(j,k,i,P_XSB,1) = 0. ! zeroout
2013	END DO
2014	END DO
2015	END DO
2016	ELSE IF ( char_stagger .EQ. 'M' ) THEN
2017	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2018	DO k = kds , kde
2019	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2020	space_bdy(j,k,i,P_XSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2021	! space_bdy(j,k,i,P_XSB,1) = 0. ! zeroout
2022	END DO
2023	END DO
2024	END DO
2025	ELSE IF ( char_stagger .EQ. 'V' ) THEN
2026	DO j = MAX(jds,jts) , MIN(jde,jte)
2027	DO k = kds , kde - 1
2028	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2029	space_bdy(j,k,i,P_XSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2030	! space_bdy(j,k,i,P_XSB,1) = 0. ! zeroout
2031	END DO
2032	END DO
2033	END DO
2034	ELSE
2035	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2036	DO k = kds , kde - 1
2037	DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2038	space_bdy(j,k,i,P_XSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2039	! space_bdy(j,k,i,P_XSB,1) = 0. ! zeroout
2040	END DO
2041	END DO
2042	END DO
2043	END IF
2044
2045	! X end boundary
2046
2047	IF ( char_stagger .EQ. 'U' ) THEN
2048	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2049	DO k = kds , kde - 1
2050	DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2051	ii = ide - i + 1
2052	space_bdy(j,k,ii,P_XEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2053	! space_bdy(j,k,ii,P_XEB,1) = 0. ! zeroout
2054	END DO
2055	END DO
2056	END DO
2057	ELSE IF ( char_stagger .EQ. 'V' ) THEN
2058	DO j = MAX(jds,jts) , MIN(jde,jte)
2059	DO k = kds , kde - 1
2060	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2061	ii = ide - i
2062	space_bdy(j,k,ii,P_XEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2063	! space_bdy(j,k,ii,P_XEB,1) = 0. ! zeroout
2064	END DO
2065	END DO
2066	END DO
2067	ELSE IF ( char_stagger .EQ. 'W' ) THEN
2068	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2069	DO k = kds , kde
2070	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2071	ii = ide - i
2072	space_bdy(j,k,ii,P_XEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2073	! space_bdy(j,k,ii,P_XEB,1) = 0. ! zeroout
2074	END DO
2075	END DO
2076	END DO
2077	ELSE IF ( char_stagger .EQ. 'M' ) THEN
2078	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2079	DO k = kds , kde
2080	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2081	ii = ide - i
2082	space_bdy(j,k,ii,P_XEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2083	! space_bdy(j,k,ii,P_XEB,1) = 0. ! zeroout
2084	END DO
2085	END DO
2086	END DO
2087	ELSE
2088	DO j = MAX(jds,jts) , MIN(jde-1,jte)
2089	DO k = kds , kde - 1
2090	DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2091	ii = ide - i
2092	space_bdy(j,k,ii,P_XEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2093	! space_bdy(j,k,ii,P_XEB,1) = 0. ! zeroout
2094	END DO
2095	END DO
2096	END DO
2097	END IF
2098
2099	! Y start boundary
2100
2101	IF ( char_stagger .EQ. 'W' ) THEN
2102	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2103	DO k = kds , kde
2104	DO i = MAX(ids,its) , MIN(ide-1,ite)
2105	space_bdy(i,k,j,P_YSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2106	! space_bdy(i,k,j,P_YSB,1) = 0. ! zeroout
2107	END DO
2108	END DO
2109	END DO
2110	ELSE IF ( char_stagger .EQ. 'M' ) THEN
2111	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2112	DO k = kds , kde
2113	DO i = MAX(ids,its) , MIN(ide-1,ite)
2114	space_bdy(i,k,j,P_YSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2115	! space_bdy(i,k,j,P_YSB,1) = 0. ! zeroout
2116	END DO
2117	END DO
2118	END DO
2119	ELSE IF ( char_stagger .EQ. 'U' ) THEN
2120	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2121	DO k = kds , kde - 1
2122	DO i = MAX(ids,its) , MIN(ide,ite)
2123	space_bdy(i,k,j,P_YSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2124	! space_bdy(i,k,j,P_YSB,1) = 0. ! zeroout
2125	END DO
2126	END DO
2127	END DO
2128	ELSE
2129	DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2130	DO k = kds , kde - 1
2131	DO i = MAX(ids,its) , MIN(ide-1,ite)
2132	space_bdy(i,k,j,P_YSB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2133	! space_bdy(i,k,j,P_YSB,1) = 0. ! zeroout
2134	END DO
2135	END DO
2136	END DO
2137	END IF
2138
2139	! Y end boundary
2140
2141	IF ( char_stagger .EQ. 'V' ) THEN
2142	DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2143	DO k = kds , kde - 1
2144	DO i = MAX(ids,its) , MIN(ide-1,ite)
2145	jj = jde - j + 1
2146	space_bdy(i,k,jj,P_YEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2147	! space_bdy(i,k,jj,P_YEB,1) = 0. ! zeroout
2148	END DO
2149	END DO
2150	END DO
2151	ELSE IF ( char_stagger .EQ. 'U' ) THEN
2152	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2153	DO k = kds , kde - 1
2154	DO i = MAX(ids,its) , MIN(ide,ite)
2155	jj = jde - j
2156	space_bdy(i,k,jj,P_YEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2157	! space_bdy(i,k,jj,P_YEB,1) = 0. ! zeroout
2158	END DO
2159	END DO
2160	END DO
2161	ELSE IF ( char_stagger .EQ. 'W' ) THEN
2162	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2163	DO k = kds , kde
2164	DO i = MAX(ids,its) , MIN(ide-1,ite)
2165	jj = jde - j
2166	space_bdy(i,k,jj,P_YEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2167	! space_bdy(i,k,jj,P_YEB,1) = 0. ! zeroout
2168	END DO
2169	END DO
2170	END DO
2171	ELSE IF ( char_stagger .EQ. 'M' ) THEN
2172	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2173	DO k = kds , kde
2174	DO i = MAX(ids,its) , MIN(ide-1,ite)
2175	jj = jde - j
2176	space_bdy(i,k,jj,P_YEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2177	! space_bdy(i,k,jj,P_YEB,1) = 0. ! zeroout
2178	END DO
2179	END DO
2180	END DO
2181	ELSE
2182	DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2183	DO k = kds , kde - 1
2184	DO i = MAX(ids,its) , MIN(ide-1,ite)
2185	jj = jde - j
2186	space_bdy(i,k,jj,P_YEB,1) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2187	! space_bdy(i,k,jj,P_YEB,1) = 0. ! zeroout
2188	END DO
2189	END DO
2190	END DO
2191	END IF
2192
2193	END SUBROUTINE stuff_bdytend
2194
2195	END MODULE module_bc
2196
2197	SUBROUTINE get_bdyzone_x ( bzx )
2198	USE module_bc
2199	IMPLICIT NONE
2200	INTEGER bzx
2201	bzx = bdyzone_x
2202	END SUBROUTINE get_bdyzone_x
2203
2204	SUBROUTINE get_bdyzone_y ( bzy)
2205	USE module_bc
2206	IMPLICIT NONE
2207	INTEGER bzy
2208	bzy = bdyzone_y
2209	END SUBROUTINE get_bdyzone_y
2210
2211	SUBROUTINE get_bdyzone ( bz)
2212	USE module_bc
2213	IMPLICIT NONE
2214	INTEGER bz
2215	bz = bdyzone
2216	END SUBROUTINE get_bdyzone
2217

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

Download in other formats:

Original Format