Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mediation_nest_move.F @ 2661

Last change on this file since 2661 was 1, checked in by lfita, 10 years ago

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 65.8 KB

Line
1
2	SUBROUTINE med_nest_move ( parent, nest )
3	! Driver layer
4	USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move
5	USE module_utility
6	USE module_timing
7	USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
8	USE module_state_description
9	! USE module_io_domain
10	USE module_dm, ONLY : wrf_dm_move_nest
11	TYPE(domain) , POINTER :: parent, nest, grid
12	INTEGER dx, dy ! number of parent domain points to move
13	#ifdef MOVE_NESTS
14	! Local
15	CHARACTER*256 mess
16	INTEGER i, j, p, parent_grid_ratio
17	INTEGER px, py ! number and direction of nd points to move
18	INTEGER :: ids , ide , jds , jde , kds , kde , &
19	ims , ime , jms , jme , kms , kme , &
20	ips , ipe , jps , jpe , kps , kpe
21	INTEGER ierr, fid
22	#ifdef HWRF
23	REAL,PARAMETER :: con_g =9.80665e+0! gravity (m/s2)
24	REAL,PARAMETER :: con_rd =2.8705e+2 ! gas constant air (J/kg/K)
25	REAL :: TLAP,TBAR,EPSI
26	#endif
27	LOGICAL input_from_hires
28	LOGICAL saved_restart_value
29	TYPE (grid_config_rec_type) :: config_flags
30	LOGICAL, EXTERNAL :: wrf_dm_on_monitor
31	LOGICAL, EXTERNAL :: should_not_move
32	#ifdef HWRFX
33	!XUEJIN added for HWRFx
34	INTEGER :: k,idum1,idum2
35	INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE
36	#else
37	!
38	#endif
39
40	INTERFACE
41	SUBROUTINE med_interp_domain ( parent , nest )
42	USE module_domain, ONLY : domain
43	IMPLICIT NONE
44	TYPE(domain) , POINTER :: parent , nest
45	END SUBROUTINE med_interp_domain
46	!#ifdef HWRFX
47	! XUEJIN added this directive here to exclude the ARW code
48	!#else
49	SUBROUTINE start_domain ( grid , allowed_to_move )
50	USE module_domain, ONLY : domain
51	IMPLICIT NONE
52	TYPE(domain) :: grid
53	LOGICAL, INTENT(IN) :: allowed_to_move
54	END SUBROUTINE start_domain
55	!#endif
56	#if ( EM_CORE == 1 )
57	SUBROUTINE shift_domain_em ( grid, disp_x, disp_y &
58	!
59	# include <dummy_new_args.inc>
60	!
61	)
62	USE module_domain, ONLY : domain
63	USE module_state_description
64	IMPLICIT NONE
65	INTEGER disp_x, disp_y
66	TYPE(domain) , POINTER :: grid
67	# include <dummy_new_decl.inc>
68	END SUBROUTINE shift_domain_em
69	#endif
70	#if ( NMM_CORE == 1 )
71	SUBROUTINE med_nest_egrid_configure ( parent , nest )
72	USE module_domain
73	IMPLICIT NONE
74	TYPE(domain) , POINTER :: parent , nest
75	END SUBROUTINE med_nest_egrid_configure
76
77	SUBROUTINE med_construct_egrid_weights ( parent , nest )
78	USE module_domain
79	IMPLICIT NONE
80	TYPE(domain) , POINTER :: parent , nest
81	END SUBROUTINE med_construct_egrid_weights
82
83	SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD, &
84	PINT,T,Q,CWM, &
85	FIS,QSH,PD,PDTOP,PTOP, &
86	ETA1,ETA2, &
87	DETA1,DETA2, &
88	IDS,IDE,JDS,JDE,KDS,KDE, &
89	IMS,IME,JMS,JME,KMS,KME, &
90	IPS,IPE,JPS,JPE,KPS,KPE )
91	!
92	#ifdef HWRFX
93	!XUEJIN added for HWRFx
94	USE MODULE_MODEL_CONSTANTS
95	#else
96	!
97	#endif
98	IMPLICIT NONE
99	INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE
100	INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME
101	INTEGER, INTENT(IN ) :: IPS,IPE,JPS,JPE,KPS,KPE
102	REAL, INTENT(IN ) :: PDTOP,PTOP
103	REAL, DIMENSION(KMS:KME), INTENT(IN) :: ETA1,ETA2,DETA1,DETA2
104	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,QSH
105	REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q,CWM
106	REAL, DIMENSION(KMS:KME) , INTENT(OUT):: PSTD
107	REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(OUT):: Z3d,Q3d,T3d
108
109	END SUBROUTINE BASE_STATE_PARENT
110
111	SUBROUTINE NEST_TERRAIN ( nest, config_flags )
112	USE module_domain, ONLY : domain
113	USE module_configure, ONLY : grid_config_rec_type
114	IMPLICIT NONE
115	TYPE(domain) , POINTER :: nest
116	TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags
117	END SUBROUTINE NEST_TERRAIN
118
119	SUBROUTINE med_init_domain_constants_nmm ( parent, nest )
120	USE module_domain, ONLY : domain
121	IMPLICIT NONE
122	TYPE(domain) , POINTER :: parent , nest
123	END SUBROUTINE med_init_domain_constants_nmm
124
125	SUBROUTINE shift_domain_nmm ( grid, disp_x, disp_y &
126	!
127	# include <dummy_new_args.inc>
128	!
129	)
130	USE module_domain
131	IMPLICIT NONE
132	INTEGER disp_x, disp_y
133	TYPE(domain) , POINTER :: grid
134	#include <dummy_new_decl.inc>
135	END SUBROUTINE shift_domain_nmm
136	#endif
137	#ifdef HWRFX
138	! XUEJIN added this directive here to exclude the ARW code
139	#else
140	LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy )
141	USE module_domain, ONLY : domain
142	IMPLICIT NONE
143	TYPE(domain) , POINTER :: parent , nest
144	INTEGER, INTENT(OUT) :: dx , dy
145	END FUNCTION time_for_move
146	#endif
147
148	#ifdef HWRF
149	#if (NMM_CORE == 1 && NMM_NEST == 1)
150	! LOGICAL FUNCTION nest_roam ( parent , nest , dx , dy ) !REPLACED BY KWON
151	!
152	LOGICAL FUNCTION direction_of_move ( parent , nest , dx , dy )
153	USE module_domain, ONLY : domain
154	IMPLICIT NONE
155	TYPE(domain) , POINTER :: parent , nest
156	INTEGER, INTENT(OUT) :: dx , dy
157	END FUNCTION direction_of_move
158	!
159	! END FUNCTION nest_roam !REPLACED BY KWON
160	#endif
161	#endif
162
163	#ifdef HWRFX
164	! XUEJIN added this directive here to exclude the ARW code
165	#else
166	SUBROUTINE input_terrain_rsmas ( grid , &
167	ids , ide , jds , jde , kds , kde , &
168	ims , ime , jms , jme , kms , kme , &
169	ips , ipe , jps , jpe , kps , kpe )
170	USE module_domain, ONLY : domain
171	IMPLICIT NONE
172	TYPE ( domain ) :: grid
173	INTEGER :: ids , ide , jds , jde , kds , kde , &
174	ims , ime , jms , jme , kms , kme , &
175	ips , ipe , jps , jpe , kps , kpe
176	END SUBROUTINE input_terrain_rsmas
177	SUBROUTINE med_nest_feedback ( parent , nest , config_flags )
178	USE module_domain, ONLY : domain
179	USE module_configure, ONLY : grid_config_rec_type
180	IMPLICIT NONE
181	TYPE (domain), POINTER :: nest , parent
182	TYPE (grid_config_rec_type) config_flags
183	END SUBROUTINE med_nest_feedback
184	SUBROUTINE blend_terrain ( ter_interpolated , ter_input , &
185	ids , ide , jds , jde , kds , kde , &
186	ims , ime , jms , jme , kms , kme , &
187	ips , ipe , jps , jpe , kps , kpe )
188	IMPLICIT NONE
189	INTEGER :: ids , ide , jds , jde , kds , kde , &
190	ims , ime , jms , jme , kms , kme , &
191	ips , ipe , jps , jpe , kps , kpe
192	REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated
193	REAL , DIMENSION(ims:ime,jms:jme) :: ter_input
194	END SUBROUTINE blend_terrain
195	SUBROUTINE copy_3d_field ( ter_interpolated , ter_input , &
196	ids , ide , jds , jde , kds , kde , &
197	ims , ime , jms , jme , kms , kme , &
198	ips , ipe , jps , jpe , kps , kpe )
199	IMPLICIT NONE
200	INTEGER :: ids , ide , jds , jde , kds , kde , &
201	ims , ime , jms , jme , kms , kme , &
202	ips , ipe , jps , jpe , kps , kpe
203	REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated
204	REAL , DIMENSION(ims:ime,jms:jme) :: ter_input
205	END SUBROUTINE copy_3d_field
206	#endif
207	END INTERFACE
208
209	! set grid pointer for code in deref_kludge (if used)
210	grid => nest
211
212	IF ( should_not_move( nest%id ) ) THEN
213	CALL wrf_message( 'Nest movement is disabled because of namelist settings' )
214	RETURN
215	ENDIF
216
217	! if the nest has stopped don't do all this
218	IF ( WRFU_ClockIsStopTime(nest%domain_clock ,rc=ierr) ) RETURN
219
220	! mask should be defined in nest domain
221
222	#ifdef HWRF
223	check_direction_of_move: IF ( direction_of_move ( parent , nest , dx, dy ) ) THEN
224	#else
225	check_for_move: IF ( time_for_move ( parent , nest , dx, dy ) ) THEN
226	#endif
227
228	#if ( EM_CORE == 1 )
229	IF ( (dx .gt. 1 .or. dx .lt. -1 ) .or. &
230	(dy .gt. 1 .or. dy .lt. -1 ) ) THEN
231	WRITE(mess,*)' invalid move: dx, dy ', dx, dy
232	CALL wrf_error_fatal( mess )
233	ENDIF
234	#endif
235	#if (NMM_CORE == 1 && NMM_NEST == 1)
236	IF(MOD(dy,2) .NE. 0)THEN
237	dy=dy+sign(1,dy)
238	WRITE(0,*)'WARNING: DY REDEFINED FOR THE NMM CORE AND RE-SET TO MASS POINT dy=',dy
239	ENDIF
240
241	IF ( dx .gt. 1 .or. dx .lt. -1 .or. dy .gt. 2 .or. dy .lt. -2 ) THEN
242	WRITE(0,*)'PROBLEM WITH SHIFTDX AND SHIFTDY','dx=',dx,'dy=',dy
243	CALL wrf_error_fatal( 'med_nest_move' )
244	ENDIF
245	#endif
246
247	IF ( wrf_dm_on_monitor() ) THEN
248	WRITE(mess,*)' moving ',grid%id,dx,dy
249	CALL wrf_message(mess)
250	ENDIF
251
252	CALL get_ijk_from_grid ( grid , &
253	ids, ide, jds, jde, kds, kde, &
254	ims, ime, jms, jme, kms, kme, &
255	ips, ipe, jps, jpe, kps, kpe )
256
257	CALL wrf_dm_move_nest ( parent, nest%intermediate_grid, dx, dy )
258
259	CALL adjust_domain_dims_for_move( nest%intermediate_grid , dx, dy )
260
261	CALL get_ijk_from_grid ( grid , &
262	ids, ide, jds, jde, kds, kde, &
263	ims, ime, jms, jme, kms, kme, &
264	ips, ipe, jps, jpe, kps, kpe )
265
266	grid => nest
267
268	#if ( EM_CORE == 1 )
269	CALL shift_domain_em( grid, dx, dy &
270	!
271	# include <actual_new_args.inc>
272	!
273	)
274	#endif
275	#if (NMM_CORE == 1 && NMM_NEST == 1)
276	CALL shift_domain_nmm( grid, dx, dy &
277	!
278	# include <actual_new_args.inc>
279	!
280	)
281	#endif
282
283	px = grid%parent_grid_ratio*dx
284	py = grid%parent_grid_ratio*dy
285
286	grid%i_parent_start = grid%i_parent_start + px / grid%parent_grid_ratio
287	CALL nl_set_i_parent_start( grid%id, grid%i_parent_start )
288	grid%j_parent_start = grid%j_parent_start + py / grid%parent_grid_ratio
289	CALL nl_set_j_parent_start( grid%id, grid%j_parent_start )
290
291	IF ( wrf_dm_on_monitor() ) THEN
292	write(mess,*) &
293	'Grid ',grid%id,' New SW corner (in parent x and y):',grid%i_parent_start, grid%j_parent_start
294	CALL wrf_message(TRIM(mess))
295	ENDIF
296
297	#if (NMM_CORE == 1 && NMM_NEST == 1)
298
299	!----------------------------------------------------------------------------
300	! initialize shifted domain configurations including setting up wbd,sbd, etc
301	!----------------------------------------------------------------------------
302
303	CALL med_nest_egrid_configure ( parent , nest )
304
305	!-------------------------------------------------------------------------
306	! initialize shifted domain lat-lons and determine weights
307	!-------------------------------------------------------------------------
308
309	CALL med_construct_egrid_weights ( parent, nest )
310
311	!
312	! Set new terrain. Since some terrain adjustment is done within the interpolation calls
313	! at the next step, the new terrain over the nested domain has to be called here.
314	!
315
316	CALL model_to_grid_config_rec ( nest%id , model_config_rec , config_flags )
317
318	CALL NEST_TERRAIN ( nest, config_flags )
319
320	CALL get_ijk_from_grid ( nest , &
321	ids, ide, jds, jde, kds, kde, &
322	ims, ime, jms, jme, kms, kme, &
323	ips, ipe, jps, jpe, kps, kpe )
324
325	#ifdef HWRF
326	! adjust pint & pressure depth due to height change in nest_terrain
327	! assume lapse rate of 6.1K/1km
328	TLAP=6.1/(con_g*1000.)
329	DO J = MAX(JPS,JDS-PY), MIN(JPE,JDE-1-PY)
330	DO I = MAX(IPS,IDS-PX), MIN(IPE,IDE-1-PX)
331	if( nest%fis(I,J).ne.nest%hres_fis(I,J) ) then
332	if( nest%T(I,J,1).gt.150. .and. nest%T(I,J,1).lt.400.) then
333	TBAR=ALOG(1.0+TLAP*(nest%fis(I,J)-nest%hres_fis(I,J)) /nest%T(I,J,1))
334	EPSI=TBAR/(con_rd*TLAP)
335	! recover pint from pressure depth after move, then adjust for diff topo
336	nest%PINT(I,J,1)=nest%PD(I,J)+nest%pdtop+nest%pt
337	nest%PINT(I,J,1)=nest%PINT(I,J,1)*EXP(EPSI)
338	nest%PD(I,J)=nest%PINT(I,J,1)-nest%pdtop-nest%pt
339	! WRITE(0,*)I,J,nest%nmm_PD(I,J),nest%nmm_PINT(I,1,J),nest%nmm_FIS(I,J),nest%nmm_hres_fis(I,J),nest%nmm_pdtop,nest%nmm_pt, &
340	! 'change pd,ptint'
341	endif
342	endif
343	ENDDO
344	ENDDO
345	#endif
346
347	DO J = JPS, MIN(JPE,JDE-1)
348	DO I = IPS, MIN(IPE,IDE-1)
349	nest%fis(I,J)=nest%hres_fis(I,J)
350	ENDDO
351	ENDDO
352
353	!
354	! De-reference dimension information stored in the grid data structure.
355	!
356	! From the hybrid, construct the GPMs on isobaric surfaces and then interpolate those
357	! values on to the nested domain. 23 standard prssure levels are assumed here. For
358	! levels below ground, lapse rate atmosphere is assumed before the use of vertical
359	! spline interpolation
360	!
361
362	CALL get_ijk_from_grid ( parent , &
363	ids, ide, jds, jde, kds, kde, &
364	ims, ime, jms, jme, kms, kme, &
365	ips, ipe, jps, jpe, kps, kpe )
366
367	CALL BASE_STATE_PARENT ( parent%Z3d,parent%Q3d,parent%T3d,parent%PSTD, &
368	parent%PINT,parent%T,parent%Q,parent%CWM, &
369	parent%FIS,parent%QSH,parent%PD,parent%pdtop,parent%pt, &
370	parent%ETA1,parent%ETA2, &
371	parent%DETA1,parent%DETA2, &
372	IDS,IDE,JDS,JDE,KDS,KDE, &
373	IMS,IME,JMS,JME,KMS,KME, &
374	IPS,IPE,JPS,JPE,KPS,KPE )
375
376	! Initialize some more constants required especially for terrain adjustment processes
377
378	nest%PSTD=parent%PSTD
379	nest%KZMAX=KME
380	parent%KZMAX=KME ! just for safety
381
382	! write(0,*) " nest%imask_nostag "
383	! write(0,"(3X,1X,1000(I3))") (I, I = IPS, MIN(IPE,IDE-1) )
384	DO J = MIN(JPE,JDE-1), JPS, -1
385	IF ( MOD(J,2) /= 0 ) THEN
386	! write(0,"(I3,1X,1000(I3))") J, (nest%imask_nostag(I,J), I = IPS, MIN(IPE,IDE-1) )
387	ELSE
388	! write(0,"(I3,3X,1000(I3))") J, (nest%imask_nostag(I,J), I = IPS, MIN(IPE,IDE-1) )
389	END IF
390	ENDDO
391
392	#endif
393
394	CALL med_interp_domain( parent, nest )
395
396	#if ( EM_CORE == 1 )
397	CALL nl_get_input_from_hires( nest%id , input_from_hires )
398	IF ( input_from_hires ) THEN
399
400	! store horizontally interpolated terrain in temp location
401	CALL copy_3d_field ( nest%ht_fine , nest%ht , &
402	ids , ide , jds , jde , 1 , 1 , &
403	ims , ime , jms , jme , 1 , 1 , &
404	ips , ipe , jps , jpe , 1 , 1 )
405	CALL copy_3d_field ( nest%mub_fine , nest%mub , &
406	ids , ide , jds , jde , 1 , 1 , &
407	ims , ime , jms , jme , 1 , 1 , &
408	ips , ipe , jps , jpe , 1 , 1 )
409	CALL copy_3d_field ( nest%phb_fine , nest%phb , &
410	ids , ide , jds , jde , kds , kde , &
411	ims , ime , jms , jme , kms , kme , &
412	ips , ipe , jps , jpe , kps , kpe )
413
414	CALL input_terrain_rsmas ( nest, &
415	ids , ide , jds , jde , 1 , 1 , &
416	ims , ime , jms , jme , 1 , 1 , &
417	ips , ipe , jps , jpe , 1 , 1 )
418
419	CALL blend_terrain ( nest%ht_fine , nest%ht , &
420	ids , ide , jds , jde , 1 , 1 , &
421	ims , ime , jms , jme , 1 , 1 , &
422	ips , ipe , jps , jpe , 1 , 1 )
423	CALL blend_terrain ( nest%mub_fine , nest%mub , &
424	ids , ide , jds , jde , 1 , 1 , &
425	ims , ime , jms , jme , 1 , 1 , &
426	ips , ipe , jps , jpe , 1 , 1 )
427	CALL blend_terrain ( nest%phb_fine , nest%phb , &
428	ids , ide , jds , jde , kds , kde , &
429	ims , ime , jms , jme , kms , kme , &
430	ips , ipe , jps , jpe , kps , kpe )
431	!
432	CALL model_to_grid_config_rec ( parent%id , model_config_rec , config_flags )
433
434	CALL med_nest_feedback ( parent , nest , config_flags )
435	parent%imask_nostag = 1
436	parent%imask_xstag = 1
437	parent%imask_ystag = 1
438	parent%imask_xystag = 1
439
440	! start_domain will key off "restart". Even if this is a restart run
441	! we don't want it to here. Save the value, set it to false, and restore afterwards
442	saved_restart_value = config_flags%restart
443	config_flags%restart = .FALSE.
444	grid%restart = .FALSE.
445	CALL nl_set_restart ( 1, .FALSE. )
446	grid%press_adj = .FALSE.
447	CALL start_domain ( parent , .FALSE. )
448	config_flags%restart = saved_restart_value
449	grid%restart = saved_restart_value
450	CALL nl_set_restart ( 1, saved_restart_value )
451
452	ENDIF
453	#endif
454
455	#if (NMM_CORE == 1 && NMM_NEST == 1)
456	!------------------------------------------------------------------------------
457	! set up constants (module_initialize_real.F for the shifted nmm domain)
458	!-----------------------------------------------------------------------------
459
460	CALL med_init_domain_constants_nmm ( parent, nest )
461
462	#endif
463
464	!
465	! masks associated with nest will have been set by shift_domain_em above
466	nest%moved = .true.
467	! start_domain will key off "restart". Even if this is a restart run
468	! we don't want it to here. Save the value, set it to false, and restore afterwards
469	saved_restart_value = config_flags%restart
470	config_flags%restart = .FALSE.
471	CALL nl_set_restart ( 1, .FALSE. )
472	grid%restart = .FALSE.
473	#if ( EM_CORE == 1 )
474	nest%press_adj = .FALSE.
475	#endif
476	CALL start_domain ( nest , .FALSE. )
477	config_flags%restart = saved_restart_value
478	grid%restart = saved_restart_value
479	CALL nl_set_restart ( 1, saved_restart_value )
480	nest%moved = .false.
481
482	!
483	! copy time level 2 to time level 1 in new regions of multi-time level fields
484	! this should be registry generated.
485	!
486	#if ( EM_CORE == 1 )
487	do k = kms,kme
488	where ( nest%imask_xstag .EQ. 1 ) nest%u_1(:,k,:) = nest%u_2(:,k,:)
489	where ( nest%imask_ystag .EQ. 1 ) nest%v_1(:,k,:) = nest%v_2(:,k,:)
490	where ( nest%imask_nostag .EQ. 1 ) nest%t_1(:,k,:) = nest%t_2(:,k,:)
491	where ( nest%imask_nostag .EQ. 1 ) nest%w_1(:,k,:) = nest%w_2(:,k,:)
492	where ( nest%imask_nostag .EQ. 1 ) nest%ph_1(:,k,:) = nest%ph_2(:,k,:)
493	where ( nest%imask_nostag .EQ. 1 ) nest%tke_1(:,k,:) = nest%tke_2(:,k,:)
494	enddo
495	where ( nest%imask_nostag .EQ. 1 ) nest%mu_1(:,:) = nest%mu_2(:,:)
496	#endif
497	!
498	#ifdef HWRF
499	ENDIF check_direction_of_move
500	#else
501	ENDIF check_for_move
502	#endif
503
504	#endif
505	END SUBROUTINE med_nest_move
506
507	LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y )
508	! Driver layer
509	USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid, adjust_domain_dims_for_move
510	! USE module_configure
511	USE module_driver_constants, ONLY : max_moves
512	USE module_compute_geop
513	USE module_dm, ONLY : wrf_dm_max_real, wrf_dm_move_nest
514	USE module_utility
515	USE module_streams, ONLY : compute_vortex_center_alarm
516	IMPLICIT NONE
517	! Arguments
518	TYPE(domain) , POINTER :: parent, grid
519	INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
520	#ifdef MOVE_NESTS
521	! Local
522	INTEGER num_moves, rc
523	INTEGER move_interval , move_id
524	TYPE(WRFU_Time) :: ct, st
525	TYPE(WRFU_TimeInterval) :: ti
526	CHARACTER*256 mess, timestr
527	INTEGER :: ids, ide, jds, jde, kds, kde, &
528	ims, ime, jms, jme, kms, kme, &
529	ips, ipe, jps, jpe, kps, kpe
530	INTEGER :: is, ie, js, je, ierr
531	REAL :: ipbar, pbar, jpbar, fact
532	REAL :: last_vc_i , last_vc_j
533
534	REAL, ALLOCATABLE, DIMENSION(:,:) :: height_l, height
535	REAL, ALLOCATABLE, DIMENSION(:,:) :: psfc, xlat, xlong, terrain
536	REAL :: minh, maxh
537	INTEGER :: mini, minj, maxi, maxj, i, j, pgr, irad
538	REAL :: disp_x, disp_y, lag, radius, center_i, center_j, dx
539	REAL :: dijsmooth, vmax, vmin, a, b
540	REAL :: dc_i, dc_j ! domain center
541	REAL :: maxws, ws
542	REAL :: pmin
543	INTEGER imploc, jmploc
544
545	INTEGER :: fje, fjs, fie, fis, fimloc, fjmloc, imloc, jmloc
546	INTEGER :: i_parent_start, j_parent_start
547	INTEGER :: max_vortex_speed, vortex_interval ! meters per second and seconds
548	INTEGER :: track_level
549	REAL :: rsmooth = 100000. ! in meters
550
551	LOGICAL, EXTERNAL :: wrf_dm_on_monitor
552
553	character*256 message, message2
554
555	!#define MOVING_DIAGS
556	# ifdef VORTEX_CENTER
557
558
559	CALL nl_get_parent_grid_ratio ( grid%id , pgr )
560	CALL nl_get_i_parent_start ( grid%id , i_parent_start )
561	CALL nl_get_j_parent_start ( grid%id , j_parent_start )
562	CALL nl_get_track_level ( grid%id , track_level )
563
564	! WRITE(mess,*)'Vortex is tracked at ', track_level
565	! CALL wrf_message(mess)
566
567	CALL get_ijk_from_grid ( grid , &
568	ids, ide, jds, jde, kds, kde, &
569	ims, ime, jms, jme, kms, kme, &
570	ips, ipe, jps, jpe, kps, kpe )
571
572	! If the alarm is ringing, recompute the Vortex Center (VC); otherwise
573	! use the previous position of VC. VC is not recomputed ever step to
574	! save on cost for global collection of height field and broadcast
575	! of new center.
576
577	# ifdef MOVING_DIAGS
578	write(0,*)'Check to see if COMPUTE_VORTEX_CENTER_ALARM is ringing? '
579	# endif
580	CALL nl_get_parent_grid_ratio ( grid%id , pgr )
581	CALL nl_get_dx ( grid%id , dx )
582
583	IF ( WRFU_AlarmIsRinging( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) ) THEN
584
585	# ifdef MOVING_DIAGS
586	write(0,*)'COMPUTE_VORTEX_CENTER_ALARM is ringing '
587	# endif
588	CALL WRFU_AlarmRingerOff( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc )
589	CALL domain_clock_get( grid, current_timestr=timestr )
590
591	last_vc_i = grid%vc_i
592	last_vc_j = grid%vc_j
593
594	ALLOCATE ( height_l ( ims:ime , jms:jme ), STAT=ierr )
595	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height_l in time_for_move2')
596	IF ( wrf_dm_on_monitor() ) THEN
597	ALLOCATE ( height ( ids:ide , jds:jde ), STAT=ierr )
598	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2')
599	ALLOCATE ( psfc ( ids:ide , jds:jde ), STAT=ierr )
600	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2')
601	ALLOCATE ( xlat ( ids:ide , jds:jde ), STAT=ierr )
602	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2')
603	ALLOCATE ( xlong ( ids:ide , jds:jde ), STAT=ierr )
604	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2')
605	ALLOCATE ( terrain ( ids:ide , jds:jde ), STAT=ierr )
606	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2')
607	ELSE
608	ALLOCATE ( height ( 1:1 , 1:1 ), STAT=ierr )
609	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2')
610	ALLOCATE ( psfc ( 1:1 , 1:1 ), STAT=ierr )
611	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2')
612	ALLOCATE ( xlat ( 1:1 , 1:1 ), STAT=ierr )
613	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2')
614	ALLOCATE ( xlong ( 1:1 , 1:1 ), STAT=ierr )
615	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2')
616	ALLOCATE ( terrain ( 1:1 , 1:1 ), STAT=ierr )
617	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2')
618	ENDIF
619
620	# if (EM_CORE == 1)
621	CALL compute_500mb_height ( grid%ph_2 , grid%phb, grid%p, grid%pb, height_l , &
622	track_level, &
623	ids, ide, jds, jde, kds, kde, &
624	ims, ime, jms, jme, kms, kme, &
625	ips, ipe, jps, jpe, kps, kpe )
626	# endif
627
628	CALL wrf_patch_to_global_real ( height_l , height , grid%domdesc, "z", "xy", &
629	ids, ide-1 , jds , jde-1 , 1 , 1 , &
630	ims, ime , jms , jme , 1 , 1 , &
631	ips, ipe , jps , jpe , 1 , 1 )
632	CALL wrf_patch_to_global_real ( grid%psfc , psfc , grid%domdesc, "z", "xy", &
633	ids, ide-1 , jds , jde-1 , 1 , 1 , &
634	ims, ime , jms , jme , 1 , 1 , &
635	ips, ipe , jps , jpe , 1 , 1 )
636	CALL wrf_patch_to_global_real ( grid%xlat , xlat , grid%domdesc, "z", "xy", &
637	ids, ide-1 , jds , jde-1 , 1 , 1 , &
638	ims, ime , jms , jme , 1 , 1 , &
639	ips, ipe , jps , jpe , 1 , 1 )
640	CALL wrf_patch_to_global_real ( grid%xlong , xlong , grid%domdesc, "z", "xy", &
641	ids, ide-1 , jds , jde-1 , 1 , 1 , &
642	ims, ime , jms , jme , 1 , 1 , &
643	ips, ipe , jps , jpe , 1 , 1 )
644	CALL wrf_patch_to_global_real ( grid%ht , terrain , grid%domdesc, "z", "xy", &
645	ids, ide-1 , jds , jde-1 , 1 , 1 , &
646	ims, ime , jms , jme , 1 , 1 , &
647	ips, ipe , jps , jpe , 1 , 1 )
648
649	! calculate max wind speed
650	maxws = 0.
651	do j = jps, jpe
652	do i = ips, ipe
653	ws = grid%u10(i,j) * grid%u10(i,j) + grid%v10(i,j) * grid%v10(i,j)
654	if ( ws > maxws ) maxws = ws
655	enddo
656	enddo
657	maxws = sqrt ( maxws )
658	maxws = wrf_dm_max_real ( maxws )
659
660	monitor_only : IF ( wrf_dm_on_monitor() ) THEN
661
662	!
663	! This vortex center finding code adapted from the Hurricane version of MM5,
664	! Courtesy:
665	!
666	! Shuyi Chen et al., Rosenstiel School of Marine and Atmos. Sci., U. Miami.
667	! Spring, 2005
668	!
669	! Get the first guess vortex center about which we do our search
670	! as mini and minh; minimum value is minh
671	!
672
673	CALL nl_get_vortex_interval( grid%id , vortex_interval )
674	CALL nl_get_max_vortex_speed( grid%id , max_vortex_speed )
675
676	IF ( grid%vc_i < 0. .AND. grid%vc_j < 0. ) THEN
677	! first time through
678	is = ids
679	ie = ide-1
680	js = jds
681	je = jde-1
682	ELSE
683	! limit the search to an area around the vortex
684	! that is limited by max_vortex_speed (default 40) meters per second from
685	! previous location over vortex_interval (default 15 mins)
686
687	is = max( grid%vc_i - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * ids )
688	js = max( grid%vc_j - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * jds )
689	ie = min( grid%vc_i + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (ide-1) )
690	je = min( grid%vc_j + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (jde-1) )
691
692	ENDIF
693
694	# ifdef MOVING_DIAGS
695	write(0,*)'search set around last position '
696	write(0,*)' is, ids-1, ie, ide-1 ', is, ids-1, ie, ide-1
697	write(0,*)' js, jds-1, je, jde-1 ', js, jds-1, je, jde-1
698	# endif
699
700	imploc = -1
701	jmploc = -1
702
703	! find minimum psfc
704	pmin = 99999999.0 ! make this very large to be sure we find a minumum
705	DO j = js, je
706	DO i = is, ie
707	! adjust approximately to sea level pressure (same as below: ATCF)
708	psfc(i,j)=psfc(i,j)+11.38*terrain(i,j)
709	IF ( psfc(i,j) .LT. pmin ) THEN
710	pmin = psfc(i,j)
711	imploc = i
712	jmploc = j
713	ENDIF
714	ENDDO
715	ENDDO
716
717	IF ( imploc .EQ. -1 .OR. jmploc .EQ. -1 ) THEN ! if we fail to find a min there is something seriously wrong
718	WRITE(mess,*)'i,j,is,ie,js,je,imploc,jmploc ',i,j,is,ie,js,je,imploc,jmploc
719	CALL wrf_message(mess)
720	CALL wrf_error_fatal('time_for_move2: Method failure searching for minimum psfc.')
721	ENDIF
722
723	imloc = -1
724	jmloc = -1
725	maxi = -1
726	maxj = -1
727
728	! find local min, max
729	vmin = 99999999.0
730	vmax = -99999999.0
731	DO j = js, je
732	DO i = is, ie
733	IF ( height(i,j) .LT. vmin ) THEN
734	vmin = height(i,j)
735	imloc = i
736	jmloc = j
737	ENDIF
738	IF ( height(i,j) .GT. vmax ) THEN
739	vmax = height(i,j)
740	maxi = i
741	maxj = j
742	ENDIF
743	ENDDO
744	ENDDO
745
746	IF ( imloc .EQ. -1 .OR. jmloc .EQ. -1 .OR. maxi .EQ. -1 .OR. maxj .EQ. -1 ) THEN
747	WRITE(mess,*)'i,j,is,ie,js,je,imloc,jmloc,maxi,maxj ',i,j,is,ie,js,je,imloc,jmloc,maxi,maxj
748	CALL wrf_message(mess)
749	CALL wrf_error_fatal('time_for_move2: Method failure searching max/min of height.')
750	ENDIF
751
752	fimloc = imloc
753	fjmloc = jmloc
754
755	if ( grid%xi .EQ. -1. ) grid%xi = fimloc
756	if ( grid%xj .EQ. -1. ) grid%xj = fjmloc
757
758	dijsmooth = rsmooth / dx
759
760	fjs = max(fjmloc-dijsmooth,1.0)
761	fje = min(fjmloc+dijsmooth,jde-2.0)
762	fis = max(fimloc-dijsmooth,1.0)
763	fie = min(fimloc+dijsmooth,ide-2.0)
764	js = fjs
765	je = fje
766	is = fis
767	ie = fie
768
769	vmin = 1000000.0
770	vmax = -1000000.0
771	DO j = js, je
772	DO i = is, ie
773	IF ( height(i,j) .GT. vmax ) THEN
774	vmax = height(i,j)
775	ENDIF
776	ENDDO
777	ENDDO
778
779	pbar = 0.0
780	ipbar = 0.0
781	jpbar = 0.0
782
783	do j=js,je
784	do i=is,ie
785	fact = vmax - height(i,j)
786	pbar = pbar + fact
787	ipbar = ipbar + fact*(i-is)
788	jpbar = jpbar + fact*(j-js)
789	enddo
790	enddo
791
792	IF ( pbar .NE. 0. ) THEN
793
794	! Compute an adjusted, smoothed, vortex center location in cross
795	! point index space.
796	! Time average. A is coef for old information; B is new
797	! If pbar is zero then just skip this, leave xi and xj alone,
798	! result will be no movement.
799	a = 0.0
800	b = 1.0
801	grid%xi = (a * grid%xi + b * (is + ipbar / pbar)) / ( a + b )
802	grid%xj = (a * grid%xj + b * (js + jpbar / pbar)) / ( a + b )
803
804	grid%vc_i = grid%xi + .5
805	grid%vc_j = grid%xj + .5
806
807
808	ENDIF
809
810	# ifdef MOVING_DIAGS
811	write(0,*)'computed grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
812	i = grid%vc_i ; j = grid%vc_j ; height( i,j ) = height(i,j) * 1.2 !mark the center
813	CALL domain_clock_get( grid, current_timestr=message2 )
814	WRITE ( message , FMT = '(A," on domain ",I3)' ) TRIM(message2), grid%id
815	# endif
816
817	!
818	i = INT(grid%xi+.5)
819	j = INT(grid%xj+.5)
820	write(mess,'("ATCF"," ",A19," ",f8.2," ",f8.2," ",f6.1," ",f6.1)') &
821	timestr(1:19), &
822	xlat(i,j), &
823	xlong(i,j), &
824	0.01*pmin, &
825	!already computed above 0.01pmin+0.1138terrain(imploc,jmploc), &
826	maxws*1.94
827	CALL wrf_message(TRIM(mess))
828
829
830
831	ENDIF monitor_only
832
833	DEALLOCATE ( psfc )
834	DEALLOCATE ( xlat )
835	DEALLOCATE ( xlong )
836	DEALLOCATE ( terrain )
837	DEALLOCATE ( height )
838	DEALLOCATE ( height_l )
839
840	CALL wrf_dm_bcast_real( grid%vc_i , 1 )
841	CALL wrf_dm_bcast_real( grid%vc_j , 1 )
842
843	CALL wrf_dm_bcast_real( pmin , 1 )
844	CALL wrf_dm_bcast_integer( imploc , 1 )
845	CALL wrf_dm_bcast_integer( jmploc , 1 )
846
847	# ifdef MOVING_DIAGS
848	write(0,*)'after bcast : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
849	# endif
850
851
852	ENDIF ! COMPUTE_VORTEX_CENTER_ALARM ringing
853
854	# ifdef MOVING_DIAGS
855	write(0,*)'After ENDIF : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
856	# endif
857
858	dc_i = (ide-ids+1)/2. ! domain center
859	dc_j = (jde-jds+1)/2.
860
861	disp_x = grid%vc_i - dc_i * 1.0
862	disp_y = grid%vc_j - dc_j * 1.0
863
864	#if 0
865	! This appears to be an old, redundant, and perhaps even misnamed parameter.
866	! Remove it from the namelist and Registry and just hard code it to
867	! the default of 6. JM 20050721
868	CALL nl_get_vortex_search_radius( 1, irad )
869	#else
870	irad = 6
871	#endif
872
873	radius = irad
874
875	if ( disp_x .GT. 0 ) disp_x = min( disp_x , radius )
876	if ( disp_y .GT. 0 ) disp_y = min( disp_y , radius )
877
878	if ( disp_x .LT. 0 ) disp_x = max( disp_x , -radius )
879	if ( disp_y .LT. 0 ) disp_y = max( disp_y , -radius )
880
881	move_cd_x = int ( disp_x / pgr )
882	move_cd_y = int ( disp_y / pgr )
883
884	IF ( move_cd_x .GT. 0 ) move_cd_x = min ( move_cd_x , 1 )
885	IF ( move_cd_y .GT. 0 ) move_cd_y = min ( move_cd_y , 1 )
886	IF ( move_cd_x .LT. 0 ) move_cd_x = max ( move_cd_x , -1 )
887	IF ( move_cd_y .LT. 0 ) move_cd_y = max ( move_cd_y , -1 )
888
889	CALL domain_clock_get( grid, current_timestr=timestr )
890
891	IF ( wrf_dm_on_monitor() ) THEN
892	WRITE(mess,*)timestr(1:19),' vortex center (in nest x and y): ',grid%vc_i, grid%vc_j
893	CALL wrf_message(TRIM(mess))
894	WRITE(mess,*)timestr(1:19),' grid center (in nest x and y): ', dc_i, dc_j
895	CALL wrf_message(TRIM(mess))
896	WRITE(mess,*)timestr(1:19),' disp : ', disp_x, disp_y
897	CALL wrf_message(TRIM(mess))
898	WRITE(mess,*)timestr(1:19),' move (rel cd) : ',move_cd_x, move_cd_y
899	CALL wrf_message(TRIM(mess))
900	ENDIF
901
902	grid%vc_i = grid%vc_i - move_cd_x * pgr
903	grid%vc_j = grid%vc_j - move_cd_y * pgr
904
905	# ifdef MOVING_DIAGS
906	IF ( wrf_dm_on_monitor() ) THEN
907	write(0,)' changing grid%vc_i, move_cd_x pgr ', grid%vc_i, move_cd_x * pgr, move_cd_x, pgr
908	ENDIF
909	# endif
910
911	IF ( ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) ) THEN
912	time_for_move2 = .TRUE.
913	ELSE
914	time_for_move2 = .FALSE.
915	ENDIF
916
917	# else
918	! from namelist
919	move_cd_x = 0
920	move_cd_y = 0
921	time_for_move2 = .FALSE.
922	CALL domain_clock_get( grid, current_time=ct, start_time=st )
923	CALL nl_get_num_moves( 1, num_moves )
924	IF ( num_moves .GT. max_moves ) THEN
925	WRITE(mess,*)'time_for_moves2: num_moves (',num_moves,') .GT. max_moves (',max_moves,')'
926	CALL wrf_error_fatal( TRIM(mess) )
927	ENDIF
928	DO i = 1, num_moves
929	CALL nl_get_move_id( i, move_id )
930	IF ( move_id .EQ. grid%id ) THEN
931	CALL nl_get_move_interval( i, move_interval )
932	IF ( move_interval .LT. 999999999 ) THEN
933	CALL WRFU_TimeIntervalSet ( ti, M=move_interval, rc=rc )
934	IF ( ct .GE. st + ti ) THEN
935	CALL nl_get_move_cd_x ( i, move_cd_x )
936	CALL nl_get_move_cd_y ( i, move_cd_y )
937	CALL nl_set_move_interval ( i, 999999999 )
938	time_for_move2 = .TRUE.
939	EXIT
940	ENDIF
941	ENDIF
942	ENDIF
943	ENDDO
944	# endif
945	RETURN
946	#else
947	time_for_move2 = .FALSE.
948	#endif
949	END FUNCTION time_for_move2
950
951	LOGICAL FUNCTION time_for_move ( parent , grid , move_cd_x, move_cd_y )
952	USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move
953	! USE module_configure
954	USE module_dm, ONLY : wrf_dm_move_nest
955	USE module_timing
956	USE module_utility
957	IMPLICIT NONE
958	! arguments
959	TYPE(domain) , POINTER :: parent, grid, par, nst
960	INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
961	#ifdef MOVE_NESTS
962	! local
963	INTEGER :: corral_dist, kid
964	INTEGER :: dw, de, ds, dn, pgr
965	INTEGER :: would_move_x, would_move_y
966	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
967	cims, cime, cjms, cjme, ckms, ckme, &
968	cips, cipe, cjps, cjpe, ckps, ckpe, &
969	nids, nide, njds, njde, nkds, nkde, &
970	nims, nime, njms, njme, nkms, nkme, &
971	nips, nipe, njps, njpe, nkps, nkpe
972	REAL :: xtime, time_to_move
973	! interface
974	INTERFACE
975	LOGICAL FUNCTION time_for_move2 ( parent , nest , dx , dy )
976	USE module_domain, ONLY : domain
977	TYPE(domain) , POINTER :: parent , nest
978	INTEGER, INTENT(OUT) :: dx , dy
979	END FUNCTION time_for_move2
980	END INTERFACE
981	! executable
982	!
983	! Simplifying assumption: domains in moving nest simulations have only
984	! one parent and only one child.
985
986	IF ( grid%num_nests .GT. 1 ) THEN
987	CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
988	ENDIF
989	kid = 1
990
991	#if ( EM_CORE == 1 )
992	! Check if it is time to move the nest
993	xtime = grid%xtime
994	CALL nl_get_time_to_move ( grid%id , time_to_move )
995	if ( xtime .lt. time_to_move ) then
996	time_for_move = .FALSE.
997	move_cd_x = 0
998	move_cd_y = 0
999	! write(0,*) 'it is not the time to move ', xtime, time_to_move
1000	return
1001	endif
1002	#endif
1003	!
1004	! find out if this is the innermost nest (will not have kids)
1005	IF ( grid%num_nests .EQ. 0 ) THEN
1006	! code that executes on innermost nest
1007	time_for_move = time_for_move2 ( parent , grid , move_cd_x, move_cd_y )
1008
1009	! Make sure the parent can move before allowing the nest to approach
1010	! its boundary
1011	par => grid%parents(1)%ptr
1012	nst => grid
1013
1014	would_move_x = move_cd_x
1015	would_move_y = move_cd_y
1016
1017	! top of until loop
1018	100 CONTINUE
1019	CALL nl_get_corral_dist ( nst%id , corral_dist )
1020	CALL get_ijk_from_grid ( nst , &
1021	nids, nide, njds, njde, nkds, nkde, &
1022	nims, nime, njms, njme, nkms, nkme, &
1023	nips, nipe, njps, njpe, nkps, nkpe )
1024	CALL get_ijk_from_grid ( par , &
1025	cids, cide, cjds, cjde, ckds, ckde, &
1026	cims, cime, cjms, cjme, ckms, ckme, &
1027	cips, cipe, cjps, cjpe, ckps, ckpe )
1028	CALL nl_get_parent_grid_ratio ( nst%id , pgr )
1029	! perform measurements...
1030	! from western boundary
1031	dw = nst%i_parent_start + would_move_x - cids
1032	! from southern boundary
1033	ds = nst%j_parent_start + would_move_y - cjds
1034	! from eastern boundary
1035	de = cide - ( nst%i_parent_start + (nide-nids+1)/pgr + would_move_x )
1036	! from northern boundary
1037	dn = cjde - ( nst%j_parent_start + (njde-njds+1)/pgr + would_move_y )
1038
1039	! would this generate a move on the parent?
1040	would_move_x = 0
1041	would_move_y = 0
1042	if ( dw .LE. corral_dist ) would_move_x = would_move_x - 1
1043	if ( de .LE. corral_dist ) would_move_x = would_move_x + 1
1044	if ( ds .LE. corral_dist ) would_move_y = would_move_y - 1
1045	if ( dn .LE. corral_dist ) would_move_y = would_move_y + 1
1046
1047	IF ( par%id .EQ. 1 ) THEN
1048	IF ( would_move_x .NE. 0 .AND. move_cd_x .NE. 0 ) THEN
1049	CALL wrf_message('MOAD can not move. Cancelling nest move in X')
1050	if ( grid%num_nests .eq. 0 ) grid%vc_i = grid%vc_i + move_cd_x * pgr ! cancel effect of move
1051	move_cd_x = 0
1052	ENDIF
1053	IF ( would_move_y .NE. 0 .AND. move_cd_y .NE. 0 ) THEN
1054	CALL wrf_message('MOAD can not move. Cancelling nest move in Y')
1055	if ( grid%num_nests .eq. 0 ) grid%vc_j = grid%vc_j + move_cd_y * pgr ! cancel effect of move
1056	move_cd_y = 0
1057	ENDIF
1058	ELSE
1059	nst => par
1060	par => nst%parents(1)%ptr
1061	GOTO 100
1062	ENDIF
1063
1064	! bottom of until loop
1065	time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
1066
1067	ELSE
1068	! code that executes on parent to see if parent needs to move
1069	! get closest number of cells we'll allow nest edge to approach parent bdy
1070	CALL nl_get_corral_dist ( grid%nests(kid)%ptr%id , corral_dist )
1071	! get dims
1072	CALL get_ijk_from_grid ( grid%nests(kid)%ptr , &
1073	nids, nide, njds, njde, nkds, nkde, &
1074	nims, nime, njms, njme, nkms, nkme, &
1075	nips, nipe, njps, njpe, nkps, nkpe )
1076	CALL get_ijk_from_grid ( grid , &
1077	cids, cide, cjds, cjde, ckds, ckde, &
1078	cims, cime, cjms, cjme, ckms, ckme, &
1079	cips, cipe, cjps, cjpe, ckps, ckpe )
1080	CALL nl_get_parent_grid_ratio ( grid%nests(kid)%ptr%id , pgr )
1081	! perform measurements...
1082	! from western boundary
1083	dw = grid%nests(kid)%ptr%i_parent_start - 1
1084	! from southern boundary
1085	ds = grid%nests(kid)%ptr%j_parent_start - 1
1086	! from eastern boundary
1087	de = cide - ( grid%nests(kid)%ptr%i_parent_start + (nide-nids+1)/pgr )
1088	! from northern boundary
1089	dn = cjde - ( grid%nests(kid)%ptr%j_parent_start + (njde-njds+1)/pgr )
1090
1091	! move this domain (the parent containing the moving nest)
1092	! in a direction that reestablishes the distance from
1093	! the boundary.
1094	move_cd_x = 0
1095	move_cd_y = 0
1096	if ( dw .LE. corral_dist ) move_cd_x = move_cd_x - 1
1097	if ( de .LE. corral_dist ) move_cd_x = move_cd_x + 1
1098	if ( ds .LE. corral_dist ) move_cd_y = move_cd_y - 1
1099	if ( dn .LE. corral_dist ) move_cd_y = move_cd_y + 1
1100
1101	time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
1102
1103	IF ( time_for_move ) THEN
1104	IF ( grid%id .EQ. 1 ) THEN
1105
1106	CALL wrf_message( 'DANGER: Nest has moved too close to boundary of outermost domain.' )
1107	time_for_move = .FALSE.
1108
1109	ELSE
1110	! need to adjust the intermediate domain of the nest in relation to this
1111	! domain since we're moving
1112
1113	CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_xpgr, -move_cd_ypgr )
1114	CALL adjust_domain_dims_for_move( grid%nests(kid)%ptr%intermediate_grid , -move_cd_xpgr, -move_cd_ypgr )
1115	grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr
1116	CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start )
1117	grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr
1118	CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start )
1119
1120	ENDIF
1121	ENDIF
1122
1123	ENDIF
1124
1125	RETURN
1126	#else
1127	time_for_move = .FALSE.
1128	#endif
1129	END FUNCTION time_for_move
1130
1131	! Put any tests for non-moving options or conditions in here
1132	LOGICAL FUNCTION should_not_move ( id )
1133	USE module_state_description
1134	! USE module_configure
1135	IMPLICIT NONE
1136	INTEGER, INTENT(IN) :: id
1137	! Local
1138	LOGICAL retval
1139	INTEGER cu_physics, ra_sw_physics, ra_lw_physics, sf_urban_physics, sf_surface_physics, obs_nudge_opt
1140
1141	retval = .FALSE.
1142	! check for GD ensemble cumulus, which can not move
1143	CALL nl_get_cu_physics( id , cu_physics )
1144	IF ( cu_physics .EQ. GDSCHEME ) THEN
1145	CALL wrf_message('Grell cumulus can not be specified with moving nests. Movement disabled.')
1146	retval = .TRUE.
1147	ENDIF
1148	! check for CAM radiation scheme , which can not move
1149	CALL nl_get_ra_sw_physics( id , ra_sw_physics )
1150	IF ( ra_sw_physics .EQ. CAMSWSCHEME ) THEN
1151	CALL wrf_message('CAM SW radiation can not be specified with moving nests. Movement disabled.')
1152	retval = .TRUE.
1153	ENDIF
1154	CALL nl_get_ra_lw_physics( id , ra_lw_physics )
1155	IF ( ra_lw_physics .EQ. CAMLWSCHEME ) THEN
1156	CALL wrf_message('CAM LW radiation can not be specified with moving nests. Movement disabled.')
1157	retval = .TRUE.
1158	ENDIF
1159	! check for urban canopy Noah LSM, which can not move
1160	CALL nl_get_sf_urban_physics( id , sf_urban_physics )
1161	IF ( sf_urban_physics .EQ. 1 .OR. sf_urban_physics .EQ. 2 ) THEN
1162	CALL wrf_message('UCMs Noah LSM can not be specified with moving nests. Movement disabled.')
1163	retval = .TRUE.
1164	ENDIF
1165	! check for PX lsm scheme, which can not move
1166	CALL nl_get_sf_surface_physics( id , sf_surface_physics )
1167	IF ( sf_surface_physics .EQ. PXLSMSCHEME ) THEN
1168	CALL wrf_message('PX LSM can not be specified with moving nests. Movement disabled.')
1169	retval = .TRUE.
1170	ENDIF
1171	#if ( EM_CORE == 1 )
1172	! check for observation nudging, which can not move
1173	CALL nl_get_obs_nudge_opt( id , obs_nudge_opt )
1174	IF ( obs_nudge_opt .EQ. 1 ) THEN
1175	CALL wrf_message('Observation nudging can not be specified with moving nests. Movement disabled.')
1176	retval = .TRUE.
1177	ENDIF
1178	#endif
1179	should_not_move = retval
1180	END FUNCTION
1181
1182	#ifdef HWRFX
1183	#if (NMM_CORE == 1 && NMM_NEST == 1)
1184	LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y )
1185	USE module_domain
1186	USE module_configure
1187	USE module_dm
1188	IMPLICIT NONE
1189	! arguments
1190	TYPE(domain) , POINTER :: parent, grid
1191	LOGICAL, EXTERNAL :: wrf_dm_on_monitor
1192	INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
1193	! local
1194	INTEGER :: coral_dist, kid
1195	INTEGER :: dw, de, ds, dn, pgr, idum, jdum
1196	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
1197	cims, cime, cjms, cjme, ckms, ckme, &
1198	cips, cipe, cjps, cjpe, ckps, ckpe, &
1199	nids, nide, njds, njde, nkds, nkde, &
1200	nims, nime, njms, njme, nkms, nkme, &
1201	nips, nipe, njps, njpe, nkps, nkpe
1202	! AUTHOR: XUEJIN ZHANG
1203	! ORIGINAL DATE: 10/12/2009
1204	! Modified: 2/28/2010
1205	! PURPOSE: DEICDE THE DIRECTION OF MOVE
1206	! executable
1207	!
1208	! Simplifying assumption: domains in moving nest simulations have only
1209	! one parent and only one child.
1210	! XUEJIN comment out 10/12/2009
1211	! IF ( grid%num_nests .GT. 1 ) THEN
1212	! CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
1213	! ENDIF
1214	! kid = 1
1215
1216	! SWITCH OFF NEST MOTION IF TOO CLOSE TO ANY OF THE BOUNDARIES
1217
1218	coral_dist=grid%ed31/grid%parent_grid_ratio
1219	IF(grid%i_parent_start .le. 5 .or. (grid%i_parent_start+coral_dist) .ge. parent%ed31 - 5)THEN
1220	grid%mvnest=.false.
1221	WRITE(0,*)'MOVING SHUT OFF BECAUSE NEST IS CLOSE TO EAST/WEST BOUNDARY'
1222	ENDIF
1223	!
1224	coral_dist=grid%ed32/grid%parent_grid_ratio
1225	IF(grid%j_parent_start .le. 5 .OR. (grid%j_parent_start+coral_dist) .ge. parent%ed32 - 5)THEN
1226	grid%mvnest=.false.
1227	WRITE(0,*)'MOVING SHUT OFF BECAUSE NEST IS CLOSE TO NORTH/SOUTH BOUNDARY'
1228	ENDIF
1229
1230	!
1231	! DETERMINE AUTOMATICALLY THE DIRECTION OF GRID MOTION
1232	!
1233	WRITE(0,*)'PROBLEM MAY BE HERE',grid%id,grid%mvnest,grid%num_moves,grid%num_nests
1234	WRITE(0,*)'PROBLEM MAY BE HERE',grid%XLOC_1,grid%XLOC_2,grid%YLOC_1,grid%YLOC_2
1235
1236	! IF(grid%num_nests.EQ.0 .AND. grid%num_moves.EQ.-99 .AND. grid%mvnest)THEN
1237	IF(grid%num_moves.EQ.-99 .AND. grid%mvnest)THEN
1238	IF((grid%XLOC_1-grid%XLOC_2) .GE. 3)THEN
1239	move_cd_x = -1
1240	IF((grid%YLOC_2-grid%YLOC_1) .GE. 3)THEN
1241	WRITE(0,*)'HURRICANE IS MOVING IN THE NORTH EAST DIRECTION',grid%id
1242	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1243	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1244	move_cd_y = +1
1245	ELSE
1246	WRITE(0,*)'HURRICANE IS MOVING IN THE EASTERLY FLOW',grid%id
1247	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1248	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1249	move_cd_y = 0
1250	ENDIF
1251	direction_of_move2= .TRUE.
1252	grid%moved = .TRUE.
1253	ELSE IF((grid%XLOC_2-grid%XLOC_1) .GE. 3)THEN
1254	move_cd_x = +1
1255	IF((grid%YLOC_2-grid%YLOC_1) .GE. 3)THEN
1256	WRITE(0,*)'HURRICANE IS MOVING IN THE NORTH WEST DIRECTION',grid%id
1257	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1258	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1259	move_cd_y = -1
1260	ELSE
1261	WRITE(0,*)'HURRICANE IN THE WESTERLY CURRENT',grid%id
1262	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1263	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1264	move_cd_y = 0
1265	ENDIF
1266	direction_of_move2= .TRUE.
1267	grid%moved = .TRUE.
1268	ELSE IF ((grid%YLOC_2-grid%YLOC_1) .GE. 6)THEN
1269	WRITE(0,*)'HURRICANE IS MOVING NORTHWARD',grid%id
1270	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1271	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1272	move_cd_x = 0
1273	move_cd_y = 2
1274	direction_of_move2= .TRUE.
1275	grid%moved = .TRUE.
1276	ELSE IF ((grid%YLOC_1-grid%YLOC_2) .GE. 6)THEN ! wait for the move
1277	WRITE(0,*)'STRANGE: HURRICANE IS MOVING SOUTHWARD, MAY BE DUE TO INITIAL MANUVARE',grid%id
1278	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1279	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1280	move_cd_x = 0
1281	move_cd_y = -2
1282	direction_of_move2= .TRUE.
1283	grid%moved = .TRUE.
1284	ELSE
1285	move_cd_x = 0
1286	move_cd_y = 0
1287	direction_of_move2= .FALSE.
1288	grid%moved = .FALSE.
1289	ENDIF
1290	ELSE
1291	move_cd_x = 0
1292	move_cd_y = 0
1293	direction_of_move2= .FALSE.
1294	grid%moved = .FALSE.
1295	ENDIF
1296
1297	RETURN
1298
1299	END FUNCTION direction_of_move2
1300
1301
1302	LOGICAL FUNCTION direction_of_move ( parent , grid , move_cd_x, move_cd_y )
1303
1304	! AUTHOR: XUEJIN ZHANG
1305	! ORIGINAL DATE: 10/12/2009
1306	! Modified: 2/28/2010
1307	! PURPOSE: DEICDE THE DIRECTION OF MOVE
1308
1309	USE module_domain
1310	USE module_configure
1311	USE module_dm
1312	IMPLICIT NONE
1313	! arguments
1314	TYPE(domain) , POINTER :: parent, grid, par, nst
1315	INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
1316	! local
1317	INTEGER :: corral_dist, kid
1318	INTEGER :: dw, de, ds, dn, pgr
1319	INTEGER :: would_move_x, would_move_y
1320	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
1321	cims, cime, cjms, cjme, ckms, ckme, &
1322	cips, cipe, cjps, cjpe, ckps, ckpe, &
1323	nids, nide, njds, njde, nkds, nkde, &
1324	nims, nime, njms, njme, nkms, nkme, &
1325	nips, nipe, njps, njpe, nkps, nkpe
1326	INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE
1327	INTEGER :: IMS,IME,JMS,JME,KMS,KME
1328	INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE
1329	! interface
1330	INTERFACE
1331	LOGICAL FUNCTION direction_of_move2 ( parent , nest , dx , dy )
1332	USE module_domain
1333	USE module_utility
1334	TYPE(domain) , POINTER :: parent , nest
1335	INTEGER, INTENT(OUT) :: dx , dy
1336	END FUNCTION direction_of_move2
1337	SUBROUTINE G2T2H_new( IIH,JJH, & ! output grid index and weights
1338	HBWGT1,HBWGT2, & ! output weights in terms of parent grid
1339	HBWGT3,HBWGT4, &
1340	I_PARENT_START,J_PARENT_START, & ! nest start I and J in parent domain
1341	RATIO, & ! Ratio of parent and child grid ( always = 3 for NMM)
1342	IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions
1343	IMS,IME,JMS,JME,KMS,KME, &
1344	ITS,ITE,JTS,JTE,KTS,KTE )
1345	IMPLICIT NONE
1346	INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE
1347	INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME
1348	INTEGER, INTENT(IN ) :: ITS,ITE,JTS,JTE,KTS,KTE
1349	INTEGER, INTENT(IN ) :: I_PARENT_START,J_PARENT_START
1350	INTEGER, INTENT(IN ) :: RATIO
1351	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
1352	INTEGER, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: IIH,JJH
1353	END SUBROUTINE G2T2H_new
1354	SUBROUTINE G2T2V_new( IIV,JJV, & ! output grid index and weights
1355	VBWGT1,VBWGT2, & ! output weights in terms of parent grid
1356	VBWGT3,VBWGT4, &
1357	I_PARENT_START,J_PARENT_START, & ! nest start I and J in parent domain
1358	RATIO, & ! Ratio of parent and child grid ( always = 3 for NMM)
1359	IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions
1360	IMS,IME,JMS,JME,KMS,KME, &
1361	ITS,ITE,JTS,JTE,KTS,KTE )
1362	IMPLICIT NONE
1363	INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE
1364	INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME
1365	INTEGER, INTENT(IN ) :: ITS,ITE,JTS,JTE,KTS,KTE
1366	INTEGER, INTENT(IN ) :: I_PARENT_START,J_PARENT_START
1367	INTEGER, INTENT(IN ) :: RATIO
1368	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
1369	INTEGER, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: IIV,JJV
1370	END SUBROUTINE G2T2V_new
1371	END INTERFACE
1372	! executable
1373	!
1374	! Simplifying assumption: domains in moving nest simulations have only
1375	! one parent and only one child.
1376
1377	IF ( grid%num_nests .GT. 1 ) THEN
1378	CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
1379	ENDIF
1380	kid = 1
1381	write(0,*) 'grid%num_nests=',grid%num_nests
1382	!
1383	! find out if this is the innermost nest (will not have kids)
1384	IF ( grid%num_nests .EQ. 0 ) THEN
1385	! code that executes on innermost nest
1386	direction_of_move = direction_of_move2 ( parent , grid , move_cd_x, move_cd_y )
1387	par => grid%parents(1)%ptr
1388	nst => grid
1389
1390	100 CONTINUE
1391	CALL get_ijk_from_grid ( nst , &
1392	nids, nide, njds, njde, nkds, nkde, &
1393	nims, nime, njms, njme, nkms, nkme, &
1394	nips, nipe, njps, njpe, nkps, nkpe )
1395	CALL get_ijk_from_grid ( par , &
1396	cids, cide, cjds, cjde, ckds, ckde, &
1397	cims, cime, cjms, cjme, ckms, ckme, &
1398	cips, cipe, cjps, cjpe, ckps, ckpe )
1399	CALL nl_get_parent_grid_ratio ( nst%id , pgr )
1400
1401	IF ( par%id .EQ. 1 ) THEN
1402	! IF ( would_move_x .NE. 0 .AND. move_cd_x .NE. 0 ) THEN
1403	CALL wrf_message('MOAD can not move. Cancelling nest move in X')
1404	! if ( grid%num_nests .eq. 0 ) grid%vc_i = grid%vc_i + move_cd_x * pgr ! cancel effect of move
1405	! move_cd_x = 0
1406	! ENDIF
1407	! IF ( would_move_y .NE. 0 .AND. move_cd_y .NE. 0 ) THEN
1408	CALL wrf_message('MOAD can not move. Cancelling nest move in Y')
1409	! if ( grid%num_nests .eq. 0 ) grid%vc_j = grid%vc_j + move_cd_y * pgr ! cancel effect of move
1410	! move_cd_y = 0
1411	! ENDIF
1412	ELSE
1413	nst => par
1414	par => nst%parents(1)%ptr
1415	GOTO 100
1416	ENDIF
1417
1418	! bottom of until loop
1419	direction_of_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
1420
1421	ELSE
1422	CALL get_ijk_from_grid ( grid%nests(kid)%ptr , &
1423	nids, nide, njds, njde, nkds, nkde, &
1424	nims, nime, njms, njme, nkms, nkme, &
1425	nips, nipe, njps, njpe, nkps, nkpe )
1426	CALL get_ijk_from_grid ( grid , &
1427	cids, cide, cjds, cjde, ckds, ckde, &
1428	cims, cime, cjms, cjme, ckms, ckme, &
1429	cips, cipe, cjps, cjpe, ckps, ckpe )
1430	CALL nl_get_parent_grid_ratio ( grid%nests(kid)%ptr%id , pgr )
1431	! move this domain (the parent containing the moving nest)
1432	! in a direction that reestablishes the distance from
1433	! the boundary.
1434	move_cd_x = 0
1435	move_cd_y = 0
1436	direction_of_move = direction_of_move2 ( parent , grid , move_cd_x, move_cd_y )
1437
1438	IF ( direction_of_move ) THEN
1439	IF ( grid%id .EQ. 1 ) THEN
1440
1441	CALL wrf_message( 'DANGER: Nest has moved too close to boundary of outermost domain.' )
1442	direction_of_move = .FALSE.
1443
1444	ELSE
1445	! need to adjust the intermediate domain of the nest in relation to this
1446	! domain since we're moving
1447	IF(MOD(move_cd_y,2) .NE. 0)THEN
1448	move_cd_y=move_cd_y+sign(1,move_cd_y)
1449	WRITE(0,*)'WARNING: move_cd_y REDEFINED FOR THE NMM CORE AND RE-SET TO MASS POINT move_cd_y=',move_cd_y
1450	ENDIF
1451
1452	CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_xpgr, -move_cd_ypgr )
1453	CALL adjust_domain_dims_for_move( grid%nests(kid)%ptr%intermediate_grid , -move_cd_xpgr, -move_cd_ypgr )
1454	grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr
1455	write(0,*)'grid%nests(kid)%ptr%i_parent_start =',grid%nests(kid)%ptr%i_parent_start,grid%nests(kid)%ptr%id
1456	CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start )
1457	grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr
1458	write(0,*)'grid%nests(kid)%ptr%j_parent_start =',grid%nests(kid)%ptr%j_parent_start,grid%nests(kid)%ptr%id
1459	CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start )
1460	IDS = grid%nests(kid)%ptr%sd31
1461	IDE = grid%nests(kid)%ptr%ed31
1462	JDS = grid%nests(kid)%ptr%sd32
1463	JDE = grid%nests(kid)%ptr%ed32
1464	KDS = grid%nests(kid)%ptr%sd33
1465	KDE = grid%nests(kid)%ptr%ed33
1466
1467	IMS = grid%nests(kid)%ptr%sm31
1468	IME = grid%nests(kid)%ptr%em31
1469	JMS = grid%nests(kid)%ptr%sm32
1470	JME = grid%nests(kid)%ptr%em32
1471	KMS = grid%nests(kid)%ptr%sm33
1472	KME = grid%nests(kid)%ptr%em33
1473
1474	ITS = grid%nests(kid)%ptr%sp31
1475	ITE = grid%nests(kid)%ptr%ep31
1476	JTS = grid%nests(kid)%ptr%sp32
1477	JTE = grid%nests(kid)%ptr%ep32
1478	KTS = grid%nests(kid)%ptr%sp33
1479	KTE = grid%nests(kid)%ptr%ep33
1480
1481	CALL G2T2H_new( grid%nests(kid)%ptr%IIH,grid%nests(kid)%ptr%JJH, & ! output grid index in parent grid
1482	grid%nests(kid)%ptr%HBWGT1,grid%nests(kid)%ptr%HBWGT2, & ! output weights in terms of parent grid
1483	grid%nests(kid)%ptr%HBWGT3,grid%nests(kid)%ptr%HBWGT4, &
1484	grid%nests(kid)%ptr%I_PARENT_START,grid%nests(kid)%ptr%J_PARENT_START, & ! nest start I, J in parent domain
1485	3, & ! Ratio of parent and child grid ( always = 3 for NMM)
1486	IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions
1487	IMS,IME,JMS,JME,KMS,KME, &
1488	ITS,ITE,JTS,JTE,KTS,KTE )
1489	CALL G2T2V_new( grid%nests(kid)%ptr%IIV,grid%nests(kid)%ptr%JJV, & ! output grid index in parent grid
1490	grid%nests(kid)%ptr%VBWGT1,grid%nests(kid)%ptr%VBWGT2, & ! output weights in terms of parent grid
1491	grid%nests(kid)%ptr%VBWGT3,grid%nests(kid)%ptr%VBWGT4, &
1492	grid%nests(kid)%ptr%I_PARENT_START,grid%nests(kid)%ptr%J_PARENT_START, & ! nest start I, J in parent domain
1493	3, & ! Ratio of parent and child grid ( always = 3 for NMM)
1494	IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions
1495	IMS,IME,JMS,JME,KMS,KME, &
1496	ITS,ITE,JTS,JTE,KTS,KTE )
1497
1498	ENDIF
1499	ENDIF
1500
1501	ENDIF
1502
1503	RETURN
1504	END FUNCTION direction_of_move
1505	#endif
1506	#else
1507	#if (NMM_CORE == 1 && NMM_NEST == 1)
1508	LOGICAL FUNCTION nest_roam ( parent , grid , move_cd_x, move_cd_y )
1509	USE module_domain
1510	USE module_configure
1511	USE module_dm
1512	IMPLICIT NONE
1513	! arguments
1514	TYPE(domain) , POINTER :: parent, grid
1515	INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
1516	! local
1517	INTEGER :: coral_dist_x, coral_dist_y
1518	INTEGER :: ntsd
1519
1520	LOGICAL, SAVE :: first = .true.
1521	INTEGER, SAVE :: x_inc, y_inc
1522
1523	IF (first) THEN
1524	x_inc = 0
1525	y_inc = 1
1526	first = .FALSE.
1527	END IF
1528
1529	CALL domain_clock_get(parent,advancecount=ntsd)
1530	IF ( MOD(ntsd,4) /= 0 ) THEN
1531	move_cd_x = 0
1532	move_cd_y = 0
1533	nest_roam = .FALSE.
1534	RETURN
1535	END IF
1536
1537	! Simplifying assumption: domains in moving nest simulations have only
1538	! one parent and only one child.
1539	IF ( grid%num_nests .GT. 1 ) THEN
1540	CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
1541	ENDIF
1542
1543	coral_dist_x = grid%ed31/grid%parent_grid_ratio
1544	coral_dist_y = grid%ed32/grid%parent_grid_ratio
1545
1546	IF ( x_inc==1 .AND. (grid%i_parent_start+coral_dist_x) .ge. parent%ed31 - 5)THEN
1547	WRITE(0,*)' nest_roam TURN TO NORTH'
1548	x_inc = 0
1549	y_inc = 1
1550	ELSE IF( y_inc==1 .AND. (grid%j_parent_start+coral_dist_y) .ge. parent%ed32 - 5)THEN
1551	WRITE(0,*)' nest_roam TURN TO WEST'
1552	x_inc = -1
1553	y_inc = 0
1554	ELSE IF ( x_inc==-1 .AND. grid%i_parent_start .le. 5)THEN
1555	WRITE(0,*)' nest_roam TURN TO SOUTH'
1556	x_inc = 0
1557	y_inc = -1
1558	ELSE IF ( y_inc==-1 .AND. grid%j_parent_start .le. 5)THEN
1559	WRITE(0,*)' nest_roam TURN TO EAST'
1560	x_inc = 1
1561	y_inc = 0
1562	ENDIF
1563
1564	move_cd_x = x_inc
1565	move_cd_y = y_inc
1566	nest_roam = .TRUE.
1567
1568	RETURN
1569
1570	END FUNCTION nest_roam
1571
1572
1573	!ADDED BY YOUNG KWON FOR VORTEX FOLLOWING NEST MOVE
1574
1575	LOGICAL FUNCTION direction_of_move ( parent , grid , move_cd_x, move_cd_y )
1576	USE module_domain, ONLY : domain
1577	! USE module_configure
1578	! USE module_dm
1579	!!! USE WRF_ESMF_MOD !!COMMENTED OUT BY KWON TO FOLLOW DUSAN'S CODING
1580	IMPLICIT NONE
1581	! arguments
1582	TYPE(domain) , POINTER :: parent, grid
1583	LOGICAL, EXTERNAL :: wrf_dm_on_monitor
1584	INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
1585	! local
1586	INTEGER :: coral_dist, kid
1587	INTEGER :: dw, de, ds, dn, pgr, idum, jdum
1588	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
1589	cims, cime, cjms, cjme, ckms, ckme, &
1590	cips, cipe, cjps, cjpe, ckps, ckpe, &
1591	nids, nide, njds, njde, nkds, nkde, &
1592	nims, nime, njms, njme, nkms, nkme, &
1593	nips, nipe, njps, njpe, nkps, nkpe
1594
1595	! executable
1596	!
1597	! Simplifying assumption: domains in moving nest simulations have only
1598	! one parent and only one child.
1599	IF ( grid%num_nests .GT. 1 ) THEN
1600	CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
1601	ENDIF
1602	kid = 1
1603
1604	! write(0,*) 'grid%ed31 grid%ed32 grid%ed33 ', grid%ed31, grid%ed32,grid%ed33
1605
1606	! SWITCH OFF NEST MOTION IF TOO CLOSE TO ANY OF THE BOUNDARIES
1607
1608	coral_dist=grid%ed31/grid%parent_grid_ratio
1609	IF(grid%i_parent_start .le. 5 .or. (grid%i_parent_start+coral_dist) .ge. parent%ed31 - 5)THEN
1610	grid%mvnest=.false.
1611	WRITE(0,*)'MOVING SHUT OFF BECAUSE NEST IS CLOSE TO EAST/WEST BOUNDARY'
1612	ENDIF
1613	!
1614	! coral_dist=grid%ed33/grid%parent_grid_ratio
1615	coral_dist=grid%ed32/grid%parent_grid_ratio !by Kwon for IJK instead of IKJ
1616	! IF(grid%j_parent_start .le. 5 .OR. (grid%j_parent_start+coral_dist) .ge. parent%ed33 - 5)THEN
1617	IF(grid%j_parent_start .le. 5 .OR. (grid%j_parent_start+coral_dist) .ge. parent%ed32 - 5)THEN !by Kwon for IJK instead of IKJ
1618	grid%mvnest=.false.
1619	WRITE(0,*)'MOVING SHUT OFF BECAUSE NEST IS CLOSE TO NORTH/SOUTH BOUNDARY'
1620	ENDIF
1621
1622	!
1623	! DETERMINE AUTOMATICALLY THE DIRECTION OF GRID MOTION
1624	!
1625	IF(grid%num_nests.EQ.0 .AND. grid%num_moves.EQ.-99 .AND. grid%mvnest)THEN
1626	IF((grid%XLOC_1-grid%XLOC_2) .GE. 3)THEN
1627	move_cd_x = -1
1628	IF((grid%YLOC_2-grid%YLOC_1) .GE. 3)THEN
1629	WRITE(0,*)'HURRICANE IS MOVING IN THE NORTH EAST DIRECTION'
1630	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1631	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1632	move_cd_y = +1
1633	ELSE
1634	WRITE(0,*)'HURRICANE IS MOVING IN THE EASTERLY FLOW'
1635	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1636	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1637	move_cd_y = 0
1638	ENDIF
1639	direction_of_move= .TRUE.
1640	grid%moved = .TRUE.
1641	ELSE IF((grid%XLOC_2-grid%XLOC_1) .GE. 3)THEN
1642	move_cd_x = +1
1643	IF((grid%YLOC_2-grid%YLOC_1) .GE. 3)THEN
1644	WRITE(0,*)'HURRICANE IS MOVING IN THE NORTH WEST DIRECTION'
1645	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1646	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1647	move_cd_y = -1
1648	ELSE
1649	WRITE(0,*)'HURRICANE IN THE WESTERLY CURRENT'
1650	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1651	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1652	move_cd_y = 0
1653	ENDIF
1654	direction_of_move= .TRUE.
1655	grid%moved = .TRUE.
1656	ELSE IF ((grid%YLOC_2-grid%YLOC_1) .GE. 3)THEN
1657	WRITE(0,*)'HURRICANE IS MOVING NORTHWARD'
1658	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1659	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1660	move_cd_x = 0
1661	move_cd_y = 2
1662	direction_of_move= .TRUE.
1663	grid%moved = .TRUE.
1664	ELSE IF ((grid%YLOC_1-grid%YLOC_2) .GE. 6)THEN ! wait for the move
1665	WRITE(0,*)'STRANGE: HURRICANE IS MOVING SOUTHWARD, MAY BE DUE TO INITIAL MANUVARE'
1666	WRITE(0,*)'INEW=',grid%XLOC_2,'IOLD=',grid%XLOC_1, &
1667	'JNEW=',grid%YLOC_2,'JOLD=',grid%YLOC_1
1668	move_cd_x = 0
1669	move_cd_y = -2
1670	direction_of_move= .TRUE.
1671	grid%moved = .TRUE.
1672	ELSE
1673	move_cd_x = 0
1674	move_cd_y = 0
1675	direction_of_move= .FALSE.
1676	grid%moved = .FALSE.
1677	ENDIF
1678	ELSE
1679	move_cd_x = 0
1680	move_cd_y = 0
1681	direction_of_move= .FALSE.
1682	grid%moved = .FALSE.
1683	ENDIF
1684
1685	RETURN
1686
1687	END FUNCTION direction_of_move
1688
1689	#endif
1690	#endif

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

Download in other formats:

Original Format