Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

couple_or_uncouple_em.F @ 3567

Last change on this file since 3567 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 15.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	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 <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
80	IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
81	CALL set_physical_bc2d( grid%mub, 't', &
82	config_flags, &
83	ids,ide, jds,jde, & ! domain dims
84	ims,ime, jms,jme, & ! memory dims
85	ips,ipe, jps,jpe, & ! patch dims
86	ips,ipe, jps,jpe )
87	CALL set_physical_bc2d( grid%mu_1, 't', &
88	config_flags, &
89	ids,ide, jds,jde, & ! domain dims
90	ims,ime, jms,jme, & ! memory dims
91	ips,ipe, jps,jpe, & ! patch dims
92	ips,ipe, jps,jpe )
93	CALL set_physical_bc2d( grid%mu_2, 't', &
94	config_flags, &
95	ids,ide, jds,jde, & ! domain dims
96	ims,ime, jms,jme, & ! memory dims
97	ips,ipe, jps,jpe, & ! patch dims
98	ips,ipe, jps,jpe )
99	ENDIF
100
101
102	#ifdef DM_PARALLEL
103	# include "HALO_EM_COUPLE_A.inc"
104	# include "PERIOD_EM_COUPLE_A.inc"
105	#endif
106
107	! computations go out one row and column to avoid having to communicate before solver
108
109	IF( couple ) THEN
110
111	! write(6,*) ' coupling: setting mu arrays '
112
113	DO j = max(jds,jps),min(jde-1,jpe)
114	DO i = max(ids,ips),min(ide-1,ipe)
115	mut_2(i,j) = grid%mub(i,j) + grid%mu_2(i,j)
116	muwt_2(i,j) = (grid%mub(i,j) + grid%mu_2(i,j))/grid%msfty(i,j) ! w coupled with y
117	ENDDO
118	ENDDO
119
120	! need boundary condition fixes for u and v ???
121
122	! write(6,*) ' coupling: setting muv and muv arrays '
123
124	DO j = max(jds,jps),min(jde-1,jpe)
125	DO i = max(ids,ips),min(ide-1,ipe)
126	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
127	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
128	ENDDO
129	ENDDO
130
131	IF ( config_flags%nested .or. config_flags%specified .or. config_flags%polar ) THEN
132
133	IF ( jpe .eq. jde ) THEN
134	j = jde
135	DO i = max(ids,ips),min(ide-1,ipe)
136	muvt_2(i,j) = (grid%mub(i,j-1) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x
137	ENDDO
138	ENDIF
139	IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
140	i = ide
141	DO j = max(jds,jps),min(jde-1,jpe)
142	muut_2(i,j) = (grid%mub(i-1,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y
143	ENDDO
144	ENDIF
145
146	ELSE
147
148	IF ( jpe .eq. jde ) THEN
149	j = jde
150	DO i = max(ids,ips),min(ide-1,ipe)
151	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
152	ENDDO
153	ENDIF
154	IF ( ipe .eq. ide ) THEN
155	i = ide
156	DO j = max(jds,jps),min(jde-1,jpe)
157	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
158	ENDDO
159	ENDIF
160
161	END IF
162
163	ELSE
164
165	! write(6,*) ' uncoupling: setting mu arrays '
166
167	DO j = max(jds,jps),min(jde-1,jpe)
168	DO i = max(ids,ips),min(ide-1,ipe)
169	mut_2(i,j) = 1./(grid%mub(i,j) + grid%mu_2(i,j))
170	muwt_2(i,j) = grid%msfty(i,j)/(grid%mub(i,j) + grid%mu_2(i,j)) ! w coupled with y
171	ENDDO
172	ENDDO
173
174	! write(6,*) ' uncoupling: setting muv arrays '
175
176	DO j = max(jds,jps),min(jde-1,jpe)
177	DO i = max(ids,ips),min(ide-1,ipe)
178	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
179	ENDDO
180	ENDDO
181
182	DO j = max(jds,jps),min(jde-1,jpe)
183	DO i = max(ids,ips),min(ide-1,ipe)
184	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
185	ENDDO
186	ENDDO
187
188	IF ( config_flags%nested .or. config_flags%specified .or. config_flags%polar ) THEN
189
190	IF ( jpe .eq. jde ) THEN
191	j = jde
192	DO i = max(ids,ips),min(ide-1,ipe)
193	muvt_2(i,j) = grid%msfvx(i,j)/(grid%mub(i,j-1) + grid%mu_2(i,j-1)) ! v coupled with x
194	ENDDO
195	ENDIF
196	IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
197	i = ide
198	DO j = max(jds,jps),min(jde-1,jpe)
199	muut_2(i,j) = grid%msfuy(i,j)/(grid%mub(i-1,j) + grid%mu_2(i-1,j)) ! u coupled with y
200	ENDDO
201	ENDIF
202
203	ELSE
204
205	IF ( jpe .eq. jde ) THEN
206	j = jde
207	DO i = max(ids,ips),min(ide-1,ipe)
208	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
209	ENDDO
210	ENDIF
211	IF ( ipe .eq. ide ) THEN
212	i = ide
213	DO j = max(jds,jps),min(jde-1,jpe)
214	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
215	ENDDO
216	ENDIF
217
218	END IF
219
220	END IF
221
222	! couple/uncouple mu point variables
223
224	!$OMP PARALLEL DO &
225	!$OMP PRIVATE ( i,j,k,im )
226	DO j = max(jds,jps),min(jde-1,jpe)
227
228	DO k = kps,kpe
229	DO i = max(ids,ips),min(ide-1,ipe)
230	grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*mut_2(i,j)
231	grid%w_2(i,k,j) = grid%w_2(i,k,j)*muwt_2(i,j)
232	ENDDO
233	ENDDO
234
235	DO k = kps,kpe-1
236	DO i = max(ids,ips),min(ide-1,ipe)
237	grid%t_2(i,k,j) = grid%t_2(i,k,j)*mut_2(i,j)
238	ENDDO
239	ENDDO
240
241	IF (num_3d_m >= PARAM_FIRST_SCALAR ) THEN
242	DO im = PARAM_FIRST_SCALAR, num_3d_m
243	DO k = kps,kpe-1
244	DO i = max(ids,ips),min(ide-1,ipe)
245	moist(i,k,j,im) = moist(i,k,j,im)*mut_2(i,j)
246	ENDDO
247	ENDDO
248	ENDDO
249	END IF
250
251	IF (num_3d_c >= PARAM_FIRST_SCALAR ) THEN
252	DO im = PARAM_FIRST_SCALAR, num_3d_c
253	DO k = kps,kpe-1
254	DO i = max(ids,ips),min(ide-1,ipe)
255	chem(i,k,j,im) = chem(i,k,j,im)*mut_2(i,j)
256	ENDDO
257	ENDDO
258	ENDDO
259	END IF
260
261	IF (num_3d_s >= PARAM_FIRST_SCALAR ) THEN
262	DO im = PARAM_FIRST_SCALAR, num_3d_s
263	DO k = kps,kpe-1
264	DO i = max(ids,ips),min(ide-1,ipe)
265	scalar(i,k,j,im) = scalar(i,k,j,im)*mut_2(i,j)
266	ENDDO
267	ENDDO
268	ENDDO
269	END IF
270
271	! do u and v
272
273	DO k = kps,kpe-1
274	DO i = max(ids,ips),min(ide,ipe)
275	grid%u_2(i,k,j) = grid%u_2(i,k,j)*muut_2(i,j)
276	ENDDO
277	ENDDO
278
279	ENDDO ! j loop
280	!$OMP END PARALLEL DO
281
282	!$OMP PARALLEL DO &
283	!$OMP PRIVATE ( i,j,k )
284	DO j = max(jds,jps),min(jde,jpe)
285	DO k = kps,kpe-1
286	DO i = max(ids,ips),min(ide-1,ipe)
287	grid%v_2(i,k,j) = grid%v_2(i,k,j)*muvt_2(i,j)
288	ENDDO
289	ENDDO
290	ENDDO
291	!$OMP END PARALLEL DO
292
293	IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
294	CALL set_physical_bc3d( grid%ph_1, 'w', &
295	config_flags, &
296	ids,ide, jds,jde, kds,kde, & ! domain dims
297	ims,ime, jms,jme, kms,kme, & ! memory dims
298	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
299	ips,ipe, jps,jpe, kps,kpe )
300	CALL set_physical_bc3d( grid%ph_2, 'w', &
301	config_flags, &
302	ids,ide, jds,jde, kds,kde, & ! domain dims
303	ims,ime, jms,jme, kms,kme, & ! memory dims
304	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
305	ips,ipe, jps,jpe, kps,kpe )
306	CALL set_physical_bc3d( grid%w_1, 'w', &
307	config_flags, &
308	ids,ide, jds,jde, kds,kde, & ! domain dims
309	ims,ime, jms,jme, kms,kme, & ! memory dims
310	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
311	ips,ipe, jps,jpe, kps,kpe )
312	CALL set_physical_bc3d( grid%w_2, 'w', &
313	config_flags, &
314	ids,ide, jds,jde, kds,kde, & ! domain dims
315	ims,ime, jms,jme, kms,kme, & ! memory dims
316	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
317	ips,ipe, jps,jpe, kps,kpe )
318	CALL set_physical_bc3d( grid%t_1, 't', &
319	config_flags, &
320	ids,ide, jds,jde, kds,kde, & ! domain dims
321	ims,ime, jms,jme, kms,kme, & ! memory dims
322	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
323	ips,ipe, jps,jpe, kps,kpe )
324	CALL set_physical_bc3d( grid%t_2, 't', &
325	config_flags, &
326	ids,ide, jds,jde, kds,kde, & ! domain dims
327	ims,ime, jms,jme, kms,kme, & ! memory dims
328	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
329	ips,ipe, jps,jpe, kps,kpe )
330	CALL set_physical_bc3d( grid%u_1, 'u', &
331	config_flags, &
332	ids,ide, jds,jde, kds,kde, & ! domain dims
333	ims,ime, jms,jme, kms,kme, & ! memory dims
334	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
335	ips,ipe, jps,jpe, kps,kpe )
336	CALL set_physical_bc3d( grid%u_2, 'u', &
337	config_flags, &
338	ids,ide, jds,jde, kds,kde, & ! domain dims
339	ims,ime, jms,jme, kms,kme, & ! memory dims
340	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
341	ips,ipe, jps,jpe, kps,kpe )
342	CALL set_physical_bc3d( grid%v_1, 'v', &
343	config_flags, &
344	ids,ide, jds,jde, kds,kde, & ! domain dims
345	ims,ime, jms,jme, kms,kme, & ! memory dims
346	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
347	ips,ipe, jps,jpe, kps,kpe )
348	CALL set_physical_bc3d( grid%v_2, 'v', &
349	config_flags, &
350	ids,ide, jds,jde, kds,kde, & ! domain dims
351	ims,ime, jms,jme, kms,kme, & ! memory dims
352	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
353	ips,ipe, jps,jpe, kps,kpe )
354
355	IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
356	DO im = PARAM_FIRST_SCALAR , num_3d_m
357
358	CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', &
359	config_flags, &
360	ids,ide, jds,jde, kds,kde, & ! domain dims
361	ims,ime, jms,jme, kms,kme, & ! memory dims
362	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
363	ips,ipe, jps,jpe, kps,kpe )
364	ENDDO
365	ENDIF
366
367
368	IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
369	DO im = PARAM_FIRST_SCALAR , num_3d_c
370
371	CALL set_physical_bc3d( chem(ims,kms,jms,im), 'p', &
372	config_flags, &
373	ids,ide, jds,jde, kds,kde, & ! domain dims
374	ims,ime, jms,jme, kms,kme, & ! memory dims
375	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
376	ips,ipe, jps,jpe, kps,kpe )
377	ENDDO
378	ENDIF
379
380	IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
381	DO im = PARAM_FIRST_SCALAR , num_3d_s
382
383	CALL set_physical_bc3d( scalar(ims,kms,jms,im), 'p', &
384	config_flags, &
385	ids,ide, jds,jde, kds,kde, & ! domain dims
386	ims,ime, jms,jme, kms,kme, & ! memory dims
387	ips,ipe, jps,jpe, kps,kpe, & ! patch dims
388	ips,ipe, jps,jpe, kps,kpe )
389	ENDDO
390	ENDIF
391
392	ENDIF
393
394	#ifdef DM_PARALLEL
395	# include "HALO_EM_COUPLE_B.inc"
396	# include "PERIOD_EM_COUPLE_B.inc"
397	#endif
398
399	END SUBROUTINE couple_or_uncouple_em
400
401	LOGICAL FUNCTION cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
402	IMPLICIT NONE
403	INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
404	LOGICAL, INTENT(IN) :: xstag, ystag
405
406	INTEGER ioff, joff, spec_zone
407
408	CALL nl_get_spec_zone( 1, spec_zone )
409	ioff = 0 ; joff = 0
410	IF ( xstag ) ioff = 1
411	IF ( ystag ) joff = 1
412
413	cd_feedback_mask = ( pig .ge. ips_save+spec_zone .and. &
414	pjg .ge. jps_save+spec_zone .and. &
415	pig .le. ipe_save-spec_zone +ioff .and. &
416	pjg .le. jpe_save-spec_zone +joff )
417
418
419	END FUNCTION cd_feedback_mask
420

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

Download in other formats:

Original Format