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_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_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 #ifdef DEREF_KLUDGE
52 ! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
53 INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
54 INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
55 INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
56 #endif
57
58 #include "deref_kludge.h"
59
60 ! De-reference dimension information stored in the grid data structure.
61
62 CALL get_ijk_from_grid ( grid , &
63 ids, ide, jds, jde, kds, kde, &
64 ims, ime, jms, jme, kms, kme, &
65 ips, ipe, jps, jpe, kps, kpe )
66
67 num_3d_m = num_moist
68 #ifdef CHEM
69 num_3d_c = num_chem
70 #endif
71 num_3d_s = num_scalar
72
73 ! couple or uncouple mass-point variables
74 ! first, compute mu or its reciprical as necessary
75
76 ! write(6,*) ' in couple '
77 ! write(6,*) ' x,y memory ', grid%sm31,grid%em31,grid%sm33,grid%em33
78 ! write(6,*) ' x,y patch ', ips, ipe, jps, jpe
79
80
81 ! if(couple) then
82 ! write(6,*) ' coupling variables for grid ',grid%id
83 ! write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe
84 ! else
85 ! write(6,*) ' uncoupling variables for grid ',grid%id
86 ! write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe
87 ! write(6,*) ' x, y, size ',size(mu_2,1),size(mu_2,2)
88 ! end if
89
90 #ifdef DM_PARALLEL
91 # include <em_data_calls.inc>
92 #endif
93
94 IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
95 CALL set_physical_bc2d( mub, 't', &
96 config_flags, &
97 ids,ide, jds,jde, & ! domain dims
98 ims,ime, jms,jme, & ! memory dims
99 ips,ipe, jps,jpe, & ! patch dims
100 ips,ipe, jps,jpe )
101 CALL set_physical_bc2d( mu_1, 't', &
102 config_flags, &
103 ids,ide, jds,jde, & ! domain dims
104 ims,ime, jms,jme, & ! memory dims
105 ips,ipe, jps,jpe, & ! patch dims
106 ips,ipe, jps,jpe )
107 CALL set_physical_bc2d( mu_2, 't', &
108 config_flags, &
109 ids,ide, jds,jde, & ! domain dims
110 ims,ime, jms,jme, & ! memory dims
111 ips,ipe, jps,jpe, & ! patch dims
112 ips,ipe, jps,jpe )
113 ENDIF
114
115
116 #ifdef DM_PARALLEL
117 # include "HALO_EM_COUPLE_A.inc"
118 # include "PERIOD_EM_COUPLE_A.inc"
119 #endif
120
121 ! computations go out one row and column to avoid having to communicate before solver
122
123 IF( couple ) THEN
124
125 ! write(6,*) ' coupling: setting mu arrays '
126
127 DO j = max(jds,jps),min(jde-1,jpe)
128 DO i = max(ids,ips),min(ide-1,ipe)
129 mut_2(i,j) = mub(i,j) + mu_2(i,j)
130 muwt_2(i,j) = (mub(i,j) + mu_2(i,j))/msft(i,j)
131 ENDDO
132 ENDDO
133
134 ! need boundary condition fixes for u and v ???
135
136 ! write(6,*) ' coupling: setting muv and muv arrays '
137
138 DO j = max(jds,jps),min(jde-1,jpe)
139 DO i = max(ids,ips),min(ide-1,ipe)
140 muut_2(i,j) = 0.5*(mub(i,j)+mub(i-1,j) + mu_2(i,j) + mu_2(i-1,j))/msfu(i,j)
141 muvt_2(i,j) = 0.5*(mub(i,j)+mub(i,j-1) + mu_2(i,j) + mu_2(i,j-1))/msfv(i,j)
142 ENDDO
143 ENDDO
144
145 IF ( config_flags%nested .or. config_flags%specified ) THEN
146
147 IF ( jpe .eq. jde ) THEN
148 j = jde
149 DO i = max(ids,ips),min(ide-1,ipe)
150 muvt_2(i,j) = (mub(i,j-1) + mu_2(i,j-1))/msfv(i,j)
151 ENDDO
152 ENDIF
153 IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
154 i = ide
155 DO j = max(jds,jps),min(jde-1,jpe)
156 muut_2(i,j) = (mub(i-1,j) + mu_2(i-1,j))/msfu(i,j)
157 ENDDO
158 ENDIF
159
160 ELSE
161
162 IF ( jpe .eq. jde ) THEN
163 j = jde
164 DO i = max(ids,ips),min(ide-1,ipe)
165 muvt_2(i,j) = 0.5*(mub(i,j)+mub(i,j-1) + mu_2(i,j) + mu_2(i,j-1))/msfv(i,j)
166 ENDDO
167 ENDIF
168 IF ( ipe .eq. ide ) THEN
169 i = ide
170 DO j = max(jds,jps),min(jde-1,jpe)
171 muut_2(i,j) = 0.5*(mub(i,j)+mub(i-1,j) + mu_2(i,j) + mu_2(i-1,j))/msfu(i,j)
172 ENDDO
173 ENDIF
174
175 END IF
176
177 ELSE
178
179 ! write(6,*) ' uncoupling: setting mu arrays '
180
181 DO j = max(jds,jps),min(jde-1,jpe)
182 DO i = max(ids,ips),min(ide-1,ipe)
183 mut_2(i,j) = 1./(mub(i,j) + mu_2(i,j))
184 muwt_2(i,j) = msft(i,j)/(mub(i,j) + mu_2(i,j))
185 ENDDO
186 ENDDO
187
188 ! write(6,*) ' uncoupling: setting muv arrays '
189
190 DO j = max(jds,jps),min(jde-1,jpe)
191 DO i = max(ids,ips),min(ide-1,ipe)
192 muut_2(i,j) = 2.*msfu(i,j)/(mub(i,j)+mub(i-1,j) + mu_2(i,j) + mu_2(i-1,j))
193 ENDDO
194 ENDDO
195
196 DO j = max(jds,jps),min(jde-1,jpe)
197 DO i = max(ids,ips),min(ide-1,ipe)
198 muvt_2(i,j) = 2.*msfv(i,j)/(mub(i,j)+mub(i,j-1) + mu_2(i,j) + mu_2(i,j-1))
199 ENDDO
200 ENDDO
201
202 IF ( config_flags%nested .or. config_flags%specified ) THEN
203
204 IF ( jpe .eq. jde ) THEN
205 j = jde
206 DO i = max(ids,ips),min(ide-1,ipe)
207 muvt_2(i,j) = msfv(i,j)/(mub(i,j-1) + mu_2(i,j-1))
208 ENDDO
209 ENDIF
210 IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
211 i = ide
212 DO j = max(jds,jps),min(jde-1,jpe)
213 muut_2(i,j) = msfu(i,j)/(mub(i-1,j) + mu_2(i-1,j))
214 ENDDO
215 ENDIF
216
217 ELSE
218
219 IF ( jpe .eq. jde ) THEN
220 j = jde
221 DO i = max(ids,ips),min(ide-1,ipe)
222 muvt_2(i,j) = 2.*msfv(i,j)/(mub(i,j)+mub(i,j-1) + mu_2(i,j) + mu_2(i,j-1))
223 ENDDO
224 ENDIF
225 IF ( ipe .eq. ide ) THEN
226 i = ide
227 DO j = max(jds,jps),min(jde-1,jpe)
228 muut_2(i,j) = 2.*msfu(i,j)/(mub(i,j)+mub(i-1,j) + mu_2(i,j) + mu_2(i-1,j))
229 ENDDO
230 ENDIF
231
232 END IF
233
234 END IF
235
236 ! couple/uncouple mu point variables
237
238 !$OMP PARALLEL DO &
239 !$OMP PRIVATE ( i,j,k,im )
240 DO j = max(jds,jps),min(jde-1,jpe)
241
242 DO k = kps,kpe
243 DO i = max(ids,ips),min(ide-1,ipe)
244 ph_2(i,k,j) = ph_2(i,k,j)*mut_2(i,j)
245 w_2(i,k,j) = w_2(i,k,j)*muwt_2(i,j)
246 ENDDO
247 ENDDO
248
249 DO k = kps,kpe-1
250 DO i = max(ids,ips),min(ide-1,ipe)
251 t_2(i,k,j) = t_2(i,k,j)*mut_2(i,j)
252 ENDDO
253 ENDDO
254
255 IF (num_3d_m >= PARAM_FIRST_SCALAR ) THEN
256 DO im = PARAM_FIRST_SCALAR, num_3d_m
257 DO k = kps,kpe-1
258 DO i = max(ids,ips),min(ide-1,ipe)
259 moist(i,k,j,im) = moist(i,k,j,im)*mut_2(i,j)
260 ENDDO
261 ENDDO
262 ENDDO
263 END IF
264
265 #ifdef CHEM
266 IF (num_3d_c >= PARAM_FIRST_SCALAR ) THEN
267 DO im = PARAM_FIRST_SCALAR, num_3d_c
268 DO k = kps,kpe-1
269 DO i = max(ids,ips),min(ide-1,ipe)
270 chem(i,k,j,im) = chem(i,k,j,im)*mut_2(i,j)
271 ENDDO
272 ENDDO
273 ENDDO
274 END IF
275 #endif
276
277 IF (num_3d_s >= PARAM_FIRST_SCALAR ) THEN
278 DO im = PARAM_FIRST_SCALAR, num_3d_s
279 DO k = kps,kpe-1
280 DO i = max(ids,ips),min(ide-1,ipe)
281 scalar(i,k,j,im) = scalar(i,k,j,im)*mut_2(i,j)
282 ENDDO
283 ENDDO
284 ENDDO
285 END IF
286
287 ! do u and v
288
289 DO k = kps,kpe-1
290 DO i = max(ids,ips),min(ide,ipe)
291 u_2(i,k,j) = u_2(i,k,j)*muut_2(i,j)
292 ENDDO
293 ENDDO
294
295 ENDDO ! j loop
296 !$OMP END PARALLEL DO
297
298 !$OMP PARALLEL DO &
299 !$OMP PRIVATE ( i,j,k )
300 DO j = max(jds,jps),min(jde,jpe)
301 DO k = kps,kpe-1
302 DO i = max(ids,ips),min(ide-1,ipe)
303 v_2(i,k,j) = v_2(i,k,j)*muvt_2(i,j)
304 ENDDO
305 ENDDO
306 ENDDO
307 !$OMP END PARALLEL DO
308
309 IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
310 CALL set_physical_bc3d( ph_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( ph_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( w_1, 'w', &
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( w_2, 'w', &
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( t_1, 't', &
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( t_2, 't', &
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( u_1, 'u', &
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( u_2, 'u', &
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 CALL set_physical_bc3d( v_1, 'v', &
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 CALL set_physical_bc3d( v_2, 'v', &
365 config_flags, &
366 ids,ide, jds,jde, kds,kde, & ! domain dims
367 ims,ime, jms,jme, kms,kme, & ! memory dims
368 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
369 ips,ipe, jps,jpe, kps,kpe )
370
371 IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
372 DO im = PARAM_FIRST_SCALAR , num_3d_m
373
374 CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', &
375 config_flags, &
376 ids,ide, jds,jde, kds,kde, & ! domain dims
377 ims,ime, jms,jme, kms,kme, & ! memory dims
378 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
379 ips,ipe, jps,jpe, kps,kpe )
380 ENDDO
381 ENDIF
382
383 #ifdef CHEM
384 IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
385 DO im = PARAM_FIRST_SCALAR , num_3d_c
386
387 CALL set_physical_bc3d( chem(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 #endif
396
397 IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
398 DO im = PARAM_FIRST_SCALAR , num_3d_s
399
400 CALL set_physical_bc3d( scalar(ims,kms,jms,im), 'p', &
401 config_flags, &
402 ids,ide, jds,jde, kds,kde, & ! domain dims
403 ims,ime, jms,jme, kms,kme, & ! memory dims
404 ips,ipe, jps,jpe, kps,kpe, & ! patch dims
405 ips,ipe, jps,jpe, kps,kpe )
406 ENDDO
407 ENDIF
408
409 ENDIF
410
411 #ifdef DM_PARALLEL
412 # include "HALO_EM_COUPLE_B.inc"
413 # include "PERIOD_EM_COUPLE_B.inc"
414 #endif
415
416 END SUBROUTINE couple_or_uncouple_em
417
418 LOGICAL FUNCTION em_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
419 USE module_configure
420 IMPLICIT NONE
421 INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
422 LOGICAL, INTENT(IN) :: xstag, ystag
423
424 INTEGER ioff, joff, spec_zone
425
426 CALL nl_get_spec_zone( 1, spec_zone )
427 ioff = 0 ; joff = 0
428 IF ( xstag ) ioff = 1
429 IF ( ystag ) joff = 1
430
431 em_cd_feedback_mask = ( pig .ge. ips_save+spec_zone .and. &
432 pjg .ge. jps_save+spec_zone .and. &
433 pig .le. ipe_save-spec_zone +ioff .and. &
434 pjg .le. jpe_save-spec_zone +joff )
435
436
437 END FUNCTION em_cd_feedback_mask
438