external/RSL_LITE/feedback_domain_em_part2.F

   1 #if ( EM_CORE == 1 && DA_CORE != 1 )
   2
   3 !------------------------------------------------------------------
   4
   5    SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags    &
   6 !
   7 #include "dummy_new_args.inc"
   8 !
   9                  )
  10       USE module_state_description
  11       USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
  12       USE module_configure, ONLY : grid_config_rec_type, model_config_rec
  13       USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
  14                             ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width,  &
  15                             nest_pes_x, nest_pes_y,                                         &
  16                             intercomm_active, nest_task_offsets,                    &
  17                             mpi_comm_to_mom, mpi_comm_to_kid, which_kid !,            &
  18                              !push_communicators_for_domain, pop_communicators_for_domain
  19
  20       USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
  21       USE module_utility
  22       IMPLICIT NONE
  23
  24 !
  25       TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
  26       TYPE(domain), POINTER :: intermediate_grid
  27       TYPE(domain), POINTER :: ngrid
  28       TYPE(domain), POINTER :: parent_grid
  29
  30 #include "dummy_new_decl.inc"
  31       INTEGER nlev, msize
  32       INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
  33       TYPE (grid_config_rec_type)            :: config_flags
  34       REAL xv(2000)
  35       INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
  36                                 cims, cime, cjms, cjme, ckms, ckme,    &
  37                                 cips, cipe, cjps, cjpe, ckps, ckpe
  38       INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
  39                                 nims, nime, njms, njme, nkms, nkme,    &
  40                                 nips, nipe, njps, njpe, nkps, nkpe
  41       INTEGER       ::          xids, xide, xjds, xjde, xkds, xkde,    &
  42                                 xims, xime, xjms, xjme, xkms, xkme,    &
  43                                 xips, xipe, xjps, xjpe, xkps, xkpe
  44       INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
  45                                 ims, ime, jms, jme, kms, kme,    &
  46                                 ips, ipe, jps, jpe, kps, kpe
  47
  48       INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
  49
  50       INTEGER icoord, jcoord, idim_cd, jdim_cd
  51       INTEGER local_comm, myproc, nproc, ioffset
  52       INTEGER iparstrt, jparstrt, sw, thisdomain_max_halo_width
  53       REAL    nest_influence
  54
  55       character*256 :: timestr
  56       integer ierr
  57
  58       LOGICAL, EXTERNAL  :: cd_feedback_mask
  59
  60 !cyl: add variables for trajectory
  61       integer tjk
  62
  63 ! On entry to this routine,
  64 !  "grid" refers to the parent domain
  65 !  "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
  66 !  "ngrid" refers to the nest, which is only needed for smoothing on the parent because
  67 !          the nest feedback data has already been transferred during em_nest_feedbackup_interp
  68 !          in part1, above.
  69 ! The way these settings c and n dimensions are set, below, looks backwards but from the point
  70 ! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
  71 ! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
  72 ! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
  73 ! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
  74 ! sign that says "DIP" than fix the dip,  at this point it was easier just to write this comment. JM
  75 !
  76       nest_influence = 1.
  77
  78       CALL domain_clock_get( grid, current_timestr=timestr )
  79
  80       CALL get_ijk_from_grid (  intermediate_grid ,                   &
  81                                 cids, cide, cjds, cjde, ckds, ckde,    &
  82                                 cims, cime, cjms, cjme, ckms, ckme,    &
  83                                 cips, cipe, cjps, cjpe, ckps, ckpe    )
  84       CALL get_ijk_from_grid (  grid ,              &
  85                                 nids, nide, njds, njde, nkds, nkde,    &
  86                                 nims, nime, njms, njme, nkms, nkme,    &
  87                                 nips, nipe, njps, njpe, nkps, nkpe    )
  88       CALL get_ijk_from_grid (  ngrid ,              &
  89                                 xids, xide, xjds, xjde, xkds, xkde,    &
  90                                 xims, xime, xjms, xjme, xkms, xkme,    &
  91                                 xips, xipe, xjps, xjpe, xkps, xkpe    )
  92
  93       ips_save = ngrid%i_parent_start   ! used in feedback_domain_em_part2 below
  94       jps_save = ngrid%j_parent_start
  95       ipe_save = ngrid%i_parent_start + (xide-xids+1) / ngrid%parent_grid_ratio - 1
  96       jpe_save = ngrid%j_parent_start + (xjde-xjds+1) / ngrid%parent_grid_ratio - 1
  97
  98
  99
 100
 101 IF ( ngrid%active_this_task ) THEN
 102 !cyl add this for trajectory
 103     CALL push_communicators_for_domain( ngrid%id )
 104
 105     do tjk = 1,config_flags%num_traj
 106      if (ngrid%traj_long(tjk) .eq. -9999.0) then
 107 !       print*,'n=-9999',tjk
 108         ngrid%traj_long(tjk)=grid%traj_long(tjk)
 109         ngrid%traj_k(tjk)=grid%traj_k(tjk)
 110      else
 111 !       print*,'p!=-9999',tjk
 112         grid%traj_long(tjk)=ngrid%traj_long(tjk)
 113         grid%traj_k(tjk)=ngrid%traj_k(tjk)
 114      endif
 115      if (ngrid%traj_lat(tjk) .eq. -9999.0) then
 116          ngrid%traj_lat(tjk)=grid%traj_lat(tjk)
 117          ngrid%traj_k(tjk)=grid%traj_k(tjk)
 118      else
 119          grid%traj_lat(tjk)=ngrid%traj_lat(tjk)
 120          grid%traj_k(tjk)=ngrid%traj_k(tjk)
 121      endif
 122     enddo
 123 !endcyl
 124
 125       CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
 126       CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
 127       CALL nl_get_shw            ( intermediate_grid%id, sw )
 128       icoord =    iparstrt - sw
 129       jcoord =    jparstrt - sw
 130       idim_cd = cide - cids + 1
 131       jdim_cd = cjde - cjds + 1
 132
 133       nlev  = ckde - ckds + 1
 134
 135       CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
 136
 137       parent_grid => grid
 138       grid => ngrid
 139 #include "nest_feedbackup_pack.inc"
 140       grid => parent_grid
 141     CALL pop_communicators_for_domain
 142
 143 END IF
 144
 145 !      CALL wrf_get_dm_communicator ( local_comm )
 146 !      CALL wrf_get_myproc( myproc )
 147 !      CALL wrf_get_nproc( nproc )
 148
 149       ! determine which communicator and offset to use
 150       IF ( intercomm_active( grid%id ) ) THEN        ! I am parent
 151         local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id )
 152         ioffset = nest_task_offsets(ngrid%id)
 153       ELSE IF ( intercomm_active( ngrid%id ) ) THEN  ! I am nest
 154         local_comm = mpi_comm_to_mom( ngrid%id )
 155         ioffset = nest_task_offsets(ngrid%id)
 156       END IF
 157
 158       IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN
 159 #ifndef STUBMPI
 160         CALL mpi_comm_rank(local_comm,myproc,ierr)
 161         CALL mpi_comm_size(local_comm,nproc,ierr)
 162 #endif
 163 !call tracebackqq()
 164         CALL rsl_lite_merge_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id),         &
 165                                           nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id),       &
 166                                           ioffset, local_comm )
 167       END IF
 168
 169 IF ( grid%active_this_task ) THEN
 170     CALL push_communicators_for_domain( grid%id )
 171
 172
 173 #define NEST_INFLUENCE(A,B) A = B
 174 #include "nest_feedbackup_unpack.inc"
 175
 176       ! smooth coarse grid
 177       CALL get_ijk_from_grid (  ngrid,                           &
 178                                 nids, nide, njds, njde, nkds, nkde,    &
 179                                 nims, nime, njms, njme, nkms, nkme,    &
 180                                 nips, nipe, njps, njpe, nkps, nkpe    )
 181       CALL get_ijk_from_grid (  grid ,              &
 182                                 ids, ide, jds, jde, kds, kde,    &
 183                                 ims, ime, jms, jme, kms, kme,    &
 184                                 ips, ipe, jps, jpe, kps, kpe    )
 185
 186 #include "HALO_INTERP_UP.inc"
 187
 188       CALL get_ijk_from_grid (  grid ,                   &
 189                                 cids, cide, cjds, cjde, ckds, ckde,    &
 190                                 cims, cime, cjms, cjme, ckms, ckme,    &
 191                                 cips, cipe, cjps, cjpe, ckps, ckpe    )
 192
 193 #include "nest_feedbackup_smooth.inc"
 194
 195     CALL pop_communicators_for_domain
 196 END IF
 197
 198       RETURN
 199    END SUBROUTINE feedback_domain_em_part2
 200 #endif