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