Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

couple_or_uncouple_em.F @ 3709

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

Line
1	!WRF:MEDIATION_LAYER:couple_uncouple_utility
2
3	SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple &
4	!
5	#include "em_dummy_new_args.inc"
6	!
7	)
8
9
10	! #undef DM_PARALLEL
11
12	! Driver layer modules
13	USE module_domain
14	USE module_configure
15	USE module_driver_constants
16	USE module_machine
17	USE module_tiles
18	USE module_dm
19	USE module_bc
20	! Mediation layer modules
21	! Registry generated module
22	USE module_state_description
23
24	IMPLICIT NONE
25
26	! Subroutine interface block.
27
28	TYPE(domain) , TARGET :: grid
29
30	! Definitions of dummy arguments to solve
31	#include <em_dummy_new_decl.inc>
32
33	! WRF state bcs
34	TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags
35
36	LOGICAL, INTENT( IN) :: couple
37
38	! Local data
39
40	INTEGER :: k_start , k_end
41	INTEGER :: ids , ide , jds , jde , kds , kde , &
42	ims , ime , jms , jme , kms , kme , &
43	ips , ipe , jps , jpe , kps , kpe
44
45	INTEGER :: i,j,k, im
46	INTEGER :: num_3d_c, num_3d_m, num_3d_s
47	REAL :: mu_factor
48
49	REAL, DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: mut_2, muut_2, muvt_2, muwt_2
50
51	! De-reference dimension information stored in the grid data structure.
52
53	CALL get_ijk_from_grid ( grid , &
54	ids, ide, jds, jde, kds, kde, &
55	ims, ime, jms, jme, kms, kme, &
56	ips, ipe, jps, jpe, kps, kpe )
57
58	num_3d_m = num_moist
59	num_3d_c = num_chem
60	num_3d_s = num_scalar
61
62	! couple or uncouple mass-point variables
63	! first, compute mu or its reciprical as necessary
64
65	! write(6,*) ' in couple '
66	! write(6,*) ' x,y memory ', grid%sm31,grid%em31,grid%sm33,grid%em33
67	! write(6,*) ' x,y patch ', ips, ipe, jps, jpe
68
69
70	! if(couple) then
71	! write(6,*) ' coupling variables for grid ',grid%id
72	! write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe
73	! else
74	! write(6,*) ' uncoupling variables for grid ',grid%id
75	! write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe
76	! write(6,*) ' x, y, size ',size(mu_2,1),size(mu_2,2)
77	! end if
78
79	#ifdef DM_PARALLEL
80	# include <em_data_calls.inc>
81	#endif
82
83
84	IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
85	CALL set_physical_bc2d( grid%em_mub, 't', &
86	config_flags, &
87	ids,ide, jds,jde, & ! domain dims
88	ims,ime, jms,jme, & ! memory dims
89	ips,ipe, jps,jpe, & ! patch dims
90	ips,ipe, jps,jpe )
91	CALL set_physical_bc2d( grid%em_mu_1, 't', &
92	config_flags, &
93	ids,ide, jds,jde, & ! domain dims
94	ims,ime, jms,jme, & ! memory dims
95	ips,ipe, jps,jpe, & ! patch dims
96	ips,ipe, jps,jpe )
97	CALL set_physical_bc2d( grid%em_mu_2, 't', &
98	config_flags, &
99	ids,ide, jds,jde, & ! domain dims
100	ims,ime, jms,jme, & ! memory dims
101	ips,ipe, jps,jpe, & ! patch dims
102	ips,ipe, jps,jpe )
103	ENDIF
104
105
106	#ifdef DM_PARALLEL
107	# include "HALO_EM_COUPLE_A.inc"
108	# include "PERIOD_EM_COUPLE_A.inc"
109	#endif
110
111	! computations go out one row and column to avoid having to communicate before solver
112
113	IF( couple ) THEN
114
115	! write(6,*) ' coupling: setting mu arrays '
116
117	DO j = max(jds,jps),min(jde-1,jpe)
118	DO i = max(ids,ips),min(ide-1,ipe)
119	mut_2(i,j) = grid%em_mub(i,j) + grid%em_mu_2(i,j)
120	muwt_2(i,j) = (grid%em_mub(i,j) + grid%em_mu_2(i,j))/grid%msft(i,j)
121	ENDDO
122	ENDDO
123
124	! need boundary condition fixes for u and v ???
125
126	! write(6,*) ' coupling: setting muv and muv arrays '
127
128	DO j = max(jds,jps),min(jde-1,jpe)
129	DO i = max(ids,ips),min(ide-1,ipe)
130	muut_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j))/grid%msfu(i,j)
131	muvt_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1))/grid%msfv(i,j)
132	ENDDO
133	ENDDO
134
135	IF ( config_flags%nested .or. config_flags%specified ) THEN
136
137	IF ( jpe .eq. jde ) THEN
138	j = jde
139	DO i = max(ids,ips),min(ide-1,ipe)
140	muvt_2(i,j) = (grid%em_mub(i,j-1) + grid%em_mu_2(i,j-1))/grid%msfv(i,j)
141	ENDDO
142	ENDIF
143	IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
144	i = ide
145	DO j = max(jds,jps),min(jde-1,jpe)
146	muut_2(i,j) = (grid%em_mub(i-1,j) + grid%em_mu_2(i-1,j))/grid%msfu(i,j)
147	ENDDO
148	ENDIF
149
150	ELSE
151
152	IF ( jpe .eq. jde ) THEN
153	j = jde
154	DO i = max(ids,ips),min(ide-1,ipe)
155	muvt_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1))/grid%msfv(i,j)
156	ENDDO
157	ENDIF
158	IF ( ipe .eq. ide ) THEN
159	i = ide
160	DO j = max(jds,jps),min(jde-1,jpe)
161	muut_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j))/grid%msfu(i,j)
162	ENDDO
163	ENDIF
164
165	END IF
166
167	ELSE
168
169	! write(6,*) ' uncoupling: setting mu arrays '
170
171	DO j = max(jds,jps),min(jde-1,jpe)
172	DO i = max(ids,ips),min(ide-1,ipe)
173	mut_2(i,j) = 1./(grid%em_mub(i,j) + grid%em_mu_2(i,j))
174	muwt_2(i,j) = grid%msft(i,j)/(grid%em_mub(i,j) + grid%em_mu_2(i,j))
175	ENDDO
176	ENDDO
177
178	! write(6,*) ' uncoupling: setting muv arrays '
179
180	DO j = max(jds,jps),min(jde-1,jpe)
181	DO i = max(ids,ips),min(ide-1,ipe)
182	muut_2(i,j) = 2.*grid%msfu(i,j)/(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j))
183	ENDDO
184	ENDDO
185
186	DO j = max(jds,jps),min(jde-1,jpe)
187	DO i = max(ids,ips),min(ide-1,ipe)
188	muvt_2(i,j) = 2.*grid%msfv(i,j)/(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1))
189	ENDDO
190	ENDDO
191
192	IF ( config_flags%nested .or. config_flags%specified ) THEN
193
194	IF ( jpe .eq. jde ) THEN
195	j = jde
196	DO i = max(ids,ips),min(ide-1,ipe)
197	muvt_2(i,j) = grid%msfv(i,j)/(grid%em_mub(i,j-1) + grid%em_mu_2(i,j-1))
198	ENDDO
199	ENDIF
200	IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
201	i = ide
202	DO j = max(jds,jps),min(jde-1,jpe)
203	muut_2(i,j) = grid%msfu(i,j)/(grid%em_mub(i-1,j) + grid%em_mu_2(i-1,j))
204	ENDDO
205	ENDIF
206
207	ELSE
208
209	IF ( jpe .eq. jde ) THEN
210	j = jde
211	DO i = max(ids,ips),min(ide-1,ipe)
212	muvt_2(i,j) = 2.*grid%msfv(i,j)/(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1))
213	ENDDO
214	ENDIF
215	IF ( ipe .eq. ide ) THEN
216	i = ide
217	DO j = max(jds,jps),min(jde-1,jpe)
218	muut_2(i,j) = 2.*grid%msfu(i,j)/(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j))
219	ENDDO
220	ENDIF
221
222	END IF
223
224	END IF
225
226	! couple/uncouple mu point variables
227
228	!$OMP PARALLEL DO &
229	!$OMP PRIVATE ( i,j,k,im )
230	DO j = max(jds,jps),min(jde-1,jpe)
231
232	DO k = kps,kpe
233	DO i = max(ids,ips),min(ide-1,ipe)
234	grid%em_ph_2(i,k,j) = grid%em_ph_2(i,k,j)*mut_2(i,j)
235	grid%em_w_2(i,k,j) = grid%em_w_2(i,k,j)*muwt_2(i,j)
236	ENDDO
237	ENDDO
238
239	DO k = kps,kpe-1
240	DO i = max(ids,ips),min(ide-1,ipe)
241	grid%em_t_2(i,k,j) = grid%em_t_2(i,k,j)*mut_2(i,j)
242	ENDDO
243	ENDDO
244
245	IF (num_3d_m >= PARAM_FIRST_SCALAR ) THEN
246	DO im = PARAM_FIRST_SCALAR, num_3d_m
247	DO k = kps,kpe-1
248	DO i = max(ids,ips),min(ide-1,ipe)
249	moist(i,k,j,im) = moist(i,k,j,im)*mut_2(i,j)
250	ENDDO
251	ENDDO
252	ENDDO
253	END IF
254
255	IF (num_3d_c >= PARAM_FIRST_SCALAR ) THEN
256	DO im = PARAM_FIRST_SCALAR, num_3d_c
257	DO k = kps,kpe-1
258	DO i = max(ids,ips),min(ide-1,ipe)
259	chem(i,k,j,im) = chem(i,k,j,im)*mut_2(i,j)
260	ENDDO
261	ENDDO
262	ENDDO
263	END IF
264
265	IF (num_3d_s >= PARAM_FIRST_SCALAR ) THEN
266	DO im = PARAM_FIRST_SCALAR, num_3d_s
267	DO k = kps,kpe-1
268	DO i = max(ids,ips),min(ide-1,ipe)
269	scalar(i,k,j,im) = scalar(i,k,j,im)*mut_2(i,j)
270	ENDDO
271	ENDDO
272	ENDDO
273	END IF
274
275	! do u and v
276
277	DO k = kps,kpe-1
278	DO i = max(ids,ips),min(ide,ipe)
279	grid%em_u_2(i,k,j) = grid%em_u_2(i,k,j)*muut_2(i,j)
280	ENDDO
281	ENDDO
282
283	ENDDO ! j loop
284	!$OMP END PARALLEL DO
285
286	!$OMP PARALLEL DO &
287	!$OMP PRIVATE ( i,j,k )
288	DO j = max(jds,jps),min(jde,jpe)
289	DO k = kps,kpe-1
290	DO i = max(ids,ips),min(ide-1,ipe)
291	grid%em_v_2(i,k,j) = grid%em_v_2(i,k,j)*muvt_2(i,j)
292	ENDDO
293	ENDDO
294	ENDDO
295	!$OMP END PARALLEL DO
296
297	IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
298	CALL set_physical_bc3d( grid%em_ph_1, 'w', &
299	config_flags, &
300	ids,ide, jds,jde, kds,kde, & ! domain dims
301	ims,ime, jms,jme, kms,kme, & ! memory dims
302	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
303	ips,ipe, jps,jpe, kps,kpe )
304	CALL set_physical_bc3d( grid%em_ph_2, 'w', &
305	config_flags, &
306	ids,ide, jds,jde, kds,kde, & ! domain dims
307	ims,ime, jms,jme, kms,kme, & ! memory dims
308	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
309	ips,ipe, jps,jpe, kps,kpe )
310	CALL set_physical_bc3d( grid%em_w_1, 'w', &
311	config_flags, &
312	ids,ide, jds,jde, kds,kde, & ! domain dims
313	ims,ime, jms,jme, kms,kme, & ! memory dims
314	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
315	ips,ipe, jps,jpe, kps,kpe )
316	CALL set_physical_bc3d( grid%em_w_2, 'w', &
317	config_flags, &
318	ids,ide, jds,jde, kds,kde, & ! domain dims
319	ims,ime, jms,jme, kms,kme, & ! memory dims
320	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
321	ips,ipe, jps,jpe, kps,kpe )
322	CALL set_physical_bc3d( grid%em_t_1, 't', &
323	config_flags, &
324	ids,ide, jds,jde, kds,kde, & ! domain dims
325	ims,ime, jms,jme, kms,kme, & ! memory dims
326	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
327	ips,ipe, jps,jpe, kps,kpe )
328	CALL set_physical_bc3d( grid%em_t_2, 't', &
329	config_flags, &
330	ids,ide, jds,jde, kds,kde, & ! domain dims
331	ims,ime, jms,jme, kms,kme, & ! memory dims
332	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
333	ips,ipe, jps,jpe, kps,kpe )
334	CALL set_physical_bc3d( grid%em_u_1, 'u', &
335	config_flags, &
336	ids,ide, jds,jde, kds,kde, & ! domain dims
337	ims,ime, jms,jme, kms,kme, & ! memory dims
338	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
339	ips,ipe, jps,jpe, kps,kpe )
340	CALL set_physical_bc3d( grid%em_u_2, 'u', &
341	config_flags, &
342	ids,ide, jds,jde, kds,kde, & ! domain dims
343	ims,ime, jms,jme, kms,kme, & ! memory dims
344	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
345	ips,ipe, jps,jpe, kps,kpe )
346	CALL set_physical_bc3d( grid%em_v_1, 'v', &
347	config_flags, &
348	ids,ide, jds,jde, kds,kde, & ! domain dims
349	ims,ime, jms,jme, kms,kme, & ! memory dims
350	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
351	ips,ipe, jps,jpe, kps,kpe )
352	CALL set_physical_bc3d( grid%em_v_2, 'v', &
353	config_flags, &
354	ids,ide, jds,jde, kds,kde, & ! domain dims
355	ims,ime, jms,jme, kms,kme, & ! memory dims
356	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
357	ips,ipe, jps,jpe, kps,kpe )
358
359	IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
360	DO im = PARAM_FIRST_SCALAR , num_3d_m
361
362	CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', &
363	config_flags, &
364	ids,ide, jds,jde, kds,kde, & ! domain dims
365	ims,ime, jms,jme, kms,kme, & ! memory dims
366	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
367	ips,ipe, jps,jpe, kps,kpe )
368	ENDDO
369	ENDIF
370
371
372	IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
373	DO im = PARAM_FIRST_SCALAR , num_3d_c
374
375	CALL set_physical_bc3d( chem(ims,kms,jms,im), 'p', &
376	config_flags, &
377	ids,ide, jds,jde, kds,kde, & ! domain dims
378	ims,ime, jms,jme, kms,kme, & ! memory dims
379	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
380	ips,ipe, jps,jpe, kps,kpe )
381	ENDDO
382	ENDIF
383
384	IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
385	DO im = PARAM_FIRST_SCALAR , num_3d_s
386
387	CALL set_physical_bc3d( scalar(ims,kms,jms,im), 'p', &
388	config_flags, &
389	ids,ide, jds,jde, kds,kde, & ! domain dims
390	ims,ime, jms,jme, kms,kme, & ! memory dims
391	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
392	ips,ipe, jps,jpe, kps,kpe )
393	ENDDO
394	ENDIF
395
396	ENDIF
397
398	#ifdef DM_PARALLEL
399	# include "HALO_EM_COUPLE_B.inc"
400	# include "PERIOD_EM_COUPLE_B.inc"
401	#endif
402
403	END SUBROUTINE couple_or_uncouple_em
404
405	LOGICAL FUNCTION em_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
406	USE module_configure
407	IMPLICIT NONE
408	INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
409	LOGICAL, INTENT(IN) :: xstag, ystag
410
411	INTEGER ioff, joff, spec_zone
412
413	CALL nl_get_spec_zone( 1, spec_zone )
414	ioff = 0 ; joff = 0
415	IF ( xstag ) ioff = 1
416	IF ( ystag ) joff = 1
417
418	em_cd_feedback_mask = ( pig .ge. ips_save+spec_zone .and. &
419	pjg .ge. jps_save+spec_zone .and. &
420	pig .le. ipe_save-spec_zone +ioff .and. &
421	pjg .le. jpe_save-spec_zone +joff )
422
423
424	END FUNCTION em_cd_feedback_mask
425

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

Download in other formats:

Original Format