dyn_em/shift_domain_em.F

   1 SUBROUTINE shift_domain_em ( grid , disp_x, disp_y &
   2 !
   3 # include "dummy_new_args.inc"
   4 !
   5                            )
   6    USE module_state_description
   7    USE module_domain, ONLY : domain, get_ijk_from_grid
   8    USE module_domain_type, ONLY : fieldlist
   9    USE module_timing
  10    USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
  11 #ifdef DM_PARALLEL
  12    USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, itrace
  13    USE module_comm_dm, ONLY : SHIFT_HALO_sub
  14 #else
  15    USE module_dm
  16 #endif
  17    IMPLICIT NONE
  18   ! Arguments
  19    INTEGER disp_x, disp_y       ! number of parent domain points to move
  20    TYPE(domain) , POINTER                     :: grid
  21   ! Local
  22    INTEGER i, j, ii, ipf
  23    INTEGER px, py       ! number and direction of nd points to move
  24    INTEGER                         :: ids , ide , jds , jde , kds , kde , &
  25                                       ims , ime , jms , jme , kms , kme , &
  26                                       ips , ipe , jps , jpe , kps , kpe
  27    INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
  28    TYPE (grid_config_rec_type)  :: config_flags
  29    TYPE( fieldlist ), POINTER :: p
  30
  31    INTERFACE
  32        ! need to split this routine to avoid clobbering certain widely used compilers
  33        SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y &
  34 !
  35 # include "dummy_new_args.inc"
  36 !
  37                            )
  38           USE module_state_description
  39           USE module_domain, ONLY : domain
  40           IMPLICIT NONE
  41          ! Arguments
  42           INTEGER disp_x, disp_y       ! number of parent domain points to move
  43           TYPE(domain) , POINTER                     :: grid
  44
  45           !  Definitions of dummy arguments to solve
  46 #include "dummy_new_decl.inc"
  47        END SUBROUTINE shift_domain_em2
  48    END INTERFACE
  49
  50    !  Definitions of dummy arguments to solve
  51 #include "dummy_new_decl.inc"
  52
  53 #ifdef MOVE_NESTS
  54
  55    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
  56
  57    CALL get_ijk_from_grid (  grid ,                   &
  58                              ids, ide, jds, jde, kds, kde,    &
  59                              ims, ime, jms, jme, kms, kme,    &
  60                              ips, ipe, jps, jpe, kps, kpe    )
  61
  62    px = isign(config_flags%parent_grid_ratio,disp_x)
  63    py = isign(config_flags%parent_grid_ratio,disp_y)
  64
  65    grid%imask_nostag = 1
  66    grid%imask_xstag = 1
  67    grid%imask_ystag = 1
  68    grid%imask_xystag = 1
  69
  70    grid%imask_nostag(ips:min(ide-1,ipe),jps:min(jde-1,jpe)) = 0
  71    grid%imask_xstag(ips:ipe,jps:min(jde-1,jpe)) = 0
  72    grid%imask_ystag(ips:min(ide-1,ipe),jps:jpe) = 0
  73    grid%imask_xystag(ips:ipe,jps:jpe) = 0
  74
  75 ! shift the nest domain in x
  76    do ii = 1,abs(disp_x)
  77 #include "SHIFT_HALO.inc"
  78 #include "../frame/loop_based_x_shift_code.h"
  79    enddo
  80
  81    CALL shift_domain_em2 ( grid , disp_x, disp_y &
  82 !
  83 # include "dummy_new_args.inc"
  84 !
  85                            )
  86
  87 #endif
  88
  89 END SUBROUTINE shift_domain_em
  90
  91 SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y &
  92 !
  93 # include "dummy_new_args.inc"
  94 !
  95                            )
  96    USE module_state_description
  97    USE module_domain, ONLY : domain, get_ijk_from_grid
  98    USE module_domain_type, ONLY : fieldlist
  99    USE module_timing
 100    USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
 101 #ifdef DM_PARALLEL
 102    USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, itrace
 103    USE module_comm_dm, ONLY : SHIFT_HALO_sub
 104 #else
 105    USE module_dm
 106 #endif
 107    IMPLICIT NONE
 108   ! Arguments
 109    INTEGER disp_x, disp_y       ! number of parent domain points to move
 110    TYPE(domain) , POINTER                     :: grid
 111   ! Local
 112    INTEGER i, j, ii, jpf
 113    INTEGER px, py       ! number and direction of nd points to move
 114    INTEGER                         :: ids , ide , jds , jde , kds , kde , &
 115                                       ims , ime , jms , jme , kms , kme , &
 116                                       ips , ipe , jps , jpe , kps , kpe
 117    INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
 118    TYPE (grid_config_rec_type)  :: config_flags
 119    TYPE( fieldlist ), POINTER :: p
 120
 121    !  Definitions of dummy arguments to solve
 122 #include "dummy_new_decl.inc"
 123
 124 #ifdef MOVE_NESTS
 125
 126    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 127
 128    CALL get_ijk_from_grid (  grid ,                   &
 129                              ids, ide, jds, jde, kds, kde,    &
 130                              ims, ime, jms, jme, kms, kme,    &
 131                              ips, ipe, jps, jpe, kps, kpe    )
 132
 133    px = isign(config_flags%parent_grid_ratio,disp_x)
 134    py = isign(config_flags%parent_grid_ratio,disp_y)
 135
 136 ! shift the nest domain in y
 137    do ii = 1,abs(disp_y)
 138 #include "SHIFT_HALO.inc"
 139 #include "../frame/loop_based_y_shift_code.h"
 140    enddo
 141
 142 #endif
 143 END SUBROUTINE shift_domain_em2
 144