Context Navigation

couple_or_uncouple_em.F

Last change on this file was 1, checked in by lfita, 11 years ago

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 16.3 KB

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

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

Download in other formats:

Original Format