external/RSL_LITE/interp_domain_em_small.F

   1
   2 !------------------------------------------------------------------
   3
   4 #if ( EM_CORE == 1 && DA_CORE != 1 )
   5
   6 !------------------------------------------------------------------
   7
   8    SUBROUTINE interp_domain_em_small_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_comm_dm, ONLY: halo_em_horiz_interp_sub
  17       USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
  18                             mytask, get_dm_max_halo_width,                          &
  19                             nest_task_offsets, mpi_comm_to_kid, mpi_comm_to_mom,    &
  20                             which_kid, nest_pes_x, nest_pes_y, intercomm_active
  21       USE module_timing
  22       IMPLICIT NONE
  23 !
  24       TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
  25       TYPE(domain), POINTER :: intermediate_grid
  26       TYPE(domain), POINTER :: ngrid
  27 #include "dummy_new_decl.inc"
  28       INTEGER nlev, msize
  29       INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
  30       INTEGER iparstrt,jparstrt,sw
  31       TYPE (grid_config_rec_type)            :: config_flags
  32       REAL xv(2000)
  33       INTEGER       ::           ids,  ide,  jds,  jde,  kds,  kde,    &
  34                                  ims,  ime,  jms,  jme,  kms,  kme,    &
  35                                  ips,  ipe,  jps,  jpe,  kps,  kpe
  36
  37       INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
  38                                 cims, cime, cjms, cjme, ckms, ckme,    &
  39                                 cips, cipe, cjps, cjpe, ckps, ckpe
  40       INTEGER       ::          iids, iide, ijds, ijde, ikds, ikde,    &
  41                                 iims, iime, ijms, ijme, ikms, ikme,    &
  42                                 iips, iipe, ijps, ijpe, ikps, ikpe
  43       INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
  44                                 nims, nime, njms, njme, nkms, nkme,    &
  45                                 nips, nipe, njps, njpe, nkps, nkpe
  46
  47       INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
  48
  49       INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
  50       INTEGER thisdomain_max_halo_width
  51       INTEGER local_comm, myproc, nproc
  52       INTEGER ioffset
  53
  54       CALL wrf_get_dm_communicator ( local_comm )
  55       CALL wrf_get_myproc( myproc )
  56       CALL wrf_get_nproc( nproc )
  57
  58       CALL get_ijk_from_grid (  grid ,                           &
  59                                 ids, ide, jds, jde, kds, kde,    &
  60                                 ims, ime, jms, jme, kms, kme,    &
  61                                 ips, ipe, jps, jpe, kps, kpe     )
  62 #ifdef DM_PARALLEL
  63 # include "HALO_EM_HORIZ_INTERP.inc"
  64 #endif
  65
  66       CALL get_ijk_from_grid (  grid ,                   &
  67                                 cids, cide, cjds, cjde, ckds, ckde,    &
  68                                 cims, cime, cjms, cjme, ckms, ckme,    &
  69                                 cips, cipe, cjps, cjpe, ckps, ckpe    )
  70       CALL get_ijk_from_grid (  intermediate_grid ,              &
  71                                 iids, iide, ijds, ijde, ikds, ikde,    &
  72                                 iims, iime, ijms, ijme, ikms, ikme,    &
  73                                 iips, iipe, ijps, ijpe, ikps, ikpe    )
  74       CALL get_ijk_from_grid (  ngrid ,              &
  75                                 nids, nide, njds, njde, nkds, nkde,    &
  76                                 nims, nime, njms, njme, nkms, nkme,    &
  77                                 nips, nipe, njps, njpe, nkps, nkpe    )
  78
  79       CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
  80       CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
  81       CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
  82       CALL nl_get_shw            ( intermediate_grid%id, sw )
  83       icoord =    iparstrt - sw
  84       jcoord =    jparstrt - sw
  85       idim_cd = iide - iids + 1
  86       jdim_cd = ijde - ijds + 1
  87
  88       nlev  = ckde - ckds + 1
  89
  90       ! get max_halo_width for parent. It may be smaller if it is moad
  91       CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
  92
  93       !  How many 3d arrays, so far just 3d theta-300 and geopotential perturbation,
  94       !  and the 2d topo elevation, three max press/temp/height fields, and three
  95       !  min press/temp/height fields.
  96
  97       msize = ( 2 )* nlev + 7
  98
  99 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, calling rsl_lite_to_child')
 100       CALL rsl_lite_to_child_info( local_communicator, msize*RWORDSIZE     &
 101                               ,cips,cipe,cjps,cjpe                         &
 102                               ,iids,iide,ijds,ijde                         &
 103                               ,nids,nide,njds,njde                         &
 104                               ,pgr , sw                                    &
 105                               ,ntasks_x,ntasks_y                           &
 106                               ,thisdomain_max_halo_width                   &
 107                               ,icoord,jcoord                               &
 108                               ,idim_cd,jdim_cd                             &
 109                               ,pig,pjg,retval )
 110 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, back from rsl_lite_to_child')
 111       DO while ( retval .eq. 1 )
 112          IF ( SIZE(grid%ph_2) .GT. 1 ) THEN
 113 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ph_2')
 114             DO k = ckds,ckde
 115                xv(k)= grid%ph_2(pig,k,pjg)
 116             END DO
 117             CALL rsl_lite_to_child_msg(((ckde)-(ckds)+1)*RWORDSIZE,xv)
 118          END IF
 119
 120          IF ( SIZE(grid%t_2) .GT. 1 ) THEN
 121 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, t_2')
 122             DO k = ckds,(ckde-1)
 123                xv(k)= grid%t_2(pig,k,pjg)
 124             END DO
 125             CALL rsl_lite_to_child_msg((((ckde-1))-(ckds)+1)*RWORDSIZE,xv)
 126          END IF
 127
 128          IF ( SIZE(grid%ht) .GT. 1 ) THEN
 129 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ht')
 130             xv(1)= grid%ht(pig,pjg)
 131             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 132          END IF
 133
 134          IF ( SIZE(grid%t_max_p) .GT. 1 ) THEN
 135 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, t_max_p')
 136             xv(1)= grid%t_max_p(pig,pjg)
 137             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 138          END IF
 139
 140          IF ( SIZE(grid%ght_max_p) .GT. 1 ) THEN
 141 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ght_max_p')
 142             xv(1)= grid%ght_max_p(pig,pjg)
 143             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 144          END IF
 145
 146          IF ( SIZE(grid%max_p) .GT. 1 ) THEN
 147 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, max_p')
 148             xv(1)= grid%max_p(pig,pjg)
 149             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 150          END IF
 151
 152          IF ( SIZE(grid%t_min_p) .GT. 1 ) THEN
 153 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, t_min_p')
 154             xv(1)= grid%t_min_p(pig,pjg)
 155             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 156          END IF
 157
 158          IF ( SIZE(grid%ght_min_p) .GT. 1 ) THEN
 159 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ght_min_p')
 160             xv(1)= grid%ght_min_p(pig,pjg)
 161             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 162          END IF
 163
 164          IF ( SIZE(grid%min_p) .GT. 1 ) THEN
 165 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, min_p')
 166             xv(1)= grid%min_p(pig,pjg)
 167             CALL rsl_lite_to_child_msg(RWORDSIZE,xv)
 168          END IF
 169
 170 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, calling rsl_lite_to_child_info')
 171          CALL rsl_lite_to_child_info( local_communicator, msize*RWORDSIZE  &
 172                                      ,cips,cipe,cjps,cjpe                  &
 173                                      ,iids,iide,ijds,ijde                  &
 174                                      ,nids,nide,njds,njde                  &
 175                                      ,pgr , sw                             &
 176                                      ,ntasks_x,ntasks_y                    &
 177                                      ,thisdomain_max_halo_width            &
 178                                      ,icoord,jcoord                        &
 179                                      ,idim_cd,jdim_cd                      &
 180                                      ,pig,pjg,retval )
 181 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, back from rsl_lite_to_child_info')
 182       END DO
 183
 184       ! determine which communicator and offset to use
 185       IF ( intercomm_active( grid%id ) ) THEN        ! I am parent
 186         local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id )
 187         ioffset = nest_task_offsets(ngrid%id)
 188       ELSE IF ( intercomm_active( ngrid%id ) ) THEN  ! I am nest
 189         local_comm = mpi_comm_to_mom( ngrid%id )
 190         ioffset = nest_task_offsets(ngrid%id)
 191       END IF
 192
 193 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, calling rsl_lite_bcast')
 194       CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id),         &
 195                                         nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id),       &
 196                                         ioffset, local_comm )
 197 !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, back from rsl_lite_bcast')
 198
 199       RETURN
 200    END SUBROUTINE interp_domain_em_small_part1
 201
 202 !------------------------------------------------------------------
 203
 204    SUBROUTINE interp_domain_em_small_part2 ( grid, ngrid, config_flags    &
 205 !
 206 #include "dummy_new_args.inc"
 207 !
 208                  )
 209       USE module_state_description
 210       USE module_domain, ONLY : domain, get_ijk_from_grid
 211       USE module_configure, ONLY : grid_config_rec_type
 212       USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
 213                             mytask, get_dm_max_halo_width
 214       USE module_comm_nesting_dm, ONLY : halo_interp_down_sub
 215       IMPLICIT NONE
 216 !
 217       TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
 218       TYPE(domain), POINTER :: ngrid
 219 #include "dummy_new_decl.inc"
 220       INTEGER nlev, msize
 221       INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
 222       TYPE (grid_config_rec_type)            :: config_flags
 223       REAL xv(2000)
 224       INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
 225                                 cims, cime, cjms, cjme, ckms, ckme,    &
 226                                 cips, cipe, cjps, cjpe, ckps, ckpe
 227       INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
 228                                 nims, nime, njms, njme, nkms, nkme,    &
 229                                 nips, nipe, njps, njpe, nkps, nkpe
 230       INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
 231                                 ims, ime, jms, jme, kms, kme,    &
 232                                 ips, ipe, jps, jpe, kps, kpe
 233
 234       INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
 235
 236       INTEGER myproc
 237       INTEGER ierr
 238       INTEGER thisdomain_max_halo_width
 239
 240       CALL get_ijk_from_grid (  grid ,                   &
 241                                 cids, cide, cjds, cjde, ckds, ckde,    &
 242                                 cims, cime, cjms, cjme, ckms, ckme,    &
 243                                 cips, cipe, cjps, cjpe, ckps, ckpe    )
 244       CALL get_ijk_from_grid (  ngrid ,              &
 245                                 nids, nide, njds, njde, nkds, nkde,    &
 246                                 nims, nime, njms, njme, nkms, nkme,    &
 247                                 nips, nipe, njps, njpe, nkps, nkpe    )
 248
 249       nlev  = ckde - ckds + 1
 250
 251       CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
 252
 253       CALL rsl_lite_from_parent_info(pig,pjg,retval)
 254
 255       DO while ( retval .eq. 1 )
 256
 257          IF ( SIZE(grid%ph_2) .GT. 1 ) THEN
 258             CALL rsl_lite_from_parent_msg(((ckde)-(ckds)+1)*RWORDSIZE,xv)
 259             DO k = ckds,ckde
 260                grid%ph_2(pig,k,pjg) = xv(k)
 261             END DO
 262          END IF
 263
 264          IF ( SIZE(grid%t_2) .GT. 1 ) THEN
 265             CALL rsl_lite_from_parent_msg((((ckde-1))-(ckds)+1)*RWORDSIZE,xv)
 266             DO k = ckds,(ckde-1)
 267                grid%t_2(pig,k,pjg) = xv(k)
 268             END DO
 269          END IF
 270
 271          IF ( SIZE(grid%ht) .GT. 1 ) THEN
 272             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 273             grid%ht(pig,pjg) = xv(1)
 274          END IF
 275
 276          IF ( SIZE(grid%t_max_p) .GT. 1 ) THEN
 277             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 278             grid%t_max_p(pig,pjg) = xv(1)
 279          END IF
 280
 281          IF ( SIZE(grid%ght_max_p) .GT. 1 ) THEN
 282             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 283             grid%ght_max_p(pig,pjg) = xv(1)
 284          END IF
 285
 286          IF ( SIZE(grid%max_p) .GT. 1 ) THEN
 287             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 288             grid%max_p(pig,pjg) = xv(1)
 289          END IF
 290
 291          IF ( SIZE(grid%t_min_p) .GT. 1 ) THEN
 292             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 293             grid%t_min_p(pig,pjg) = xv(1)
 294          END IF
 295
 296          IF ( SIZE(grid%ght_min_p) .GT. 1 ) THEN
 297             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 298             grid%ght_min_p(pig,pjg) = xv(1)
 299          END IF
 300
 301          IF ( SIZE(grid%min_p) .GT. 1 ) THEN
 302             CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)
 303             grid%min_p(pig,pjg) = xv(1)
 304          END IF
 305
 306          CALL rsl_lite_from_parent_info(pig,pjg,retval)
 307
 308       END DO
 309
 310       CALL get_ijk_from_grid (  grid ,              &
 311                                 ids, ide, jds, jde, kds, kde,    &
 312                                 ims, ime, jms, jme, kms, kme,    &
 313                                 ips, ipe, jps, jpe, kps, kpe    )
 314
 315 #include "HALO_INTERP_DOWN.inc"
 316
 317       CALL interp_fcn_bl ( grid%ph_2,                                           &
 318                            cids, cide, ckds, ckde, cjds, cjde,                  &
 319                            cims, cime, ckms, ckme, cjms, cjme,                  &
 320                            cips, cipe, ckps, MIN( ckde, ckpe ), cjps, cjpe,     &
 321                            ngrid%ph_2,                                          &
 322                            nids, nide, nkds, nkde, njds, njde,                  &
 323                            nims, nime, nkms, nkme, njms, njme,                  &
 324                            nips, nipe, nkps, MIN( nkde, nkpe ), njps, njpe,     &
 325                            config_flags%shw, ngrid%imask_nostag,                &
 326                            .FALSE., .FALSE.,                                    &
 327                            ngrid%i_parent_start, ngrid%j_parent_start,          &
 328                            ngrid%parent_grid_ratio, ngrid%parent_grid_ratio,    &
 329                            grid%ht, ngrid%ht,                                   &
 330                            grid%t_max_p, ngrid%t_max_p,                         &
 331                            grid%ght_max_p, ngrid%ght_max_p,                     &
 332                            grid%max_p, ngrid%max_p,                             &
 333                            grid%t_min_p, ngrid%t_min_p,                         &
 334                            grid%ght_min_p, ngrid%ght_min_p,                     &
 335                            grid%min_p, ngrid%min_p,                             &
 336                            ngrid%znw, ngrid%p_top                               )
 337
 338       CALL interp_fcn_bl ( grid%t_2,                                            &
 339                            cids, cide, ckds, ckde, cjds, cjde,                  &
 340                            cims, cime, ckms, ckme, cjms, cjme,                  &
 341                            cips, cipe, ckps, MIN( (ckde-1), ckpe ), cjps, cjpe, &
 342                            ngrid%t_2,                                           &
 343                            nids, nide, nkds, nkde, njds, njde,                  &
 344                            nims, nime, nkms, nkme, njms, njme,                  &
 345                            nips, nipe, nkps, MIN( (nkde-1), nkpe ), njps, njpe, &
 346                            config_flags%shw, ngrid%imask_nostag,                &
 347                            .FALSE., .FALSE.,                                    &
 348                            ngrid%i_parent_start, ngrid%j_parent_start,          &
 349                            ngrid%parent_grid_ratio, ngrid%parent_grid_ratio,    &
 350                            grid%ht, ngrid%ht,                                   &
 351                            grid%t_max_p, ngrid%t_max_p,                         &
 352                            grid%ght_max_p, ngrid%ght_max_p,                     &
 353                            grid%max_p, ngrid%max_p,                             &
 354                            grid%t_min_p, ngrid%t_min_p,                         &
 355                            grid%ght_min_p, ngrid%ght_min_p,                     &
 356                            grid%min_p, ngrid%min_p,                             &
 357                            ngrid%znu, ngrid%p_top                               )
 358
 359       RETURN
 360    END SUBROUTINE interp_domain_em_small_part2
 361
 362 !------------------------------------------------------------------
 363
 364    SUBROUTINE feedback_nest_prep ( grid, config_flags    &
 365 !
 366 #include "dummy_new_args.inc"
 367 !
 368 )
 369       USE module_state_description
 370       USE module_domain, ONLY : domain, get_ijk_from_grid
 371       USE module_configure, ONLY : grid_config_rec_type
 372       USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask !, &
 373                              !push_communicators_for_domain, pop_communicators_for_domain
 374       USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
 375       IMPLICIT NONE
 376 !
 377       TYPE(domain), TARGET :: grid          ! name of the grid being dereferenced (must be "grid")
 378       TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
 379                                                   ! soil temp, moisture, etc., has vertical dim
 380                                                   ! of soil categories
 381 #include "dummy_new_decl.inc"
 382
 383       INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
 384                                 ims, ime, jms, jme, kms, kme,    &
 385                                 ips, ipe, jps, jpe, kps, kpe
 386
 387       INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
 388
 389       INTEGER       :: idum1, idum2
 390
 391
 392       CALL get_ijk_from_grid (  grid ,              &
 393                                 ids, ide, jds, jde, kds, kde,    &
 394                                 ims, ime, jms, jme, kms, kme,    &
 395                                 ips, ipe, jps, jpe, kps, kpe    )
 396
 397     IF ( grid%active_this_task ) THEN
 398       CALL push_communicators_for_domain( grid%id )
 399
 400 #ifdef DM_PARALLEL
 401 #include "HALO_INTERP_UP.inc"
 402 #endif
 403
 404       CALL pop_communicators_for_domain
 405     END IF
 406
 407    END SUBROUTINE feedback_nest_prep
 408
 409 !------------------------------------------------------------------
 410
 411 #endif