share/mediation_nest_move.F

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