share/mediation_force_domain.F

   1 !
   2 !WRF:MEDIATION_LAYER:NESTING
   3 !
   4 SUBROUTINE med_force_domain ( parent_grid , nested_grid )
   5    USE module_domain
   6    USE module_configure
   7 #ifdef DM_PARALLEL
   8    USE module_dm, ONLY : intercomm_active, &
   9                          mpi_comm_to_kid, mpi_comm_to_mom, which_kid
  10 #else
  11    USE module_dm, ONLY : intercomm_active
  12 #endif
  13
  14    IMPLICIT NONE
  15    TYPE(domain), POINTER :: parent_grid , nested_grid
  16    TYPE(domain), POINTER :: grid
  17    INTEGER nlev, msize
  18 #if !defined(MAC_KLUDGE)
  19    TYPE (grid_config_rec_type)            :: config_flags
  20 #endif
  21
  22 ! ----------------------------------------------------------
  23 ! ------------------------------------------------------
  24 ! Interface blocks
  25 ! ------------------------------------------------------
  26    INTERFACE
  27 ! ------------------------------------------------------
  28 !    Interface definitions for EM CORE
  29 ! ------------------------------------------------------
  30 #if (EM_CORE == 1)
  31 #if !defined(MAC_KLUDGE)
  32 ! ------------------------------------------------------
  33 !    These routines are supplied by module_dm.F from the
  34 !    external communication package (e.g. external/RSL)
  35 ! ------------------------------------------------------
  36       SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags   &
  37 !
  38 #        include "dummy_new_args.inc"
  39 !
  40                  )
  41          USE module_domain
  42          USE module_configure
  43          TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
  44          TYPE(domain), POINTER :: intermediate_grid
  45          TYPE(domain), POINTER :: ngrid
  46          TYPE (grid_config_rec_type)            :: config_flags
  47 #        include "dummy_new_decl.inc"
  48       END SUBROUTINE interp_domain_em_part1
  49
  50       SUBROUTINE force_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags   &
  51 !
  52 #        include "dummy_new_args.inc"
  53 !
  54                  )
  55          USE module_domain
  56          USE module_configure
  57          TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
  58          TYPE(domain), POINTER :: nested_grid
  59          TYPE(domain), POINTER :: parent_grid   ! KAL added for vertical nesting
  60          TYPE (grid_config_rec_type)            :: config_flags
  61 #        include "dummy_new_decl.inc"
  62       END SUBROUTINE force_domain_em_part2
  63
  64 ! ----------------------------------------------------------
  65 !    This routine is supplied by dyn_em/couple_or_uncouple_em.F
  66 ! ----------------------------------------------------------
  67       SUBROUTINE couple_or_uncouple_em ( grid, config_flags , couple  &
  68 !
  69 #        include "dummy_new_args.inc"
  70 !
  71                  )
  72          USE module_domain
  73          USE module_configure
  74          TYPE(domain), INTENT(INOUT)            :: grid
  75          TYPE (grid_config_rec_type)            :: config_flags
  76          LOGICAL, INTENT(   IN) :: couple
  77 #        include "dummy_new_decl.inc"
  78       END SUBROUTINE couple_or_uncouple_em
  79 #endif
  80 #endif
  81    END INTERFACE
  82 ! ----------------------------------------------------------
  83 ! End of Interface blocks
  84 ! ----------------------------------------------------------
  85 ! ----------------------------------------------------------
  86 ! ----------------------------------------------------------
  87 ! Executable code
  88 ! ----------------------------------------------------------
  89 ! ----------------------------------------------------------
  90 !    Forcing calls for EM CORE.
  91 ! ----------------------------------------------------------
  92 #if (EM_CORE == 1 && defined( DM_PARALLEL ))
  93 # if !defined(MAC_KLUDGE)
  94    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
  95
  96    grid => nested_grid%intermediate_grid
  97 #  if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10))))
  98 !   IF ( intercomm_active(grid%id) ) THEN
  99      CALL alloc_space_field ( grid, grid%id , 1 , 2 ,  .TRUE. , intercomm_active(grid%id),    &
 100                             grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
 101                             grid%sm31,  grid%em31,  grid%sm32,  grid%em32,  grid%sm33,  grid%em33, &
 102                             grid%sp31,  grid%ep31,  grid%sp32,  grid%ep32,  grid%sp33,  grid%ep33, &
 103                             grid%sp31x, grid%ep31x, grid%sp32x, grid%ep32x, grid%sp33x, grid%ep33x,&
 104                             grid%sp31y, grid%ep31y, grid%sp32y, grid%ep32y, grid%sp33y, grid%ep33y,&
 105                             grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, &   ! x-xpose
 106                             grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y  &   ! y-xpose
 107      )
 108 !   ENDIF
 109 #  endif
 110
 111    ! couple parent domain
 112    grid => parent_grid
 113    IF ( grid%active_this_task ) THEN
 114      CALL push_communicators_for_domain(grid%id)
 115    ! swich config_flags to point to parent rconfig info
 116      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 117      CALL couple_or_uncouple_em ( grid , config_flags ,  .true. &
 118 !
 119 #         include "actual_new_args.inc"
 120 !
 121                                 )
 122      CALL pop_communicators_for_domain
 123    ENDIF
 124    ! couple nested domain
 125    grid => nested_grid
 126    IF ( grid%active_this_task ) THEN
 127      CALL push_communicators_for_domain(grid%id)
 128      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 129      CALL couple_or_uncouple_em ( grid , config_flags ,  .true. &
 130 !
 131 #         include "actual_new_args.inc"
 132 !
 133                                    )
 134      CALL pop_communicators_for_domain
 135    ENDIF
 136    ! perform first part: transfer data from parent to intermediate domain
 137    ! at the same resolution but on the same decomposition as the nest
 138    ! note that this will involve communication on multiple DM procs
 139    grid => parent_grid
 140    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 141    !
 142    ! Added following line to handle adaptive time step.  This should probably
 143    !   go somewhere else, but I'm not sure where.
 144    !
 145    ! T. Hutchinson, WSI  1/23/07
 146    !
 147
 148    IF ( parent_grid%active_this_task .AND. nested_grid%active_this_task ) THEN
 149      nested_grid%intermediate_grid%dt = grid%dt
 150    ENDIF
 151    IF ( parent_grid%active_this_task ) THEN
 152      CALL BYTE_BCAST( parent_grid%dt,RWORDSIZE,mpi_comm_to_kid( which_kid( nested_grid%id ) , parent_grid%id ))
 153    ELSE IF ( nested_grid%active_this_task ) THEN
 154      CALL BYTE_BCAST( nested_grid%dt,RWORDSIZE,mpi_comm_to_mom( nested_grid%id ) )
 155    ENDIF
 156
 157    IF ( parent_grid%active_this_task .OR. nested_grid%active_this_task ) THEN
 158      CALL wrf_dm_nestexchange_init
 159
 160      CALL interp_domain_em_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags  &
 161 !
 162 #         include "actual_new_args.inc"
 163 !
 164                                     )
 165    ENDIF
 166
 167   IF ( nested_grid%active_this_task ) THEN
 168    grid => nested_grid%intermediate_grid
 169       ! perform 2nd part: run interpolation on the intermediate domain
 170       ! and compute the values for the nest boundaries
 171       ! note that this is all local (no communication)
 172    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 173    CALL force_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags   &
 174 !
 175 #          include "actual_new_args.inc"
 176 !
 177                                    )
 178   ENDIF
 179    ! uncouple the nest
 180    grid => nested_grid
 181    IF ( grid%active_this_task ) THEN
 182      CALL push_communicators_for_domain(grid%id)
 183      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 184      CALL couple_or_uncouple_em ( grid , config_flags ,  .false.  &
 185 !
 186 #          include "actual_new_args.inc"
 187 !
 188                                    )
 189      CALL pop_communicators_for_domain
 190    ENDIF
 191    ! uncouple the parent
 192    grid => parent_grid
 193    IF ( grid%active_this_task ) THEN
 194      CALL push_communicators_for_domain(grid%id)
 195      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 196      CALL couple_or_uncouple_em ( grid , config_flags ,  .false.  &
 197 !
 198 #          include "actual_new_args.inc"
 199 !
 200                                 )
 201      CALL pop_communicators_for_domain
 202    ENDIF
 203    IF ( nested_grid%first_force ) THEN
 204       nested_grid%first_force = .FALSE.
 205    ENDIF
 206    nested_grid%dtbc = 0.
 207 !
 208    grid => nested_grid%intermediate_grid
 209 #  if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10))))
 210    IF ( intercomm_active(grid%id) ) THEN
 211      CALL dealloc_space_field ( grid )
 212    ENDIF
 213 #  endif
 214 # endif
 215 #endif
 216 ! ------------------------------------------------------
 217 !    End of Forcing calls for EM CORE.
 218 ! ------------------------------------------------------
 219    RETURN
 220 END SUBROUTINE med_force_domain
 221
 222