external/RSL_LITE/interp_domain_em_part1.F

   1
   2 !------------------------------------------------------------------
   3
   4 #if ( EM_CORE == 1 && DA_CORE != 1 )
   5
   6 !------------------------------------------------------------------
   7
   8    SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags    &
   9 !
  10 #include "dummy_new_args.inc"
  11 !
  12                  )
  13       USE module_state_description
  14       USE module_domain, ONLY : domain, get_ijk_from_grid
  15       USE module_configure, ONLY : grid_config_rec_type
  16       USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
  17                             nest_task_offsets, nest_pes_x, nest_pes_y, which_kid,   &
  18                             intercomm_active, mpi_comm_to_kid, mpi_comm_to_mom,     &
  19                             mytask, get_dm_max_halo_width
  20       USE module_timing
  21       IMPLICIT NONE
  22 !
  23       TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
  24       TYPE(domain), POINTER :: intermediate_grid
  25       TYPE(domain), POINTER :: ngrid
  26 #include "dummy_new_decl.inc"
  27       INTEGER nlev, msize
  28       INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
  29       INTEGER iparstrt,jparstrt,sw
  30       TYPE (grid_config_rec_type)            :: config_flags
  31       REAL xv(2000)
  32       INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
  33                                 cims, cime, cjms, cjme, ckms, ckme,    &
  34                                 cips, cipe, cjps, cjpe, ckps, ckpe
  35       INTEGER       ::          iids, iide, ijds, ijde, ikds, ikde,    &
  36                                 iims, iime, ijms, ijme, ikms, ikme,    &
  37                                 iips, iipe, ijps, ijpe, ikps, ikpe
  38       INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
  39                                 nims, nime, njms, njme, nkms, nkme,    &
  40                                 nips, nipe, njps, njpe, nkps, nkpe
  41
  42       INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
  43
  44       INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
  45       INTEGER thisdomain_max_halo_width
  46       INTEGER local_comm, myproc, nproc
  47       INTEGER ioffset, ierr
  48
  49       CALL wrf_get_dm_communicator ( local_comm )
  50       CALL wrf_get_myproc( myproc )
  51       CALL wrf_get_nproc( nproc )
  52
  53       CALL get_ijk_from_grid (  grid ,                   &
  54                                 cids, cide, cjds, cjde, ckds, ckde,    &
  55                                 cims, cime, cjms, cjme, ckms, ckme,    &
  56                                 cips, cipe, cjps, cjpe, ckps, ckpe    )
  57       CALL get_ijk_from_grid (  intermediate_grid ,              &
  58                                 iids, iide, ijds, ijde, ikds, ikde,    &
  59                                 iims, iime, ijms, ijme, ikms, ikme,    &
  60                                 iips, iipe, ijps, ijpe, ikps, ikpe    )
  61       CALL get_ijk_from_grid (  ngrid ,              &
  62                                 nids, nide, njds, njde, nkds, nkde,    &
  63                                 nims, nime, njms, njme, nkms, nkme,    &
  64                                 nips, nipe, njps, njpe, nkps, nkpe    )
  65
  66       CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
  67       CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
  68       CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
  69       CALL nl_get_shw            ( intermediate_grid%id, sw )
  70       icoord =    iparstrt - sw
  71       jcoord =    jparstrt - sw
  72       idim_cd = iide - iids + 1
  73       jdim_cd = ijde - ijds + 1
  74
  75       nlev  = ckde - ckds + 1
  76
  77       ! get max_halo_width for parent. It may be smaller if it is moad
  78       CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
  79
  80       IF ( grid%active_this_task ) THEN
  81 #include "nest_interpdown_pack.inc"
  82       END IF
  83
  84       ! determine which communicator and offset to use
  85       IF ( intercomm_active( grid%id ) ) THEN        ! I am parent
  86         local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id )
  87         ioffset = nest_task_offsets(ngrid%id)
  88       ELSE IF ( intercomm_active( ngrid%id ) ) THEN  ! I am nest
  89         local_comm = mpi_comm_to_mom( ngrid%id )
  90         ioffset = nest_task_offsets(ngrid%id)
  91       END IF
  92
  93       IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN
  94 #ifndef STUBMPI
  95         CALL mpi_comm_rank(local_comm,myproc,ierr)
  96         CALL mpi_comm_size(local_comm,nproc,ierr)
  97 #endif
  98         CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id),         &
  99                                           nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id),       &
 100                                           ioffset, local_comm )
 101       END IF
 102
 103       RETURN
 104    END SUBROUTINE interp_domain_em_part1
 105 #endif