Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_bc_em.F @ 3094

Last change on this file since 3094 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: 53.8 KB

Line
1	!WRF:MODEL_LAYER:BOUNDARY
2	!
3	MODULE module_bc_em
4
5	USE module_bc
6	USE module_configure
7	USE module_wrf_error
8
9	CONTAINS
10
11	!------------------------------------------------------------------------
12
13	SUBROUTINE spec_bdyupdate_ph( ph_save, field, &
14	field_tend, mu_tend, muts, dt, &
15	variable_in, config_flags, &
16	spec_zone, &
17	ids,ide, jds,jde, kds,kde, & ! domain dims
18	ims,ime, jms,jme, kms,kme, & ! memory dims
19	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
20	its,ite, jts,jte, kts,kte )
21
22	! This subroutine adds the tendencies in the boundary specified region.
23	! spec_zone is the width of the outer specified b.c.s that are set here.
24	! (JD August 2000)
25
26	IMPLICIT NONE
27
28	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
29	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
30	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
31	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
32	INTEGER, INTENT(IN ) :: spec_zone
33	CHARACTER, INTENT(IN ) :: variable_in
34	REAL, INTENT(IN ) :: dt
35
36
37	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
38	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend, ph_save
39	REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu_tend, muts
40	TYPE( grid_config_rec_type ) config_flags
41
42	CHARACTER :: variable
43	INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
44	INTEGER :: b_dist, b_limit
45
46	! Local array
47
48	REAL, DIMENSION( its:ite , jts:jte ) :: mu_old
49	LOGICAL :: periodic_x
50
51	periodic_x = config_flags%periodic_x
52
53	variable = variable_in
54
55	IF (variable == 'U') variable = 'u'
56	IF (variable == 'V') variable = 'v'
57	IF (variable == 'M') variable = 'm'
58	IF (variable == 'H') variable = 'h'
59
60	ibs = ids
61	ibe = ide-1
62	itf = min(ite,ide-1)
63	jbs = jds
64	jbe = jde-1
65	jtf = min(jte,jde-1)
66	ktf = kde-1
67	IF (variable == 'u') ibe = ide
68	IF (variable == 'u') itf = min(ite,ide)
69	IF (variable == 'v') jbe = jde
70	IF (variable == 'v') jtf = min(jte,jde)
71	IF (variable == 'm') ktf = kte
72	IF (variable == 'h') ktf = kte
73
74	IF (jts - jbs .lt. spec_zone) THEN
75	! Y-start boundary
76	DO j = jts, min(jtf,jbs+spec_zone-1)
77	b_dist = j - jbs
78	b_limit = b_dist
79	IF(periodic_x)b_limit = 0
80	DO k = kts, ktf
81	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
82
83	mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j)
84
85	field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + &
86	dt*field_tend(i,k,j)/muts(i,j) + &
87	ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.)
88
89	ENDDO
90	ENDDO
91	ENDDO
92	ENDIF
93	IF (jbe - jtf .lt. spec_zone) THEN
94	! Y-end boundary
95	DO j = max(jts,jbe-spec_zone+1), jtf
96	b_dist = jbe - j
97	b_limit = b_dist
98	IF(periodic_x)b_limit = 0
99	DO k = kts, ktf
100	DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
101
102	mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j)
103
104	field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + &
105	dt*field_tend(i,k,j)/muts(i,j) + &
106	ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.)
107
108	ENDDO
109	ENDDO
110	ENDDO
111	ENDIF
112
113	IF(.NOT.periodic_x)THEN
114	IF (its - ibs .lt. spec_zone) THEN
115	! X-start boundary
116	DO i = its, min(itf,ibs+spec_zone-1)
117	b_dist = i - ibs
118	DO k = kts, ktf
119	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
120
121	mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j)
122
123	field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + &
124	dt*field_tend(i,k,j)/muts(i,j) + &
125	ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.)
126
127	ENDDO
128	ENDDO
129	ENDDO
130	ENDIF
131
132	IF (ibe - itf .lt. spec_zone) THEN
133	! X-end boundary
134	DO i = max(its,ibe-spec_zone+1), itf
135	b_dist = ibe - i
136	DO k = kts, ktf
137	DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
138
139	mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j)
140
141	field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + &
142	dt*field_tend(i,k,j)/muts(i,j) + &
143	ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.)
144
145	ENDDO
146	ENDDO
147	ENDDO
148	ENDIF
149	ENDIF
150
151	END SUBROUTINE spec_bdyupdate_ph
152
153	!------------------------------------------------------------------------
154
155	SUBROUTINE relax_bdy_dry ( config_flags, &
156	ru_tendf, rv_tendf, ph_tendf, t_tendf, &
157	rw_tendf, mu_tend, &
158	ru, rv, ph, t, &
159	w, mu, mut, &
160	u_bxs,u_bxe,u_bys,u_bye, &
161	v_bxs,v_bxe,v_bys,v_bye, &
162	ph_bxs,ph_bxe,ph_bys,ph_bye, &
163	t_bxs,t_bxe,t_bys,t_bye, &
164	w_bxs,w_bxe,w_bys,w_bye, &
165	mu_bxs,mu_bxe,mu_bys,mu_bye, &
166	u_btxs,u_btxe,u_btys,u_btye, &
167	v_btxs,v_btxe,v_btys,v_btye, &
168	ph_btxs,ph_btxe,ph_btys,ph_btye, &
169	t_btxs,t_btxe,t_btys,t_btye, &
170	w_btxs,w_btxe,w_btys,w_btye, &
171	mu_btxs,mu_btxe,mu_btys,mu_btye, &
172	spec_bdy_width, spec_zone, relax_zone, &
173	dtbc, fcx, gcx, &
174	ids,ide, jds,jde, kds,kde, & ! domain dims
175	ims,ime, jms,jme, kms,kme, & ! memory dims
176	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
177	its, ite, jts, jte, kts, kte)
178	IMPLICIT NONE
179
180	! Input data.
181	TYPE( grid_config_rec_type ) config_flags
182
183	INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
184	ims, ime, jms, jme, kms, kme, &
185	ips, ipe, jps, jpe, kps, kpe, &
186	its, ite, jts, jte, kts, kte
187	INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone
188
189	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN ) :: ru, &
190	rv, &
191	ph, &
192	w, &
193	t
194	REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu , &
195	mut
196	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: ru_tendf, &
197	rv_tendf, &
198	ph_tendf, &
199	rw_tendf, &
200	t_tendf
201	REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: mu_tend
202	REAL , DIMENSION( spec_bdy_width) , INTENT(IN ) :: fcx, gcx
203
204	REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: u_bxs,u_bxe, &
205	v_bxs,v_bxe, &
206	ph_bxs,ph_bxe, &
207	w_bxs,w_bxe, &
208	t_bxs,t_bxe, &
209	u_btxs,u_btxe, &
210	v_btxs,v_btxe, &
211	ph_btxs,ph_btxe, &
212	w_btxs,w_btxe, &
213	t_btxs,t_btxe
214
215	REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: u_bys,u_bye, &
216	v_bys,v_bye, &
217	ph_bys,ph_bye, &
218	w_bys,w_bye, &
219	t_bys,t_bye, &
220	u_btys,u_btye, &
221	v_btys,v_btye, &
222	ph_btys,ph_btye, &
223	w_btys,w_btye, &
224	t_btys,t_btye
225
226
227	REAL, DIMENSION( jms:jme , 1:1 , spec_bdy_width ), INTENT(IN ) :: mu_bxs,mu_bxe, &
228	mu_btxs,mu_btxe
229
230	REAL, DIMENSION( ims:ime , 1:1 , spec_bdy_width ), INTENT(IN ) :: mu_bys,mu_bye, &
231	mu_btys,mu_btye
232	REAL, INTENT(IN ) :: dtbc
233
234	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) :: rfield
235	INTEGER :: i_start, i_end, j_start, j_end, i, j, k
236
237	CALL relax_bdytend ( ru, ru_tendf, &
238	u_bxs,u_bxe,u_bys,u_bye,u_btxs,u_btxe,u_btys,u_btye, &
239	'u' , config_flags, &
240	spec_bdy_width, spec_zone, relax_zone, &
241	dtbc, fcx, gcx, &
242	ids,ide, jds,jde, kds,kde, & ! domain dims
243	ims,ime, jms,jme, kms,kme, & ! memory dims
244	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
245	its,ite, jts,jte, kts,kte )
246	CALL relax_bdytend ( rv, rv_tendf, &
247	v_bxs,v_bxe,v_bys,v_bye,v_btxs,v_btxe,v_btys,v_btye, &
248	'v' , config_flags, &
249	spec_bdy_width, spec_zone, relax_zone, &
250	dtbc, fcx, gcx, &
251	ids,ide, jds,jde, kds,kde, & ! domain dims
252	ims,ime, jms,jme, kms,kme, & ! memory dims
253	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
254	its,ite, jts,jte, kts,kte )
255
256	! rfield will be calculated beyond tile limits because relax_bdytend
257	! requires a 5-point stencil, and this avoids need for inter-tile/patch
258	! communication here
259	i_start = max(its-1, ids)
260	i_end = min(ite+1, ide-1)
261	j_start = max(jts-1, jds)
262	j_end = min(jte+1, jde-1)
263
264	DO j=j_start,j_end
265	DO k=kts,kte
266	DO i=i_start,i_end
267	rfield(i,k,j) = ph(i,k,j)*mut(i,j)
268	ENDDO
269	ENDDO
270	ENDDO
271
272	CALL relax_bdytend ( rfield, ph_tendf, &
273	ph_bxs,ph_bxe,ph_bys,ph_bye, ph_btxs,ph_btxe,ph_btys,ph_btye, &
274	'h' , config_flags, &
275	spec_bdy_width, spec_zone, relax_zone, &
276	dtbc, fcx, gcx, &
277	ids,ide, jds,jde, kds,kde, & ! domain dims
278	ims,ime, jms,jme, kms,kme, & ! memory dims
279	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
280	its,ite, jts,jte, kts,kte )
281	DO j=j_start,j_end
282	DO k=kts,kte-1
283	DO i=i_start,i_end
284	rfield(i,k,j) = t(i,k,j)*mut(i,j)
285	ENDDO
286	ENDDO
287	ENDDO
288	CALL relax_bdytend ( rfield, t_tendf, &
289	t_bxs,t_bxe,t_bys,t_bye, t_btxs,t_btxe,t_btys,t_btye, &
290	't' , config_flags, &
291	spec_bdy_width, spec_zone, relax_zone, &
292	dtbc, fcx, gcx, &
293	ids,ide, jds,jde, kds,kde, & ! domain dims
294	ims,ime, jms,jme, kms,kme, & ! memory dims
295	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
296	its,ite, jts,jte, kts,kte )
297	CALL relax_bdytend ( mu, mu_tend, &
298	mu_bxs,mu_bxe,mu_bys,mu_bye, mu_btxs,mu_btxe,mu_btys,mu_btye, &
299	'm' , config_flags, &
300	spec_bdy_width, spec_zone, relax_zone, &
301	dtbc, fcx, gcx, &
302	ids,ide, jds,jde, 1 ,1 , & ! domain dims
303	ims,ime, jms,jme, 1 ,1 , & ! memory dims
304	ips,ipe, jps,jpe, 1 ,1 , & ! patch dims
305	its,ite, jts,jte, 1 ,1 )
306
307	IF( config_flags%nested) THEN
308
309	i_start = max(its-1, ids)
310	i_end = min(ite+1, ide-1)
311	j_start = max(jts-1, jds)
312	j_end = min(jte+1, jde-1)
313
314	DO j=j_start,j_end
315	DO k=kts,kte
316	DO i=i_start,i_end
317	rfield(i,k,j) = w(i,k,j)*mut(i,j)
318	ENDDO
319	ENDDO
320	ENDDO
321
322	CALL relax_bdytend ( rfield, rw_tendf, &
323	w_bxs,w_bxe,w_bys,w_bye, w_btxs,w_btxe,w_btys,w_btye, &
324	'h' , config_flags, &
325	spec_bdy_width, spec_zone, relax_zone, &
326	dtbc, fcx, gcx, &
327	ids,ide, jds,jde, kds,kde, & ! domain dims
328	ims,ime, jms,jme, kms,kme, & ! memory dims
329	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
330	its,ite, jts,jte, kts,kte )
331
332	END IF
333
334	END SUBROUTINE relax_bdy_dry
335	!------------------------------------------------------------------------
336	SUBROUTINE relax_bdy_scalar ( scalar_tend, &
337	scalar, mu, &
338	scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, &
339	scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, &
340	spec_bdy_width, spec_zone, relax_zone, &
341	dtbc, fcx, gcx, &
342	config_flags, &
343	ids,ide, jds,jde, kds,kde, & ! domain dims
344	ims,ime, jms,jme, kms,kme, & ! memory dims
345	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
346	its, ite, jts, jte, kts, kte)
347	IMPLICIT NONE
348
349	! Input data.
350	TYPE( grid_config_rec_type ) config_flags
351
352	INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
353	ims, ime, jms, jme, kms, kme, &
354	ips, ipe, jps, jpe, kps, kpe, &
355	its, ite, jts, jte, kts, kte
356	INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone
357
358	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN ) :: scalar
359	REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu
360	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: scalar_tend
361	REAL , DIMENSION( spec_bdy_width) , INTENT(IN ) :: fcx, gcx
362
363	REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: scalar_bxs,scalar_bxe, &
364	scalar_btxs,scalar_btxe
365	REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: scalar_bys,scalar_bye, &
366	scalar_btys,scalar_btye
367	REAL, INTENT(IN ) :: dtbc
368	!Local
369	INTEGER :: i,j,k, i_start, i_end, j_start, j_end
370	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) :: rscalar
371
372	! rscalar will be calculated beyond tile limits because relax_bdytend
373	! requires a 5-point stencil, and this avoids need for inter-tile/patch
374	! communication here
375	i_start = max(its-1, ids)
376	i_end = min(ite+1, ide-1)
377	j_start = max(jts-1, jds)
378	j_end = min(jte+1, jde-1)
379
380	DO j=j_start,j_end
381	DO k=kts,min(kte,kde-1)
382	DO i=i_start,i_end
383	rscalar(i,k,j) = scalar(i,k,j)*mu(i,j)
384	ENDDO
385	ENDDO
386	ENDDO
387
388	CALL relax_bdytend (rscalar, scalar_tend, &
389	scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, &
390	'q' , config_flags, &
391	spec_bdy_width, spec_zone, relax_zone, &
392	dtbc, fcx, gcx, &
393	ids,ide, jds,jde, kds,kde, & ! domain dims
394	ims,ime, jms,jme, kms,kme, & ! memory dims
395	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
396	its,ite, jts,jte, kts,kte )
397
398
399	END SUBROUTINE relax_bdy_scalar
400
401	!------------------------------------------------------------------------
402	SUBROUTINE spec_bdy_dry ( config_flags, &
403	ru_tend, rv_tend, ph_tend, t_tend, &
404	rw_tend, mu_tend, &
405	u_bxs,u_bxe,u_bys,u_bye, &
406	v_bxs,v_bxe,v_bys,v_bye, &
407	ph_bxs,ph_bxe,ph_bys,ph_bye, &
408	t_bxs,t_bxe,t_bys,t_bye, &
409	w_bxs,w_bxe,w_bys,w_bye, &
410	mu_bxs,mu_bxe,mu_bys,mu_bye, &
411	u_btxs,u_btxe,u_btys,u_btye, &
412	v_btxs,v_btxe,v_btys,v_btye, &
413	ph_btxs,ph_btxe,ph_btys,ph_btye, &
414	t_btxs,t_btxe,t_btys,t_btye, &
415	w_btxs,w_btxe,w_btys,w_btye, &
416	mu_btxs,mu_btxe,mu_btys,mu_btye, &
417	spec_bdy_width, spec_zone, &
418	ids,ide, jds,jde, kds,kde, & ! domain dims
419	ims,ime, jms,jme, kms,kme, & ! memory dims
420	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
421	its, ite, jts, jte, kts, kte)
422	IMPLICIT NONE
423
424	! Input data.
425	TYPE( grid_config_rec_type ) config_flags
426
427
428	INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
429	ims, ime, jms, jme, kms, kme, &
430	ips, ipe, jps, jpe, kps, kpe, &
431	its, ite, jts, jte, kts, kte
432	INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone
433
434	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT ) :: ru_tend, &
435	rv_tend, &
436	ph_tend, &
437	rw_tend, &
438	t_tend
439	REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(OUT ) :: mu_tend
440
441	REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: u_bxs,u_bxe, &
442	v_bxs,v_bxe, &
443	ph_bxs,ph_bxe, &
444	w_bxs,w_bxe, &
445	t_bxs,t_bxe, &
446	u_btxs,u_btxe, &
447	v_btxs,v_btxe, &
448	ph_btxs,ph_btxe, &
449	w_btxs,w_btxe, &
450	t_btxs,t_btxe
451
452	REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: u_bys,u_bye, &
453	v_bys,v_bye, &
454	ph_bys,ph_bye, &
455	w_bys,w_bye, &
456	t_bys,t_bye, &
457	u_btys,u_btye, &
458	v_btys,v_btye, &
459	ph_btys,ph_btye, &
460	w_btys,w_btye, &
461	t_btys,t_btye
462
463	REAL, DIMENSION( jms:jme , 1:1 , spec_bdy_width ), INTENT(IN ) :: mu_bxs,mu_bxe, &
464	mu_btxs,mu_btxe
465
466	REAL, DIMENSION( ims:ime , 1:1 , spec_bdy_width ), INTENT(IN ) :: mu_bys,mu_bye, &
467	mu_btys,mu_btye
468	CALL spec_bdytend ( ru_tend, &
469	u_bxs,u_bxe,u_bys,u_bye, u_btxs,u_btxe,u_btys,u_btye, &
470	'u' , config_flags, &
471	spec_bdy_width, spec_zone, &
472	ids,ide, jds,jde, kds,kde, & ! domain dims
473	ims,ime, jms,jme, kms,kme, & ! memory dims
474	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
475	its,ite, jts,jte, kts,kte )
476	CALL spec_bdytend ( rv_tend, &
477	v_bxs,v_bxe,v_bys,v_bye, v_btxs,v_btxe,v_btys,v_btye, &
478	'v' , config_flags, &
479	spec_bdy_width, spec_zone, &
480	ids,ide, jds,jde, kds,kde, & ! domain dims
481	ims,ime, jms,jme, kms,kme, & ! memory dims
482	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
483	its,ite, jts,jte, kts,kte )
484	CALL spec_bdytend ( ph_tend, &
485	ph_bxs,ph_bxe,ph_bys,ph_bye, ph_btxs,ph_btxe,ph_btys,ph_btye, &
486	'h' , config_flags, &
487	spec_bdy_width, spec_zone, &
488	ids,ide, jds,jde, kds,kde, & ! domain dims
489	ims,ime, jms,jme, kms,kme, & ! memory dims
490	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
491	its,ite, jts,jte, kts,kte )
492	CALL spec_bdytend ( t_tend, &
493	t_bxs,t_bxe,t_bys,t_bye, t_btxs,t_btxe,t_btys,t_btye, &
494	't' , config_flags, &
495	spec_bdy_width, spec_zone, &
496	ids,ide, jds,jde, kds,kde, & ! domain dims
497	ims,ime, jms,jme, kms,kme, & ! memory dims
498	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
499	its,ite, jts,jte, kts,kte )
500	CALL spec_bdytend ( mu_tend, &
501	mu_bxs,mu_bxe,mu_bys,mu_bye, mu_btxs,mu_btxe,mu_btys,mu_btye, &
502	'm' , config_flags, &
503	spec_bdy_width, spec_zone, &
504	ids,ide, jds,jde, 1 ,1 , & ! domain dims
505	ims,ime, jms,jme, 1 ,1 , & ! memory dims
506	ips,ipe, jps,jpe, 1 ,1 , & ! patch dims
507	its,ite, jts,jte, 1 ,1 )
508
509	if(config_flags%nested) &
510	CALL spec_bdytend ( rw_tend, &
511	w_bxs,w_bxe,w_bys,w_bye, w_btxs,w_btxe,w_btys,w_btye, &
512	'h' , config_flags, &
513	spec_bdy_width, spec_zone, &
514	ids,ide, jds,jde, kds,kde, & ! domain dims
515	ims,ime, jms,jme, kms,kme, & ! memory dims
516	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
517	its,ite, jts,jte, kts,kte )
518
519	END SUBROUTINE spec_bdy_dry
520
521	!------------------------------------------------------------------------
522	SUBROUTINE spec_bdy_scalar ( scalar_tend, &
523	scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, &
524	scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, &
525	spec_bdy_width, spec_zone, &
526	config_flags, &
527	ids,ide, jds,jde, kds,kde, & ! domain dims
528	ims,ime, jms,jme, kms,kme, & ! memory dims
529	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
530	its, ite, jts, jte, kts, kte)
531	IMPLICIT NONE
532
533	! Input data.
534	TYPE( grid_config_rec_type ) config_flags
535
536
537	INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
538	ims, ime, jms, jme, kms, kme, &
539	ips, ipe, jps, jpe, kps, kpe, &
540	its, ite, jts, jte, kts, kte
541	INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone
542
543	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT ) :: scalar_tend
544
545	REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: scalar_bxs,scalar_bxe, &
546	scalar_btxs,scalar_btxe
547
548	REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: scalar_bys,scalar_bye, &
549	scalar_btys,scalar_btye
550
551	!Local
552	INTEGER :: i,j,k
553
554
555	CALL spec_bdytend ( scalar_tend, &
556	scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, &
557	'q' , config_flags, &
558	spec_bdy_width, spec_zone, &
559	ids,ide, jds,jde, kds,kde, & ! domain dims
560	ims,ime, jms,jme, kms,kme, & ! memory dims
561	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
562	its,ite, jts,jte, kts,kte )
563
564
565	END SUBROUTINE spec_bdy_scalar
566
567	!------------------------------------------------------------------------
568
569	SUBROUTINE set_phys_bc_dry_1( config_flags, u_1, u_2, v_1, v_2, &
570	rw_1, rw_2, w_1, w_2, &
571	t_1, t_2, tp_1, tp_2, pp, pip, &
572	ids,ide, jds,jde, kds,kde, &
573	ims,ime, jms,jme, kms,kme, &
574	ips,ipe, jps,jpe, kps,kpe, &
575	its,ite, jts,jte, kts,kte )
576
577	!
578	! this is just a wraper to call the boundary condition routines
579	! for each variable
580	!
581
582	IMPLICIT NONE
583
584	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
585	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
586	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
587	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
588
589	TYPE( grid_config_rec_type ) config_flags
590
591	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: &
592	u_1,u_2, v_1, v_2, rw_1, rw_2, w_1, w_2, &
593	t_1, t_2, tp_1, tp_2, pp, pip
594
595
596
597	CALL set_physical_bc3d( u_1 , 'u', config_flags, &
598	ids, ide, jds, jde, kds, kde, &
599	ims, ime, jms, jme, kms, kme, &
600	ips, ipe, jps, jpe, kps, kpe, &
601	its, ite, jts, jte, kts, kte )
602	CALL set_physical_bc3d( u_2 , 'u', config_flags, &
603	ids, ide, jds, jde, kds, kde, &
604	ims, ime, jms, jme, kms, kme, &
605	ips, ipe, jps, jpe, kps, kpe, &
606	its, ite, jts, jte, kts, kte )
607	CALL set_physical_bc3d( v_1 , 'v', config_flags, &
608	ids, ide, jds, jde, kds, kde, &
609	ims, ime, jms, jme, kms, kme, &
610	ips, ipe, jps, jpe, kps, kpe, &
611	its, ite, jts, jte, kts, kte )
612	CALL set_physical_bc3d( v_2 , 'v', config_flags, &
613	ids, ide, jds, jde, kds, kde, &
614	ims, ime, jms, jme, kms, kme, &
615	ips, ipe, jps, jpe, kps, kpe, &
616	its, ite, jts, jte, kts, kte )
617	CALL set_physical_bc3d( rw_1 , 'w', config_flags, &
618	ids, ide, jds, jde, kds, kde, &
619	ims, ime, jms, jme, kms, kme, &
620	ips, ipe, jps, jpe, kps, kpe, &
621	its, ite, jts, jte, kts, kte )
622	CALL set_physical_bc3d( rw_2 , 'w', config_flags, &
623	ids, ide, jds, jde, kds, kde, &
624	ims, ime, jms, jme, kms, kme, &
625	ips, ipe, jps, jpe, kps, kpe, &
626	its, ite, jts, jte, kts, kte )
627	CALL set_physical_bc3d( w_1 , 'w', config_flags, &
628	ids, ide, jds, jde, kds, kde, &
629	ims, ime, jms, jme, kms, kme, &
630	ips, ipe, jps, jpe, kps, kpe, &
631	its, ite, jts, jte, kts, kte )
632	CALL set_physical_bc3d( w_2 , 'w', config_flags, &
633	ids, ide, jds, jde, kds, kde, &
634	ims, ime, jms, jme, kms, kme, &
635	ips, ipe, jps, jpe, kps, kpe, &
636	its, ite, jts, jte, kts, kte )
637	CALL set_physical_bc3d( t_1, 'p', config_flags, &
638	ids, ide, jds, jde, kds, kde, &
639	ims, ime, jms, jme, kms, kme, &
640	ips, ipe, jps, jpe, kps, kpe, &
641	its, ite, jts, jte, kts, kte )
642	CALL set_physical_bc3d( t_2, 'p', config_flags, &
643	ids, ide, jds, jde, kds, kde, &
644	ims, ime, jms, jme, kms, kme, &
645	ips, ipe, jps, jpe, kps, kpe, &
646	its, ite, jts, jte, kts, kte )
647	CALL set_physical_bc3d( tp_1, 'p', config_flags, &
648	ids, ide, jds, jde, kds, kde, &
649	ims, ime, jms, jme, kms, kme, &
650	ips, ipe, jps, jpe, kps, kpe, &
651	its, ite, jts, jte, kts, kte )
652	CALL set_physical_bc3d( tp_2, 'p', config_flags, &
653	ids, ide, jds, jde, kds, kde, &
654	ims, ime, jms, jme, kms, kme, &
655	ips, ipe, jps, jpe, kps, kpe, &
656	its, ite, jts, jte, kts, kte )
657	CALL set_physical_bc3d( pp , 'p', config_flags, &
658	ids, ide, jds, jde, kds, kde, &
659	ims, ime, jms, jme, kms, kme, &
660	ips, ipe, jps, jpe, kps, kpe, &
661	its, ite, jts, jte, kts, kte )
662	CALL set_physical_bc3d( pip , 'p', config_flags, &
663	ids, ide, jds, jde, kds, kde, &
664	ims, ime, jms, jme, kms, kme, &
665	ips, ipe, jps, jpe, kps, kpe, &
666	its, ite, jts, jte, kts, kte )
667
668	END SUBROUTINE set_phys_bc_dry_1
669
670	!--------------------------------------------------------------
671
672	SUBROUTINE set_phys_bc_dry_2( config_flags, &
673	u_1, u_2, v_1, v_2, w_1, w_2, &
674	t_1, t_2, ph_1, ph_2, mu_1, mu_2, &
675	ids,ide, jds,jde, kds,kde, &
676	ims,ime, jms,jme, kms,kme, &
677	ips,ipe, jps,jpe, kps,kpe, &
678	its,ite, jts,jte, kts,kte )
679
680	!
681	! this is just a wraper to call the boundary condition routines
682	! for each variable
683	!
684
685	IMPLICIT NONE
686
687	TYPE( grid_config_rec_type ) config_flags
688
689	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
690	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
691	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
692	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
693
694	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: &
695	u_1, u_2, v_1, v_2, w_1, w_2, &
696	t_1, t_2, ph_1, ph_2
697
698	REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: &
699	mu_1, mu_2
700
701
702	CALL set_physical_bc3d( u_1, 'U', config_flags, &
703	ids, ide, jds, jde, kds, kde, &
704	ims, ime, jms, jme, kms, kme, &
705	ips, ipe, jps, jpe, kps, kpe, &
706	its, ite, jts, jte, kts, kte )
707
708	CALL set_physical_bc3d( u_2, 'U', config_flags, &
709	ids, ide, jds, jde, kds, kde, &
710	ims, ime, jms, jme, kms, kme, &
711	ips, ipe, jps, jpe, kps, kpe, &
712	its, ite, jts, jte, kts, kte )
713
714	CALL set_physical_bc3d( v_1 , 'V', config_flags, &
715	ids, ide, jds, jde, kds, kde, &
716	ims, ime, jms, jme, kms, kme, &
717	ips, ipe, jps, jpe, kps, kpe, &
718	its, ite, jts, jte, kts, kte )
719	CALL set_physical_bc3d( v_2 , 'V', config_flags, &
720	ids, ide, jds, jde, kds, kde, &
721	ims, ime, jms, jme, kms, kme, &
722	ips, ipe, jps, jpe, kps, kpe, &
723	its, ite, jts, jte, kts, kte )
724
725	CALL set_physical_bc3d( w_1, 'w', config_flags, &
726	ids, ide, jds, jde, kds, kde, &
727	ims, ime, jms, jme, kms, kme, &
728	ips, ipe, jps, jpe, kps, kpe, &
729	its, ite, jts, jte, kts, kte )
730	CALL set_physical_bc3d( w_2, 'w', config_flags, &
731	ids, ide, jds, jde, kds, kde, &
732	ims, ime, jms, jme, kms, kme, &
733	ips, ipe, jps, jpe, kps, kpe, &
734	its, ite, jts, jte, kts, kte )
735
736	CALL set_physical_bc3d( t_1, 'p', config_flags, &
737	ids, ide, jds, jde, kds, kde, &
738	ims, ime, jms, jme, kms, kme, &
739	ips, ipe, jps, jpe, kps, kpe, &
740	its, ite, jts, jte, kts, kte )
741
742	CALL set_physical_bc3d( t_2, 'p', config_flags, &
743	ids, ide, jds, jde, kds, kde, &
744	ims, ime, jms, jme, kms, kme, &
745	ips, ipe, jps, jpe, kps, kpe, &
746	its, ite, jts, jte, kts, kte )
747
748	CALL set_physical_bc3d( ph_1 , 'w', config_flags, &
749	ids, ide, jds, jde, kds, kde, &
750	ims, ime, jms, jme, kms, kme, &
751	ips, ipe, jps, jpe, kps, kpe, &
752	its, ite, jts, jte, kts, kte )
753
754	CALL set_physical_bc3d( ph_2 , 'w', config_flags, &
755	ids, ide, jds, jde, kds, kde, &
756	ims, ime, jms, jme, kms, kme, &
757	ips, ipe, jps, jpe, kps, kpe, &
758	its, ite, jts, jte, kts, kte )
759
760	CALL set_physical_bc2d( mu_1, 't', config_flags, &
761	ids, ide, jds, jde, &
762	ims, ime, jms, jme, &
763	ips, ipe, jps, jpe, &
764	its, ite, jts, jte )
765
766	CALL set_physical_bc2d( mu_2, 't', config_flags, &
767	ids, ide, jds, jde, &
768	ims, ime, jms, jme, &
769	ips, ipe, jps, jpe, &
770	its, ite, jts, jte )
771
772	END SUBROUTINE set_phys_bc_dry_2
773
774	!------------------------------------------------------------------------
775
776	SUBROUTINE set_phys_bc_smallstep_1( config_flags, ru_1, du, rv_1, dv, &
777	ids,ide, jds,jde, kds,kde, &
778	ims,ime, jms,jme, kms,kme, &
779	ips,ipe, jps,jpe, kps,kpe, &
780	its,ite, jts,jte, kts,kte )
781
782	!
783	! this is just a wraper to call the boundary condition routines
784	! for each variable
785	!
786
787	IMPLICIT NONE
788
789	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
790	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
791	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
792	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
793
794	TYPE( grid_config_rec_type ) config_flags
795
796	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: &
797	ru_1,du, rv_1, dv
798
799	CALL set_physical_bc3d( ru_1 , 'u', config_flags, &
800	ids, ide, jds, jde, kds, kde, &
801	ims, ime, jms, jme, kms, kme, &
802	ips, ipe, jps, jpe, kps, kpe, &
803	its, ite, jts, jte, kts, kde )
804	CALL set_physical_bc3d( du , 'u', config_flags, &
805	ids, ide, jds, jde, kds, kde, &
806	ims, ime, jms, jme, kms, kme, &
807	ips, ipe, jps, jpe, kps, kpe, &
808	its, ite, jts, jte, kts, kde )
809	CALL set_physical_bc3d( rv_1 , 'v', config_flags, &
810	ids, ide, jds, jde, kds, kde, &
811	ims, ime, jms, jme, kms, kme, &
812	ips, ipe, jps, jpe, kps, kpe, &
813	its, ite, jts, jte, kts, kde )
814	CALL set_physical_bc3d( dv , 'v', config_flags, &
815	ids, ide, jds, jde, kds, kde, &
816	ims, ime, jms, jme, kms, kme, &
817	ips, ipe, jps, jpe, kps, kpe, &
818	its, ite, jts, jte, kts, kde )
819
820	END SUBROUTINE set_phys_bc_smallstep_1
821
822	!-------------------------------------------------------------------
823
824	SUBROUTINE rk_phys_bc_dry_1( config_flags, u, v, rw, w, &
825	muu, muv, mut, php, alt, p, &
826	ids,ide, jds,jde, kds,kde, &
827	ims,ime, jms,jme, kms,kme, &
828	ips,ipe, jps,jpe, kps,kpe, &
829	its,ite, jts,jte, kts,kte )
830
831	!
832	! this is just a wraper to call the boundary condition routines
833	! for each variable
834	!
835
836	IMPLICIT NONE
837
838	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
839	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
840	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
841	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
842
843	TYPE( grid_config_rec_type ) config_flags
844
845	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
846	INTENT(INOUT) :: u, v, rw, w, php, alt, p
847	REAL, DIMENSION( ims:ime, jms:jme ), &
848	INTENT(INOUT) :: muu, muv, mut
849
850	CALL set_physical_bc3d( u , 'u', config_flags, &
851	ids, ide, jds, jde, kds, kde, &
852	ims, ime, jms, jme, kms, kme, &
853	ips, ipe, jps, jpe, kps, kpe, &
854	its, ite, jts, jte, kts, kte )
855	CALL set_physical_bc3d( v , 'v', config_flags, &
856	ids, ide, jds, jde, kds, kde, &
857	ims, ime, jms, jme, kms, kme, &
858	ips, ipe, jps, jpe, kps, kpe, &
859	its, ite, jts, jte, kts, kte )
860	CALL set_physical_bc3d(rw , 'w', config_flags, &
861	ids, ide, jds, jde, kds, kde, &
862	ims, ime, jms, jme, kms, kme, &
863	ips, ipe, jps, jpe, kps, kpe, &
864	its, ite, jts, jte, kts, kte )
865	CALL set_physical_bc3d( w , 'w', config_flags, &
866	ids, ide, jds, jde, kds, kde, &
867	ims, ime, jms, jme, kms, kme, &
868	ips, ipe, jps, jpe, kps, kpe, &
869	its, ite, jts, jte, kts, kte )
870	CALL set_physical_bc3d( php , 'w', config_flags, &
871	ids, ide, jds, jde, kds, kde, &
872	ims, ime, jms, jme, kms, kme, &
873	ips, ipe, jps, jpe, kps, kpe, &
874	its, ite, jts, jte, kts, kte )
875	CALL set_physical_bc3d( alt, 't', config_flags, &
876	ids, ide, jds, jde, kds, kde, &
877	ims, ime, jms, jme, kms, kme, &
878	ips, ipe, jps, jpe, kps, kpe, &
879	its, ite, jts, jte, kts, kte )
880
881	CALL set_physical_bc3d( p, 'p', config_flags, &
882	ids, ide, jds, jde, kds, kde, &
883	ims, ime, jms, jme, kms, kme, &
884	ips, ipe, jps, jpe, kps, kpe, &
885	its, ite, jts, jte, kts, kte )
886
887	CALL set_physical_bc2d( muu, 'u', config_flags, &
888	ids, ide, jds, jde, &
889	ims, ime, jms, jme, &
890	ips, ipe, jps, jpe, &
891	its, ite, jts, jte )
892
893	CALL set_physical_bc2d( muv, 'v', config_flags, &
894	ids, ide, jds, jde, &
895	ims, ime, jms, jme, &
896	ips, ipe, jps, jpe, &
897	its, ite, jts, jte )
898
899	CALL set_physical_bc2d( mut, 't', config_flags, &
900	ids, ide, jds, jde, &
901	ims, ime, jms, jme, &
902	ips, ipe, jps, jpe, &
903	its, ite, jts, jte )
904
905	END SUBROUTINE rk_phys_bc_dry_1
906
907	!------------------------------------------------------------------------
908
909	SUBROUTINE rk_phys_bc_dry_2( config_flags, u, v, w, &
910	t, ph, mu, &
911	ids,ide, jds,jde, kds,kde, &
912	ims,ime, jms,jme, kms,kme, &
913	ips,ipe, jps,jpe, kps,kpe, &
914	its,ite, jts,jte, kts,kte )
915
916	!
917	! this is just a wraper to call the boundary condition routines
918	! for each variable
919	!
920
921	IMPLICIT NONE
922
923	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
924	INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
925	INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
926	INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
927
928	TYPE( grid_config_rec_type ) config_flags
929
930	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: &
931	u, v, w, t, ph
932
933	REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: &
934	mu
935
936	CALL set_physical_bc3d( u , 'U', config_flags, &
937	ids, ide, jds, jde, kds, kde, &
938	ims, ime, jms, jme, kms, kme, &
939	ips, ipe, jps, jpe, kps, kpe, &
940	its, ite, jts, jte, kts, kte )
941	CALL set_physical_bc3d( v , 'V', config_flags, &
942	ids, ide, jds, jde, kds, kde, &
943	ims, ime, jms, jme, kms, kme, &
944	ips, ipe, jps, jpe, kps, kpe, &
945	its, ite, jts, jte, kts, kte )
946	CALL set_physical_bc3d( w , 'w', config_flags, &
947	ids, ide, jds, jde, kds, kde, &
948	ims, ime, jms, jme, kms, kme, &
949	ips, ipe, jps, jpe, kps, kpe, &
950	its, ite, jts, jte, kts, kte )
951	CALL set_physical_bc3d( t, 'p', config_flags, &
952	ids, ide, jds, jde, kds, kde, &
953	ims, ime, jms, jme, kms, kme, &
954	ips, ipe, jps, jpe, kps, kpe, &
955	its, ite, jts, jte, kts, kte )
956	CALL set_physical_bc3d( ph , 'w', config_flags, &
957	ids, ide, jds, jde, kds, kde, &
958	ims, ime, jms, jme, kms, kme, &
959	ips, ipe, jps, jpe, kps, kpe, &
960	its, ite, jts, jte, kts, kte )
961
962	CALL set_physical_bc2d( mu, 't', config_flags, &
963	ids, ide, jds, jde, &
964	ims, ime, jms, jme, &
965	ips, ipe, jps, jpe, &
966	its, ite, jts, jte )
967
968	END SUBROUTINE rk_phys_bc_dry_2
969
970	!---------------------------------------------------------------------
971
972	SUBROUTINE set_w_surface( config_flags, znw, &
973	w, ht, u, v, cf1, cf2, cf3, rdx, rdy, &
974	msftx, msfty, &
975	ids, ide, jds, jde, kds, kde, &
976	ips, ipe, jps, jpe, kps, kpe, &
977	its, ite, jts, jte, kts, kte, &
978	ims, ime, jms, jme, kms, kme )
979	implicit none
980
981	TYPE( grid_config_rec_type ) config_flags
982
983	INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
984	ims, ime, jms, jme, kms, kme, &
985	its, ite, jts, jte, kts, kte, &
986	ips, ipe, jps, jpe, kps, kpe
987
988	REAL :: rdx, rdy, cf1, cf2, cf3
989
990
991	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
992	INTENT(IN ) :: u, &
993	v
994
995	REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
996	INTENT(INOUT) :: w
997
998	REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: ht, &
999	msftx, &
1000	msfty
1001	REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: znw
1002
1003
1004	INTEGER :: i,j,k
1005	INTEGER :: ip1,im1,jp1,jm1
1006
1007	! set kinematic lower boundary condition on W
1008
1009	! Comments on directional map scale factors:
1010	! Chain rule: if Z=Z(X,Y) [true at the surface] then
1011	! dZ/dt = dZ/dX * dX/dt + dZ/dY * dY/dt, U=dX/dt, V=dY/dt
1012	! using capitals to denote actual values
1013	! in mapped values, u=U, v=V, z=Z, 1/dX=mx/dx, 1/dY=my/dy
1014	! => w = dz/dt = mx u dz/dx + my v dz/dy
1015	! [where dz/dx is just the surface height change between x
1016	! gridpoints, and dz/dy is the change between y gridpoints]
1017	! [NB - cf1, cf2 and cf3 do vertical weighting of u or v values
1018	! nearest the surface]
1019
1020	DO j = jts,min(jte,jde-1)
1021	jm1 = max(j-1,jds)
1022	jp1 = min(j+1,jde-1)
1023	DO i = its,min(ite,ide-1)
1024	im1 = max(i-1,ids)
1025	ip1 = min(i+1,ide-1)
1026
1027	w(i,1,j)= msfty(i,j)* &
1028	.5rdy( &
1029	(ht(i,jp1)-ht(i,j )) &
1030	(cf1v(i,1,j+1)+cf2v(i,2,j+1)+cf3v(i,3,j+1)) &
1031	+(ht(i,j )-ht(i,jm1)) &
1032	(cf1v(i,1,j )+cf2v(i,2,j )+cf3v(i,3,j )) ) &
1033	+msftx(i,j)* &
1034	.5rdx( &
1035	(ht(ip1,j)-ht(i,j )) &
1036	(cf1u(i+1,1,j)+cf2u(i+1,2,j)+cf3u(i+1,3,j)) &
1037	+(ht(i ,j)-ht(im1,j)) &
1038	(cf1u(i ,1,j)+cf2u(i ,2,j)+cf3u(i ,3,j)) )
1039
1040	ENDDO
1041	ENDDO
1042
1043	! Fill the atmospheric w field with smoothly decaying values
1044
1045	DO j = jts,min(jte,jde-1)
1046	DO k = kts+1,kte
1047	DO i = its,min(ite,ide-1)
1048	w(i,k,j) = w(i,1,j)znw(k)znw(k)
1049	ENDDO
1050	ENDDO
1051	ENDDO
1052
1053	END SUBROUTINE set_w_surface
1054
1055	SUBROUTINE lbc_fcx_gcx ( fcx , gcx , spec_bdy_width , &
1056	spec_zone , relax_zone , dt , spec_exp , &
1057	specified , nested )
1058
1059	IMPLICIT NONE
1060
1061	INTEGER , INTENT(IN) :: spec_bdy_width , spec_zone , relax_zone
1062	REAL , INTENT(IN) :: dt , spec_exp
1063	LOGICAL , INTENT(IN) :: specified , nested
1064	REAL , DIMENSION(spec_bdy_width) :: fcx , gcx
1065
1066	! Local variables.
1067
1068	INTEGER :: loop
1069	REAL :: spongeweight
1070
1071	IF (specified) THEN
1072
1073	! Arrays for specified boundary conditions
1074
1075	DO loop = spec_zone + 1, spec_zone + relax_zone
1076	fcx(loop) = 0.1 / dt * (spec_zone + relax_zone - loop) / (relax_zone - 1)
1077	gcx(loop) = 1.0 / dt / 50. * (spec_zone + relax_zone - loop) / (relax_zone - 1)
1078	spongeweight=exp(-(loop-(spec_zone + 1))*spec_exp)
1079	fcx(loop) = fcx(loop)*spongeweight
1080	gcx(loop) = gcx(loop)*spongeweight
1081	ENDDO
1082
1083	ELSE IF (nested) THEN
1084
1085	! Arrays for specified boundary conditions
1086
1087	DO loop = spec_zone + 1, spec_zone + relax_zone
1088	fcx(loop) = 0.1 / dt * (spec_zone + relax_zone - loop) / (relax_zone - 1)
1089	gcx(loop) = 1.0 / dt / 50. * (spec_zone + relax_zone - loop) / (relax_zone - 1)
1090	! spongeweight=EXP(-(loop-2)/3.)
1091	! fcx(loop) = fcx(loop)*spongeweight
1092	! gcx(loop) = gcx(loop)*spongeweight
1093	! fcx(loop) = 0.
1094	! gcx(loop) = 0.
1095	ENDDO
1096
1097	ENDIF
1098
1099	END SUBROUTINE lbc_fcx_gcx
1100
1101	END MODULE module_bc_em

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

Download in other formats:

Original Format