SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & 1,9
!
# include <dummy_new_args.inc>
!
)
USE module_domain
USE module_timing
USE module_configure
USE module_dm
USE module_comm_dm
USE module_timing
IMPLICIT NONE
! Arguments
INTEGER disp_x, disp_y ! number of parent domain points to move
TYPE(domain) , POINTER :: grid
! Local
INTEGER :: i, j, ii, ipf, jpf
INTEGER :: px, py ! number and direction of nd points to move
INTEGER :: ids , ide , jds , jde , kds , kde , &
ims , ime , jms , jme , kms , kme , &
ips , ipe , jps , jpe , kps , kpe
TYPE (grid_config_rec_type) :: config_flags
TYPE( fieldlist ), POINTER :: p
LOGICAL :: E_BDY,N_BDY,S_BDY,W_BDY
CHARACTER(LEN=255) :: message
! Definitions of dummy arguments to solve
#include <dummy_new_decl.inc>
!#define COPY_IN
!#include <scalar_derefs.inc>
#ifdef DM_PARALLEL
# include <data_calls.inc>
#endif
CALL model_to_grid_config_rec
( grid%id , model_config_rec , config_flags )
CALL get_ijk_from_grid
( grid , &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe )
S_BDY=(JPS==JDS)
N_BDY=(JPE==JDE)
W_BDY=(IPS==IDS)
E_BDY=(IPE==IDE)
write(message,*)' S_BDY,N_BDY,W_BDY,E_BDY ', S_BDY,N_BDY,W_BDY,E_BDY
CALL wrf_message
(trim(message))
grid%imask_nostag=0
#if 1
IF ( disp_x > 0 ) THEN
IF ( E_BDY ) THEN
DO J=jps,min(jde-1,jpe)
DO I=ips,min(ide-1,ipe-2-mod(j+1,2))
grid%imask_nostag(i,j) = 1
END DO
END DO
ELSE
DO J=jps,min(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
END IF
!
IF ( disp_y > 0 ) THEN
IF ( N_BDY ) THEN
DO J=min(jde-1,jpe-2),max(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 0
END DO
END DO
ENDIF
ELSEIF ( disp_y < 0 ) THEN
IF ( S_BDY ) THEN
DO J=jps,jps+1
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 0
END DO
END DO
ENDIF
ENDIF !disp_y
!
ELSEIF ( disp_x < 0 ) THEN
IF ( W_BDY ) THEN
DO J=jps,min(jde-1,jpe)
DO I=ips+1,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
ELSE
DO J=jps,min(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
END IF
!
IF ( disp_y > 0 ) THEN
IF ( N_BDY ) THEN
DO J=min(jde-1,jpe-2),max(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 0
END DO
END DO
ENDIF
ELSEIF ( disp_y < 0 ) THEN
IF ( S_BDY ) THEN
DO J=jps,jps+1
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 0
END DO
END DO
ENDIF
ENDIF !disp_y
!
ELSE ! disp_x = 0
!
IF ( disp_y > 0 ) THEN
IF ( N_BDY ) THEN
DO J=jps,min(jde-1,jpe-3)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
ELSE
DO J=jps,min(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
END IF
END IF
IF ( disp_y < 0 ) THEN
IF ( S_BDY ) THEN
DO J=jps+2,min(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
ELSE
DO J=jps,min(jde-1,jpe)
DO I=ips,min(ide-1,ipe)
grid%imask_nostag(i,j) = 1
END DO
END DO
END IF
END IF
!
END IF
!
#else
grid%imask_nostag(ips:min(ide-4,ipe),jps:min(jde-1,jpe)) = 1
! grid%imask_nostag(ips+1:min(ide-2,ipe),jps+1:min(jde-2,jpe)) = 1
! grid%imask_nostag(ips+1:min(ide-1,ipe-1),jps+2:min(jde-1,jpe-2)) = 1
#endif
px = isign(grid%parent_grid_ratio,disp_x)
py = isign(grid%parent_grid_ratio,disp_y)
#ifdef DM_PARALLEL
! shift the nest domain in x
do ii = 1,abs(disp_x)
#include <../inc/SHIFT_HALO_X_HALO.inc>
#include <../frame/loop_based_x_shift_code.h>
enddo
! shift the nest domain in y
do ii = 1,abs(disp_y)
#include <../inc/SHIFT_HALO_Y_HALO.inc>
#include <../frame/loop_based_y_shift_code.h>
enddo
#endif
!#define COPY_OUT
!#include <scalar_derefs.inc>
END SUBROUTINE shift_domain_nmm