From 18105833beef27962e3c27c2808a7b1fecf62cfe Mon Sep 17 00:00:00 2001
From: Philippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Date: Tue, 25 Jul 2023 14:30:57 +0200
Subject: [PATCH] Philippe 25/07/2023: transfer ZSOLVER/ppm.f90 to MNH/ + adapt
it. This gives better performance on GPUs.
---
src/MNH/ppm.f90 | 1571 +++++++++-----
src/ZSOLVER/ppm.f90 | 4911 -------------------------------------------
2 files changed, 1010 insertions(+), 5472 deletions(-)
delete mode 100644 src/ZSOLVER/ppm.f90
diff --git a/src/MNH/ppm.f90 b/src/MNH/ppm.f90
index 414b1bcb1..2b8a1a1db 100644
--- a/src/MNH/ppm.f90
+++ b/src/MNH/ppm.f90
@@ -10,7 +10,8 @@
! P. Wautelet 18/07/2019: OpenACC: remove use of macros for dif2x/y/z
!-----------------------------------------------------------------
#ifdef MNH_OPENACC
-!! inline shuman with macro
+!
+! inline shuman with macro
!
!#define dxf(PDXF,PA) PDXF(1:IIU-1,:,:) = PA(2:IIU,:,:) - PA(1:IIU-1,:,:) ; PDXF(IIU,:,:) = PDXF(2*JPHEXT,:,:) ! DXF(PDXF,PA)
!#define dyf(PDYF,PA) PDYF(:,1:IJU-1,:) = PA(:,2:IJU,:) - PA(:,1:IJU-1,:); PDYF(:,IJU,:) = PDYF(:,2*JPHEXT,:) ! DYF(PDYF,PA)
@@ -318,14 +319,62 @@ END MODULE MODI_PPM
!
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
+! ########################################################################
+!!$ FUNCTION PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
+!!$ RESULT(PR)
SUBROUTINE PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
+! ########################################################################
+
+ USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+ USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+
+ IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+! output source term
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+
+INTEGER :: IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG
+
+!$acc data present( PSRC, PCR, PRHO, PR )
+
+ CALL MNH_GET_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
+
+ CALL PPM_01_X_D(IIU,IJU,IKU,HLBCX, KGRID, &
+ & PSRC, PCR, PRHO, PTSTEP, PR, &
+ & ZT3D(:,:,:,IZQL),ZT3D(:,:,:,IZQR),ZT3D(:,:,:,IZDQ),ZT3D(:,:,:,IZQ6), &
+ & ZT3D(:,:,:,IZDMQ),ZT3D(:,:,:,IZQL0),ZT3D(:,:,:,IZQR0), ZT3D(:,:,:,IZQ60), &
+ & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG) )
+
+ CALL MNH_REL_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
+
+!$acc end data
+!
+CONTAINS
+!
+! ########################################################################
+ SUBROUTINE PPM_01_X_D(IIU,IJU,IKU,HLBCX, KGRID, &
+ & PSRC, PCR, PRHO, PTSTEP, PR, &
+ & ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60,ZFPOS,ZFNEG)
+
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_01_X - PPM_01 fully monotonic PPM advection scheme in X direction
!! Colella notation
@@ -343,9 +392,6 @@ END MODULE MODI_PPM
USE MODD_CONF
USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
use mode_mppdb
#ifdef MNH_OPENACC
use mode_msg
@@ -368,6 +414,9 @@ IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
!
+#ifdef MNH_OPENACC
+INTEGER , INTENT(IN) :: IIU,IJU,IKU
+#endif
CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
!
INTEGER, INTENT(IN) :: KGRID ! C grid localisation
@@ -381,7 +430,7 @@ REAL, INTENT(IN) :: PTSTEP ! Time step
#ifndef MNH_OPENACC
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+REAL, DIMENSION(IIU,IJU,IKU), INTENT(OUT) :: PR
#endif
!
!* 0.2 Declarations of local variables :
@@ -390,8 +439,8 @@ INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE ! End useful area in x,y,z directions
!
integer :: ji, jj, jk
-integer :: iiu, iju, iku
#ifndef MNH_OPENACC
+integer :: iiu, iju, iku
! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL,ZQR
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDQ,ZQ6
@@ -402,20 +451,26 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL0,ZQR0,ZQ60
!
! advection fluxes
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
+!
+!BEG JUAN PPM_LL
+INTEGER :: IJS,IJN
+!END JUAN PPM_LL
#else
INTEGER :: I,J,K
-! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZQL,ZQR
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZDQ,ZQ6
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZDMQ
!
-! extra variables for the initial guess of parabolae parameters
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZQL0,ZQR0,ZQ60
+!!$!
+!!$! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
+REAL , DIMENSION(IIU,IJU,IKU) :: &
+ ZQL,ZQR, ZDQ,ZQ6, ZDMQ &
+!!$!
+!!$! extra variables for the initial guess of parabolae parameters
+ , ZQL0,ZQR0,ZQ60 &
+!!$!
+!!$! advection fluxes
+ , ZFPOS, ZFNEG
!
-! advection fluxes
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFPOS, ZFNEG
-#endif
INTEGER :: IJS,IJN
+#endif
LOGICAL :: GWEST , GEAST
!-------------------------------------------------------------------------------
!
@@ -423,6 +478,9 @@ LOGICAL :: GWEST , GEAST
CALL SBR_FZ(PSRC(:,:,:))
#endif
!
+!$acc data present( PSRC, PCR, PRHO, PR , &
+!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
+
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
CALL MPPDB_CHECK(PCR, "PPM_01_X beg:PCR")
@@ -430,30 +488,6 @@ IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
CALL MPPDB_CHECK(PSRC,"PPM_01_X beg:PSRC")
END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_01_X' )
-
-CALL MNH_MEM_GET( ZQL, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQR, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZDQ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQ6, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZDMQ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQL0, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQR0, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQ60, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFNEG, IIU, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PR , &
-!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
@@ -470,6 +504,10 @@ GEAST = LEAST_ll()
!* initialise & update halo & halo2 for PSRC
!
#ifndef MNH_OPENACC
+iiu = size( PSRC, 1 )
+iju = size( PSRC, 2 )
+iku = size( PSRC, 3 )
+
CALL GET_HALO(PSRC, HNAME='PSRC')
!
PR (:,:,:) = PSRC(:,:,:)
@@ -484,7 +522,7 @@ ZQ60 (:,:,:) = PSRC(:,:,:)
ZFPOS(:,:,:) = PSRC(:,:,:)
ZFNEG(:,:,:) = PSRC(:,:,:)
#else
-CALL GET_HALO_D(PSRC,HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::PSRC')
+CALL GET_HALO_D(PSRC,HDIR="01_X", HNAME='PSRC')
!
!$acc kernels present_cr(ZFPOS,ZFNEG,PSRC,PR,ZQL,zqr,zdq,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60)
!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = 1:iku )
@@ -497,10 +535,17 @@ CALL GET_HALO_D(PSRC,HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::PSRC')
ZQL0 (ji, jj, jk ) = PSRC(ji, jj, jk )
ZQR0 (ji, jj, jk ) = PSRC(ji, jj, jk )
ZQ60 (ji, jj, jk ) = PSRC(ji, jj, jk )
- !$mnh_end_do()
+!$mnh_end_do()
!
+#if 0
+ZFPOS(:,1:IJS,:)=PSRC(:,1:IJS,:)
+ZFNEG(:,1:IJS,:)=PSRC(:,1:IJS,:)
+ZFPOS(:,IJN:,:)=PSRC(:,IJN:,:)
+ZFNEG(:,IJN:,:)=PSRC(:,IJN:,:)
+#else
ZFPOS(:,:,:) = PSRC(:,:,:)
ZFNEG(:,:,:) = PSRC(:,:,:)
+#endif
!$acc end kernels
#endif
!
@@ -517,7 +562,7 @@ CASE ('CYCL','WALL') ! In that case one must have HLBCX(1) == HLBCX(2)
#endif
!
! calculate dmq
- CALL DIF2X( PSRC, ZDMQ )
+ ZDMQ = DIF2X(PSRC)
!
! monotonize the difference followinq eq. 5 in Lin94
!
@@ -649,7 +694,13 @@ CASE ('CYCL','WALL') ! In that case one must have HLBCX(1) == HLBCX(2)
CASE('OPEN')
!
! calculate dmq
- CALL DIF2X( PSRC, ZDMQ )
+!
+#ifndef MNH_OPENACC
+ ZDMQ = DIF2X(PSRC)
+#else
+ CALL DIF2X_DEVICE(ZDMQ,PSRC)
+#endif
+
!
! overwrite the values on the boundary to get second order difference
! for qL and qR at the boundary
@@ -708,7 +759,7 @@ CASE('OPEN')
CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
#else
!$acc end kernels
- CALL GET_HALO_D(ZDMQ, HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::ZDMQ')
+ CALL GET_HALO_D(ZDMQ, HDIR="01_X", HNAME='ZDMQ')
#endif
!$acc kernels present_cr(zdmq,zql0)
!
@@ -724,33 +775,30 @@ CASE('OPEN')
CALL GET_HALO(ZQL0, HNAME='ZQL0')
#else
!$acc end kernels
- CALL GET_HALO_D(ZQL0,HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
+ CALL GET_HALO_D(ZQL0,HDIR="01_X", HNAME='ZQL0')
+!$acc kernels present( ZQL0, ZQR0 )
#endif
!
! WEST BOUND
!
IF (GWEST) THEN
-!$acc kernels
ZQL0(IIB-1,IJS:IJN,:) = ZQL0(IIB,IJS:IJN,:)
-!$acc end kernels
ENDIF
!
-!$acc kernels present( ZQL0, ZQR0 )
ZQR0(IIB-1:IIE,IJS:IJN,:) = ZQL0(IIB:IIE+1,IJS:IJN,:)
-!$acc end kernels
!
#ifndef MNH_OPENACC
CALL GET_HALO(ZQR0, HNAME='ZQR0')
#else
- CALL GET_HALO_D(ZQR0, HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::ZQR0')
+!$acc end kernels
+ CALL GET_HALO_D(ZQR0, HDIR="01_X", HNAME='ZQR0')
+!$acc kernels present( PSRC,ZQ60,ZDQ,ZQL,ZQR,ZQ6,ZQL0,ZQR0,ZFPOS )
#endif
!
! EAST BOUND
!
IF (GEAST) THEN
-!$acc kernels present( ZQR0 )
ZQR0(IIE+1,IJS:IJN,:) = ZQR0(IIE,IJS:IJN,:)
-!$acc end kernels
ENDIF
#ifndef MNH_OPENACC
!
@@ -785,7 +833,6 @@ CASE('OPEN')
!
ZDQ(:,IJS:IJN,:) = ZQR(:,IJS:IJN,:) - ZQL(:,IJS:IJN,:)
#else
-!$acc kernels present(ZQL0,ZQR0) present_cr(psrc,zq60,ZDQ,ZQL,ZQR,ZQ6)
!$mnh_do_concurrent(I=1:IIU , J = IJS:IJN , K=1:IKU )
!
! determine initial coefficients of the parabolae
@@ -819,7 +866,6 @@ CASE('OPEN')
!
ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
!$mnh_end_do()
-!$acc end kernels
#endif
!
! and finally calculate fluxes for the advection
@@ -830,7 +876,6 @@ CASE('OPEN')
!!$ ZFPOS(IIB+1:IIE+1,:,:) = ZQR(IIB:IIE,:,:) - 0.5*PCR(IIB+1:IIE+1,:,:) * &
!!$ (ZDQ(IIB:IIE,:,:) - (1.0 - 2.0*PCR(IIB+1:IIE+1,:,:)/3.0) &
!!$ * ZQ6(IIB:IIE,:,:))
-!$acc kernels present_cr(zq6,zfpos)
!$mnh_do_concurrent( ji = iib:iie + 1 , jj = ijs:ijn , jk = 1:iku )
ZFPOS(ji, jj, jk ) = ZQR(ji - 1, jj, jk ) - 0.5 * PCR(ji, jj, jk ) &
* ( ZDQ(ji - 1, jj, jk) - (1.0 - 2.0 * PCR(ji, jj, jk ) / 3.0 ) &
@@ -842,7 +887,8 @@ CASE('OPEN')
CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
#else
!$acc end kernels
- CALL GET_HALO_D(ZFPOS, HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::ZFPOS')
+ CALL GET_HALO_D(ZFPOS, HDIR="01_X", HNAME='ZFPOS')
+!$acc kernels present_cr(ZFPOS,ZFNEG,ZQ6,ZQR)
#endif
!
!
@@ -851,19 +897,16 @@ CASE('OPEN')
! advection flux at open boundary when u(IIB) > 0
!
IF (GWEST) THEN
-!$acc kernels present_cr(ZFPOS,ZQR)
ZFPOS(IIB,IJS:IJN,:) = (PSRC(IIB-1,IJS:IJN,:) - ZQR(IIB-1,IJS:IJN,:))*PCR(IIB,IJS:IJN,:) + &
ZQR(IIB-1,IJS:IJN,:)
! PPOSX(IIB-1,:,:) is not important for the calc of advection so
! we set it to 0
!!$ ZFPOS(IIB-1,:,:) = 0.0
-!$acc end kernels
ENDIF
!
!!$ ZFNEG(IIB-1:IIE,:,:) = ZQL(IIB-1:IIE,:,:) - 0.5*PCR(IIB-1:IIE,:,:) * &
!!$ (ZDQ(IIB-1:IIE,:,:) + (1.0 + 2.0*PCR(IIB-1:IIE,:,:)/3.0) &
!!$ * ZQ6(IIB-1:IIE,:,:))
-!$acc kernels present_cr(zq6,zfneg)
!$mnh_do_concurrent( ji = 1:iiu , jj = ijs:ijn , jk = 1:iku )
ZFNEG(ji, jj, jk ) = ZQL(ji, jj, jk ) - 0.5*PCR(ji, jj, jk ) * &
( ZDQ(ji, jj, jk ) + (1.0 + 2.0*PCR(ji, jj, jk )/3.0) * ZQ6(ji, jj, jk ) )
@@ -873,17 +916,16 @@ CASE('OPEN')
CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
#else
!$acc end kernels
- CALL GET_HALO_D(ZFNEG, HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::ZFNEG')
+ CALL GET_HALO_D(ZFNEG, HDIR="01_X", HNAME='ZFNEG')
+!$acc kernels present_cr(ZFPOS,ZFNEG)
#endif
!
! EAST BOUND
!
! advection flux at open boundary when u(IIE+1) < 0
IF (GEAST) THEN
-!$acc kernels present_cr(ZFNEG,ZQR)
ZFNEG(IIE+1,IJS:IJN,:) = (ZQR(IIE,IJS:IJN,:)-PSRC(IIE+1,IJS:IJN,:))*PCR(IIE+1,IJS:IJN,:) + &
ZQR(IIE,IJS:IJN,:)
-!$acc end kernels
ENDIF
!
! advect the actual field in X direction by U*dt
@@ -894,6 +936,7 @@ CASE('OPEN')
CALL GET_HALO(PR, HNAME='PR')
#else
!mxm(ZQL,PRHO)
+!$acc end kernels
CALL MXM_DEVICE(PRHO,ZQL)
!$acc kernels present_cr(ZFPOS,ZFNEG,ZQR)
where ( PCR(:,:,:) > 0. )
@@ -904,7 +947,7 @@ CASE('OPEN')
!dxf(PR,ZQR)
!$acc end kernels
CALL DXF_DEVICE(ZQR,PR)
- CALL GET_HALO_D(PR, HDIR="01_X", HNAME='UPDATE_HALO_ll::GET_HALO::PR')
+ CALL GET_HALO_D(PR, HDIR="01_X", HNAME='PR')
#endif
!
END SELECT
@@ -922,19 +965,19 @@ END IF
!$acc end data
-#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_01_X' )
-#endif
-
+#ifndef MNH_OPENACC
CONTAINS
+#else
+END SUBROUTINE PPM_01_X_D
+#endif
!
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
! ########################################################################
- SUBROUTINE DIF2X( PQ, DQ )
+ FUNCTION DIF2X(PQ) RESULT(DQ)
! ########################################################################
+!!
!!**** DIF2X - leap-frog difference operator in X direction
!!
!! Calculates the difference assuming periodic BC (CYCL).
@@ -950,7 +993,7 @@ CONTAINS
!-------------------------------------------------------------------------------
!
!
-! USE MODE_ll
+USE MODE_ll
!
IMPLICIT NONE
!
@@ -989,8 +1032,69 @@ DQ = 0.5*DQ
!$acc end data
-END SUBROUTINE DIF2X
+END FUNCTION DIF2X
+!-------------------------------------------------------------------------------
+!
+! ########################################################################
+ SUBROUTINE DIF2X_DEVICE(DQ,PQ)
+! ########################################################################
+!!
+!!**** DIF2X - leap-frog difference operator in X direction
+!!
+!! Calculates the difference assuming periodic BC (CYCL).
+!!
+!! DQ(I) = 0.5 * (PQ(I+1) - PQ(I-1))
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! 18.3.2006. T. Maric - original version
+!! 07/2010 J.Escobar : Correction for reproducility
+!! 04/2017 J.Escobar : initialize realistic value in all HALO pts
+!-------------------------------------------------------------------------------
+!
+!
+USE MODE_ll
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
+REAL, DIMENSION(:,:,:) :: DQ
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IIB,IJB ! Begining useful area in x,y directions
+INTEGER :: IIE,IJE ! End useful area in x,y directions
+!
+!-------------------------------------------------------------------------------
+
+!$acc data present( PQ, DQ )
+!
+!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
+! -----------------------------
+!
+!!$CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+IIB=2 ; IIE = SIZE(PQ,1) -1
+IJB=2 ; IJE = SIZE(PQ,2) -1
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.0. COMPUTE THE DIFFERENCE
+! ----------------------
+!
+!$acc kernels
+DQ(IIB:IIE,:,:) = PQ(IIB+1:IIE+1,:,:) - PQ(IIB-1:IIE-1,:,:)
+DQ(IIB-1,:,:) = PQ(IIB,:,:) - PQ(IIE-1,:,:)
+DQ(IIE+1,:,:) = PQ(IIB+1,:,:) - PQ(IIE,:,:)
+DQ = 0.5*DQ
+!$acc end kernels
+
+!$acc end data
+END SUBROUTINE DIF2X_DEVICE
+!
#ifdef MNH_OPENACC
END SUBROUTINE PPM_01_X
#else
@@ -1001,14 +1105,62 @@ END FUNCTION PPM_01_X
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
+! ########################################################################
+!!$ FUNCTION PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
+!!$ RESULT(PR)
SUBROUTINE PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
+! ########################################################################
+
+ USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+ USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT):: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR & ! Courant number
+ , PRHO ! density
+!
+! output source term
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+
+INTEGER :: IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG
+
+!$acc data present( PSRC, PCR, PRHO, PR )
+
+ CALL MNH_GET_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
+
+ CALL PPM_01_Y_D(IIU,IJU,IKU,HLBCY, KGRID, &
+ & PSRC, PCR, PRHO, PTSTEP, PR, &
+ & ZT3D(:,:,:,IZQL),ZT3D(:,:,:,IZQR),ZT3D(:,:,:,IZDQ),ZT3D(:,:,:,IZQ6), &
+ & ZT3D(:,:,:,IZDMQ),ZT3D(:,:,:,IZQL0),ZT3D(:,:,:,IZQR0), ZT3D(:,:,:,IZQ60), &
+ & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG) )
+
+ CALL MNH_REL_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
+
+!$acc end data
+
+CONTAINS
+!
+! ########################################################################
+ SUBROUTINE PPM_01_Y_D(IIU,IJU,IKU,HLBCY, KGRID, &
+ & PSRC, PCR, PRHO, PTSTEP, PR, &
+ & ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60,ZFPOS,ZFNEG)
+
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_01_Y - PPM_01 fully monotonic PPM advection scheme in Y direction
!! Colella notation
@@ -1027,12 +1179,9 @@ USE MODD_CONF
USE MODE_ll
#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-use mode_mppdb
-#ifdef MNH_OPENACC
use mode_msg
#endif
+use mode_mppdb
#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
USE MODI_BITREP
@@ -1051,6 +1200,9 @@ IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
!
+#ifdef MNH_OPENACC
+integer, intent(in) :: iiu, iju, iku
+#endif
CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
!
INTEGER, INTENT(IN) :: KGRID ! C grid localisation
@@ -1065,7 +1217,7 @@ REAL, INTENT(IN) :: PTSTEP ! Time step
#ifndef MNH_OPENACC
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+REAL, DIMENSION(IIU,IJU,IKU), INTENT(OUT) :: PR
#endif
!
!* 0.2 Declarations of local variables :
@@ -1073,11 +1225,11 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE ! End useful area in x,y,z directions
!
-integer :: iiu, iju, iku
INTEGER :: IIW,IIA
!
LOGICAL :: GSOUTH , GNORTH
#ifndef MNH_OPENACC
+integer :: iiu, iju, iku
!
! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL,ZQR
@@ -1092,20 +1244,20 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
!
#else
! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZQL, ZQR
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZDQ, ZQ6
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZDMQ
-!
+REAL, DIMENSION(IIU,IJU,IKU) :: &
+ ZQL,ZQR , ZDQ,ZQ6 , ZDMQ &
! extra variables for the initial guess of parabolae parameters
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZQL0,ZQR0,ZQ60
-!
+ , ZQL0,ZQR0,ZQ60 &
! advection fluxes
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFPOS, ZFNEG
+ , ZFPOS, ZFNEG
+
!
+!JUAN ACC
INTEGER :: I,J,K
!
INTEGER :: IKB,IKE
INTEGER :: IJN,IJS
+!JUAN ACC
#endif
integer :: ji, jj, jk
!-------------------------------------------------------------------------------
@@ -1114,6 +1266,9 @@ integer :: ji, jj, jk
CALL SBR_FZ(PSRC(:,:,:))
#endif
!
+!$acc data present( PSRC, PCR, PRHO, PR, &
+!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
+
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
CALL MPPDB_CHECK(PCR, "PPM_01_Y beg:PCR")
@@ -1121,30 +1276,6 @@ IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
CALL MPPDB_CHECK(PSRC,"PPM_01_Y beg:PSRC")
END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_01_Y' )
-
-CALL MNH_MEM_GET( ZQL, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQR, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZDQ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQ6, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZDMQ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQL0, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQR0, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQ60, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFNEG, IIU, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PR, &
-!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
@@ -1157,6 +1288,10 @@ GSOUTH=LSOUTH_ll()
GNORTH=LNORTH_ll()
!
#ifndef MNH_OPENACC
+iiu = size( PSRC, 1 )
+iju = size( PSRC, 2 )
+iku = size( PSRC, 3 )
+
CALL GET_HALO(PSRC, HNAME='PSRC')
#else
IJS=1
@@ -1171,7 +1306,7 @@ IKE=IKU
!IIB=2
!IIE=IIU-1
!
-CALL GET_HALO_D(PSRC, HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::PSRC')
+CALL GET_HALO_D(PSRC, HDIR="01_Y", HNAME='PSRC')
#endif
!
!-------------------------------------------------------------------------------
@@ -1189,8 +1324,20 @@ CALL GET_HALO_D(PSRC, HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::PSRC')
ZQR0 (ji, jj, jk ) = PSRC(ji, jj, jk )
ZQ60 (ji, jj, jk ) = PSRC(ji, jj, jk )
!$mnh_end_do()
+#ifndef MNH_OPENACC
+ZFPOS=PSRC
+ZFNEG=PSRC
+#else
+#if 0
+ZFPOS(1:IIW,:,IKB:IKE)=PSRC(1:IIW,:,IKB:IKE)
+ZFNEG(1:IIW,:,IKB:IKE)=PSRC(1:IIW,:,IKB:IKE)
+ZFPOS(IIA:,:,IKB:IKE)=PSRC(IIA:,:,IKB:IKE)
+ZFNEG(IIA:,:,IKB:IKE)=PSRC(IIA:,:,IKB:IKE)
+#else
ZFPOS(:,:,:) = PSRC(:,:,:)
ZFNEG(:,:,:) = PSRC(:,:,:)
+#endif
+#endif
!$acc end kernels
!
SELECT CASE ( HLBCY(1) ) ! Y direction LBC type: (1) for left side
@@ -1201,7 +1348,7 @@ SELECT CASE ( HLBCY(1) ) ! Y direction LBC type: (1) for left side
CASE ('CYCL','WALL') ! In that case one must have HLBCY(1) == HLBCY(2)
!
! calculate dmq
- CALL DIF2Y( PSRC, ZDMQ )
+ ZDMQ = DIF2Y(PSRC)
!
! monotonize the difference followinq eq. 5 in Lin94
!BEG JUAN PPM_LL01
@@ -1237,7 +1384,7 @@ CASE ('CYCL','WALL') ! In that case one must have HLBCY(1) == HLBCY(2)
CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
#else
!$acc end kernels
- CALL GET_HALO_D(ZDMQ,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZDMQ')
+ CALL GET_HALO_D(ZDMQ,HDIR="01_Y", HNAME='ZDMQ')
!$acc kernels present_cr(ZQL0,PSRC,ZDMQ)
#endif
!
@@ -1245,27 +1392,15 @@ CASE ('CYCL','WALL') ! In that case one must have HLBCY(1) == HLBCY(2)
!
! ZQL0(IIW:IIA,IJB:IJE+1,:) = 0.5*(PSRC(IIW:IIA,IJB:IJE+1,:) + PSRC(IIW:IIA,IJB-1:IJE,:)) - &
! (ZDMQ(IIW:IIA,IJB:IJE+1,:) - ZDMQ(IIW:IIA,IJB-1:IJE,:))/6.0
-#if 1
!$mnh_do_concurrent( ji = iiw:iia , jj = ijb:ije + 1 , jk = 1:iku )
ZQL0(ji, jj, jk ) = 0.5 * ( PSRC(ji, jj, jk ) + PSRC(ji, jj-1, jk )) - ( ZDMQ(ji, jj, jk ) - ZDMQ(ji, jj-1, jk ) ) / 6.0
!$mnh_end_do()
-#else
- !$mnh_do_concurrent( ji = iiw : iia, jj = ijb : ije + 1, jk = 1 : iku )
- ZQL0(ji, jj, jk ) = 0.5 * ( PSRC(ji, jj, jk ) + PSRC(ji, jj-1, jk )) - ( ZDMQ(ji, jj, jk ) - ZDMQ(ji, jj-1, jk ) ) / 6.0
- !$mnh_end_do()
-#endif
!
#ifndef MNH_OPENACC
-CALL MPPDB_CHECK(PSRC,"PPM_01_Y: PSRC")
-CALL MPPDB_CHECK(ZDMQ,"PPM_01_Y: ZDMQ")
-CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
CALL GET_HALO(ZQL0, HNAME='ZQL0')
#else
!$acc end kernels
-CALL MPPDB_CHECK(PSRC,"PPM_01_Y: PSRC")
-CALL MPPDB_CHECK(ZDMQ,"PPM_01_Y: ZDMQ")
-CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
- CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
+ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='ZQL0')
!$acc kernels
#endif
!
@@ -1279,8 +1414,8 @@ CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
CALL GET_HALO(ZQR0, HNAME='ZQR0')
#else
!$acc end kernels
- CALL GET_HALO_D(ZQR0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQR0')
-!$acc kernels present_cr(ZDQ,ZQR0,ZQL0,ZQ60,ZQL,ZQR,ZQ6)
+ CALL GET_HALO_D(ZQR0,HDIR="01_Y", HNAME='ZQR0')
+!$acc kernels
#endif
!
! NORTH BOUND
@@ -1353,8 +1488,6 @@ CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
!
!$mnh_end_do()
-!$acc end kernels
-!$acc kernels
#endif
!
! and finally calculate fluxes for the advection
@@ -1369,7 +1502,7 @@ CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
#else
!$acc end kernels
- CALL GET_HALO_D(ZFPOS,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZFPOS')
+ CALL GET_HALO_D(ZFPOS,HDIR="01_Y", HNAME='ZFPOS')
!$acc kernels
#endif
!
@@ -1386,7 +1519,7 @@ CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
#else
!$acc end kernels
- CALL GET_HALO_D(ZFNEG,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZFNEG')
+ CALL GET_HALO_D(ZFNEG,HDIR="01_Y", HNAME='ZFNEG')
#endif
!
! advect the actual field in Y direction by V*dt
@@ -1410,7 +1543,7 @@ CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
#ifndef MNH_OPENACC
CALL GET_HALO(PR, HNAME='PR')
#else
- CALL GET_HALO_D(PR,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::PR')
+ CALL GET_HALO_D(PR,HDIR="01_Y", HNAME='PR')
#endif
!
!* 2.2 NON-CYCLIC BOUNDARY CONDITIONS IN THE Y DIRECTION
@@ -1419,28 +1552,28 @@ CALL MPPDB_CHECK(ZQL0,"PPM_01_Y: ZQL0")
CASE('OPEN')
!
! calculate dmq
- CALL DIF2Y( PSRC, ZDMQ )
+#ifndef MNH_OPENACC
+ ZDMQ = DIF2Y(PSRC)
+#else
+ CALL DIF2Y_DEVICE(ZDMQ,PSRC)
+#endif
+!$acc kernels present_cr(ZDMQ,PSRC)
! overwrite the values on the boundary to get second order difference
! for qL and qR at the boundary
!
! SOUTH BOUND
!
IF (GSOUTH) THEN
-!$acc kernels
ZDMQ(IIW:IIA,IJB-1,:) = -ZDMQ(IIW:IIA,IJB,:)
-!$acc end kernels
ENDIF
!
! NORTH BOUND
!
IF (GNORTH) THEN
-!$acc kernels
ZDMQ(IIW:IIA,IJE+1,:) = -ZDMQ(IIW:IIA,IJE,:)
-!$acc end kernels
ENDIF
!
! monotonize the difference followinq eq. 5 in Lin94
-!$acc kernels present_cr(ZDMQ,PSRC)
!$mnh_do_concurrent( ji = iiw:iia , jj = ijb:ije , jk = 1:iku )
ZDMQ(ji, jj, jk ) = SIGN( &
MIN( ABS( ZDMQ(ji, jj, jk ) ), &
@@ -1465,7 +1598,7 @@ CASE('OPEN')
CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
#else
!$acc end kernels
- CALL GET_HALO_D(ZDMQ,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZDMQ')
+ CALL GET_HALO_D(ZDMQ,HDIR="01_Y", HNAME='ZDMQ')
!$acc kernels present_cr(ZQL0,PSRC,ZDMQ)
#endif
!
@@ -1479,29 +1612,24 @@ CASE('OPEN')
CALL GET_HALO(ZQL0, HNAME='ZQL0')
#else
!$acc end kernels
-CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
+CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='ZQL0')
+!$acc kernels present_cr(ZDQ,ZQR0,ZQL0,ZQ60,PSRC,ZQL,ZQR,ZQ6,ZFPOS,PCR)
#endif
!
! SOUTH BOUND
!
IF (GSOUTH) THEN
-!$acc kernels
ZQL0(IIW:IIA,IJB-1,:) = ZQL0(IIW:IIA,IJB,:)
-!$acc end kernels
ENDIF
!
-!$acc kernels present_cr(ZQR0,ZQL0)
!$mnh_do_concurrent( ji = iiw:iia , jj = ijb - 1:ije , jk = 1:iku )
ZQR0(ji, jj, jk ) = ZQL0(ji, jj+1, jk )
!$mnh_end_do()
-!$acc end kernels
!
! NORTH BOUND
!
IF (GNORTH) THEN
-!$acc kernels
ZQR0(IIW:IIA,IJE+1,:) = ZQR0(IIW:IIA,IJE,:)
-!$acc end kernels
ENDIF
#ifndef MNH_OPENACC
!
@@ -1537,7 +1665,6 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
ZDQ(IIW:IIA,:,:) = ZQR(IIW:IIA,:,:) - ZQL(IIW:IIA,:,:)
!
#else
-!$acc kernels present_cr(ZDQ,ZQR0,ZQL0,ZQ60,PSRC,ZQL,ZQR,ZQ6)
!$mnh_do_concurrent( I=1:IIU , J=IJS:IJN , K=IKB:IKE )
!
! determine initial coefficients of the parabolae
@@ -1572,7 +1699,6 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
!
!$mnh_end_do()
-!$acc end kernels
#endif
!
! and finally calculate fluxes for the advection
@@ -1580,7 +1706,6 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
!!$ ZFPOS(:,IJB+1:IJE+1,:) = ZQR(:,IJB:IJE,:) - 0.5*PCR(:,IJB+1:IJE+1,:) * &
!!$ (ZDQ(:,IJB:IJE,:) - (1.0 - 2.0*PCR(:,IJB+1:IJE+1,:)/3.0) &
!!$ * ZQ6(:,IJB:IJE,:))
-!$acc kernels present_cr(ZFPOS,ZQR,PCR,ZDQ,ZQ6)
!$mnh_do_concurrent( ji = iiw:iia , jj = ijb:ije + 1 , jk = 1:iku )
ZFPOS(ji, jj, jk ) = ZQR(ji, jj-1, jk ) - 0.5 * PCR(ji, jj, jk ) &
* ( ZDQ(ji, jj-1, jk ) - ( 1.0 - 2.0 * PCR(ji, jj, jk ) / 3.0 ) * ZQ6(ji, jj-1, jk ) )
@@ -1590,7 +1715,8 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
#else
!$acc end kernels
- CALL GET_HALO_D(ZFPOS,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZFPOS')
+ CALL GET_HALO_D(ZFPOS,HDIR="01_Y", HNAME='ZFPOS')
+!$acc kernels present_cr(ZFPOS,ZQR,ZFNEG,ZQL,PCR,ZDQ,ZQ6)
#endif
!
!
@@ -1599,10 +1725,8 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
! SOUTH BOUND
!
IF (GSOUTH) THEN
-!$acc kernels present_cr(ZFPOS,ZQR)
ZFPOS(IIW:IIA,IJB,:) = (PSRC(IIW:IIA,IJB-1,:) - ZQR(IIW:IIA,IJB-1,:))*PCR(IIW:IIA,IJB,:) + &
ZQR(IIW:IIA,IJB-1,:)
-!$acc end kernels
ENDIF
!
! PPOSX(:,IJB-1,:) is not important for the calc of advection so
@@ -1612,7 +1736,6 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
!!$ ZFNEG(:,IJB-1:IJE,:) = ZQL(:,IJB-1:IJE,:) - 0.5*PCR(:,IJB-1:IJE,:) * &
!!$ ( ZDQ(:,IJB-1:IJE,:) + (1.0 + 2.0*PCR(:,IJB-1:IJE,:)/3.0) * &
!!$ ZQ6(:,IJB-1:IJE,:) )
-!$acc kernels present_cr(ZFNEG,ZQL,PCR,ZDQ,ZQ6)
!$mnh_do_concurrent( ji = iiw:iia , jj = 1:iju , jk = 1:iku )
ZFNEG(ji, jj, jk ) = ZQL(ji, jj, jk ) - 0.5 * PCR(ji, jj, jk ) &
* ( ZDQ(ji, jj, jk ) + ( 1.0 + 2.0 * PCR(ji, jj, jk ) / 3.0 ) * ZQ6(ji, jj, jk ) )
@@ -1622,7 +1745,8 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
#else
!$acc end kernels
- CALL GET_HALO_D(ZFNEG,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZFNEG')
+ CALL GET_HALO_D(ZFNEG,HDIR="01_Y", HNAME='ZFNEG')
+!$acc kernels present_cr(ZFPOS,ZFNEG,ZQR)
#endif
!
! advection flux at open boundary when u(IJE+1) < 0
@@ -1630,10 +1754,8 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
! NORTH BOUND
!
IF (GNORTH) THEN
-!$acc kernels present_cr(ZFNEG,ZQR)
ZFNEG(IIW:IIA,IJE+1,:) = (ZQR(IIW:IIA,IJE,:)-PSRC(IIW:IIA,IJE+1,:))*PCR(IIW:IIA,IJE+1,:) + &
ZQR(IIW:IIA,IJE,:)
-!$acc end kernels
ENDIF
#ifndef MNH_OPENACC
!
@@ -1643,6 +1765,7 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
!
#else
+!$acc end kernels
CALL MYM_DEVICE(PRHO,ZQL)
!$acc kernels present_cr(ZQR,PCR,ZQL,ZFPOS,ZFNEG)
!$mnh_do_concurrent( I=1:IIU , J=IJS:IJN , K=IKB:IKE )
@@ -1659,7 +1782,7 @@ CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::ZQL0')
#ifndef MNH_OPENACC
CALL GET_HALO(PR, HNAME='PR')
#else
- CALL GET_HALO_D(PR,HDIR="01_Y", HNAME='UPDATE_HALO_ll::GET_HALO::PR')
+ CALL GET_HALO_D(PR,HDIR="01_Y", HNAME='PR')
#endif
!
!
@@ -1678,18 +1801,80 @@ END IF
!$acc end data
-#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_01_Y' )
-#endif
-
+#ifndef MNH_OPENACC
CONTAINS
+#else
+END SUBROUTINE PPM_01_Y_D
+#endif
!
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
! ########################################################################
- SUBROUTINE DIF2Y( PQ, DQ )
+ FUNCTION DIF2Y(PQ) RESULT(DQ)
+! ########################################################################
+!!
+!!**** DIF2Y - leap-frog difference operator in Y direction
+!!
+!! Calculates the difference assuming periodic BC (CYCL).
+!!
+!! DQ(J) = 0.5 * (PQ(J+1) - PQ(J-1))
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! 18.3.2006. T. Maric - original version, works only for periodic boundary
+!! conditions and on one domain
+!! 04/2017 J.Escobar : initialize realistic value in all HALO pts
+!!
+!-------------------------------------------------------------------------------
+!
+!
+USE MODE_ll
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
+REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)) :: DQ
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IIB,IJB ! Begining useful area in x,y directions
+INTEGER :: IIE,IJE ! End useful area in x,y directions
+!
+!-------------------------------------------------------------------------------
+
+!$acc data present(PQ, DQ)
+!
+!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
+! -----------------------------
+!
+!!$CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+IIB=2 ; IIE = SIZE(PQ,1) -1
+IJB=2 ; IJE = SIZE(PQ,2) -1
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.0. COMPUTE THE DIFFERENCE
+! ----------------------
+!
+!$acc kernels
+DQ(:,IJB:IJE,:) = PQ(:,IJB+1:IJE+1,:) - PQ(:,IJB-1:IJE-1,:)
+DQ(:,IJB-1,:) = PQ(:,IJB,:) - PQ(:,IJE-1,:)
+DQ(:,IJE+1,:) = PQ(:,IJB+1,:) - PQ(:,IJE,:)
+DQ = 0.5 * DQ
+!$acc end kernels
+
+!$acc end data
+
+END FUNCTION DIF2Y
+!-------------------------------------------------------------------------------
+!
+! ########################################################################
+ SUBROUTINE DIF2Y_DEVICE(DQ,PQ)
! ########################################################################
!!
!!**** DIF2Y - leap-frog difference operator in Y direction
@@ -1715,8 +1900,8 @@ IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)), INTENT(OUT) :: DQ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
+REAL, DIMENSION(:,:,:) :: DQ
!
!* 0.2 Declarations of local variables :
!
@@ -1748,10 +1933,12 @@ DQ = 0.5 * DQ
!$acc end data
-END SUBROUTINE DIF2Y
+END SUBROUTINE DIF2Y_DEVICE
! #endif
!
#ifdef MNH_OPENACC
+! END SUBROUTINE PPM_01_Y_D
+
END SUBROUTINE PPM_01_Y
#else
END FUNCTION PPM_01_Y
@@ -1761,13 +1948,57 @@ END FUNCTION PPM_01_Y
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
+! ########################################################################
+!!$ FUNCTION PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) RESULT(PR)
SUBROUTINE PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
+! ########################################################################
+
+ USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+ USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+
+ IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR & ! Courant number
+ , PRHO ! density
+!
+! output source term
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+
+INTEGER :: IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG
+
+!$acc data present( PSRC, PCR, PRHO, PR )
+
+ CALL MNH_GET_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
+
+ CALL PPM_01_Z_D(IIU,IJU,IKU, KGRID, &
+ & PSRC, PCR, PRHO, PTSTEP, PR, &
+ & ZT3D(:,:,:,IZQL),ZT3D(:,:,:,IZQR),ZT3D(:,:,:,IZDQ),ZT3D(:,:,:,IZQ6), &
+ & ZT3D(:,:,:,IZDMQ),ZT3D(:,:,:,IZQL0),ZT3D(:,:,:,IZQR0), ZT3D(:,:,:,IZQ60), &
+ & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG) )
+
+ CALL MNH_REL_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
+
+!$acc end data
+
+CONTAINS
+!
+! ########################################################################
+ SUBROUTINE PPM_01_Z_D(IIU,IJU,IKU,KGRID, &
+ & PSRC, PCR, PRHO, PTSTEP, PR, &
+ & ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60,ZFPOS,ZFNEG)
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_01_Z - PPM_01 fully monotonic PPM advection scheme in Z direction
!! Colella notation
@@ -1779,33 +2010,33 @@ END FUNCTION PPM_01_Y
!!
!-------------------------------------------------------------------------------
!
-USE MODD_CONF
-USE MODD_PARAMETERS, ONLY: JPVEXT
-
USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-USE MODE_MPPDB
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+USE MODI_GET_HALO
#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
USE MODI_BITREP
#endif
#ifdef MNH_BITREP_OMP
USE MODI_BITREPZ
#endif
-
-USE MODI_GET_HALO
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
+!
+USE MODD_CONF
+USE MODD_PARAMETERS
+!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+USE MODE_MPPDB
!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
!
+#ifdef MNH_OPENACC
+integer, intent(in) :: iiu, iju, iku
+#endif
INTEGER, INTENT(IN) :: KGRID ! C grid localisation
!
#ifndef MNH_OPENACC
@@ -1822,16 +2053,16 @@ REAL, INTENT(IN) :: PTSTEP ! Time step
#ifndef MNH_OPENACC
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+REAL, DIMENSION(IIU,IJU,IKU), INTENT(OUT) :: PR
#endif
!
!* 0.2 Declarations of local variables :
!
+#ifndef MNH_OPENACC
INTEGER :: IIU, IJU, IKU
INTEGER:: IKB ! Begining useful area in x,y,z directions
INTEGER:: IKE ! End useful area in x,y,z directions
!
-#ifndef MNH_OPENACC
! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL,ZQR
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDQ,ZQ6
@@ -1844,15 +2075,17 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL0,ZQR0,ZQ60
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
#else
! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZQL, ZQR
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZDQ, ZQ6
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZDMQ
+REAL, DIMENSION(IIU,IJU,IKU) :: &
+ ZQL, ZQR, ZDQ, ZQ6, ZDMQ &
!
! extra variables for the initial guess of parabolae parameters
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZQL0,ZQR0,ZQ60
+ , ZQL0,ZQR0,ZQ60 &
!
! advection fluxes
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFPOS, ZFNEG
+ , ZFPOS, ZFNEG
+!
+INTEGER:: IKB ! Begining useful area in x,y,z directions
+INTEGER:: IKE ! End useful area in x,y,z directions
!
INTEGER :: I,J,K
#endif
@@ -1864,6 +2097,8 @@ integer :: ji, jj, jk
CALL SBR_FZ(PSRC(:,:,:))
#endif
!
+!$acc data present( PSRC, PCR, PRHO, PR, &
+!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
CALL MPPDB_CHECK(PCR, "PPM_01_Z beg:PCR")
@@ -1871,36 +2106,17 @@ IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
CALL MPPDB_CHECK(PSRC,"PPM_01_Z beg:PSRC")
END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_01_Z' )
-
-CALL MNH_MEM_GET( ZQL, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQR, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZDQ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQ6, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZDMQ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQL0, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQR0, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZQ60, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFNEG, IIU, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PR, &
-!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
!
IKB = 1 + JPVEXT
IKE = SIZE(PSRC,3) - JPVEXT
+#ifndef MNH_OPENACC
+iiu = size( PSRC, 1 )
+iju = size( PSRC, 2 )
+iku = size( PSRC, 3 )
+#endif
!$acc kernels present_cr(ZFPOS,ZFNEG,PSRC,PR,ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60)
!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = 1:iku )
@@ -1936,8 +2152,12 @@ ZFNEG(:,:,:) = PSRC(:,:,:)
! --------------------------------
!
! calculate dmq
- call DIF2Z( PSRC, ZDMQ )
-!$acc kernels present_cr(ZDMQ,PSRC)
+#ifndef MNH_OPENACC
+ZDMQ = DIF2Z(PSRC)
+#else
+CALL DIF2Z_DEVICE(ZDMQ,PSRC)
+#endif
+!$acc kernels present_cr(ZDMQ,PSRC,ZQR0,ZQL0,ZDQ,ZQ60,ZQL,ZQR,ZQ6,ZFPOS,ZFNEG,PCR)
!
! monotonize the difference followinq eq. 5 in Lin94
! use the periodic BC here, it doesn't matter for vertical (hopefully)
@@ -1949,22 +2169,16 @@ ZFNEG(:,:,:) = PSRC(:,:,:)
2.0 * ( - PSRC(ji, jj, jk ) + MAX( PSRC(ji, jj, jk-1 ), PSRC(ji, jj, jk ), PSRC(ji, jj, jk+1 ) ) ) ), &
ZDMQ(ji, jj, jk ) )
!$mnh_end_do()
-!$acc end kernels
-!$acc kernels present_cr(ZDMQ,PSRC)
ZDMQ(:,:,IKB-1) = &
SIGN( (MIN( ABS(ZDMQ(:,:,IKB-1)), 2.0*(PSRC(:,:,IKB-1) - &
MIN(PSRC(:,:,IKE-1),PSRC(:,:,IKB-1),PSRC(:,:,IKB))), &
2.0*(MAX(PSRC(:,:,IKE-1),PSRC(:,:,IKB-1),PSRC(:,:,IKB)) - &
PSRC(:,:,IKB-1)) )), ZDMQ(:,:,IKB-1) )
-!$acc end kernels
-!$acc kernels present_cr(ZDMQ,PSRC)
ZDMQ(:,:,IKE+1) = &
SIGN( (MIN( ABS(ZDMQ(:,:,IKE+1)), 2.0*(PSRC(:,:,IKE+1) - &
MIN(PSRC(:,:,IKE),PSRC(:,:,IKE+1),PSRC(:,:,IKB+1))), &
2.0*(MAX(PSRC(:,:,IKE),PSRC(:,:,IKE+1),PSRC(:,:,IKB+1)) - &
PSRC(:,:,IKE+1)) )), ZDMQ(:,:,IKE+1) )
-!$acc end kernels
-!$acc kernels present_cr(ZQL0,PSRC,ZDMQ)
!
! calculate qL and qR with the modified dmq
!
@@ -1973,8 +2187,6 @@ ZDMQ(:,:,IKE+1) = &
!$mnh_end_do()
ZQL0(:,:,IKB-1) = ZQL0(:,:,IKE)
!
-!$acc end kernels
-!$acc kernels present_cr(ZQR0,ZQL0,ZDQ,ZQ60,PSRC,ZQL,ZQR,ZQ6)
!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = ikb-1:ike )
ZQR0(ji, jj, jk ) = ZQL0(ji, jj, jk+1 )
!$mnh_end_do()
@@ -2064,18 +2276,14 @@ ZDQ = ZQR - ZQL
!
!$mnh_end_do()
#endif
-!$acc end kernels
!
! and finally calculate fluxes for the advection
!
-!$acc kernels present_cr(ZFPOS,ZQR,PCR,ZDQ,ZQ6)
-!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = ikb + 1: ike + 1 )
+!!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = ikb + 1: ike + 1 )
ZFPOS(ji, jj, jk ) = ZQR(ji, jj, jk-1 ) - 0.5 * PCR(ji, jj, jk ) &
* ( ZDQ(ji, jj, jk-1 ) - ( 1.0 - 2.0 * PCR(ji, jj, jk ) / 3.0) * ZQ6(ji, jj, jk-1 ) )
!$mnh_end_do()
-!$acc end kernels
!
-!$acc kernels present_cr(ZFPOS,ZQR)
! advection flux at open boundary when u(IKB) > 0
ZFPOS(:,:,IKB) = (PSRC(:,:,IKB-1) - ZQR(:,:,IKB-1))*PCR(:,:,IKB) + &
ZQR(:,:,IKB-1)
@@ -2084,15 +2292,11 @@ ZFPOS(:,:,IKB) = (PSRC(:,:,IKB-1) - ZQR(:,:,IKB-1))*PCR(:,:,IKB) + &
! we set it to 0
ZFPOS(:,:,IKB-1) = 0.0
!
-!$acc end kernels
-!$acc kernels present_cr(ZFNEG,ZQL,PCR,ZDQ,ZQ6)
!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = ikb - 1: ike )
ZFNEG(ji, jj, jk ) = ZQL(ji, jj, jk ) - 0.5 * PCR(ji, jj, jk ) &
* ( ZDQ(ji, jj, jk ) + ( 1.0 + 2.0 * PCR(ji, jj, jk ) / 3.0) * ZQ6(ji, jj, jk ) )
!$mnh_end_do()
!
-!$acc end kernels
-!$acc kernels present_cr(ZFNEG,ZQR)
! advection flux at open boundary when u(IKE+1) < 0
ZFNEG(:,:,IKE+1) = (ZQR(:,:,IKE)-PSRC(:,:,IKE+1))*PCR(:,:,IKE+1) + &
ZQR(:,:,IKE)
@@ -2103,7 +2307,7 @@ ZFNEG(:,:,IKE+1) = (ZQR(:,:,IKE)-PSRC(:,:,IKE+1))*PCR(:,:,IKE+1) + &
PR = DZF( PCR*MZM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
#else
-!$acc end kernels
+!$acc end kernels
CALL MZM_DEVICE(PRHO,ZQL)
!$acc kernels present_cr(ZQR,PCR,ZQL,ZFPOS,ZFNEG)
!$mnh_do_concurrent( ji = 1:iiu , jj = 1:iju , jk = 1:iku )
@@ -2115,7 +2319,7 @@ PR = DZF( PCR*MZM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
!$mnh_end_do()
!dzf(PR,ZQR)
!$acc end kernels
- CALL DZF_DEVICE( ZQR, PR )
+ CALL DZF_DEVICE(ZQR,PR)
#endif
!
#ifndef MNH_OPENACC
@@ -2137,20 +2341,82 @@ END IF
!$acc end data
-#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_01_Z' )
-#endif
-
+#ifndef MNH_OPENACC
CONTAINS
+#else
+END SUBROUTINE PPM_01_Z_D
+#endif
!
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
! ########################################################################
- SUBROUTINE DIF2Z( PQ, DQ )
+ FUNCTION DIF2Z(PQ) RESULT(DQ)
! ########################################################################
+!!
+!!**** DIF2Z - leap-frog difference operator in Z direction
+!!
+!! Calculates the difference assuming periodic BC (CYCL).
+!!
+!! DQ(K) = 0.5 * (PQ(K+1) - PQ(K-1))
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! 18.3.2006. T. Maric - original version
+!!
+!-------------------------------------------------------------------------------
+!
+!
+USE MODE_ll
+USE MODD_CONF
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
+REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)) :: DQ
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IKB ! Begining useful area in z directions
+INTEGER :: IKE ! End useful area in z directions
!
+!-------------------------------------------------------------------------------
+
+!$acc data present( PQ, DQ )
+!
+!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
+! -----------------------------
+!
+!CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+IKB = 1 + JPVEXT
+IKE = SIZE(PQ,3) - JPVEXT
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.0. COMPUTE THE DIFFERENCE
+! ----------------------
+!
+!$acc kernels
+DQ(:,:,IKB:IKE) = PQ(:,:,IKB+1:IKE+1) - PQ(:,:,IKB-1:IKE-1)
+DQ(:,:,IKB-1) = -DQ(:,:,IKB)
+DQ(:,:,IKE+1) = -DQ(:,:,IKE)
+DQ = 0.5 * DQ
+!$acc end kernels
+
+!$acc end data
+
+END FUNCTION DIF2Z
+!-------------------------------------------------------------------------------
+!
+! ########################################################################
+ SUBROUTINE DIF2Z_DEVICE(DQ,PQ)
+! ########################################################################
+!!
!!**** DIF2Z - leap-frog difference operator in Z direction
!!
!! Calculates the difference assuming periodic BC (CYCL).
@@ -2174,9 +2440,8 @@ IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)), INTENT(OUT) :: DQ
-!REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)) :: DQ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
+REAL, DIMENSION(:,:,:) :: DQ
!
!* 0.2 Declarations of local variables :
!
@@ -2208,9 +2473,13 @@ DQ = 0.5 * DQ
!$acc end data
-END SUBROUTINE DIF2Z
+END SUBROUTINE DIF2Z_DEVICE
+! #endif
+!
#ifdef MNH_OPENACC
+! END SUBROUTINE PPM_01_Z_D
+!
END SUBROUTINE PPM_01_Z
#else
END FUNCTION PPM_01_Z
@@ -2220,14 +2489,59 @@ END FUNCTION PPM_01_Z
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
- SUBROUTINE PPM_S0_X( HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP, PR )
+! ########################################################################
+!!$ FUNCTION PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
+!!$ RESULT(PR)
+SUBROUTINE PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP , PR)
+
+ USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+ USE MODE_MNH_ZWORK, ONLY : ZPSRC_HALO2_WEST
+
+ IMPLICIT NONE
+ !
+ !* 0.1 Declarations of dummy arguments :
+ !
+ CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+ !
+ INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+ REAL, INTENT(IN) :: PTSTEP ! Time step
+ !
+ ! output source term
+ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+
+ INTEGER :: IZFPOS,IZFNEG,IZPHAT,IZRHO_MXM,IZCR_MXM,IZCR_DXF
+
+!$acc data present( PSRC, PCR, PRHO, PR )
+
+ CALL MNH_GET_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MXM,IZCR_MXM,IZCR_DXF)
+
+ CALL PPM_S0_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP , PR, &
+ & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG),ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRHO_MXM), &
+ & ZT3D(:,:,:,IZCR_MXM),ZT3D(:,:,:,IZCR_DXF),ZPSRC_HALO2_WEST )
+
+ CALL MNH_REL_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MXM,IZCR_MXM,IZCR_DXF)
+
+!$acc end data
+
+CONTAINS
+!
+! ########################################################################
+ SUBROUTINE PPM_S0_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP , PR &
+ & ,ZFPOS,ZPHAT,ZFNEG &
+ & ,ZRHO_MXM,ZCR_MXM,ZCR_DXF,ZPSRC_HALO2_WEST )
+
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_S0_X - PPM advection scheme in X direction in Skamarock 2006
!! notation - NO CONSTRAINTS
@@ -2245,10 +2559,6 @@ USE MODD_CONF
USE MODE_ll
#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-USE MODE_MPPDB
-#ifdef MNH_OPENACC
use mode_msg
#endif
@@ -2259,6 +2569,15 @@ USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
!
+#ifdef MNH_OPENACC
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODE_MNH_ZWORK, ONLY : IIB,IIE, IIU,IJU,IKU , IJS,IJN, GWEST,GEAST
+!
+USE MODD_IO, ONLY : GSMONOPROC
+#endif
+USE MODE_MPPDB
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -2282,14 +2601,14 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
!
!* 0.2 Declarations of local variables :
!
+#ifndef MNH_OPENACC
INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE ! End useful area in x,y,z directions
INTEGER :: IJS,IJN
-integer :: iiu, iju, iku
+INTEGER :: IIU, IJU, IKU
!
LOGICAL :: GWEST, GEAST
-#ifndef MNH_OPENACC
! advection fluxes
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
!
@@ -2299,21 +2618,30 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT
REAL, DIMENSION(SIZE(PCR,2),SIZE(PCR,3)) :: ZPSRC_HALO2_WEST
#else
! advection fluxes
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFPOS, ZFNEG
+REAL, DIMENSION(:,:,:) :: ZFPOS, ZFNEG
!
! variable at cell edges
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPHAT
+REAL, DIMENSION(:,:,:) :: ZPHAT
!
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZCR_DXF, ZCR_MXM, ZRHO_MXM
+REAL, DIMENSION(:,:,:) :: ZRHO_MXM, ZCR_MXM , ZCR_DXF
INTEGER :: I,J,K
!
-REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZPSRC_HALO2_WEST
+LOGICAL, SAVE :: GFIRST_CALL_PPM_S0_X = .TRUE.
+REAL, DIMENSION(:,:) :: ZPSRC_HALO2_WEST
#endif
+#ifndef MNH_OPENACC
TYPE(HALO2LIST_ll), POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
-
+#else
+TYPE(HALO2LIST_ll), SAVE , POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
+!
+REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZWEST
+#endif
!-------------------------------------------------------------------------------
+!$acc data present( PSRC, PCR, PRHO, PR , &
+!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MXM, ZCR_MXM, ZCR_DXF, ZPSRC_HALO2_WEST )
+
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
CALL MPPDB_CHECK(PCR, "PPM_S0_X beg:PCR")
@@ -2321,31 +2649,11 @@ IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
CALL MPPDB_CHECK(PSRC,"PPM_S0_X beg:PSRC")
END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_S0_X' )
-
-CALL MNH_MEM_GET( ZFPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFNEG, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZPHAT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZCR_DXF, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZCR_MXM, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRHO_MXM, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZPSRC_HALO2_WEST, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PR , &
-!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MXM, ZCR_MXM, ZCR_DXF, ZPSRC_HALO2_WEST )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
!
+#ifndef MNH_OPENACC
CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
IJS=IJB
IJN=IJE
@@ -2355,13 +2663,30 @@ IJN=IJE
GWEST = LWEST_ll()
GEAST = LEAST_ll()
!
+IIU = SIZE( PSRC, 1 )
+IJU = SIZE( PSRC, 2 )
+IKU = SIZE( PSRC, 3 )
+#endif
+!
!BEG JUAN PPM_LL
!
!* initialise & update halo & halo2 for PSRC
!
+#ifndef MNH_OPENACC
CALL GET_HALO2(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
ZPSRC_HALO2_WEST(:,:) = TZ_PSRC_HALO2_ll%HALO2%WEST(:,:)
-!$acc update device (ZPSRC_HALO2_WEST)
+#else
+IF (GFIRST_CALL_PPM_S0_X) THEN
+ GFIRST_CALL_PPM_S0_X = .FALSE.
+ NULLIFY(TZ_PSRC_HALO2_ll)
+ CALL INIT_HALO2_ll(TZ_PSRC_HALO2_ll,1,IIU,IJU,IKU,'PPM_S0_X')
+END IF
+CALL GET_HALO2_DF(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
+ZWEST => TZ_PSRC_HALO2_ll%HALO2%WEST
+!$acc kernels
+ZPSRC_HALO2_WEST(:,:) = ZWEST(:,:)
+!$acc end kernels
+#endif
!$acc kernels
ZPHAT=PSRC
ZFPOS=PSRC
@@ -2452,6 +2777,7 @@ CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
CALL GET_HALO(PR, HNAME='PR') ! JUAN
!
CASE ('OPEN')
+!$acc kernels
!
!!$ ZPHAT(IIB,:,:) = 0.5*(PSRC(IIB-1,:,:) + PSRC(IIB,:,:))
!!$ ZPHAT(IIB-1,:,:) = ZPHAT(IIB,:,:) ! not used
@@ -2460,13 +2786,12 @@ CASE ('OPEN')
! WEST BOUND
!
IF (.NOT. GWEST) THEN
-!$acc kernels
ZPHAT(IIB ,IJS:IJN,:) = ( 7.0 * &
( PSRC(IIB ,IJS:IJN,:) + PSRC(IIB-1,IJS:IJN,:) ) - &
( PSRC(IIB+1,IJS:IJN,:) + ZPSRC_HALO2_WEST(IJS:IJN,:) ) ) / 12.0
! <=> WEST BOUND ( PSRC(IIB+1,IJS:IJN,:) + PSRC(IIB-2,IJS:IJN,:) ) ) / 12.0
-!$acc end kernels
ENDIF
+!$acc end kernels
!
! update ZPHAT HALO before next/further utilisation
!
@@ -2513,17 +2838,15 @@ ENDIF
! acc update device(ZFPOS)
#endif
!
+!$acc kernels present_cr(ZFPOS,ZFNEG,ZPHAT)
! positive flux on the WEST boundary
IF (GWEST) THEN
-!$acc kernels present_cr(ZFPOS,ZPHAT)
ZFPOS(IIB,IJS:IJN,:) = (PSRC(IIB-1,IJS:IJN,:) - ZPHAT(IIB,IJS:IJN,:))*PCR(IIB,IJS:IJN,:) + &
ZPHAT(IIB,IJS:IJN,:)
! this is not used
ZFPOS(IIB-1,IJS:IJN,:) = 0.0
-!$acc end kernels
ENDIF
!
-!$acc kernels present_cr(ZFNEG,ZPHAT)
! negative fluxes
!!$ ZFNEG(IIB:IIE,:,:) = ZPHAT(IIB:IIE,:,:) + &
!!$ PCR(IIB:IIE,:,:)*(ZPHAT(IIB:IIE,:,:) - PSRC(IIB:IIE,:,:)) + &
@@ -2543,8 +2866,8 @@ ENDIF
! acc update device(ZFNEG)
#endif
!
+!$acc kernels present_cr(ZFPOS,ZFNEG,ZPHAT)
IF (GEAST) THEN
-!$acc kernels present_cr(ZFNEG,ZPHAT)
!
! in OPEN case PCR(IIB-1) is not used, so we also set ZFNEG(IIB-1) = 0
!
@@ -2555,7 +2878,6 @@ ENDIF
!
ZFNEG(IIE+1,IJS:IJN,:) = (ZPHAT(IIE+1,IJS:IJN,:) - PSRC(IIE+1,IJS:IJN,:))*PCR(IIE+1,IJS:IJN,:) + &
ZPHAT(IIE+1,IJS:IJN,:)
-!$acc end kernels
ENDIF
!
! calculate the advection
@@ -2565,6 +2887,7 @@ ENDIF
DXF( PCR*MXM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
#else
+!$acc end kernels
CALL MXM_DEVICE(PRHO,ZRHO_MXM)
!$acc kernels present_cr(ZCR_MXM,ZRHO_MXM,ZFPOS,ZFNEG)
ZCR_MXM = PCR * ZRHO_MXM * ( ZFPOS*(0.5+SIGN(0.5,PCR)) + ZFNEG*(0.5-SIGN(0.5,PCR)) )
@@ -2572,31 +2895,27 @@ ENDIF
CALL DXF_DEVICE(ZCR_MXM,ZCR_DXF)
!$acc kernels
PR = PSRC * PRHO - ZCR_DXF
-!$acc end kernels
#endif
!
! in OPEN case fix boundary conditions
!
IF (GWEST) THEN
-!$acc kernels
WHERE ( PCR(IIB,IJS:IJN,:) <= 0. ) ! OUTFLOW condition
PR(IIB-1,IJS:IJN,:) = 2.*PR(IIB,IJS:IJN,:) - PR(IIB+1,IJS:IJN,:)
ELSEWHERE
PR(IIB-1,IJS:IJN,:) = PR(IIB,IJS:IJN,:)
END WHERE
-!$acc end kernels
ENDIF
!
IF (GEAST) THEN
-!$acc kernels
WHERE ( PCR(IIE,IJS:IJN,:) >= 0. ) ! OUTFLOW condition
PR(IIE+1,IJS:IJN,:) = 2.*PR(IIE,IJS:IJN,:) - PR(IIE-1,IJS:IJN,:)
ELSEWHERE
PR(IIE+1,IJS:IJN,:) = PR(IIE,IJS:IJN,:)
END WHERE
-!$acc end kernels
ENDIF
!
+!$acc end kernels
!
!
END SELECT
@@ -2604,11 +2923,12 @@ END SELECT
#ifndef MNH_OPENACC
CALL GET_HALO(PR, HNAME='PR')
#else
-! CALL GET_HALO_D(PR, HDIR="S0_X", HNAME='PR')
-CALL GET_HALO_D(PR, HDIR="S0_X", HNAME='UPDATE_HALO_ll::GET_HALO::PR')
+CALL GET_HALO_D(PR, HDIR="S0_X", HNAME='PR')
#endif
!-------------------------------------------------------------------------------
+#ifndef MNH_OPENACC
CALL DEL_HALO2_ll(TZ_PSRC_HALO2_ll)
+#endif
IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
@@ -2620,11 +2940,8 @@ END IF
!$acc end data
#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_S0_X' )
-#endif
+END SUBROUTINE PPM_S0_X_D
-#ifdef MNH_OPENACC
END SUBROUTINE PPM_S0_X
#else
END FUNCTION PPM_S0_X
@@ -2633,14 +2950,59 @@ END FUNCTION PPM_S0_X
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
+! ########################################################################
+!!$ FUNCTION PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
+!!$ RESULT(PR)
SUBROUTINE PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
+
+ USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+ USE MODE_MNH_ZWORK, ONLY : ZPSRC_HALO2_SOUTH
+
+ IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+! output source term
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
+
+ INTEGER :: IZFPOS,IZPHAT,IZFNEG,IZRHO_MYM,IZCR_MYM,IZCR_DYF
+
+!$acc data present( PSRC, PCR, PRHO, PR )
+
+ CALL MNH_GET_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MYM,IZCR_MYM,IZCR_DYF)
+
+ CALL PPM_S0_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP , PR, &
+ & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG),ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRHO_MYM), &
+ & ZT3D(:,:,:,IZCR_MYM),ZT3D(:,:,:,IZCR_DYF),ZPSRC_HALO2_SOUTH )
+
+ CALL MNH_REL_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MYM,IZCR_MYM,IZCR_DYF)
+
+!$acc end data
+
+CONTAINS
+!
+! ########################################################################
+ SUBROUTINE PPM_S0_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP , PR &
+ & ,ZFPOS,ZPHAT,ZFNEG &
+ & ,ZRHO_MYM,ZCR_MYM,ZCR_DYF,ZPSRC_HALO2_SOUTH )
+
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_S0_Y - PPM advection scheme in Y direction in Skamarock 2006
!! notation - NO CONSTRAINTS
@@ -2656,10 +3018,6 @@ USE MODD_CONF
USE MODE_ll
#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-USE MODE_MPPDB
-#ifdef MNH_OPENACC
use mode_msg
#endif
@@ -2670,6 +3028,16 @@ USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
!
+#ifdef MNH_OPENACC
+USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODE_MNH_ZWORK, ONLY : IJB,IJE, IIU,IJU,IKU , IIW,IIA, GSOUTH , GNORTH
+!
+USE MODD_IO, ONLY : GSMONOPROC
+#endif
+USE MODE_MPPDB
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -2693,14 +3061,15 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
!
!* 0.2 Declarations of local variables :
!
+#ifndef MNH_OPENACC
INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE ! End useful area in x,y,z directions
+INTEGER :: IJS,IJN
INTEGER :: IIW,IIA
INTEGER :: IIU, IJU, IKU
!
LOGICAL :: GNORTH, GSOUTH
!
-#ifndef MNH_OPENACC
! advection fluxes
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
!
@@ -2712,24 +3081,36 @@ TYPE(HALO2LIST_ll), POINTER :: TZ_PHAT_HALO2_ll ! halo2 for ZPHAT
!
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,3)) :: ZPSRC_HALO2_SOUTH
#else
+!
! advection fluxes
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFPOS, ZFNEG
+REAL, DIMENSION(:,:,:) :: ZFPOS, ZFNEG
!
! variable at cell edges
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPHAT
+REAL, DIMENSION(:,:,:) :: ZPHAT
!
+#ifndef MNH_OPENACC
TYPE(HALO2LIST_ll), POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
+#else
+TYPE(HALO2LIST_ll), SAVE ,POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
+
+REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZSOUTH
+#endif
+
TYPE(HALO2LIST_ll), POINTER :: TZ_PHAT_HALO2_ll ! halo2 for ZPHAT
!
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZCR_DYF, ZCR_MYM, ZRHO_MYM
+REAL, DIMENSION(:,:,:) :: ZRHO_MYM , ZCR_MYM , ZCR_DYF
!
INTEGER :: I,J,K
!
-REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZPSRC_HALO2_SOUTH
+LOGICAL, SAVE :: GFIRST_CALL_PPM_S0_Y = .TRUE.
+REAL, DIMENSION(:,:) :: ZPSRC_HALO2_SOUTH
#endif
!
!-------------------------------------------------------------------------------
+!$acc data present( PSRC, PCR, PRHO, PR , &
+!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MYM, ZCR_MYM, ZCR_DYF, ZPSRC_HALO2_SOUTH )
+
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
CALL MPPDB_CHECK(PCR, "PPM_S0_Y beg:PCR")
@@ -2737,31 +3118,11 @@ IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
CALL MPPDB_CHECK(PSRC,"PPM_S0_Y beg:PSRC")
END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_S0_Y' )
-
-CALL MNH_MEM_GET( ZFPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFNEG, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZPHAT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZCR_DYF, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZCR_MYM, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRHO_MYM, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZPSRC_HALO2_SOUTH, IIU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PR , &
-!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MYM, ZCR_MYM, ZCR_DYF, ZPSRC_HALO2_SOUTH )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
!
+#ifndef MNH_OPENACC
CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
IIW=IIB
IIA=IIE
@@ -2771,6 +3132,11 @@ IIA=IIE
GNORTH = LNORTH_ll()
GSOUTH = LSOUTH_ll()
!
+IIU = SIZE( PSRC, 1 )
+IJU = SIZE( PSRC, 2 )
+IKU = SIZE( PSRC, 3 )
+#endif
+!
!-------------------------------------------------------------------------------
!
IF ( L2D ) THEN
@@ -2782,10 +3148,22 @@ IF ( L2D ) THEN
CALL MPPDB_CHECK(PR,"PPM_S0_Y end:PR")
! RETURN
ELSE !not L2D
- !
+ !
+#ifndef MNH_OPENACC
CALL GET_HALO2(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
ZPSRC_HALO2_SOUTH(:,:) = TZ_PSRC_HALO2_ll%HALO2%SOUTH(:,:)
-!$acc update device (ZPSRC_HALO2_SOUTH)
+#else
+IF (GFIRST_CALL_PPM_S0_Y) THEN
+ GFIRST_CALL_PPM_S0_Y = .FALSE.
+ NULLIFY(TZ_PSRC_HALO2_ll)
+ CALL INIT_HALO2_ll(TZ_PSRC_HALO2_ll,1,IIU,IJU,IKU,'PPM_S0_Y')
+END IF
+CALL GET_HALO2_DF(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
+ZSOUTH => TZ_PSRC_HALO2_ll%HALO2%SOUTH(:,:)
+!$acc kernels
+ZPSRC_HALO2_SOUTH(:,:) = ZSOUTH(:,:)
+!$acc end kernels
+#endif
!
! Initialize with relalistic value all work array
!
@@ -2870,6 +3248,7 @@ CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
#endif
!
CASE ('OPEN')
+!$acc kernels
!
!!$ ZPHAT(:,IJB,:) = 0.5*(PSRC(:,IJB-1,:) + PSRC(:,IJB,:))
!!$ ZPHAT(:,IJB-1,:) = ZPHAT(:,IJB,:) ! not used
@@ -2879,16 +3258,15 @@ CASE ('OPEN')
! SOUTH BOUND
!
IF ( .NOT. GSOUTH) THEN
-!$acc kernels
ZPHAT(IIW:IIA,IJB ,:) = (7.0 * &
(PSRC(IIW:IIA,IJB ,:) + PSRC(IIW:IIA,IJB-1,:)) - &
(PSRC(IIW:IIA,IJB+1,:) + ZPSRC_HALO2_SOUTH(IIW:IIA,:) )) / 12.0
! (PSRC(IIW:IIA,IJB+1,:) + TZ_PSRC_HALO2_ll%HALO2%SOUTH(IIW:IIA,:) )) / 12.0
! <=> SOUTH BOUND (PSRC(IIW:IIA,IJB+1,:) + PSRC(IIW:IIA,IJB-2,:) )) / 12.0
-!$acc end kernels
ENDIF
!
!TEMPO_JUAN
+!$acc end kernels
!
#ifndef MNH_OPENACC
!PW: a remettre? CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
@@ -2898,19 +3276,16 @@ CASE ('OPEN')
! acc update device(ZPHAT)
#endif
!
+!$acc kernels present_cr(ZFPOS,ZPHAT)
IF (GSOUTH) THEN
-!$acc kernels
ZPHAT(IIW:IIA,IJB ,:) = 0.5*(PSRC(IIW:IIA,IJB-1,:) + PSRC(IIW:IIA,IJB,:))
ZPHAT(IIW:IIA,IJB-1,:) = ZPHAT(IIW:IIA,IJB,:)
-!$acc end kernels
ENDIF
!
! NORTH BOUND
!
IF (GNORTH) THEN
-!$acc kernels present_cr(ZPHAT)
ZPHAT(IIW:IIA,IJE+1,:) = 0.5*(PSRC(IIW:IIA,IJE,:) + PSRC(IIW:IIA,IJE+1,:))
-!$acc end kernels
ENDIF
!
!
@@ -2924,7 +3299,6 @@ CASE ('OPEN')
!!$ PCR(:,IJB+1:IJE+1,:)*(ZPHAT(:,IJB+1:IJE+1,:) - PSRC(:,IJB:IJE,:)) - &
!!$ PCR(:,IJB+1:IJE+1,:)*(1.0 - PCR(:,IJB+1:IJE+1,:)) * &
!!$ (ZPHAT(:,IJB:IJE,:) - 2.0*PSRC(:,IJB:IJE,:) + ZPHAT(:,IJB+1:IJE+1,:))
-!$acc kernels present_cr(ZFPOS,ZPHAT)
ZFPOS(IIW:IIA,IJB:IJE+1,:) = ZPHAT(IIW:IIA,IJB:IJE+1,:) - &
PCR(IIW:IIA,IJB:IJE+1,:)*( ZPHAT(IIW:IIA,IJB:IJE+1,:) - PSRC(IIW:IIA,IJB-1:IJE ,:) ) - &
PCR(IIW:IIA,IJB:IJE+1,:)*( 1.0 - PCR(IIW:IIA,IJB :IJE+1,:) ) * &
@@ -2939,15 +3313,14 @@ CASE ('OPEN')
! acc update device(ZFPOS)
#endif
!
+!$acc kernels present_cr(ZFPOS,ZFNEG,ZPHAT)
! positive flux on the SOUTH boundary
IF (GSOUTH) THEN
-!$acc kernels present_cr(ZFPOS,ZPHAT)
ZFPOS(IIW:IIA,IJB,:) = (PSRC(IIW:IIA,IJB-1,:) - ZPHAT(IIW:IIA,IJB,:))*PCR(IIW:IIA,IJB,:) + &
ZPHAT(IIW:IIA,IJB,:)
!
! this is not used
ZFPOS(IIW:IIA,IJB-1,:) = 0.0
-!$acc end kernels
ENDIF
!
! negative fluxes
@@ -2955,7 +3328,6 @@ CASE ('OPEN')
!!$ PCR(:,IJB:IJE,:)*(ZPHAT(:,IJB:IJE,:) - PSRC(:,IJB:IJE,:)) + &
!!$ PCR(:,IJB:IJE,:)*(1.0 + PCR(:,IJB:IJE,:)) * &
!!$ (ZPHAT(:,IJB:IJE,:) - 2.0*PSRC(:,IJB:IJE,:) +ZPHAT(:,IJB+1:IJE+1,:))
-!$acc kernels present_cr(ZFNEG,ZPHAT)
ZFNEG(IIW:IIA,IJB-1:IJE,:) = ZPHAT(IIW:IIA,IJB-1:IJE,:) + &
PCR(IIW:IIA,IJB-1:IJE,:)*(ZPHAT(IIW:IIA,IJB-1:IJE,:) - PSRC(IIW:IIA,IJB-1:IJE,:)) + &
PCR(IIW:IIA,IJB-1:IJE,:)*(1.0 + PCR(IIW:IIA,IJB-1:IJE,:)) * &
@@ -2970,15 +3342,14 @@ CASE ('OPEN')
! acc update device(ZFNEG)
#endif
!
- IF (GNORTH) THEN
!$acc kernels present_cr(ZFNEG,ZPHAT)
+ IF (GNORTH) THEN
! this is not used
ZFNEG(IIW:IIA,IJB-1,:) = 0.0
!
! negative flux on the NORTH boundary
ZFNEG(IIW:IIA,IJE+1,:) = (ZPHAT(IIW:IIA,IJE+1,:) - PSRC(IIW:IIA,IJE+1,:))*PCR(IIW:IIA,IJE+1,:) + &
ZPHAT(IIW:IIA,IJE+1,:)
-!$acc end kernels
ENDIF
!
! calculate the advection
@@ -2988,6 +3359,7 @@ CASE ('OPEN')
DYF( PCR*MYM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
#else
+!$acc end kernels
CALL MYM_DEVICE(PRHO,ZRHO_MYM)
!$acc kernels present_cr(ZCR_MYM,ZRHO_MYM,ZFPOS,ZFNEG)
ZCR_MYM = PCR * ZRHO_MYM * ( ZFPOS(:,:,:)*(0.5+SIGN(0.5,PCR)) + ZFNEG*(0.5-SIGN(0.5,PCR)) )
@@ -2995,42 +3367,40 @@ CASE ('OPEN')
CALL DYF_DEVICE(ZCR_MYM,ZCR_DYF)
!$acc kernels
PR = PSRC * PRHO - ZCR_DYF
-!$acc end kernels
#endif
!
! in OPEN case fix boundary conditions
!
IF (GSOUTH) THEN
-!$acc kernels
WHERE ( PCR(IIW:IIA,IJB,:) <= 0. ) ! OUTFLOW condition
PR(IIW:IIA,IJB-1,:) = 1.0 * 2.*PR(IIW:IIA,IJB,:) - PR(IIW:IIA,IJB+1,:)
ELSEWHERE
PR(IIW:IIA,IJB-1,:) = PR(IIW:IIA,IJB,:)
END WHERE
-!$acc end kernels
ENDIF
!
IF (GNORTH) THEN
-!$acc kernels
WHERE ( PCR(IIW:IIA,IJE,:) >= 0. ) ! OUTFLOW condition
PR(IIW:IIA,IJE+1,:) = 1.0 * 2.*PR(IIW:IIA,IJE,:) - PR(IIW:IIA,IJE-1,:)
ELSEWHERE
PR(IIW:IIA,IJE+1,:) = PR(IIW:IIA,IJE,:)
END WHERE
-!$acc end kernels
ENDIF
!
+!$acc end kernels
+!
!
END SELECT
!
#ifndef MNH_OPENACC
CALL GET_HALO(PR, HNAME='PR')
#else
-! CALL GET_HALO_D(PR, HDIR="S0_Y", HNAME='PR')
-CALL GET_HALO_D(PR, HDIR="S0_Y", HNAME='UPDATE_HALO_ll::GET_HALO::PR')
+CALL GET_HALO_D(PR, HDIR="S0_Y", HNAME='PR')
#endif
!
+#ifndef MNH_OPENACC
CALL DEL_HALO2_ll(TZ_PSRC_HALO2_ll)
+#endif
!
IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
@@ -3043,11 +3413,8 @@ END IF !not L2D
!$acc end data
#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_S0_Y' )
-#endif
+END SUBROUTINE PPM_S0_Y_D
-#ifdef MNH_OPENACC
END SUBROUTINE PPM_S0_Y
#else
END FUNCTION PPM_S0_Y
@@ -3057,14 +3424,58 @@ END FUNCTION PPM_S0_Y
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
- SUBROUTINE PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
+! ########################################################################
+!!$ FUNCTION PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) &
+!!$ RESULT(PR)
+SUBROUTINE PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
+
+ USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+
+ IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+! output source term
+REAL, DIMENSION(:,:,:),INTENT(OUT):: PR
+
+
+ INTEGER :: IZFPOS,IZPHAT,IZFNEG,IZRHO_MZM,IZCR_MZM,IZCR_DZF
+
+!$acc data present ( PSRC, PCR, PRHO, PR )
+
+ CALL MNH_GET_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MZM,IZCR_MZM,IZCR_DZF)
+
+ CALL PPM_S0_Z_D(KGRID, PSRC, PCR, PRHO, PTSTEP , PR, &
+ & ZT3D(:,:,:,IZFPOS), ZT3D(:,:,:,IZFNEG), ZT3D(:,:,:,IZPHAT), &
+ & ZT3D(:,:,:,IZRHO_MZM),ZT3D(:,:,:,IZCR_MZM),ZT3D(:,:,:,IZCR_DZF) )
+
+ CALL MNH_REL_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MZM,IZCR_MZM,IZCR_DZF)
+
+!$acc end data
+
+CONTAINS
+!
+! ########################################################################
+SUBROUTINE PPM_S0_Z_D(KGRID, PSRC, PCR, PRHO, PTSTEP , PR &
+ & ,ZFPOS,ZFNEG,ZPHAT &
+ & ,ZRHO_MZM,ZCR_MZM,ZCR_DZF )
+
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) &
RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_S0_Z - PPM advection scheme in Z direction in Skamarock 2006
!! notation - NO CONSTRAINTS
@@ -3076,22 +3487,22 @@ END FUNCTION PPM_S0_Y
!!
!-------------------------------------------------------------------------------
!
-USE MODD_CONF
-USE MODD_PARAMETERS
-
USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-USE MODE_MPPDB
-
-USE MODI_GET_HALO
#ifndef MNH_OPENACC
USE MODI_SHUMAN
#else
USE MODI_SHUMAN_DEVICE
#endif
-
+USE MODI_GET_HALO
+!
+USE MODD_CONF
+USE MODD_PARAMETERS
+USE MODE_MPPDB
+!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK, ONLY : IKB,IKE, IKU
+#endif
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -3113,11 +3524,10 @@ REAL, DIMENSION(:,:,:),INTENT(OUT):: PR
!
!* 0.2 Declarations of local variables :
!
+#ifndef MNH_OPENACC
INTEGER:: IKB ! Begining useful area in x,y,z directions
INTEGER:: IKE ! End useful area in x,y,z directions
-INTEGER :: IIU, IJU, IKU
!
-#ifndef MNH_OPENACC
! advection fluxes
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
!
@@ -3125,48 +3535,33 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT
#else
! advection fluxes
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFPOS, ZFNEG
+REAL, DIMENSION(:,:,:),INTENT(OUT):: ZFPOS, ZFNEG &
!
-! interpolated variable at cell edges
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPHAT
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZCR_DZF, ZCR_MZM, ZRHO_MZM
-#endif
-!
-!-------------------------------------------------------------------------------
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S0_Z beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_S0_Z beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_Z beg:PSRC")
-END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_S0_Z' )
-
-CALL MNH_MEM_GET( ZFPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFNEG, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZPHAT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZCR_DZF, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZCR_MZM, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRHO_MZM, IIU, IJU, IKU )
+! interpolated variable at cell edges
+ & , ZPHAT &
+ & , ZRHO_MZM ,ZCR_MZM,ZCR_DZF
#endif
+!
+!-------------------------------------------------------------------------------
!$acc data present ( PSRC, PCR, PRHO, PR , &
!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MZM, ZCR_MZM, ZCR_DZF )
+IF (MPPDB_INITIALIZED) THEN
+ !Check all IN arrays
+ CALL MPPDB_CHECK(PCR, "PPM_S0_Z beg:PCR")
+ CALL MPPDB_CHECK(PRHO,"PPM_S0_Z beg:PRHO")
+ !Check all INOUT arrays
+ CALL MPPDB_CHECK(PSRC,"PPM_S0_Z beg:PSRC")
+END IF
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
!
+#ifndef MNH_OPENACC
IKB = 1 + JPVEXT
IKE = SIZE(PSRC,3) - JPVEXT
+#endif
!
!-------------------------------------------------------------------------------
!
@@ -3175,7 +3570,7 @@ IKE = SIZE(PSRC,3) - JPVEXT
#ifndef MNH_OPENACC
CALL GET_HALO(PSRC, HNAME='PSRC')
#else
- CALL GET_HALO_D(PSRC, HNAME='UPDATE_HALO_ll::GET_HALO::PSRC')
+ CALL GET_HALO_D(PSRC, HNAME='PSRC')
#endif
!
!$acc kernels present_cr(ZFPOS,ZPHAT,ZFNEG)
@@ -3247,16 +3642,12 @@ PR = PSRC * PRHO - &
PR(:,:,IKB-1) = PR(:,:,IKB)
PR(:,:,IKE+1) = PR(:,:,IKE)
!
-!$acc end kernels
+!$acc end kernels
!
-CALL MPPDB_CHECK(ZPHAT,"PPM_S0_Z:ZPHAT")
-CALL MPPDB_CHECK(ZFPOS,"PPM_S0_Z:ZFPOS")
-CALL MPPDB_CHECK(ZFNEG,"PPM_S0_Z:ZFNEG")
-CALL MPPDB_CHECK(PR,"PPM_S0_Z:PR")
#ifndef MNH_OPENACC
CALL GET_HALO(PR, HNAME='PR')
#else
- CALL GET_HALO_D(PR, HNAME='UPDATE_HALO_ll::GET_HALO::PR')
+ CALL GET_HALO_D(PR, HNAME='PR')
#endif
IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
@@ -3268,11 +3659,8 @@ END IF
!$acc end data
#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_S0_Z' )
-#endif
+END SUBROUTINE PPM_S0_Z_D
-#ifdef MNH_OPENACC
END SUBROUTINE PPM_S0_Z
#else
END FUNCTION PPM_S0_Z
@@ -3281,14 +3669,71 @@ END FUNCTION PPM_S0_Z
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
- SUBROUTINE PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR)
+! ########################################################################
+! FUNCTION PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
+! PTSTEP) RESULT(PR)
+ SUBROUTINE PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
+ PTSTEP, PR)
+! ########################################################################
+USE MODE_ll
+use mode_msg
+USE MODE_IO
+USE MODI_SHUMAN_DEVICE
+!
+USE MODD_CONF
+USE MODD_LUNIT
+USE MODD_PARAMETERS
+!
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+! output source term
+REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
+
+INTEGER :: IZPHAT,IZRUT,IZFUP,IZFCOR,IZRPOS,IZRNEG
+
+!$acc data present( PSRC, PCR, PRHO, PRHOT, PR )
+
+ call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_X', 'OpenACC: not yet implemented' )
+
+ CALL MNH_GET_ZT3D(IZPHAT,IZRUT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
+
+ CALL PPM_S1_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR, &
+ ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRUT),ZT3D(:,:,:,IZFUP), &
+ ZT3D(:,:,:,IZFCOR),ZT3D(:,:,:,IZRPOS),ZT3D(:,:,:,IZRNEG) )
+
+ CALL MNH_REL_ZT3D(IZPHAT,IZRUT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
+
+!$acc end data
+
+ CONTAINS
+!
+! ########################################################################
+! FUNCTION PPM_S1_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
+! PTSTEP) RESULT(PR)
+ SUBROUTINE PPM_S1_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
+ PTSTEP, PR, ZPHAT,ZRUT,ZFUP,ZFCOR,ZRPOS,ZRNEG)
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
PTSTEP) RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_S1_X - PPM advection scheme in X direction in Skamarock 2006
!! notation - with flux limiting for monotonicity
@@ -3300,13 +3745,7 @@ END FUNCTION PPM_S0_Z
!!
!-------------------------------------------------------------------------------
!
-USE MODD_CONF
-USE MODD_PARAMETERS
-
USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
use mode_mppdb
#ifndef MNH_OPENACC
@@ -3315,7 +3754,11 @@ USE MODI_SHUMAN
USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
-
+!
+USE MODD_CONF
+USE MODD_PARAMETERS
+!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -3345,9 +3788,7 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
!
INTEGER:: IIB,IJB,IKB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE,IKE ! End useful area in x,y,z directions
-INTEGER :: IIU, IJU, IKU
!
-#ifndef MNH_OPENACC
! variable at cell edges
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT, ZRUT
!
@@ -3356,16 +3797,6 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFUP, ZFCOR
!
! ratios for limiting the correction flux
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZRPOS, ZRNEG
-#else
-! variable at cell edges
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPHAT, ZRUT
-!
-! advection fluxes, upwind and correction
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFUP, ZFCOR
-!
-! ratios for limiting the correction flux
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRPOS, ZRNEG
-#endif
!
! variables for limiting the correction flux
REAL :: ZSRCMAX, ZSRCMIN, ZFIN, ZFOUT
@@ -3376,9 +3807,9 @@ INTEGER :: II, IJ, IK
INTEGER :: IRESP ! for prints
!
!-------------------------------------------------------------------------------
-#ifdef MNH_OPENACC
-call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_X', 'OpenACC: not yet implemented' )
-#endif
+
+!$acc data present( PSRC, PCR, PRHO, PRHOT, PR, &
+!$acc & ZPHAT, ZRUT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
@@ -3388,26 +3819,6 @@ IF (MPPDB_INITIALIZED) THEN
!Check all INOUT arrays
CALL MPPDB_CHECK(PSRC, "PPM_S1_X beg:PSRC")
END IF
-
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_S1_X' )
-
-CALL MNH_MEM_GET( ZPHAT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRUT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFUP, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFCOR, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRNEG, IIU, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR, &
-!$acc & ZPHAT, ZRUT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
@@ -3601,11 +4012,7 @@ END IF
!$acc end data
#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_S1_X' )
-#endif
-
-#ifdef MNH_OPENACC
+ END SUBROUTINE PPM_S1_X_D
END SUBROUTINE PPM_S1_X
#else
END FUNCTION PPM_S1_X
@@ -3614,15 +4021,71 @@ END FUNCTION PPM_S1_X
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
- SUBROUTINE PPM_S1_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
+! ########################################################################
+! FUNCTION PPM_S1_Y(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
+! PTSTEP) RESULT(PR)
+ SUBROUTINE PPM_S1_Y(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
PTSTEP, PR)
+! ########################################################################
+USE MODE_ll
+USE MODE_IO
+use mode_msg
+USE MODI_SHUMAN_DEVICE
+!
+USE MODD_CONF
+USE MODD_LUNIT
+USE MODD_PARAMETERS
+!
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+! output source term
+REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
+
+INTEGER :: IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG
+
+!$acc data present( PSRC, PCR, PRHO, PRHOT, PR )
+
+ call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_Y', 'OpenACC: not yet implemented' )
+
+ CALL MNH_GET_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
+
+ CALL PPM_S1_Y_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR, &
+ ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRVT),ZT3D(:,:,:,IZFUP), &
+ ZT3D(:,:,:,IZFCOR),ZT3D(:,:,:,IZRPOS),ZT3D(:,:,:,IZRNEG) )
+
+ CALL MNH_REL_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
+
+!$acc end data
+
+ CONTAINS
+!
+! ########################################################################
+! FUNCTION PPM_S1_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
+! PTSTEP) RESULT(PR)
+ SUBROUTINE PPM_S1_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
+ PTSTEP, PR, ZPHAT,ZRVT,ZFUP,ZFCOR,ZRPOS,ZRNEG)
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_S1_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
PTSTEP) RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_S1_Y - PPM advection scheme in Y direction in Skamarock 2006
!! notation - with flux limiting for monotonicity
@@ -3634,13 +4097,7 @@ END FUNCTION PPM_S1_X
!!
!-------------------------------------------------------------------------------
!
-USE MODD_CONF
-USE MODD_PARAMETERS
-
USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
use mode_mppdb
#ifndef MNH_OPENACC
@@ -3650,6 +4107,12 @@ USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
!
+USE MODD_CONF
+USE MODD_PARAMETERS
+!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+#endif
!
IMPLICIT NONE
!
@@ -3680,9 +4143,7 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
!
INTEGER:: IIB,IJB,IKB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE,IKE ! End useful area in x,y,z directions
-INTEGER :: IIU, IJU, IKU
!
-#ifndef MNH_OPENACC
! variable at cell edges
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT, ZRVT
!
@@ -3691,16 +4152,6 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFUP, ZFCOR
!
! ratios for limiting the correction flux
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZRPOS, ZRNEG
-#else
-! variable at cell edges
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPHAT, ZRVT
-!
-! advection fluxes, upwind and correction
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFUP, ZFCOR
-!
-! ratios for limiting the correction flux
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRPOS, ZRNEG
-#endif
!
! variables for limiting the correction flux
REAL :: ZSRCMAX, ZSRCMIN, ZFIN, ZFOUT
@@ -3712,9 +4163,9 @@ INTEGER :: II, IJ, IK
INTEGER :: IRESP ! Return code of FM-routines
!
!-------------------------------------------------------------------------------
-#ifdef MNH_OPENACC
-call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_Y', 'OpenACC: not yet implemented' )
-#endif
+
+!$acc data present( PSRC, PCR, PRHO, PRHOT, PR , &
+!$acc & ZPHAT, ZRVT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
@@ -3725,25 +4176,7 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PSRC, "PPM_S1_Y beg:PSRC")
END IF
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_S1_Y' )
-
-CALL MNH_MEM_GET( ZPHAT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRVT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFUP, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFCOR, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRNEG, IIU, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR , &
-!$acc & ZPHAT, ZRVT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
-
+!
IF ( L2D ) THEN
PR = PSRC*PRHO
!RETURN
@@ -3940,11 +4373,7 @@ END IF !not L2D
!$acc end data
#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_S1_Y' )
-#endif
-
-#ifdef MNH_OPENACC
+ END SUBROUTINE PPM_S1_Y_D
END SUBROUTINE PPM_S1_Y
#else
END FUNCTION PPM_S1_Y
@@ -3953,14 +4382,68 @@ END FUNCTION PPM_S1_Y
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
-! ########################################################################
#ifdef MNH_OPENACC
- SUBROUTINE PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR)
+!
+! ########################################################################
+! FUNCTION PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, &
+! PTSTEP) RESULT(PR)
+ SUBROUTINE PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, &
+ PTSTEP, PR)
+! ########################################################################
+USE MODE_ll
+USE MODE_IO
+use mode_msg
+
+USE MODI_SHUMAN_DEVICE
+!
+USE MODD_CONF
+USE MODD_LUNIT
+USE MODD_PARAMETERS
+!
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KGRID ! C grid localisation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
+REAL, INTENT(IN) :: PTSTEP ! Time step
+!
+! output source term
+REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
+
+INTEGER :: IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG
+
+!$acc data present( PSRC, PCR, PRHO, PRHOT, PR )
+
+ call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_Z', 'OpenACC: not yet implemented' )
+
+ CALL MNH_GET_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
+
+ CALL PPM_S1_Z_D(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR, &
+ ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRVT),ZT3D(:,:,:,IZFUP), &
+ ZT3D(:,:,:,IZFCOR),ZT3D(:,:,:,IZRPOS),ZT3D(:,:,:,IZRNEG) )
+
+ CALL MNH_REL_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
+
+!$acc end data
+
+ CONTAINS
+! ########################################################################
+ SUBROUTINE PPM_S1_Z_D(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, &
+ PR, ZPHAT,ZRVT,ZFUP,ZFCOR,ZRPOS,ZRNEG)
+! ########################################################################
#else
+! ########################################################################
FUNCTION PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP) &
RESULT(PR)
-#endif
! ########################################################################
+#endif
!!
!!**** PPM_S1_Z - PPM advection scheme in Z direction in Skamarock 2006
!! notation - with flux limiting for monotonicity
@@ -3972,13 +4455,7 @@ END FUNCTION PPM_S1_Y
!!
!-------------------------------------------------------------------------------
!
-USE MODD_CONF
-USE MODD_PARAMETERS
-
USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
use mode_mppdb
#ifndef MNH_OPENACC
@@ -3987,7 +4464,14 @@ USE MODI_SHUMAN
USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
-
+!
+USE MODD_CONF
+USE MODD_PARAMETERS
+!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+#endif
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -4015,9 +4499,7 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
!
INTEGER:: IIB,IJB,IKB ! Begining useful area in x,y,z directions
INTEGER:: IIE,IJE,IKE ! End useful area in x,y,z directions
-INTEGER :: IIU, IJU, IKU
!
-#ifndef MNH_OPENACC
! variable at cell edges
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT, ZRVT
!
@@ -4026,16 +4508,6 @@ REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFUP, ZFCOR
!
! ratios for limiting the correction flux
REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZRPOS, ZRNEG
-#else
-! variable at cell edges
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPHAT, ZRVT
-!
-! advection fluxes, upwind and correction
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZFUP, ZFCOR
-!
-! ratios for limiting the correction flux
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRPOS, ZRNEG
-#endif
!
! variables for limiting the correction flux
REAL :: ZSRCMAX, ZSRCMIN, ZFIN, ZFOUT
@@ -4045,9 +4517,9 @@ REAL, PARAMETER :: ZEPS = 1.0E-16
INTEGER :: II, IJ, IK
!
!-------------------------------------------------------------------------------
-#ifdef MNH_OPENACC
-call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_Z', 'OpenACC: not yet implemented' )
-#endif
+
+!$acc data present( PSRC, PCR, PRHO, PRHOT, PR, &
+!$acc & ZPHAT, ZRVT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
@@ -4058,25 +4530,6 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PSRC, "PPM_S1_Z beg:PSRC")
END IF
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-#ifdef MNH_OPENACC
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN( 'PPM_S1_Z' )
-
-CALL MNH_MEM_GET( ZPHAT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRVT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFUP, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZFCOR, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRPOS, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRNEG, IIU, IJU, IKU )
-#endif
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR, &
-!$acc & ZPHAT, ZRVT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
-
!
!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
@@ -4334,11 +4787,7 @@ END IF
!$acc end data
#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE( 'PPM_S1_Z' )
-#endif
-
-#ifdef MNH_OPENACC
+ END SUBROUTINE PPM_S1_Z_D
END SUBROUTINE PPM_S1_Z
#else
END FUNCTION PPM_S1_Z
diff --git a/src/ZSOLVER/ppm.f90 b/src/ZSOLVER/ppm.f90
deleted file mode 100644
index 51bf1a52a..000000000
--- a/src/ZSOLVER/ppm.f90
+++ /dev/null
@@ -1,4911 +0,0 @@
-!MNH_LIC Copyright 1994-2020 CNRS, Meteo-France and Universite Paul Sabatier
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
-!MNH_LIC for details. version 1.
-!-----------------------------------------------------------------
-! Modifications:
-! P. Wautelet 05/2016-04/2018: new data structures and calls for I/O
-! P. Wautelet 20/06/2019: OpenACC: correct intent of some dummy variables
-! P. Wautelet 01/07/2019: OpenACC: optimisation of ppm_s0_x/y/z_d for GPU
-! P. Wautelet 18/07/2019: OpenACC: remove use of macros for dif2x/y/z
-!-----------------------------------------------------------------
-#ifdef MNH_OPENACC
-!
-! inline shuman with macro
-!
-!#define dxf(PDXF,PA) PDXF(1:IIU-1,:,:) = PA(2:IIU,:,:) - PA(1:IIU-1,:,:) ; PDXF(IIU,:,:) = PDXF(2*JPHEXT,:,:) ! DXF(PDXF,PA)
-!#define dyf(PDYF,PA) PDYF(:,1:IJU-1,:) = PA(:,2:IJU,:) - PA(:,1:IJU-1,:); PDYF(:,IJU,:) = PDYF(:,2*JPHEXT,:) ! DYF(PDYF,PA)
-!!#define dyf(PDYF,PA) PDYF(1:IIU,1:IJU-1,IKB:IKE) = PA(1:IIU,2:IJU,IKB:IKE) - PA(1:IIU,1:IJU-1,IKB:IKE); ! PDYF(1:IIU,IJU,IKB:IKE) = PDYF(1:IIU,2*JPHEXT,IKB:IKE) ! DYF(PDYF,PA)
-!#define dzf(PDZF,PA) PDZF(:,:,1:IKU-1) = PA(:,:,2:IKU) - PA(:,:,1:IKU-1) ; PDZF(:,:,IKU) = -999. ! DZF(PDZF,PA)
-!
-!#define mxm(PMXM,PA) PMXM(2:IIU,:,:) = 0.5*( PA(2:IIU,:,:)+PA(1:IIU-1,:,:) ) ; PMXM(1,:,:) = PMXM(IIU-2*JPHEXT+1,:,:) ! MXM(PMXM,PA)
-!!#define mym(PMYM,PA) PMYM(1:IIU,2:IJU,IKB:IKE) = 0.5*( PA(1:IIU,2:IJU,IKB:IKE)+PA(1:IIU,1:IJU-1,IKB:IKE) ) ; ! PMYM(1:IIU,1,IKB:IKE) = PMYM(1:IIU,IJU-2*JPHEXT+1,IKB:IKE) ! MYM(PMYM,PA)
-!#define mzm(PMZM,PA) PMZM(:,:,2:IKU) = 0.5*( PA(:,:,2:IKU)+PA(:,:,1:IKU-1) ) ; PMZM(:,:,1) = -999. ! MZM(PMZM,PA)
-!#define mym(PMYM,PA) PMYM(:,2:IJU,:) = 0.5*( PA(:,2:IJU,:)+PA(:,1:IJU-1,:) ) ; PMYM(:,1,:) = PMYM(:,IJU-2*JPHEXT+1,:) ! MYM(PMYM,PA)
-!
-! #define dif2x(DQ,PQ) DQ(IIB:IIE,:,:)=0.5*(PQ(IIB+1:IIE+1,:,:)-PQ(IIB-1:IIE-1,:,:));\
-! DQ(IIB-1,:,:)=0.5*(PQ(IIB,:,:)-PQ(IIE-1,:,:));\
-! DQ(IIE+1,:,:)=0.5*(PQ(IIB+1,:,:)-PQ(IIE,:,:)) ! DIF2X(DQ,PQ)
-!
-! #define dif2y(DQ,PQ) DQ(1:IIU,IJB:IJE,IKB:IKE) = 0.5*(PQ(1:IIU,IJB+1:IJE+1,IKB:IKE) - PQ(1:IIU,IJB-1:IJE-1,IKB:IKE)) ; !
-! ! DQ(1:IIU,IJB-1,IKB:IKE) = 0.5*(PQ(1:IIU,IJB,IKB:IKE) - PQ(1:IIU,IJE-1,IKB:IKE)) ; \
-! DQ(1:IIU,IJE+1,IKB:IKE) = 0.5*(PQ(1:IIU,IJB+1,IKB:IKE) - PQ(1:IIU,IJE,IKB:IKE)) ! DIF2Y(DQ,PQ)
-!
-! #define dif2z(DQ,PQ) DQ(:,:,IKB:IKE) = 0.5*(PQ(:,:,IKB+1:IKE+1) - PQ(:,:,IKB-1:IKE-1)) ; \
-! DQ(:,:,IKB-1) = -DQ(:,:,IKB) ;\
-! DQ(:,:,IKE+1) = -DQ(:,:,IKE) ! DIF2Z(DQ,PQ)
-!
-#endif
-! ###############
- MODULE MODI_PPM
-! ###############
-!
-INTERFACE
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-#else
-SUBROUTINE PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-#endif
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_01_X
-#else
-END SUBROUTINE PPM_01_X
-#endif
-!
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-#else
-SUBROUTINE PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-#endif
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_01_Y
-#else
-END SUBROUTINE PPM_01_Y
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) RESULT(PR)
-#else
-SUBROUTINE PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-#endif
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-#ifndef MNH_OPENACC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
-#else
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-#endif
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_01_Z
-#else
-END SUBROUTINE PPM_01_Z
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-#else
-SUBROUTINE PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP &
- , PR)
-#endif
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_S0_X
-#else
-END SUBROUTINE PPM_S0_X
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-#else
-SUBROUTINE PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP &
- , PR)
-#endif
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_S0_Y
-#else
-END SUBROUTINE PPM_S0_Y
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-#else
-SUBROUTINE PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP &
- , PR)
-#endif
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_S0_Z
-#else
-END SUBROUTINE PPM_S0_Z
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP) RESULT(PR)
-#else
-SUBROUTINE PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR)
-#endif
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_S1_X
-#else
-END SUBROUTINE PPM_S1_X
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_S1_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP) RESULT(PR)
-#else
-SUBROUTINE PPM_S1_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR)
-#endif
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_S1_Y
-#else
-END SUBROUTINE PPM_S1_Y
-#endif
-!
-#ifndef MNH_OPENACC
-FUNCTION PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP) &
- RESULT(PR)
-#else
-SUBROUTINE PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, &
- PR)
-#endif
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-#ifndef MNH_OPENACC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
-#else
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-#endif
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-#ifndef MNH_OPENACC
-END FUNCTION PPM_S1_Z
-#else
-END SUBROUTINE PPM_S1_Z
-#endif
-!
-END INTERFACE
-!
-END MODULE MODI_PPM
-!
-!
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-!!$ FUNCTION PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
-!!$ RESULT(PR)
- SUBROUTINE PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-! ########################################################################
-
- USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
- USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
-
- IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-
-INTEGER :: IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG
-
-!$acc data present( PSRC, PCR, PRHO, PR )
-
- CALL MNH_GET_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
-
- CALL PPM_01_X_D(IIU,IJU,IKU,HLBCX, KGRID, &
- & PSRC, PCR, PRHO, PTSTEP, PR, &
- & ZT3D(:,:,:,IZQL),ZT3D(:,:,:,IZQR),ZT3D(:,:,:,IZDQ),ZT3D(:,:,:,IZQ6), &
- & ZT3D(:,:,:,IZDMQ),ZT3D(:,:,:,IZQL0),ZT3D(:,:,:,IZQR0), ZT3D(:,:,:,IZQ60), &
- & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG) )
-
- CALL MNH_REL_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
-
-!$acc end data
-!
-CONTAINS
-!
-! ########################################################################
- SUBROUTINE PPM_01_X_D(IIU,IJU,IKU,HLBCX, KGRID, &
- & PSRC, PCR, PRHO, PTSTEP, PR, &
- & ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60,ZFPOS,ZFNEG)
-
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_01_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_01_X - PPM_01 fully monotonic PPM advection scheme in X direction
-!! Colella notation
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 11.5.2006. T. Maric - original version
-!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
-!! J.Escobar 28/06/2018: limit computation on TAB(:,IJS:IJN,:) to avoid unneeded NaN
-!! J.Escobr 16/07/2018: still NaN pb => reintroduce initialization of temporary local array
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODD_CONF
-
-USE MODE_ll
-use mode_mppdb
-#ifdef MNH_OPENACC
-use mode_msg
-#endif
-
-#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
-USE MODI_BITREP
-#endif
-#ifdef MNH_BITREP_OMP
-USE MODI_BITREPZ
-#endif
-USE MODI_GET_HALO
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-#ifdef MNH_OPENACC
-INTEGER , INTENT(IN) :: IIU,IJU,IKU
-#endif
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(IIU,IJU,IKU), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE ! End useful area in x,y,z directions
-!
-integer :: ji, jj, jk
-#ifndef MNH_OPENACC
-integer :: iiu, iju, iku
-! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL,ZQR
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDQ,ZQ6
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDMQ
-!
-! extra variables for the initial guess of parabolae parameters
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL0,ZQR0,ZQ60
-!
-! advection fluxes
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
-!
-!BEG JUAN PPM_LL
-INTEGER :: IJS,IJN
-!END JUAN PPM_LL
-#else
-INTEGER :: I,J,K
-!
-!!$!
-!!$! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL , DIMENSION(IIU,IJU,IKU) :: &
- ZQL,ZQR, ZDQ,ZQ6, ZDMQ &
-!!$!
-!!$! extra variables for the initial guess of parabolae parameters
- , ZQL0,ZQR0,ZQ60 &
-!!$!
-!!$! advection fluxes
- , ZFPOS, ZFNEG
-!
-INTEGER :: IJS,IJN
-#endif
-LOGICAL :: GWEST , GEAST
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_BITREP_OMP
-CALL SBR_FZ(PSRC(:,:,:))
-#endif
-!
-!$acc data present( PSRC, PCR, PRHO, PR , &
-!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_01_X beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_01_X beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_01_X beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IJS=IJB
-IJN=IJE
-!
-GWEST = LWEST_ll()
-GEAST = LEAST_ll()
-!
-!BEG JUAN PPM_LL
-!
-!* initialise & update halo & halo2 for PSRC
-!
-#ifndef MNH_OPENACC
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-CALL GET_HALO(PSRC, HNAME='PSRC')
-!
-PR (:,:,:) = PSRC(:,:,:)
-ZQL (:,:,:) = PSRC(:,:,:)
-ZQR (:,:,:) = PSRC(:,:,:)
-ZDQ (:,:,:) = PSRC(:,:,:)
-ZQ6 (:,:,:) = PSRC(:,:,:)
-ZDMQ (:,:,:) = PSRC(:,:,:)
-ZQL0 (:,:,:) = PSRC(:,:,:)
-ZQR0 (:,:,:) = PSRC(:,:,:)
-ZQ60 (:,:,:) = PSRC(:,:,:)
-ZFPOS(:,:,:) = PSRC(:,:,:)
-ZFNEG(:,:,:) = PSRC(:,:,:)
-#else
-CALL GET_HALO_D(PSRC,HDIR="01_X", HNAME='PSRC')
-!
-!$acc kernels
-!$mnh_do_concurrent (ji=1:iiu,jj=1:iju,jk=1:iku)
- PR (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQL (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQR (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZDQ (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQ6 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZDMQ (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQL0 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQR0 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQ60 (ji, jj, jk ) = PSRC(ji, jj, jk )
-!$mnh_end_do()
-!
-#if 0
-ZFPOS(:,1:IJS,:)=PSRC(:,1:IJS,:)
-ZFNEG(:,1:IJS,:)=PSRC(:,1:IJS,:)
-ZFPOS(:,IJN:,:)=PSRC(:,IJN:,:)
-ZFNEG(:,IJN:,:)=PSRC(:,IJN:,:)
-#else
-ZFPOS(:,:,:) = PSRC(:,:,:)
-ZFNEG(:,:,:) = PSRC(:,:,:)
-#endif
-!$acc end kernels
-#endif
-!
-!-------------------------------------------------------------------------------
-!
-SELECT CASE ( HLBCX(1) ) ! X direction LBC type: (1) for left side
-!
-! 1.1 CYCLIC BOUNDARY CONDITIONS IN X DIRECTION
-! -----------------------------------------
-!
-CASE ('CYCL','WALL') ! In that case one must have HLBCX(1) == HLBCX(2)
-#ifdef MNH_OPENACC
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_01_X', 'OpenACC: CYCL/WALL boundaries not yet implemented' )
-#endif
-!
-! calculate dmq
- ZDMQ = DIF2X(PSRC)
-!
-! monotonize the difference followinq eq. 5 in Lin94
-!
-!BEG JUAN PPM_LL01
-!
-! ZDMQ(i) = Fct[ ZDMQ(i),PSRC(i),PSRC(i-1),PSRC(i+1) ]
-!
- ZDMQ(IIB:IIE,IJS:IJN,:) = &
- SIGN( (MIN( ABS(ZDMQ(IIB:IIE,IJS:IJN,:)),2.0*(PSRC(IIB:IIE,IJS:IJN,:) - &
- MIN(PSRC(IIB-1:IIE-1,IJS:IJN,:),PSRC(IIB:IIE,IJS:IJN,:),PSRC(IIB+1:IIE+1,IJS:IJN,:))), &
- 2.0*(MAX(PSRC(IIB-1:IIE-1,IJS:IJN,:),PSRC(IIB:IIE,IJS:IJN,:),PSRC(IIB+1:IIE+1,IJS:IJN,:)) - &
- PSRC(IIB:IIE,IJS:IJN,:)) )), ZDMQ(IIB:IIE,IJS:IJN,:) )
-!
-! WEST BOUND
-!
-!!$ ZDMQ(IIB-1,:,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(IIB-1,:,:)), 2.0*(PSRC(IIB-1,:,:) - &
-!!$ MIN(PSRC(IIE-1,:,:),PSRC(IIB-1,:,:),PSRC(IIB,:,:))), &
-!!$ 2.0*(MAX(PSRC(IIE-1,:,:),PSRC(IIB-1,:,:),PSRC(IIB,:,:)) - &
-!!$ PSRC(IIB-1,:,:)) )), ZDMQ(IIB-1,:,:) )
-!
-! EAST BOUND
-!
-!!$ ZDMQ(IIE+1,:,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(IIE+1,:,:)), 2.0*(PSRC(IIE+1,:,:) - &
-!!$ MIN(PSRC(IIE,:,:),PSRC(IIE+1,:,:),PSRC(IIB+1,:,:))), &
-!!$ 2.0*(MAX(PSRC(IIE,:,:),PSRC(IIE+1,:,:),PSRC(IIB+1,:,:)) - &
-!!$ PSRC(IIE+1,:,:)) )), ZDMQ(IIE+1,:,:) )
-!
-! update ZDMQ HALO before next/further utilisation
-!
- CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
-!
-! calculate qL and qR with the modified dmq
-!
-! ZQL0(i) = Fct[ PSRC(i),PSRC(i-1),ZDMQ(i),ZDMQ(i-1) ]
-!
- ZQL0(IIB:IIE+1,IJS:IJN,:) = 0.5*(PSRC(IIB:IIE+1,IJS:IJN,:) + PSRC(IIB-1:IIE,IJS:IJN,:)) - &
- (ZDMQ(IIB:IIE+1,IJS:IJN,:) - ZDMQ(IIB-1:IIE,IJS:IJN,:))/6.0
-!
- CALL GET_HALO(ZQL0, HNAME='ZQL0')
-!
-! WEST BOUND
-!
-!!$ ZQL0(IIB-1,:,:) = ZQL0(IIE,:,:) JUAN PPMLL01
-!
- ZQR0(IIB-1:IIE,IJS:IJN,:) = ZQL0(IIB:IIE+1,IJS:IJN,:)
-!
- CALL GET_HALO(ZQR0, HNAME='ZQR0')
-!
-! EAST BOUND
-!
-!!$ ZQR0(IIE+1,:,:) = ZQR0(IIB,:,:) JUAN PPMLL01
-!
-! determine initial coefficients of the parabolae
-!
- ZDQ(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:) - ZQL0(:,IJS:IJN,:)
- ZQ60(:,IJS:IJN,:) = 6.0*(PSRC(:,IJS:IJN,:) - 0.5*(ZQL0(:,IJS:IJN,:) + ZQR0(:,IJS:IJN,:)))
-!
-! initialize final parabolae parameters
-!
- ZQL(:,IJS:IJN,:) = ZQL0(:,IJS:IJN,:)
- ZQR(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:)
- ZQ6(:,IJS:IJN,:) = ZQ60(:,IJS:IJN,:)
-!
-! eliminate over and undershoots and create qL and qR as in Lin96
-!
- WHERE ( ZDMQ(:,IJS:IJN,:) == 0.0 )
- ZQL(:,IJS:IJN,:) = PSRC(:,IJS:IJN,:)
- ZQR(:,IJS:IJN,:) = PSRC(:,IJS:IJN,:)
- ZQ6(:,IJS:IJN,:) = 0.0
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- ELSEWHERE ( ZQ60(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) < -(ZDQ(:,IJS:IJN,:))**2 )
-#else
- ELSEWHERE ( ZQ60(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) < -BR_P2(ZDQ(:,IJS:IJN,:)) )
-#endif
- ZQ6(:,IJS:IJN,:) = 3.0*(ZQL0(:,IJS:IJN,:) - PSRC(:,IJS:IJN,:))
- ZQR(:,IJS:IJN,:) = ZQL0(:,IJS:IJN,:) - ZQ6(:,IJS:IJN,:)
- ZQL(:,IJS:IJN,:) = ZQL0(:,IJS:IJN,:)
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- ELSEWHERE ( ZQ60(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) > (ZDQ(:,IJS:IJN,:))**2 )
-#else
- ELSEWHERE ( ZQ60(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) > BR_P2(ZDQ(:,IJS:IJN,:)) )
-#endif
- ZQ6(:,IJS:IJN,:) = 3.0*(ZQR0(:,IJS:IJN,:) - PSRC(:,IJS:IJN,:))
- ZQL(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:) - ZQ6(:,IJS:IJN,:)
- ZQR(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:)
- END WHERE
-!
-! recalculate coefficients of the parabolae
-!
- ZDQ(:,IJS:IJN,:) = ZQR(:,IJS:IJN,:) - ZQL(:,IJS:IJN,:)
-!
-! and finally calculate fluxes for the advection
-!
-! ZFPOS(i) = Fct[ ZQR(i-1),PCR(i),ZDQ(i-1),ZQ6(i-1) ]
-!
- ZFPOS(IIB:IIE+1,IJS:IJN,:) = ZQR(IIB-1:IIE,IJS:IJN,:) - 0.5*PCR(IIB:IIE+1,IJS:IJN,:) * &
- (ZDQ(IIB-1:IIE,IJS:IJN,:) - (1.0 - 2.0*PCR(IIB:IIE+1,IJS:IJN,:)/3.0) &
- * ZQ6(IIB-1:IIE,IJS:IJN,:))
-!
- CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
-!
-! WEST BOUND
-!
-! PPOSX(IIB-1,:,:) is not important for the calc of advection so
-! we set it to 0
-!!$ ZFPOS(IIB-1,:,:) = 0.0 JUANPPMLL01
-!
- ZFNEG(:,IJS:IJN,:) = ZQL(:,IJS:IJN,:) - 0.5*PCR(:,IJS:IJN,:) * &
- ( ZDQ(:,IJS:IJN,:) + (1.0 + 2.0*PCR(:,IJS:IJN,:)/3.0) * ZQ6(:,IJS:IJN,:) )
-!
- CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
-!
-! advect the actual field in X direction by U*dt
-!
-#ifndef MNH_OPENACC
- PR = DXF( PCR*MXM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_01_X', 'OpenACC: CYCL/WALL boundaries not yet implemented' )
-#endif
- CALL GET_HALO(PR, HNAME='PR')
-!
-!
-!* 1.2 NON-CYCLIC BOUNDARY CONDITIONS IN THE X DIRECTION
-! -------------------------------------------------
-!
-CASE('OPEN')
-!
-! calculate dmq
-!
-#ifndef MNH_OPENACC
- ZDMQ = DIF2X(PSRC)
-#else
- CALL DIF2X_DEVICE(ZDMQ,PSRC)
-#endif
-
-!$acc kernels
-!
-! overwrite the values on the boundary to get second order difference
-! for qL and qR at the boundary
-!
-! WEST BOUND
-!
- IF (GWEST) THEN
- ZDMQ(IIB-1,IJS:IJN,:) = -ZDMQ(IIB,IJS:IJN,:)
- ENDIF
-!
-! EAST BOUND
-!
- IF (GEAST) THEN
- ZDMQ(IIE+1,IJS:IJN,:) = -ZDMQ(IIE,IJS:IJN,:)
- ENDIF
-!
-! monotonize the difference followinq eq. 5 in Lin94
-!
-! ZDMQ(i) = Fct[ ZDMQ(i),PSRC(i),PSRC(i-1),PSRC(i+1) ]
-!
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijs, ijn
- do ji = iib, iie
- ZDMQ(ji, jj, jk ) = SIGN( &
- MIN( ABS(ZDMQ(ji, jj, jk )), &
- 2.0 * ( PSRC(ji, jj, jk ) &
- - MIN(PSRC(ji - 1, jj, jk ),PSRC(ji, jj, jk ),PSRC(ji + 1, jj, jk )) ), &
- 2.0 * (-PSRC(ji, jj, jk ) &
- + MAX(PSRC(ji - 1, jj, jk ),PSRC(ji, jj, jk ),PSRC(ji + 1, jj, jk )) ) ), &
- ZDMQ(ji, jj, jk ) )
- end do
- end do
- end do
-!
-! WEST BOUND
-!
-!!$ ZDMQ(IIB-1,:,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(IIB-1,:,:)), 2.0*(PSRC(IIB-1,:,:) - &
-!!$ MIN(PSRC(IIE-1,:,:),PSRC(IIB-1,:,:),PSRC(IIB,:,:))), &
-!!$ 2.0*(MAX(PSRC(IIE-1,:,:),PSRC(IIB-1,:,:),PSRC(IIB,:,:)) - &
-!!$ PSRC(IIB-1,:,:)) )), ZDMQ(IIB-1,:,:) )
-!
-! EAST BOUND
-!
-!!$ ZDMQ(IIE+1,:,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(IIE+1,:,:)), 2.0*(PSRC(IIE+1,:,:) - &
-!!$ MIN(PSRC(IIE,:,:),PSRC(IIE+1,:,:),PSRC(IIB+1,:,:))), &
-!!$ 2.0*(MAX(PSRC(IIE,:,:),PSRC(IIE+1,:,:),PSRC(IIB+1,:,:)) - &
-!!$ PSRC(IIE+1,:,:)) )), ZDMQ(IIE+1,:,:) )
-!
-!
-! update ZDMQ HALO before next/further utilisation
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZDMQ, HDIR="01_X", HNAME='ZDMQ')
-#endif
-!$acc kernels
-!
-! calculate qL and qR
-!
-! ZQL0(i) = Fct[ PSRC(i),PSRC(i-1),ZDMQ(i),ZDMQ(i-1) ]
-!
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijs, ijn
- do ji = iib, iie + 1
- ZQL0(ji, jj, jk ) = 0.5 * ( PSRC(ji, jj, jk ) + PSRC(ji-1, jj, jk ) ) - ( ZDMQ(ji, jj, jk ) - ZDMQ(ji-1, jj, jk ) ) / 6.0
- end do
- end do
- end do
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZQL0, HNAME='ZQL0')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZQL0,HDIR="01_X", HNAME='ZQL0')
-!$acc kernels
-#endif
-!
-! WEST BOUND
-!
- IF (GWEST) THEN
- ZQL0(IIB-1,IJS:IJN,:) = ZQL0(IIB,IJS:IJN,:)
- ENDIF
-!
- ZQR0(IIB-1:IIE,IJS:IJN,:) = ZQL0(IIB:IIE+1,IJS:IJN,:)
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZQR0, HNAME='ZQR0')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZQR0, HDIR="01_X", HNAME='ZQR0')
-!$acc kernels
-#endif
-!
-! EAST BOUND
-!
- IF (GEAST) THEN
- ZQR0(IIE+1,IJS:IJN,:) = ZQR0(IIE,IJS:IJN,:)
- ENDIF
-#ifndef MNH_OPENACC
-!
-! determine initial coefficients of the parabolae
-!
- ZDQ(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:) - ZQL0(:,IJS:IJN,:)
- ZQ60(:,IJS:IJN,:) = 6.0*(PSRC(:,IJS:IJN,:) - 0.5*(ZQL0(:,IJS:IJN,:) + ZQR0(:,IJS:IJN,:)))
-!
-! initialize final parabolae parameters
-!
- ZQL(:,IJS:IJN,:) = ZQL0(:,IJS:IJN,:)
- ZQR(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:)
- ZQ6(:,IJS:IJN,:) = ZQ60(:,IJS:IJN,:)
-!
-! eliminate over and undershoots and create qL and qR as in Lin96
-!
- WHERE ( ZDMQ(:,IJS:IJN,:) == 0.0 )
- ZQL(:,IJS:IJN,:) = PSRC(:,IJS:IJN,:)
- ZQR(:,IJS:IJN,:) = PSRC(:,IJS:IJN,:)
- ZQ6(:,IJS:IJN,:) = 0.0
- ELSEWHERE ( ZQ60(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) < -ZDQ(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) )
- ZQ6(:,IJS:IJN,:) = 3.0*(ZQL0(:,IJS:IJN,:) - PSRC(:,IJS:IJN,:))
- ZQR(:,IJS:IJN,:) = ZQL0(:,IJS:IJN,:) - ZQ6(:,IJS:IJN,:)
- ZQL(:,IJS:IJN,:) = ZQL0(:,IJS:IJN,:)
- ELSEWHERE ( ZQ60(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) > ZDQ(:,IJS:IJN,:)*ZDQ(:,IJS:IJN,:) )
- ZQ6(:,IJS:IJN,:) = 3.0*(ZQR0(:,IJS:IJN,:) - PSRC(:,IJS:IJN,:))
- ZQL(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:) - ZQ6(:,IJS:IJN,:)
- ZQR(:,IJS:IJN,:) = ZQR0(:,IJS:IJN,:)
- END WHERE
-!
-! recalculate coefficients of the parabolae
-!
- ZDQ(:,IJS:IJN,:) = ZQR(:,IJS:IJN,:) - ZQL(:,IJS:IJN,:)
-#else
-!$acc loop independent collapse(3)
-DO K=1,IKU
- DO J = IJS,IJN
- ! acc loop vector(24)
- DO I=1,IIU
-!
-! determine initial coefficients of the parabolae
-!
- ZDQ (I,J,K)= ZQR0(I,J,K) - ZQL0(I,J,K)
- ZQ60(I,J,K) = 6.0*(PSRC(I,J,K) - 0.5*(ZQL0(I,J,K) + ZQR0(I,J,K)))
-!
-! initialize final parabolae parameters
-!
- ZQL(I,J,K) = ZQL0(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- ZQ6(I,J,K) = ZQ60(I,J,K)
-!
-! eliminate over and undershoots and create qL and qR as in Lin96
-!
- IF ( ZDMQ(I,J,K) == 0.0 ) THEN
- ZQL(I,J,K) = PSRC(I,J,K)
- ZQR(I,J,K) = PSRC(I,J,K)
- ZQ6(I,J,K) = 0.0
- ELSEIF ( ZQ60(I,J,K)*ZDQ(I,J,K) < -ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQL0(I,J,K) - PSRC(I,J,K))
- ZQR(I,J,K) = ZQL0(I,J,K) - ZQ6(I,J,K)
- ZQL(I,J,K) = ZQL0(I,J,K)
- ELSEIF ( ZQ60(I,J,K)*ZDQ(I,J,K) > ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQR0(I,J,K) - PSRC(I,J,K))
- ZQL(I,J,K) = ZQR0(I,J,K) - ZQ6(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- ENDIF
-!
-! recalculate coefficients of the parabolae
-!
- ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
-ENDDO ; ENDDO ; ENDDO
-#endif
-!
-! and finally calculate fluxes for the advection
-!
-!
-! ZFPOS(i) = Fct[ ZQR(i-1),PCR(i),ZDQ(i-1),ZQ6(i-1) ]
-!
-!!$ ZFPOS(IIB+1:IIE+1,:,:) = ZQR(IIB:IIE,:,:) - 0.5*PCR(IIB+1:IIE+1,:,:) * &
-!!$ (ZDQ(IIB:IIE,:,:) - (1.0 - 2.0*PCR(IIB+1:IIE+1,:,:)/3.0) &
-!!$ * ZQ6(IIB:IIE,:,:))
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijs, ijn
- do ji = iib, iie + 1
- ZFPOS(ji, jj, jk ) = ZQR(ji - 1, jj, jk ) - 0.5 * PCR(ji, jj, jk ) &
- * ( ZDQ(ji - 1, jj, jk) - (1.0 - 2.0 * PCR(ji, jj, jk ) / 3.0 ) &
- * ZQ6(ji - 1, jj, jk) )
- end do
- end do
- end do
-!
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZFPOS, HDIR="01_X", HNAME='ZFPOS')
-!$acc kernels
-#endif
-!
-!
-! WEST BOUND
-!
-! advection flux at open boundary when u(IIB) > 0
-!
- IF (GWEST) THEN
- ZFPOS(IIB,IJS:IJN,:) = (PSRC(IIB-1,IJS:IJN,:) - ZQR(IIB-1,IJS:IJN,:))*PCR(IIB,IJS:IJN,:) + &
- ZQR(IIB-1,IJS:IJN,:)
-! PPOSX(IIB-1,:,:) is not important for the calc of advection so
-! we set it to 0
-!!$ ZFPOS(IIB-1,:,:) = 0.0
- ENDIF
-!
-!!$ ZFNEG(IIB-1:IIE,:,:) = ZQL(IIB-1:IIE,:,:) - 0.5*PCR(IIB-1:IIE,:,:) * &
-!!$ (ZDQ(IIB-1:IIE,:,:) + (1.0 + 2.0*PCR(IIB-1:IIE,:,:)/3.0) &
-!!$ * ZQ6(IIB-1:IIE,:,:))
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijs, ijn
- do ji = 1, iiu
- ZFNEG(ji, jj, jk ) = ZQL(ji, jj, jk ) - 0.5*PCR(ji, jj, jk ) * &
- ( ZDQ(ji, jj, jk ) + (1.0 + 2.0*PCR(ji, jj, jk )/3.0) * ZQ6(ji, jj, jk ) )
- end do
- end do
- end do
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZFNEG, HDIR="01_X", HNAME='ZFNEG')
-!$acc kernels
-#endif
-!
-! EAST BOUND
-!
-! advection flux at open boundary when u(IIE+1) < 0
- IF (GEAST) THEN
- ZFNEG(IIE+1,IJS:IJN,:) = (ZQR(IIE,IJS:IJN,:)-PSRC(IIE+1,IJS:IJN,:))*PCR(IIE+1,IJS:IJN,:) + &
- ZQR(IIE,IJS:IJN,:)
- ENDIF
-!
-! advect the actual field in X direction by U*dt
-!
-#ifndef MNH_OPENACC
- PR = DXF( PCR*MXM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
- CALL GET_HALO(PR, HNAME='PR')
-#else
- !mxm(ZQL,PRHO)
-!$acc end kernels
- CALL MXM_DEVICE(PRHO,ZQL)
-!$acc kernels
- where ( PCR(:,:,:) > 0. )
- ZQR(:,:,:) = PCR(:,:,:) * ZQL(:,:,:) * ZFPOS(:,:,:)
- elsewhere
- ZQR(:,:,:) = PCR(:,:,:) * ZQL(:,:,:) * ZFNEG(:,:,:)
- end where
- !dxf(PR,ZQR)
-!$acc end kernels
- CALL DXF_DEVICE(ZQR,PR)
- CALL GET_HALO_D(PR, HDIR="01_X", HNAME='PR')
-#endif
-!
-END SELECT
-!
-#ifdef MNH_BITREP_OMP
-CALL SBR_FZ(PR(:,:,:))
-#endif
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_01_X end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_01_X end:PR")
-END IF
-
-!$acc end data
-
-#ifndef MNH_OPENACC
-CONTAINS
-#else
-END SUBROUTINE PPM_01_X_D
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-! ########################################################################
- FUNCTION DIF2X(PQ) RESULT(DQ)
-! ########################################################################
-!!
-!!**** DIF2X - leap-frog difference operator in X direction
-!!
-!! Calculates the difference assuming periodic BC (CYCL).
-!!
-!! DQ(I) = 0.5 * (PQ(I+1) - PQ(I-1))
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 18.3.2006. T. Maric - original version
-!! 07/2010 J.Escobar : Correction for reproducility
-!! 04/2017 J.Escobar : initialize realistic value in all HALO pts
-!-------------------------------------------------------------------------------
-!
-!
-USE MODE_ll
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)) :: DQ
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IIB,IJB ! Begining useful area in x,y directions
-INTEGER :: IIE,IJE ! End useful area in x,y directions
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PQ, DQ )
-!
-!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
-! -----------------------------
-!
-!!$CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IIB=2 ; IIE = SIZE(PQ,1) -1
-IJB=2 ; IJE = SIZE(PQ,2) -1
-!
-!-------------------------------------------------------------------------------
-!
-!* 2.0. COMPUTE THE DIFFERENCE
-! ----------------------
-!
-!$acc kernels
-DQ(IIB:IIE,:,:) = PQ(IIB+1:IIE+1,:,:) - PQ(IIB-1:IIE-1,:,:)
-DQ(IIB-1,:,:) = PQ(IIB,:,:) - PQ(IIE-1,:,:)
-DQ(IIE+1,:,:) = PQ(IIB+1,:,:) - PQ(IIE,:,:)
-DQ = 0.5*DQ
-!$acc end kernels
-
-!$acc end data
-
-END FUNCTION DIF2X
-!-------------------------------------------------------------------------------
-!
-! ########################################################################
- SUBROUTINE DIF2X_DEVICE(DQ,PQ)
-! ########################################################################
-!!
-!!**** DIF2X - leap-frog difference operator in X direction
-!!
-!! Calculates the difference assuming periodic BC (CYCL).
-!!
-!! DQ(I) = 0.5 * (PQ(I+1) - PQ(I-1))
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 18.3.2006. T. Maric - original version
-!! 07/2010 J.Escobar : Correction for reproducility
-!! 04/2017 J.Escobar : initialize realistic value in all HALO pts
-!-------------------------------------------------------------------------------
-!
-!
-USE MODE_ll
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(:,:,:) :: DQ
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IIB,IJB ! Begining useful area in x,y directions
-INTEGER :: IIE,IJE ! End useful area in x,y directions
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PQ, DQ )
-!
-!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
-! -----------------------------
-!
-!!$CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IIB=2 ; IIE = SIZE(PQ,1) -1
-IJB=2 ; IJE = SIZE(PQ,2) -1
-!
-!-------------------------------------------------------------------------------
-!
-!* 2.0. COMPUTE THE DIFFERENCE
-! ----------------------
-!
-!$acc kernels
-DQ(IIB:IIE,:,:) = PQ(IIB+1:IIE+1,:,:) - PQ(IIB-1:IIE-1,:,:)
-DQ(IIB-1,:,:) = PQ(IIB,:,:) - PQ(IIE-1,:,:)
-DQ(IIE+1,:,:) = PQ(IIB+1,:,:) - PQ(IIE,:,:)
-DQ = 0.5*DQ
-!$acc end kernels
-
-!$acc end data
-
-END SUBROUTINE DIF2X_DEVICE
-!
-#ifdef MNH_OPENACC
-END SUBROUTINE PPM_01_X
-#else
-END FUNCTION PPM_01_X
-#endif
-!
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-!!$ FUNCTION PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
-!!$ RESULT(PR)
- SUBROUTINE PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-! ########################################################################
-
- USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
- USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
-
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT):: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR & ! Courant number
- , PRHO ! density
-!
-! output source term
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-
-INTEGER :: IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG
-
-!$acc data present( PSRC, PCR, PRHO, PR )
-
- CALL MNH_GET_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
-
- CALL PPM_01_Y_D(IIU,IJU,IKU,HLBCY, KGRID, &
- & PSRC, PCR, PRHO, PTSTEP, PR, &
- & ZT3D(:,:,:,IZQL),ZT3D(:,:,:,IZQR),ZT3D(:,:,:,IZDQ),ZT3D(:,:,:,IZQ6), &
- & ZT3D(:,:,:,IZDMQ),ZT3D(:,:,:,IZQL0),ZT3D(:,:,:,IZQR0), ZT3D(:,:,:,IZQ60), &
- & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG) )
-
- CALL MNH_REL_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
-
-!$acc end data
-
-CONTAINS
-!
-! ########################################################################
- SUBROUTINE PPM_01_Y_D(IIU,IJU,IKU,HLBCY, KGRID, &
- & PSRC, PCR, PRHO, PTSTEP, PR, &
- & ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60,ZFPOS,ZFNEG)
-
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_01_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_01_Y - PPM_01 fully monotonic PPM advection scheme in Y direction
-!! Colella notation
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 11.5.2006. T. Maric - original version
-!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
-!! J.Escobar 28/06/2018: limit computation on TAB(IIW:IIA,:,:) to avoid unneeded NaN
-!! J.Escobr 16/07/2018: still NaN pb => reintroduce initialization of temporary local array
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODD_CONF
-
-USE MODE_ll
-#ifdef MNH_OPENACC
-use mode_msg
-#endif
-use mode_mppdb
-
-#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
-USE MODI_BITREP
-#endif
-#ifdef MNH_BITREP_OMP
-USE MODI_BITREPZ
-#endif
-USE MODI_GET_HALO
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-#ifdef MNH_OPENACC
-integer, intent(in) :: iiu, iju, iku
-#endif
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(IIU,IJU,IKU), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE ! End useful area in x,y,z directions
-!
-INTEGER :: IIW,IIA
-!
-LOGICAL :: GSOUTH , GNORTH
-#ifndef MNH_OPENACC
-integer :: iiu, iju, iku
-!
-! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL,ZQR
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDQ,ZQ6
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDMQ
-!
-! extra variables for the initial guess of parabolae parameters
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL0,ZQR0,ZQ60
-!
-! advection fluxes
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
-!
-#else
-! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(IIU,IJU,IKU) :: &
- ZQL,ZQR , ZDQ,ZQ6 , ZDMQ &
-! extra variables for the initial guess of parabolae parameters
- , ZQL0,ZQR0,ZQ60 &
-! advection fluxes
- , ZFPOS, ZFNEG
-
-!
-!JUAN ACC
-INTEGER :: I,J,K
-!
-INTEGER :: IKB,IKE
-INTEGER :: IJN,IJS
-!JUAN ACC
-#endif
-integer :: ji, jj, jk
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_BITREP_OMP
-CALL SBR_FZ(PSRC(:,:,:))
-#endif
-!
-!$acc data present( PSRC, PCR, PRHO, PR, &
-!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_01_Y beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_01_Y beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_01_Y beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IIW=IIB
-IIA=IIE
-!
-GSOUTH=LSOUTH_ll()
-GNORTH=LNORTH_ll()
-!
-#ifndef MNH_OPENACC
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-
-CALL GET_HALO(PSRC, HNAME='PSRC')
-#else
-IJS=1
-IJN=IJU
-IKB=1
-IKE=IKU
-!
-! For HALO >=2 all possible domaine computed
-!
-!IJB=2
-!IJE=IJU-1
-!IIB=2
-!IIE=IIU-1
-!
-CALL GET_HALO_D(PSRC, HDIR="01_Y", HNAME='PSRC')
-#endif
-!
-!-------------------------------------------------------------------------------
-!
-!
-!$acc kernels
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = 1, iju
- do ji = 1, iiu
- PR (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQL (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQR (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZDQ (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQ6 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZDMQ (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQL0 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQR0 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQ60 (ji, jj, jk ) = PSRC(ji, jj, jk )
- end do
- end do
-end do
-#ifndef MNH_OPENACC
-ZFPOS=PSRC
-ZFNEG=PSRC
-#else
-#if 0
-ZFPOS(1:IIW,:,IKB:IKE)=PSRC(1:IIW,:,IKB:IKE)
-ZFNEG(1:IIW,:,IKB:IKE)=PSRC(1:IIW,:,IKB:IKE)
-ZFPOS(IIA:,:,IKB:IKE)=PSRC(IIA:,:,IKB:IKE)
-ZFNEG(IIA:,:,IKB:IKE)=PSRC(IIA:,:,IKB:IKE)
-#else
-ZFPOS(:,:,:) = PSRC(:,:,:)
-ZFNEG(:,:,:) = PSRC(:,:,:)
-#endif
-#endif
-!$acc end kernels
-!
-SELECT CASE ( HLBCY(1) ) ! Y direction LBC type: (1) for left side
-!
-!* 2.1 CYCLIC BOUNDARY CONDITIONS IN THE Y DIRECTION
-! ---------------------------------------------
-!
-CASE ('CYCL','WALL') ! In that case one must have HLBCY(1) == HLBCY(2)
-!
-! calculate dmq
- ZDMQ = DIF2Y(PSRC)
-!
-! monotonize the difference followinq eq. 5 in Lin94
-!BEG JUAN PPM_LL01
-!
-! ZDMQ(j) = Fct[ ZDMQ(j),PSRC(j),PSRC(j-1),PSRC(j+1) ]
-!
-!$acc kernels
- ZDMQ(IIW:IIA,IJB:IJE,:) = &
- SIGN( (MIN( ABS(ZDMQ(IIW:IIA,IJB:IJE,:)),2.0*(PSRC(IIW:IIA,IJB:IJE,:) - &
- MIN(PSRC(IIW:IIA,IJB-1:IJE-1,:),PSRC(IIW:IIA,IJB:IJE,:),PSRC(IIW:IIA,IJB+1:IJE+1,:))), &
- 2.0*(MAX(PSRC(IIW:IIA,IJB-1:IJE-1,:),PSRC(IIW:IIA,IJB:IJE,:),PSRC(IIW:IIA,IJB+1:IJE+1,:)) - &
- PSRC(IIW:IIA,IJB:IJE,:)) )), ZDMQ(IIW:IIA,IJB:IJE,:) )
-!
-! SOUTH BOUND
-!
-!!$ ZDMQ(:,IJB-1,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(:,IJB-1,:)), 2.0*(PSRC(:,IJB-1,:) - &
-!!$ MIN(PSRC(:,IJE-1,:),PSRC(:,IJB-1,:),PSRC(:,IJB,:))), &
-!!$ 2.0*(MAX(PSRC(:,IJE-1,:),PSRC(:,IJB-1,:),PSRC(:,IJB,:)) - &
-!!$ PSRC(:,IJB-1,:)) )), ZDMQ(:,IJB-1,:) )
-!
-! NORTH BOUND
-!
-!!$ ZDMQ(:,IJE+1,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(:,IJE+1,:)), 2.0*(PSRC(:,IJE+1,:) - &
-!!$ MIN(PSRC(:,IJE,:),PSRC(:,IJE+1,:),PSRC(:,IJB+1,:))), &
-!!$ 2.0*(MAX(PSRC(:,IJE,:),PSRC(:,IJE+1,:),PSRC(:,IJB+1,:)) - &
-!!$ PSRC(:,IJE+1,:)) )), ZDMQ(:,IJE+1,:) )
-!
-! update ZDMQ HALO before next/further utilisation
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZDMQ,HDIR="01_Y", HNAME='ZDMQ')
-!$acc kernels
-#endif
-!
-! calculate qL and qR with the modified dmq
-!
-! ZQL0(IIW:IIA,IJB:IJE+1,:) = 0.5*(PSRC(IIW:IIA,IJB:IJE+1,:) + PSRC(IIW:IIA,IJB-1:IJE,:)) - &
-! (ZDMQ(IIW:IIA,IJB:IJE+1,:) - ZDMQ(IIW:IIA,IJB-1:IJE,:))/6.0
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijb, ije + 1
- do ji = iiw, iia
- ZQL0(ji, jj, jk ) = 0.5 * ( PSRC(ji, jj, jk ) + PSRC(ji, jj-1, jk )) - ( ZDMQ(ji, jj, jk ) - ZDMQ(ji, jj-1, jk ) ) / 6.0
- end do
- end do
- end do
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZQL0, HNAME='ZQL0')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='ZQL0')
-!$acc kernels
-#endif
-!
-! SOUTH BOUND
-!
-!!$ ZQL0(:,IJB-1,:) = ZQL0(:,IJE,:) JUAN PPMLL01
-!
- ZQR0(IIW:IIA,IJB-1:IJE,:) = ZQL0(IIW:IIA,IJB:IJE+1,:)
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZQR0, HNAME='ZQR0')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZQR0,HDIR="01_Y", HNAME='ZQR0')
-!$acc kernels
-#endif
-!
-! NORTH BOUND
-!
-!!$ ZQR0(:,IJE+1,:) = ZQR0(:,IJB,:) JUAN PPMLL01
-#ifndef MNH_OPENACC
-!
-! determine initial coefficients of the parabolae
-!
- ZDQ(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:) - ZQL0(IIW:IIA,:,:)
- ZQ60(IIW:IIA,:,:) = 6.0*(PSRC(IIW:IIA,:,:) - 0.5*(ZQL0(IIW:IIA,:,:) + ZQR0(IIW:IIA,:,:)))
-!
-! initialize final parabolae parameters
-!
- ZQL(IIW:IIA,:,:) = ZQL0(IIW:IIA,:,:)
- ZQR(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:)
- ZQ6(IIW:IIA,:,:) = ZQ60(IIW:IIA,:,:)
-!
-! eliminate over and undershoots and create qL and qR as in Lin96
-!
- WHERE ( ZDMQ(IIW:IIA,:,:) == 0.0 )
- ZQL(IIW:IIA,:,:) = PSRC(IIW:IIA,:,:)
- ZQR(IIW:IIA,:,:) = PSRC(IIW:IIA,:,:)
- ZQ6(IIW:IIA,:,:) = 0.0
- ELSEWHERE ( ZQ60(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) < -ZDQ(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) )
- ZQ6(IIW:IIA,:,:) = 3.0*(ZQL0(IIW:IIA,:,:) - PSRC(IIW:IIA,:,:))
- ZQR(IIW:IIA,:,:) = ZQL0(IIW:IIA,:,:) - ZQ6(IIW:IIA,:,:)
- ZQL(IIW:IIA,:,:) = ZQL0(IIW:IIA,:,:)
- ELSEWHERE ( ZQ60(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) > ZDQ(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) )
- ZQ6(IIW:IIA,:,:) = 3.0*(ZQR0(IIW:IIA,:,:) - PSRC(IIW:IIA,:,:))
- ZQL(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:) - ZQ6(IIW:IIA,:,:)
- ZQR(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:)
- END WHERE
-!
-! recalculate coefficients of the parabolae
-!
- ZDQ(IIW:IIA,:,:) = ZQR(IIW:IIA,:,:) - ZQL(IIW:IIA,:,:)
-#else
-!$acc loop independent collapse(3)
- DO K=IKB,IKE
- DO J=IJS,IJN
- DO I=1,IIU
- !
- ! determine initial coefficients of the parabolae
- !
- ZDQ(I,J,K) = ZQR0(I,J,K) - ZQL0(I,J,K)
- ZQ60(I,J,K) = 6.0*(PSRC(I,J,K) - 0.5*(ZQL0(I,J,K) + ZQR0(I,J,K)))
- !
- ! initialize final parabolae parameters
- !
- ZQL(I,J,K) = ZQL0(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- ZQ6(I,J,K) = ZQ60(I,J,K)
- !
- ! eliminate over and undershoots and create qL and qR as in Lin96
- !
- IF ( ZDMQ(I,J,K) == 0.0 ) THEN
- ZQL(I,J,K) = PSRC(I,J,K)
- ZQR(I,J,K) = PSRC(I,J,K)
- ZQ6(I,J,K) = 0.0
- ELSE IF ( ZQ60(I,J,K)*ZDQ(I,J,K) < -ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQL0(I,J,K) - PSRC(I,J,K))
- ZQR(I,J,K) = ZQL0(I,J,K) - ZQ6(I,J,K)
- ZQL(I,J,K) = ZQL0(I,J,K)
- ELSE IF ( ZQ60(I,J,K)*ZDQ(I,J,K) > ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQR0(I,J,K) - PSRC(I,J,K))
- ZQL(I,J,K) = ZQR0(I,J,K) - ZQ6(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- END IF
- !
- ! recalculate coefficients of the parabolae
- !
- ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
- !
- END DO
- END DO
- END DO
-#endif
-!
-! and finally calculate fluxes for the advection
-!
-! ZFPOS(j) = Fct[ ZQR(j-1),PCR(i),ZDQ(j-1),ZQ6(j-1) ]
-!
- ZFPOS(IIW:IIA,IJB:IJE+1,:) = ZQR(IIW:IIA,IJB-1:IJE,:) - 0.5*PCR(IIW:IIA,IJB:IJE+1,:) * &
- (ZDQ(IIW:IIA,IJB-1:IJE,:) - (1.0 - 2.0*PCR(IIW:IIA,IJB:IJE+1,:)/3.0) &
- * ZQ6(IIW:IIA,IJB-1:IJE,:))
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZFPOS,HDIR="01_Y", HNAME='ZFPOS')
-!$acc kernels
-#endif
-!
-! SOUTH BOUND
-!
-! PPOSX(:,IJB-1,:) is not important for the calc of advection so
-! we set it to 0
-!!$ ZFPOS(:,IJB-1,:) = 0.0 JUANPPMLL01
-!
- ZFNEG(IIW:IIA,:,:) = ZQL(IIW:IIA,:,:) - 0.5*PCR(IIW:IIA,:,:) * &
- ( ZDQ(IIW:IIA,:,:) + (1.0 + 2.0*PCR(IIW:IIA,:,:)/3.0) * ZQ6(IIW:IIA,:,:) )
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZFNEG,HDIR="01_Y", HNAME='ZFNEG')
-#endif
-!
-! advect the actual field in Y direction by V*dt
-!
-#ifndef MNH_OPENACC
- PR = DYF( PCR*MYM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
- CALL MYM_DEVICE(PRHO,ZQL)
-!$acc kernels
-!$acc loop independent collapse(3)
- DO K=IKB,IKE
- DO J=IJS,IJN
- DO I=1,IIU
- if ( PCR(I,J,K) > 0. ) then
- ZQR(I,J,K) = PCR(I,J,K)* ZQL(I,J,K) * ZFPOS(I,J,K)
- else
- ZQR(I,J,K) = PCR(I,J,K)* ZQL(I,J,K) * ZFNEG(I,J,K)
- end if
- END DO
- END DO
- END DO
-!$acc end kernels
- CALL DYF_DEVICE(ZQR,PR)
-#endif
-#ifndef MNH_OPENACC
- CALL GET_HALO(PR, HNAME='PR')
-#else
- CALL GET_HALO_D(PR,HDIR="01_Y", HNAME='PR')
-#endif
-!
-!* 2.2 NON-CYCLIC BOUNDARY CONDITIONS IN THE Y DIRECTION
-! -------------------------------------------------
-!
-CASE('OPEN')
-!
-! calculate dmq
-#ifndef MNH_OPENACC
- ZDMQ = DIF2Y(PSRC)
-#else
- CALL DIF2Y_DEVICE(ZDMQ,PSRC)
-#endif
-!$acc kernels
-! overwrite the values on the boundary to get second order difference
-! for qL and qR at the boundary
-!
-! SOUTH BOUND
-!
- IF (GSOUTH) THEN
- ZDMQ(IIW:IIA,IJB-1,:) = -ZDMQ(IIW:IIA,IJB,:)
- ENDIF
-!
-! NORTH BOUND
-!
- IF (GNORTH) THEN
- ZDMQ(IIW:IIA,IJE+1,:) = -ZDMQ(IIW:IIA,IJE,:)
- ENDIF
-!
-! monotonize the difference followinq eq. 5 in Lin94
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijb, ije
- do ji = iiw, iia
- ZDMQ(ji, jj, jk ) = SIGN( &
- MIN( ABS( ZDMQ(ji, jj, jk ) ), &
- 2.0 * ( PSRC(ji, jj, jk ) - MIN( PSRC(ji, jj-1, jk ), PSRC(ji, jj, jk ), PSRC(ji, jj+1, jk ) ) ), &
- 2.0 * ( - PSRC(ji, jj, jk ) + MAX( PSRC(ji, jj-1, jk ), PSRC(ji, jj, jk ), PSRC(ji, jj+1, jk ) ) ) ), &
- ZDMQ(ji, jj, jk ) )
- end do
- end do
-end do
-!!$ ZDMQ(:,IJB-1,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(:,IJB-1,:)), 2.0*(PSRC(:,IJB-1,:) - &
-!!$ MIN(PSRC(:,IJE-1,:),PSRC(:,IJB-1,:),PSRC(:,IJB,:))), &
-!!$ 2.0*(MAX(PSRC(:,IJE-1,:),PSRC(:,IJB-1,:),PSRC(:,IJB,:)) - &
-!!$ PSRC(:,IJB-1,:)) )), ZDMQ(:,IJB-1,:) )
-!!$ ZDMQ(:,IJE+1,:) = &
-!!$ SIGN( (MIN( ABS(ZDMQ(:,IJE+1,:)), 2.0*(PSRC(:,IJE+1,:) - &
-!!$ MIN(PSRC(:,IJE,:),PSRC(:,IJE+1,:),PSRC(:,IJB+1,:))), &
-!!$ 2.0*(MAX(PSRC(:,IJE,:),PSRC(:,IJE+1,:),PSRC(:,IJB+1,:)) - &
-!!$ PSRC(:,IJE+1,:)) )), ZDMQ(:,IJE+1,:) )
-!
-! update ZDMQ HALO before next/further utilisation
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZDMQ, HNAME='ZDMQ')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZDMQ,HDIR="01_Y", HNAME='ZDMQ')
-!$acc kernels
-#endif
-!
-! calculate qL and qR with the modified dmq
-!
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijb, ije + 1
- do ji = iiw, iia
- ZQL0(ji, jj, jk ) = 0.5 * ( PSRC(ji, jj, jk ) + PSRC(ji, jj-1, jk )) - ( ZDMQ(ji, jj, jk ) - ZDMQ(ji, jj-1, jk ) ) / 6.0
- end do
- end do
- end do
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZQL0, HNAME='ZQL0')
-#else
-!$acc end kernels
-CALL GET_HALO_D(ZQL0,HDIR="01_Y", HNAME='ZQL0')
-!$acc kernels
-#endif
-!
-! SOUTH BOUND
-!
- IF (GSOUTH) THEN
- ZQL0(IIW:IIA,IJB-1,:) = ZQL0(IIW:IIA,IJB,:)
- ENDIF
-!
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijb - 1, ije
- do ji = iiw, iia
- ZQR0(ji, jj, jk ) = ZQL0(ji, jj+1, jk )
- end do
- end do
- end do
-!
-! NORTH BOUND
-!
- IF (GNORTH) THEN
- ZQR0(IIW:IIA,IJE+1,:) = ZQR0(IIW:IIA,IJE,:)
- ENDIF
-#ifndef MNH_OPENACC
-!
-! determine initial coefficients of the parabolae
-!
- ZDQ(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:) - ZQL0(IIW:IIA,:,:)
- ZQ60(IIW:IIA,:,:) = 6.0*(PSRC(IIW:IIA,:,:) - 0.5*(ZQL0(IIW:IIA,:,:) + ZQR0(IIW:IIA,:,:)))
-!
-! initialize final parabolae parameters
-!
- ZQL(IIW:IIA,:,:) = ZQL0(IIW:IIA,:,:)
- ZQR(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:)
- ZQ6(IIW:IIA,:,:) = ZQ60(IIW:IIA,:,:)
-!
-! eliminate over and undershoots and create qL and qR as in Lin96
-!
- WHERE ( ZDMQ(IIW:IIA,:,:) == 0.0 )
- ZQL(IIW:IIA,:,:) = PSRC(IIW:IIA,:,:)
- ZQR(IIW:IIA,:,:) = PSRC(IIW:IIA,:,:)
- ZQ6(IIW:IIA,:,:) = 0.0
- ELSEWHERE ( ZQ60(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) < -ZDQ(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) )
- ZQ6(IIW:IIA,:,:) = 3.0*(ZQL0(IIW:IIA,:,:) - PSRC(IIW:IIA,:,:))
- ZQR(IIW:IIA,:,:) = ZQL0(IIW:IIA,:,:) - ZQ6(IIW:IIA,:,:)
- ZQL(IIW:IIA,:,:) = ZQL0(IIW:IIA,:,:)
- ELSEWHERE ( ZQ60(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) > ZDQ(IIW:IIA,:,:)*ZDQ(IIW:IIA,:,:) )
- ZQ6(IIW:IIA,:,:) = 3.0*(ZQR0(IIW:IIA,:,:) - PSRC(IIW:IIA,:,:))
- ZQL(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:) - ZQ6(IIW:IIA,:,:)
- ZQR(IIW:IIA,:,:) = ZQR0(IIW:IIA,:,:)
- END WHERE
-!
-! recalculate coefficients of the parabolae
-!
- ZDQ(IIW:IIA,:,:) = ZQR(IIW:IIA,:,:) - ZQL(IIW:IIA,:,:)
-!
-#else
-!$acc loop independent collapse(3)
- DO K=IKB,IKE
- DO J=IJS,IJN
- DO I=1,IIU
- !
- ! determine initial coefficients of the parabolae
- !
- ZDQ(I,J,K) = ZQR0(I,J,K) - ZQL0(I,J,K)
- ZQ60(I,J,K) = 6.0*(PSRC(I,J,K) - 0.5*(ZQL0(I,J,K) + ZQR0(I,J,K)))
- !
- ! initialize final parabolae parameters
- !
- ZQL(I,J,K) = ZQL0(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- ZQ6(I,J,K) = ZQ60(I,J,K)
- !
- ! eliminate over and undershoots and create qL and qR as in Lin96
- !
- IF ( ZDMQ(I,J,K) == 0.0 ) THEN
- ZQL(I,J,K) = PSRC(I,J,K)
- ZQR(I,J,K) = PSRC(I,J,K)
- ZQ6(I,J,K) = 0.0
- ELSE IF ( ZQ60(I,J,K)*ZDQ(I,J,K) < -ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQL0(I,J,K) - PSRC(I,J,K))
- ZQR(I,J,K) = ZQL0(I,J,K) - ZQ6(I,J,K)
- ZQL(I,J,K) = ZQL0(I,J,K)
- ELSE IF ( ZQ60(I,J,K)*ZDQ(I,J,K) > ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQR0(I,J,K) - PSRC(I,J,K))
- ZQL(I,J,K) = ZQR0(I,J,K) - ZQ6(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- END IF
- !
- ! recalculate coefficients of the parabolae
- !
- ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
- !
- END DO
- END DO
- END DO
-#endif
-!
-! and finally calculate fluxes for the advection
-!
-!!$ ZFPOS(:,IJB+1:IJE+1,:) = ZQR(:,IJB:IJE,:) - 0.5*PCR(:,IJB+1:IJE+1,:) * &
-!!$ (ZDQ(:,IJB:IJE,:) - (1.0 - 2.0*PCR(:,IJB+1:IJE+1,:)/3.0) &
-!!$ * ZQ6(:,IJB:IJE,:))
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = ijb, ije + 1
- do ji = iiw, iia
- ZFPOS(ji, jj, jk ) = ZQR(ji, jj-1, jk ) - 0.5 * PCR(ji, jj, jk ) &
- * ( ZDQ(ji, jj-1, jk ) - ( 1.0 - 2.0 * PCR(ji, jj, jk ) / 3.0 ) * ZQ6(ji, jj-1, jk ) )
- end do
- end do
- end do
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFPOS, HNAME='ZFPOS')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZFPOS,HDIR="01_Y", HNAME='ZFPOS')
-!$acc kernels
-#endif
-!
-!
-! advection flux at open boundary when u(IJB) > 0
-!
-! SOUTH BOUND
-!
- IF (GSOUTH) THEN
- ZFPOS(IIW:IIA,IJB,:) = (PSRC(IIW:IIA,IJB-1,:) - ZQR(IIW:IIA,IJB-1,:))*PCR(IIW:IIA,IJB,:) + &
- ZQR(IIW:IIA,IJB-1,:)
- ENDIF
-!
-! PPOSX(:,IJB-1,:) is not important for the calc of advection so
-! we set it to 0
-!!$ ZFPOS(:,IJB-1,:) = 0.0 ! JUAN PPMLL01
-!
-!!$ ZFNEG(:,IJB-1:IJE,:) = ZQL(:,IJB-1:IJE,:) - 0.5*PCR(:,IJB-1:IJE,:) * &
-!!$ ( ZDQ(:,IJB-1:IJE,:) + (1.0 + 2.0*PCR(:,IJB-1:IJE,:)/3.0) * &
-!!$ ZQ6(:,IJB-1:IJE,:) )
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = 1, iju
- do ji = iiw, iia
- ZFNEG(ji, jj, jk ) = ZQL(ji, jj, jk ) - 0.5 * PCR(ji, jj, jk ) &
- * ( ZDQ(ji, jj, jk ) + ( 1.0 + 2.0 * PCR(ji, jj, jk ) / 3.0 ) * ZQ6(ji, jj, jk ) )
- end do
- end do
- end do
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFNEG, HNAME='ZFNEG')
-#else
-!$acc end kernels
- CALL GET_HALO_D(ZFNEG,HDIR="01_Y", HNAME='ZFNEG')
-!$acc kernels
-#endif
-!
-! advection flux at open boundary when u(IJE+1) < 0
-!
-! NORTH BOUND
-!
- IF (GNORTH) THEN
- ZFNEG(IIW:IIA,IJE+1,:) = (ZQR(IIW:IIA,IJE,:)-PSRC(IIW:IIA,IJE+1,:))*PCR(IIW:IIA,IJE+1,:) + &
- ZQR(IIW:IIA,IJE,:)
- ENDIF
-#ifndef MNH_OPENACC
-!
-! advect the actual field in X direction by U*dt
-!
- PR = DYF( PCR*MYM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-!
-#else
-!$acc end kernels
- CALL MYM_DEVICE(PRHO,ZQL)
-!$acc kernels
-!$acc loop independent collapse(3)
- DO K=IKB,IKE
- DO J=IJS,IJN
- DO I=1,IIU
- if ( PCR(I,J,K) > 0. ) then
- ZQR(I,J,K) = PCR(I,J,K)* ZQL(I,J,K) * ZFPOS(I,J,K)
- else
- ZQR(I,J,K) = PCR(I,J,K)* ZQL(I,J,K) * ZFNEG(I,J,K)
- end if
- END DO
- END DO
- END DO
-!$acc end kernels
- CALL DYF_DEVICE(ZQR,PR)
-#endif
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(PR, HNAME='PR')
-#else
- CALL GET_HALO_D(PR,HDIR="01_Y", HNAME='PR')
-#endif
-!
-!
-END SELECT
-!
-#ifdef MNH_BITREP_OMP
-CALL SBR_FZ(PR(:,:,:))
-#endif
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_01_Y end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_01_Y end:PR")
-END IF
-
-!$acc end data
-
-#ifndef MNH_OPENACC
-CONTAINS
-#else
-END SUBROUTINE PPM_01_Y_D
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-! ########################################################################
- FUNCTION DIF2Y(PQ) RESULT(DQ)
-! ########################################################################
-!!
-!!**** DIF2Y - leap-frog difference operator in Y direction
-!!
-!! Calculates the difference assuming periodic BC (CYCL).
-!!
-!! DQ(J) = 0.5 * (PQ(J+1) - PQ(J-1))
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 18.3.2006. T. Maric - original version, works only for periodic boundary
-!! conditions and on one domain
-!! 04/2017 J.Escobar : initialize realistic value in all HALO pts
-!!
-!-------------------------------------------------------------------------------
-!
-!
-USE MODE_ll
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)) :: DQ
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IIB,IJB ! Begining useful area in x,y directions
-INTEGER :: IIE,IJE ! End useful area in x,y directions
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present(PQ, DQ)
-!
-!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
-! -----------------------------
-!
-!!$CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IIB=2 ; IIE = SIZE(PQ,1) -1
-IJB=2 ; IJE = SIZE(PQ,2) -1
-!
-!-------------------------------------------------------------------------------
-!
-!* 2.0. COMPUTE THE DIFFERENCE
-! ----------------------
-!
-!$acc kernels
-DQ(:,IJB:IJE,:) = PQ(:,IJB+1:IJE+1,:) - PQ(:,IJB-1:IJE-1,:)
-DQ(:,IJB-1,:) = PQ(:,IJB,:) - PQ(:,IJE-1,:)
-DQ(:,IJE+1,:) = PQ(:,IJB+1,:) - PQ(:,IJE,:)
-DQ = 0.5 * DQ
-!$acc end kernels
-
-!$acc end data
-
-END FUNCTION DIF2Y
-!-------------------------------------------------------------------------------
-!
-! ########################################################################
- SUBROUTINE DIF2Y_DEVICE(DQ,PQ)
-! ########################################################################
-!!
-!!**** DIF2Y - leap-frog difference operator in Y direction
-!!
-!! Calculates the difference assuming periodic BC (CYCL).
-!!
-!! DQ(J) = 0.5 * (PQ(J+1) - PQ(J-1))
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 18.3.2006. T. Maric - original version, works only for periodic boundary
-!! conditions and on one domain
-!! 04/2017 J.Escobar : initialize realistic value in all HALO pts
-!!
-!-------------------------------------------------------------------------------
-!
-!
-USE MODE_ll
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(:,:,:) :: DQ
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IIB,IJB ! Begining useful area in x,y directions
-INTEGER :: IIE,IJE ! End useful area in x,y directions
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present(PQ, DQ)
-!
-!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
-! -----------------------------
-!
-!!$CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IIB=2 ; IIE = SIZE(PQ,1) -1
-IJB=2 ; IJE = SIZE(PQ,2) -1
-!
-!-------------------------------------------------------------------------------
-!
-!* 2.0. COMPUTE THE DIFFERENCE
-! ----------------------
-!
-!$acc kernels
-DQ(:,IJB:IJE,:) = PQ(:,IJB+1:IJE+1,:) - PQ(:,IJB-1:IJE-1,:)
-DQ(:,IJB-1,:) = PQ(:,IJB,:) - PQ(:,IJE-1,:)
-DQ(:,IJE+1,:) = PQ(:,IJB+1,:) - PQ(:,IJE,:)
-DQ = 0.5 * DQ
-!$acc end kernels
-
-!$acc end data
-
-END SUBROUTINE DIF2Y_DEVICE
-! #endif
-!
-#ifdef MNH_OPENACC
-! END SUBROUTINE PPM_01_Y_D
-
-END SUBROUTINE PPM_01_Y
-#else
-END FUNCTION PPM_01_Y
-#endif
-!
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-!!$ FUNCTION PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) RESULT(PR)
- SUBROUTINE PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-! ########################################################################
-
- USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
- USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
-
- IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR & ! Courant number
- , PRHO ! density
-!
-! output source term
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-
-INTEGER :: IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG
-
-!$acc data present( PSRC, PCR, PRHO, PR )
-
- CALL MNH_GET_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
-
- CALL PPM_01_Z_D(IIU,IJU,IKU, KGRID, &
- & PSRC, PCR, PRHO, PTSTEP, PR, &
- & ZT3D(:,:,:,IZQL),ZT3D(:,:,:,IZQR),ZT3D(:,:,:,IZDQ),ZT3D(:,:,:,IZQ6), &
- & ZT3D(:,:,:,IZDMQ),ZT3D(:,:,:,IZQL0),ZT3D(:,:,:,IZQR0), ZT3D(:,:,:,IZQ60), &
- & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG) )
-
- CALL MNH_REL_ZT3D(IZQL,IZQR,IZDQ,IZQ6,IZDMQ,IZQL0,IZQR0,IZQ60,IZFPOS,IZFNEG)
-
-!$acc end data
-
-CONTAINS
-!
-! ########################################################################
- SUBROUTINE PPM_01_Z_D(IIU,IJU,IKU,KGRID, &
- & PSRC, PCR, PRHO, PTSTEP, PR, &
- & ZQL,ZQR,ZDQ,ZQ6,ZDMQ,ZQL0,ZQR0,ZQ60,ZFPOS,ZFNEG)
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_01_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_01_Z - PPM_01 fully monotonic PPM advection scheme in Z direction
-!! Colella notation
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 11.5.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODE_ll
-
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-USE MODI_GET_HALO
-#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
-USE MODI_BITREP
-#endif
-#ifdef MNH_BITREP_OMP
-USE MODI_BITREPZ
-#endif
-!
-USE MODD_CONF
-USE MODD_PARAMETERS
-!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-USE MODE_MPPDB
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-#ifdef MNH_OPENACC
-integer, intent(in) :: iiu, iju, iku
-#endif
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-#ifndef MNH_OPENACC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
-#else
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-#endif
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(IIU,IJU,IKU), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-#ifndef MNH_OPENACC
-INTEGER :: IIU, IJU, IKU
-INTEGER:: IKB ! Begining useful area in x,y,z directions
-INTEGER:: IKE ! End useful area in x,y,z directions
-!
-! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL,ZQR
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDQ,ZQ6
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZDMQ
-!
-! extra variables for the initial guess of parabolae parameters
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZQL0,ZQR0,ZQ60
-!
-! advection fluxes
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
-#else
-! terms used in parabolic interpolation, dmq, qL, qR, dq, q6
-REAL, DIMENSION(IIU,IJU,IKU) :: &
- ZQL, ZQR, ZDQ, ZQ6, ZDMQ &
-!
-! extra variables for the initial guess of parabolae parameters
- , ZQL0,ZQR0,ZQ60 &
-!
-! advection fluxes
- , ZFPOS, ZFNEG
-!
-INTEGER:: IKB ! Begining useful area in x,y,z directions
-INTEGER:: IKE ! End useful area in x,y,z directions
-!
-INTEGER :: I,J,K
-#endif
-integer :: ji, jj, jk
-!
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_BITREP_OMP
-CALL SBR_FZ(PSRC(:,:,:))
-#endif
-!
-!$acc data present( PSRC, PCR, PRHO, PR, &
-!$acc & ZQL, ZQR, ZDQ, ZQ6, ZDMQ, ZQL0, ZQR0, ZQ60, ZFPOS, ZFNEG )
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_01_Z beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_01_Z beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_01_Z beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-IKB = 1 + JPVEXT
-IKE = SIZE(PSRC,3) - JPVEXT
-#ifndef MNH_OPENACC
-iiu = size( PSRC, 1 )
-iju = size( PSRC, 2 )
-iku = size( PSRC, 3 )
-#endif
-
-!$acc kernels
-!$acc loop independent collapse(3)
- do jk = 1, iku
- do jj = 1, iju
- do ji = 1, iiu
- PR (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQL (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQR (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZDQ (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQ6 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZDMQ (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQL0 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQR0 (ji, jj, jk ) = PSRC(ji, jj, jk )
- ZQ60 (ji, jj, jk ) = PSRC(ji, jj, jk )
- end do
- end do
-end do
-#ifndef MNH_OPENACC
-ZFPOS=PSRC
-ZFNEG=PSRC
-#else
-#if 0
-ZFPOS(1:IIW,:,IKB:IKE)=PSRC(1:IIW,:,IKB:IKE)
-ZFNEG(1:IIW,:,IKB:IKE)=PSRC(1:IIW,:,IKB:IKE)
-ZFPOS(IIA:,:,IKB:IKE)=PSRC(IIA:,:,IKB:IKE)
-ZFNEG(IIA:,:,IKB:IKE)=PSRC(IIA:,:,IKB:IKE)
-#else
-ZFPOS(:,:,:) = PSRC(:,:,:)
-ZFNEG(:,:,:) = PSRC(:,:,:)
-#endif
-#endif
-!$acc end kernels
-!
-!-------------------------------------------------------------------------------
-!
-!* 3. PPM ADVECTION IN THE Z DIRECTION
-! --------------------------------
-!
-! calculate dmq
-#ifndef MNH_OPENACC
-ZDMQ = DIF2Z(PSRC)
-#else
-CALL DIF2Z_DEVICE(ZDMQ,PSRC)
-#endif
-!$acc kernels
-!
-! monotonize the difference followinq eq. 5 in Lin94
-! use the periodic BC here, it doesn't matter for vertical (hopefully)
-!
-!$acc loop independent collapse(3)
-do jk = ikb, ike
- do jj = 1, iju
- do ji = 1, iiu
- ZDMQ(ji, jj, jk ) = SIGN( &
- MIN( ABS( ZDMQ(ji, jj, jk ) ), &
- 2.0 * ( PSRC(ji, jj, jk ) - MIN( PSRC(ji, jj, jk-1 ), PSRC(ji, jj, jk ), PSRC(ji, jj, jk+1 ) ) ) , &
- 2.0 * ( - PSRC(ji, jj, jk ) + MAX( PSRC(ji, jj, jk-1 ), PSRC(ji, jj, jk ), PSRC(ji, jj, jk+1 ) ) ) ), &
- ZDMQ(ji, jj, jk ) )
- end do
- end do
-end do
-ZDMQ(:,:,IKB-1) = &
- SIGN( (MIN( ABS(ZDMQ(:,:,IKB-1)), 2.0*(PSRC(:,:,IKB-1) - &
- MIN(PSRC(:,:,IKE-1),PSRC(:,:,IKB-1),PSRC(:,:,IKB))), &
- 2.0*(MAX(PSRC(:,:,IKE-1),PSRC(:,:,IKB-1),PSRC(:,:,IKB)) - &
- PSRC(:,:,IKB-1)) )), ZDMQ(:,:,IKB-1) )
-ZDMQ(:,:,IKE+1) = &
- SIGN( (MIN( ABS(ZDMQ(:,:,IKE+1)), 2.0*(PSRC(:,:,IKE+1) - &
- MIN(PSRC(:,:,IKE),PSRC(:,:,IKE+1),PSRC(:,:,IKB+1))), &
- 2.0*(MAX(PSRC(:,:,IKE),PSRC(:,:,IKE+1),PSRC(:,:,IKB+1)) - &
- PSRC(:,:,IKE+1)) )), ZDMQ(:,:,IKE+1) )
-!
-! calculate qL and qR with the modified dmq
-!
-!$acc loop independent collapse(3)
-do jk = ikb, ike + 1
- do jj = 1, iju
- do ji = 1, iiu
- ZQL0(ji, jj, jk ) = 0.5 * ( PSRC(ji, jj, jk ) + PSRC(ji, jj, jk-1 ) ) - ( ZDMQ(ji, jj, jk ) - ZDMQ(ji, jj, jk-1 ) ) / 6.0
- end do
- end do
-end do
-ZQL0(:,:,IKB-1) = ZQL0(:,:,IKE)
-!
-!$acc loop independent collapse(3)
-do jk = ikb - 1, ike
- do jj = 1, iju
- do ji = 1, iiu
- ZQR0(ji, jj, jk ) = ZQL0(ji, jj, jk+1 )
- end do
- end do
-end do
-ZQR0(:,:,IKE+1) = ZQR0(:,:,IKB)
-#ifndef MNH_OPENACC
-!
-! determine initial coefficients of the parabolae
-!
-!Note: do loop on jk is done from 1 to iku to prevent problems with unitialized value
-! in the next "where"
-! do jk = ikb - 1, ike
-do jk = 1, iku
- do jj = 1, iju
- do ji = 1, iiu
- ZDQ (ji, jj, jk ) = ZQR0(ji, jj, jk ) - ZQL0(ji, jj, jk )
- ZQ60(ji, jj, jk ) = 6.0 * ( PSRC(ji, jj, jk ) - 0.5 * ( ZQL0(ji, jj, jk ) + ZQR0(ji, jj, jk ) ) )
- end do
- end do
-end do
-!
-! initialize final parabolae parameters
-!
-ZQL = ZQL0
-ZQR = ZQR0
-ZQ6 = ZQ60
-!
-! eliminate over and undershoots and create qL and qR as in Lin96
-!
-WHERE ( ZDMQ == 0.0 )
- ZQL = PSRC
- ZQR = PSRC
- ZQ6 = 0.0
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-ELSEWHERE ( ZQ60*ZDQ < -(ZDQ)**2 )
-#else
-ELSEWHERE ( ZQ60*ZDQ < -BR_P2(ZDQ) )
-#endif
- ZQ6 = 3.0*(ZQL0 - PSRC)
- ZQR = ZQL0 - ZQ6
- ZQL = ZQL0
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-ELSEWHERE ( ZQ60*ZDQ > (ZDQ)**2 )
-#else
-ELSEWHERE ( ZQ60*ZDQ > BR_P2(ZDQ) )
-#endif
- ZQ6 = 3.0*(ZQR0 - PSRC)
- ZQL = ZQR0 - ZQ6
- ZQR = ZQR0
-END WHERE
-!
-! recalculate coefficients of the parabolae
-!
-ZDQ = ZQR - ZQL
-#else
-!$acc loop independent collapse(3)
- DO K=1,IKU
- DO J=1,IJU
- DO I=1,IIU
- !
- ! determine initial coefficients of the parabolae
- !
- ZDQ(I,J,K) = ZQR0(I,J,K) - ZQL0(I,J,K)
- ZQ60(I,J,K) = 6.0*(PSRC(I,J,K) - 0.5*(ZQL0(I,J,K) + ZQR0(I,J,K)))
- !
- ! initialize final parabolae parameters
- !
- ZQL(I,J,K) = ZQL0(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- ZQ6(I,J,K) = ZQ60(I,J,K)
- !
- ! eliminate over and undershoots and create qL and qR as in Lin96
- !
- IF ( ZDMQ(I,J,K) == 0.0 ) THEN
- ZQL(I,J,K) = PSRC(I,J,K)
- ZQR(I,J,K) = PSRC(I,J,K)
- ZQ6(I,J,K) = 0.0
- ELSE IF ( ZQ60(I,J,K)*ZDQ(I,J,K) < -ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQL0(I,J,K) - PSRC(I,J,K))
- ZQR(I,J,K) = ZQL0(I,J,K) - ZQ6(I,J,K)
- ZQL(I,J,K) = ZQL0(I,J,K)
- ELSE IF ( ZQ60(I,J,K)*ZDQ(I,J,K) > ZDQ(I,J,K)*ZDQ(I,J,K) ) THEN
- ZQ6(I,J,K) = 3.0*(ZQR0(I,J,K) - PSRC(I,J,K))
- ZQL(I,J,K) = ZQR0(I,J,K) - ZQ6(I,J,K)
- ZQR(I,J,K) = ZQR0(I,J,K)
- END IF
- !
- ! recalculate coefficients of the parabolae
- !
- ZDQ(I,J,K) = ZQR(I,J,K) - ZQL(I,J,K)
- !
- END DO
- END DO
- END DO
-#endif
-!
-! and finally calculate fluxes for the advection
-!
-!$acc loop independent collapse(3)
-do jk = ikb + 1, ike + 1
- do jj = 1, iju
- do ji = 1, iiu
- ZFPOS(ji, jj, jk ) = ZQR(ji, jj, jk-1 ) - 0.5 * PCR(ji, jj, jk ) &
- * ( ZDQ(ji, jj, jk-1 ) - ( 1.0 - 2.0 * PCR(ji, jj, jk ) / 3.0) * ZQ6(ji, jj, jk-1 ) )
- end do
- end do
-end do
-!
-! advection flux at open boundary when u(IKB) > 0
-ZFPOS(:,:,IKB) = (PSRC(:,:,IKB-1) - ZQR(:,:,IKB-1))*PCR(:,:,IKB) + &
- ZQR(:,:,IKB-1)
-!
-! PPOSX(IKB-1) is not important for the calc of advection so
-! we set it to 0
-ZFPOS(:,:,IKB-1) = 0.0
-!
-!$acc loop independent collapse(3)
-do jk = ikb - 1, ike
- do jj = 1, iju
- do ji = 1, iiu
- ZFNEG(ji, jj, jk ) = ZQL(ji, jj, jk ) - 0.5 * PCR(ji, jj, jk ) &
- * ( ZDQ(ji, jj, jk ) + ( 1.0 + 2.0 * PCR(ji, jj, jk ) / 3.0) * ZQ6(ji, jj, jk ) )
- end do
- end do
-end do
-!
-! advection flux at open boundary when u(IKE+1) < 0
-ZFNEG(:,:,IKE+1) = (ZQR(:,:,IKE)-PSRC(:,:,IKE+1))*PCR(:,:,IKE+1) + &
- ZQR(:,:,IKE)
-!
-! advect the actual field in Z direction by W*dt
-!
-#ifndef MNH_OPENACC
-PR = DZF( PCR*MZM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
-!$acc end kernels
- CALL MZM_DEVICE(PRHO,ZQL)
-!$acc kernels
-!$acc loop independent collapse(3)
-do jk = 1, iku
- do jj = 1, iju
- do ji = 1, iiu
- if ( PCR(ji, jj, jk ) > 0. ) then
- ZQR(ji, jj, jk ) = PCR(ji, jj, jk ) * ZQL(ji, jj, jk ) * ZFPOS(ji, jj, jk )
- else
- ZQR(ji, jj, jk ) = PCR(ji, jj, jk ) * ZQL(ji, jj, jk ) * ZFNEG(ji, jj, jk )
- end if
- end do
- end do
-end do
- !dzf(PR,ZQR)
-!$acc end kernels
- CALL DZF_DEVICE(ZQR,PR)
-#endif
-!
-#ifndef MNH_OPENACC
-!Unnecessary CALL GET_HALO(PR)
-#else
-!Unnecessary CALL GET_HALO_D(PR)
-#endif
-!
-#ifdef MNH_BITREP_OMP
-CALL SBR_FZ(PR(:,:,:))
-#endif
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_01_Z end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_01_Z end:PR")
-END IF
-
-!$acc end data
-
-#ifndef MNH_OPENACC
-CONTAINS
-#else
-END SUBROUTINE PPM_01_Z_D
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-! ########################################################################
- FUNCTION DIF2Z(PQ) RESULT(DQ)
-! ########################################################################
-!!
-!!**** DIF2Z - leap-frog difference operator in Z direction
-!!
-!! Calculates the difference assuming periodic BC (CYCL).
-!!
-!! DQ(K) = 0.5 * (PQ(K+1) - PQ(K-1))
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 18.3.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-!
-USE MODE_ll
-USE MODD_CONF
-USE MODD_PARAMETERS
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(SIZE(PQ,1),SIZE(PQ,2),SIZE(PQ,3)) :: DQ
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IKB ! Begining useful area in z directions
-INTEGER :: IKE ! End useful area in z directions
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PQ, DQ )
-!
-!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
-! -----------------------------
-!
-!CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKB = 1 + JPVEXT
-IKE = SIZE(PQ,3) - JPVEXT
-!
-!-------------------------------------------------------------------------------
-!
-!* 2.0. COMPUTE THE DIFFERENCE
-! ----------------------
-!
-!$acc kernels
-DQ(:,:,IKB:IKE) = PQ(:,:,IKB+1:IKE+1) - PQ(:,:,IKB-1:IKE-1)
-DQ(:,:,IKB-1) = -DQ(:,:,IKB)
-DQ(:,:,IKE+1) = -DQ(:,:,IKE)
-DQ = 0.5 * DQ
-!$acc end kernels
-
-!$acc end data
-
-END FUNCTION DIF2Z
-!-------------------------------------------------------------------------------
-!
-! ########################################################################
- SUBROUTINE DIF2Z_DEVICE(DQ,PQ)
-! ########################################################################
-!!
-!!**** DIF2Z - leap-frog difference operator in Z direction
-!!
-!! Calculates the difference assuming periodic BC (CYCL).
-!!
-!! DQ(K) = 0.5 * (PQ(K+1) - PQ(K-1))
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 18.3.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-!
-USE MODE_ll
-USE MODD_CONF
-USE MODD_PARAMETERS
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PQ
-REAL, DIMENSION(:,:,:) :: DQ
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IKB ! Begining useful area in z directions
-INTEGER :: IKE ! End useful area in z directions
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PQ, DQ )
-!
-!* 1.0. COMPUTE THE DOMAIN DIMENSIONS
-! -----------------------------
-!
-!CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKB = 1 + JPVEXT
-IKE = SIZE(PQ,3) - JPVEXT
-!
-!-------------------------------------------------------------------------------
-!
-!* 2.0. COMPUTE THE DIFFERENCE
-! ----------------------
-!
-!$acc kernels
-DQ(:,:,IKB:IKE) = PQ(:,:,IKB+1:IKE+1) - PQ(:,:,IKB-1:IKE-1)
-DQ(:,:,IKB-1) = -DQ(:,:,IKB)
-DQ(:,:,IKE+1) = -DQ(:,:,IKE)
-DQ = 0.5 * DQ
-!$acc end kernels
-
-!$acc end data
-
-END SUBROUTINE DIF2Z_DEVICE
-
-! #endif
-!
-#ifdef MNH_OPENACC
-! END SUBROUTINE PPM_01_Z_D
-!
-END SUBROUTINE PPM_01_Z
-#else
-END FUNCTION PPM_01_Z
-#endif
-!
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-!!$ FUNCTION PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
-!!$ RESULT(PR)
-SUBROUTINE PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP , PR)
-
- USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
- USE MODE_MNH_ZWORK, ONLY : ZPSRC_HALO2_WEST
-
- IMPLICIT NONE
- !
- !* 0.1 Declarations of dummy arguments :
- !
- CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
- !
- INTEGER, INTENT(IN) :: KGRID ! C grid localisation
- !
- REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
- REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
- REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
- REAL, INTENT(IN) :: PTSTEP ! Time step
- !
- ! output source term
- REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-
- INTEGER :: IZFPOS,IZFNEG,IZPHAT,IZRHO_MXM,IZCR_MXM,IZCR_DXF
-
-!$acc data present( PSRC, PCR, PRHO, PR )
-
- CALL MNH_GET_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MXM,IZCR_MXM,IZCR_DXF)
-
- CALL PPM_S0_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP , PR, &
- & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG),ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRHO_MXM), &
- & ZT3D(:,:,:,IZCR_MXM),ZT3D(:,:,:,IZCR_DXF),ZPSRC_HALO2_WEST )
-
- CALL MNH_REL_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MXM,IZCR_MXM,IZCR_DXF)
-
-!$acc end data
-
-CONTAINS
-!
-! ########################################################################
- SUBROUTINE PPM_S0_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP , PR &
- & ,ZFPOS,ZPHAT,ZFNEG &
- & ,ZRHO_MXM,ZCR_MXM,ZCR_DXF,ZPSRC_HALO2_WEST )
-
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_S0_X(HLBCX, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_S0_X - PPM advection scheme in X direction in Skamarock 2006
-!! notation - NO CONSTRAINTS
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 20.6.2006. T. Maric - original version
-!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-USE MODD_CONF
-
-USE MODE_ll
-#ifdef MNH_OPENACC
-use mode_msg
-#endif
-
-USE MODI_GET_HALO
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-#ifdef MNH_OPENACC
-USE MODD_PARAMETERS, ONLY : JPHEXT
-!
-USE MODE_MNH_ZWORK, ONLY : IIB,IIE, IIU,IJU,IKU , IJS,IJN, GWEST,GEAST
-!
-USE MODD_IO, ONLY : GSMONOPROC
-#endif
-USE MODE_MPPDB
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-#ifndef MNH_OPENACC
-INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE ! End useful area in x,y,z directions
-INTEGER :: IJS,IJN
-INTEGER :: IIU, IJU, IKU
-!
-LOGICAL :: GWEST, GEAST
-
-! advection fluxes
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
-!
-! variable at cell edges
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT
-!
-REAL, DIMENSION(SIZE(PCR,2),SIZE(PCR,3)) :: ZPSRC_HALO2_WEST
-#else
-! advection fluxes
-REAL, DIMENSION(:,:,:) :: ZFPOS, ZFNEG
-!
-! variable at cell edges
-REAL, DIMENSION(:,:,:) :: ZPHAT
-!
-REAL, DIMENSION(:,:,:) :: ZRHO_MXM, ZCR_MXM , ZCR_DXF
-INTEGER :: I,J,K
-!
-LOGICAL, SAVE :: GFIRST_CALL_PPM_S0_X = .TRUE.
-REAL, DIMENSION(:,:) :: ZPSRC_HALO2_WEST
-#endif
-
-#ifndef MNH_OPENACC
-TYPE(HALO2LIST_ll), POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
-#else
-TYPE(HALO2LIST_ll), SAVE , POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
-!
-REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZWEST
-#endif
-!-------------------------------------------------------------------------------
-
-!$acc data present( PSRC, PCR, PRHO, PR , &
-!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MXM, ZCR_MXM, ZCR_DXF, ZPSRC_HALO2_WEST )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S0_X beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_S0_X beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_X beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-#ifndef MNH_OPENACC
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IJS=IJB
-IJN=IJE
-!!$IJS=IJB-1
-!!$IJN=IJE+1
-!
-GWEST = LWEST_ll()
-GEAST = LEAST_ll()
-!
-IIU = SIZE( PSRC, 1 )
-IJU = SIZE( PSRC, 2 )
-IKU = SIZE( PSRC, 3 )
-#endif
-!
-!BEG JUAN PPM_LL
-!
-!* initialise & update halo & halo2 for PSRC
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO2(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
-ZPSRC_HALO2_WEST(:,:) = TZ_PSRC_HALO2_ll%HALO2%WEST(:,:)
-#else
-IF (GFIRST_CALL_PPM_S0_X) THEN
- GFIRST_CALL_PPM_S0_X = .FALSE.
- NULLIFY(TZ_PSRC_HALO2_ll)
- CALL INIT_HALO2_ll(TZ_PSRC_HALO2_ll,1,IIU,IJU,IKU)
-END IF
-CALL GET_HALO2_DF(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
-ZWEST => TZ_PSRC_HALO2_ll%HALO2%WEST
-!$acc kernels
-ZPSRC_HALO2_WEST(:,:) = ZWEST(:,:)
-!$acc end kernels
-#endif
-!$acc kernels
-ZPHAT=PSRC
-ZFPOS=PSRC
-ZFNEG=PSRC
-PR=PSRC
-!
-!END JUAN PPM_LL
-!-------------------------------------------------------------------------------
-!
-! calculate 4th order fluxes at cell edges
-!
-!BEG JUAN PPM_LL
-!
-! i=IIB+1:IIE ( inner domain IIB exclude )
-! ZPATH(i) = Fct[ PSRC(i) ,PSRC(i-1),PSRC(i+1),PSRC(i-2) ]
-!
-! doc MNH ZPATH(i+1) = Fct[ PSRC(i+1),PSRC(i) ,PSRC(i+2),PSRC(i-1) ]
-!
-!
-ZPHAT(IIB+1:IIE,IJS:IJN,:) = ( 7.0 * &
- ( PSRC(IIB+1:IIE ,IJS:IJN,:) + PSRC(IIB :IIE-1,IJS:IJN,:) ) - &
- ( PSRC(IIB+2:IIE+1,IJS:IJN,:) + PSRC(IIB-1:IIE-2,IJS:IJN,:) ) ) / 12.0
-!$acc end kernels
-!
-SELECT CASE ( HLBCX(1) ) ! X direction LBC type: (1) for left side
-CASE ('CYCL','WALL') ! In that case one must have HLBCX(1) == HLBCX(2)
-#ifdef MNH_OPENACC
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S0_X', 'OpenACC: CYCL/WALL boundaries not yet implemented' )
-#endif
-!
-!!$ ZPHAT(IIB,:,:) = (7.0 * &
-!!$ (PSRC(IIB,:,:) + PSRC(IIB-1,:,:)) - &
-!!$ (PSRC(IIB+1,:,:) + PSRC(IIE-1,:,:))) / 12.0
-!!$
-!!$!
-!!$ ZPHAT(IIE+1,:,:) = ZPHAT(IIB,:,:)
-!!$ ZPHAT(IIB-1,:,:) = ZPHAT(IIE,:,:)
-!
-! WEST BOUND
-!
- ZPHAT(IIB ,IJS:IJN,:) = ( 7.0 * &
- ( PSRC(IIB ,IJS:IJN,:) + PSRC(IIB-1,IJS:IJN,:) ) - &
- ( PSRC(IIB+1,IJS:IJN,:) + TZ_PSRC_HALO2_ll%HALO2%WEST(IJS:IJN,:) ) ) / 12.0
-! <=> WEST BOUND ( PSRC(IIB+1,IJS:IJN,:) + PSRC(IIB-2,IJS:IJN,:) ) ) / 12.0
-!
-! The ZPHAT(IIB-1,:,:) doesn't matter only define an realistic value
-!
-!!$ ZPHAT(IIB-1,:,:) = ZPHAT(IIB,:,:) ! JUANTEST1
-!
-! EAST BOUND
-!
-! The ZPHAT(IIE+1,:,:) doesn't matter only define an realistic value
-!
-!!$ ZPHAT(IIE+1,:,:) = ZPHAT(IIE,:,:) ! JUANTEST1
-!
-!
-! update ZPHAT HALO before next/further utilisation
-!
-CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
-!
- ZFPOS(IIB:IIE+1,IJS:IJN,:) = ZPHAT(IIB:IIE+1,IJS:IJN,:) - &
- PCR(IIB:IIE+1,IJS:IJN,:)*(ZPHAT(IIB:IIE+1,IJS:IJN,:) - PSRC(IIB-1:IIE,IJS:IJN,:)) - &
- PCR(IIB:IIE+1,IJS:IJN,:)*(1.0 - PCR(IIB:IIE+1,IJS:IJN,:)) * &
- (ZPHAT(IIB-1:IIE,IJS:IJN,:) - 2.0*PSRC(IIB-1:IIE,IJS:IJN,:) + ZPHAT(IIB:IIE+1,IJS:IJN,:))
-!
-!!$ ZFPOS(IIB-1,:,:) = ZFPOS(IIE,:,:) !JUAN
-CALL GET_HALO(ZFPOS, HNAME='ZFPOS') ! JUAN
-!
- ZFNEG(IIB-1:IIE,IJS:IJN,:) = ZPHAT(IIB-1:IIE,IJS:IJN,:) + &
- PCR(IIB-1:IIE,IJS:IJN,:)*(ZPHAT(IIB-1:IIE,IJS:IJN,:) - PSRC(IIB-1:IIE,IJS:IJN,:)) + &
- PCR(IIB-1:IIE,IJS:IJN,:)*(1.0 + PCR(IIB-1:IIE,IJS:IJN,:)) * &
- (ZPHAT(IIB-1:IIE,IJS:IJN,:) - 2.0*PSRC(IIB-1:IIE,IJS:IJN,:) + ZPHAT(IIB:IIE+1,IJS:IJN,:))
-!
-! define fluxes for CYCL BC outside physical domain
-!!$ ZFNEG(IIE+1,:,:) = ZFNEG(IIB,:,:) !JUAN
-CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
-
-!
-! calculate the advection
-!
-#ifndef MNH_OPENACC
- PR = PSRC * PRHO - &
- DXF( PCR*MXM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S0_X', 'OpenACC: CYCL/WALL boundaries not yet implemented' )
-#endif
- CALL GET_HALO(PR, HNAME='PR') ! JUAN
-!
-CASE ('OPEN')
-!$acc kernels
-!
-!!$ ZPHAT(IIB,:,:) = 0.5*(PSRC(IIB-1,:,:) + PSRC(IIB,:,:))
-!!$ ZPHAT(IIB-1,:,:) = ZPHAT(IIB,:,:) ! not used
-!!$ ZPHAT(IIE+1,:,:) = 0.5*(PSRC(IIE,:,:) + PSRC(IIE+1,:,:))
-!
-! WEST BOUND
-!
-IF (.NOT. GWEST) THEN
- ZPHAT(IIB ,IJS:IJN,:) = ( 7.0 * &
- ( PSRC(IIB ,IJS:IJN,:) + PSRC(IIB-1,IJS:IJN,:) ) - &
- ( PSRC(IIB+1,IJS:IJN,:) + ZPSRC_HALO2_WEST(IJS:IJN,:) ) ) / 12.0
-! <=> WEST BOUND ( PSRC(IIB+1,IJS:IJN,:) + PSRC(IIB-2,IJS:IJN,:) ) ) / 12.0
-ENDIF
-!$acc end kernels
-!
-! update ZPHAT HALO before next/further utilisation
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
-#else
-! acc update self(ZPHAT)
-!CALL GET_HALO_D(ZPHAT(:,:,:), HDIR="Z0_X", HNAME='ZPHAT')
-! acc update device(ZPHAT)
-#endif
-!
-!$acc kernels
- IF (GWEST) THEN
- ZPHAT(IIB ,IJS:IJN,:) = 0.5*(PSRC(IIB-1,IJS:IJN,:) + PSRC(IIB,IJS:IJN,:))
- ZPHAT(IIB-1,IJS:IJN,:) = ZPHAT(IIB,IJS:IJN,:)
- ENDIF
-!
-!
-! EAST BOUND
-!
- IF (GEAST) THEN
- ZPHAT(IIE+1,IJS:IJN,:) = 0.5*(PSRC(IIE,IJS:IJN,:) + PSRC(IIE+1,IJS:IJN,:))
- ENDIF
-!
-! update ZPHAT HALO before next/further utilisation
-!
-!!$CALL GET_HALO(ZPHAT)
-!
-!!$ ZFPOS(IIB+1:IIE+1,:,:) = ZPHAT(IIB+1:IIE+1,:,:) - &
-!!$ PCR(IIB+1:IIE+1,:,:)*(ZPHAT(IIB+1:IIE+1,:,:) - PSRC(IIB:IIE,:,:)) - &
-!!$ PCR(IIB+1:IIE+1,:,:)*(1.0 - PCR(IIB+1:IIE+1,:,:)) * &
-!!$ (ZPHAT(IIB:IIE,:,:) - 2.0*PSRC(IIB:IIE,:,:) + ZPHAT(IIB+1:IIE+1,:,:))
- ZFPOS(IIB:IIE+1,IJS:IJN,:) = ZPHAT(IIB:IIE+1,IJS:IJN,:) - &
- PCR(IIB:IIE+1,IJS:IJN,:)*(ZPHAT(IIB:IIE+1,IJS:IJN,:) - PSRC(IIB-1:IIE,IJS:IJN,:)) - &
- PCR(IIB:IIE+1,IJS:IJN,:)*(1.0 - PCR(IIB:IIE+1,IJS:IJN,:)) * &
- (ZPHAT(IIB-1:IIE,IJS:IJN,:) - 2.0*PSRC(IIB-1:IIE,IJS:IJN,:) + ZPHAT(IIB:IIE+1,IJS:IJN,:))
-!$acc end kernels
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO(ZFPOS, HNAME='ZFPOS') ! JUAN
-#else
-! acc update self(ZFPOS)
-!CALL GET_HALO_D(ZFPOS(:,:,:), HDIR="Z0_X", HNAME='ZFPOS') ! JUAN
-! acc update device(ZFPOS)
-#endif
-!
-!$acc kernels
-! positive flux on the WEST boundary
- IF (GWEST) THEN
- ZFPOS(IIB,IJS:IJN,:) = (PSRC(IIB-1,IJS:IJN,:) - ZPHAT(IIB,IJS:IJN,:))*PCR(IIB,IJS:IJN,:) + &
- ZPHAT(IIB,IJS:IJN,:)
-! this is not used
- ZFPOS(IIB-1,IJS:IJN,:) = 0.0
- ENDIF
-!
-! negative fluxes
-!!$ ZFNEG(IIB:IIE,:,:) = ZPHAT(IIB:IIE,:,:) + &
-!!$ PCR(IIB:IIE,:,:)*(ZPHAT(IIB:IIE,:,:) - PSRC(IIB:IIE,:,:)) + &
-!!$ PCR(IIB:IIE,:,:)*(1.0 + PCR(IIB:IIE,:,:)) * &
-!!$ (ZPHAT(IIB:IIE,:,:) - 2.0*PSRC(IIB:IIE,:,:) + ZPHAT(IIB+1:IIE+1,:,:))
- ZFNEG(IIB-1:IIE,IJS:IJN,:) = ZPHAT(IIB-1:IIE,IJS:IJN,:) + &
- PCR(IIB-1:IIE,IJS:IJN,:)*(ZPHAT(IIB-1:IIE,IJS:IJN,:) - PSRC(IIB-1:IIE,IJS:IJN,:)) + &
- PCR(IIB-1:IIE,IJS:IJN,:)*(1.0 + PCR(IIB-1:IIE,IJS:IJN,:)) * &
- (ZPHAT(IIB-1:IIE,IJS:IJN,:) - 2.0*PSRC(IIB-1:IIE,IJS:IJN,:) + ZPHAT(IIB:IIE+1,IJS:IJN,:))
-!$acc end kernels
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
-#else
-! acc update self(ZFNEG)
-!CALL GET_HALO_D(ZFNEG, HDIR="Z0_X", HNAME='ZFNEG') ! JUAN
-! acc update device(ZFNEG)
-#endif
-!
-!$acc kernels
- IF (GEAST) THEN
-!
-! in OPEN case PCR(IIB-1) is not used, so we also set ZFNEG(IIB-1) = 0
-!
- ZFNEG(IIB-1,IJS:IJN,:) = 0.0
-!
-! modified negative flux on EAST boundary. We use linear function instead of a
-! parabola to represent the tracer field, so it simplifies the flux expresion
-!
- ZFNEG(IIE+1,IJS:IJN,:) = (ZPHAT(IIE+1,IJS:IJN,:) - PSRC(IIE+1,IJS:IJN,:))*PCR(IIE+1,IJS:IJN,:) + &
- ZPHAT(IIE+1,IJS:IJN,:)
- ENDIF
-!
-! calculate the advection
-!
-#ifndef MNH_OPENACC
- PR = PSRC * PRHO - &
- DXF( PCR*MXM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
-!$acc end kernels
- CALL MXM_DEVICE(PRHO,ZRHO_MXM)
-!$acc kernels
- ZCR_MXM = PCR * ZRHO_MXM * ( ZFPOS*(0.5+SIGN(0.5,PCR)) + ZFNEG*(0.5-SIGN(0.5,PCR)) )
-!$acc end kernels
- CALL DXF_DEVICE(ZCR_MXM,ZCR_DXF)
-!$acc kernels
- PR = PSRC * PRHO - ZCR_DXF
-#endif
-!
-! in OPEN case fix boundary conditions
-!
- IF (GWEST) THEN
- WHERE ( PCR(IIB,IJS:IJN,:) <= 0. ) ! OUTFLOW condition
- PR(IIB-1,IJS:IJN,:) = 2.*PR(IIB,IJS:IJN,:) - PR(IIB+1,IJS:IJN,:)
- ELSEWHERE
- PR(IIB-1,IJS:IJN,:) = PR(IIB,IJS:IJN,:)
- END WHERE
- ENDIF
-!
- IF (GEAST) THEN
- WHERE ( PCR(IIE,IJS:IJN,:) >= 0. ) ! OUTFLOW condition
- PR(IIE+1,IJS:IJN,:) = 2.*PR(IIE,IJS:IJN,:) - PR(IIE-1,IJS:IJN,:)
- ELSEWHERE
- PR(IIE+1,IJS:IJN,:) = PR(IIE,IJS:IJN,:)
- END WHERE
- ENDIF
-!
-!$acc end kernels
-!
-!
-END SELECT
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO(PR, HNAME='PR')
-#else
-CALL GET_HALO_D(PR, HDIR="S0_X", HNAME='PR')
-#endif
-!-------------------------------------------------------------------------------
-#ifndef MNH_OPENACC
-CALL DEL_HALO2_ll(TZ_PSRC_HALO2_ll)
-#endif
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_X end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S0_X end:PR")
-END IF
-
-!$acc end data
-
-#ifdef MNH_OPENACC
-END SUBROUTINE PPM_S0_X_D
-
-END SUBROUTINE PPM_S0_X
-#else
-END FUNCTION PPM_S0_X
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-!!$ FUNCTION PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
-!!$ RESULT(PR)
- SUBROUTINE PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-
- USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
- USE MODE_MNH_ZWORK, ONLY : ZPSRC_HALO2_SOUTH
-
- IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-
- INTEGER :: IZFPOS,IZPHAT,IZFNEG,IZRHO_MYM,IZCR_MYM,IZCR_DYF
-
-!$acc data present( PSRC, PCR, PRHO, PR )
-
- CALL MNH_GET_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MYM,IZCR_MYM,IZCR_DYF)
-
- CALL PPM_S0_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP , PR, &
- & ZT3D(:,:,:,IZFPOS),ZT3D(:,:,:,IZFNEG),ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRHO_MYM), &
- & ZT3D(:,:,:,IZCR_MYM),ZT3D(:,:,:,IZCR_DYF),ZPSRC_HALO2_SOUTH )
-
- CALL MNH_REL_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MYM,IZCR_MYM,IZCR_DYF)
-
-!$acc end data
-
-CONTAINS
-!
-! ########################################################################
- SUBROUTINE PPM_S0_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP , PR &
- & ,ZFPOS,ZPHAT,ZFNEG &
- & ,ZRHO_MYM,ZCR_MYM,ZCR_DYF,ZPSRC_HALO2_SOUTH )
-
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_S0_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_S0_Y - PPM advection scheme in Y direction in Skamarock 2006
-!! notation - NO CONSTRAINTS
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 20.6.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODD_CONF
-
-USE MODE_ll
-#ifdef MNH_OPENACC
-use mode_msg
-#endif
-
-USE MODI_GET_HALO
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-#ifdef MNH_OPENACC
-USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-USE MODD_PARAMETERS, ONLY : JPHEXT
-!
-USE MODE_MNH_ZWORK, ONLY : IJB,IJE, IIU,IJU,IKU , IIW,IIA, GSOUTH , GNORTH
-!
-USE MODD_IO, ONLY : GSMONOPROC
-#endif
-USE MODE_MPPDB
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-#ifndef MNH_OPENACC
-INTEGER:: IIB,IJB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE ! End useful area in x,y,z directions
-INTEGER :: IJS,IJN
-INTEGER :: IIW,IIA
-INTEGER :: IIU, IJU, IKU
-!
-LOGICAL :: GNORTH, GSOUTH
-!
-! advection fluxes
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
-!
-! variable at cell edges
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT
-!
-TYPE(HALO2LIST_ll), POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
-TYPE(HALO2LIST_ll), POINTER :: TZ_PHAT_HALO2_ll ! halo2 for ZPHAT
-!
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,3)) :: ZPSRC_HALO2_SOUTH
-#else
-!
-! advection fluxes
-REAL, DIMENSION(:,:,:) :: ZFPOS, ZFNEG
-!
-! variable at cell edges
-REAL, DIMENSION(:,:,:) :: ZPHAT
-!
-#ifndef MNH_OPENACC
-TYPE(HALO2LIST_ll), POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
-#else
-TYPE(HALO2LIST_ll), SAVE ,POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
-
-REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZSOUTH
-#endif
-
-TYPE(HALO2LIST_ll), POINTER :: TZ_PHAT_HALO2_ll ! halo2 for ZPHAT
-!
-REAL, DIMENSION(:,:,:) :: ZRHO_MYM , ZCR_MYM , ZCR_DYF
-!
-INTEGER :: I,J,K
-!
-LOGICAL, SAVE :: GFIRST_CALL_PPM_S0_Y = .TRUE.
-REAL, DIMENSION(:,:) :: ZPSRC_HALO2_SOUTH
-#endif
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PSRC, PCR, PRHO, PR , &
-!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MYM, ZCR_MYM, ZCR_DYF, ZPSRC_HALO2_SOUTH )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S0_Y beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_S0_Y beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_Y beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-#ifndef MNH_OPENACC
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IIW=IIB
-IIA=IIE
-!!$IIW=IIB-1
-!!$IIA=IIE+1
-!
-GNORTH = LNORTH_ll()
-GSOUTH = LSOUTH_ll()
-!
-IIU = SIZE( PSRC, 1 )
-IJU = SIZE( PSRC, 2 )
-IKU = SIZE( PSRC, 3 )
-#endif
-!
-!-------------------------------------------------------------------------------
-!
-IF ( L2D ) THEN
-!$acc kernels
- PR(:, :, : ) = PSRC(:, :, : ) * PRHO(:, :, : )
-!$acc end kernels
-
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S0_Y end:PR")
-! RETURN
-ELSE !not L2D
- !
-#ifndef MNH_OPENACC
-CALL GET_HALO2(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
-ZPSRC_HALO2_SOUTH(:,:) = TZ_PSRC_HALO2_ll%HALO2%SOUTH(:,:)
-#else
-IF (GFIRST_CALL_PPM_S0_Y) THEN
- GFIRST_CALL_PPM_S0_Y = .FALSE.
- NULLIFY(TZ_PSRC_HALO2_ll)
- CALL INIT_HALO2_ll(TZ_PSRC_HALO2_ll,1,IIU,IJU,IKU)
-END IF
-CALL GET_HALO2_DF(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
-ZSOUTH => TZ_PSRC_HALO2_ll%HALO2%SOUTH(:,:)
-!$acc kernels
-ZPSRC_HALO2_SOUTH(:,:) = ZSOUTH(:,:)
-!$acc end kernels
-#endif
-!
-! Initialize with relalistic value all work array
-!
-!$acc kernels
-ZPHAT=PSRC
-ZFPOS=PSRC
-ZFNEG=PSRC
-PR=PSRC
-!
-!-------------------------------------------------------------------------------
-!
-! calculate 4th order fluxes at cell edges in the inner domain
-!
-ZPHAT(IIW:IIA,IJB+1:IJE,:) = (7.0 * &
- (PSRC(IIW:IIA,IJB+1:IJE,:) + PSRC(IIW:IIA,IJB:IJE-1,:)) - &
- (PSRC(IIW:IIA,IJB+2:IJE+1,:) + PSRC(IIW:IIA,IJB-1:IJE-2,:))) / 12.0
-!$acc end kernels
-!
-SELECT CASE ( HLBCY(1) ) ! Y direction LBC type: (1) for left side
-CASE ('CYCL','WALL') ! In that case one must have HLBCY(1) == HLBCY(2)
-#ifdef MNH_OPENACC
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S0_Y', 'OpenACC: CYCL/WALL boundaries not yet implemented' )
-#endif
-!
-!!$ ZPHAT(:,IJB,:) = (7.0 * &
-!!$ (PSRC(:,IJB,:) + PSRC(:,IJB-1,:)) - &
-!!$ (PSRC(:,IJB+1,:) + PSRC(:,IJE-1,:))) / 12.0
-!!$!
-!!$ ZPHAT(:,IJE+1,:) = ZPHAT(:,IJB,:)
-!!$ ZPHAT(:,IJB-1,:) = ZPHAT(:,IJE,:)
-!
-! SOUTH BOUND
-!
- ZPHAT(IIW:IIA,IJB,:) = ( 7.0 * &
- ( PSRC(IIW:IIA,IJB ,:) + PSRC(IIW:IIA,IJB-1,:) ) - &
- ( PSRC(IIW:IIA,IJB+1,:) + TZ_PSRC_HALO2_ll%HALO2%SOUTH(IIW:IIA,:) ) ) / 12.0
-! <=> SOUTH B ( PSRC(IIW:IIA,IJB+1,:) + PSRC(IIW:IIA,IJB-2,:) ) ) / 12.0
-!
-! The ZPHAT(:,IJB-1,:) doesn't matter only define an realistic value
-!
-!!$ ZPHAT(:,IJB-1,:) = ZPHAT(:,IJB,:)
-!
-! NORTH BOUND
-!
-! The ZPHAT(:IJE+1,:) doesn't matter only define an realistic value
-!
-!!$ ZPHAT(:,IJE+1,:) = ZPHAT(:,IJE,:)
-!
-! update ZPHAT HALO before next/further utilisation
-!
-CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
-!
-! calculate the fluxes:
-!
- ZFPOS(IIW:IIA,IJB:IJE+1,:) = ZPHAT(IIW:IIA,IJB:IJE+1,:) - &
- PCR(IIW:IIA,IJB:IJE+1,:)*(ZPHAT(IIW:IIA,IJB:IJE+1,:) - PSRC(IIW:IIA,IJB-1:IJE,:)) - &
- PCR(IIW:IIA,IJB:IJE+1,:)*(1.0 - PCR(IIW:IIA,IJB:IJE+1,:)) * &
- (ZPHAT(IIW:IIA,IJB-1:IJE,:) - 2.0*PSRC(IIW:IIA,IJB-1:IJE,:) + ZPHAT(IIW:IIA,IJB:IJE+1,:))
-!
-!!$ ZFPOS(:,IJB-1,:) = ZFPOS(:,IJE,:)
-CALL GET_HALO(ZFPOS, HNAME='ZFPOS') ! JUAN
-!
- ZFNEG(IIW:IIA,IJB-1:IJE,:) = ZPHAT(IIW:IIA,IJB-1:IJE,:) + &
- PCR(IIW:IIA,IJB-1:IJE,:)*(ZPHAT(IIW:IIA,IJB-1:IJE,:) - PSRC(IIW:IIA,IJB-1:IJE,:)) + &
- PCR(IIW:IIA,IJB-1:IJE,:)*(1.0 + PCR(IIW:IIA,IJB-1:IJE,:)) * &
- (ZPHAT(IIW:IIA,IJB-1:IJE,:) - 2.0*PSRC(IIW:IIA,IJB-1:IJE,:) +ZPHAT(IIW:IIA,IJB:IJE+1,:))
-!
-
-!
-! define fluxes for CYCL BC outside physical domain
-!!$ ZFNEG(:,IJE+1,:) = ZFNEG(:,IJB,:)
-CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
-!
-! calculate the advection
-!
-#ifndef MNH_OPENACC
- PR = PSRC * PRHO - &
- DYF( PCR*MYM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S0_Y', 'OpenACC: CYCL/WALL boundaries not yet implemented' )
-#endif
-!
-CASE ('OPEN')
-!$acc kernels
-!
-!!$ ZPHAT(:,IJB,:) = 0.5*(PSRC(:,IJB-1,:) + PSRC(:,IJB,:))
-!!$ ZPHAT(:,IJB-1,:) = ZPHAT(:,IJB,:) ! not used
-!!$ ZPHAT(:,IJE+1,:) = 0.5*(PSRC(:,IJE,:) + PSRC(:,IJE+1,:))
-!
-!
-! SOUTH BOUND
-!
- IF ( .NOT. GSOUTH) THEN
- ZPHAT(IIW:IIA,IJB ,:) = (7.0 * &
- (PSRC(IIW:IIA,IJB ,:) + PSRC(IIW:IIA,IJB-1,:)) - &
- (PSRC(IIW:IIA,IJB+1,:) + ZPSRC_HALO2_SOUTH(IIW:IIA,:) )) / 12.0
-! (PSRC(IIW:IIA,IJB+1,:) + TZ_PSRC_HALO2_ll%HALO2%SOUTH(IIW:IIA,:) )) / 12.0
-! <=> SOUTH BOUND (PSRC(IIW:IIA,IJB+1,:) + PSRC(IIW:IIA,IJB-2,:) )) / 12.0
- ENDIF
-!
-!TEMPO_JUAN
-!$acc end kernels
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
-#else
-! acc update self(ZPHAT)
-!CALL GET_HALO_D(ZPHAT(:,:,:), HDIR="Z0_Y", HNAME='ZPHAT')
-! acc update device(ZPHAT)
-#endif
-!
-!$acc kernels
- IF (GSOUTH) THEN
- ZPHAT(IIW:IIA,IJB ,:) = 0.5*(PSRC(IIW:IIA,IJB-1,:) + PSRC(IIW:IIA,IJB,:))
- ZPHAT(IIW:IIA,IJB-1,:) = ZPHAT(IIW:IIA,IJB,:)
- ENDIF
-!
-! NORTH BOUND
-!
- IF (GNORTH) THEN
- ZPHAT(IIW:IIA,IJE+1,:) = 0.5*(PSRC(IIW:IIA,IJE,:) + PSRC(IIW:IIA,IJE+1,:))
- ENDIF
-!
-!
-! update ZPHAT HALO before next/further utilisation
-!
-!!$CALL GET_HALO(ZPHAT)
-!
-! calculate the fluxes:
-! positive fluxes
-!!$ ZFPOS(:,IJB+1:IJE+1,:) = ZPHAT(:,IJB+1:IJE+1,:) - &
-!!$ PCR(:,IJB+1:IJE+1,:)*(ZPHAT(:,IJB+1:IJE+1,:) - PSRC(:,IJB:IJE,:)) - &
-!!$ PCR(:,IJB+1:IJE+1,:)*(1.0 - PCR(:,IJB+1:IJE+1,:)) * &
-!!$ (ZPHAT(:,IJB:IJE,:) - 2.0*PSRC(:,IJB:IJE,:) + ZPHAT(:,IJB+1:IJE+1,:))
- ZFPOS(IIW:IIA,IJB:IJE+1,:) = ZPHAT(IIW:IIA,IJB:IJE+1,:) - &
- PCR(IIW:IIA,IJB:IJE+1,:)*( ZPHAT(IIW:IIA,IJB:IJE+1,:) - PSRC(IIW:IIA,IJB-1:IJE ,:) ) - &
- PCR(IIW:IIA,IJB:IJE+1,:)*( 1.0 - PCR(IIW:IIA,IJB :IJE+1,:) ) * &
- (ZPHAT(IIW:IIA,IJB-1:IJE,:) - 2.0*PSRC(IIW:IIA,IJB-1:IJE,:) + ZPHAT(IIW:IIA,IJB:IJE+1,:))
-!$acc end kernels
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO(ZFPOS, HNAME='ZFPOS') ! JUAN
-#else
-! acc update self(ZFPOS)
-!CALL GET_HALO_D(ZFPOS(:,:,:), HDIR="Z0_Y", HNAME='ZFPOS') ! JUAN
-! acc update device(ZFPOS)
-#endif
-!
-!$acc kernels
-! positive flux on the SOUTH boundary
- IF (GSOUTH) THEN
- ZFPOS(IIW:IIA,IJB,:) = (PSRC(IIW:IIA,IJB-1,:) - ZPHAT(IIW:IIA,IJB,:))*PCR(IIW:IIA,IJB,:) + &
- ZPHAT(IIW:IIA,IJB,:)
-!
-! this is not used
- ZFPOS(IIW:IIA,IJB-1,:) = 0.0
- ENDIF
-!
-! negative fluxes
-!!$ ZFNEG(:,IJB:IJE,:) = ZPHAT(:,IJB:IJE,:) + &
-!!$ PCR(:,IJB:IJE,:)*(ZPHAT(:,IJB:IJE,:) - PSRC(:,IJB:IJE,:)) + &
-!!$ PCR(:,IJB:IJE,:)*(1.0 + PCR(:,IJB:IJE,:)) * &
-!!$ (ZPHAT(:,IJB:IJE,:) - 2.0*PSRC(:,IJB:IJE,:) +ZPHAT(:,IJB+1:IJE+1,:))
- ZFNEG(IIW:IIA,IJB-1:IJE,:) = ZPHAT(IIW:IIA,IJB-1:IJE,:) + &
- PCR(IIW:IIA,IJB-1:IJE,:)*(ZPHAT(IIW:IIA,IJB-1:IJE,:) - PSRC(IIW:IIA,IJB-1:IJE,:)) + &
- PCR(IIW:IIA,IJB-1:IJE,:)*(1.0 + PCR(IIW:IIA,IJB-1:IJE,:)) * &
- (ZPHAT(IIW:IIA,IJB-1:IJE,:) - 2.0*PSRC(IIW:IIA,IJB-1:IJE,:) +ZPHAT(IIW:IIA,IJB:IJE+1,:))
-!$acc end kernels
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
-#else
-! acc update self(ZFNEG)
-! CALL GET_HALO_D(ZFNEG, HDIR="Z0_Y", HNAME='ZFNEG') ! JUAN
-! acc update device(ZFNEG)
-#endif
-!
-!$acc kernels
- IF (GNORTH) THEN
-! this is not used
- ZFNEG(IIW:IIA,IJB-1,:) = 0.0
-!
-! negative flux on the NORTH boundary
- ZFNEG(IIW:IIA,IJE+1,:) = (ZPHAT(IIW:IIA,IJE+1,:) - PSRC(IIW:IIA,IJE+1,:))*PCR(IIW:IIA,IJE+1,:) + &
- ZPHAT(IIW:IIA,IJE+1,:)
- ENDIF
-!
-! calculate the advection
-!
-#ifndef MNH_OPENACC
- PR = PSRC * PRHO - &
- DYF( PCR*MYM(PRHO)*( ZFPOS*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
-!$acc end kernels
- CALL MYM_DEVICE(PRHO,ZRHO_MYM)
-!$acc kernels
- ZCR_MYM = PCR* ZRHO_MYM*( ZFPOS(:,:,:)*(0.5+SIGN(0.5,PCR)) + ZFNEG*(0.5-SIGN(0.5,PCR)) )
-!$acc end kernels
- CALL DYF_DEVICE(ZCR_MYM,ZCR_DYF)
-!$acc kernels
- PR = PSRC * PRHO - ZCR_DYF
-#endif
-!
-! in OPEN case fix boundary conditions
-!
- IF (GSOUTH) THEN
- WHERE ( PCR(IIW:IIA,IJB,:) <= 0. ) ! OUTFLOW condition
- PR(IIW:IIA,IJB-1,:) = 1.0 * 2.*PR(IIW:IIA,IJB,:) - PR(IIW:IIA,IJB+1,:)
- ELSEWHERE
- PR(IIW:IIA,IJB-1,:) = PR(IIW:IIA,IJB,:)
- END WHERE
- ENDIF
-!
- IF (GNORTH) THEN
- WHERE ( PCR(IIW:IIA,IJE,:) >= 0. ) ! OUTFLOW condition
- PR(IIW:IIA,IJE+1,:) = 1.0 * 2.*PR(IIW:IIA,IJE,:) - PR(IIW:IIA,IJE-1,:)
- ELSEWHERE
- PR(IIW:IIA,IJE+1,:) = PR(IIW:IIA,IJE,:)
- END WHERE
- ENDIF
-!
-!$acc end kernels
-!
-!
-END SELECT
-!
-#ifndef MNH_OPENACC
-CALL GET_HALO(PR, HNAME='PR')
-#else
-CALL GET_HALO_D(PR, HDIR="S0_Y", HNAME='PR')
-#endif
-!
-#ifndef MNH_OPENACC
-CALL DEL_HALO2_ll(TZ_PSRC_HALO2_ll)
-#endif
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_Y end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S0_Y end:PR")
-END IF
-
-END IF !not L2D
-!$acc end data
-
-#ifdef MNH_OPENACC
-END SUBROUTINE PPM_S0_Y_D
-
-END SUBROUTINE PPM_S0_Y
-#else
-END FUNCTION PPM_S0_Y
-#endif
-!
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-!!$ FUNCTION PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) &
-!!$ RESULT(PR)
-SUBROUTINE PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP, PR)
-
- USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
-
- IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-REAL, DIMENSION(:,:,:),INTENT(OUT):: PR
-
-
- INTEGER :: IZFPOS,IZPHAT,IZFNEG,IZRHO_MZM,IZCR_MZM,IZCR_DZF
-
-!$acc data present ( PSRC, PCR, PRHO, PR )
-
- CALL MNH_GET_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MZM,IZCR_MZM,IZCR_DZF)
-
- CALL PPM_S0_Z_D(KGRID, PSRC, PCR, PRHO, PTSTEP , PR, &
- & ZT3D(:,:,:,IZFPOS), ZT3D(:,:,:,IZFNEG), ZT3D(:,:,:,IZPHAT), &
- & ZT3D(:,:,:,IZRHO_MZM),ZT3D(:,:,:,IZCR_MZM),ZT3D(:,:,:,IZCR_DZF) )
-
- CALL MNH_REL_ZT3D(IZFPOS,IZFNEG,IZPHAT,IZRHO_MZM,IZCR_MZM,IZCR_DZF)
-
-!$acc end data
-
-CONTAINS
-!
-! ########################################################################
-SUBROUTINE PPM_S0_Z_D(KGRID, PSRC, PCR, PRHO, PTSTEP , PR &
- & ,ZFPOS,ZFNEG,ZPHAT &
- & ,ZRHO_MZM,ZCR_MZM,ZCR_DZF )
-
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_S0_Z(KGRID, PSRC, PCR, PRHO, PTSTEP) &
- RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_S0_Z - PPM advection scheme in Z direction in Skamarock 2006
-!! notation - NO CONSTRAINTS
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 20.6.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODE_ll
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-USE MODI_GET_HALO
-!
-USE MODD_CONF
-USE MODD_PARAMETERS
-USE MODE_MPPDB
-!
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY : IKB,IKE, IKU
-#endif
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:),INTENT(OUT):: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-#ifndef MNH_OPENACC
-INTEGER:: IKB ! Begining useful area in x,y,z directions
-INTEGER:: IKE ! End useful area in x,y,z directions
-!
-! advection fluxes
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFPOS, ZFNEG
-!
-! interpolated variable at cell edges
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT
-#else
-! advection fluxes
-REAL, DIMENSION(:,:,:),INTENT(OUT):: ZFPOS, ZFNEG &
-!
-! interpolated variable at cell edges
- & , ZPHAT &
- & , ZRHO_MZM ,ZCR_MZM,ZCR_DZF
-#endif
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present ( PSRC, PCR, PRHO, PR , &
-!$acc & ZFPOS, ZFNEG, ZPHAT, ZRHO_MZM, ZCR_MZM, ZCR_DZF )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S0_Z beg:PCR")
- CALL MPPDB_CHECK(PRHO,"PPM_S0_Z beg:PRHO")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_Z beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-#ifndef MNH_OPENACC
-IKB = 1 + JPVEXT
-IKE = SIZE(PSRC,3) - JPVEXT
-#endif
-!
-!-------------------------------------------------------------------------------
-!
-! calculate 4th order fluxes at cell edges in the inner domain
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(PSRC, HNAME='PSRC')
-#else
- CALL GET_HALO_D(PSRC, HNAME='PSRC')
-#endif
-!
-#ifdef MNH_OPENACC
-!$acc kernels
-#endif
-!
-ZPHAT(:,:,IKB+1:IKE) = (7.0 * &
- (PSRC(:,:,IKB+1:IKE) + PSRC(:,:,IKB:IKE-1)) - &
- (PSRC(:,:,IKB+2:IKE+1) + PSRC(:,:,IKB-1:IKE-2))) / 12.0
-!
-! set OPEN BC at the top and bottom
-ZPHAT(:,:,IKB) = 0.5*(PSRC(:,:,IKB-1) + PSRC(:,:,IKB))
-ZPHAT(:,:,IKB-1) = ZPHAT(:,:,IKB) ! not used
-ZPHAT(:,:,IKE+1) = 0.5*(PSRC(:,:,IKE) + PSRC(:,:,IKE+1))
-!
-!!$CALL GET_HALO(ZPHAT(:,:,:))
-!
-! calculate fluxes through cell edges for positive and negative Courant numbers
-! (for inflow or outflow situation)
-!
-ZFPOS(:,:,IKB+1:IKE+1) = ZPHAT(:,:,IKB+1:IKE+1) - &
- PCR(:,:,IKB+1:IKE+1)*(ZPHAT(:,:,IKB+1:IKE+1) - PSRC(:,:,IKB:IKE)) - &
- PCR(:,:,IKB+1:IKE+1)*(1.0 - PCR(:,:,IKB+1:IKE+1)) * &
- (ZPHAT(:,:,IKB:IKE) - 2.0*PSRC(:,:,IKB:IKE) + ZPHAT(:,:,IKB+1:IKE+1))
-!
-!!$CALL GET_HALO(ZFPOS(:,:,:)) ! JUAN
-!
-! positive flux on the BOTTOM boundary
-ZFPOS(:,:,IKB) = (PSRC(:,:,IKB-1) - ZPHAT(:,:,IKB))*PCR(:,:,IKB) + &
- ZPHAT(:,:,IKB)
-!
-! below bottom flux - not used
-ZFPOS(:,:,IKB-1) = 0.0
-!
-! negative fluxes:
-!
-ZFNEG(:,:,IKB:IKE) = ZPHAT(:,:,IKB:IKE) + &
- PCR(:,:,IKB:IKE)*(ZPHAT(:,:,IKB:IKE) - PSRC(:,:,IKB:IKE)) + &
- PCR(:,:,IKB:IKE)*(1.0 + PCR(:,:,IKB:IKE)) * &
- (ZPHAT(:,:,IKB:IKE) - 2.0*PSRC(:,:,IKB:IKE) +ZPHAT(:,:,IKB+1:IKE+1))
-!
-!!$ CALL GET_HALO(ZFNEG) ! JUAN
-!
-! set bottom negative flux to 0
-ZFNEG(:,:,IKB-1) = 0.0
-!
-! negative flux at the TOP
-ZFNEG(:,:,IKE+1) = (ZPHAT(:,:,IKE+1) - PSRC(:,:,IKE+1))*PCR(:,:,IKE+1) + &
- ZPHAT(:,:,IKE+1)
-!
-! calculate the advection
-!
-#ifndef MNH_OPENACC
-PR = PSRC * PRHO - &
- DZF( PCR*MZM(PRHO)*( ZFPOS(:,:,:)*(0.5+SIGN(0.5,PCR)) + &
- ZFNEG*(0.5-SIGN(0.5,PCR)) ) )
-#else
-!$acc end kernels
- CALL MZM_DEVICE(PRHO,ZRHO_MZM)
-!$acc kernels
- ZCR_MZM = PCR* ZRHO_MZM*( ZFPOS(:,:,:)*(0.5+SIGN(0.5,PCR)) + ZFNEG*(0.5-SIGN(0.5,PCR)) )
- !dzf(ZCR_DZF,ZCR_MZM)
-!$acc end kernels
- CALL DZF_DEVICE(ZCR_MZM,ZCR_DZF)
-!$acc kernels
- PR = PSRC * PRHO - ZCR_DZF
-#endif
-!
-! in OPEN case fix boundary conditions
-!
- PR(:,:,IKB-1) = PR(:,:,IKB)
- PR(:,:,IKE+1) = PR(:,:,IKE)
-!
-!$acc end kernels
-!
-#ifndef MNH_OPENACC
- CALL GET_HALO(PR, HNAME='PR')
-#else
- CALL GET_HALO_D(PR, HNAME='PR')
-#endif
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S0_Z end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S0_Z end:PR")
-END IF
-
-!$acc end data
-
-#ifdef MNH_OPENACC
-END SUBROUTINE PPM_S0_Z_D
-
-END SUBROUTINE PPM_S0_Z
-#else
-END FUNCTION PPM_S0_Z
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-! FUNCTION PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
-! PTSTEP) RESULT(PR)
- SUBROUTINE PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR)
-! ########################################################################
-USE MODE_ll
-use mode_msg
-USE MODE_IO
-USE MODI_SHUMAN_DEVICE
-!
-USE MODD_CONF
-USE MODD_LUNIT
-USE MODD_PARAMETERS
-!
-USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-
-INTEGER :: IZPHAT,IZRUT,IZFUP,IZFCOR,IZRPOS,IZRNEG
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR )
-
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_X', 'OpenACC: not yet implemented' )
-
- CALL MNH_GET_ZT3D(IZPHAT,IZRUT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
-
- CALL PPM_S1_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR, &
- ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRUT),ZT3D(:,:,:,IZFUP), &
- ZT3D(:,:,:,IZFCOR),ZT3D(:,:,:,IZRPOS),ZT3D(:,:,:,IZRNEG) )
-
- CALL MNH_REL_ZT3D(IZPHAT,IZRUT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
-
-!$acc end data
-
- CONTAINS
-!
-! ########################################################################
-! FUNCTION PPM_S1_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
-! PTSTEP) RESULT(PR)
- SUBROUTINE PPM_S1_X_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR, ZPHAT,ZRUT,ZFUP,ZFCOR,ZRPOS,ZRNEG)
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_S1_X(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP) RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_S1_X - PPM advection scheme in X direction in Skamarock 2006
-!! notation - with flux limiting for monotonicity
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 23.6.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODE_ll
-use mode_mppdb
-
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-USE MODD_CONF
-USE MODD_PARAMETERS
-!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-#ifndef MNH_OPENACC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
-#else
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-#endif
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER:: IIB,IJB,IKB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE,IKE ! End useful area in x,y,z directions
-!
-! variable at cell edges
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT, ZRUT
-!
-! advection fluxes, upwind and correction
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFUP, ZFCOR
-!
-! ratios for limiting the correction flux
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZRPOS, ZRNEG
-!
-! variables for limiting the correction flux
-REAL :: ZSRCMAX, ZSRCMIN, ZFIN, ZFOUT
-!
-REAL, PARAMETER :: ZEPS = 1.0E-16
-!
-INTEGER :: II, IJ, IK
-INTEGER :: IRESP ! for prints
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR, &
-!$acc & ZPHAT, ZRUT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S1_X beg:PCR")
- CALL MPPDB_CHECK(PRHO, "PPM_S1_X beg:PRHO")
- CALL MPPDB_CHECK(PRHOT,"PPM_S1_X beg:PRHOT")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC, "PPM_S1_X beg:PSRC")
-END IF
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKB = 1 + JPVEXT
-IKE = SIZE(PSRC,3) - JPVEXT
-!
-!-------------------------------------------------------------------------------
-!
-! Calculate contravariant component rho*u/dx
-!
-ZRUT = PCR/PTSTEP * MXM(PRHO)
-!
-! calculate 4th order fluxes at cell edges in the inner domain
-!
-ZPHAT(IIB+1:IIE,:,:) = (7.0 * &
- (PSRC(IIB+1:IIE,:,:) + PSRC(IIB:IIE-1,:,:)) - &
- (PSRC(IIB+2:IIE+1,:,:) + PSRC(IIB-1:IIE-2,:,:))) / 12.0
-!
-SELECT CASE ( HLBCX(1) ) ! X direction LBC type: (1) for left side
-CASE ('CYCL','WALL') ! In that case one must have HLBCX(1) == HLBCX(2)
-!
- ZPHAT(IIB,:,:) = (7.0 * &
- (PSRC(IIB,:,:) + PSRC(IIB-1,:,:)) - &
- (PSRC(IIB+1,:,:) + PSRC(IIE-1,:,:))) / 12.0
-!
- ZPHAT(IIE+1,:,:) = ZPHAT(IIB,:,:)
- ZPHAT(IIB-1,:,:) = ZPHAT(IIE,:,:)
-!
-CASE ('OPEN')
-!
- ZPHAT(IIB,:,:) = 0.5*(PSRC(IIB-1,:,:) + PSRC(IIB,:,:))
- ZPHAT(IIB-1,:,:) = ZPHAT(IIB,:,:)
- ZPHAT(IIE+1,:,:) = 0.5*(PSRC(IIE,:,:) + PSRC(IIE+1,:,:))
-!
-!
-END SELECT
-!
-! calculate upwind and correction fluxes. upwind flux is upstream value of the
-! scalar variable, and correction flux is the correction to the upstream flux
-! that makes it equivalent to the PPM flux
-! flux_ppm = flux_up + flux_corr
-!
-WHERE ( PCR(IIB:IIE,:,:) .GT. 0.0 )
- ZFUP(IIB:IIE,:,:) = ZRUT(IIB:IIE,:,:) * PSRC(IIB-1:IIE-1,:,:)
- ZFCOR(IIB:IIE,:,:) = ZRUT(IIB:IIE,:,:) * &
- (1.0 - PCR(IIB:IIE,:,:)) * &
- (ZPHAT(IIB:IIE,:,:) - PSRC(IIB-1:IIE-1,:,:) - PCR(IIB:IIE,:,:) * &
- (ZPHAT(IIB-1:IIE-1,:,:) - 2.0*PSRC(IIB-1:IIE-1,:,:)+ZPHAT(IIB:IIE,:,:)))
-ELSEWHERE
- ZFUP(IIB:IIE,:,:) = ZRUT(IIB:IIE,:,:) * PSRC(IIB:IIE,:,:)
- ZFCOR(IIB:IIE,:,:) = ZRUT(IIB:IIE,:,:) * &
- (1.0 + PCR(IIB:IIE,:,:)) * &
- (ZPHAT(IIB:IIE,:,:) - PSRC(IIB:IIE,:,:) + PCR(IIB:IIE,:,:) * &
- (ZPHAT(IIB:IIE,:,:) - 2.0*PSRC(IIB:IIE,:,:) + ZPHAT(IIB+1:IIE+1,:,:)))
-END WHERE
-!
-! set boundaries to CYCL
-!
-WHERE ( PCR(IIB-1,:,:) .GT. 0.0 )
- ZFUP(IIB-1,:,:) = ZRUT(IIB-1,:,:) * PSRC(IIE-1,:,:)
- ZFCOR(IIB-1,:,:) = ZRUT(IIB-1,:,:) * &
- (1.0 - PCR(IIB-1,:,:)) * &
- (ZPHAT(IIB-1,:,:) - PSRC(IIE-1,:,:) - PCR(IIB-1,:,:) * &
- (ZPHAT(IIE-1,:,:) - 2.0*PSRC(IIE-1,:,:) + ZPHAT(IIB-1,:,:)))
-ELSEWHERE
- ZFUP(IIB-1,:,:) = ZRUT(IIB-1,:,:) * PSRC(IIB-1,:,:)
- ZFCOR(IIB-1,:,:) = ZRUT(IIB-1,:,:) * &
- (1.0 + PCR(IIB-1,:,:)) * &
- (ZPHAT(IIB-1,:,:) - PSRC(IIB-1,:,:) + PCR(IIB-1,:,:) * &
- (ZPHAT(IIB-1,:,:) - 2.0*PSRC(IIB-1,:,:) + ZPHAT(IIB,:,:)))
-END WHERE
-!
-WHERE ( PCR(IIE+1,:,:) .GT. 0.0 )
- ZFUP(IIE+1,:,:) = ZRUT(IIE+1,:,:) * PSRC(IIE,:,:)
- ZFCOR(IIE+1,:,:) = ZRUT(IIE+1,:,:) * &
- (1.0 - PCR(IIE+1,:,:)) * &
- (ZPHAT(IIE+1,:,:) - PSRC(IIE,:,:) - PCR(IIE+1,:,:) * &
- (ZPHAT(IIE,:,:) - 2.0*PSRC(IIE,:,:) + ZPHAT(IIE+1,:,:)))
-ELSEWHERE
- ZFUP(IIE+1,:,:) = ZRUT(IIE+1,:,:) * PSRC(IIE+1,:,:)
- ZFCOR(IIE+1,:,:) = ZRUT(IIE+1,:,:) * &
- (1.0 + PCR(IIE+1,:,:)) * &
- (ZPHAT(IIE+1,:,:) - PSRC(IIE+1,:,:) + PCR(IIE+1,:,:) * &
- (ZPHAT(IIE+1,:,:) - 2.0*PSRC(IIE+1,:,:) + ZPHAT(IIB+1,:,:)))
-END WHERE
-!
-! Perform limiting of the fluxes
-!
-! 1. calculate upwind tendency of the source
-!
-PR = PSRC*PRHO - PTSTEP*DXF(ZFUP)
-!
-!-------------------------------------------------------------------------------
-! compute and apply the limiters
-!
-DO II = IIB,IIE
- DO IJ = IJB-1,IJE+1
- DO IK = IKB-1,IKE+1
-!
-! 2. find local extrema in the source
-!
- ZSRCMAX = MAX( PSRC(II-1,IJ,IK),PSRC(II,IJ,IK),PSRC(II+1,IJ,IK) )
- ZSRCMIN = MIN( PSRC(II-1,IJ,IK),PSRC(II,IJ,IK),PSRC(II+1,IJ,IK) )
-!
-! 3. compute incoming and outgoing fluxes for this cell
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II+1,IJ,IK)) - MIN(0.,ZFCOR(II,IJ,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IK)) - MIN(0.,ZFCOR(II+1,IJ,IK)))
-!
-! 4. calculate fraction of outgoing and incoming flux which will drive scalar
-! values outside the local extrema
-!
- ZRNEG(II,IJ,IK) = MAX(0.,MIN(1., &
- (PR(II,IJ,IK) - PRHOT(II,IJ,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJ,IK) = MAX(0.,MIN(1., &
- (PRHOT(II,IJ,IK)*ZSRCMAX - PR(II,IJ,IK)) &
- / PTSTEP / ZFIN))
- END DO
- END DO
-END DO
-!
-! set CYCL boundaries
-!
-DO IJ = IJB-1,IJE+1
- DO IK = IKB-1,IKE+1
-!
- ZSRCMAX = MAX( PSRC(IIE-1,IJ,IK),PSRC(IIB-1,IJ,IK),PSRC(IIB,IJ,IK) )
- ZSRCMIN = MIN( PSRC(IIE-1,IJ,IK),PSRC(IIB-1,IJ,IK),PSRC(IIB,IJ,IK) )
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(IIB,IJ,IK)) - MIN(0.,ZFCOR(IIB-1,IJ,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(IIB-1,IJ,IK)) - MIN(0.,ZFCOR(IIB,IJ,IK)))
-!
- ZRNEG(IIB-1,IJ,IK) = MAX(0.,MIN(1., &
- (PR(IIB-1,IJ,IK) - PRHOT(IIB-1,IJ,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(IIB-1,IJ,IK) = MAX(0.,MIN(1., &
- (PRHOT(IIB-1,IJ,IK)*ZSRCMAX - PR(IIB-1,IJ,IK)) &
- / PTSTEP / ZFIN))
-!
-!
- ZSRCMAX = MAX( PSRC(IIE,IJ,IK),PSRC(IIE+1,IJ,IK),PSRC(IIB+1,IJ,IK) )
- ZSRCMIN = MIN( PSRC(IIE,IJ,IK),PSRC(IIE+1,IJ,IK),PSRC(IIB+1,IJ,IK) )
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(IIB+1,IJ,IK)) - MIN(0.,ZFCOR(IIE+1,IJ,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(IIE+1,IJ,IK)) - MIN(0.,ZFCOR(IIB+1,IJ,IK)))
-!
- ZRNEG(IIE+1,IJ,IK) = MAX(0.,MIN(1., &
- (PR(IIE+1,IJ,IK) - PRHOT(IIE+1,IJ,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(IIE+1,IJ,IK) = MAX(0.,MIN(1., &
- (PRHOT(IIE+1,IJ,IK)*ZSRCMAX - PR(IIE+1,IJ,IK)) &
- / PTSTEP / ZFIN))
-!
- END DO
-END DO
-!
-! 5. apply the limit to the fluxes where needed
-!
-ZFCOR(IIB:IIE+1,:,:) = MAX( &
- MIN(ZRNEG(IIB:IIE+1,:,:),ZRPOS(IIB-1:IIE,:,:)) * ZFCOR(IIB:IIE+1,:,:), &
- ZFCOR(IIB:IIE+1,:,:) )
-ZFCOR(IIB-1,:,:) = MAX( &
- MIN(ZRNEG(IIB-1,:,:),ZRPOS(IIE-1,:,:))*ZFCOR(IIB-1,:,:),ZFCOR(IIB-1,:,:))
-!ZFCOR(IIB-1,:,:) = MAX( ZRNEG(IIB-1,:,:)*ZFCOR(IIB-1,:,:), ZFCOR(IIB-1,:,:) )
-!
-ZFCOR(IIB:IIE+1,:,:) = MIN( &
- MIN(ZRPOS(IIB:IIE+1,:,:),ZRNEG(IIB-1:IIE,:,:)) * ZFCOR(IIB:IIE+1,:,:), &
- ZFCOR(IIB:IIE+1,:,:) )
-ZFCOR(IIB-1,:,:) = MIN( &
- MIN(ZRPOS(IIB-1,:,:),ZRNEG(IIE-1,:,:))*ZFCOR(IIB-1,:,:),ZFCOR(IIB-1,:,:))
-!ZFCOR(IIB-1,:,:) = MIN( ZRPOS(IIB-1,:,:)*ZFCOR(IIB-1,:,:), ZFCOR(IIB-1,:,:) )
-
-!-------------------------------------------------------------------------------
-! 6. apply the limited flux correction to scalar field
-!
-PR = PR - PTSTEP*DXF(ZFCOR)
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S1_X end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S1_X end:PR")
-END IF
-
-!$acc end data
-
-#ifdef MNH_OPENACC
- END SUBROUTINE PPM_S1_X_D
-END SUBROUTINE PPM_S1_X
-#else
-END FUNCTION PPM_S1_X
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-! ########################################################################
-! FUNCTION PPM_S1_Y(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
-! PTSTEP) RESULT(PR)
- SUBROUTINE PPM_S1_Y(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR)
-! ########################################################################
-USE MODE_ll
-USE MODE_IO
-use mode_msg
-USE MODI_SHUMAN_DEVICE
-!
-USE MODD_CONF
-USE MODD_LUNIT
-USE MODD_PARAMETERS
-!
-USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-
-INTEGER :: IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR )
-
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_Y', 'OpenACC: not yet implemented' )
-
- CALL MNH_GET_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
-
- CALL PPM_S1_Y_D(HLBCX, KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR, &
- ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRVT),ZT3D(:,:,:,IZFUP), &
- ZT3D(:,:,:,IZFCOR),ZT3D(:,:,:,IZRPOS),ZT3D(:,:,:,IZRNEG) )
-
- CALL MNH_REL_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
-
-!$acc end data
-
- CONTAINS
-!
-! ########################################################################
-! FUNCTION PPM_S1_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
-! PTSTEP) RESULT(PR)
- SUBROUTINE PPM_S1_Y_D(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR, ZPHAT,ZRVT,ZFUP,ZFCOR,ZRPOS,ZRNEG)
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_S1_Y(HLBCY, KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP) RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_S1_Y - PPM advection scheme in Y direction in Skamarock 2006
-!! notation - with flux limiting for monotonicity
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 23.6.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODE_ll
-use mode_mppdb
-
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-USE MODD_CONF
-USE MODD_PARAMETERS
-!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
-#endif
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! X direction LBC type
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-#ifndef MNH_OPENACC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
-#else
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-#endif
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER:: IIB,IJB,IKB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE,IKE ! End useful area in x,y,z directions
-!
-! variable at cell edges
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT, ZRVT
-!
-! advection fluxes, upwind and correction
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFUP, ZFCOR
-!
-! ratios for limiting the correction flux
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZRPOS, ZRNEG
-!
-! variables for limiting the correction flux
-REAL :: ZSRCMAX, ZSRCMIN, ZFIN, ZFOUT
-!
-!
-REAL, PARAMETER :: ZEPS = 1.0E-16
-!
-INTEGER :: II, IJ, IK
-INTEGER :: IRESP ! Return code of FM-routines
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR , &
-!$acc & ZPHAT, ZRVT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S1_Y beg:PCR")
- CALL MPPDB_CHECK(PRHO, "PPM_S1_Y beg:PRHO")
- CALL MPPDB_CHECK(PRHOT,"PPM_S1_Y beg:PRHOT")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC, "PPM_S1_Y beg:PSRC")
-END IF
-
-!
-IF ( L2D ) THEN
- PR = PSRC*PRHO
- !RETURN
-ELSE
-!
-!-------------------------------------------------------------------------------
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKB = 1 + JPVEXT
-IKE = SIZE(PSRC,3) - JPVEXT
-!
-!-------------------------------------------------------------------------------
-!
-ZRVT = PCR/PTSTEP * MYM(PRHO)
-!
-! calculate 4th order fluxes at cell edges in the inner domain !
-ZPHAT(:,IJB+1:IJE,:) = (7.0 * &
- (PSRC(:,IJB+1:IJE,:) + PSRC(:,IJB:IJE-1,:)) - &
- (PSRC(:,IJB+2:IJE+1,:) + PSRC(:,IJB-1:IJE-2,:))) / 12.0
-!
-SELECT CASE ( HLBCY(1) ) ! X direction LBC type: (1) for left side
-CASE ('CYCL','WALL') ! In that case one must have HLBCY(1) == HLBCY(2)
-!
- ZPHAT(:,IJB,:) = (7.0 * &
- (PSRC(:,IJB,:) + PSRC(:,IJB-1,:)) - &
- (PSRC(:,IJB+1,:) + PSRC(:,IJE-1,:))) / 12.0
-!
- ZPHAT(:,IJE+1,:) = ZPHAT(:,IJB,:)
- ZPHAT(:,IJB-1,:) = ZPHAT(:,IJE,:)
-!
-CASE ('OPEN')
-!
- ZPHAT(:,IJB,:) = 0.5*(PSRC(:,IJB-1,:) + PSRC(:,IJB,:))
- ZPHAT(:,IJB-1,:) = ZPHAT(:,IJB,:)
- ZPHAT(:,IJE+1,:) = 0.5*(PSRC(:,IJE,:) + PSRC(:,IJE+1,:))
-!
-!
-END SELECT
-!
-! calculate upwind and correction fluxes. upwind flux is upstream value of the
-! scalar variable, and correction flux is the correction to the upstream flux
-! that makes it equivalent to the PPM flux
-! flux_ppm = flux_up + flux_corr
-!
-WHERE ( PCR(:,IJB:IJE,:) .GT. 0.0 )
- ZFUP(:,IJB:IJE,:) = ZRVT(:,IJB:IJE,:) * PSRC(:,IJB-1:IJE-1,:)
- ZFCOR(:,IJB:IJE,:) = ZRVT(:,IJB:IJE,:) * &
- (1.0 - PCR(:,IJB:IJE,:)) * &
- (ZPHAT(:,IJB:IJE,:) - PSRC(:,IJB-1:IJE-1,:) - PCR(:,IJB:IJE,:) * &
- (ZPHAT(:,IJB-1:IJE-1,:) - 2.0*PSRC(:,IJB-1:IJE-1,:)+ZPHAT(:,IJB:IJE,:)))
-ELSEWHERE
- ZFUP(:,IJB:IJE,:) = ZRVT(:,IJB:IJE,:) * PSRC(:,IJB:IJE,:)
- ZFCOR(:,IJB:IJE,:) = ZRVT(:,IJB:IJE,:) * &
- (1.0 + PCR(:,IJB:IJE,:)) * &
- (ZPHAT(:,IJB:IJE,:) - PSRC(:,IJB:IJE,:) + PCR(:,IJB:IJE,:) * &
- (ZPHAT(:,IJB:IJE,:) - 2.0*PSRC(:,IJB:IJE,:) + ZPHAT(:,IJB+1:IJE+1,:)))
-END WHERE
-!
-! set boundaries to CYCL
-!
-WHERE ( PCR(:,IJB-1,:) .GT. 0.0 )
- ZFUP(:,IJB-1,:) = ZRVT(:,IJB-1,:) * PSRC(:,IJE-1,:)
- ZFCOR(:,IJB-1,:) = ZRVT(:,IJB-1,:) * &
- (1.0 - PCR(:,IJB-1,:)) * &
- (ZPHAT(:,IJB-1,:) - PSRC(:,IJE-1,:) - PCR(:,IJB-1,:) * &
- (ZPHAT(:,IJE-1,:) - 2.0*PSRC(:,IJE-1,:) + ZPHAT(:,IJB-1,:)))
-ELSEWHERE
- ZFUP(:,IJB-1,:) = ZRVT(:,IJB-1,:) * PSRC(:,IJB-1,:)
- ZFCOR(:,IJB-1,:) = ZRVT(:,IJB-1,:) * &
- (1.0 + PCR(:,IJB-1,:)) * &
- (ZPHAT(:,IJB-1,:) - PSRC(:,IJB-1,:) + PCR(:,IJB-1,:) * &
- (ZPHAT(:,IJB-1,:) - 2.0*PSRC(:,IJB-1,:) + ZPHAT(:,IJB,:)))
-END WHERE
-!
-WHERE ( PCR(:,IJE+1,:) .GT. 0.0 )
- ZFUP(:,IJE+1,:) = ZRVT(:,IJE+1,:) * PSRC(:,IJE,:)
- ZFCOR(:,IJE+1,:) = ZRVT(:,IJE+1,:) * &
- (1.0 - PCR(:,IJE+1,:)) * &
- (ZPHAT(:,IJE+1,:) - PSRC(:,IJE,:) - PCR(:,IJE+1,:) * &
- (ZPHAT(:,IJE,:) - 2.0*PSRC(:,IJE,:) + ZPHAT(:,IJE+1,:)))
-ELSEWHERE
- ZFUP(:,IJE+1,:) = ZRVT(:,IJE+1,:) * PSRC(:,IJE+1,:)
- ZFCOR(:,IJE+1,:) = ZRVT(:,IJE+1,:) * &
- (1.0 + PCR(:,IJE+1,:)) * &
- (ZPHAT(:,IJE+1,:) - PSRC(:,IJE+1,:) + PCR(:,IJE+1,:) * &
- (ZPHAT(:,IJE+1,:) - 2.0*PSRC(:,IJE+1,:) + ZPHAT(:,IJB+1,:)))
-END WHERE
-!
-! Perform limiting of the fluxes
-!
-! 1. calculate upwind tendency of the source
-!
-PR = PSRC*PRHO - PTSTEP*DYF(ZFUP)
-!
-!-------------------------------------------------------------------------------
-! compute and apply the limiters
-!
-DO II = IIB-1,IIE+1
- DO IJ = IJB,IJE
- DO IK = IKB-1,IKE+1
-!
-! 2. find local extrema in the source
-!
- ZSRCMAX = MAX( PSRC(II,IJ-1,IK),PSRC(II,IJ,IK),PSRC(II,IJ+1,IK) )
- ZSRCMIN = MIN( PSRC(II,IJ-1,IK),PSRC(II,IJ,IK),PSRC(II,IJ+1,IK) )
-!
-! 3. compute incoming and outgoing fluxes for this cell
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ+1,IK)) - MIN(0.,ZFCOR(II,IJ,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IK)) - MIN(0.,ZFCOR(II,IJ+1,IK)))
-!
-! 4. calculate fraction of outgoing and incoming flux which will drive scalar
-! values outside the local extrema
-!
- ZRNEG(II,IJ,IK) = MAX(0.,MIN(1., &
- (PR(II,IJ,IK) - PRHOT(II,IJ,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJ,IK) = MAX(0.,MIN(1., &
- (PRHOT(II,IJ,IK)*ZSRCMAX - PR(II,IJ,IK)) &
- / PTSTEP / ZFIN))
- END DO
- END DO
-END DO
-!
-! set CYCL boundaries
-!
-DO II = IIB-1,IIE+1
- DO IK = IKB-1,IKE+1
-!
- ZSRCMAX = MAX( PSRC(II,IJE-1,IK),PSRC(II,IJB-1,IK),PSRC(II,IJB,IK) )
- ZSRCMIN = MIN( PSRC(II,IJE-1,IK),PSRC(II,IJB-1,IK),PSRC(II,IJB,IK) )
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJB,IK)) - MIN(0.,ZFCOR(II,IJB-1,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJB-1,IK)) - MIN(0.,ZFCOR(II,IJB,IK)))
-!
- ZRNEG(II,IJB-1,IK) = MAX(0.,MIN(1., &
- (PR(II,IJB-1,IK) - PRHOT(II,IJB-1,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJB-1,IK) = MAX(0.,MIN(1., &
- (PRHOT(II,IJB-1,IK)*ZSRCMAX - PR(II,IJB-1,IK)) &
- / PTSTEP / ZFIN))
-!
-!
- ZSRCMAX = MAX( PSRC(II,IJE,IK),PSRC(II,IJE+1,IK),PSRC(II,IJB+1,IK) )
- ZSRCMIN = MIN( PSRC(II,IJE,IK),PSRC(II,IJE+1,IK),PSRC(II,IJB+1,IK) )
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJB+1,IK)) - MIN(0.,ZFCOR(II,IJE+1,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJE+1,IK)) - MIN(0.,ZFCOR(II,IJB+1,IK)))
-!
- ZRNEG(II,IJE+1,IK) = MAX(0.,MIN(1., &
- (PR(II,IJE+1,IK) - PRHOT(II,IJE+1,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJE+1,IK) = MAX(0.,MIN(1., &
- (PRHOT(II,IJE+1,IK)*ZSRCMAX - PR(II,IJE+1,IK)) &
- / PTSTEP / ZFIN))
-!
- END DO
-END DO
-!
-! 5. apply the limit to the fluxes where needed
-!
-ZFCOR(:,IJB:IJE+1,:) = MAX( &
- MIN(ZRNEG(:,IJB:IJE+1,:),ZRPOS(:,IJB-1:IJE,:)) * ZFCOR(:,IJB:IJE+1,:), &
- ZFCOR(:,IJB:IJE+1,:) )
-ZFCOR(:,IJB-1,:) = MAX( &
- MIN(ZRNEG(:,IJB-1,:),ZRPOS(:,IJE-1,:))*ZFCOR(:,IJB-1,:),ZFCOR(:,IJB-1,:))
-!
-ZFCOR(:,IJB:IJE+1,:) = MIN( &
- MIN(ZRPOS(:,IJB:IJE+1,:),ZRNEG(:,IJB-1:IJE,:)) * ZFCOR(:,IJB:IJE+1,:), &
- ZFCOR(:,IJB:IJE+1,:) )
-ZFCOR(:,IJB-1,:) = MIN( &
- MIN(ZRPOS(:,IJB-1,:),ZRNEG(:,IJE-1,:))*ZFCOR(:,IJB-1,:),ZFCOR(:,IJB-1,:))
-!
-!-------------------------------------------------------------------------------
-! 6. apply the limited flux correction to scalar field
-!
-PR = PR - PTSTEP*DYF(ZFCOR)
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S1_Y end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S1_Y end:PR")
-END IF
-
-END IF !not L2D
-
-!$acc end data
-
-#ifdef MNH_OPENACC
- END SUBROUTINE PPM_S1_Y_D
-END SUBROUTINE PPM_S1_Y
-#else
-END FUNCTION PPM_S1_Y
-#endif
-!
-!-------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------
-!
-#ifdef MNH_OPENACC
-!
-! ########################################################################
-! FUNCTION PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, &
-! PTSTEP) RESULT(PR)
- SUBROUTINE PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, &
- PTSTEP, PR)
-! ########################################################################
-USE MODE_ll
-USE MODE_IO
-use mode_msg
-
-USE MODI_SHUMAN_DEVICE
-!
-USE MODD_CONF
-USE MODD_LUNIT
-USE MODD_PARAMETERS
-!
-USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-
-INTEGER :: IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR )
-
- call Print_msg( NVERB_ERROR, 'GEN', 'PPM_S1_Z', 'OpenACC: not yet implemented' )
-
- CALL MNH_GET_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
-
- CALL PPM_S1_Z_D(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, PR, &
- ZT3D(:,:,:,IZPHAT),ZT3D(:,:,:,IZRVT),ZT3D(:,:,:,IZFUP), &
- ZT3D(:,:,:,IZFCOR),ZT3D(:,:,:,IZRPOS),ZT3D(:,:,:,IZRNEG) )
-
- CALL MNH_REL_ZT3D(IZPHAT,IZRVT,IZFUP,IZFCOR,IZRPOS,IZRNEG)
-
-!$acc end data
-
- CONTAINS
-! ########################################################################
- SUBROUTINE PPM_S1_Z_D(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP, &
- PR, ZPHAT,ZRVT,ZFUP,ZFCOR,ZRPOS,ZRNEG)
-! ########################################################################
-#else
-! ########################################################################
- FUNCTION PPM_S1_Z(KGRID, PSRC, PCR, PRHO, PRHOT, PTSTEP) &
- RESULT(PR)
-! ########################################################################
-#endif
-!!
-!!**** PPM_S1_Z - PPM advection scheme in Z direction in Skamarock 2006
-!! notation - with flux limiting for monotonicity
-!!
-!! MODIFICATIONS
-!! -------------
-!!
-!! 23.6.2006. T. Maric - original version
-!!
-!-------------------------------------------------------------------------------
-!
-USE MODE_ll
-use mode_mppdb
-
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN
-USE MODI_SHUMAN_DEVICE
-#endif
-!
-USE MODD_CONF
-USE MODD_PARAMETERS
-!USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
-#endif
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-INTEGER, INTENT(IN) :: KGRID ! C grid localisation
-!
-#ifndef MNH_OPENACC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
-#else
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-#endif
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCR ! Courant number
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO ! density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHOT ! density at t+dt
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-! output source term
-#ifndef MNH_OPENACC
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: PR
-#else
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PR
-#endif
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER:: IIB,IJB,IKB ! Begining useful area in x,y,z directions
-INTEGER:: IIE,IJE,IKE ! End useful area in x,y,z directions
-!
-! variable at cell edges
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZPHAT, ZRVT
-!
-! advection fluxes, upwind and correction
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZFUP, ZFCOR
-!
-! ratios for limiting the correction flux
-REAL, DIMENSION(SIZE(PCR,1),SIZE(PCR,2),SIZE(PCR,3)) :: ZRPOS, ZRNEG
-!
-! variables for limiting the correction flux
-REAL :: ZSRCMAX, ZSRCMIN, ZFIN, ZFOUT
-!
-REAL, PARAMETER :: ZEPS = 1.0E-16
-!
-INTEGER :: II, IJ, IK
-!
-!-------------------------------------------------------------------------------
-
-!$acc data present( PSRC, PCR, PRHO, PRHOT, PR, &
-!$acc & ZPHAT, ZRVT, ZFUP, ZFCOR, ZRPOS, ZRNEG )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PCR, "PPM_S1_Z beg:PCR")
- CALL MPPDB_CHECK(PRHO, "PPM_S1_Z beg:PRHO")
- CALL MPPDB_CHECK(PRHOT,"PPM_S1_Z beg:PRHOT")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC, "PPM_S1_Z beg:PSRC")
-END IF
-
-!
-!* 0.3. COMPUTES THE DOMAIN DIMENSIONS
-! ------------------------------
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKB = 1 + JPVEXT
-IKE = SIZE(PSRC,3) - JPVEXT
-!
-!-------------------------------------------------------------------------------
-!
-ZRVT = PCR/PTSTEP * MZM(PRHO)
-!
-! calculate 4th order fluxes at cell edges in the inner domain !
-ZPHAT(:,:,IKB+1:IKE) = (7.0 * &
- (PSRC(:,:,IKB+1:IKE) + PSRC(:,:,IKB:IKE-1)) - &
- (PSRC(:,:,IKB+2:IKE+1) + PSRC(:,:,IKB-1:IKE-2))) / 12.0
-!
-! set BC to WALL
-!
-ZPHAT(:,:,IKB) = (7.0 * &
- (PSRC(:,:,IKB) + PSRC(:,:,IKB+1)) - &
- (PSRC(:,:,IKB+1) + PSRC(:,:,IKB+2))) / 12.0
-ZPHAT(:,:,IKB-1) = ZPHAT(:,:,IKB+1)
-ZPHAT(:,:,IKE+1) = (7.0 * &
- (PSRC(:,:,IKE+1) + PSRC(:,:,IKE)) - &
- (PSRC(:,:,IKE) + PSRC(:,:,IKE-1))) / 12.0
-!
-! set BC to OPEN
-!
-!!$ZPHAT(:,:,IKB) = 0.5*(PSRC(:,:,IKB-1) + PSRC(:,:,IKB))
-!!$ZPHAT(:,:,IKB-1) = ZPHAT(:,:,IKB)
-!!$ZPHAT(:,:,IKE+1) = 0.5*(PSRC(:,:,IKE) + PSRC(:,:,IKE+1))
-!
-! calculate upwind and correction fluxes. upwind flux is upstream value of the
-! scalar variable, and correction flux is the correction to the upstream flux
-! that makes it equivalent to the PPM flux
-! flux_ppm = flux_up + flux_corr
-!
-WHERE ( PCR(:,:,IKB:IKE) .GT. 0.0 )
- ZFUP(:,:,IKB:IKE) = ZRVT(:,:,IKB:IKE) * PSRC(:,:,IKB-1:IKE-1)
- ZFCOR(:,:,IKB:IKE) = ZRVT(:,:,IKB:IKE) * &
- (1.0 - PCR(:,:,IKB:IKE)) * &
- (ZPHAT(:,:,IKB:IKE) - PSRC(:,:,IKB-1:IKE-1) - PCR(:,:,IKB:IKE) * &
- (ZPHAT(:,:,IKB-1:IKE-1) - 2.0*PSRC(:,:,IKB-1:IKE-1)+ZPHAT(:,:,IKB:IKE)))
-ELSEWHERE
- ZFUP(:,:,IKB:IKE) = ZRVT(:,:,IKB:IKE) * PSRC(:,:,IKB:IKE)
- ZFCOR(:,:,IKB:IKE) = ZRVT(:,:,IKB:IKE) * &
- (1.0 + PCR(:,:,IKB:IKE)) * &
- (ZPHAT(:,:,IKB:IKE) - PSRC(:,:,IKB:IKE) + PCR(:,:,IKB:IKE) * &
- (ZPHAT(:,:,IKB:IKE) - 2.0*PSRC(:,:,IKB:IKE) + ZPHAT(:,:,IKB+1:IKE+1)))
-END WHERE
-!
-! set BC to WALL
-!
-WHERE ( PCR(:,:,IKB-1) .GT. 0.0 )
- ZFUP(:,:,IKB-1) = ZRVT(:,:,IKB-1) * PSRC(:,:,IKB+2)
- ZFCOR(:,:,IKB-1) = ZRVT(:,:,IKB-1) * &
- (1.0 - PCR(:,:,IKB-1)) * &
- (ZPHAT(:,:,IKB+1) - PSRC(:,:,IKB+2) - PCR(:,:,IKB+1) * &
- (ZPHAT(:,:,IKB+2) - 2.0*PSRC(:,:,IKB+2) + ZPHAT(:,:,IKB+1)))
-ELSEWHERE
- ZFUP(:,:,IKB-1) = ZRVT(:,:,IKB-1) * PSRC(:,:,IKB+1)
- ZFCOR(:,:,IKB-1) = ZRVT(:,:,IKB-1) * &
- (1.0 + PCR(:,:,IKB-1)) * &
- (ZPHAT(:,:,IKB+1) - PSRC(:,:,IKB+1) + PCR(:,:,IKB+1) * &
- (ZPHAT(:,:,IKB+1) - 2.0*PSRC(:,:,IKB+1) + ZPHAT(:,:,IKB)))
-END WHERE
-!
-WHERE ( PCR(:,:,IKE+1) .GT. 0.0 )
- ZFUP(:,:,IKE+1) = ZRVT(:,:,IKE+1) * PSRC(:,:,IKE)
- ZFCOR(:,:,IKE+1) = ZRVT(:,:,IKE+1) * &
- (1.0 - PCR(:,:,IKE+1)) * &
- (ZPHAT(:,:,IKE+1) - PSRC(:,:,IKE) - PCR(:,:,IKE+1) * &
- (ZPHAT(:,:,IKE) - 2.0*PSRC(:,:,IKE) + ZPHAT(:,:,IKE+1)))
-ELSEWHERE
- ZFUP(:,:,IKE+1) = ZRVT(:,:,IKE+1) * PSRC(:,:,IKE+1)
- ZFCOR(:,:,IKE+1) = ZRVT(:,:,IKE+1) * &
- (1.0 + PCR(:,:,IKE+1)) * &
- (ZPHAT(:,:,IKE+1) - PSRC(:,:,IKE+1) + PCR(:,:,IKE+1) * &
- (ZPHAT(:,:,IKE+1) - 2.0*PSRC(:,:,IKE+1) + ZPHAT(:,:,IKE)))
-END WHERE
-!
-!
-!!$! set boundaries to CYCL
-!!$!
-!!$WHERE ( PCR(:,:,IKB-1) .GT. 0.0 )
-!!$ ZFUP(:,:,IKB-1) = ZRVT(:,:,IKB-1) * PSRC(:,:,IKE-1)
-!!$ ZFCOR(:,:,IKB-1) = ZRVT(:,:,IKB-1) * &
-!!$ (1.0 - PCR(:,:,IKB-1)) * &
-!!$ (ZPHAT(:,:,IKB-1) - PSRC(:,:,IKE-1) - PCR(:,:,IKB-1) * &
-!!$ (ZPHAT(:,:,IKE-1) - 2.0*PSRC(:,:,IKE-1) + ZPHAT(:,:,IKB-1)))
-!!$ELSEWHERE
-!!$ ZFUP(:,:,IKB-1) = ZRVT(:,:,IKB-1) * PSRC(:,:,IKB-1)
-!!$ ZFCOR(:,:,IKB-1) = ZRVT(:,:,IKB-1) * &
-!!$ (1.0 + PCR(:,:,IKB-1)) * &
-!!$ (ZPHAT(:,:,IKB-1) - PSRC(:,:,IKB-1) + PCR(:,:,IKB-1) * &
-!!$ (ZPHAT(:,:,IKB-1) - 2.0*PSRC(:,:,IKB-1) + ZPHAT(:,:,IKB)))
-!!$END WHERE
-!!$!
-!!$WHERE ( PCR(:,:,IKE+1) .GT. 0.0 )
-!!$ ZFUP(:,:,IKE+1) = ZRVT(:,:,IKE+1) * PSRC(:,:,IKE)
-!!$ ZFCOR(:,:,IKE+1) = ZRVT(:,:,IKE+1) * &
-!!$ (1.0 - PCR(:,:,IKE+1)) * &
-!!$ (ZPHAT(:,:,IKE+1) - PSRC(:,:,IKE) - PCR(:,:,IKE+1) * &
-!!$ (ZPHAT(:,:,IKE) - 2.0*PSRC(:,:,IKE) + ZPHAT(:,:,IKE+1)))
-!!$ELSEWHERE
-!!$ ZFUP(:,:,IKE+1) = ZRVT(:,:,IKE+1) * PSRC(:,:,IKE+1)
-!!$ ZFCOR(:,:,IKE+1) = ZRVT(:,:,IKE+1) * &
-!!$ (1.0 + PCR(:,:,IKE+1)) * &
-!!$ (ZPHAT(:,:,IKE+1) - PSRC(:,:,IKE+1) + PCR(:,:,IKE+1) * &
-!!$ (ZPHAT(:,:,IKE+1) - 2.0*PSRC(:,:,IKE+1) + ZPHAT(:,:,IKB+1)))
-!!$END WHERE
-!
-! Perform limiting of the fluxes
-!
-! 1. calculate upwind tendency of the source
-!
-PR = PSRC*PRHO - PTSTEP*DZF(ZFUP)
-!
-!-------------------------------------------------------------------------------
-! compute and apply the limiters
-!
-DO II = IIB-1,IIE+1
- DO IJ = IJB-1,IJE+1
- DO IK = IKB,IKE
-!
-! 2. find local extrema in the source
-!
- ZSRCMAX = MAX( PSRC(II,IJ,IK-1),PSRC(II,IJ,IK),PSRC(II,IJ,IK+1) )
- ZSRCMIN = MIN( PSRC(II,IJ,IK-1),PSRC(II,IJ,IK),PSRC(II,IJ,IK+1) )
-!
-! 3. compute incoming and outgoing fluxes for this cell
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IK+1)) - MIN(0.,ZFCOR(II,IJ,IK)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IK)) - MIN(0.,ZFCOR(II,IJ,IK+1)))
-!
-! 4. calculate fraction of outgoing and incoming flux which will drive scalar
-! values outside the local extrema
-!
- ZRNEG(II,IJ,IK) = MAX(0.,MIN(1., &
- (PR(II,IJ,IK) - PRHOT(II,IJ,IK)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJ,IK) = MAX(0.,MIN(1., &
- (PRHOT(II,IJ,IK)*ZSRCMAX - PR(II,IJ,IK)) &
- / PTSTEP / ZFIN))
- END DO
- END DO
-END DO
-!
-! set WALL boundaries
-!
-DO II = IIB-1,IIE+1
- DO IJ = IJB-1,IJE+1
-!
- ZSRCMAX = MAX( PSRC(II,IJ,IKB+1),PSRC(II,IJ,IKB) )
- ZSRCMIN = MIN( PSRC(II,IJ,IKB+1),PSRC(II,IJ,IKB) )
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKB)) - MIN(0.,ZFCOR(II,IJ,IKB-1)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKB-1)) - MIN(0.,ZFCOR(II,IJ,IKB)))
-!
- ZRNEG(II,IJ,IKB-1) = MAX(0.,MIN(1., &
- (PR(II,IJ,IKB-1) - PRHOT(II,IJ,IKB-1)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJ,IKB-1) = MAX(0.,MIN(1., &
- (PRHOT(II,IJ,IKB-1)*ZSRCMAX - PR(II,IJ,IKB-1)) &
- / PTSTEP / ZFIN))
-!
-!
- ZSRCMAX = MAX( PSRC(II,IJ,IKE),PSRC(II,IJ,IKE+1) )
- ZSRCMIN = MIN( PSRC(II,IJ,IKE),PSRC(II,IJ,IKE+1) )
-!
- ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKE)) - MIN(0.,ZFCOR(II,IJ,IKE+1)))
- ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKE+1)) - MIN(0.,ZFCOR(II,IJ,IKE)))
-!
- ZRNEG(II,IJ,IKE+1) = MAX(0.,MIN(1., &
- (PR(II,IJ,IKE+1) - PRHOT(II,IJ,IKE+1)*ZSRCMIN) &
- / PTSTEP / ZFOUT))
-!
- ZRPOS(II,IJ,IKE+1) = MAX(0.,MIN(1., &
- (PRHOT(II,IJ,IKE+1)*ZSRCMAX - PR(II,IJ,IKE+1)) &
- / PTSTEP / ZFIN))
-!
- END DO
-END DO
-!
-! set CYCL boundaries
-!
-!!$DO II = IIB-1,IIE+1
-!!$ DO IJ = IJB-1,IJE+1
-!!$!
-!!$ ZSRCMAX = MAX( PSRC(II,IJ,IKE-1),PSRC(II,IJ,IKB-1),PSRC(II,IJ,IKB) )
-!!$ ZSRCMIN = MIN( PSRC(II,IJ,IKE-1),PSRC(II,IJ,IKB-1),PSRC(II,IJ,IKB) )
-!!$!
-!!$ ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKB)) - MIN(0.,ZFCOR(II,IJ,IKB-1)))
-!!$ ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKB-1)) - MIN(0.,ZFCOR(II,IJ,IKB)))
-!!$!
-!!$ ZRNEG(II,IJ,IKB-1) = MAX(0.,MIN(1., &
-!!$ (PR(II,IJ,IKB-1) - PRHOT(II,IJ,IKB-1)*ZSRCMIN) &
-!!$ / PTSTEP / ZFOUT))
-!!$!
-!!$ ZRPOS(II,IJ,IKB-1) = MAX(0.,MIN(1., &
-!!$ (PRHOT(II,IJ,IKB-1)*ZSRCMAX - PR(II,IJ,IKB-1)) &
-!!$ / PTSTEP / ZFIN))
-!!$!
-!!$!
-!!$ ZSRCMAX = MAX( PSRC(II,IJ,IKE),PSRC(II,IJ,IKE+1),PSRC(II,IJ,IKB+1) )
-!!$ ZSRCMIN = MIN( PSRC(II,IJ,IKE),PSRC(II,IJ,IKE+1),PSRC(II,IJ,IKB+1) )
-!!$!
-!!$ ZFOUT = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKB+1)) - MIN(0.,ZFCOR(II,IJ,IKE+1)))
-!!$ ZFIN = MAX(ZEPS,MAX(0.,ZFCOR(II,IJ,IKE+1)) - MIN(0.,ZFCOR(II,IJ,IKB+1)))
-!!$!
-!!$ ZRNEG(II,IJ,IKE+1) = MAX(0.,MIN(1., &
-!!$ (PR(II,IJ,IKE+1) - PRHOT(II,IJ,IKE+1)*ZSRCMIN) &
-!!$ / PTSTEP / ZFOUT))
-!!$!
-!!$ ZRPOS(II,IJ,IKE+1) = MAX(0.,MIN(1., &
-!!$ (PRHOT(II,IJ,IKE+1)*ZSRCMAX - PR(II,IJ,IKE+1)) &
-!!$ / PTSTEP / ZFIN))
-!!$!
-!!$ END DO
-!!$END DO
-!
-! 5. apply the limit to the fluxes where needed
-!
-ZFCOR(:,:,IKB:IKE+1) = MAX( &
- MIN(ZRNEG(:,:,IKB:IKE+1),ZRPOS(:,:,IKB-1:IKE)) * ZFCOR(:,:,IKB:IKE+1), &
- ZFCOR(:,:,IKB:IKE+1) )
-ZFCOR(:,:,IKB-1) = MAX( &
- MIN(ZRNEG(:,:,IKB-1),ZRPOS(:,:,IKB+2))*ZFCOR(:,:,IKB-1),ZFCOR(:,:,IKB-1))
-!!$ZFCOR(:,:,IKB-1) = MAX( &
-!!$ MIN(ZRNEG(:,:,IKB-1),ZRPOS(:,:,IKE-1))*ZFCOR(:,:,IKB-1),ZFCOR(:,:,IKB-1))
-!
-ZFCOR(:,:,IKB:IKE+1) = MIN( &
- MIN(ZRPOS(:,:,IKB:IKE+1),ZRNEG(:,:,IKB-1:IKE)) * ZFCOR(:,:,IKB:IKE+1), &
- ZFCOR(:,:,IKB:IKE+1) )
-ZFCOR(:,:,IKB-1) = MIN( &
- MIN(ZRPOS(:,:,IKB-1),ZRNEG(:,:,IKB+2))*ZFCOR(:,:,IKB-1),ZFCOR(:,:,IKB-1))
-!!$ZFCOR(:,:,IKB-1) = MIN( &
-!!$ MIN(ZRPOS(:,:,IKB-1),ZRNEG(:,:,IKE-1))*ZFCOR(:,:,IKB-1),ZFCOR(:,:,IKB-1))
-!
-!-------------------------------------------------------------------------------
-! 6. apply the limited flux correction to scalar field
-!
-PR = PR - PTSTEP*DZF(ZFCOR)
-!
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PSRC,"PPM_S1_Z end:PSRC")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PR,"PPM_S1_Z end:PR")
-END IF
-
-!$acc end data
-
-#ifdef MNH_OPENACC
- END SUBROUTINE PPM_S1_Z_D
-END SUBROUTINE PPM_S1_Z
-#else
-END FUNCTION PPM_S1_Z
-#endif
--
GitLab