mediation_nest_move.F
References to this file elsewhere.
1
2 SUBROUTINE med_nest_move ( parent, nest )
3 ! Driver layer
4 USE module_domain
5 USE module_timing
6 USE module_configure
7 USE module_io_domain
8 USE module_dm
9 TYPE(domain) , POINTER :: parent, nest, grid
10 INTEGER dx, dy ! number of parent domain points to move
11 #ifdef MOVE_NESTS
12 ! Local
13 CHARACTER*256 mess
14 INTEGER i, j, p, parent_grid_ratio, dyn_opt
15 INTEGER px, py ! number and direction of nd points to move
16 INTEGER :: ids , ide , jds , jde , kds , kde , &
17 ims , ime , jms , jme , kms , kme , &
18 ips , ipe , jps , jpe , kps , kpe
19 INTEGER ierr, fid
20 LOGICAL input_from_hires
21 LOGICAL saved_restart_value
22 TYPE (grid_config_rec_type) :: config_flags
23 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
24 LOGICAL, EXTERNAL :: should_not_move
25
26 INTERFACE
27 SUBROUTINE med_interp_domain ( parent , nest )
28 USE module_domain
29 TYPE(domain) , POINTER :: parent , nest
30 END SUBROUTINE med_interp_domain
31 SUBROUTINE start_domain ( grid , allowed_to_move )
32 USE module_domain
33 TYPE(domain) :: grid
34 LOGICAL, INTENT(IN) :: allowed_to_move
35 END SUBROUTINE start_domain
36 #if ( EM_CORE == 1 )
37 SUBROUTINE shift_domain_em ( grid, disp_x, disp_y &
38 !
39 # include <em_dummy_new_args.inc>
40 !
41 )
42 USE module_domain
43 USE module_configure
44 USE module_timing
45 IMPLICIT NONE
46 INTEGER disp_x, disp_y
47 TYPE(domain) , POINTER :: grid
48 # include <em_dummy_new_decl.inc>
49 END SUBROUTINE shift_domain_em
50 #endif
51 #if ( NMM_CORE == 1 )
52 #endif
53 LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy )
54 USE module_domain
55 USE module_utility
56 TYPE(domain) , POINTER :: parent , nest
57 INTEGER, INTENT(OUT) :: dx , dy
58 END FUNCTION time_for_move
59 SUBROUTINE input_terrain_rsmas ( grid , &
60 ids , ide , jds , jde , kds , kde , &
61 ims , ime , jms , jme , kms , kme , &
62 ips , ipe , jps , jpe , kps , kpe )
63 USE module_domain
64 TYPE ( domain ) :: grid
65 INTEGER :: ids , ide , jds , jde , kds , kde , &
66 ims , ime , jms , jme , kms , kme , &
67 ips , ipe , jps , jpe , kps , kpe
68 END SUBROUTINE input_terrain_rsmas
69 SUBROUTINE med_nest_feedback ( parent , nest , config_flags )
70 USE module_domain
71 USE module_configure
72 TYPE (domain), POINTER :: nest , parent
73 TYPE (grid_config_rec_type) config_flags
74 END SUBROUTINE med_nest_feedback
75 SUBROUTINE blend_terrain ( ter_interpolated , ter_input , &
76 ids , ide , jds , jde , kds , kde , &
77 ims , ime , jms , jme , kms , kme , &
78 ips , ipe , jps , jpe , kps , kpe )
79 INTEGER :: ids , ide , jds , jde , kds , kde , &
80 ims , ime , jms , jme , kms , kme , &
81 ips , ipe , jps , jpe , kps , kpe
82 REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated
83 REAL , DIMENSION(ims:ime,jms:jme) :: ter_input
84 END SUBROUTINE blend_terrain
85 SUBROUTINE store_terrain ( ter_interpolated , ter_input , &
86 ids , ide , jds , jde , kds , kde , &
87 ims , ime , jms , jme , kms , kme , &
88 ips , ipe , jps , jpe , kps , kpe )
89 INTEGER :: ids , ide , jds , jde , kds , kde , &
90 ims , ime , jms , jme , kms , kme , &
91 ips , ipe , jps , jpe , kps , kpe
92 REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated
93 REAL , DIMENSION(ims:ime,jms:jme) :: ter_input
94 END SUBROUTINE store_terrain
95 END INTERFACE
96
97 ! set grid pointer for code in deref_kludge (if used)
98 grid => nest
99
100 CALL nl_get_dyn_opt ( 1, dyn_opt )
101
102 IF ( should_not_move( nest%id ) ) THEN
103 CALL wrf_message( 'Nest movement is disabled because of namelist settings' )
104 RETURN
105 ENDIF
106
107 ! if the nest has stopped don't do all this
108 IF ( WRFU_ClockIsStopTime(nest%domain_clock ,rc=ierr) ) RETURN
109
110 ! mask should be defined in nest domain
111
112 check_for_move: IF ( time_for_move ( parent , nest , dx, dy ) ) THEN
113
114 IF ( (dx .gt. 1 .or. dx .lt. -1 ) .or. &
115 (dy .gt. 1 .or. dy .lt. -1 ) ) THEN
116 WRITE(mess,*)' invalid move: dx, dy ', dx, dy
117 CALL wrf_error_fatal( mess )
118 ENDIF
119
120 WRITE(mess,*)' moving ',grid%id,dx,dy
121 CALL wrf_message(mess)
122
123 CALL get_ijk_from_grid ( grid , &
124 ids, ide, jds, jde, kds, kde, &
125 ims, ime, jms, jme, kms, kme, &
126 ips, ipe, jps, jpe, kps, kpe )
127
128 CALL wrf_dm_move_nest ( parent, nest%intermediate_grid, dx, dy )
129
130 CALL adjust_domain_dims_for_move( nest%intermediate_grid , dx, dy )
131
132 CALL get_ijk_from_grid ( grid , &
133 ids, ide, jds, jde, kds, kde, &
134 ims, ime, jms, jme, kms, kme, &
135 ips, ipe, jps, jpe, kps, kpe )
136
137 grid => nest
138
139 #if ( EM_CORE == 1 )
140 IF ( dyn_opt .EQ. DYN_EM ) THEN
141 CALL shift_domain_em( grid, dx, dy &
142 !
143 # include <em_actual_new_args.inc>
144 !
145 )
146 ENDIF
147 #endif
148 #if ( WRF_NMM_CORE == 1 )
149 IF ( dyn_opt .EQ. DYN_NMM ) THEN
150 ENDIF
151 #endif
152
153 px = grid%parent_grid_ratio*dx
154 py = grid%parent_grid_ratio*dy
155
156 grid%i_parent_start = grid%i_parent_start + px / grid%parent_grid_ratio
157 CALL nl_set_i_parent_start( grid%id, grid%i_parent_start )
158 grid%j_parent_start = grid%j_parent_start + py / grid%parent_grid_ratio
159 CALL nl_set_j_parent_start( grid%id, grid%j_parent_start )
160
161 IF ( wrf_dm_on_monitor() ) THEN
162 write(mess,*) &
163 'Grid ',grid%id,' New SW corner (in parent x and y):',grid%i_parent_start, grid%j_parent_start
164 CALL wrf_message(TRIM(mess))
165 ENDIF
166
167 CALL med_interp_domain( parent, nest )
168
169 CALL nl_get_input_from_hires( nest%id , input_from_hires )
170 IF ( input_from_hires ) THEN
171
172 ! store horizontally interpolated terrain in temp location
173 CALL store_terrain ( nest%ht_fine , nest%ht , &
174 ids , ide , jds , jde , 1 , 1 , &
175 ims , ime , jms , jme , 1 , 1 , &
176 ips , ipe , jps , jpe , 1 , 1 )
177 CALL store_terrain ( nest%em_mub_fine , nest%em_mub , &
178 ids , ide , jds , jde , 1 , 1 , &
179 ims , ime , jms , jme , 1 , 1 , &
180 ips , ipe , jps , jpe , 1 , 1 )
181 CALL store_terrain ( nest%em_phb_fine , nest%em_phb , &
182 ids , ide , jds , jde , kds , kde , &
183 ims , ime , jms , jme , kms , kme , &
184 ips , ipe , jps , jpe , kps , kpe )
185
186 CALL input_terrain_rsmas ( nest, &
187 ids , ide , jds , jde , 1 , 1 , &
188 ims , ime , jms , jme , 1 , 1 , &
189 ips , ipe , jps , jpe , 1 , 1 )
190
191 CALL blend_terrain ( nest%ht_fine , nest%ht , &
192 ids , ide , jds , jde , 1 , 1 , &
193 ims , ime , jms , jme , 1 , 1 , &
194 ips , ipe , jps , jpe , 1 , 1 )
195 CALL blend_terrain ( nest%em_mub_fine , nest%em_mub , &
196 ids , ide , jds , jde , 1 , 1 , &
197 ims , ime , jms , jme , 1 , 1 , &
198 ips , ipe , jps , jpe , 1 , 1 )
199 CALL blend_terrain ( nest%em_phb_fine , nest%em_phb , &
200 ids , ide , jds , jde , kds , kde , &
201 ims , ime , jms , jme , kms , kme , &
202 ips , ipe , jps , jpe , kps , kpe )
203 !
204 CALL model_to_grid_config_rec ( parent%id , model_config_rec , config_flags )
205
206 CALL med_nest_feedback ( parent , nest , config_flags )
207 parent%imask_nostag = 1
208 parent%imask_xstag = 1
209 parent%imask_ystag = 1
210 parent%imask_xystag = 1
211
212 ! start_domain will key off "restart". Even if this is a restart run
213 ! we don't want it to here. Save the value, set it to false, and restore afterwards
214 saved_restart_value = config_flags%restart
215 config_flags%restart = .FALSE.
216 grid%restart = .FALSE.
217 CALL nl_set_restart ( 1, .FALSE. )
218 CALL start_domain ( parent , .FALSE. )
219 config_flags%restart = saved_restart_value
220 grid%restart = saved_restart_value
221 CALL nl_set_restart ( 1, saved_restart_value )
222
223 ENDIF
224
225 !
226 ! masks associated with nest will have been set by shift_domain_em above
227 nest%moved = .true.
228 ! start_domain will key off "restart". Even if this is a restart run
229 ! we don't want it to here. Save the value, set it to false, and restore afterwards
230 saved_restart_value = config_flags%restart
231 config_flags%restart = .FALSE.
232 CALL nl_set_restart ( 1, .FALSE. )
233 grid%restart = .FALSE.
234 CALL start_domain ( nest , .FALSE. )
235 config_flags%restart = saved_restart_value
236 grid%restart = saved_restart_value
237 CALL nl_set_restart ( 1, saved_restart_value )
238 nest%moved = .false.
239
240 !
241 ! copy time level 2 to time level 1 in new regions of multi-time level fields
242 ! this should be registry generated.
243 !
244 #if ( EM_CORE == 1 )
245 IF ( dyn_opt .EQ. DYN_EM ) THEN
246 do k = kms,kme
247 where ( nest%imask_xstag .EQ. 1 ) nest%em_u_1(:,k,:) = nest%em_u_2(:,k,:)
248 where ( nest%imask_ystag .EQ. 1 ) nest%em_v_1(:,k,:) = nest%em_v_2(:,k,:)
249 where ( nest%imask_nostag .EQ. 1 ) nest%em_t_1(:,k,:) = nest%em_t_2(:,k,:)
250 where ( nest%imask_nostag .EQ. 1 ) nest%em_w_1(:,k,:) = nest%em_w_2(:,k,:)
251 where ( nest%imask_nostag .EQ. 1 ) nest%em_ph_1(:,k,:) = nest%em_ph_2(:,k,:)
252 where ( nest%imask_nostag .EQ. 1 ) nest%em_tp_1(:,k,:) = nest%em_tp_2(:,k,:)
253 where ( nest%imask_nostag .EQ. 1 ) nest%em_tke_1(:,k,:) = nest%em_tke_2(:,k,:)
254 enddo
255 where ( nest%imask_nostag .EQ. 1 ) nest%em_mu_1(:,:) = nest%em_mu_2(:,:)
256 ENDIF
257 #endif
258 #if ( WRF_NMM_CORE == 1 )
259 IF ( dyn_opt .EQ. DYN_NMM ) THEN
260 ENDIF
261 #endif
262 !
263 ENDIF check_for_move
264 #endif
265 END SUBROUTINE med_nest_move
266
267 LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y )
268 ! Driver layer
269 USE module_domain
270 USE module_configure
271 USE module_compute_geop
272 USE module_dm
273 USE module_utility
274 IMPLICIT NONE
275 ! Arguments
276 TYPE(domain) , POINTER :: parent, grid
277 INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
278 #ifdef MOVE_NESTS
279 ! Local
280 INTEGER num_moves, rc
281 INTEGER move_interval , move_id
282 TYPE(WRFU_Time) :: ct, st
283 TYPE(WRFU_TimeInterval) :: ti
284 CHARACTER*256 mess, timestr
285 INTEGER :: ids, ide, jds, jde, kds, kde, &
286 ims, ime, jms, jme, kms, kme, &
287 ips, ipe, jps, jpe, kps, kpe
288 INTEGER :: is, ie, js, je, ierr
289 REAL :: ipbar, pbar, jpbar, fact
290 REAL :: last_vc_i , last_vc_j
291
292 REAL, ALLOCATABLE, DIMENSION(:,:) :: height_l, height
293 REAL, ALLOCATABLE, DIMENSION(:,:) :: psfc, xlat, xlong, terrain
294 REAL :: minh, maxh
295 INTEGER :: mini, minj, maxi, maxj, i, j, pgr, irad
296 REAL :: disp_x, disp_y, lag, radius, center_i, center_j, dx
297 REAL :: dijsmooth, vmax, vmin, a, b
298 REAL :: dc_i, dc_j ! domain center
299 REAL :: maxws, ws
300 REAL :: pmin
301 INTEGER imploc, jmploc
302
303 INTEGER :: fje, fjs, fie, fis, fimloc, fjmloc, imloc, jmloc, dyn_opt
304 INTEGER :: i_parent_start, j_parent_start
305 INTEGER :: max_vortex_speed, vortex_interval ! meters per second and seconds
306 REAL :: rsmooth = 100. ! kilometers?
307
308 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
309
310 character*256 message, message2
311
312 !#define MOVING_DIAGS
313 # ifdef VORTEX_CENTER
314
315
316 CALL nl_get_dyn_opt ( 1, dyn_opt )
317 CALL nl_get_parent_grid_ratio ( grid%id , pgr )
318 CALL nl_get_i_parent_start ( grid%id , i_parent_start )
319 CALL nl_get_j_parent_start ( grid%id , j_parent_start )
320
321 CALL get_ijk_from_grid ( grid , &
322 ids, ide, jds, jde, kds, kde, &
323 ims, ime, jms, jme, kms, kme, &
324 ips, ipe, jps, jpe, kps, kpe )
325
326 ! If the alarm is ringing, recompute the Vortex Center (VC); otherwise
327 ! use the previous position of VC. VC is not recomputed ever step to
328 ! save on cost for global collection of height field and broadcast
329 ! of new center.
330
331 # ifdef MOVING_DIAGS
332 write(0,*)'Check to see if COMPUTE_VORTEX_CENTER_ALARM is ringing? '
333 # endif
334 CALL nl_get_parent_grid_ratio ( grid%id , pgr )
335 CALL nl_get_dx ( grid%id , dx )
336
337 IF ( WRFU_AlarmIsRinging( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) ) THEN
338
339 # ifdef MOVING_DIAGS
340 write(0,*)'COMPUTE_VORTEX_CENTER_ALARM is ringing '
341 # endif
342 CALL WRFU_AlarmRingerOff( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc )
343 CALL domain_clock_get( grid, current_timestr=timestr )
344
345 last_vc_i = grid%vc_i
346 last_vc_j = grid%vc_j
347
348 ALLOCATE ( height_l ( ims:ime , jms:jme ), STAT=ierr )
349 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height_l in time_for_move2')
350 IF ( wrf_dm_on_monitor() ) THEN
351 ALLOCATE ( height ( ids:ide , jds:jde ), STAT=ierr )
352 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2')
353 ALLOCATE ( psfc ( ids:ide , jds:jde ), STAT=ierr )
354 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2')
355 ALLOCATE ( xlat ( ids:ide , jds:jde ), STAT=ierr )
356 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2')
357 ALLOCATE ( xlong ( ids:ide , jds:jde ), STAT=ierr )
358 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2')
359 ALLOCATE ( terrain ( ids:ide , jds:jde ), STAT=ierr )
360 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2')
361 ELSE
362 ALLOCATE ( height ( 1:1 , 1:1 ), STAT=ierr )
363 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2')
364 ALLOCATE ( psfc ( 1:1 , 1:1 ), STAT=ierr )
365 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2')
366 ALLOCATE ( xlat ( 1:1 , 1:1 ), STAT=ierr )
367 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2')
368 ALLOCATE ( xlong ( 1:1 , 1:1 ), STAT=ierr )
369 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2')
370 ALLOCATE ( terrain ( 1:1 , 1:1 ), STAT=ierr )
371 IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2')
372 ENDIF
373
374 # if (EM_CORE == 1)
375 IF ( dyn_opt .EQ. DYN_EM ) THEN
376 CALL compute_500mb_height ( grid%em_ph_2 , grid%em_phb, grid%em_p, grid%em_pb, height_l , &
377 ids, ide, jds, jde, kds, kde, &
378 ims, ime, jms, jme, kms, kme, &
379 ips, ipe, jps, jpe, kps, kpe )
380 ENDIF
381 # endif
382 # if (WRF_NMM_CORE == 1)
383 IF ( dyn_opt .EQ. DYN_NMM ) THEN
384 ENDIF
385 # endif
386
387 CALL wrf_patch_to_global_real ( height_l , height , grid%domdesc, "z", "xy", &
388 ids, ide-1 , jds , jde-1 , 1 , 1 , &
389 ims, ime , jms , jme , 1 , 1 , &
390 ips, ipe , jps , jpe , 1 , 1 )
391 CALL wrf_patch_to_global_real ( grid%psfc , psfc , grid%domdesc, "z", "xy", &
392 ids, ide-1 , jds , jde-1 , 1 , 1 , &
393 ims, ime , jms , jme , 1 , 1 , &
394 ips, ipe , jps , jpe , 1 , 1 )
395 CALL wrf_patch_to_global_real ( grid%xlat , xlat , grid%domdesc, "z", "xy", &
396 ids, ide-1 , jds , jde-1 , 1 , 1 , &
397 ims, ime , jms , jme , 1 , 1 , &
398 ips, ipe , jps , jpe , 1 , 1 )
399 CALL wrf_patch_to_global_real ( grid%xlong , xlong , grid%domdesc, "z", "xy", &
400 ids, ide-1 , jds , jde-1 , 1 , 1 , &
401 ims, ime , jms , jme , 1 , 1 , &
402 ips, ipe , jps , jpe , 1 , 1 )
403 CALL wrf_patch_to_global_real ( grid%ht , terrain , grid%domdesc, "z", "xy", &
404 ids, ide-1 , jds , jde-1 , 1 , 1 , &
405 ims, ime , jms , jme , 1 , 1 , &
406 ips, ipe , jps , jpe , 1 , 1 )
407
408 ! calculate max wind speed
409 maxws = 0.
410 do j = jps, jpe
411 do i = ips, ipe
412 ws = grid%u10(i,j) * grid%u10(i,j) + grid%v10(i,j) * grid%v10(i,j)
413 if ( ws > maxws ) maxws = ws
414 enddo
415 enddo
416 maxws = sqrt ( maxws )
417 maxws = wrf_dm_max_real ( maxws )
418
419 monitor_only : IF ( wrf_dm_on_monitor() ) THEN
420
421 !
422 ! This vortex center finding code adapted from the Hurricane version of MM5,
423 ! Courtesy:
424 !
425 ! Shuyi Chen et al., Rosenstiel School of Marine and Atmos. Sci., U. Miami.
426 ! Spring, 2005
427 !
428 ! Get the first guess vortex center about which we do our search
429 ! as mini and minh; minimum value is minh
430 !
431
432 CALL nl_get_vortex_interval( grid%id , vortex_interval )
433 CALL nl_get_max_vortex_speed( grid%id , max_vortex_speed )
434
435 IF ( grid%vc_i < 0. .AND. grid%vc_j < 0. ) THEN
436 ! first time through
437 is = ids
438 ie = ide-1
439 js = jds
440 je = jde-1
441 ELSE
442 ! limit the search to an area around the vortex
443 ! that is limited by max_vortex_speed (default 40) meters per second from
444 ! previous location over vortex_interval (default 15 mins)
445
446 is = max( grid%vc_i - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * ids )
447 js = max( grid%vc_j - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * jds )
448 ie = min( grid%vc_i + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (ide-1) )
449 je = min( grid%vc_j + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (jde-1) )
450
451 ENDIF
452
453 # ifdef MOVING_DIAGS
454 write(0,*)'search set around last position '
455 write(0,*)' is, ids-1, ie, ide-1 ', is, ids-1, ie, ide-1
456 write(0,*)' js, jds-1, je, jde-1 ', js, jds-1, je, jde-1
457 # endif
458
459 imploc = -1
460 jmploc = -1
461
462 ! find minimum psfc
463 pmin = 99999999.0 ! make this very large to be sure we find a minumum
464 DO j = js, je
465 DO i = is, ie
466 IF ( psfc(i,j) .LT. pmin ) THEN
467 pmin = psfc(i,j)
468 imploc = i
469 jmploc = j
470 ENDIF
471 ENDDO
472 ENDDO
473
474 IF ( imploc .EQ. -1 .OR. jmploc .EQ. -1 ) THEN ! if we fail to find a min there is something seriously wrong
475 WRITE(mess,*)'i,j,is,ie,js,je,imploc,jmploc ',i,j,is,ie,js,je,imploc,jmploc
476 CALL wrf_message(mess)
477 CALL wrf_error_fatal('time_for_move2: Method failure searching for minimum psfc.')
478 ENDIF
479
480 imloc = -1
481 jmloc = -1
482 maxi = -1
483 maxj = -1
484
485 ! find local min, max
486 vmin = 99999999.0
487 vmax = -99999999.0
488 DO j = js, je
489 DO i = is, ie
490 IF ( height(i,j) .LT. vmin ) THEN
491 vmin = height(i,j)
492 imloc = i
493 jmloc = j
494 ENDIF
495 IF ( height(i,j) .GT. vmax ) THEN
496 vmax = height(i,j)
497 maxi = i
498 maxj = j
499 ENDIF
500 ENDDO
501 ENDDO
502
503 IF ( imloc .EQ. -1 .OR. jmloc .EQ. -1 .OR. maxi .EQ. -1 .OR. maxj .EQ. -1 ) THEN
504 WRITE(mess,*)'i,j,is,ie,js,je,imloc,jmloc,maxi,maxj ',i,j,is,ie,js,je,imloc,jmloc,maxi,maxj
505 CALL wrf_message(mess)
506 CALL wrf_error_fatal('time_for_move2: Method failure searching max/min of height.')
507 ENDIF
508
509 fimloc = imloc
510 fjmloc = jmloc
511
512 if ( grid%xi .EQ. -1. ) grid%xi = fimloc
513 if ( grid%xj .EQ. -1. ) grid%xj = fjmloc
514
515 dijsmooth = rsmooth / dx
516
517 fjs = max(fjmloc-dijsmooth,1.0)
518 fje = min(fjmloc+dijsmooth,jde-2.0)
519 fis = max(fimloc-dijsmooth,1.0)
520 fie = min(fimloc+dijsmooth,ide-2.0)
521 js = fjs
522 je = fje
523 is = fis
524 ie = fie
525
526 vmin = 1000000.0
527 vmax = -1000000.0
528 DO j = js, je
529 DO i = is, ie
530 IF ( height(i,j) .GT. vmax ) THEN
531 vmax = height(i,j)
532 ENDIF
533 ENDDO
534 ENDDO
535
536 pbar = 0.0
537 ipbar = 0.0
538 jpbar = 0.0
539
540 do j=js,je
541 do i=is,ie
542 fact = vmax - height(i,j)
543 pbar = pbar + fact
544 ipbar = ipbar + fact*(i-is)
545 jpbar = jpbar + fact*(j-js)
546 enddo
547 enddo
548
549 IF ( pbar .NE. 0. ) THEN
550
551 ! Compute an adjusted, smoothed, vortex center location in cross
552 ! point index space.
553 ! Time average. A is coef for old information; B is new
554 ! If pbar is zero then just skip this, leave xi and xj alone,
555 ! result will be no movement.
556 a = 0.0
557 b = 1.0
558 grid%xi = (a * grid%xi + b * (is + ipbar / pbar)) / ( a + b )
559 grid%xj = (a * grid%xj + b * (js + jpbar / pbar)) / ( a + b )
560
561 grid%vc_i = grid%xi + .5
562 grid%vc_j = grid%xj + .5
563
564
565 ENDIF
566
567 # ifdef MOVING_DIAGS
568 write(0,*)'computed grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
569 i = grid%vc_i ; j = grid%vc_j ; height( i,j ) = height(i,j) * 1.2 !mark the center
570 CALL domain_clock_get( grid, current_timestr=message2 )
571 WRITE ( message , FMT = '(A," on domain ",I3)' ) TRIM(message2), grid%id
572 # endif
573
574 !
575 i = INT(grid%xi+.5)
576 j = INT(grid%xj+.5)
577 write(mess,'("ATCF"," ",A19," ",f8.2," ",f8.2," ",f6.1," ",f6.1)') &
578 timestr(1:19), &
579 xlat(i,j), &
580 xlong(i,j), &
581 0.01*pmin+0.1138*terrain(imploc,jmploc), &
582 maxws*1.94
583 CALL wrf_message(TRIM(mess))
584
585
586
587 ENDIF monitor_only
588
589 DEALLOCATE ( psfc )
590 DEALLOCATE ( xlat )
591 DEALLOCATE ( xlong )
592 DEALLOCATE ( terrain )
593 DEALLOCATE ( height )
594 DEALLOCATE ( height_l )
595
596 CALL wrf_dm_bcast_real( grid%vc_i , 1 )
597 CALL wrf_dm_bcast_real( grid%vc_j , 1 )
598
599 CALL wrf_dm_bcast_real( pmin , 1 )
600 CALL wrf_dm_bcast_integer( imploc , 1 )
601 CALL wrf_dm_bcast_integer( jmploc , 1 )
602
603 # ifdef MOVING_DIAGS
604 write(0,*)'after bcast : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
605 # endif
606
607
608 ENDIF ! COMPUTE_VORTEX_CENTER_ALARM ringing
609
610 # ifdef MOVING_DIAGS
611 write(0,*)'After ENDIF : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
612 # endif
613
614 dc_i = (ide-ids+1)/2. ! domain center
615 dc_j = (jde-jds+1)/2.
616
617 disp_x = grid%vc_i - dc_i * 1.0
618 disp_y = grid%vc_j - dc_j * 1.0
619
620 #if 0
621 ! This appears to be an old, redundant, and perhaps even misnamed parameter.
622 ! Remove it from the namelist and Registry and just hard code it to
623 ! the default of 6. JM 20050721
624 CALL nl_get_vortex_search_radius( 1, irad )
625 #else
626 irad = 6
627 #endif
628
629 radius = irad
630
631 if ( disp_x .GT. 0 ) disp_x = min( disp_x , radius )
632 if ( disp_y .GT. 0 ) disp_y = min( disp_y , radius )
633
634 if ( disp_x .LT. 0 ) disp_x = max( disp_x , -radius )
635 if ( disp_y .LT. 0 ) disp_y = max( disp_y , -radius )
636
637 move_cd_x = int ( disp_x / pgr )
638 move_cd_y = int ( disp_y / pgr )
639
640 IF ( move_cd_x .GT. 0 ) move_cd_x = min ( move_cd_x , 1 )
641 IF ( move_cd_y .GT. 0 ) move_cd_y = min ( move_cd_y , 1 )
642 IF ( move_cd_x .LT. 0 ) move_cd_x = max ( move_cd_x , -1 )
643 IF ( move_cd_y .LT. 0 ) move_cd_y = max ( move_cd_y , -1 )
644
645 CALL domain_clock_get( grid, current_timestr=timestr )
646
647 WRITE(mess,*)timestr(1:19),' vortex center (in nest x and y): ',grid%vc_i, grid%vc_j
648 CALL wrf_message(TRIM(mess))
649 WRITE(mess,*)timestr(1:19),' grid center (in nest x and y): ', dc_i, dc_j
650 CALL wrf_message(TRIM(mess))
651 WRITE(mess,*)timestr(1:19),' disp : ', disp_x, disp_y
652 CALL wrf_message(TRIM(mess))
653 WRITE(mess,*)timestr(1:19),' move (rel cd) : ',move_cd_x, move_cd_y
654 CALL wrf_message(TRIM(mess))
655
656 grid%vc_i = grid%vc_i - move_cd_x * pgr
657 grid%vc_j = grid%vc_j - move_cd_y * pgr
658
659 # ifdef MOVING_DIAGS
660 write(0,*)' changing grid%vc_i, move_cd_x * pgr ', grid%vc_i, move_cd_x * pgr, move_cd_x, pgr
661 # endif
662
663 IF ( ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) ) THEN
664 time_for_move2 = .TRUE.
665 ELSE
666 time_for_move2 = .FALSE.
667 ENDIF
668
669 # else
670 ! from namelist
671 move_cd_x = 0
672 move_cd_y = 0
673 time_for_move2 = .FALSE.
674 CALL domain_clock_get( grid, current_time=ct, start_time=st )
675 CALL nl_get_num_moves( 1, num_moves )
676 IF ( num_moves .GT. max_moves ) THEN
677 WRITE(mess,*)'time_for_moves2: num_moves (',num_moves,') .GT. max_moves (',max_moves,')'
678 CALL wrf_error_fatal( TRIM(mess) )
679 ENDIF
680 DO i = 1, num_moves
681 CALL nl_get_move_id( i, move_id )
682 IF ( move_id .EQ. grid%id ) THEN
683 CALL nl_get_move_interval( i, move_interval )
684 IF ( move_interval .LT. 999999999 ) THEN
685 CALL WRFU_TimeIntervalSet ( ti, M=move_interval, rc=rc )
686 IF ( ct .GE. st + ti ) THEN
687 CALL nl_get_move_cd_x ( i, move_cd_x )
688 CALL nl_get_move_cd_y ( i, move_cd_y )
689 CALL nl_set_move_interval ( i, 999999999 )
690 time_for_move2 = .TRUE.
691 EXIT
692 ENDIF
693 ENDIF
694 ENDIF
695 ENDDO
696 # endif
697 RETURN
698 #endif
699 END FUNCTION time_for_move2
700
701 LOGICAL FUNCTION time_for_move ( parent , grid , move_cd_x, move_cd_y )
702 USE module_domain
703 USE module_configure
704 USE module_dm
705 USE module_timing
706 USE module_utility
707 IMPLICIT NONE
708 ! arguments
709 TYPE(domain) , POINTER :: parent, grid, par, nst
710 INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
711 #ifdef MOVE_NESTS
712 ! local
713 INTEGER :: corral_dist, kid
714 INTEGER :: dw, de, ds, dn, pgr
715 INTEGER :: would_move_x, would_move_y
716 INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
717 cims, cime, cjms, cjme, ckms, ckme, &
718 cips, cipe, cjps, cjpe, ckps, ckpe, &
719 nids, nide, njds, njde, nkds, nkde, &
720 nims, nime, njms, njme, nkms, nkme, &
721 nips, nipe, njps, njpe, nkps, nkpe
722 ! interface
723 INTERFACE
724 LOGICAL FUNCTION time_for_move2 ( parent , nest , dx , dy )
725 USE module_domain
726 USE module_utility
727 TYPE(domain) , POINTER :: parent , nest
728 INTEGER, INTENT(OUT) :: dx , dy
729 END FUNCTION time_for_move2
730 END INTERFACE
731 ! executable
732 !
733 ! Simplifying assumption: domains in moving nest simulations have only
734 ! one parent and only one child.
735
736 IF ( grid%num_nests .GT. 1 ) THEN
737 CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
738 ENDIF
739 kid = 1
740 !
741 ! find out if this is the innermost nest (will not have kids)
742 IF ( grid%num_nests .EQ. 0 ) THEN
743 ! code that executes on innermost nest
744 time_for_move = time_for_move2 ( parent , grid , move_cd_x, move_cd_y )
745
746 ! Make sure the parent can move before allowing the nest to approach
747 ! its boundary
748 par => grid%parents(1)%ptr
749 nst => grid
750
751 would_move_x = move_cd_x
752 would_move_y = move_cd_y
753
754 ! top of until loop
755 100 CONTINUE
756 CALL nl_get_corral_dist ( nst%id , corral_dist )
757 CALL get_ijk_from_grid ( nst , &
758 nids, nide, njds, njde, nkds, nkde, &
759 nims, nime, njms, njme, nkms, nkme, &
760 nips, nipe, njps, njpe, nkps, nkpe )
761 CALL get_ijk_from_grid ( par , &
762 cids, cide, cjds, cjde, ckds, ckde, &
763 cims, cime, cjms, cjme, ckms, ckme, &
764 cips, cipe, cjps, cjpe, ckps, ckpe )
765 CALL nl_get_parent_grid_ratio ( nst%id , pgr )
766 ! perform measurements...
767 ! from western boundary
768 dw = nst%i_parent_start + would_move_x - cids
769 ! from southern boundary
770 ds = nst%j_parent_start + would_move_y - cjds
771 ! from eastern boundary
772 de = cide - ( nst%i_parent_start + (nide-nids+1)/pgr + would_move_x )
773 ! from northern boundary
774 dn = cjde - ( nst%j_parent_start + (njde-njds+1)/pgr + would_move_y )
775
776 ! would this generate a move on the parent?
777 would_move_x = 0
778 would_move_y = 0
779 if ( dw .LE. corral_dist ) would_move_x = would_move_x - 1
780 if ( de .LE. corral_dist ) would_move_x = would_move_x + 1
781 if ( ds .LE. corral_dist ) would_move_y = would_move_y - 1
782 if ( dn .LE. corral_dist ) would_move_y = would_move_y + 1
783
784 IF ( par%id .EQ. 1 ) THEN
785 IF ( would_move_x .NE. 0 .AND. move_cd_x .NE. 0 ) THEN
786 CALL wrf_message('MOAD can not move. Cancelling nest move in X')
787 if ( grid%num_nests .eq. 0 ) grid%vc_i = grid%vc_i + move_cd_x * pgr ! cancel effect of move
788 move_cd_x = 0
789 ENDIF
790 IF ( would_move_y .NE. 0 .AND. move_cd_y .NE. 0 ) THEN
791 CALL wrf_message('MOAD can not move. Cancelling nest move in Y')
792 if ( grid%num_nests .eq. 0 ) grid%vc_j = grid%vc_j + move_cd_y * pgr ! cancel effect of move
793 move_cd_y = 0
794 ENDIF
795 ELSE
796 nst => par
797 par => nst%parents(1)%ptr
798 GOTO 100
799 ENDIF
800
801 ! bottom of until loop
802 time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
803
804 ELSE
805 ! code that executes on parent to see if parent needs to move
806 ! get closest number of cells we'll allow nest edge to approach parent bdy
807 CALL nl_get_corral_dist ( grid%nests(kid)%ptr%id , corral_dist )
808 ! get dims
809 CALL get_ijk_from_grid ( grid%nests(kid)%ptr , &
810 nids, nide, njds, njde, nkds, nkde, &
811 nims, nime, njms, njme, nkms, nkme, &
812 nips, nipe, njps, njpe, nkps, nkpe )
813 CALL get_ijk_from_grid ( grid , &
814 cids, cide, cjds, cjde, ckds, ckde, &
815 cims, cime, cjms, cjme, ckms, ckme, &
816 cips, cipe, cjps, cjpe, ckps, ckpe )
817 CALL nl_get_parent_grid_ratio ( grid%nests(kid)%ptr%id , pgr )
818 ! perform measurements...
819 ! from western boundary
820 dw = grid%nests(kid)%ptr%i_parent_start - 1
821 ! from southern boundary
822 ds = grid%nests(kid)%ptr%j_parent_start - 1
823 ! from eastern boundary
824 de = cide - ( grid%nests(kid)%ptr%i_parent_start + (nide-nids+1)/pgr )
825 ! from northern boundary
826 dn = cjde - ( grid%nests(kid)%ptr%j_parent_start + (njde-njds+1)/pgr )
827
828 ! move this domain (the parent containing the moving nest)
829 ! in a direction that reestablishes the distance from
830 ! the boundary.
831 move_cd_x = 0
832 move_cd_y = 0
833 if ( dw .LE. corral_dist ) move_cd_x = move_cd_x - 1
834 if ( de .LE. corral_dist ) move_cd_x = move_cd_x + 1
835 if ( ds .LE. corral_dist ) move_cd_y = move_cd_y - 1
836 if ( dn .LE. corral_dist ) move_cd_y = move_cd_y + 1
837
838 time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
839
840 IF ( time_for_move ) THEN
841 IF ( grid%id .EQ. 1 ) THEN
842
843 CALL wrf_message( 'DANGER: Nest has moved too close to boundary of outermost domain.' )
844 time_for_move = .FALSE.
845
846 ELSE
847 ! need to adjust the intermediate domain of the nest in relation to this
848 ! domain since we're moving
849
850 CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr )
851 CALL adjust_domain_dims_for_move( grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr )
852 grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr
853 CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start )
854 grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr
855 CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start )
856
857 ENDIF
858 ENDIF
859
860 ENDIF
861
862 RETURN
863 #endif
864 END FUNCTION time_for_move
865
866 ! Put any tests for non-moving options or conditions in here
867 LOGICAL FUNCTION should_not_move ( id )
868 USE module_state_description
869 USE module_configure
870 IMPLICIT NONE
871 INTEGER, INTENT(IN) :: id
872 ! Local
873 LOGICAL retval
874 INTEGER cu_physics, ra_sw_physics, ra_lw_physics, ucmcall, obs_nudge_opt
875
876 retval = .FALSE.
877 ! check for GD ensemble cumulus, which can not move
878 CALL nl_get_cu_physics( id , cu_physics )
879 IF ( cu_physics .EQ. GDSCHEME ) THEN
880 CALL wrf_message('Grell cumulus can not be specified with moving nests. Movement disabled.')
881 retval = .TRUE.
882 ENDIF
883 ! check for CAM radiation scheme , which can not move
884 CALL nl_get_ra_sw_physics( id , ra_sw_physics )
885 IF ( ra_sw_physics .EQ. CAMSWSCHEME ) THEN
886 CALL wrf_message('CAM SW radiation can not be specified with moving nests. Movement disabled.')
887 retval = .TRUE.
888 ENDIF
889 CALL nl_get_ra_lw_physics( id , ra_lw_physics )
890 IF ( ra_lw_physics .EQ. CAMLWSCHEME ) THEN
891 CALL wrf_message('CAM LW radiation can not be specified with moving nests. Movement disabled.')
892 retval = .TRUE.
893 ENDIF
894 ! check for urban canopy Noah LSM, which can not move
895 CALL nl_get_ucmcall( id , ucmcall )
896 IF ( ucmcall .EQ. 1 ) THEN
897 CALL wrf_message('UCM Noah LSM can not be specified with moving nests. Movement disabled.')
898 retval = .TRUE.
899 ENDIF
900 ! check for observation nudging, which can not move
901 CALL nl_get_obs_nudge_opt( id , obs_nudge_opt )
902 IF ( obs_nudge_opt .EQ. 1 ) THEN
903 CALL wrf_message('Observation nudging can not be specified with moving nests. Movement disabled.')
904 retval = .TRUE.
905 ENDIF
906 should_not_move = retval
907 END FUNCTION
908