PageRenderTime 55ms CodeModel.GetById 12ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/share/mediation_nest_move.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1855 lines | 1176 code | 230 blank | 449 comment | 39 complexity | becc91f11ed8d96cda6a032001241f7f MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

  1. SUBROUTINE med_nest_move ( parent, nest )
  2. ! Driver layer
  3. USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move
  4. USE module_utility
  5. USE module_timing
  6. USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
  7. USE module_state_description
  8. ! USE module_io_domain
  9. USE module_dm, ONLY : wrf_dm_move_nest
  10. TYPE(domain) , POINTER :: parent, nest, grid
  11. INTEGER dx, dy ! number of parent domain points to move
  12. #ifdef MOVE_NESTS
  13. ! Local
  14. CHARACTER*256 mess
  15. INTEGER i, j, p, parent_grid_ratio
  16. INTEGER px, py ! number and direction of nd points to move
  17. INTEGER :: ids , ide , jds , jde , kds , kde , &
  18. ims , ime , jms , jme , kms , kme , &
  19. ips , ipe , jps , jpe , kps , kpe
  20. INTEGER ierr, fid
  21. #ifdef HWRF
  22. REAL,PARAMETER :: con_g =9.80665e+0! gravity (m/s2)
  23. REAL,PARAMETER :: con_rd =2.8705e+2 ! gas constant air (J/kg/K)
  24. REAL :: TLAP,TBAR,EPSI
  25. #endif
  26. LOGICAL input_from_hires
  27. LOGICAL saved_restart_value
  28. TYPE (grid_config_rec_type) :: config_flags
  29. LOGICAL, EXTERNAL :: wrf_dm_on_monitor
  30. LOGICAL, EXTERNAL :: should_not_move
  31. #ifdef HWRF
  32. !XUEJIN added for HWRFx
  33. INTEGER :: k,idum1,idum2
  34. INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE
  35. #else
  36. !
  37. #endif
  38. INTERFACE
  39. SUBROUTINE med_interp_domain ( parent , nest )
  40. USE module_domain, ONLY : domain
  41. IMPLICIT NONE
  42. TYPE(domain) , POINTER :: parent , nest
  43. END SUBROUTINE med_interp_domain
  44. !#ifdef HWRFX
  45. ! XUEJIN added this directive here to exclude the ARW code
  46. !#else
  47. SUBROUTINE start_domain ( grid , allowed_to_move )
  48. USE module_domain, ONLY : domain
  49. IMPLICIT NONE
  50. TYPE(domain) :: grid
  51. LOGICAL, INTENT(IN) :: allowed_to_move
  52. END SUBROUTINE start_domain
  53. !#endif
  54. #if ( EM_CORE == 1 )
  55. SUBROUTINE shift_domain_em ( grid, disp_x, disp_y &
  56. !
  57. # include <dummy_new_args.inc>
  58. !
  59. )
  60. USE module_domain, ONLY : domain
  61. USE module_state_description
  62. IMPLICIT NONE
  63. INTEGER disp_x, disp_y
  64. TYPE(domain) , POINTER :: grid
  65. # include <dummy_new_decl.inc>
  66. END SUBROUTINE shift_domain_em
  67. #endif
  68. #if ( NMM_CORE == 1 )
  69. SUBROUTINE med_nest_egrid_configure ( parent , nest )
  70. USE module_domain
  71. IMPLICIT NONE
  72. TYPE(domain) , POINTER :: parent , nest
  73. END SUBROUTINE med_nest_egrid_configure
  74. SUBROUTINE med_construct_egrid_weights ( parent , nest )
  75. USE module_domain
  76. IMPLICIT NONE
  77. TYPE(domain) , POINTER :: parent , nest
  78. END SUBROUTINE med_construct_egrid_weights
  79. SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD, &
  80. PINT,T,Q,CWM, &
  81. FIS,QSH,PD,PDTOP,PTOP, &
  82. ETA1,ETA2, &
  83. DETA1,DETA2, &
  84. IDS,IDE,JDS,JDE,KDS,KDE, &
  85. IMS,IME,JMS,JME,KMS,KME, &
  86. IPS,IPE,JPS,JPE,KPS,KPE )
  87. !
  88. #ifdef HWRF
  89. !XUEJIN added for HWRFx
  90. USE MODULE_MODEL_CONSTANTS
  91. #else
  92. !
  93. #endif
  94. IMPLICIT NONE
  95. INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE
  96. INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME
  97. INTEGER, INTENT(IN ) :: IPS,IPE,JPS,JPE,KPS,KPE
  98. REAL, INTENT(IN ) :: PDTOP,PTOP
  99. REAL, DIMENSION(KMS:KME), INTENT(IN) :: ETA1,ETA2,DETA1,DETA2
  100. REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,QSH
  101. REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q,CWM
  102. REAL, DIMENSION(KMS:KME) , INTENT(OUT):: PSTD
  103. REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(OUT):: Z3d,Q3d,T3d
  104. END SUBROUTINE BASE_STATE_PARENT
  105. SUBROUTINE NEST_TERRAIN ( nest, config_flags )
  106. USE module_domain, ONLY : domain
  107. USE module_configure, ONLY : grid_config_rec_type
  108. IMPLICIT NONE
  109. TYPE(domain) , POINTER :: nest
  110. TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags
  111. END SUBROUTINE NEST_TERRAIN
  112. SUBROUTINE med_init_domain_constants_nmm ( parent, nest )
  113. USE module_domain, ONLY : domain
  114. IMPLICIT NONE
  115. TYPE(domain) , POINTER :: parent , nest
  116. END SUBROUTINE med_init_domain_constants_nmm
  117. SUBROUTINE shift_domain_nmm ( grid, disp_x, disp_y &
  118. !
  119. # include <dummy_new_args.inc>
  120. !
  121. )
  122. USE module_domain
  123. IMPLICIT NONE
  124. INTEGER disp_x, disp_y
  125. TYPE(domain) , POINTER :: grid
  126. #include <dummy_new_decl.inc>
  127. END SUBROUTINE shift_domain_nmm
  128. #endif
  129. #ifdef HWRF
  130. ! XUEJIN added this directive here to exclude the ARW code
  131. #else
  132. LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy )
  133. USE module_domain, ONLY : domain
  134. IMPLICIT NONE
  135. TYPE(domain) , POINTER :: parent , nest
  136. INTEGER, INTENT(OUT) :: dx , dy
  137. END FUNCTION time_for_move
  138. #endif
  139. #ifdef HWRF
  140. #if (NMM_CORE == 1 && NMM_NEST == 1)
  141. ! LOGICAL FUNCTION nest_roam ( parent , nest , dx , dy ) !REPLACED BY KWON
  142. !
  143. LOGICAL FUNCTION direction_of_move ( parent , nest , dx , dy )
  144. USE module_domain, ONLY : domain
  145. IMPLICIT NONE
  146. TYPE(domain) , POINTER :: parent , nest
  147. INTEGER, INTENT(OUT) :: dx , dy
  148. END FUNCTION direction_of_move
  149. !
  150. ! END FUNCTION nest_roam !REPLACED BY KWON
  151. #endif
  152. #endif
  153. #ifdef HWRF
  154. ! XUEJIN added this directive here to exclude the ARW code
  155. #else
  156. SUBROUTINE input_terrain_rsmas ( grid , &
  157. ids , ide , jds , jde , kds , kde , &
  158. ims , ime , jms , jme , kms , kme , &
  159. ips , ipe , jps , jpe , kps , kpe )
  160. USE module_domain, ONLY : domain
  161. IMPLICIT NONE
  162. TYPE ( domain ) :: grid
  163. INTEGER :: ids , ide , jds , jde , kds , kde , &
  164. ims , ime , jms , jme , kms , kme , &
  165. ips , ipe , jps , jpe , kps , kpe
  166. END SUBROUTINE input_terrain_rsmas
  167. SUBROUTINE med_nest_feedback ( parent , nest , config_flags )
  168. USE module_domain, ONLY : domain
  169. USE module_configure, ONLY : grid_config_rec_type
  170. IMPLICIT NONE
  171. TYPE (domain), POINTER :: nest , parent
  172. TYPE (grid_config_rec_type) config_flags
  173. END SUBROUTINE med_nest_feedback
  174. SUBROUTINE blend_terrain ( ter_interpolated , ter_input , &
  175. ids , ide , jds , jde , kds , kde , &
  176. ims , ime , jms , jme , kms , kme , &
  177. ips , ipe , jps , jpe , kps , kpe )
  178. IMPLICIT NONE
  179. INTEGER :: ids , ide , jds , jde , kds , kde , &
  180. ims , ime , jms , jme , kms , kme , &
  181. ips , ipe , jps , jpe , kps , kpe
  182. REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated
  183. REAL , DIMENSION(ims:ime,jms:jme) :: ter_input
  184. END SUBROUTINE blend_terrain
  185. SUBROUTINE copy_3d_field ( ter_interpolated , ter_input , &
  186. ids , ide , jds , jde , kds , kde , &
  187. ims , ime , jms , jme , kms , kme , &
  188. ips , ipe , jps , jpe , kps , kpe )
  189. IMPLICIT NONE
  190. INTEGER :: ids , ide , jds , jde , kds , kde , &
  191. ims , ime , jms , jme , kms , kme , &
  192. ips , ipe , jps , jpe , kps , kpe
  193. REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated
  194. REAL , DIMENSION(ims:ime,jms:jme) :: ter_input
  195. END SUBROUTINE copy_3d_field
  196. #endif
  197. END INTERFACE
  198. ! set grid pointer for code in deref_kludge (if used)
  199. grid => nest
  200. IF ( should_not_move( nest%id ) ) THEN
  201. CALL wrf_message( 'Nest movement is disabled because of namelist settings' )
  202. RETURN
  203. ENDIF
  204. ! if the nest has stopped don't do all this
  205. IF ( WRFU_ClockIsStopTime(nest%domain_clock ,rc=ierr) ) RETURN
  206. ! mask should be defined in nest domain
  207. #ifdef HWRF
  208. check_direction_of_move: IF ( direction_of_move ( parent , nest , dx, dy ) ) THEN
  209. #else
  210. check_for_move: IF ( time_for_move ( parent , nest , dx, dy ) ) THEN
  211. #endif
  212. #if ( EM_CORE == 1 )
  213. IF ( (dx .gt. 1 .or. dx .lt. -1 ) .or. &
  214. (dy .gt. 1 .or. dy .lt. -1 ) ) THEN
  215. WRITE(mess,*)' invalid move: dx, dy ', dx, dy
  216. CALL wrf_error_fatal( mess )
  217. ENDIF
  218. #endif
  219. #if (NMM_CORE == 1 && NMM_NEST == 1)
  220. IF(MOD(dy,2) .NE. 0)THEN
  221. dy=dy+sign(1,dy)
  222. WRITE(0,*)'WARNING: DY REDEFINED FOR THE NMM CORE AND RE-SET TO MASS POINT dy=',dy
  223. ENDIF
  224. IF ( dx .gt. 1 .or. dx .lt. -1 .or. dy .gt. 2 .or. dy .lt. -2 ) THEN
  225. WRITE(0,*)'PROBLEM WITH SHIFTDX AND SHIFTDY','dx=',dx,'dy=',dy
  226. CALL wrf_error_fatal( 'med_nest_move' )
  227. ENDIF
  228. #endif
  229. IF ( wrf_dm_on_monitor() ) THEN
  230. WRITE(mess,*)' moving ',grid%id,dx,dy
  231. CALL wrf_message(mess)
  232. ENDIF
  233. CALL get_ijk_from_grid ( grid , &
  234. ids, ide, jds, jde, kds, kde, &
  235. ims, ime, jms, jme, kms, kme, &
  236. ips, ipe, jps, jpe, kps, kpe )
  237. CALL wrf_dm_move_nest ( parent, nest%intermediate_grid, dx, dy )
  238. CALL adjust_domain_dims_for_move( nest%intermediate_grid , dx, dy )
  239. CALL get_ijk_from_grid ( grid , &
  240. ids, ide, jds, jde, kds, kde, &
  241. ims, ime, jms, jme, kms, kme, &
  242. ips, ipe, jps, jpe, kps, kpe )
  243. grid => nest
  244. #if ( EM_CORE == 1 )
  245. CALL shift_domain_em( grid, dx, dy &
  246. !
  247. # include <actual_new_args.inc>
  248. !
  249. )
  250. #endif
  251. #if (NMM_CORE == 1 && NMM_NEST == 1)
  252. CALL shift_domain_nmm( grid, dx, dy &
  253. !
  254. # include <actual_new_args.inc>
  255. !
  256. )
  257. #endif
  258. px = grid%parent_grid_ratio*dx
  259. py = grid%parent_grid_ratio*dy
  260. grid%i_parent_start = grid%i_parent_start + px / grid%parent_grid_ratio
  261. CALL nl_set_i_parent_start( grid%id, grid%i_parent_start )
  262. grid%j_parent_start = grid%j_parent_start + py / grid%parent_grid_ratio
  263. CALL nl_set_j_parent_start( grid%id, grid%j_parent_start )
  264. IF ( wrf_dm_on_monitor() ) THEN
  265. write(mess,*) &
  266. 'Grid ',grid%id,' New SW corner (in parent x and y):',grid%i_parent_start, grid%j_parent_start
  267. CALL wrf_message(TRIM(mess))
  268. ENDIF
  269. #if (NMM_CORE == 1 && NMM_NEST == 1)
  270. !----------------------------------------------------------------------------
  271. ! initialize shifted domain configurations including setting up wbd,sbd, etc
  272. !----------------------------------------------------------------------------
  273. CALL med_nest_egrid_configure ( parent , nest )
  274. !-------------------------------------------------------------------------
  275. ! initialize shifted domain lat-lons and determine weights
  276. !-------------------------------------------------------------------------
  277. CALL med_construct_egrid_weights ( parent, nest )
  278. !
  279. ! Set new terrain. Since some terrain adjustment is done within the interpolation calls
  280. ! at the next step, the new terrain over the nested domain has to be called here.
  281. !
  282. CALL model_to_grid_config_rec ( nest%id , model_config_rec , config_flags )
  283. CALL NEST_TERRAIN ( nest, config_flags )
  284. CALL get_ijk_from_grid ( nest , &
  285. ids, ide, jds, jde, kds, kde, &
  286. ims, ime, jms, jme, kms, kme, &
  287. ips, ipe, jps, jpe, kps, kpe )
  288. #ifdef HWRF
  289. ! adjust pint & pressure depth due to height change in nest_terrain
  290. ! assume lapse rate of 6.1K/1km
  291. TLAP=6.1/(con_g*1000.)
  292. DO J = MAX(JPS,JDS-PY), MIN(JPE,JDE-1-PY)
  293. DO I = MAX(IPS,IDS-PX), MIN(IPE,IDE-1-PX)
  294. if( nest%fis(I,J).ne.nest%hres_fis(I,J) ) then
  295. if( nest%T(I,J,1).gt.150. .and. nest%T(I,J,1).lt.400.) then
  296. TBAR=ALOG(1.0+TLAP*(nest%fis(I,J)-nest%hres_fis(I,J)) /nest%T(I,J,1))
  297. EPSI=TBAR/(con_rd*TLAP)
  298. ! recover pint from pressure depth after move, then adjust for diff topo
  299. nest%PINT(I,J,1)=nest%PD(I,J)+nest%pdtop+nest%pt
  300. nest%PINT(I,J,1)=nest%PINT(I,J,1)*EXP(EPSI)
  301. nest%PD(I,J)=nest%PINT(I,J,1)-nest%pdtop-nest%pt
  302. ! 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, &
  303. ! 'change pd,ptint'
  304. endif
  305. endif
  306. ENDDO
  307. ENDDO
  308. #endif
  309. DO J = JPS, MIN(JPE,JDE-1)
  310. DO I = IPS, MIN(IPE,IDE-1)
  311. nest%fis(I,J)=nest%hres_fis(I,J)
  312. ENDDO
  313. ENDDO
  314. !
  315. ! De-reference dimension information stored in the grid data structure.
  316. !
  317. ! From the hybrid, construct the GPMs on isobaric surfaces and then interpolate those
  318. ! values on to the nested domain. 23 standard prssure levels are assumed here. For
  319. ! levels below ground, lapse rate atmosphere is assumed before the use of vertical
  320. ! spline interpolation
  321. !
  322. CALL get_ijk_from_grid ( parent , &
  323. ids, ide, jds, jde, kds, kde, &
  324. ims, ime, jms, jme, kms, kme, &
  325. ips, ipe, jps, jpe, kps, kpe )
  326. CALL BASE_STATE_PARENT ( parent%Z3d,parent%Q3d,parent%T3d,parent%PSTD, &
  327. parent%PINT,parent%T,parent%Q,parent%CWM, &
  328. parent%FIS,parent%QSH,parent%PD,parent%pdtop,parent%pt, &
  329. parent%ETA1,parent%ETA2, &
  330. parent%DETA1,parent%DETA2, &
  331. IDS,IDE,JDS,JDE,KDS,KDE, &
  332. IMS,IME,JMS,JME,KMS,KME, &
  333. IPS,IPE,JPS,JPE,KPS,KPE )
  334. ! Initialize some more constants required especially for terrain adjustment processes
  335. nest%PSTD=parent%PSTD
  336. nest%KZMAX=KME
  337. parent%KZMAX=KME ! just for safety
  338. ! write(0,*) " nest%imask_nostag "
  339. ! write(0,"(3X,1X,1000(I3))") (I, I = IPS, MIN(IPE,IDE-1) )
  340. DO J = MIN(JPE,JDE-1), JPS, -1
  341. IF ( MOD(J,2) /= 0 ) THEN
  342. ! write(0,"(I3,1X,1000(I3))") J, (nest%imask_nostag(I,J), I = IPS, MIN(IPE,IDE-1) )
  343. ELSE
  344. ! write(0,"(I3,3X,1000(I3))") J, (nest%imask_nostag(I,J), I = IPS, MIN(IPE,IDE-1) )
  345. END IF
  346. ENDDO
  347. #endif
  348. CALL med_interp_domain( parent, nest )
  349. #if ( EM_CORE == 1 )
  350. CALL nl_get_input_from_hires( nest%id , input_from_hires )
  351. IF ( input_from_hires ) THEN
  352. ! store horizontally interpolated terrain in temp location
  353. CALL copy_3d_field ( nest%ht_fine , nest%ht , &
  354. ids , ide , jds , jde , 1 , 1 , &
  355. ims , ime , jms , jme , 1 , 1 , &
  356. ips , ipe , jps , jpe , 1 , 1 )
  357. CALL copy_3d_field ( nest%mub_fine , nest%mub , &
  358. ids , ide , jds , jde , 1 , 1 , &
  359. ims , ime , jms , jme , 1 , 1 , &
  360. ips , ipe , jps , jpe , 1 , 1 )
  361. CALL copy_3d_field ( nest%phb_fine , nest%phb , &
  362. ids , ide , jds , jde , kds , kde , &
  363. ims , ime , jms , jme , kms , kme , &
  364. ips , ipe , jps , jpe , kps , kpe )
  365. CALL input_terrain_rsmas ( nest, &
  366. ids , ide , jds , jde , 1 , 1 , &
  367. ims , ime , jms , jme , 1 , 1 , &
  368. ips , ipe , jps , jpe , 1 , 1 )
  369. CALL blend_terrain ( nest%ht_fine , nest%ht , &
  370. ids , ide , jds , jde , 1 , 1 , &
  371. ims , ime , jms , jme , 1 , 1 , &
  372. ips , ipe , jps , jpe , 1 , 1 )
  373. CALL blend_terrain ( nest%mub_fine , nest%mub , &
  374. ids , ide , jds , jde , 1 , 1 , &
  375. ims , ime , jms , jme , 1 , 1 , &
  376. ips , ipe , jps , jpe , 1 , 1 )
  377. CALL blend_terrain ( nest%phb_fine , nest%phb , &
  378. ids , ide , jds , jde , kds , kde , &
  379. ims , ime , jms , jme , kms , kme , &
  380. ips , ipe , jps , jpe , kps , kpe )
  381. !
  382. CALL model_to_grid_config_rec ( parent%id , model_config_rec , config_flags )
  383. CALL med_nest_feedback ( parent , nest , config_flags )
  384. parent%imask_nostag = 1
  385. parent%imask_xstag = 1
  386. parent%imask_ystag = 1
  387. parent%imask_xystag = 1
  388. ! start_domain will key off "restart". Even if this is a restart run
  389. ! we don't want it to here. Save the value, set it to false, and restore afterwards
  390. saved_restart_value = config_flags%restart
  391. config_flags%restart = .FALSE.
  392. grid%restart = .FALSE.
  393. CALL nl_set_restart ( 1, .FALSE. )
  394. grid%press_adj = .FALSE.
  395. CALL start_domain ( parent , .FALSE. )
  396. config_flags%restart = saved_restart_value
  397. grid%restart = saved_restart_value
  398. CALL nl_set_restart ( 1, saved_restart_value )
  399. ENDIF
  400. #endif
  401. #if (NMM_CORE == 1 && NMM_NEST == 1)
  402. !------------------------------------------------------------------------------
  403. ! set up constants (module_initialize_real.F for the shifted nmm domain)
  404. !-----------------------------------------------------------------------------
  405. CALL med_init_domain_constants_nmm ( parent, nest )
  406. #endif
  407. !
  408. ! masks associated with nest will have been set by shift_domain_em above
  409. nest%moved = .true.
  410. ! start_domain will key off "restart". Even if this is a restart run
  411. ! we don't want it to here. Save the value, set it to false, and restore afterwards
  412. saved_restart_value = config_flags%restart
  413. config_flags%restart = .FALSE.
  414. CALL nl_set_restart ( 1, .FALSE. )
  415. grid%restart = .FALSE.
  416. #if ( EM_CORE == 1 )
  417. nest%press_adj = .FALSE.
  418. #endif
  419. CALL start_domain ( nest , .FALSE. )
  420. config_flags%restart = saved_restart_value
  421. grid%restart = saved_restart_value
  422. CALL nl_set_restart ( 1, saved_restart_value )
  423. nest%moved = .false.
  424. !
  425. ! copy time level 2 to time level 1 in new regions of multi-time level fields
  426. ! this should be registry generated.
  427. !
  428. #if ( EM_CORE == 1 )
  429. do k = kms,kme
  430. where ( nest%imask_xstag .EQ. 1 ) nest%u_1(:,k,:) = nest%u_2(:,k,:)
  431. where ( nest%imask_ystag .EQ. 1 ) nest%v_1(:,k,:) = nest%v_2(:,k,:)
  432. where ( nest%imask_nostag .EQ. 1 ) nest%t_1(:,k,:) = nest%t_2(:,k,:)
  433. where ( nest%imask_nostag .EQ. 1 ) nest%w_1(:,k,:) = nest%w_2(:,k,:)
  434. where ( nest%imask_nostag .EQ. 1 ) nest%ph_1(:,k,:) = nest%ph_2(:,k,:)
  435. where ( nest%imask_nostag .EQ. 1 ) nest%tke_1(:,k,:) = nest%tke_2(:,k,:)
  436. enddo
  437. where ( nest%imask_nostag .EQ. 1 ) nest%mu_1(:,:) = nest%mu_2(:,:)
  438. #endif
  439. !
  440. #ifdef HWRF
  441. ENDIF check_direction_of_move
  442. #else
  443. ENDIF check_for_move
  444. #endif
  445. #endif
  446. END SUBROUTINE med_nest_move
  447. LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y )
  448. ! Driver layer
  449. USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid, adjust_domain_dims_for_move
  450. ! USE module_configure
  451. USE module_driver_constants, ONLY : max_moves
  452. USE module_compute_geop
  453. USE module_dm, ONLY : wrf_dm_max_real, wrf_dm_move_nest
  454. USE module_utility
  455. USE module_streams, ONLY : compute_vortex_center_alarm
  456. IMPLICIT NONE
  457. ! Arguments
  458. TYPE(domain) , POINTER :: parent, grid
  459. INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
  460. #ifdef MOVE_NESTS
  461. ! Local
  462. INTEGER num_moves, rc
  463. INTEGER move_interval , move_id
  464. TYPE(WRFU_Time) :: ct, st
  465. TYPE(WRFU_TimeInterval) :: ti
  466. CHARACTER*256 mess, timestr
  467. INTEGER :: ids, ide, jds, jde, kds, kde, &
  468. ims, ime, jms, jme, kms, kme, &
  469. ips, ipe, jps, jpe, kps, kpe
  470. INTEGER :: is, ie, js, je, ierr
  471. REAL :: ipbar, pbar, jpbar, fact
  472. REAL :: last_vc_i , last_vc_j
  473. REAL, ALLOCATABLE, DIMENSION(:,:) :: height_l, height
  474. REAL, ALLOCATABLE, DIMENSION(:,:) :: psfc, xlat, xlong, terrain
  475. REAL :: minh, maxh
  476. INTEGER :: mini, minj, maxi, maxj, i, j, pgr, irad
  477. REAL :: disp_x, disp_y, lag, radius, center_i, center_j, dx
  478. REAL :: dijsmooth, vmax, vmin, a, b
  479. REAL :: dc_i, dc_j ! domain center
  480. REAL :: maxws, ws
  481. REAL :: pmin
  482. INTEGER imploc, jmploc
  483. INTEGER :: fje, fjs, fie, fis, fimloc, fjmloc, imloc, jmloc
  484. INTEGER :: i_parent_start, j_parent_start
  485. INTEGER :: max_vortex_speed, vortex_interval ! meters per second and seconds
  486. INTEGER :: track_level
  487. REAL :: rsmooth = 100000. ! in meters
  488. LOGICAL, EXTERNAL :: wrf_dm_on_monitor
  489. character*256 message, message2
  490. !#define MOVING_DIAGS
  491. # ifdef VORTEX_CENTER
  492. CALL nl_get_parent_grid_ratio ( grid%id , pgr )
  493. CALL nl_get_i_parent_start ( grid%id , i_parent_start )
  494. CALL nl_get_j_parent_start ( grid%id , j_parent_start )
  495. CALL nl_get_track_level ( grid%id , track_level )
  496. ! WRITE(mess,*)'Vortex is tracked at ', track_level
  497. ! CALL wrf_message(mess)
  498. CALL get_ijk_from_grid ( grid , &
  499. ids, ide, jds, jde, kds, kde, &
  500. ims, ime, jms, jme, kms, kme, &
  501. ips, ipe, jps, jpe, kps, kpe )
  502. ! If the alarm is ringing, recompute the Vortex Center (VC); otherwise
  503. ! use the previous position of VC. VC is not recomputed ever step to
  504. ! save on cost for global collection of height field and broadcast
  505. ! of new center.
  506. # ifdef MOVING_DIAGS
  507. write(0,*)'Check to see if COMPUTE_VORTEX_CENTER_ALARM is ringing? '
  508. # endif
  509. CALL nl_get_parent_grid_ratio ( grid%id , pgr )
  510. CALL nl_get_dx ( grid%id , dx )
  511. IF ( WRFU_AlarmIsRinging( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) ) THEN
  512. # ifdef MOVING_DIAGS
  513. write(0,*)'COMPUTE_VORTEX_CENTER_ALARM is ringing '
  514. # endif
  515. CALL WRFU_AlarmRingerOff( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc )
  516. CALL domain_clock_get( grid, current_timestr=timestr )
  517. last_vc_i = grid%vc_i
  518. last_vc_j = grid%vc_j
  519. ALLOCATE ( height_l ( ims:ime , jms:jme ), STAT=ierr )
  520. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height_l in time_for_move2')
  521. IF ( wrf_dm_on_monitor() ) THEN
  522. ALLOCATE ( height ( ids:ide , jds:jde ), STAT=ierr )
  523. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2')
  524. ALLOCATE ( psfc ( ids:ide , jds:jde ), STAT=ierr )
  525. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2')
  526. ALLOCATE ( xlat ( ids:ide , jds:jde ), STAT=ierr )
  527. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2')
  528. ALLOCATE ( xlong ( ids:ide , jds:jde ), STAT=ierr )
  529. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2')
  530. ALLOCATE ( terrain ( ids:ide , jds:jde ), STAT=ierr )
  531. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2')
  532. ELSE
  533. ALLOCATE ( height ( 1:1 , 1:1 ), STAT=ierr )
  534. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2')
  535. ALLOCATE ( psfc ( 1:1 , 1:1 ), STAT=ierr )
  536. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2')
  537. ALLOCATE ( xlat ( 1:1 , 1:1 ), STAT=ierr )
  538. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2')
  539. ALLOCATE ( xlong ( 1:1 , 1:1 ), STAT=ierr )
  540. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2')
  541. ALLOCATE ( terrain ( 1:1 , 1:1 ), STAT=ierr )
  542. IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2')
  543. ENDIF
  544. # if (EM_CORE == 1)
  545. CALL compute_500mb_height ( grid%ph_2 , grid%phb, grid%p, grid%pb, height_l , &
  546. track_level, &
  547. ids, ide, jds, jde, kds, kde, &
  548. ims, ime, jms, jme, kms, kme, &
  549. ips, ipe, jps, jpe, kps, kpe )
  550. # endif
  551. CALL wrf_patch_to_global_real ( height_l , height , grid%domdesc, "z", "xy", &
  552. ids, ide-1 , jds , jde-1 , 1 , 1 , &
  553. ims, ime , jms , jme , 1 , 1 , &
  554. ips, ipe , jps , jpe , 1 , 1 )
  555. CALL wrf_patch_to_global_real ( grid%psfc , psfc , grid%domdesc, "z", "xy", &
  556. ids, ide-1 , jds , jde-1 , 1 , 1 , &
  557. ims, ime , jms , jme , 1 , 1 , &
  558. ips, ipe , jps , jpe , 1 , 1 )
  559. CALL wrf_patch_to_global_real ( grid%xlat , xlat , grid%domdesc, "z", "xy", &
  560. ids, ide-1 , jds , jde-1 , 1 , 1 , &
  561. ims, ime , jms , jme , 1 , 1 , &
  562. ips, ipe , jps , jpe , 1 , 1 )
  563. CALL wrf_patch_to_global_real ( grid%xlong , xlong , grid%domdesc, "z", "xy", &
  564. ids, ide-1 , jds , jde-1 , 1 , 1 , &
  565. ims, ime , jms , jme , 1 , 1 , &
  566. ips, ipe , jps , jpe , 1 , 1 )
  567. CALL wrf_patch_to_global_real ( grid%ht , terrain , grid%domdesc, "z", "xy", &
  568. ids, ide-1 , jds , jde-1 , 1 , 1 , &
  569. ims, ime , jms , jme , 1 , 1 , &
  570. ips, ipe , jps , jpe , 1 , 1 )
  571. ! calculate max wind speed
  572. maxws = 0.
  573. do j = jps, jpe
  574. do i = ips, ipe
  575. ws = grid%u10(i,j) * grid%u10(i,j) + grid%v10(i,j) * grid%v10(i,j)
  576. if ( ws > maxws ) maxws = ws
  577. enddo
  578. enddo
  579. maxws = sqrt ( maxws )
  580. maxws = wrf_dm_max_real ( maxws )
  581. monitor_only : IF ( wrf_dm_on_monitor() ) THEN
  582. !
  583. ! This vortex center finding code adapted from the Hurricane version of MM5,
  584. ! Courtesy:
  585. !
  586. ! Shuyi Chen et al., Rosenstiel School of Marine and Atmos. Sci., U. Miami.
  587. ! Spring, 2005
  588. !
  589. ! Get the first guess vortex center about which we do our search
  590. ! as mini and minh; minimum value is minh
  591. !
  592. CALL nl_get_vortex_interval( grid%id , vortex_interval )
  593. CALL nl_get_max_vortex_speed( grid%id , max_vortex_speed )
  594. IF ( grid%vc_i < 0. .AND. grid%vc_j < 0. ) THEN
  595. ! first time through
  596. is = ids
  597. ie = ide-1
  598. js = jds
  599. je = jde-1
  600. ELSE
  601. ! limit the search to an area around the vortex
  602. ! that is limited by max_vortex_speed (default 40) meters per second from
  603. ! previous location over vortex_interval (default 15 mins)
  604. is = max( grid%vc_i - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * ids )
  605. js = max( grid%vc_j - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * jds )
  606. ie = min( grid%vc_i + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (ide-1) )
  607. je = min( grid%vc_j + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (jde-1) )
  608. ENDIF
  609. # ifdef MOVING_DIAGS
  610. write(0,*)'search set around last position '
  611. write(0,*)' is, ids-1, ie, ide-1 ', is, ids-1, ie, ide-1
  612. write(0,*)' js, jds-1, je, jde-1 ', js, jds-1, je, jde-1
  613. # endif
  614. imploc = -1
  615. jmploc = -1
  616. ! find minimum psfc
  617. pmin = 99999999.0 ! make this very large to be sure we find a minumum
  618. DO j = js, je
  619. DO i = is, ie
  620. ! adjust approximately to sea level pressure (same as below: ATCF)
  621. psfc(i,j)=psfc(i,j)+11.38*terrain(i,j)
  622. IF ( psfc(i,j) .LT. pmin ) THEN
  623. pmin = psfc(i,j)
  624. imploc = i
  625. jmploc = j
  626. ENDIF
  627. ENDDO
  628. ENDDO
  629. IF ( imploc .EQ. -1 .OR. jmploc .EQ. -1 ) THEN ! if we fail to find a min there is something seriously wrong
  630. WRITE(mess,*)'i,j,is,ie,js,je,imploc,jmploc ',i,j,is,ie,js,je,imploc,jmploc
  631. CALL wrf_message(mess)
  632. CALL wrf_error_fatal('time_for_move2: Method failure searching for minimum psfc.')
  633. ENDIF
  634. imloc = -1
  635. jmloc = -1
  636. maxi = -1
  637. maxj = -1
  638. ! find local min, max
  639. vmin = 99999999.0
  640. vmax = -99999999.0
  641. DO j = js, je
  642. DO i = is, ie
  643. IF ( height(i,j) .LT. vmin ) THEN
  644. vmin = height(i,j)
  645. imloc = i
  646. jmloc = j
  647. ENDIF
  648. IF ( height(i,j) .GT. vmax ) THEN
  649. vmax = height(i,j)
  650. maxi = i
  651. maxj = j
  652. ENDIF
  653. ENDDO
  654. ENDDO
  655. IF ( imloc .EQ. -1 .OR. jmloc .EQ. -1 .OR. maxi .EQ. -1 .OR. maxj .EQ. -1 ) THEN
  656. WRITE(mess,*)'i,j,is,ie,js,je,imloc,jmloc,maxi,maxj ',i,j,is,ie,js,je,imloc,jmloc,maxi,maxj
  657. CALL wrf_message(mess)
  658. CALL wrf_error_fatal('time_for_move2: Method failure searching max/min of height.')
  659. ENDIF
  660. fimloc = imloc
  661. fjmloc = jmloc
  662. if ( grid%xi .EQ. -1. ) grid%xi = fimloc
  663. if ( grid%xj .EQ. -1. ) grid%xj = fjmloc
  664. dijsmooth = rsmooth / dx
  665. fjs = max(fjmloc-dijsmooth,1.0)
  666. fje = min(fjmloc+dijsmooth,jde-2.0)
  667. fis = max(fimloc-dijsmooth,1.0)
  668. fie = min(fimloc+dijsmooth,ide-2.0)
  669. js = fjs
  670. je = fje
  671. is = fis
  672. ie = fie
  673. vmin = 1000000.0
  674. vmax = -1000000.0
  675. DO j = js, je
  676. DO i = is, ie
  677. IF ( height(i,j) .GT. vmax ) THEN
  678. vmax = height(i,j)
  679. ENDIF
  680. ENDDO
  681. ENDDO
  682. pbar = 0.0
  683. ipbar = 0.0
  684. jpbar = 0.0
  685. do j=js,je
  686. do i=is,ie
  687. fact = vmax - height(i,j)
  688. pbar = pbar + fact
  689. ipbar = ipbar + fact*(i-is)
  690. jpbar = jpbar + fact*(j-js)
  691. enddo
  692. enddo
  693. IF ( pbar .NE. 0. ) THEN
  694. ! Compute an adjusted, smoothed, vortex center location in cross
  695. ! point index space.
  696. ! Time average. A is coef for old information; B is new
  697. ! If pbar is zero then just skip this, leave xi and xj alone,
  698. ! result will be no movement.
  699. a = 0.0
  700. b = 1.0
  701. grid%xi = (a * grid%xi + b * (is + ipbar / pbar)) / ( a + b )
  702. grid%xj = (a * grid%xj + b * (js + jpbar / pbar)) / ( a + b )
  703. grid%vc_i = grid%xi + .5
  704. grid%vc_j = grid%xj + .5
  705. ENDIF
  706. # ifdef MOVING_DIAGS
  707. write(0,*)'computed grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
  708. i = grid%vc_i ; j = grid%vc_j ; height( i,j ) = height(i,j) * 1.2 !mark the center
  709. CALL domain_clock_get( grid, current_timestr=message2 )
  710. WRITE ( message , FMT = '(A," on domain ",I3)' ) TRIM(message2), grid%id
  711. # endif
  712. !
  713. i = INT(grid%xi+.5)
  714. j = INT(grid%xj+.5)
  715. write(mess,'("ATCF"," ",A19," ",f8.2," ",f8.2," ",f6.1," ",f6.1)') &
  716. timestr(1:19), &
  717. xlat(i,j), &
  718. xlong(i,j), &
  719. 0.01*pmin, &
  720. !already computed above 0.01*pmin+0.1138*terrain(imploc,jmploc), &
  721. maxws*1.94
  722. CALL wrf_message(TRIM(mess))
  723. ENDIF monitor_only
  724. DEALLOCATE ( psfc )
  725. DEALLOCATE ( xlat )
  726. DEALLOCATE ( xlong )
  727. DEALLOCATE ( terrain )
  728. DEALLOCATE ( height )
  729. DEALLOCATE ( height_l )
  730. CALL wrf_dm_bcast_real( grid%vc_i , 1 )
  731. CALL wrf_dm_bcast_real( grid%vc_j , 1 )
  732. CALL wrf_dm_bcast_real( pmin , 1 )
  733. CALL wrf_dm_bcast_integer( imploc , 1 )
  734. CALL wrf_dm_bcast_integer( jmploc , 1 )
  735. # ifdef MOVING_DIAGS
  736. write(0,*)'after bcast : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
  737. # endif
  738. ENDIF ! COMPUTE_VORTEX_CENTER_ALARM ringing
  739. # ifdef MOVING_DIAGS
  740. write(0,*)'After ENDIF : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j
  741. # endif
  742. dc_i = (ide-ids+1)/2. ! domain center
  743. dc_j = (jde-jds+1)/2.
  744. disp_x = grid%vc_i - dc_i * 1.0
  745. disp_y = grid%vc_j - dc_j * 1.0
  746. #if 0
  747. ! This appears to be an old, redundant, and perhaps even misnamed parameter.
  748. ! Remove it from the namelist and Registry and just hard code it to
  749. ! the default of 6. JM 20050721
  750. CALL nl_get_vortex_search_radius( 1, irad )
  751. #else
  752. irad = 6
  753. #endif
  754. radius = irad
  755. if ( disp_x .GT. 0 ) disp_x = min( disp_x , radius )
  756. if ( disp_y .GT. 0 ) disp_y = min( disp_y , radius )
  757. if ( disp_x .LT. 0 ) disp_x = max( disp_x , -radius )
  758. if ( disp_y .LT. 0 ) disp_y = max( disp_y , -radius )
  759. move_cd_x = int ( disp_x / pgr )
  760. move_cd_y = int ( disp_y / pgr )
  761. IF ( move_cd_x .GT. 0 ) move_cd_x = min ( move_cd_x , 1 )
  762. IF ( move_cd_y .GT. 0 ) move_cd_y = min ( move_cd_y , 1 )
  763. IF ( move_cd_x .LT. 0 ) move_cd_x = max ( move_cd_x , -1 )
  764. IF ( move_cd_y .LT. 0 ) move_cd_y = max ( move_cd_y , -1 )
  765. CALL domain_clock_get( grid, current_timestr=timestr )
  766. IF ( wrf_dm_on_monitor() ) THEN
  767. WRITE(mess,*)timestr(1:19),' vortex center (in nest x and y): ',grid%vc_i, grid%vc_j
  768. CALL wrf_message(TRIM(mess))
  769. WRITE(mess,*)timestr(1:19),' grid center (in nest x and y): ', dc_i, dc_j
  770. CALL wrf_message(TRIM(mess))
  771. WRITE(mess,*)timestr(1:19),' disp : ', disp_x, disp_y
  772. CALL wrf_message(TRIM(mess))
  773. WRITE(mess,*)timestr(1:19),' move (rel cd) : ',move_cd_x, move_cd_y
  774. CALL wrf_message(TRIM(mess))
  775. ENDIF
  776. grid%vc_i = grid%vc_i - move_cd_x * pgr
  777. grid%vc_j = grid%vc_j - move_cd_y * pgr
  778. # ifdef MOVING_DIAGS
  779. IF ( wrf_dm_on_monitor() ) THEN
  780. write(0,*)' changing grid%vc_i, move_cd_x * pgr ', grid%vc_i, move_cd_x * pgr, move_cd_x, pgr
  781. ENDIF
  782. # endif
  783. IF ( ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) ) THEN
  784. time_for_move2 = .TRUE.
  785. ELSE
  786. time_for_move2 = .FALSE.
  787. ENDIF
  788. # else
  789. ! from namelist
  790. move_cd_x = 0
  791. move_cd_y = 0
  792. time_for_move2 = .FALSE.
  793. CALL domain_clock_get( grid, current_time=ct, start_time=st )
  794. CALL nl_get_num_moves( 1, num_moves )
  795. IF ( num_moves .GT. max_moves ) THEN
  796. WRITE(mess,*)'time_for_moves2: num_moves (',num_moves,') .GT. max_moves (',max_moves,')'
  797. CALL wrf_error_fatal( TRIM(mess) )
  798. ENDIF
  799. DO i = 1, num_moves
  800. CALL nl_get_move_id( i, move_id )
  801. IF ( move_id .EQ. grid%id ) THEN
  802. CALL nl_get_move_interval( i, move_interval )
  803. IF ( move_interval .LT. 999999999 ) THEN
  804. CALL WRFU_TimeIntervalSet ( ti, M=move_interval, rc=rc )
  805. IF ( ct .GE. st + ti ) THEN
  806. CALL nl_get_move_cd_x ( i, move_cd_x )
  807. CALL nl_get_move_cd_y ( i, move_cd_y )
  808. CALL nl_set_move_interval ( i, 999999999 )
  809. time_for_move2 = .TRUE.
  810. EXIT
  811. ENDIF
  812. ENDIF
  813. ENDIF
  814. ENDDO
  815. # endif
  816. RETURN
  817. #else
  818. time_for_move2 = .FALSE.
  819. #endif
  820. END FUNCTION time_for_move2
  821. LOGICAL FUNCTION time_for_move ( parent , grid , move_cd_x, move_cd_y )
  822. USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move
  823. ! USE module_configure
  824. USE module_dm, ONLY : wrf_dm_move_nest
  825. USE module_timing
  826. USE module_utility
  827. IMPLICIT NONE
  828. ! arguments
  829. TYPE(domain) , POINTER :: parent, grid, par, nst
  830. INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
  831. #ifdef MOVE_NESTS
  832. ! local
  833. INTEGER :: corral_dist, kid
  834. INTEGER :: dw, de, ds, dn, pgr
  835. INTEGER :: would_move_x, would_move_y
  836. INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
  837. cims, cime, cjms, cjme, ckms, ckme, &
  838. cips, cipe, cjps, cjpe, ckps, ckpe, &
  839. nids, nide, njds, njde, nkds, nkde, &
  840. nims, nime, njms, njme, nkms, nkme, &
  841. nips, nipe, njps, njpe, nkps, nkpe
  842. REAL :: xtime, time_to_move
  843. ! interface
  844. INTERFACE
  845. LOGICAL FUNCTION time_for_move2 ( parent , nest , dx , dy )
  846. USE module_domain, ONLY : domain
  847. TYPE(domain) , POINTER :: parent , nest
  848. INTEGER, INTENT(OUT) :: dx , dy
  849. END FUNCTION time_for_move2
  850. END INTERFACE
  851. ! executable
  852. !
  853. ! Simplifying assumption: domains in moving nest simulations have only
  854. ! one parent and only one child.
  855. IF ( grid%num_nests .GT. 1 ) THEN
  856. CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' )
  857. ENDIF
  858. kid = 1
  859. #if ( EM_CORE == 1 )
  860. ! Check if it is time to move the nest
  861. xtime = grid%xtime
  862. CALL nl_get_time_to_move ( grid%id , time_to_move )
  863. if ( xtime .lt. time_to_move ) then
  864. time_for_move = .FALSE.
  865. move_cd_x = 0
  866. move_cd_y = 0
  867. ! write(0,*) 'it is not the time to move ', xtime, time_to_move
  868. return
  869. endif
  870. #endif
  871. !
  872. ! find out if this is the innermost nest (will not have kids)
  873. IF ( grid%num_nests .EQ. 0 ) THEN
  874. ! code that executes on innermost nest
  875. time_for_move = time_for_move2 ( parent , grid , move_cd_x, move_cd_y )
  876. ! Make sure the parent can move before allowing the nest to approach
  877. ! its boundary
  878. par => grid%parents(1)%ptr
  879. nst => grid
  880. would_move_x = move_cd_x
  881. would_move_y = move_cd_y
  882. ! top of until loop
  883. 100 CONTINUE
  884. CALL nl_get_corral_dist ( nst%id , corral_dist )
  885. CALL get_ijk_from_grid ( nst , &
  886. nids, nide, njds, njde, nkds, nkde, &
  887. nims, nime, njms, njme, nkms, nkme, &
  888. nips, nipe, njps, njpe, nkps, nkpe )
  889. CALL get_ijk_from_grid ( par , &
  890. cids, cide, cjds, cjde, ckds, ckde, &
  891. cims, cime, cjms, cjme, ckms, ckme, &
  892. cips, cipe, cjps, cjpe, ckps, ckpe )
  893. CALL nl_get_parent_grid_ratio ( nst%id , pgr )
  894. ! perform measurements...
  895. ! from western boundary
  896. dw = nst%i_parent_start + would_move_x - cids
  897. ! from southern boundary
  898. ds = nst%j_parent_start + would_move_y - cjds
  899. ! from eastern boundary
  900. de = cide - ( nst%i_parent_start + (nide-nids+1)/pgr + would_move_x )
  901. ! from northern boundary
  902. dn = cjde - ( nst%j_parent_start + (njde-njds+1)/pgr + would_move_y )
  903. ! would this generate a move on the parent?
  904. would_move_x = 0
  905. would_move_y = 0
  906. if ( dw .LE. corral_dist ) would_move_x = would_move_x - 1
  907. if ( de .LE. corral_dist ) would_move_x = would_move_x + 1
  908. if ( ds .LE. corral_dist ) would_move_y = would_move_y - 1
  909. if ( dn .LE. corral_dist ) would_move_y = would_move_y + 1
  910. IF ( par%id .EQ. 1 ) THEN
  911. IF ( would_move_x .NE. 0 .AND. move_cd_x .NE. 0 ) THEN
  912. CALL wrf_message('MOAD can not move. Cancelling nest move in X')
  913. if ( grid%num_nests .eq. 0 ) grid%vc_i = grid%vc_i + move_cd_x * pgr ! cancel effect of move
  914. move_cd_x = 0
  915. ENDIF
  916. IF ( would_move_y .NE. 0 .AND. move_cd_y .NE. 0 ) THEN
  917. CALL wrf_message('MOAD can not move. Cancelling nest move in Y')
  918. if ( grid%num_nests .eq. 0 ) grid%vc_j = grid%vc_j + move_cd_y * pgr ! cancel effect of move
  919. move_cd_y = 0
  920. ENDIF
  921. ELSE
  922. nst => par
  923. par => nst%parents(1)%ptr
  924. GOTO 100
  925. ENDIF
  926. ! bottom of until loop
  927. time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
  928. ELSE
  929. ! code that executes on parent to see if parent needs to move
  930. ! get closest number of cells we'll allow nest edge to approach parent bdy
  931. CALL nl_get_corral_dist ( grid%nests(kid)%ptr%id , corral_dist )
  932. ! get dims
  933. CALL get_ijk_from_grid ( grid%nests(kid)%ptr , &
  934. nids, nide, njds, njde, nkds, nkde, &
  935. nims, nime, njms, njme, nkms, nkme, &
  936. nips, nipe, njps, njpe, nkps, nkpe )
  937. CALL get_ijk_from_grid ( grid , &
  938. cids, cide, cjds, cjde, ckds, ckde, &
  939. cims, cime, cjms, cjme, ckms, ckme, &
  940. cips, cipe, cjps, cjpe, ckps, ckpe )
  941. CALL nl_get_parent_grid_ratio ( grid%nests(kid)%ptr%id , pgr )
  942. ! perform measurements...
  943. ! from western boundary
  944. dw = grid%nests(kid)%ptr%i_parent_start - 1
  945. ! from southern boundary
  946. ds = grid%nests(kid)%ptr%j_parent_start - 1
  947. ! from eastern boundary
  948. de = cide - ( grid%nests(kid)%ptr%i_parent_start + (nide-nids+1)/pgr )
  949. ! from northern boundary
  950. dn = cjde - ( grid%nests(kid)%ptr%j_parent_start + (njde-njds+1)/pgr )
  951. ! move this domain (the parent containing the moving nest)
  952. ! in a direction that reestablishes the distance from
  953. ! the boundary.
  954. move_cd_x = 0
  955. move_cd_y = 0
  956. if ( dw .LE. corral_dist ) move_cd_x = move_cd_x - 1
  957. if ( de .LE. corral_dist ) move_cd_x = move_cd_x + 1
  958. if ( ds .LE. corral_dist ) move_cd_y = move_cd_y - 1
  959. if ( dn .LE. corral_dist ) move_cd_y = move_cd_y + 1
  960. time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 )
  961. IF ( time_for_move ) THEN
  962. IF ( grid%id .EQ. 1 ) THEN
  963. CALL wrf_message( 'DANGER: Nest has moved too close to boundary of outermost domain.' )
  964. time_for_move = .FALSE.
  965. ELSE
  966. ! need to adjust the intermediate domain of the nest in relation to this
  967. ! domain since we're moving
  968. CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr )
  969. CALL adjust_domain_dims_for_move( grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr )
  970. grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr
  971. CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start )
  972. grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr
  973. CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start )
  974. ENDIF
  975. ENDIF
  976. ENDIF
  977. RETURN
  978. #else
  979. time_for_move = .FALSE.
  980. #endif
  981. END FUNCTION time_for_move
  982. ! Put any tests for non-moving options or conditions in here
  983. LOGICAL FUNCTION should_not_move ( id )
  984. USE module_state_description
  985. ! USE module_configure
  986. IMPLICIT NONE
  987. INTEGER, INTENT(IN) :: id
  988. ! Local
  989. LOGICAL retval
  990. INTEGER cu_physics, ra_sw_physics, ra_lw_physics, sf_urban_physics, sf_surface_physics, obs_nudge_opt
  991. retval = .FALSE.
  992. ! check for GD ensemble cumulus, which can not move
  993. CALL nl_get_cu_physics( id , cu_physics )
  994. IF ( cu_physics .EQ. GDSCHEME ) THEN
  995. CALL wrf_message('Grell cumulus can not be specified with moving nests. Movement disabled.')
  996. retval = .TRUE.
  997. ENDIF
  998. ! check for CAM radiation scheme , which can not move
  999. CALL nl_get_ra_sw_physics( id , ra_sw_physics )
  1000. IF ( ra_sw_physics .EQ. CAMSWSCHEME ) THEN
  1001. CALL wrf_message('CAM SW radiation can not be specified with moving nests. Movement disabled.')
  1002. retval = .TRUE.
  1003. ENDIF
  1004. CALL nl_get_ra_lw_physics( id , ra_lw_physics )
  1005. IF ( ra_lw_physics .EQ. CAMLWSCHEME ) THEN
  1006. CALL wrf_message('CAM LW radiation can not be specified with moving nests. Movement disabled.')
  1007. retval = .TRUE.
  1008. ENDIF
  1009. ! check for urban canopy Noah LSM, which can not move
  1010. CALL nl_get_sf_urban_physics( id , sf_urban_physics )
  1011. IF ( sf_urban_physics .EQ. 1 .OR. sf_urban_physics .EQ. 2 ) THEN
  1012. CALL wrf_message('UCMs Noah LSM can not be specified with moving nests. Movement disabled.')
  1013. retval = .TRUE.
  1014. ENDIF
  1015. ! check for PX lsm scheme, which can not move
  1016. CALL nl_get_sf_surface_physics( id , sf_surface_physics )
  1017. IF ( sf_surface_physics .EQ. PXLSMSCHEME ) THEN
  1018. CALL wrf_message('PX LSM can not be specified with moving nests. Movement disabled.')
  1019. retval = .TRUE.
  1020. ENDIF
  1021. #if ( EM_CORE == 1 )
  1022. ! check for observation nudging, which can not move
  1023. CALL nl_get_obs_nudge_opt( id , obs_nudge_opt )
  1024. IF ( obs_nudge_opt .EQ. 1 ) THEN
  1025. CALL wrf_message('Observation nudging can not be specified with moving nests. Movement disabled.')
  1026. retval = .TRUE.
  1027. ENDIF
  1028. #endif
  1029. should_not_move = retval
  1030. END FUNCTION
  1031. #ifdef HWRF
  1032. #if (NMM_CORE == 1 && NMM_NEST == 1)
  1033. LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y )
  1034. USE module_domain
  1035. USE module_configure
  1036. USE module_dm
  1037. IMPLICIT NONE
  1038. ! arguments
  1039. TYPE(domain) , POINTER :: parent, grid, kid
  1040. LOGICAL, EXTERNAL :: wrf_dm_on_monitor
  1041. INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y
  1042. CHARACTER*256 mess
  1043. ! local
  1044. INTEGER :: coral_dist, ikid
  1045. INTEGER :: dw, de, ds, dn, idum, jdum
  1046. INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
  1047. cims, cime, cjms, cjme, ckms, ckme, &
  1048. cips, cipe, cjps, cjpe, ckps, ckpe, &
  1049. nids, nide, njds, njde, nkds, nkde, &
  1050. nims, nime, njms, njme, nkms, nkme, &
  1051. nips, nipe, njps, njpe, nkps, nkpe
  1052. real :: dx,dy,kid_ic,kid_jc,my_ic,my_jc,pgr,pgrn
  1053. real, parameter :: pmult=1.35
  1054. integer :: inew,jnew
  1055. logical :: abort
  1056. ! PURPOSE: DECIDE THE DIRECTION OF MOVE
  1057. ! Two modes:
  1058. ! vortex_tracker=3 -- use results of STATS_FOR_MOVE to follow
  1059. ! the vortex center. If the vortex is more than 3 X
  1060. ! gridpoints or 6 Y gridpoints from the center, then
  1061. ! move to follow it.
  1062. ! vortex_tracker=2 -- follow this domain's nest. Only works
  1063. ! if this domain has a nest, otherwise this domain is
  1064. ! stationary. If the nest domain is more than 3 X
  1065. ! gridpoints or 6 Y gridpoints from the center, then move
  1066. ! to follow it. (Added by Sam Trahan, April 1, 2011)
  1067. ! RETURN VALUE: TRUE if domain should move, FALSE otherwise.
  1068. ! OUTPUTS:
  1069. ! move_cd_x = number of parent gridpoints to move in X
  1070. ! move_cd_y = number of parent gridpoints to move in Y
  1071. ! grid%moved = TRUE if domain should move, FALSE otherwise.
  1072. ! AUTHOR: XUEJIN ZHANG, October 12, 2009
  1073. ! MODIFIED: XUEJIN ZHANG, February 28, 2010
  1074. ! MODIFIED: SAM TRAHAN, April 1, 2011 to add vortex_tracker, and the
  1075. ! nest-following vortex tracker (option 2)
  1076. abort=.false. ! will be set to .true. if any safety checks fail
  1077. ! INITIALIZE NEST MOTION TO DISABLED
  1078. move_cd_x=0
  1079. move_cd_y=0
  1080. direction_of_move2 = .false.
  1081. grid%moved = .false.
  1082. ! Simplifying assumption: domains in moving nest simulations have
  1083. ! only one parent and only one child.
  1084. if(grid%num_nests .gt. 1) then
  1085. write(mess,'("d",I0,": not moving because it has more than one nest")') grid%id
  1086. call WRF_MESSAGE(trim(mess))
  1087. abort=.true.
  1088. endif
  1089. ! SWITCH OFF NEST MOTION IF TOO CLOSE TO ANY OF THE BOUNDARIES
  1090. coral_dist=(grid%ed31+grid%parent_grid_ratio-1)/grid%parent_grid_ratio
  1091. IF(grid%i_parent_start .le. 5) then
  1092. abort=.true.
  1093. write(mess,'("d",I0,": cannot move: too close to parent d",I0," -X boundary")') grid%id,parent%id
  1094. call wrf_message(trim(mess))
  1095. ELSEIF((grid%i_parent_start+coral_dist) .ge. parent%ed31 - 5)THEN
  1096. abort=.true.
  1097. write(mess,'("d",I0,": cannot move: too close to parent d",I0," +X boundary")') grid%id,parent%id
  1098. call wrf_message(trim(mess))
  1099. ENDIF
  1100. coral_dist=(grid%ed32+grid%parent_grid_ratio-1)/grid%parent_grid_ratio
  1101. IF(grid%j_parent_start .le. 5) THEN
  1102. abort=.true.
  1103. write(mess,'("d",I0,": cannot move: too close to parent d",I0," -Y boundary")') grid%id,parent%id
  1104. call wrf_message(trim(mess))
  1105. ELSEIF((grid%j_parent_start+coral_dist) .ge. parent%ed32 - 5)THEN
  1106. abort=.true.
  1107. write(mess,'("d",I0,": cannot move: too close to parent d",I0," +Y boundary")') grid%id,parent%id
  1108. call wrf_message(trim(mess))
  1109. ENDIF
  1110. !
  1111. ! DETERMINE AUTOMATICALLY THE DIRECTION OF GRID MOTION
  1112. !
  1113. can_move: if(grid%num_moves.eq.-99 .and. grid%mvnest .and. .not. abort) then
  1114. if(wrf_dm_on_monitor() .and. .not. abort) then
  1115. WRITE(mess,*)'vortex tracking: id,mvnest,num_moves,num_nests: ', &
  1116. grid%id,grid%mvnest,grid%num_moves,grid%num_nests
  1117. call wrf_debug(1,mess)
  1118. WRITE(mess,*)'vortex tracking: xloc_1,xloc_2,yloc_y,yloc_2,vortex_tracker: ', &
  1119. grid%XLOC_1,grid%XLOC_2,grid%YLOC_1,grid%YLOC_2,grid%vortex_tracker
  1120. call wrf_debug(1,mess)
  1121. endif
  1122. nest_following: IF(grid%vortex_tracker==2)THEN
  1123. ! Follow child
  1124. pgr=grid%parent_grid_ratio+0.01
  1125. pgrn=grid%parent_grid_ratio-0.01
  1126. kid=>grid%nests(1)%ptr !

Large files files are truncated, but you can click here to view the full file