diff --git a/src/ZSOLVER/SURCOUCHE/mode_exchange2_ll.f90 b/src/ZSOLVER/SURCOUCHE/mode_exchange2_ll.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8d2affca44ef628c6003ff27fbe700901b5bba7e
--- /dev/null
+++ b/src/ZSOLVER/SURCOUCHE/mode_exchange2_ll.f90
@@ -0,0 +1,924 @@
+!MNH_LIC Copyright 1998-2019 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:
+! J. Escobar 15/09/2015: WENO5 & JPHEXT <> 1
+! P. Wautelet 21/05/2019: use name argument of LIST_ll for MPPDB_CHECK
+!-----------------------------------------------------------------
+
+! ########################
+ MODULE MODE_EXCHANGE2_ll
+! ########################
+!!
+!! Purpose
+!! -------
+!
+! The purpose of this module is the implementation of communication routine
+! UPDATE_HALO2 that updates the second layer of the halo
+!!
+!! Glossary
+!! --------
+! For short, we will refer as "halo2" the zone corresponding
+! to the second layer of the halo to be updated.
+!!
+!! Routines Of The User Interface
+!! ------------------------------
+!
+! SUBROUTINES : UPDATE_HALO2_ll, INIT_HALO2_ll
+!
+!! Reference
+!! ---------
+!
+! User Interface for Meso-NH parallel package
+! Ph. Kloos, L. Giraud, R. Guivarch, D. Lugato
+!
+!! Authors
+!! -------
+!
+! R. Guivarch, D. Lugato * CERFACS *
+! Ph. Kloos * CERFACS - CNRM *
+!
+!! Implicit Arguments
+!! ------------------
+!
+! Module MODD_ARGSLIST_ll
+! types HALO2LIST_ll, LIST_ll
+!
+! Module MODD_STRUCTURE_ll
+! types CRSPD_ll, ZONE_ll
+!
+! Module MODD_VAR_ll
+! IP - Number of local processor=subdomain
+! TCRRT_COMDATA - Current communication data structure for current model
+! and local processor
+! NHALO2_COM - MPI communicator for halo 2
+! NCOMBUFFSIZE2 - buffer size
+! MNHREAL_MPI - mpi precision
+! NNEXTTAG, NMAXTAG - variable to define message tag
+!
+!! Modifications
+!! -------------
+! Original May 19, 1998
+! R. Guivarch June 24, 1998 _ll
+! R. Guivarch June 29, 1998 MNHREAL_MPI
+! N. Gicquel October 30, 1998 COPY_CRSPD2
+! J.Escobar 10/02/2012 : Bug , in MPI_RECV replace
+! MPI_STATUSES_IGNORE with MPI_STATUS_IGNORE
+!
+!-------------------------------------------------------------------------------
+!
+implicit none
+!
+ CONTAINS
+!
+!-----------------------------------------------------------------------
+!
+! ######################################################################
+ SUBROUTINE INIT_HALO2_ll(TPHALO2LIST, KNBVAR, KDIMX, KDIMY, KDIMZ)
+! ######################################################################
+!
+!!**** *INIT_HALO2_ll* initialise the second layer of the halo
+!!
+!!
+!! Purpose
+!! -------
+! The purpose of this routine is to allocate and initialise the
+! TPHALO2LIST variable which contains the second layer of the
+! halo for each variable.
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_ARGSLIST_ll
+! type HALO2LIST_ll
+!!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! P. Kloos * CERFACS - CNRM *
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+!
+ IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of HALO2_lls
+ INTEGER :: KNBVAR ! number of HALO2_lls to allocate
+ INTEGER :: KDIMX, KDIMY, KDIMZ ! dimensions of the HALO2_lls
+!
+!
+!* 0.2 Declarations of local variables :
+!
+ TYPE(HALO2LIST_ll), POINTER :: TZHALO2LIST
+ INTEGER :: JJ ! loop counter
+
+ REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZWEST,ZEAST,ZSOUTH,ZNORTH
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Allocate the list of HALO2_lls
+!
+ ALLOCATE(TPHALO2LIST)
+ TZHALO2LIST => TPHALO2LIST
+!
+ DO JJ=1, KNBVAR
+!
+!* 1.1 Allocate the current HALO2_ll
+!
+ ALLOCATE(TZHALO2LIST%HALO2)
+
+ ALLOCATE(TZHALO2LIST%HALO2%WEST(KDIMY, KDIMZ))
+ ALLOCATE(TZHALO2LIST%HALO2%EAST(KDIMY, KDIMZ))
+ ALLOCATE(TZHALO2LIST%HALO2%SOUTH(KDIMX, KDIMZ))
+ ALLOCATE(TZHALO2LIST%HALO2%NORTH(KDIMX, KDIMZ))
+ ZWEST => TZHALO2LIST%HALO2%WEST
+ ZEAST => TZHALO2LIST%HALO2%EAST
+ ZSOUTH => TZHALO2LIST%HALO2%SOUTH
+ ZNORTH => TZHALO2LIST%HALO2%NORTH
+ !$acc enter data create(ZWEST,ZEAST,ZSOUTH,ZNORTH)
+
+ !$acc kernels
+ ZWEST=0.
+ ZEAST=0.
+ ZSOUTH=0.
+ ZNORTH=0.
+ !$acc end kernels
+
+ ALLOCATE(TZHALO2LIST%NEXT)
+!
+!* 1.2 Go to the next HALO2_ll, or terminate the list
+!
+ IF (JJ < KNBVAR) THEN
+ TZHALO2LIST => TZHALO2LIST%NEXT
+ ELSE
+ DEALLOCATE(TZHALO2LIST%NEXT)
+ NULLIFY(TZHALO2LIST%NEXT)
+ ENDIF
+ ENDDO
+!
+!-------------------------------------------------------------------------------
+!
+ END SUBROUTINE INIT_HALO2_ll
+!
+! ######################################################
+ SUBROUTINE UPDATE_HALO2_ll(TPLIST, TPLISTHALO2, KINFO)
+! ######################################################
+!
+!!**** *UPDATE_HALO2_ll* - routine to update the second layer halo
+!!
+!! Purpose
+!! -------
+! This routine updates the halo with the values computed by the
+! neighbor subdomains. The fields to be updated are in the
+! TPLIST list of fields. Before UPDATE_HALO is called, TPLIST
+! has been filled with the fields to be communicated
+!
+!!** Method
+!! ------
+! First the processors send their internal halos to their
+! neighboring processors/subdomains, and then they receive
+! their external halos from their neighboring processors.
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_ARGSLIST_ll
+! type HALO2LIST_ll, LIST_ll
+!
+! Module MODD_VAR_ll
+! TCRRT_COMDATA - Current communication data structure for current model
+! and local processor
+! NHALO2_COM - MPI communicator for halo 2
+!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! P. Kloos * CERFACS - CNRM *
+!! J.Escobar 21/03/014: add mppd_check for all updated field
+! P. Wautelet 21/05/2019: use name argument of LIST_ll for MPPDB_CHECK
+!
+!-------------------------------------------------------------------------------!
+!* 0. DECLARATIONS
+!
+ USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+ USE MODD_VAR_ll, ONLY : TCRRT_COMDATA, NHALO2_COM
+!
+ USE MODE_MPPDB
+!
+!* 0.1 declarations of arguments
+!
+ TYPE(LIST_ll), POINTER :: TPLIST ! pointer to the list of
+ ! fields to be sent
+ TYPE(HALO2LIST_ll), POINTER :: TPLISTHALO2 ! pointer to the list of
+ ! halo2 to be received
+ INTEGER :: KINFO ! return status
+!
+ TYPE(LIST_ll), POINTER :: TZFIELD
+!
+ INTEGER :: ICOUNT
+ CHARACTER(len=2) :: YCOUNT
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. SEND / RECV THE INTERNAL HALO TO/FROM THE NEIGHBORING PROCESSORS
+! ----------------------------------------------------
+!
+ CALL SEND_RECV_CRSPD2(TCRRT_COMDATA%TSEND_HALO2, TCRRT_COMDATA%TRECV_HALO2, &
+ TPLIST, TPLISTHALO2, NHALO2_COM, KINFO)
+
+!------------------------------------------------------------------------------
+!
+!* 2. ZONES TO SEND TO THE PROC ITSELF
+! --------------------------------
+!
+ CALL COPY_CRSPD2(TCRRT_COMDATA%TSEND_HALO2, TCRRT_COMDATA%TRECV_HALO2, &
+ TPLIST, TPLISTHALO2, KINFO)
+!
+!JUAN MPP_CHECK2D/3D
+!
+ IF (MPPDB_INITIALIZED) THEN
+ TZFIELD => TPLIST
+ ICOUNT=0
+ DO WHILE (ASSOCIATED(TZFIELD))
+ ICOUNT=ICOUNT+1
+ WRITE(YCOUNT,'(I2)') ICOUNT
+ if (tzfield%l1d) then
+ CALL MPPDB_CHECK(TZFIELD%ARRAY1D,"UPDATE_HALO2_ll::"//tzfield%cname)
+ else if (tzfield%l2d) then
+ CALL MPPDB_CHECK(TZFIELD%ARRAY2D,"UPDATE_HALO2_ll::"//tzfield%cname)
+ else if (tzfield%l3d) then
+ CALL MPPDB_CHECK(TZFIELD%ARRAY3D,"UPDATE_HALO2_ll::"//tzfield%cname)
+ end if
+ TZFIELD => TZFIELD%NEXT
+ END DO
+ END IF
+!
+!----------------------------------------------------------------------
+!
+ END SUBROUTINE UPDATE_HALO2_ll
+!
+! ##########################################################################
+ SUBROUTINE COPY_CRSPD2(TPSENDCRSPD, TPRECVCRSPD, TPSENDLIST, TPRECVLIST, &
+ KINFO)
+! ##########################################################################
+!
+!!**** *COPY_CRSPD2* - routine to copy zones that a proc sends to itself
+!!
+!! Purpose
+!! -------
+!!
+! Copy the field sendtplist of the zone sendcrspd to the field recvtplist
+! of the zones recvcrspd.
+!
+!!** Method
+!! ------
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_STRUCTURE_ll
+! type CRSPD_ll
+!
+! Module MODD_ARGSLIST_ll
+! type HALO2LIST_ll, LIST_ll
+!
+! Module MODD_VAR_ll
+! IP - Number of local processor=subdomain
+!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! N. Gicquel * CERFACS - CNRM *
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+ USE MODD_STRUCTURE_ll, ONLY : CRSPD_ll
+ USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+ USE MODD_VAR_ll, ONLY : IP
+!
+ IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+ TYPE(CRSPD_ll), POINTER :: TPSENDCRSPD, TPRECVCRSPD
+ TYPE(LIST_ll), POINTER :: TPSENDLIST
+ TYPE(HALO2LIST_ll), POINTER :: TPRECVLIST
+ INTEGER :: KINFO
+!
+!* 0.2 declarations of local variables
+!
+ TYPE(CRSPD_ll), POINTER :: TZSEND, TZRECV
+!
+!------------------------------------------------------------------------------
+!
+ TZSEND => TPSENDCRSPD
+ DO WHILE (ASSOCIATED(TZSEND))
+ IF (TZSEND%TELT%NUMBER == IP) THEN
+ TZRECV => TPRECVCRSPD
+ DO WHILE (ASSOCIATED(TZRECV))
+ IF (TZRECV%TELT%NUMBER == IP&
+ & .AND.TZSEND%TELT%MSSGTAG == TZRECV%TELT%MSSGTAG) THEN
+ CALL COPY_ZONE2(TZSEND%TELT, TZRECV%TELT, TPSENDLIST, &
+ TPRECVLIST, KINFO)
+ ENDIF
+ TZRECV => TZRECV%TNEXT
+ ENDDO
+ ENDIF
+ TZSEND => TZSEND%TNEXT
+ ENDDO
+!
+!------------------------------------------------------------------------------
+!
+ END SUBROUTINE COPY_CRSPD2
+!
+! ####################################################################
+ SUBROUTINE COPY_ZONE2(TPSEND, TPRECV, TPSENDLIST, TPRECVLIST, KINFO)
+! ####################################################################
+!
+!!**** *COPY_ZONE2* -
+!!
+!! Purpose
+!! -------
+! This routine copies the values of the fields in the TPSENDLIST to the
+! halo 2 fields of TPRECVLIST according the TPSEND and TPRECV zones
+!
+!!** Method
+!! ------
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_STRUCTURE_ll
+! type ZONE_ll
+!
+! Module MODD_ARGSLIST_ll
+! type HALO2LIST_ll, LIST_ll
+!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! P. Kloos * CERFACS - CNRM *
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+ USE MODD_STRUCTURE_ll, ONLY : ZONE_ll
+ USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+!
+ IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+ TYPE(ZONE_ll) :: TPSEND, TPRECV
+ TYPE(LIST_ll), POINTER :: TPSENDLIST
+ TYPE(HALO2LIST_ll), POINTER :: TPRECVLIST
+ INTEGER :: KINFO
+!
+!* 0.2 declarations of local variables
+!
+ TYPE(LIST_ll), POINTER :: TZLIST
+ TYPE(HALO2LIST_ll), POINTER :: TZHALO
+ REAL, DIMENSION(:,:), POINTER :: TZTAB2D
+ INTEGER :: IIBS, IIES, IJBS, IJES, IIBR, IIER, IJBR, IJER, IKES, IKBS, &
+ IKBR, IKER
+!
+ INTEGER, PARAMETER :: ISENDNORTH=2, &
+ ISENDWEST=4, &
+ ISENDSOUTH=6, &
+ ISENDEAST=8, &
+ ISENDCYCNORTH=12, &
+ ISENDCYCWEST=14, &
+ ISENDCYCSOUTH=16, &
+ ISENDCYCEAST=18
+!
+!-------------------------------------------------------------------------------
+!
+ IIBS = TPSEND%NXOR
+ IIES = TPSEND%NXEND
+ IJBS = TPSEND%NYOR
+ IJES = TPSEND%NYEND
+ IKBS = TPSEND%NZOR
+ IKES = TPSEND%NZEND
+!
+ IIBR = TPRECV%NXOR
+ IIER = TPRECV%NXEND
+ IJBR = TPRECV%NYOR
+ IJER = TPRECV%NYEND
+ IKBR = TPRECV%NZOR
+ IKER = TPRECV%NZEND
+!
+ TZLIST => TPSENDLIST
+ TZHALO => TPRECVLIST
+ DO WHILE (ASSOCIATED(TZLIST))
+ SELECT CASE(TPSEND%MSSGTAG)
+ CASE(ISENDNORTH, ISENDCYCNORTH)
+ TZTAB2D => TZHALO%HALO2%SOUTH
+ TZTAB2D(IIBR:IIER, IKBR:IKER) = &
+ TZLIST%ARRAY3D(IIBS:IIES, IJBS, IKBS:IKES)
+ CASE(ISENDSOUTH, ISENDCYCSOUTH)
+ TZTAB2D => TZHALO%HALO2%NORTH
+ TZTAB2D(IIBR:IIER, IKBR:IKER) = &
+ TZLIST%ARRAY3D(IIBS:IIES, IJBS, IKBS:IKES)
+ CASE(ISENDWEST, ISENDCYCWEST)
+ TZTAB2D => TZHALO%HALO2%EAST
+ TZTAB2D(IJBR:IJER, IKBR:IKER) = &
+ TZLIST%ARRAY3D(IIBS, IJBS:IJES, IKBS:IKES)
+ CASE(ISENDEAST, ISENDCYCEAST)
+ TZTAB2D => TZHALO%HALO2%WEST
+ TZTAB2D(IJBR:IJER, IKBR:IKER) = &
+ TZLIST%ARRAY3D(IIBS, IJBS:IJES, IKBS:IKES)
+ END SELECT
+ TZLIST => TZLIST%NEXT
+ TZHALO => TZHALO%NEXT
+ ENDDO
+!
+!-------------------------------------------------------------------------------
+!
+ END SUBROUTINE COPY_ZONE2
+!
+! ######################################################
+ SUBROUTINE FILLOUT_ZONE2(TPHALO2LIST, TPZONE, PBUFFER)
+! ######################################################
+!
+!!**** *FILLOUT_ZONE2* -
+!!
+!! Purpose
+!! -------
+! This routine receives the data of the fields of the TPHALO2LIST
+! list of fields situated in the TPZONE ZONE_ll.
+!
+!!** Method
+!! ------
+! First the data are received in a buffer. Then each field
+! of the TPHALO2LIST list of fields is filled in at the
+! location pointed by the zone.
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_STRUCTURE_ll
+! type ZONE_ll
+!
+! Module MODD_ARGSLIST_ll
+! type HALO2LIST_ll
+!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! P. Kloos * CERFACS - CNRM *
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_STRUCTURE_ll, ONLY : ZONE_ll
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ USE MODD_MPIF
+!
+ IMPLICIT NONE
+
+! INCLUDE 'mpif.h'
+!
+!* 0.1 declarations of arguments
+!
+ TYPE(ZONE_ll) :: TPZONE ! ZONE_ll to be received
+ TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of halo2 to be received
+ REAL, DIMENSION(:) :: PBUFFER ! reception buffer for unpacking data
+!
+! INTEGER, DIMENSION(MPI_STATUS_SIZE) :: KSTATUS ! status of received message
+!
+!* 0.2 declarations of local variables
+!
+ INTEGER :: JI,JJ,JK,JINC ! loop counters
+ TYPE(HALO2LIST_ll), POINTER :: TZHALO2 ! temporary list of halo2
+!
+ INTEGER, PARAMETER :: ISENDNORTH=2, &
+ ISENDWEST=4, &
+ ISENDSOUTH=6, &
+ ISENDEAST=8, &
+ ISENDCYCNORTH=12, &
+ ISENDCYCWEST=14, &
+ ISENDCYCSOUTH=16, &
+ ISENDCYCEAST=18
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Set MPI message tags
+! --------------------
+! ISENDNORTH = 2
+! ISENDWEST = 4
+! ISENDSOUTH = 6
+! ISENDEAST = 8
+!
+! ISENDCYCNORTH = 12 ! ! ISENDCYCWEST = 14 ! | In case of cyclic
+
+! ISENDCYCSOUTH = 16 ! | boundary conditions
+! ISENDCYCEAST = 18 ! /
+
+!
+!* 2. Store the received message
+! --------------------------
+!
+!* 2.1 See at which side of the halo the message has to be stored
+!
+ SELECT CASE(TPZONE%MSSGTAG)
+!
+!* 2.1.1 Message is to be put in the south halo
+!
+ CASE(ISENDNORTH, ISENDCYCNORTH)
+!
+!* 2.1.1.1 Go over the TPHALO2LIST list of halo2
+!
+ TZHALO2 => TPHALO2LIST
+ JINC=0
+ DO WHILE (ASSOCIATED(TZHALO2))
+!
+!* 2.1.1.2 Fill out the buffer in the south part of the halo2
+!
+ DO JK=TPZONE%NZOR, TPZONE%NZEND
+ DO JI=TPZONE%NXOR, TPZONE%NXEND
+!
+ JINC = JINC + 1
+ TZHALO2%HALO2%SOUTH(JI,JK) = PBUFFER(JINC)
+!
+ ENDDO
+ ENDDO
+!
+!* 2.1.1.3 Go to the next halo2 in the list
+!
+ TZHALO2 => TZHALO2%NEXT
+!
+ ENDDO
+!
+!* 2.1.2 Message is coming from the east
+!
+ CASE(ISENDWEST, ISENDCYCWEST)
+!
+!* 2.1.2.1 Go over the TPHALO2LIST list of halo2
+!
+ TZHALO2 => TPHALO2LIST
+ JINC=0
+ DO WHILE (ASSOCIATED(TZHALO2))
+!
+!* 2.1.2.2 Fill out the buffer in the east part of the halo2
+!
+ DO JK=TPZONE%NZOR, TPZONE%NZEND
+ DO JJ=TPZONE%NYOR, TPZONE%NYEND
+!
+ JINC = JINC + 1
+ TZHALO2%HALO2%EAST(JJ,JK) = PBUFFER(JINC)
+!
+ ENDDO
+ ENDDO
+!
+!* 2.1.2.3 Go to the next halo2 in the list
+!
+ TZHALO2 => TZHALO2%NEXT
+!
+ ENDDO
+!
+!* 2.1.3 Message is coming from the north
+!
+ CASE(ISENDSOUTH, ISENDCYCSOUTH)
+!
+!* 2.1.3.1 Go over the TPHALO2LIST list of halo2
+!
+ TZHALO2 => TPHALO2LIST
+ JINC=0
+ DO WHILE (ASSOCIATED(TZHALO2))
+!
+!* 2.1.3.2 Fill out the buffer in the north part of the halo2
+!
+ DO JK=TPZONE%NZOR, TPZONE%NZEND
+ DO JI=TPZONE%NXOR, TPZONE%NXEND
+!
+ JINC = JINC + 1
+ TZHALO2%HALO2%NORTH(JI,JK) = PBUFFER(JINC)
+!
+ ENDDO
+ ENDDO
+!
+!* 2.1.3.3 Go to the next halo2 in the list
+!
+ TZHALO2 => TZHALO2%NEXT
+!
+ ENDDO
+!
+!* 2.1.4 Message is coming from the west
+!
+ CASE(ISENDEAST, ISENDCYCEAST)
+!
+!* 2.1.4.1 Go over the TPHALO2LIST list of halo2
+!
+ TZHALO2 => TPHALO2LIST
+ JINC=0
+ DO WHILE (ASSOCIATED(TZHALO2))
+!
+!* 2.1.4.2 Fill out the buffer in the west part of the halo2
+!
+ DO JK=TPZONE%NZOR, TPZONE%NZEND
+ DO JJ=TPZONE%NYOR, TPZONE%NYEND
+!
+ JINC = JINC + 1
+ TZHALO2%HALO2%WEST(JJ,JK) = PBUFFER(JINC)
+!
+ ENDDO
+ ENDDO
+!
+!* 2.1.4.3 Go to the next halo2 in the list
+!
+ TZHALO2 => TZHALO2%NEXT
+!
+ ENDDO
+!
+ END SELECT
+!
+!-------------------------------------------------------------------------------
+!
+ END SUBROUTINE FILLOUT_ZONE2
+!
+! ########################################################################
+ SUBROUTINE SEND_RECV_CRSPD2(TPCRSPDSEND, TPCRSPDRECV, TPFIELDLISTSEND, &
+ TPFIELDLISTRECV, KMPI_COMM, KINFO)
+! ########################################################################
+!
+!!**** *SEND_RECV_CRSPD2* -
+!
+!! Purpose
+!! -------
+! This routine sends the data of the TPFIELDLISTSEND list
+! to the correspondants of the TPCRSPDSEND list
+! and receives the data of the TPFIELDLISTRECV list
+! from the correspondants of the TPCRSPDRECV list
+!
+!!** Method
+!! ------
+!
+! This routine is based on the following rule :
+! one sent for one received (if it is possible);
+! The algorithm is the following :
+!
+! while (there is some messages to send)
+! OR (there is some messages to receive)
+! do
+! if (there is some messages to send)
+! send the first of the list
+! end if
+! if (there is some messages to receive)
+! try to receive
+! end if
+! done
+!
+! The receptions are non-blocking and don't follow necessarly
+! the order of the TPCRSPDRECV list
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_STRUCTURE_ll
+! type CRSPD_ll, ZONE_ll
+!
+! Module MODD_ARGSLIST_ll
+! type LIST_ll, HALO2LIST_ll
+!
+! Module MODD_VAR_ll
+! IP - Number of local processor=subdomain
+! NCOMBUFFSIZE2 - buffer size
+! NNEXTTAG, NMAXTAG - variable to define message tag
+!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! P. Kloos * CERFACS - CNRM *
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+ USE MODD_STRUCTURE_ll, ONLY : CRSPD_ll, ZONE_ll
+ USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+ use modd_precision, only: MNHREAL_MPI
+ USE MODD_VAR_ll, ONLY : NCOMBUFFSIZE2, IP, NNEXTTAG, NMAXTAG
+ USE MODE_EXCHANGE_ll, ONLY : FILLIN_BUFFERS
+ USE MODD_MPIF
+!JUANZ
+ USE MODD_CONFZ, ONLY : LMNH_MPI_BSEND
+!JUANZ
+!
+ USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE
+!
+ IMPLICIT NONE
+!
+! INCLUDE 'mpif.h'
+!
+!* 0.1 declarations of arguments
+!
+ TYPE(CRSPD_ll), POINTER :: TPCRSPDSEND, TPCRSPDRECV
+ TYPE(LIST_ll), POINTER :: TPFIELDLISTSEND
+ TYPE(HALO2LIST_ll), POINTER :: TPFIELDLISTRECV
+ INTEGER :: KMPI_COMM
+ INTEGER :: KINFO
+!
+!* 0.2 declarations of local variables
+!
+ INTEGER :: JINC, JI, JJ, JK ! Loop and counter variables
+ INTEGER :: FOUND, KERROR
+!
+!JUAN
+!if defined (MNH_MPI_ISEND)
+ REAL, DIMENSION (:,:), ALLOCATABLE,TARGET :: TZBUFFER ! Buffers for info
+ ! received
+!!$#else
+!!$ REAL, DIMENSION (NCOMBUFFSIZE2), TARGET :: TZBUFFER ! Buffers for info
+!!$ ! received
+!!$#endif
+!JUAN
+!
+ ! INTEGER IRECVSTATUS(MPI_STATUS_SIZE) ! Status of completed receive request
+ LOGICAL :: IRECVFLAG, ISENDFLAG
+ INTEGER :: IMSGTAG, ISENDERPROC
+!
+ INTEGER :: IRECVNB, ISENDNB ! Total numbers of receive and send to do
+ INTEGER :: IRECVDONE ! RECEIVE COMPLETED (receive and treated)
+!
+ TYPE(CRSPD_ll), POINTER :: TPMAILSEND, TPMAILRECV
+ TYPE(ZONE_ll), POINTER :: TZZONESEND
+!
+ TYPE(LIST_ll), POINTER :: TZFIELDLISTSEND
+ TYPE(HALO2LIST_ll), POINTER :: TZFIELDLISTRECV
+ INTEGER, SAVE :: ITAGOFFSET = 0
+! JUAN
+!if defined (MNH_MPI_ISEND)
+INTEGER,PARAMETER :: MPI_MAX_REQ = 1024
+!INTEGER,SAVE,DIMENSION(MPI_MAX_REQ) :: REQ_TAB
+!INTEGER,SAVE,DIMENSION(MPI_STATUS_SIZE,MPI_MAX_REQ) :: STATUS_TAB
+INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB
+INTEGER :: NB_REQ,NFIRST_REQ_RECV
+!endif
+! JUAN
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALISATIONS
+! ---------------
+!
+ TZFIELDLISTSEND => TPFIELDLISTSEND
+ TZFIELDLISTRECV => TPFIELDLISTRECV
+!
+ IRECVDONE = 0
+!
+ IF (ASSOCIATED(TPCRSPDRECV)) THEN
+ IRECVNB = TPCRSPDRECV%NCARDDIF
+ ELSE
+ IRECVNB = 0
+ ENDIF
+ IF (ASSOCIATED(TPCRSPDSEND)) THEN
+ ISENDNB = TPCRSPDSEND%NCARDDIF
+ ELSE
+ ISENDNB = 0
+ ENDIF
+
+!JUAN
+!if defined (MNH_MPI_ISEND)
+ IF (LMNH_MPI_BSEND) THEN
+ ALLOCATE(TZBUFFER(NCOMBUFFSIZE2,1))
+ ELSE
+ ALLOCATE(TZBUFFER(NCOMBUFFSIZE2,ISENDNB+IRECVNB))
+ NB_REQ = 0
+ ALLOCATE(REQ_TAB(ISENDNB+IRECVNB))
+ END IF
+!endif
+!JUAN
+!
+ TPMAILRECV => TPCRSPDRECV
+ TPMAILSEND => TPCRSPDSEND
+!
+!NZJUAN CALL MPI_BARRIER(KMPI_COMM, KERROR)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. MAIN LOOP
+! ---------
+!
+ DO WHILE (ASSOCIATED(TPMAILSEND))
+!
+!* 2.1 if there is still something to send
+!
+ IF (ASSOCIATED(TPMAILSEND)) THEN
+ TZZONESEND => TPMAILSEND%TELT
+ IF (TZZONESEND%NUMBER /= IP) THEN
+ JINC = 0
+!JUAN
+!if defined(MNH_MPI_ISEND)
+ IF ( .NOT. LMNH_MPI_BSEND) THEN
+ NB_REQ = NB_REQ + 1
+ CALL FILLIN_BUFFERS(TZFIELDLISTSEND, TZZONESEND, TZBUFFER(:,NB_REQ), JINC)
+ else
+ CALL FILLIN_BUFFERS(TZFIELDLISTSEND, TZZONESEND, TZBUFFER(:,1), JINC)
+ endif
+!JUAN
+!if defined(MNH_MPI_BSEND)
+ IF (LMNH_MPI_BSEND) THEN
+ CALL MPI_BSEND(TZBUFFER, JINC, MNHREAL_MPI, &
+ TZZONESEND%NUMBER - 1, TZZONESEND%MSSGTAG + ITAGOFFSET, &
+ KMPI_COMM, KERROR)
+else
+!JUAN
+!if defined(MNH_MPI_ISEND)
+ CALL MPI_ISEND(TZBUFFER(1,NB_REQ), JINC, MNHREAL_MPI, &
+ TZZONESEND%NUMBER - 1, TZZONESEND%MSSGTAG + ITAGOFFSET, &
+ KMPI_COMM, REQ_TAB(NB_REQ), KERROR)
+
+ endif
+!JUAN
+
+ ENDIF
+ TPMAILSEND => TPMAILSEND%TNEXT
+ ENDIF
+ ENDDO
+
+!NZJUAN CALL MPI_BARRIER(KMPI_COMM, KERROR)
+
+! JUAN
+!if defined (MNH_MPI_ISEND)
+ IF ( .NOT. LMNH_MPI_BSEND) THEN
+ NFIRST_REQ_RECV = NB_REQ
+ endif
+ ! JUAN
+
+ DO WHILE (ASSOCIATED(TPMAILRECV))
+ IF (TPMAILRECV%TELT%NUMBER == IP) THEN
+ TPMAILRECV => TPMAILRECV%TNEXT
+ ELSE
+! JUAN
+!if defined (MNH_MPI_ISEND)
+ IF ( .NOT. LMNH_MPI_BSEND) THEN
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(TZBUFFER(1,NB_REQ), NCOMBUFFSIZE2, MNHREAL_MPI, &
+ TPMAILRECV%TELT%NUMBER-1, &
+ TPMAILRECV%TELT%MSSGTAG + ITAGOFFSET, &
+ KMPI_COMM, REQ_TAB(NB_REQ), KERROR)
+else
+ CALL MPI_RECV(TZBUFFER, NCOMBUFFSIZE2, MNHREAL_MPI, &
+ TPMAILRECV%TELT%NUMBER-1, &
+ TPMAILRECV%TELT%MSSGTAG + ITAGOFFSET, &
+ KMPI_COMM, MPI_STATUS_IGNORE, KERROR)
+ CALL FILLOUT_ZONE2(TZFIELDLISTRECV, TPMAILRECV%TELT, TZBUFFER(:,1))
+endif
+! JUAN
+ TPMAILRECV => TPMAILRECV%TNEXT
+ ENDIF
+
+ ENDDO
+
+! JUAN
+!if defined (MNH_MPI_ISEND)
+ IF ( .NOT. LMNH_MPI_BSEND) THEN
+ CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,KINFO)
+
+ TPMAILRECV => TPCRSPDRECV
+ NB_REQ = NFIRST_REQ_RECV
+
+ DO WHILE (ASSOCIATED(TPMAILRECV))
+ IF (TPMAILRECV%TELT%NUMBER == IP) THEN
+ TPMAILRECV => TPMAILRECV%TNEXT
+ ELSE
+ NB_REQ = NB_REQ + 1
+ CALL FILLOUT_ZONE2(TZFIELDLISTRECV, TPMAILRECV%TELT, TZBUFFER(:,NB_REQ))
+ TPMAILRECV => TPMAILRECV%TNEXT
+ ENDIF
+
+ ENDDO
+
+ DEALLOCATE(REQ_TAB)
+ endif
+!JUAN
+!
+ DEALLOCATE(TZBUFFER)
+ ITAGOFFSET = MOD((ITAGOFFSET + NNEXTTAG), NMAXTAG)
+!
+!NZJUAN CALL MPI_BARRIER(KMPI_COMM, KERROR)
+!
+!-------------------------------------------------------------------------------!
+ END SUBROUTINE SEND_RECV_CRSPD2
+!
+END MODULE MODE_EXCHANGE2_ll
diff --git a/src/ZSOLVER/advection_uvw.f90 b/src/ZSOLVER/advection_uvw.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5c92dba01d1c9910880d4c3c759bf75d12817e6c
--- /dev/null
+++ b/src/ZSOLVER/advection_uvw.f90
@@ -0,0 +1,584 @@
+!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.
+!-----------------------------------------------------------------
+! #########################
+ MODULE MODI_ADVECTION_UVW
+! #########################
+!
+INTERFACE
+ SUBROUTINE ADVECTION_UVW (HUVW_ADV_SCHEME, &
+ HTEMP_SCHEME, KWENO_ORDER, OSPLIT_WENO, &
+ HLBCX, HLBCY, PTSTEP, &
+ PUT, PVT, PWT, &
+ PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, &
+ PRUS, PRVS, PRWS, &
+ PRUS_PRES, PRVS_PRES, PRWS_PRES )
+!
+CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME ! to the selected
+CHARACTER(LEN=4), INTENT(IN) :: HTEMP_SCHEME ! Temporal scheme
+!
+INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO
+ ! scheme (3 or 5)
+LOGICAL, INTENT(IN) :: OSPLIT_WENO ! flag to add a time
+ ! splitting to RK for WENO
+!
+CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
+!
+REAL, INTENT(IN) :: PTSTEP
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT , PVT , PWT
+ ! Variables at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS , PRVS, PRWS
+ ! Sources terms
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUS_PRES, PRVS_PRES, PRWS_PRES
+!
+END SUBROUTINE ADVECTION_UVW
+!
+END INTERFACE
+!
+END MODULE MODI_ADVECTION_UVW
+! ##########################################################################
+ SUBROUTINE ADVECTION_UVW (HUVW_ADV_SCHEME, &
+ HTEMP_SCHEME, KWENO_ORDER, OSPLIT_WENO, &
+ HLBCX, HLBCY, PTSTEP, &
+ PUT, PVT, PWT, &
+ PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, &
+ PRUS, PRVS, PRWS, &
+ PRUS_PRES, PRVS_PRES, PRWS_PRES )
+! ##########################################################################
+!
+!!**** *ADVECTION_UVW * - routine to call the specialized advection routines for wind
+!!
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book1 and book2 ( routine ADVECTION )
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!! J.-P. Lafore * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/07/94
+!! 01/04/95 (Ph. Hereil J. Nicolau) add the model number
+!! 23/10/95 (J. Vila and JP Lafore) advection schemes scalar
+!! 16/01/97 (JP Pinty) change presentation
+!! 30/04/98 (J. Stein P Jabouille) extrapolation for the cyclic
+!! case and parallelisation
+!! 24/06/99 (P Jabouille) case of NHALO>1
+!! 25/10/05 (JP Pinty) 4th order scheme
+!! 04/2011 (V. Masson & C. Lac) splits the routine and adds
+!! time splitting
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! C.LAC 10/2016 : Add OSPLIT_WENO
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+USE MODD_PARAMETERS, ONLY : JPVEXT
+USE MODD_CONF, ONLY : NHALO
+USE MODD_BUDGET
+!
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+USE MODI_CONTRAV
+USE MODI_ADVECUVW_RK
+USE MODI_ADV_BOUNDARIES
+USE MODI_BUDGET
+USE MODI_GET_HALO
+!
+#ifdef MNH_OPENACC
+USE MODE_DEVICE
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D, MNH_GET_ZT4D , MNH_REL_ZT4D, &
+ MNH_ALLOCATE_ZT3D
+#endif
+use mode_mppdb
+!
+!-------------------------------------------------------------------------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME ! to the selected
+CHARACTER(LEN=4), INTENT(IN) :: HTEMP_SCHEME ! Temporal scheme
+!
+INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO
+ ! scheme (3 or 5)
+LOGICAL, INTENT(IN) :: OSPLIT_WENO ! flag to add a time
+ ! splitting to RK for WENO
+!
+CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
+!
+REAL, INTENT(IN) :: PTSTEP
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT , PVT , PWT
+ ! Variables at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS , PRVS, PRWS
+ ! Sources terms
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUS_PRES, PRVS_PRES, PRWS_PRES
+!
+!
+!* 0.2 declarations of local variables
+!
+!
+!
+INTEGER :: IKE ! indice K End in z direction
+!
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRUT
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRVT
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRWT
+INTEGER :: IZRUT,IZRVT,IZRWT
+ ! cartesian
+ ! components of
+ ! momentum
+!
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRUCT
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRVCT
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRWCT
+INTEGER :: IZRUCT,IZRVCT,IZRWCT
+ ! contravariant
+ ! components
+ ! of momentum
+!
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZU, ZV, ZW
+INTEGER :: IZU, IZV, IZW
+! Guesses at the end of the sub time step
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRUS_OTHER
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRVS_OTHER
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRWS_OTHER
+INTEGER :: IZRUS_OTHER,IZRVS_OTHER,IZRWS_OTHER
+! Contribution of the RK time step
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRUS_ADV
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRVS_ADV
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRWS_ADV
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZMXM_RHODJ
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZMYM_RHODJ
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZMZM_RHODJ
+INTEGER :: IZRUS_ADV,IZRVS_ADV,IZRWS_ADV
+INTEGER :: IZMXM_RHODJ,IZMYM_RHODJ,IZMZM_RHODJ
+!
+! Momentum tendencies due to advection
+INTEGER :: ISPLIT ! Number of splitting loops
+INTEGER :: JSPL ! Loop index
+REAL :: ZTSTEP ! Sub Time step
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+TYPE(LIST_ll), POINTER :: TZFIELD_ll ! list of fields to exchange
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+TYPE(LIST_ll), POINTER :: TZFIELDS0_ll ! list of fields to exchange
+!
+#ifdef MNH_OPENACC
+INTEGER :: ISPL, IZUT, IZVT, IZWT, IZ1, IZ2
+INTEGER :: IZRUSB, IZRUSE, IZRVSB, IZRVSE, IZRWSB, IZRWSE
+#endif
+!
+INTEGER :: IIU,IJU,IKU
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. INITIALIZATION
+! --------------
+!
+!
+IIU = SIZE(PUT,1)
+IJU = SIZE(PUT,2)
+IKU = SIZE(PUT,3)
+!
+!$acc data present( PUT, PVT, PWT, PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, PRUS, PRVS, PRWS, PRUS_PRES, PRVS_PRES, PRWS_PRES )
+
+IF (MPPDB_INITIALIZED) THEN
+ !Check all IN arrays
+ CALL MPPDB_CHECK(PUT,"ADVECTION_UVW beg:PUT")
+ CALL MPPDB_CHECK(PVT,"ADVECTION_UVW beg:PVT")
+ CALL MPPDB_CHECK(PWT,"ADVECTION_UVW beg:PWT")
+ CALL MPPDB_CHECK(PRHODJ,"ADVECTION_UVW beg:PRHODJ")
+ CALL MPPDB_CHECK(PDXX,"ADVECTION_UVW beg:PDXX")
+ CALL MPPDB_CHECK(PDYY,"ADVECTION_UVW beg:PDYY")
+ CALL MPPDB_CHECK(PDZZ,"ADVECTION_UVW beg:PDZZ")
+ CALL MPPDB_CHECK(PDZX,"ADVECTION_UVW beg:PDZX")
+ CALL MPPDB_CHECK(PDZY,"ADVECTION_UVW beg:PDZY")
+ CALL MPPDB_CHECK(PRUS_PRES,"ADVECTION_UVW beg:PRUS_PRES")
+ CALL MPPDB_CHECK(PRVS_PRES,"ADVECTION_UVW beg:PRVS_PRES")
+ CALL MPPDB_CHECK(PRWS_PRES,"ADVECTION_UVW beg:PRWS_PRES")
+ !Check all INOUT arrays
+ CALL MPPDB_CHECK(PRUS,"ADVECTION_UVW beg:PRUS")
+ CALL MPPDB_CHECK(PRVS,"ADVECTION_UVW beg:PRVS")
+ CALL MPPDB_CHECK(PRWS,"ADVECTION_UVW beg:PRWS")
+END IF
+
+#ifndef MNH_OPENACC
+ALLOCATE( ZRUT ( IIU,IJU,IKU ) )
+ALLOCATE( ZRVT ( IIU,IJU,IKU ) )
+ALLOCATE( ZRWT ( IIU,IJU,IKU ) )
+ALLOCATE( ZRUCT ( IIU,IJU,IKU ) )
+ALLOCATE( ZRVCT ( IIU,IJU,IKU ) )
+ALLOCATE( ZRWCT ( IIU,IJU,IKU ) )
+ALLOCATE( ZU ( IIU,IJU,IKU ) )
+ALLOCATE( ZV ( IIU,IJU,IKU ) )
+ALLOCATE( ZW ( IIU,IJU,IKU ) )
+ALLOCATE( ZRUS_OTHER( IIU,IJU,IKU ) )
+ALLOCATE( ZRVS_OTHER( IIU,IJU,IKU ) )
+ALLOCATE( ZRWS_OTHER( IIU,IJU,IKU ) )
+ALLOCATE( ZRUS_ADV ( IIU,IJU,IKU ) )
+ALLOCATE( ZRVS_ADV ( IIU,IJU,IKU ) )
+ALLOCATE( ZRWS_ADV ( IIU,IJU,IKU ) )
+ALLOCATE( ZMXM_RHODJ( IIU,IJU,IKU ) )
+ALLOCATE( ZMYM_RHODJ( IIU,IJU,IKU ) )
+ALLOCATE( ZMZM_RHODJ( IIU,IJU,IKU ) )
+#else
+IZRUT = MNH_ALLOCATE_ZT3D( ZRUT ,IIU,IJU,IKU )
+IZRVT = MNH_ALLOCATE_ZT3D( ZRVT ,IIU,IJU,IKU )
+IZRWT = MNH_ALLOCATE_ZT3D( ZRWT ,IIU,IJU,IKU )
+IZRUCT = MNH_ALLOCATE_ZT3D( ZRUCT ,IIU,IJU,IKU )
+IZRVCT = MNH_ALLOCATE_ZT3D( ZRVCT ,IIU,IJU,IKU )
+IZRWCT = MNH_ALLOCATE_ZT3D( ZRWCT ,IIU,IJU,IKU )
+IZU = MNH_ALLOCATE_ZT3D( ZU ,IIU,IJU,IKU )
+IZV = MNH_ALLOCATE_ZT3D( ZV ,IIU,IJU,IKU )
+IZW = MNH_ALLOCATE_ZT3D( ZW ,IIU,IJU,IKU )
+IZRUS_OTHER = MNH_ALLOCATE_ZT3D( ZRUS_OTHER,IIU,IJU,IKU )
+IZRVS_OTHER = MNH_ALLOCATE_ZT3D( ZRVS_OTHER,IIU,IJU,IKU )
+IZRWS_OTHER = MNH_ALLOCATE_ZT3D( ZRWS_OTHER,IIU,IJU,IKU )
+IZRUS_ADV = MNH_ALLOCATE_ZT3D( ZRUS_ADV ,IIU,IJU,IKU )
+IZRVS_ADV = MNH_ALLOCATE_ZT3D( ZRVS_ADV ,IIU,IJU,IKU )
+IZRWS_ADV = MNH_ALLOCATE_ZT3D( ZRWS_ADV ,IIU,IJU,IKU )
+IZMXM_RHODJ = MNH_ALLOCATE_ZT3D( ZMXM_RHODJ,IIU,IJU,IKU )
+IZMYM_RHODJ = MNH_ALLOCATE_ZT3D( ZMYM_RHODJ,IIU,IJU,IKU )
+IZMZM_RHODJ = MNH_ALLOCATE_ZT3D( ZMZM_RHODJ,IIU,IJU,IKU )
+#endif
+
+!$acc data present( zrut, zrvt, zrwt, zruct, zrvct, zrwct, zu, zv, zw, &
+!$acc & zrus_other, zrvs_other, zrws_other, zrus_adv, zrvs_adv, zrws_adv, &
+!$acc & zmxm_rhodj, zmym_rhodj, zmzm_rhodj )
+
+#ifdef MNH_OPENACC
+#if 0
+CALL INIT_ON_HOST_AND_DEVICE(ZRUT,-1e99,'ADVECTION_UVW::ZRUT')
+CALL INIT_ON_HOST_AND_DEVICE(ZRVT,-2e99,'ADVECTION_UVW::ZRVT')
+CALL INIT_ON_HOST_AND_DEVICE(ZRWT,-3e99,'ADVECTION_UVW::ZRWT')
+CALL INIT_ON_HOST_AND_DEVICE(ZRUCT,-1e98,'ADVECTION_UVW::ZRUCT')
+CALL INIT_ON_HOST_AND_DEVICE(ZRVCT,-2e98,'ADVECTION_UVW::ZRVCT')
+CALL INIT_ON_HOST_AND_DEVICE(ZRWCT,-3e98,'ADVECTION_UVW::ZRWCT')
+CALL INIT_ON_HOST_AND_DEVICE(ZU,-1e99,'ADVECTION_UVW::ZU')
+CALL INIT_ON_HOST_AND_DEVICE(ZV,-1e99,'ADVECTION_UVW::ZV')
+CALL INIT_ON_HOST_AND_DEVICE(ZW,-1e99,'ADVECTION_UVW::ZW')
+CALL INIT_ON_HOST_AND_DEVICE(ZRUS_OTHER,-1e99,'ADVECTION_UVW::ZRUS_OTHER')
+CALL INIT_ON_HOST_AND_DEVICE(ZRVS_OTHER,-1e99,'ADVECTION_UVW::ZRVS_OTHER')
+CALL INIT_ON_HOST_AND_DEVICE(ZRWS_OTHER,-1e99,'ADVECTION_UVW::ZRWS_OTHER')
+CALL INIT_ON_HOST_AND_DEVICE(ZRUS_ADV,-1e99,'ADVECTION_UVW::ZRUS_ADV')
+CALL INIT_ON_HOST_AND_DEVICE(ZRVS_ADV,-1e99,'ADVECTION_UVW::ZRVS_ADV')
+CALL INIT_ON_HOST_AND_DEVICE(ZRWS_ADV,-1e99,'ADVECTION_UVW::ZRWS_ADV')
+CALL INIT_ON_HOST_AND_DEVICE(ZMXM_RHODJ,-1e97,'ADVECTION_UVW::ZMXM_RHODJ')
+CALL INIT_ON_HOST_AND_DEVICE(ZMYM_RHODJ,-2e97,'ADVECTION_UVW::ZMYM_RHODJ')
+CALL INIT_ON_HOST_AND_DEVICE(ZMZM_RHODJ,-3e97,'ADVECTION_UVW::ZMZM_RHODJ')
+#endif
+!
+SELECT CASE (HTEMP_SCHEME)
+ CASE('RK11')
+ ISPL = 1
+ CASE('RK21')
+ ISPL = 2
+ CASE('NP32')
+ ISPL = 3
+ CASE('SP32')
+ ISPL = 3
+ CASE('RK33')
+ ISPL = 3
+ CASE('RKC4')
+ ISPL = 4
+ CASE('RK4B')
+ ISPL = 4
+ CASE('RK53')
+ ISPL = 5
+ CASE('RK62')
+ ISPL = 6
+ CASE('RK65')
+ ISPL = 6
+ CASE DEFAULT
+ call Print_msg( NVERB_FATAL, 'GEN', 'ADVECTION_UVW', 'unknown htemp_scheme' )
+END SELECT
+!
+CALL MNH_GET_ZT3D(IZUT, IZVT, IZWT, IZ1, IZ2)
+CALL MNH_GET_ZT4D(ISPL, IZRUSB, IZRUSE)
+CALL MNH_GET_ZT4D(ISPL, IZRVSB, IZRVSE)
+CALL MNH_GET_ZT4D(ISPL, IZRWSB, IZRWSE)
+#endif
+!
+IKE = SIZE(PWT,3) - JPVEXT
+!
+#ifndef MNH_OPENACC
+ZMXM_RHODJ = MXM(PRHODJ)
+ZMYM_RHODJ = MYM(PRHODJ)
+ZMZM_RHODJ = MZM(PRHODJ)
+#else
+CALL MXM_DEVICE(PRHODJ,ZMXM_RHODJ)
+CALL MYM_DEVICE(PRHODJ,ZMYM_RHODJ)
+CALL MZM_DEVICE(PRHODJ,ZMZM_RHODJ)
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTES THE CONTRAVARIANT COMPONENTS
+! -------------------------------------
+!
+!$acc kernels
+ZRUT(:,:,:) = PUT(:,:,:) * ZMXM_RHODJ(:,:,:)
+ZRVT(:,:,:) = PVT(:,:,:) * ZMYM_RHODJ(:,:,:)
+ZRWT(:,:,:) = PWT(:,:,:) * ZMZM_RHODJ(:,:,:)
+!$acc end kernels
+
+!
+#ifndef MNH_OPENACC
+NULLIFY(TZFIELD_ll)
+!!$IF(NHALO == 1) THEN
+ CALL ADD3DFIELD_ll( TZFIELD_ll, ZRUT, 'ADVECTION_UVW::ZRUT' )
+ CALL ADD3DFIELD_ll( TZFIELD_ll, ZRVT, 'ADVECTION_UVW::ZRVT' )
+ CALL UPDATE_HALO_ll(TZFIELD_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELD_ll)
+!!$END IF
+#else
+! acc update self(ZRUT,ZRVT)
+ CALL GET_HALO_D(ZRUT,HNAME='ADVECTION_UVW::ZRUT')
+ CALL GET_HALO_D(ZRVT,HNAME='ADVECTION_UVW::ZRVT')
+! acc update device(ZRUT,ZRVT)
+#endif
+
+
+!
+#ifndef MNH_OPENACC
+CALL CONTRAV (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,4)
+#else
+CALL CONTRAV_DEVICE (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,4,&
+ ZT3D(:,:,:,IZ1),ZT3D(:,:,:,IZ2),ODATA_ON_DEVICE=.TRUE.)
+!Not necessary: already done in contrav_device !$acc update self(ZRUCT,ZRVCT,ZRWCT)
+#endif
+!
+#ifndef MNH_OPENACC
+ NULLIFY(TZFIELDS_ll)
+!!$IF(NHALO == 1) THEN
+ CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRWCT, 'ADVECTION_UVW::ZRWCT' )
+ CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRUCT, 'ADVECTION_UVW::ZRUCT' )
+ CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRVCT, 'ADVECTION_UVW::ZRVCT' )
+ CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELDS_ll)
+!!$END IF
+#else
+ CALL GET_HALO_D(ZRUCT,HNAME='ADVECTION_UVW::ZRUCT')
+ CALL GET_HALO_D(ZRVCT,HNAME='ADVECTION_UVW::ZRVCT')
+ CALL GET_HALO_D(ZRWCT,HNAME='ADVECTION_UVW::ZRWCT')
+! acc update device(ZRUCT,ZRVCT,ZRWCT) !Needed in advecuvw_weno_k called by advecuvw_rk
+#endif
+
+
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 2. COMPUTES THE TENDENCIES SINCE THE BEGINNING OF THE TIME STEP
+! ------------------------------------------------------------
+!
+!$acc kernels
+ZRUS_OTHER(:,:,:) = PRUS(:,:,:) - ZRUT(:,:,:) / PTSTEP + PRUS_PRES(:,:,:)
+ZRVS_OTHER(:,:,:) = PRVS(:,:,:) - ZRVT(:,:,:) / PTSTEP + PRVS_PRES(:,:,:)
+ZRWS_OTHER(:,:,:) = PRWS(:,:,:) - ZRWT(:,:,:) / PTSTEP + PRWS_PRES(:,:,:)
+!$acc end kernels
+!
+! Top and bottom Boundaries
+!
+#ifndef MNH_OPENACC
+CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRUS_OTHER)
+CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRVS_OTHER)
+CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRWS_OTHER)
+#else
+CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRUS_OTHER)
+CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRVS_OTHER)
+CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRWS_OTHER)
+#endif
+!$acc kernels
+ZRWS_OTHER(:,:,IKE+1) = 0.
+!$acc end kernels
+
+#ifndef MNH_OPENACC
+
+NULLIFY(TZFIELDS0_ll)
+!!$IF(NHALO == 1) THEN
+ CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRUS_OTHER, 'ADVECTION_UVW::ZRUS_OTHER' )
+ CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRVS_OTHER, 'ADVECTION_UVW::ZRVS_OTHER' )
+ CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRWS_OTHER, 'ADVECTION_UVW::ZRWS_OTHER' )
+ CALL UPDATE_HALO_ll(TZFIELDS0_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELDS0_ll)
+!!$END IF
+#else
+! acc update self(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
+ CALL GET_HALO_D(ZRUS_OTHER,HNAME='ADVECTION_UVW::ZRUS_OTHER' )
+ CALL GET_HALO_D(ZRVS_OTHER,HNAME='ADVECTION_UVW::ZRVS_OTHER' )
+ CALL GET_HALO_D(ZRWS_OTHER,HNAME='ADVECTION_UVW::ZRWS_OTHER' )
+! acc update device(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
+#endif
+
+
+!
+!
+!
+!-------------------------------------------------------------------------------
+!
+IF ( HUVW_ADV_SCHEME == 'CEN4TH' ) THEN
+ ISPLIT = 1
+ELSE IF (OSPLIT_WENO) THEN
+ ISPLIT = 2
+ELSE
+ ISPLIT = 1
+END IF
+ZTSTEP = PTSTEP / REAL(ISPLIT)
+!
+!-------------------------------------------------------------------------------
+!
+!$acc kernels
+ZU(:,:,:) = PUT(:,:,:)
+ZV(:,:,:) = PVT(:,:,:)
+ZW(:,:,:) = PWT(:,:,:)
+!$acc end kernels
+!$acc update self(ZU,ZV,ZW)
+!
+!
+!* 3. TIME SPLITTING
+! --------------
+!
+DO JSPL=1,ISPLIT
+!
+ CALL ADVECUVW_RK (HUVW_ADV_SCHEME, &
+ HTEMP_SCHEME, KWENO_ORDER, &
+ HLBCX, HLBCY, ZTSTEP, &
+ ZU, ZV, ZW, &
+ PUT, PVT, PWT, &
+ ZMXM_RHODJ, ZMYM_RHODJ, ZMZM_RHODJ, &
+ ZRUCT, ZRVCT, ZRWCT, &
+ ZRUS_ADV, ZRVS_ADV, ZRWS_ADV, &
+ ZRUS_OTHER, ZRVS_OTHER, ZRWS_OTHER &
+#ifndef MNH_OPENACC
+ )
+#else
+ ,ZT3D(:,:,:,IZUT), ZT3D(:,:,:,IZVT), ZT3D(:,:,:,IZWT), &
+ ZT3D(:,:,:,IZRUSB:IZRUSE), ZT3D(:,:,:,IZRVSB:IZRVSE), ZT3D(:,:,:,IZRWSB:IZRWSE) )
+#endif
+!
+! Tendencies on wind
+!$acc update device(ZRUS_ADV,ZRVS_ADV,ZRWS_ADV)
+!$acc kernels
+ PRUS(:,:,:) = PRUS(:,:,:) + ZRUS_ADV(:,:,:) / ISPLIT
+ PRVS(:,:,:) = PRVS(:,:,:) + ZRVS_ADV(:,:,:) / ISPLIT
+ PRWS(:,:,:) = PRWS(:,:,:) + ZRWS_ADV(:,:,:) / ISPLIT
+!$acc end kernels
+!
+ IF (JSPL<ISPLIT) THEN
+!
+! Guesses for next time splitting loop
+ !
+ !$acc kernels
+ ZU(:,:,:) = ZU(:,:,:) + ZTSTEP / ZMXM_RHODJ * &
+ (ZRUS_OTHER(:,:,:) + ZRUS_ADV(:,:,:))
+ ZV(:,:,:) = ZV(:,:,:) + ZTSTEP / ZMYM_RHODJ * &
+ (ZRVS_OTHER(:,:,:) + ZRVS_ADV(:,:,:))
+ ZW(:,:,:) = ZW(:,:,:) + ZTSTEP / ZMZM_RHODJ * &
+ (ZRWS_OTHER(:,:,:) + ZRWS_ADV(:,:,:))
+ !$acc end kernels
+ END IF
+!
+! Top and bottom Boundaries
+!
+ IF (JSPL<ISPLIT) THEN
+#ifndef MNH_OPENACC
+ CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZU, PUT, 'U' )
+ CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZV, PVT, 'V' )
+ CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZW, PWT, 'W' )
+#else
+ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZU, PUT, 'U' )
+ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZV, PVT, 'V' )
+ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZW, PWT, 'W' )
+#endif
+!$acc kernels
+ ZW (:,:,IKE+1 ) = 0.
+!$acc end kernels
+!$acc update self(ZU,ZV,ZW)
+ END IF
+!
+! End of the time splitting loop
+END DO
+!
+!
+!* 4. BUDGETS
+! -------
+!
+IF (LBUDGET_U) THEN
+!$acc update self(PRUS)
+ CALL BUDGET (PRUS,1,'ADV_BU_RU')
+END IF
+IF (LBUDGET_V) THEN
+!$acc update self(PRVS)
+ CALL BUDGET (PRVS,2,'ADV_BU_RV')
+END IF
+IF (LBUDGET_W) THEN
+!$acc update self(PRWS)
+ CALL BUDGET (PRWS,3,'ADV_BU_RW')
+END IF
+!-------------------------------------------------------------------------------
+!
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT4D(ISPL, IZRWSB)
+CALL MNH_REL_ZT4D(ISPL, IZRVSB)
+CALL MNH_REL_ZT4D(ISPL, IZRUSB)
+CALL MNH_REL_ZT3D(IZUT, IZVT, IZWT, IZ1, IZ2)
+#endif
+
+IF (MPPDB_INITIALIZED) THEN
+ !Check all INOUT arrays
+ CALL MPPDB_CHECK(PRUS,"ADVECTION_UVW end:PRUS")
+ CALL MPPDB_CHECK(PRVS,"ADVECTION_UVW end:PRVS")
+ CALL MPPDB_CHECK(PRWS,"ADVECTION_UVW end:PRWS")
+END IF
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+DEALLOCATE(zrut, zrvt, zrwt, zruct, zrvct, zrwct, zu, zv, zw, &
+ zrus_other, zrvs_other, zrws_other, zrus_adv, zrvs_adv, zrws_adv, &
+ zmxm_rhodj, zmym_rhodj, zmzm_rhodj )
+#else
+CALL MNH_REL_ZT3D(izmxm_rhodj, izmym_rhodj, izmzm_rhodj )
+CALL MNH_REL_ZT3D(izrus_other, izrvs_other, izrws_other, izrus_adv, izrvs_adv, izrws_adv )
+CALL MNH_REL_ZT3D(izrut, izrvt, izrwt, izruct, izrvct, izrwct, izu, izv, izw)
+#endif
+
+!$acc end data
+
+END SUBROUTINE ADVECTION_UVW
diff --git a/src/ZSOLVER/advecuvw_rk.f90 b/src/ZSOLVER/advecuvw_rk.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6bdfae2fe4342040acd6d061ac9fa988b5f72be6
--- /dev/null
+++ b/src/ZSOLVER/advecuvw_rk.f90
@@ -0,0 +1,581 @@
+!MNH_LIC Copyright 1994-2019 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.
+!-----------------------------------------------------------------
+! #####################
+ MODULE MODI_ADVECUVW_RK
+! #####################
+!
+INTERFACE
+ SUBROUTINE ADVECUVW_RK (HUVW_ADV_SCHEME, &
+ HTEMP_SCHEME, KWENO_ORDER, &
+ HLBCX, HLBCY, PTSTEP, &
+ PU, PV, PW, &
+ PUT, PVT, PWT, &
+ PMXM_RHODJ, PMYM_RHODJ, PMZM_RHODJ, &
+ PRUCT, PRVCT, PRWCT, &
+ PRUS_ADV, PRVS_ADV, PRWS_ADV, &
+ PRUS_OTHER, PRVS_OTHER, PRWS_OTHER &
+#ifndef MNH_OPENACC
+ )
+#else
+ ,ZUT, ZVT, ZWT, ZRUS, ZRVS, ZRWS)
+#endif
+!
+CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME! to the selected
+CHARACTER(LEN=4), INTENT(IN) :: HTEMP_SCHEME ! Temporal scheme
+!
+INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO
+ ! scheme (3 or 5)
+!
+CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
+!
+REAL, INTENT(IN) :: PTSTEP
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PU , PV , PW
+ ! Variables to advect
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT , PWT
+ ! Variables at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMXM_RHODJ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMYM_RHODJ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMZM_RHODJ
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT , PRVCT, PRWCT
+ ! Contravariant wind components
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUS_ADV , PRVS_ADV, PRWS_ADV
+ ! Tendency due to advection
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUS_OTHER , PRVS_OTHER, PRWS_OTHER
+! ! tendencies from other processes
+#ifdef MNH_OPENACC
+! Work arrays
+REAL, DIMENSION(:,:,:) :: ZUT, ZVT, ZWT
+REAL, DIMENSION(:,:,:,:) :: ZRUS,ZRVS,ZRWS
+#endif
+!
+!
+END SUBROUTINE ADVECUVW_RK
+!
+END INTERFACE
+!
+END MODULE MODI_ADVECUVW_RK
+! ##########################################################################
+ SUBROUTINE ADVECUVW_RK (HUVW_ADV_SCHEME, &
+ HTEMP_SCHEME, KWENO_ORDER, &
+ HLBCX, HLBCY, PTSTEP, &
+ PU, PV, PW, &
+ PUT, PVT, PWT, &
+ PMXM_RHODJ, PMYM_RHODJ, PMZM_RHODJ, &
+ PRUCT, PRVCT, PRWCT, &
+ PRUS_ADV, PRVS_ADV, PRWS_ADV, &
+ PRUS_OTHER, PRVS_OTHER, PRWS_OTHER &
+#ifndef MNH_OPENACC
+ )
+#else
+ ,ZUT, ZVT, ZWT, ZRUS, ZRVS, ZRWS)
+#endif
+! ##########################################################################
+!
+!!**** *ADVECUVW_RK * - routine to call the specialized advection routines for wind
+!!
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book1 and book2 ( routine ADVECTION )
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!! J.-P. Lafore * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/07/94
+!! 01/04/95 (Ph. Hereil J. Nicolau) add the model number
+!! 23/10/95 (J. Vila and JP Lafore) advection schemes scalar
+!! 16/01/97 (JP Pinty) change presentation
+!! 30/04/98 (J. Stein P Jabouille) extrapolation for the cyclic
+!! case and parallelisation
+!! 24/06/99 (P Jabouille) case of NHALO>1
+!! 25/10/05 (JP Pinty) 4th order scheme
+!! 24/04/06 (C.Lac) Split scalar and passive
+!! tracer routines
+!! 08/06 (T.Maric) PPM scheme
+!! 04/2011 (V. Masson & C. Lac) splits the routine and adds
+!! time splitting
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! F.Auguste and C.Lac : 08/16 : CEN4TH with RKC4
+!! C.Lac 10/16 : Correction on RK loop
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ARGSLIST_ll, ONLY: LIST_ll, HALO2LIST_ll
+USE MODD_CONF, ONLY: NHALO
+USE MODD_PARAMETERS, ONLY: JPVEXT
+!
+USE MODE_ll
+USE MODE_MPPDB
+use mode_msg
+!
+USE MODI_ADV_BOUNDARIES
+USE MODI_ADVECUVW_4TH
+USE MODI_ADVECUVW_WENO_K
+USE MODI_GET_HALO
+USE MODI_SHUMAN
+!
+!
+#ifdef MNH_OPENACC
+USE MODE_DEVICE
+USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME! to the selected
+CHARACTER(LEN=4), INTENT(IN) :: HTEMP_SCHEME ! Temporal scheme
+!
+INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO
+ ! scheme (3 or 5)
+!
+CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
+!
+REAL, INTENT(IN) :: PTSTEP
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PU , PV , PW
+ ! Variables to advect
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT , PWT
+ ! Variables at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMXM_RHODJ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMYM_RHODJ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMZM_RHODJ
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT , PRVCT, PRWCT
+ ! Contravariant wind components
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUS_ADV , PRVS_ADV, PRWS_ADV
+ ! Tendency due to advection
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUS_OTHER , PRVS_OTHER, PRWS_OTHER
+! ! tendencies from other processes
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:) :: ZUT, ZVT, ZWT
+REAL, DIMENSION(:,:,:,:) :: ZRUS,ZRVS,ZRWS
+#endif
+!
+!
+!
+!* 0.2 declarations of local variables
+!
+!
+!
+character(len=3) :: ynum
+INTEGER :: IKE ! indice K End in z direction
+!
+#ifndef MNH_OPENACC
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZUT, ZVT, ZWT
+! Intermediate Guesses inside the RK loop
+!
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZRUS,ZRVS,ZRWS
+#endif
+! Momentum tendencies due to advection
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZBUT ! Butcher array coefficients
+ ! at the RK sub time step
+REAL, DIMENSION(:), ALLOCATABLE :: ZBUTS! Butcher array coefficients
+ ! at the end of the RK loop
+!JUAN
+TYPE(LIST_ll), POINTER :: TZFIELDMT_ll ! list of fields to exchange
+TYPE(HALO2LIST_ll), POINTER :: TZHALO2MT_ll ! momentum variables
+TYPE(HALO2LIST_ll), SAVE , POINTER :: TZHALO2_UT,TZHALO2_VT,TZHALO2_WT
+LOGICAL , SAVE :: GFIRST_CALL_ADVECUVW_RK = .TRUE.
+INTEGER :: INBVAR
+INTEGER :: IIU, IJU, IKU ! array sizes
+!JUAN
+
+#ifdef MNH_OPENACC
+INTEGER :: IZMEAN, IZWORK
+#endif
+! Momentum tendencies due to advection
+INTEGER :: ISPL ! Number of RK splitting loops
+INTEGER :: JI, JS ! Loop index
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+TYPE(LIST_ll), POINTER :: TZFIELD_ll ! list of fields to exchange
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+TYPE(LIST_ll), POINTER :: TZFIELDS0_ll ! list of fields to exchange
+TYPE(LIST_ll), POINTER :: TZFIELDS4_ll ! list of fields to exchange
+!
+!-------------------------------------------------------------------------------
+!$acc data present( PU, PV, PW, PUT, PVT, PWT, PMXM_RHODJ, PMYM_RHODJ, PMZM_RHODJ, &
+!$acc & PRUCT, PRVCT, PRWCT, PRUS_ADV, PRVS_ADV, PRWS_ADV, &
+!$acc & PRUS_OTHER, PRVS_OTHER, PRWS_OTHER, ZUT, ZVT, ZWT, ZRUS, ZRVS, ZRWS )
+
+IF (MPPDB_INITIALIZED) THEN
+ !Check all IN arrays
+ CALL MPPDB_CHECK(PU,"ADVECUVW_RK beg:PU")
+ CALL MPPDB_CHECK(PV,"ADVECUVW_RK beg:PV")
+ CALL MPPDB_CHECK(PW,"ADVECUVW_RK beg:PW")
+ CALL MPPDB_CHECK(PUT,"ADVECUVW_RK beg:PUT")
+ CALL MPPDB_CHECK(PVT,"ADVECUVW_RK beg:PVT")
+ CALL MPPDB_CHECK(PWT,"ADVECUVW_RK beg:PWT")
+ CALL MPPDB_CHECK(PMXM_RHODJ,"ADVECUVW_RK beg:PMXM_RHODJ")
+ CALL MPPDB_CHECK(PMYM_RHODJ,"ADVECUVW_RK beg:PMYM_RHODJ")
+ CALL MPPDB_CHECK(PMZM_RHODJ,"ADVECUVW_RK beg:PMZM_RHODJ")
+ CALL MPPDB_CHECK(PRUCT,"ADVECUVW_RK beg:PRUCT")
+ CALL MPPDB_CHECK(PRVCT,"ADVECUVW_RK beg:PRVCT")
+ CALL MPPDB_CHECK(PRWCT,"ADVECUVW_RK beg:PRWCT")
+ CALL MPPDB_CHECK(PRUS_OTHER,"ADVECUVW_RK beg:PRUS_OTHER")
+ CALL MPPDB_CHECK(PRVS_OTHER,"ADVECUVW_RK beg:PRVS_OTHER")
+ CALL MPPDB_CHECK(PRWS_OTHER,"ADVECUVW_RK beg:PRWS_OTHER")
+END IF
+!
+!* 0. INITIALIZATION
+! --------------
+!
+#ifndef MNH_OPENACC
+allocate(ZUT(SIZE(PUT,1),SIZE(PUT,2),SIZE(PUT,3)))
+allocate(ZVT(SIZE(PUT,1),SIZE(PUT,2),SIZE(PUT,3)))
+allocate(ZWT(SIZE(PUT,1),SIZE(PUT,2),SIZE(PUT,3)))
+#endif
+
+#ifdef MNH_OPENACC
+CALL INIT_ON_HOST_AND_DEVICE(ZUT,4e99,'ADVECUVW_RK::ZUT')
+CALL INIT_ON_HOST_AND_DEVICE(ZVT,5e99,'ADVECUVW_RK::ZVT')
+CALL INIT_ON_HOST_AND_DEVICE(ZWT,6e99,'ADVECUVW_RK::ZWT')
+!
+CALL MNH_GET_ZT3D(IZMEAN,IZWORK)
+#endif
+!
+IKE = SIZE(PWT,3) - JPVEXT
+IIU=SIZE(PUT,1)
+IJU=SIZE(PUT,2)
+IKU=SIZE(PUT,3)
+!
+SELECT CASE (HTEMP_SCHEME)
+ CASE('RK11')
+ ISPL = 1
+ CASE('RK21')
+ ISPL = 2
+ CASE('NP32')
+ ISPL = 3
+ CASE('SP32')
+ ISPL = 3
+ CASE('RK33')
+ ISPL = 3
+ CASE('RKC4')
+ ISPL = 4
+ CASE('RK4B')
+ ISPL = 4
+ CASE('RK53')
+ ISPL = 5
+ CASE('RK62')
+ ISPL = 6
+ CASE('RK65')
+ ISPL = 6
+ CASE DEFAULT
+ call Print_msg(NVERB_FATAL,'GEN','ADVECUVW_RK','unknown HTEMP_SCHEME')
+END SELECT
+!
+!
+ALLOCATE(ZBUT(ISPL-1,ISPL-1))
+ALLOCATE(ZBUTS(ISPL))
+
+!$acc data create(ZBUT,ZBUTS)
+
+SELECT CASE (HTEMP_SCHEME)
+ CASE('RK11')
+ ZBUTS = (/ 1. /)
+ CASE('RK21')
+ ZBUTS = (/ 0. , 1. /)
+ ZBUT(1,1) = 3./4.
+ CASE('RK33')
+ ZBUTS = (/ 1./6. , 1./6. , 2./3. /)
+ ZBUT(1,1) = 1.
+ ZBUT(1,2) = 0.
+ ZBUT(2,1) = 1./4.
+ ZBUT(2,2) = 1./4.
+ CASE('NP32')
+ ZBUTS = (/ 1./2. , 0., 1./2. /)
+ ZBUT(1,1) = 1./3.
+ ZBUT(1,2) = 0.
+ ZBUT(2,1) = 0.
+ ZBUT(2,2) = 1.
+ CASE('SP32')
+ ZBUTS = (/ 1./3. , 1./3. , 1./3. /)
+ ZBUT(1,1) = 1./2.
+ ZBUT(1,2) = 0.
+ ZBUT(2,1) = 1./2.
+ ZBUT(2,2) = 1./2.
+ CASE('RKC4')
+ ZBUTS = (/ 1./6. , 1./3. , 1./3. , 1./6./)
+ ZBUT = 0.
+ ZBUT(1,1) = 1./2.
+ ZBUT(2,2) = 1./2.
+ ZBUT(3,3) = 1.
+ CASE('RK4B')
+ ZBUTS = (/ 1./8. , 3./8. , 3./8. , 1./8./)
+ ZBUT = 0.
+ ZBUT(1,1) = 1./3.
+ ZBUT(2,1) = -1./3.
+ ZBUT(2,2) = 1.
+ ZBUT(3,1) = 1.
+ ZBUT(3,2) = -1.
+ ZBUT(3,3) = 1.
+ CASE('RK53')
+ ZBUTS = (/ 1./4. , 0. , 0. , 0. , 3./4. /)
+ ZBUT = 0.
+ ZBUT(1,1) = 1./7.
+ ZBUT(2,2) = 3./16.
+ ZBUT(3,3) = 1./3.
+ ZBUT(4,4) = 2./3.
+ CASE('RK62')
+ ZBUTS = (/ 1./6. , 1./6. , 1./6. , 1./6. , 1./6. , 1./6. /)
+ ZBUT = 0.
+ ZBUT(1,1) = 1./5.
+ ZBUT(2,1) = 1./5.
+ ZBUT(2,2) = 1./5.
+ ZBUT(3,1) = 1./5.
+ ZBUT(3,2) = 1./5.
+ ZBUT(3,3) = 1./5.
+ ZBUT(4,1) = 1./5.
+ ZBUT(4,2) = 1./5.
+ ZBUT(4,3) = 1./5.
+ ZBUT(4,4) = 1./5.
+ ZBUT(5,1) = 1./5.
+ ZBUT(5,2) = 1./5.
+ ZBUT(5,3) = 1./5.
+ ZBUT(5,4) = 1./5.
+ ZBUT(5,5) = 1./5.
+CASE('RK65')
+ ZBUTS= (/ 7./90. , 0. , 16./45. , 2./15. , 16./45. , 7./90. /)
+ ZBUT= 0.
+ ZBUT(1,1) = 1./4.
+ ZBUT(2,1) = 1./8.
+ ZBUT(2,2) = 1./8.
+ ZBUT(3,1) = 0
+ ZBUT(3,2) = -1./2.
+ ZBUT(3,3) = 1
+ ZBUT(4,1) = 3./16.
+ ZBUT(4,2) = 0
+ ZBUT(4,3) = 0
+ ZBUT(4,4) = 9./16.
+ ZBUT(5,1) = -3./7.
+ ZBUT(5,2) = 2./7.
+ ZBUT(5,3) = 12./7.
+ ZBUT(5,4) = -12./7.
+ ZBUT(5,5) = 8./7.
+END SELECT
+!$acc update device(ZBUTS,ZBUT)
+!
+#ifndef MNH_OPENACC
+ALLOCATE(ZRUS(SIZE(PUT,1),SIZE(PUT,2),SIZE(PWT,3),ISPL))
+ALLOCATE(ZRVS(SIZE(PUT,1),SIZE(PUT,2),SIZE(PWT,3),ISPL))
+ALLOCATE(ZRWS(SIZE(PUT,1),SIZE(PUT,2),SIZE(PWT,3),ISPL))
+#endif
+!
+!$acc kernels present(PRUS_ADV,PRVS_ADV,PRWS_ADV) present(ZUT,ZVT,ZWT) present(PU,PV,PW)
+PRUS_ADV = 0.
+PRVS_ADV = 0.
+PRWS_ADV = 0.
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. Wind guess before RK loop
+! -------------------------
+!
+ZUT = PU
+ZVT = PV
+ZWT = PW
+!$acc end kernels
+!
+#ifndef MNH_OPENACC
+CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZUT, PUT, 'U' )
+CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZVT, PVT, 'V' )
+CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZWT, PWT, 'W' )
+#else
+CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZUT, PUT, 'U' )
+CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZVT, PVT, 'V' )
+CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZWT, PWT, 'W' )
+#endif
+!
+NULLIFY(TZFIELDMT_ll)
+CALL ADD3DFIELD_ll( TZFIELDMT_ll, ZUT, 'ADVECUVW_RK::ZUT' )
+CALL ADD3DFIELD_ll( TZFIELDMT_ll, ZVT, 'ADVECUVW_RK::ZVT' )
+CALL ADD3DFIELD_ll( TZFIELDMT_ll, ZWT, 'ADVECUVW_RK::ZWT' )
+INBVAR = 3
+CALL INIT_HALO2_ll(TZHALO2MT_ll,INBVAR,SIZE(PUT,1),SIZE(PUT,2),SIZE(PWT,3))
+!
+!$acc kernels
+ZRUS(:, :, :, : ) = 0.
+ZRVS(:, :, :, : ) = 0.
+ZRWS(:, :, :, : ) = 0.
+!$acc end kernels
+
+!Necessary to work around a PGI bug (19.10)
+!because following update ZRUS(:,:,:,JS) are done on the WHOLE array
+!$acc update self(ZRUS,ZRVS,ZRWS)
+
+!-------------------------------------------------------------------------------
+!
+!* 3. BEGINNING of Runge-Kutta loop
+! -----------------------------
+!
+ DO JS = 1, ISPL
+!
+#ifndef MNH_OPENACC
+ CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZUT, PUT, 'U' )
+ CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZVT, PVT, 'V' )
+ CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZWT, PWT, 'W' )
+#else
+ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZUT, PUT, 'U' )
+ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZVT, PVT, 'V' )
+ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZWT, PWT, 'W' )
+#endif
+ !
+#ifndef MNH_OPENACC
+ CALL UPDATE_HALO_ll(TZFIELDMT_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TZFIELDMT_ll, TZHALO2MT_ll, IINFO_ll)
+#else
+! acc update self(ZUT,ZVT,ZWT)
+!!$ CALL GET_HALO_D(ZUT,HNAME='ZUT')
+!!$ CALL GET_HALO_D(ZVT,HNAME='ZVT')
+!!$ CALL GET_HALO_D(ZWT,HNAME='ZWT')
+!!$ CALL UPDATE_HALO2_ll(TZFIELDMT_ll, TZHALO2MT_ll, IINFO_ll)
+IF (GFIRST_CALL_ADVECUVW_RK) THEN
+ GFIRST_CALL_ADVECUVW_RK = .FALSE.
+ NULLIFY(TZHALO2_UT,TZHALO2_VT,TZHALO2_WT)
+ CALL INIT_HALO2_ll(TZHALO2_UT,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_VT,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_WT,1,IIU,IJU,IKU)
+END IF
+ CALL GET_HALO2_DF(ZUT,TZHALO2_UT,HNAME='ZUT')
+ CALL GET_HALO2_DF(ZVT,TZHALO2_VT,HNAME='ZVT')
+ CALL GET_HALO2_DF(ZWT,TZHALO2_WT,HNAME='ZWT')
+! acc update device(ZUT,ZVT,ZWT)
+#endif
+
+
+
+!
+!* 4. Advection with WENO
+! -------------------
+!
+!!$TZHALO2_UT => TZHALO2MT_ll ! 1rst add3dfield in model_n
+!!$TZHALO2_VT => TZHALO2MT_ll%NEXT ! 2nd add3dfield in model_n
+!!$TZHALO2_WT => TZHALO2MT_ll%NEXT%NEXT ! 3rst add3dfield in model_n
+
+ IF (HUVW_ADV_SCHEME=='WENO_K') THEN
+ CALL ADVECUVW_WENO_K (HLBCX, HLBCY, KWENO_ORDER, ZUT, ZVT, ZWT, &
+ PRUCT, PRVCT, PRWCT, &
+ ZRUS(:,:,:,JS), ZRVS(:,:,:,JS), ZRWS(:,:,:,JS), &
+ TZHALO2_UT,TZHALO2_VT,TZHALO2_WT &
+#ifndef MNH_OPENACC
+ )
+#else
+ , ZT3D(:,:,:,IZMEAN), ZT3D(:,:,:,IZWORK) )
+#endif
+ ELSE IF ((HUVW_ADV_SCHEME=='CEN4TH') .AND. (HTEMP_SCHEME=='RKC4')) THEN
+ CALL ADVECUVW_4TH (HLBCX, HLBCY, PRUCT, PRVCT, PRWCT, &
+ ZUT, ZVT, ZWT, &
+ ZRUS(:,:,:,JS), ZRVS(:,:,:,JS), ZRWS(:,:,:,JS), &
+ TZHALO2MT_ll )
+ ENDIF
+!
+
+!
+ write ( ynum, '( I3 )' ) js
+#ifndef MNH_OPENACC
+ NULLIFY(TZFIELDS4_ll)
+ CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRUS(:,:,:,JS), 'ADVECUVW_RK::ZRUS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRVS(:,:,:,JS), 'ADVECUVW_RK::ZRVS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRWS(:,:,:,JS), 'ADVECUVW_RK::ZRWS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL UPDATE_HALO_ll(TZFIELDS4_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELDS4_ll)
+#else
+ CALL GET_HALO_D(ZRUS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRUS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL GET_HALO_D(ZRVS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRVS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL GET_HALO_D(ZRWS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRWS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+! acc update device(ZRUS(:,:,:,JS),ZRVS(:,:,:,JS),ZRWS(:,:,:,JS))
+#endif
+!
+!
+! Guesses at the end of the RK loop
+!
+!$acc kernels present(PRUS_ADV,PRVS_ADV,PRWS_ADV,ZBUTS) present(ZRUS,ZRVS,ZRWS)
+ PRUS_ADV(:,:,:) = PRUS_ADV(:,:,:) + ZBUTS(JS) * ZRUS(:,:,:,JS)
+ PRVS_ADV(:,:,:) = PRVS_ADV(:,:,:) + ZBUTS(JS) * ZRVS(:,:,:,JS)
+ PRWS_ADV(:,:,:) = PRWS_ADV(:,:,:) + ZBUTS(JS) * ZRWS(:,:,:,JS)
+!$acc end kernels
+!
+ IF ( JS < ISPL ) THEN
+!$acc kernels present(ZUT,ZVT,ZWT) present(ZBUT) present(PU,PV,PW) &
+!$acc & present(ZRUS,ZRVS,ZRWS) present(PRUS_OTHER,PRVS_OTHER,PRWS_OTHER) &
+!$acc & present(PMXM_RHODJ,PMYM_RHODJ,PMZM_RHODJ)
+!
+ ZUT = PU
+ ZVT = PV
+ ZWT = PW
+!
+ DO JI = 1, JS
+!
+! Intermediate guesses inside the RK loop
+!
+ ZUT(:,:,:) = ZUT(:,:,:) + ZBUT(JS,JI) * PTSTEP * &
+ ( ZRUS(:,:,:,JI) + PRUS_OTHER(:,:,:) ) / PMXM_RHODJ
+ ZVT(:,:,:) = ZVT(:,:,:) + ZBUT(JS,JI) * PTSTEP * &
+ ( ZRVS(:,:,:,JI) + PRVS_OTHER(:,:,:) ) / PMYM_RHODJ
+ ZWT(:,:,:) = ZWT(:,:,:) + ZBUT(JS,JI) * PTSTEP * &
+ ( ZRWS(:,:,:,JI) + PRWS_OTHER(:,:,:) ) / PMZM_RHODJ
+!
+ END DO
+!$acc end kernels
+!$acc update self(ZUT,ZVT,ZWT)
+ END IF
+!
+! End of the RK loop
+ END DO
+!
+!
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT3D(IZMEAN,IZWORK)
+#endif
+!
+CALL CLEANLIST_ll(TZFIELDMT_ll)
+CALL DEL_HALO2_ll(TZHALO2MT_ll)
+!!$CALL DEL_HALO2_ll(TZHALO2_UT)
+!!$CALL DEL_HALO2_ll(TZHALO2_VT)
+!!$CALL DEL_HALO2_ll(TZHALO2_WT)
+!$acc update self(PRUS_ADV,PRVS_ADV,PRWS_ADV)
+!-------------------------------------------------------------------------------
+!
+IF (MPPDB_INITIALIZED) THEN
+ !Check all OUT arrays
+ CALL MPPDB_CHECK(PRUS_ADV,"ADVECUVW_RK end:PRUS_ADV")
+ CALL MPPDB_CHECK(PRVS_ADV,"ADVECUVW_RK end:PRVS_ADV")
+ CALL MPPDB_CHECK(PRWS_ADV,"ADVECUVW_RK end:PRWS_ADV")
+END IF
+
+!$acc end data
+
+!$acc end data
+
+END SUBROUTINE ADVECUVW_RK
diff --git a/src/ZSOLVER/advecuvw_weno_k.f90 b/src/ZSOLVER/advecuvw_weno_k.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f41009ae4ef63792834dff1b2f025e0808f1a2e2
--- /dev/null
+++ b/src/ZSOLVER/advecuvw_weno_k.f90
@@ -0,0 +1,662 @@
+!MNH_LIC Copyright 2013-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.
+!-----------------------------------------------------------------
+! ###########################
+ MODULE MODI_ADVECUVW_WENO_K
+! ###########################
+!
+INTERFACE
+!
+ SUBROUTINE ADVECUVW_WENO_K(HLBCX, HLBCY, KWENO_ORDER, PUT, PVT, PWT, &
+ PRUCT, PRVCT, PRWCT, PRUS, PRVS, PRWS, &
+ TPHALO2_UT,TPHALO2_VT,TPHALO2_WT &
+#ifndef MNH_OPENACC
+ )
+#else
+ , ZMEAN, ZWORK)
+#endif
+!
+USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO
+ ! scheme (3 or 5)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT ! contravariant
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVCT ! components
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWCT ! of momentum
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT, PWT ! U,V,W at t
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS ! Source terms
+!
+TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT
+!
+#ifdef MNH_OPENACC
+! Work arrays
+REAL, DIMENSION(:,:,:) :: ZMEAN, ZWORK
+#endif
+!
+END SUBROUTINE ADVECUVW_WENO_K
+!
+END INTERFACE
+!
+END MODULE MODI_ADVECUVW_WENO_K
+!
+! ##########################################################################
+ SUBROUTINE ADVECUVW_WENO_K(HLBCX, HLBCY, KWENO_ORDER, PUT, PVT, PWT, &
+ PRUCT, PRVCT, PRWCT, PRUS, PRVS, PRWS, &
+ TPHALO2_UT,TPHALO2_VT,TPHALO2_WT &
+#ifndef MNH_OPENACC
+ )
+#else
+ , ZMEAN, ZWORK)
+#endif
+! ##########################################################################
+!
+!! AUTHOR
+!! ------
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 tests
+!! T.Lunet 02/10/2014: add get_halo for WENO 5
+!! suppress comment of NHALO=1 tests
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_ll
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+!
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+USE MODI_ADVEC_WENO_K_1_AUX
+USE MODI_ADVEC_WENO_K_2_AUX
+USE MODI_ADVEC_WENO_K_3_AUX
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_MPPDB
+USE MODI_GET_HALO
+!
+#ifdef MNH_OPENACC
+USE MODE_DEVICE
+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) :: HLBCX ! X direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO
+ ! scheme (3 or 5)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT ! contravariant
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVCT ! components
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWCT ! of momentum
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT, PWT ! Variables at t
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS ! Source terms
+!
+!
+!* 0.2 Declarations of local variables :
+!
+TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT
+
+INTEGER :: IINFO_ll ! return code of parallel routine
+!
+#ifndef MNH_OPENACC
+REAL, DIMENSION(:,:,:), allocatable :: ZMEAN, ZWORK
+#else
+REAL, DIMENSION(:,:,:) :: ZMEAN, ZWORK
+#endif
+!
+INTEGER :: IKU
+#ifdef MNH_OPENACC
+INTEGER :: IZFPOS1, IZFPOS2, IZFPOS3
+INTEGER :: IZFNEG1, IZFNEG2, IZFNEG3
+INTEGER :: IZBPOS1, IZBPOS2, IZBPOS3
+INTEGER :: IZBNEG1, IZBNEG2, IZBNEG3
+INTEGER :: IZOMP1, IZOMP2, IZOMP3
+INTEGER :: IZOMN1, IZOMN2, IZOMN3
+#endif
+!
+!$acc data present( PRUCT, PRVCT, PRWCT, PUT, PVT, PWT, PRUS, PRVS, PRWS, ZMEAN, ZWORK )
+!
+IF (MPPDB_INITIALIZED) THEN
+ !Check all IN arrays
+ CALL MPPDB_CHECK(PRUCT,"ADVECUVW_WENO_K beg:PRUCT")
+ CALL MPPDB_CHECK(PRVCT,"ADVECUVW_WENO_K beg:PRVCT")
+ CALL MPPDB_CHECK(PRWCT,"ADVECUVW_WENO_K beg:PRWCT")
+ CALL MPPDB_CHECK(PUT,"ADVECUVW_WENO_K beg:PUT")
+ CALL MPPDB_CHECK(PVT,"ADVECUVW_WENO_K beg:PVT")
+ CALL MPPDB_CHECK(PWT,"ADVECUVW_WENO_K beg:PWT")
+ !Check all INOUT arrays
+ CALL MPPDB_CHECK(PRUS,"ADVECUVW_WENO_K beg:PRUS")
+ CALL MPPDB_CHECK(PRVS,"ADVECUVW_WENO_K beg:PRVS")
+ CALL MPPDB_CHECK(PRWS,"ADVECUVW_WENO_K beg:PRWS")
+END IF
+
+#ifndef MNH_OPENACC
+allocate(ZMEAN(SIZE(PUT,1), SIZE(PUT,2), SIZE(PUT,3)))
+allocate(ZWORK(SIZE(PUT,1), SIZE(PUT,2), SIZE(PUT,3)))
+#endif
+
+#ifdef MNH_OPENACC
+CALL INIT_ON_HOST_AND_DEVICE(ZMEAN,1e90,'ADVECUVW_WENO_K::ZMEAN')
+CALL INIT_ON_HOST_AND_DEVICE(ZWORK,2e90,'ADVECUVW_WENO_K::ZWORK')
+#endif
+!
+!------------------------- ADVECTION OF MOMENTUM ------------------------------
+!
+!
+!!$TPHALO2_UT => TPHALO2LIST ! 1rst add3dfield in model_n
+!!$TPHALO2_VT => TPHALO2LIST%NEXT ! 2nd add3dfield in model_n
+!!$TPHALO2_WT => TPHALO2LIST%NEXT%NEXT ! 3rst add3dfield in model_n
+!
+IKU=SIZE(PUT,3)
+! -------------------------------------------------------
+!
+SELECT CASE(KWENO_ORDER)
+!
+CASE(1) ! WENO 1
+#ifndef MNH_OPENACC
+!
+! U component
+!
+ PRUS = PRUS - DXM(UP_UX(PUT,MXF(PRUCT)))
+!
+ PRUS = PRUS - DYF(UP_MY(PUT,MXM(PRVCT)))
+!
+ PRUS = PRUS - DZF(UP_MZ(PUT,MXM(PRWCT)))
+!
+! V component
+!
+ PRVS = PRVS - DXF(UP_MX(PVT,MYM(PRUCT)))
+!
+ PRVS = PRVS - DYM(UP_VY(PVT,MYF(PRVCT)))
+!
+ PRVS = PRVS - DZF(UP_MZ(PVT,MYM(PRWCT)))
+!
+! W component
+!
+ PRWS = PRWS - DXF(UP_MX(PWT,MZM(PRUCT)))
+!
+ PRWS = PRWS - DYF(UP_MY(PWT,MZM(PRVCT)))
+!
+ PRWS = PRWS - DZM(UP_WZ(PWT,MZF(PRWCT)))
+#else
+!
+! U component
+!
+ !PRUS = PRUS - DXM(UP_UX(PUT,MXF(PRUCT)))
+ CALL MXF_DEVICE(PRUCT,ZWORK)
+ CALL UP_UX_DEVICE(PUT,ZWORK,ZMEAN)
+ CALL DXM_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+ !PRUS = PRUS - DYF(UP_MY(PUT,MXM(PRVCT)))
+ CALL MXM_DEVICE(PRVCT,ZWORK)
+ CALL UP_MY_DEVICE(PUT,ZWORK,ZMEAN)
+ CALL DYF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+ !PRUS = PRUS - DZF(1,IKU,1,UP_MZ(PUT,MXM(PRWCT)))
+ CALL MXM_DEVICE(PRWCT,ZWORK)
+ CALL UP_MZ_DEVICE(PUT,ZWORK,ZMEAN)
+ CALL DZF_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+! V component
+!
+ !PRVS = PRVS - DXF(UP_MX(PVT,MYM(PRUCT)))
+ CALL MYM_DEVICE(PRUCT,ZWORK)
+ CALL UP_MX_DEVICE(PVT,ZWORK,ZMEAN)
+ CALL DXF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+ !PRVS = PRVS - DYM(UP_VY(PVT,MYF(PRVCT)))
+ CALL MYF_DEVICE(PRVCT,ZWORK)
+ CALL UP_VY_DEVICE(PVT,ZWORK,ZMEAN)
+ CALL DYM_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+ !PRVS = PRVS - DZF(1,IKU,1,UP_MZ(PVT,MYM(PRWCT)))
+ CALL MYM_DEVICE(PRWCT,ZWORK)
+ CALL UP_MZ_DEVICE(PVT,ZWORK,ZMEAN)
+ CALL DZF_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+! W component
+!
+ !PRWS = PRWS - DXF(UP_MX(PWT,MZM(1,IKU,1,PRUCT)))
+ CALL MZM_DEVICE(PRUCT,ZWORK)
+ CALL UP_MX_DEVICE(PWT,ZWORK,ZMEAN)
+ CALL DXF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+!
+ !PRWS = PRWS - DYF(UP_MY(PWT,MZM(1,IKU,1,PRVCT)))
+ CALL MZM_DEVICE(PRVCT,ZWORK)
+ CALL UP_MY_DEVICE(PWT,ZWORK,ZMEAN)
+ CALL DYF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+!
+ !PRWS = PRWS - DZM(1,IKU,1,UP_WZ(PWT,MZF(1,IKU,1,PRWCT)))
+ CALL MZF_DEVICE(1,IKU,1,PRWCT,ZWORK)
+ CALL UP_WZ_DEVICE(PWT,ZWORK,ZMEAN)
+ CALL DZM_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+#endif
+!
+!
+CASE(3) ! WENO 3
+#ifndef MNH_OPENACC
+!
+! U component
+!
+ ZWORK = MXF(PRUCT)
+ CALL ADVEC_WENO_K_2_UX(HLBCX, PUT, ZWORK, ZMEAN, TPHALO2_UT%HALO2)
+ PRUS = PRUS - DXM(ZMEAN)
+
+!
+ IF (.NOT.L2D) THEN
+ ZWORK = MXM(PRVCT)
+ CALL ADVEC_WENO_K_2_MY(HLBCY, PUT, ZWORK, ZMEAN, TPHALO2_UT%HALO2)
+ PRUS = PRUS - DYF(ZMEAN)
+ END IF
+!
+ PRUS = PRUS - DZF(WENO_K_2_MZ(PUT, MXM(PRWCT)))
+!
+! V component
+!
+ IF (.NOT.L2D) THEN
+ ZWORK = MYM(PRUCT)
+ CALL ADVEC_WENO_K_2_MX(HLBCX, PVT, ZWORK, ZMEAN, TPHALO2_VT%HALO2)
+ PRVS = PRVS - DXF(ZMEAN)
+!
+ ZWORK = MYF(PRVCT)
+ CALL ADVEC_WENO_K_2_VY(HLBCY, PVT, ZWORK, ZMEAN, TPHALO2_VT%HALO2)
+ PRVS = PRVS - DYM(ZMEAN)
+!
+ PRVS = PRVS - DZF(WENO_K_2_MZ(PVT, MYM(PRWCT)))
+ END IF
+!
+! W component
+!
+ ZWORK = MZM(PRUCT)
+ CALL ADVEC_WENO_K_2_MX(HLBCX, PWT, ZWORK, ZMEAN, TPHALO2_WT%HALO2)
+ PRWS = PRWS - DXF(ZMEAN)
+!
+ IF (.NOT.L2D) THEN
+ ZWORK = MZM(PRVCT)
+ CALL ADVEC_WENO_K_2_MY(HLBCY, PWT, ZWORK, ZMEAN, TPHALO2_WT%HALO2)
+ PRWS = PRWS - DYF(ZMEAN)
+ END IF
+!
+ PRWS = PRWS - DZM(WENO_K_2_WZ(PWT,MZF(PRWCT)))
+#else
+ CALL MNH_GET_ZT3D(IZFPOS1,IZFPOS2,IZFNEG1,IZFNEG2,IZBPOS1,IZBPOS2,IZBNEG1,IZBNEG2,IZOMP1,IZOMP2,IZOMN1,IZOMN2)
+!
+! U component
+!
+ CALL MXF_DEVICE(PRUCT,ZWORK)
+ CALL ADVEC_WENO_K_2_UX(HLBCX, PUT, ZWORK, ZMEAN, TPHALO2_UT%HALO2%WEST, TPHALO2_UT%HALO2%EAST, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DXM_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+ IF (.NOT.L2D) THEN
+ CALL MXM_DEVICE(PRVCT,ZWORK)
+ CALL ADVEC_WENO_K_2_MY(HLBCY, PUT, ZWORK, ZMEAN, TPHALO2_UT%HALO2%NORTH, TPHALO2_UT%HALO2%SOUTH, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DYF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+ END IF
+!
+! PRUS = PRUS - DZF(1,IKU,1,WENO_K_2_MZ(PUT, MXM(PRWCT)))
+ CALL MXM_DEVICE(PRWCT,ZWORK)
+ CALL WENO_K_2_MZ(PUT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DZF_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+! V component
+!
+ IF (.NOT.L2D) THEN
+ CALL MYM_DEVICE(PRUCT,ZWORK)
+ CALL ADVEC_WENO_K_2_MX(HLBCX, PVT, ZWORK, ZMEAN, TPHALO2_VT%HALO2%WEST, TPHALO2_VT%HALO2%EAST, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DXF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+ CALL MYF_DEVICE(PRVCT,ZWORK)
+ CALL ADVEC_WENO_K_2_VY(HLBCY, PVT, ZWORK, ZMEAN, TPHALO2_VT%HALO2%NORTH, TPHALO2_VT%HALO2%SOUTH, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DYM_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+! PRVS = PRVS - DZF(1,IKU,1,WENO_K_2_MZ(PVT, MYM(PRWCT)))
+ CALL MYM_DEVICE(PRWCT,ZWORK)
+ CALL WENO_K_2_MZ(PVT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DZF_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+ END IF
+!
+! W component
+!
+! ZWORK = MZM(1,IKU,1,PRUCT)
+ CALL MZM_DEVICE(PRUCT,ZWORK)
+ CALL ADVEC_WENO_K_2_MX(HLBCX, PWT, ZWORK, ZMEAN, TPHALO2_WT%HALO2%WEST, TPHALO2_WT%HALO2%EAST, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DXF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+!
+ IF (.NOT.L2D) THEN
+! ZWORK = MZM(1,IKU,1,PRVCT)
+ CALL MZM_DEVICE(PRVCT,ZWORK)
+ CALL ADVEC_WENO_K_2_MY(HLBCY, PWT, ZWORK, ZMEAN, TPHALO2_WT%HALO2%NORTH, TPHALO2_WT%HALO2%SOUTH, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DYF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+ END IF
+!
+! PRWS = PRWS - DZM(1,IKU,1,WENO_K_2_WZ(PWT,MZF(1,IKU,1,PRWCT)))
+ CALL MZF_DEVICE(1,IKU,1,PRWCT,ZWORK)
+ CALL WENO_K_2_WZ(PWT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2) )
+ CALL DZM_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+!
+ CALL MNH_REL_ZT3D(IZFPOS1,IZFPOS2,IZFNEG1,IZFNEG2,IZBPOS1,IZBPOS2,IZBNEG1,IZBNEG2,IZOMP1,IZOMP2,IZOMN1,IZOMN2)
+#endif
+!
+!
+CASE(5) ! WENO 5
+#ifndef MNH_OPENACC
+!
+! U component
+!
+ ZWORK = MXF(PRUCT)
+ CALL ADVEC_WENO_K_3_UX(HLBCX, PUT, ZWORK, ZMEAN)
+ CALL GET_HALO(ZMEAN)! Update HALO
+ PRUS = PRUS - DXM(ZMEAN)
+!
+ IF (.NOT.L2D) THEN! 3D Case
+ ZWORK = MXM(PRVCT)
+ CALL ADVEC_WENO_K_3_MY(HLBCY, PUT, ZWORK, ZMEAN)
+ CALL GET_HALO(ZMEAN)! Update HALO
+ PRUS = PRUS - DYF(ZMEAN)
+ END IF
+!
+ ZMEAN = WENO_K_3_MZ(PUT, MXM(PRWCT))
+ CALL GET_HALO(ZMEAN)! Update HALO - maybe not necessary (T.Lunet)
+ PRUS = PRUS - DZF(ZMEAN)
+!
+! V component, only called in 3D case
+!
+ IF (.NOT.L2D) THEN
+!
+ ZWORK = MYM(PRUCT)
+ CALL ADVEC_WENO_K_3_MX(HLBCX, PVT, ZWORK, ZMEAN)
+ CALL GET_HALO(ZMEAN)! Update HALO
+ PRVS = PRVS - DXF(ZMEAN)
+!
+ ZWORK = MYF(PRVCT)
+ CALL ADVEC_WENO_K_3_VY(HLBCY, PVT, ZWORK, ZMEAN)
+ CALL GET_HALO(ZMEAN)! Update HALO
+ PRVS = PRVS - DYM(ZMEAN)
+!
+ ZMEAN = WENO_K_3_MZ(PVT, MYM(PRWCT))
+ CALL GET_HALO(ZMEAN)! Update HALO - maybe not necessary (T.Lunet)
+ PRVS = PRVS - DZF(ZMEAN)
+!
+ END IF
+!
+! W component
+!
+ ZWORK = MZM(PRUCT)
+ CALL ADVEC_WENO_K_3_MX(HLBCX, PWT, ZWORK, ZMEAN)
+ CALL GET_HALO(ZMEAN)! Update HALO
+ PRWS = PRWS - DXF(ZMEAN)
+!
+ IF (.NOT.L2D) THEN! 3D Case
+ ZWORK = MZM(PRVCT)
+ CALL ADVEC_WENO_K_3_MY(HLBCY, PWT, ZWORK, ZMEAN)
+ CALL GET_HALO(ZMEAN)! Update HALO
+ PRWS = PRWS - DYF(ZMEAN)
+ END IF
+!
+ ZMEAN = WENO_K_3_WZ(PWT,MZF(PRWCT))
+ CALL GET_HALO(ZMEAN)! Update HALO - maybe not necessary (T.Lunet)
+ PRWS = PRWS - DZM(ZMEAN)
+#else
+ CALL MNH_GET_ZT3D(IZFPOS1,IZFPOS2,IZFPOS3,IZFNEG1,IZFNEG2,IZFNEG3,IZBPOS1, &
+ IZBPOS2,IZBPOS3,IZBNEG1,IZBNEG2,IZBNEG3,IZOMP1,IZOMP2,IZOMP3,IZOMN1,IZOMN2,IZOMN3)
+!
+! U component
+!
+ CALL MXF_DEVICE(PRUCT,ZWORK)
+ CALL ADVEC_WENO_K_3_UX(HLBCX, PUT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO
+ CALL DXM_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+ IF (.NOT.L2D) THEN
+ CALL MXM_DEVICE(PRVCT,ZWORK)
+ CALL ADVEC_WENO_K_3_MY(HLBCY, PUT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO
+ CALL DYF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+ END IF
+!
+ CALL MXM_DEVICE(PRWCT,ZWORK)
+ CALL WENO_K_3_MZ(PUT,ZWORK,ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO - maybe not necessary (T.Lunet)
+ CALL DZF_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRUS = PRUS - ZWORK
+!$acc end kernels
+!
+! V component
+!
+ IF (.NOT.L2D) THEN
+ CALL MYM_DEVICE(PRUCT,ZWORK)
+ CALL ADVEC_WENO_K_3_MX(HLBCX, PVT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO
+ CALL DXF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+ CALL MYF_DEVICE(PRVCT,ZWORK)
+ CALL ADVEC_WENO_K_3_VY(HLBCY, PVT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO
+ CALL DYM_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+!
+ CALL MYM_DEVICE(PRWCT,ZWORK)
+ CALL WENO_K_3_MZ(PVT,ZWORK,ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO - maybe not necessary (T.Lunet)
+ CALL DZF_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRVS = PRVS - ZWORK
+!$acc end kernels
+ END IF
+!
+! W component
+!
+ CALL MZM_DEVICE(PRUCT,ZWORK)
+ CALL ADVEC_WENO_K_3_MX(HLBCX, PWT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO
+ CALL DXF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+!
+ IF (.NOT.L2D) THEN
+ CALL MZM_DEVICE(PRVCT,ZWORK)
+ CALL ADVEC_WENO_K_3_MY(HLBCY, PWT, ZWORK, ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO
+ CALL DYF_DEVICE(ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+ END IF
+!
+ CALL MZF_DEVICE(1,IKU,1,PRWCT,ZWORK)
+ CALL WENO_K_3_WZ(PWT,ZWORK,ZMEAN, &
+ ZT3D(:,:,:,IZFPOS1), ZT3D(:,:,:,IZFPOS2), ZT3D(:,:,:,IZFPOS3), &
+ ZT3D(:,:,:,IZFNEG1), ZT3D(:,:,:,IZFNEG2), ZT3D(:,:,:,IZFNEG3), &
+ ZT3D(:,:,:,IZBPOS1), ZT3D(:,:,:,IZBPOS2), ZT3D(:,:,:,IZBPOS3), &
+ ZT3D(:,:,:,IZBNEG1), ZT3D(:,:,:,IZBNEG2), ZT3D(:,:,:,IZBNEG3), &
+ ZT3D(:,:,:,IZOMP1), ZT3D(:,:,:,IZOMP2), ZT3D(:,:,:,IZOMP3), &
+ ZT3D(:,:,:,IZOMN1), ZT3D(:,:,:,IZOMN2), ZT3D(:,:,:,IZOMN3) )
+ CALL GET_HALO_D(ZMEAN)! Update HALO - maybe not necessary (T.Lunet)
+ CALL DZM_DEVICE(1,IKU,1,ZMEAN,ZWORK)
+!$acc kernels
+ PRWS = PRWS - ZWORK
+!$acc end kernels
+!
+ CALL MNH_REL_ZT3D(IZFPOS1,IZFPOS2,IZFPOS3,IZFNEG1,IZFNEG2,IZFNEG3,IZBPOS1, &
+ IZBPOS2,IZBPOS3,IZBNEG1,IZBNEG2,IZBNEG3,IZOMP1,IZOMP2,IZOMP3,IZOMN1,IZOMN2,IZOMN3)
+#endif
+!
+!
+END SELECT
+! ---------------------------------
+!$acc update self(PRUS,PRVS,PRWS)
+!
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(PRUS,"ADVECUVW_WENO_K end:PRUS")
+ CALL MPPDB_CHECK(PRVS,"ADVECUVW_WENO_K end:PRVS")
+ CALL MPPDB_CHECK(PRWS,"ADVECUVW_WENO_K end:PRWS")
+END IF
+
+!$acc end data
+
+END SUBROUTINE ADVECUVW_WENO_K
diff --git a/src/ZSOLVER/contrav.f90 b/src/ZSOLVER/contrav.f90
index ebef79590bb7b5f6faa48cb6a8a680d0525a4f3e..97df82096f4d57928bc287dce6eaf863ea163fa5 100644
--- a/src/ZSOLVER/contrav.f90
+++ b/src/ZSOLVER/contrav.f90
@@ -567,7 +567,8 @@ LOGICAL :: GDATA_ON_DEVICE
real :: ZTMP1, ZTMP2 ! Intermediate work variables
REAL, DIMENSION(:,:), POINTER , CONTIGUOUS :: ZU_EAST, ZV_NORTH, ZDZX_EAST, ZDZY_NORTH
TYPE(LIST_ll), POINTER :: TZFIELD_U, TZFIELD_V, TZFIELD_DZX, TZFIELD_DZY
-TYPE(HALO2LIST_ll), POINTER :: TZHALO2_U, TZHALO2_V, TZHALO2_DZX, TZHALO2_DZY
+TYPE(HALO2LIST_ll), SAVE, POINTER :: TZHALO2_U, TZHALO2_V, TZHALO2_DZX, TZHALO2_DZY
+LOGICAL , SAVE :: GFIRST_CALL_CONTRAV_DEVICE = .TRUE.
!
LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
!
@@ -634,23 +635,26 @@ IF (KADV_ORDER == 4 ) THEN
!!$ NULLIFY(TZFIELD_DZY)
!!$ CALL ADD3DFIELD_ll( TZFIELD_DZX, PDZX, 'CONTRAV::PDZX' )
!!$ CALL ADD3DFIELD_ll( TZFIELD_DZY, PDZY, 'CONTRAV::PDZY' )
-!!$ NULLIFY(TZHALO2_U)
-!!$ NULLIFY(TZHALO2_V)
-!!$ NULLIFY(TZHALO2_DZX)
-!!$ NULLIFY(TZHALO2_DZY)
-!!$ CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU)
-!!$ CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU)
-!!$ CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU)
-!!$ CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU)
+ IF ( GFIRST_CALL_CONTRAV_DEVICE ) THEN
+ GFIRST_CALL_CONTRAV_DEVICE = .FALSE.
+ NULLIFY(TZHALO2_U)
+ NULLIFY(TZHALO2_V)
+ NULLIFY(TZHALO2_DZX)
+ NULLIFY(TZHALO2_DZY)
+ CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU)
+ END IF
!!$ CALL UPDATE_HALO2_ll(TZFIELD_U, TZHALO2_U, IINFO_ll)
!!$ CALL UPDATE_HALO2_ll(TZFIELD_V, TZHALO2_V, IINFO_ll)
!!$ CALL UPDATE_HALO2_ll(TZFIELD_DZX, TZHALO2_DZX, IINFO_ll)
!!$ CALL UPDATE_HALO2_ll(TZFIELD_DZY, TZHALO2_DZY, IINFO_ll)
!
- CALL GET_HALO2_D(PRUCT,TZHALO2_U,'CONTRAV::PRUCT')
- CALL GET_HALO2_D(PRVCT,TZHALO2_V,'CONTRAV::PRVCT')
- CALL GET_HALO2_D(PDZX,TZHALO2_DZX,'CONTRAV::PDZX')
- CALL GET_HALO2_D(PDZY,TZHALO2_DZY,'CONTRAV::PDZY')
+ CALL GET_HALO2_DF(PRUCT,TZHALO2_U,'CONTRAV::PRUCT')
+ CALL GET_HALO2_DF(PRVCT,TZHALO2_V,'CONTRAV::PRVCT')
+ CALL GET_HALO2_DF(PDZX,TZHALO2_DZX,'CONTRAV::PDZX')
+ CALL GET_HALO2_DF(PDZY,TZHALO2_DZY,'CONTRAV::PDZY')
!!$!$acc update device(PRUCT,PRVCT)
!!$ !!$ END IF
@@ -874,10 +878,10 @@ IF (KADV_ORDER == 4 ) THEN
!!$ !!$ IF (NHALO==1) THEN
!!$ CALL CLEANLIST_ll(TZFIELD_DZX)
!!$ CALL CLEANLIST_ll(TZFIELD_DZY)
- CALL DEL_HALO2_ll(TZHALO2_U)
- CALL DEL_HALO2_ll(TZHALO2_V)
- CALL DEL_HALO2_ll(TZHALO2_DZX)
- CALL DEL_HALO2_ll(TZHALO2_DZY)
+!!$ CALL DEL_HALO2_ll(TZHALO2_U)
+!!$ CALL DEL_HALO2_ll(TZHALO2_V)
+!!$ CALL DEL_HALO2_ll(TZHALO2_DZX)
+!!$ CALL DEL_HALO2_ll(TZHALO2_DZY)
!!$ !!$ END IF
END IF
diff --git a/src/ZSOLVER/get_halo.f90 b/src/ZSOLVER/get_halo.f90
index 784b664f64a3842ce6a230d8fad1f047258b2fa3..7dec4456cba761f8600a66e3bdf78a86b3c860de 100644
--- a/src/ZSOLVER/get_halo.f90
+++ b/src/ZSOLVER/get_halo.f90
@@ -63,6 +63,19 @@ INTERFACE
!
END SUBROUTINE GET_HALO2_DD
END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO2_DF(PSRC, TP_PSRC_HALO2_ll, HNAME)
+ !
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO2_DF
+END INTERFACE
INTERFACE
SUBROUTINE GET_HALO_D(PSRC, HDIR, HNAME)
IMPLICIT NONE
@@ -104,6 +117,36 @@ INTERFACE
!
END SUBROUTINE GET_HALO_DD
END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO_DDC(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO_DDC
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_2D_HALO_DD(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:), INTENT(INOUT) :: PSRC ! variable at t
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_2D_HALO_DD
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_2D_HALO_DDC(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:), INTENT(INOUT) :: PSRC ! variable at t
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_2D_HALO_DDC
+END INTERFACE
#endif
!
INTERFACE
@@ -202,14 +245,27 @@ MODULE MODD_HALO_D
REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN
REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTHC_IN, ZSOUTHC_IN, ZWESTC_IN, ZEASTC_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTHC_OUT, ZSOUTHC_OUT, ZWESTC_OUT, ZEASTC_OUT
+
REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTH2_IN, ZSOUTH2_IN, ZWEST2_IN, ZEAST2_IN
REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT
-
+
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTH_2D_IN, ZSOUTH_2D_IN, ZWEST_2D_IN, ZEAST_2D_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTH_2D_OUT, ZSOUTH_2D_OUT, ZWEST_2D_OUT, ZEAST_2D_OUT
+
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTHC_2D_IN, ZSOUTHC_2D_IN, ZWESTC_2D_IN, ZEASTC_2D_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTHC_2D_OUT, ZSOUTHC_2D_OUT, ZWESTC_2D_OUT, ZEASTC_2D_OUT
+
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH2F_IN, ZSOUTH2F_IN, ZWEST2F_IN, ZEAST2F_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH2F_OUT, ZSOUTH2F_OUT, ZWEST2F_OUT, ZEAST2F_OUT
+
LOGICAL, SAVE :: GFIRST_GET_HALO_D = .TRUE.
LOGICAL, SAVE :: GFIRST_INIT_HALO_D = .TRUE.
INTEGER, SAVE :: IHALO_1
INTEGER, SAVE :: NP_NORTH,NP_SOUTH,NP_WEST,NP_EAST
+ INTEGER, SAVE :: IHALO2,IHALO2_1
CONTAINS
@@ -227,7 +283,9 @@ CONTAINS
IF (GFIRST_INIT_HALO_D) THEN
!
- IHALO_1 = NHALO-1
+ IHALO_1 = NHALO-1
+ IHALO2 = MAX(2,NHALO)
+ IHALO2_1 = IHALO2-1
!
! Init HALO
!
@@ -243,6 +301,20 @@ CONTAINS
ALLOCATE ( ZEAST_OUT ( IIE+1:IIU , IJB:IJE , IKU ) )
!$acc enter data create (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
!
+ ! Init HALO with Corner
+ !
+ ALLOCATE ( ZSOUTHC_IN ( 1:IIU , IJB:IJB+IHALO_1 , IKU ) )
+ ALLOCATE ( ZNORTHC_IN ( 1:IIU , IJE-IHALO_1:IJE , IKU ) )
+ ALLOCATE ( ZWESTC_IN ( IIB:IIB+IHALO_1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEASTC_IN ( IIE-IHALO_1:IIE , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTHC_IN, ZSOUTHC_IN, ZWESTC_IN, ZEASTC_IN)
+ !
+ ALLOCATE ( ZSOUTHC_OUT ( 1:IIU , 1:IJB-1 , IKU ) )
+ ALLOCATE ( ZNORTHC_OUT ( 1:IIU , IJE+1:IJU , IKU ) )
+ ALLOCATE ( ZWESTC_OUT ( 1:IIB-1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEASTC_OUT ( IIE+1:IIU , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTHC_OUT, ZSOUTHC_OUT, ZWESTC_OUT, ZEASTC_OUT)
+ !
! Init HALO2
!
ALLOCATE ( ZSOUTH2_IN ( IIU , IKU ) )
@@ -255,8 +327,50 @@ CONTAINS
ALLOCATE ( ZNORTH2_OUT ( IIU , IKU ) )
ALLOCATE ( ZWEST2_OUT ( IJU , IKU ) )
ALLOCATE ( ZEAST2_OUT ( IJU , IKU ) )
- !$acc enter data create (ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT)
-
+ !$acc enter data create (ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT)
+ !
+ ! Init HALO_2D
+ !
+ ALLOCATE ( ZSOUTH_2D_IN ( IIB:IIE , IJB:IJB+IHALO_1 ) )
+ ALLOCATE ( ZNORTH_2D_IN ( IIB:IIE , IJE-IHALO_1:IJE ) )
+ ALLOCATE ( ZWEST_2D_IN ( IIB:IIB+IHALO_1 , IJB:IJE ) )
+ ALLOCATE ( ZEAST_2D_IN ( IIE-IHALO_1:IIE , IJB:IJE ) )
+ !$acc enter data create (ZNORTH_2D_IN, ZSOUTH_2D_IN, ZWEST_2D_IN, ZEAST_2D_IN)
+ !
+ ALLOCATE ( ZSOUTH_2D_OUT ( IIB:IIE , 1:IJB-1) )
+ ALLOCATE ( ZNORTH_2D_OUT ( IIB:IIE , IJE+1:IJU) )
+ ALLOCATE ( ZWEST_2D_OUT ( 1:IIB-1 , IJB:IJE ) )
+ ALLOCATE ( ZEAST_2D_OUT ( IIE+1:IIU , IJB:IJE ) )
+ !$acc enter data create (ZNORTH_2D_OUT, ZSOUTH_2D_OUT, ZWEST_2D_OUT, ZEAST_2D_OUT)
+ !
+ ! Init HALO 2D with Corner
+ !
+ ALLOCATE ( ZSOUTHC_2D_IN ( 1:IIU , IJB:IJB+IHALO_1 ) )
+ ALLOCATE ( ZNORTHC_2D_IN ( 1:IIU , IJE-IHALO_1:IJE ) )
+ ALLOCATE ( ZWESTC_2D_IN ( IIB:IIB+IHALO_1 , IJB:IJE ) )
+ ALLOCATE ( ZEASTC_2D_IN ( IIE-IHALO_1:IIE , IJB:IJE ) )
+ !$acc enter data create (ZNORTHC_2D_IN, ZSOUTHC_2D_IN, ZWESTC_2D_IN, ZEASTC_2D_IN)
+ !
+ ALLOCATE ( ZSOUTHC_2D_OUT ( 1:IIU , 1:IJB-1 ) )
+ ALLOCATE ( ZNORTHC_2D_OUT ( 1:IIU , IJE+1:IJU ) )
+ ALLOCATE ( ZWESTC_2D_OUT ( 1:IIB-1 , IJB:IJE ) )
+ ALLOCATE ( ZEASTC_2D_OUT ( IIE+1:IIU , IJB:IJE ) )
+ !$acc enter data create (ZNORTHC_2D_OUT, ZSOUTHC_2D_OUT, ZWESTC_2D_OUT, ZEASTC_2D_OUT)
+ !
+ ! Init HALO2 for Full update in 1 time <-> GET_HALO + GET_HALO2
+ !
+ ALLOCATE ( ZSOUTH2F_IN ( IIB:IIE , IJB:IJB+IHALO2_1 , IKU ) )
+ ALLOCATE ( ZNORTH2F_IN ( IIB:IIE , IJE-IHALO2_1:IJE , IKU ) )
+ ALLOCATE ( ZWEST2F_IN ( IIB:IIB+IHALO2_1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEAST2F_IN ( IIE-IHALO2_1:IIE , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTH2F_IN, ZSOUTH2F_IN, ZWEST2F_IN, ZEAST2F_IN)
+ !
+ ALLOCATE ( ZSOUTH2F_OUT ( IIB:IIE , IJB-IHALO2:IJB-1 , IKU ) )
+ ALLOCATE ( ZNORTH2F_OUT ( IIB:IIE , IJE+1:IJE+IHALO2 , IKU ) )
+ ALLOCATE ( ZWEST2F_OUT ( IIB-IHALO2:IIB-1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEAST2F_OUT ( IIE+1:IIE+IHALO2 , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTH2F_OUT, ZSOUTH2F_OUT, ZWEST2F_OUT, ZEAST2F_OUT)
+
IF (.NOT. GWEST ) THEN
NP_WEST = ( IP-1 -1 ) + 1
ELSE
@@ -891,10 +1005,8 @@ END IF
!$acc end data
END SUBROUTINE GET_HALO_DD
-
-!-------------------------------------------------------------------------------
! ########################################
- SUBROUTINE GET_HALO2_DD(PSRC, TP_PSRC_HALO2_ll, HNAME)
+ SUBROUTINE GET_2D_HALO_DD(PSRC, HDIR, HNAME)
! ########################################
#define MNH_GPUDIRECT
!
@@ -905,25 +1017,27 @@ USE MODD_PARAMETERS, ONLY : JPHEXT
!
USE MODD_IO, ONLY : GSMONOPROC
USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
-USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
-USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
!
USE MODD_CONF, ONLY : NHALO
USE MODE_DEVICE
USE MODE_MPPDB
-!
-USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
-USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
-USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
USE MODD_PRECISION, ONLY : MNHREAL_MPI
!
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
IMPLICIT NONE
!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PSRC ! variable at t
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
!
character(len=:), allocatable :: yname
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
INTEGER :: IERROR ! error return code
INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
@@ -933,44 +1047,62 @@ LOGICAL :: LX , LY
INTEGER :: INB_REQ , IREQ(8)
INTEGER :: IERR
-REAL , DIMENSION(:,:) , POINTER , CONTIGUOUS :: ZH2_EAST,ZH2_WEST,ZH2_NORTH,ZH2_SOUTH
-
if ( NPROC == 1 ) RETURN
-!$acc data present ( PSRC ) &
-!$acc present (ZNORTH2_IN, ZSOUTH2_IN, ZWEST2_IN, ZEAST2_IN) &
-!$acc present (ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT)
+CALL INIT_HALO_D()
+
+!$acc data present ( PSRC )
+
+NULLIFY( TZ_PSRC_ll)
!
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
LX = .TRUE.
LY = .TRUE.
+ELSE
+ !
+ ! Problem of reproductibility in ppm_s0_x/y if only S0_X or S0_Y
+ ! so add S0_X + S0_Y for ppm_s0*
+ !
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+END IF
+
+!!$LX = .TRUE.
+!!$LY = .TRUE.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
INB_REQ = 0
!
-! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+! Post the recieve of Zxxxx_2D_OUT buffer first via MPI(Gpu_direct)
!
IF (LX) THEN
IF (.NOT. GWEST) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZWEST2_OUT)
+ !$acc host_data use_device(ZWEST_2D_OUT)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_IRECV(ZWEST2_OUT,SIZE(ZWEST2_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_IRECV(ZWEST_2D_OUT,SIZE(ZWEST_2D_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
END IF
IF (.NOT.GEAST) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZEAST2_OUT)
+ !$acc host_data use_device(ZEAST_2D_OUT)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_IRECV(ZEAST2_OUT,SIZE(ZEAST2_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_IRECV(ZEAST_2D_OUT,SIZE(ZEAST_2D_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
@@ -980,20 +1112,20 @@ END IF
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZSOUTH2_OUT)
+ !$acc host_data use_device(ZSOUTH_2D_OUT)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_IRECV(ZSOUTH2_OUT,SIZE(ZSOUTH2_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_IRECV(ZSOUTH_2D_OUT,SIZE(ZSOUTH_2D_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
ENDIF
IF (.NOT.GNORTH) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZNORTH2_OUT)
+ !$acc host_data use_device(ZNORTH_2D_OUT)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_IRECV(ZNORTH2_OUT,SIZE(ZNORTH2_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_IRECV(ZNORTH_2D_OUT,SIZE(ZNORTH_2D_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
@@ -1002,33 +1134,29 @@ END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!Copy the halo on the device PSRC to Zxxxx_IN
+!Copy the halo on the device PSRC to Zxxxx_2D_IN
IF (LX) THEN
IF (.NOT. GWEST) THEN
!$acc kernels async(IS_WEST)
-!!$ ZWEST2_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
- ZWEST2_IN ( : , : ) = PSRC( IIB+1 , : , : )
+ ZWEST_2D_IN ( IIB:IIB+IHALO_1 , IJB:IJE ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE )
!$acc end kernels
END IF
IF (.NOT.GEAST) THEN
!$acc kernels async(IS_EAST)
-!!$ ZEAST2_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
- ZEAST2_IN ( : , : ) = PSRC( IIE-1 , : , : )
+ ZEAST_2D_IN ( IIE-IHALO_1:IIE , IJB:IJE ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE )
!$acc end kernels
ENDIF
END IF
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
!$acc kernels async(IS_SOUTH)
-!!$ ZSOUTH2_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
- ZSOUTH2_IN ( : , : ) = PSRC( : , IJB+1 , : )
+ ZSOUTH_2D_IN ( IIB:IIE , IJB:IJB+IHALO_1 ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 )
!$acc end kernels
ENDIF
IF (.NOT.GNORTH) THEN
!$acc kernels async(IS_NORTH)
-!!$ ZNORTH2_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
- ZNORTH2_IN ( : , : ) = PSRC( : , IJE-1 , : )
+ ZNORTH_2D_IN ( IIB:IIE , IJE-IHALO_1:IJE ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE )
!$acc end kernels
ENDIF
ENDIF
@@ -1036,29 +1164,29 @@ ENDIF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
-! Send Zxxxx2_IN buffer via MPI(Gpu_direct) or copy to host
+! Send Zxxxx_2D_IN buffer via MPI(Gpu_direct) or copy to host
!
IF (LX) THEN
IF (.NOT. GWEST) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZWEST2_IN)
+ !$acc host_data use_device(ZWEST_2D_IN)
#else
- !$acc update host(ZWEST2_IN)
+ !$acc update host(ZWEST_2D_IN)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_ISEND(ZWEST2_IN,SIZE(ZWEST2_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_ISEND(ZWEST_2D_IN,SIZE(ZWEST_2D_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
END IF
IF (.NOT.GEAST) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZEAST2_IN)
+ !$acc host_data use_device(ZEAST_2D_IN)
#else
- !$acc update host(ZEAST2_IN)
+ !$acc update host(ZEAST_2D_IN)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_ISEND(ZEAST2_IN,SIZE(ZEAST2_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_ISEND(ZEAST_2D_IN,SIZE(ZEAST_2D_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
@@ -1068,24 +1196,24 @@ END IF
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZSOUTH2_IN)
+ !$acc host_data use_device(ZSOUTH_2D_IN)
#else
- !$acc update host(ZSOUTH2_IN)
+ !$acc update host(ZSOUTH_2D_IN)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_ISEND(ZSOUTH2_IN,SIZE(ZSOUTH2_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_ISEND(ZSOUTH_2D_IN,SIZE(ZSOUTH_2D_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
ENDIF
IF (.NOT.GNORTH) THEN
#ifdef MNH_GPUDIRECT
- !$acc host_data use_device(ZNORTH2_IN)
+ !$acc host_data use_device(ZNORTH_2D_IN)
#else
- !$acc update host(ZNORTH2_IN)
+ !$acc update host(ZNORTH_2D_IN)
#endif
INB_REQ = INB_REQ + 1
- CALL MPI_ISEND(ZNORTH2_IN,SIZE(ZNORTH2_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+ CALL MPI_ISEND(ZNORTH_2D_IN,SIZE(ZNORTH_2D_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
#ifdef MNH_GPUDIRECT
!$acc end host_data
#endif
@@ -1108,44 +1236,36 @@ END IF
IF (LX) THEN
IF (.NOT.GWEST) THEN
#ifndef MNH_GPUDIRECT
- !$acc update device(ZWEST2_OUT) async(IS_WEST)
+ !$acc update device(ZWEST_2D_OUT) async(IS_WEST)
#endif
- ZH2_WEST => TP_PSRC_HALO2_ll%HALO2%WEST
!$acc kernels async(IS_WEST)
-!!$ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST2_OUT( 1:IIB-1 , IJB:IJE , : )
- ZH2_WEST( : , : ) = ZWEST2_OUT( : , : )
+ PSRC( 1:IIB-1 , IJB:IJE ) = ZWEST_2D_OUT( 1:IIB-1 , IJB:IJE )
!$acc end kernels
ENDIF
IF (.NOT.GEAST) THEN
#ifndef MNH_GPUDIRECT
- !$acc update device(ZEAST2_OUT) async(IS_EAST)
+ !$acc update device(ZEAST_2D_OUT) async(IS_EAST)
#endif
- ZH2_EAST => TP_PSRC_HALO2_ll%HALO2%EAST
!$acc kernels async(IS_EAST)
-!!$ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST2_OUT( IIE+1:IIU , IJB:IJE , : )
- ZH2_EAST( : , : ) = ZEAST2_OUT( : , : )
+ PSRC( IIE+1:IIU , IJB:IJE ) = ZEAST_2D_OUT( IIE+1:IIU , IJB:IJE )
!$acc end kernels
ENDIF
END IF
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
#ifndef MNH_GPUDIRECT
- !$acc update device(ZSOUTH2_OUT) async(IS_SOUTH)
+ !$acc update device(ZSOUTH_2D_OUT) async(IS_SOUTH)
#endif
- ZH2_SOUTH => TP_PSRC_HALO2_ll%HALO2%SOUTH
!$acc kernels async(IS_SOUTH)
-!!$ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH2_OUT( IIB:IIE , 1:IJB-1 , : )
- ZH2_SOUTH( : , : ) = ZSOUTH2_OUT( : , : )
+ PSRC( IIB:IIE , 1:IJB-1) = ZSOUTH_2D_OUT( IIB:IIE , 1:IJB-1 )
!$acc end kernels
ENDIF
IF (.NOT.GNORTH) THEN
#ifndef MNH_GPUDIRECT
- !$acc update device(ZNORTH2_OUT) async(IS_NORTH)
+ !$acc update device(ZNORTH_2D_OUT) async(IS_NORTH)
#endif
- ZH2_NORTH => TP_PSRC_HALO2_ll%HALO2%NORTH
!$acc kernels async(IS_NORTH)
-!!$ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH2_OUT ( IIB:IIE , IJE+1:IJU , : )
- ZH2_NORTH( : , : ) = ZNORTH2_OUT ( : , : )
+ PSRC( IIB:IIE , IJE+1:IJU) = ZNORTH_2D_OUT ( IIB:IIE , IJE+1:IJU )
!$acc end kernels
ENDIF
END IF
@@ -1153,47 +1273,1169 @@ END IF
!$acc end data
-END SUBROUTINE GET_HALO2_DD
-!
-! ###################################################
- SUBROUTINE GET_HALO2_D(PSRC, TP_PSRC_HALO2_ll, HNAME)
-! ###################################################
+END SUBROUTINE GET_2D_HALO_DD
+!-------------------------------------------------------------------------------
+! ########################################
+ SUBROUTINE GET_HALO_DDC(PSRC, HDIR, HNAME)
+! ########################################
+#define MNH_GPUDIRECT
!
+USE MODD_HALO_D
USE MODE_ll
-USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
-USE MODI_GET_HALO, ONLY : GET_HALO_D,GET_HALO_DD,GET_HALO2_DD
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODD_IO, ONLY : GSMONOPROC
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_DEVICE
+USE MODE_MPPDB
+
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
!
IMPLICIT NONE
!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
-TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
!
character(len=:), allocatable :: yname
-INTEGER :: IIU,IJU,IKU ! domain sizes
TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+LOGICAL :: LX , LY
+
+INTEGER :: INB_REQEW , IREQEW(4)
+INTEGER :: INB_REQNS , IREQNS(4)
+INTEGER :: IERR
+
+if ( NPROC == 1 ) RETURN
+
+CALL INIT_HALO_D()
+
+!$acc data present ( PSRC )
+
+NULLIFY( TZ_PSRC_ll)
!
-IIU = SIZE(PSRC,1)
-IJU = SIZE(PSRC,2)
-IKU = SIZE(PSRC,3)
-if ( present ( hname ) ) then
- yname = hname
-else
- yname = 'PSRC'
-end if
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-CALL GET_HALO_DD(PSRC,HNAME=yname)
+LX = .FALSE.
+LY = .FALSE.
-!!$NULLIFY( TZ_PSRC_ll,TP_PSRC_HALO2_ll)
-CALL INIT_HALO2_ll(TP_PSRC_HALO2_ll,1,IIU,IJU,IKU)
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+ !
+ ! Problem of reproductibility in ppm_s0_x/y if only S0_X or S0_Y
+ ! so add S0_X + S0_Y for ppm_s0*
+ !
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+END IF
+
+!!$LX = .TRUE.
+!!$LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
-!!$CALL ADD3DFIELD_ll( TZ_PSRC_ll, PSRC, 'GET_HALO2_D::'//trim( yname ) )
-!!$CALL UPDATE_HALO2_ll(TZ_PSRC_ll,TP_PSRC_HALO2_ll,IERROR)
-CALL GET_HALO2_DD(PSRC,TP_PSRC_HALO2_ll,'GET_HALO2_DD::'//trim( yname ) )
+! Post first the recieve of ZxxxxC_OUT buffer via MPI(Gpu_direct)
!
-! clean local halo list
+!-------------------------------------------------------------------------------!
+! IRecv E/W !
+!-------------------------------------------------------------------------------!
+INB_REQEW = 0
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWESTC_OUT)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_IRECV(ZWESTC_OUT,SIZE(ZWESTC_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEASTC_OUT)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_IRECV(ZEASTC_OUT,SIZE(ZEASTC_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo E/W on the device PSRC to ZxxxxC_IN
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+ ZWESTC_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+ ZEASTC_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send E/W ZxxxxC_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWESTC_IN)
+#else
+ !$acc update host(ZWESTC_IN)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_ISEND(ZWESTC_IN,SIZE(ZWESTC_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEASTC_IN)
+#else
+ !$acc update host(ZEASTC_IN)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_ISEND(ZEASTC_IN,SIZE(ZEASTC_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQEW > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQEW,IREQEW,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo E/W from buffer to PSRC
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWESTC_OUT) async(IS_WEST)
+#endif
+ !$acc kernels async(IS_WEST)
+ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWESTC_OUT( 1:IIB-1 , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEASTC_OUT) async(IS_EAST)
+#endif
+ !$acc kernels async(IS_EAST)
+ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEASTC_OUT( IIE+1:IIU , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Post first the recieve of N/S ZxxxxC_OUT buffer via MPI(Gpu_direct)
+!
+!-------------------------------------------------------------------------------!
+! IRecv N/S !
+!-------------------------------------------------------------------------------!
+INB_REQNS = 0
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTHC_OUT)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_IRECV(ZSOUTHC_OUT,SIZE(ZSOUTHC_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTHC_OUT)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_IRECV(ZNORTHC_OUT,SIZE(ZNORTHC_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!
+!Copy the halo N/S on the device PSRC to ZxxxxC_IN
+!
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+ ZSOUTHC_IN ( 1:IIU , IJB:IJB+IHALO_1 , : ) = PSRC( 1:IIU , IJB:IJB+IHALO_1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+ ZNORTHC_IN ( 1:IIU , IJE-IHALO_1:IJE , : ) = PSRC( 1:IIU , IJE-IHALO_1:IJE , : )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send N/S ZxxxxC_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTHC_IN)
+#else
+ !$acc update host(ZSOUTHC_IN)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_ISEND(ZSOUTHC_IN,SIZE(ZSOUTHC_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTHC_IN)
+#else
+ !$acc update host(ZNORTHC_IN)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_ISEND(ZNORTHC_IN,SIZE(ZNORTHC_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQNS > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQNS,IREQNS,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo N/S
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo N/S/W from buffer to PSRC
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTHC_OUT) async(IS_SOUTH)
+#endif
+ !$acc kernels async(IS_SOUTH)
+ PSRC( 1:IIU , 1:IJB-1 , : ) = ZSOUTHC_OUT( 1:IIU , 1:IJB-1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTHC_OUT) async(IS_NORTH)
+#endif
+ !$acc kernels async(IS_NORTH)
+ PSRC( 1:IIU , IJE+1:IJU , : ) = ZNORTHC_OUT ( 1:IIU , IJE+1:IJU , : )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+END IF
+
+!$acc end data
+
+END SUBROUTINE GET_HALO_DDC
+!-------------------------------------------------------------------------------
+! ########################################
+ SUBROUTINE GET_2D_HALO_DDC(PSRC, HDIR, HNAME)
+! ########################################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODD_IO, ONLY : GSMONOPROC
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_DEVICE
+USE MODE_MPPDB
+
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PSRC ! variable at t
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+LOGICAL :: LX , LY
+
+INTEGER :: INB_REQEW , IREQEW(4)
+INTEGER :: INB_REQNS , IREQNS(4)
+INTEGER :: IERR
+
+if ( NPROC == 1 ) RETURN
+
+CALL INIT_HALO_D()
+
+!$acc data present ( PSRC )
+
+NULLIFY( TZ_PSRC_ll)
+!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+ !
+ ! Problem of reproductibility in ppm_s0_x/y if only S0_X or S0_Y
+ ! so add S0_X + S0_Y for ppm_s0*
+ !
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+END IF
+
+!!$LX = .TRUE.
+!!$LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Post first the recieve of ZxxxxC_2D_OUT buffer via MPI(Gpu_direct)
+!
+!-------------------------------------------------------------------------------!
+! IRecv E/W !
+!-------------------------------------------------------------------------------!
+INB_REQEW = 0
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWESTC_2D_OUT)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_IRECV(ZWESTC_2D_OUT,SIZE(ZWESTC_2D_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEASTC_2D_OUT)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_IRECV(ZEASTC_2D_OUT,SIZE(ZEASTC_2D_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo E/W on the device PSRC to ZxxxxC_2D_IN
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+ ZWESTC_2D_IN ( IIB:IIB+IHALO_1 , IJB:IJE ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+ ZEASTC_2D_IN ( IIE-IHALO_1:IIE , IJB:IJE ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send E/W ZxxxxC_2D_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWESTC_2D_IN)
+#else
+ !$acc update host(ZWESTC_2D_IN)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_ISEND(ZWESTC_2D_IN,SIZE(ZWESTC_2D_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEASTC_2D_IN)
+#else
+ !$acc update host(ZEASTC_2D_IN)
+#endif
+ INB_REQEW = INB_REQEW + 1
+ CALL MPI_ISEND(ZEASTC_2D_IN,SIZE(ZEASTC_2D_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQEW(INB_REQEW),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQEW > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQEW,IREQEW,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo E/W from buffer to PSRC
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWESTC_2D_OUT) async(IS_WEST)
+#endif
+ !$acc kernels async(IS_WEST)
+ PSRC( 1:IIB-1 , IJB:IJE ) = ZWESTC_2D_OUT( 1:IIB-1 , IJB:IJE )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEASTC_2D_OUT) async(IS_EAST)
+#endif
+ !$acc kernels async(IS_EAST)
+ PSRC( IIE+1:IIU , IJB:IJE ) = ZEASTC_2D_OUT( IIE+1:IIU , IJB:IJE )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Post first the recieve of N/S ZxxxxC_2D_OUT buffer via MPI(Gpu_direct)
+!
+!-------------------------------------------------------------------------------!
+! IRecv N/S !
+!-------------------------------------------------------------------------------!
+INB_REQNS = 0
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTHC_2D_OUT)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_IRECV(ZSOUTHC_2D_OUT,SIZE(ZSOUTHC_2D_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTHC_2D_OUT)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_IRECV(ZNORTHC_2D_OUT,SIZE(ZNORTHC_2D_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!
+!Copy the halo N/S on the device PSRC to ZxxxxC_2D_IN
+!
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+ ZSOUTHC_2D_IN ( 1:IIU , IJB:IJB+IHALO_1 ) = PSRC( 1:IIU , IJB:IJB+IHALO_1 )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+ ZNORTHC_2D_IN ( 1:IIU , IJE-IHALO_1:IJE ) = PSRC( 1:IIU , IJE-IHALO_1:IJE )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send N/S ZxxxxC_2D_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTHC_2D_IN)
+#else
+ !$acc update host(ZSOUTHC_2D_IN)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_ISEND(ZSOUTHC_2D_IN,SIZE(ZSOUTHC_2D_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTHC_2D_IN)
+#else
+ !$acc update host(ZNORTHC_2D_IN)
+#endif
+ INB_REQNS = INB_REQNS + 1
+ CALL MPI_ISEND(ZNORTHC_2D_IN,SIZE(ZNORTHC_2D_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQNS(INB_REQNS),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQNS > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQNS,IREQNS,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo N/S
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo N/S/W from buffer to PSRC
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTHC_2D_OUT) async(IS_SOUTH)
+#endif
+ !$acc kernels async(IS_SOUTH)
+ PSRC( 1:IIU , 1:IJB-1) = ZSOUTHC_2D_OUT( 1:IIU , 1:IJB-1 )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTHC_2D_OUT) async(IS_NORTH)
+#endif
+ !$acc kernels async(IS_NORTH)
+ PSRC( 1:IIU , IJE+1:IJU) = ZNORTHC_2D_OUT ( 1:IIU , IJE+1:IJU )
+ !$acc end kernels
+ ENDIF
+ !$acc wait
+END IF
+
+!$acc end data
+
+END SUBROUTINE GET_2D_HALO_DDC
+!-------------------------------------------------------------------------------
+! ########################################
+ SUBROUTINE GET_HALO2_DD(PSRC, TP_PSRC_HALO2_ll, HNAME)
+! ########################################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODD_IO, ONLY : GSMONOPROC
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+LOGICAL :: LX , LY
+
+INTEGER :: INB_REQ , IREQ(8)
+INTEGER :: IERR
+
+REAL , DIMENSION(:,:) , POINTER , CONTIGUOUS :: ZH2_EAST,ZH2_WEST,ZH2_NORTH,ZH2_SOUTH
+
+if ( NPROC == 1 ) RETURN
+
+!$acc data present ( PSRC ) &
+!$acc present (ZNORTH2_IN, ZSOUTH2_IN, ZWEST2_IN, ZEAST2_IN) &
+!$acc present (ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+LX = .TRUE.
+LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+INB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZWEST2_OUT,SIZE(ZWEST2_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZEAST2_OUT,SIZE(ZEAST2_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH2_OUT,SIZE(ZSOUTH2_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZNORTH2_OUT,SIZE(ZNORTH2_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo on the device PSRC to Zxxxx_IN
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+!!$ ZWEST2_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ ZWEST2_IN ( : , : ) = PSRC( IIB+1 , : , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+!!$ ZEAST2_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ ZEAST2_IN ( : , : ) = PSRC( IIE-1 , : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+!!$ ZSOUTH2_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
+ ZSOUTH2_IN ( : , : ) = PSRC( : , IJB+1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+!!$ ZNORTH2_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
+ ZNORTH2_IN ( : , : ) = PSRC( : , IJE-1 , : )
+ !$acc end kernels
+ ENDIF
+ENDIF
+!$acc wait
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send Zxxxx2_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST2_IN)
+#else
+ !$acc update host(ZWEST2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZWEST2_IN,SIZE(ZWEST2_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST2_IN)
+#else
+ !$acc update host(ZEAST2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZEAST2_IN,SIZE(ZEAST2_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH2_IN)
+#else
+ !$acc update host(ZSOUTH2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH2_IN,SIZE(ZSOUTH2_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH2_IN)
+#else
+ !$acc update host(ZNORTH2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZNORTH2_IN,SIZE(ZNORTH2_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQ > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQ,IREQ,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Is update halo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWEST2_OUT) async(IS_WEST)
+#endif
+ ZH2_WEST => TP_PSRC_HALO2_ll%HALO2%WEST
+ !$acc kernels async(IS_WEST)
+!!$ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST2_OUT( 1:IIB-1 , IJB:IJE , : )
+ ZH2_WEST( : , : ) = ZWEST2_OUT( : , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEAST2_OUT) async(IS_EAST)
+#endif
+ ZH2_EAST => TP_PSRC_HALO2_ll%HALO2%EAST
+ !$acc kernels async(IS_EAST)
+!!$ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST2_OUT( IIE+1:IIU , IJB:IJE , : )
+ ZH2_EAST( : , : ) = ZEAST2_OUT( : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTH2_OUT) async(IS_SOUTH)
+#endif
+ ZH2_SOUTH => TP_PSRC_HALO2_ll%HALO2%SOUTH
+ !$acc kernels async(IS_SOUTH)
+!!$ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH2_OUT( IIB:IIE , 1:IJB-1 , : )
+ ZH2_SOUTH( : , : ) = ZSOUTH2_OUT( : , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTH2_OUT) async(IS_NORTH)
+#endif
+ ZH2_NORTH => TP_PSRC_HALO2_ll%HALO2%NORTH
+ !$acc kernels async(IS_NORTH)
+!!$ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH2_OUT ( IIB:IIE , IJE+1:IJU , : )
+ ZH2_NORTH( : , : ) = ZNORTH2_OUT ( : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+!$acc wait
+
+!$acc end data
+
+END SUBROUTINE GET_HALO2_DD
+!-------------------------------------------------------------------------------
+! ########################################
+ SUBROUTINE GET_HALO2_DF(PSRC, TP_PSRC_HALO2F_ll, HNAME)
+! ########################################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODD_IO, ONLY : GSMONOPROC
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2F_ll ! halo2 for SRC
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+LOGICAL :: LX , LY
+
+INTEGER :: INB_REQ , IREQ(8)
+INTEGER :: IERR
+
+REAL , DIMENSION(:,:) , POINTER , CONTIGUOUS :: ZH2F_EAST,ZH2F_WEST,ZH2F_NORTH,ZH2F_SOUTH
+
+if ( NPROC == 1 ) RETURN
+
+!$acc data present ( PSRC ) &
+!$acc present (ZNORTH2F_IN, ZSOUTH2F_IN, ZWEST2F_IN, ZEAST2F_IN) &
+!$acc present (ZNORTH2F_OUT, ZSOUTH2F_OUT, ZWEST2F_OUT, ZEAST2F_OUT)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+LX = .TRUE.
+LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+INB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST2F_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZWEST2F_OUT,SIZE(ZWEST2F_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST2F_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZEAST2F_OUT,SIZE(ZEAST2F_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH2F_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH2F_OUT,SIZE(ZSOUTH2F_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH2F_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZNORTH2F_OUT,SIZE(ZNORTH2F_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo on the device PSRC to Zxxxx_IN
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+ ZWEST2F_IN ( IIB:IIB+IHALO2_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO2_1 , IJB:IJE , : )
+!!$ ZWEST2F_IN ( : , : ) = PSRC( IIB+1 , : , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+ ZEAST2F_IN ( IIE-IHALO2_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO2_1:IIE , IJB:IJE , : )
+!!$ ZEAST2F_IN ( : , : ) = PSRC( IIE-1 , : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+ ZSOUTH2F_IN ( IIB:IIE , IJB:IJB+IHALO2_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO2_1 , : )
+!!$ ZSOUTH2F_IN ( : , : ) = PSRC( : , IJB+1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+ ZNORTH2F_IN ( IIB:IIE , IJE-IHALO2_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO2_1:IJE , : )
+!!$ ZNORTH2F_IN ( : , : ) = PSRC( : , IJE-1 , : )
+ !$acc end kernels
+ ENDIF
+ENDIF
+!$acc wait
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send Zxxxx2F_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST2F_IN)
+#else
+ !$acc update host(ZWEST2F_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZWEST2F_IN,SIZE(ZWEST2F_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST2F_IN)
+#else
+ !$acc update host(ZEAST2F_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZEAST2F_IN,SIZE(ZEAST2F_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH2F_IN)
+#else
+ !$acc update host(ZSOUTH2F_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH2F_IN,SIZE(ZSOUTH2F_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH2F_IN)
+#else
+ !$acc update host(ZNORTH2F_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZNORTH2F_IN,SIZE(ZNORTH2F_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQ > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQ,IREQ,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Update halo in PSRC + %HALO2
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWEST2F_OUT) async(IS_WEST)
+#endif
+ ZH2F_WEST => TP_PSRC_HALO2F_ll%HALO2%WEST
+ !$acc kernels async(IS_WEST)
+ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST2F_OUT( 1:IIB-1 , IJB:IJE , : )
+ ZH2F_WEST( IJB:IJE , : ) = ZWEST2F_OUT( IIB-2, IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEAST2F_OUT) async(IS_EAST)
+#endif
+ ZH2F_EAST => TP_PSRC_HALO2F_ll%HALO2%EAST
+ !$acc kernels async(IS_EAST)
+ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST2F_OUT( IIE+1:IIU , IJB:IJE , : )
+ ZH2F_EAST( IJB:IJE , : ) = ZEAST2F_OUT( IIE+2 , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTH2F_OUT) async(IS_SOUTH)
+#endif
+ ZH2F_SOUTH => TP_PSRC_HALO2F_ll%HALO2%SOUTH
+ !$acc kernels async(IS_SOUTH)
+ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH2F_OUT( IIB:IIE , 1:IJB-1 , : )
+ ZH2F_SOUTH( IIB:IIE , : ) = ZSOUTH2F_OUT( IIB:IIE , IJB-2 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTH2F_OUT) async(IS_NORTH)
+#endif
+ ZH2F_NORTH => TP_PSRC_HALO2F_ll%HALO2%NORTH
+ !$acc kernels async(IS_NORTH)
+ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH2F_OUT ( IIB:IIE , IJE+1:IJU , : )
+ ZH2F_NORTH( IIB:IIE , : ) = ZNORTH2F_OUT ( IIB:IIE , IJE+2 , : )
+ !$acc end kernels
+ ENDIF
+END IF
+!$acc wait
+
+!$acc end data
+
+END SUBROUTINE GET_HALO2_DF
+!
+! ###################################################
+ SUBROUTINE GET_HALO2_D(PSRC, TP_PSRC_HALO2_ll, HNAME)
+! ###################################################
+!
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+USE MODI_GET_HALO, ONLY : GET_HALO_D,GET_HALO_DD,GET_HALO2_DD
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+INTEGER :: IIU,IJU,IKU ! domain sizes
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
+INTEGER :: IERROR ! error return code
+!
+IIU = SIZE(PSRC,1)
+IJU = SIZE(PSRC,2)
+IKU = SIZE(PSRC,3)
+
+if ( present ( hname ) ) then
+ yname = hname
+else
+ yname = 'PSRC'
+end if
+
+CALL GET_HALO_DD(PSRC,HNAME=yname)
+
+!!$NULLIFY( TZ_PSRC_ll,TP_PSRC_HALO2_ll)
+!!$CALL INIT_HALO2_ll(TP_PSRC_HALO2_ll,1,IIU,IJU,IKU)
+!
+CALL GET_HALO2_DD(PSRC,TP_PSRC_HALO2_ll,'GET_HALO2_DD::'//trim( yname ) )
+!
+! clean local halo list , must be done outside
!
!!$CALL CLEANLIST_ll(TZ_PSRC_ll)
!
diff --git a/src/ZSOLVER/ini_modeln.f90 b/src/ZSOLVER/ini_modeln.f90
index 8203f0ada7d3d47b9a065697b8587553b551aa77..7fa50a868f56b4f03f92f506a153227281417929 100644
--- a/src/ZSOLVER/ini_modeln.f90
+++ b/src/ZSOLVER/ini_modeln.f90
@@ -786,6 +786,7 @@ ALLOCATE(XTHT(IIU,IJU,IKU)) ; XTHT = 0.0
ALLOCATE(XRUS(IIU,IJU,IKU)) ; XRUS = 0.0
ALLOCATE(XRVS(IIU,IJU,IKU)) ; XRVS = 0.0
ALLOCATE(XRWS(IIU,IJU,IKU)) ; XRWS = 0.0
+!$acc enter data copyin(XRUS,XRVS,XRWS)
ALLOCATE(XRUS_PRES(IIU,IJU,IKU)); XRUS_PRES = 0.0
ALLOCATE(XRVS_PRES(IIU,IJU,IKU)); XRVS_PRES = 0.0
ALLOCATE(XRWS_PRES(IIU,IJU,IKU)); XRWS_PRES = 0.0
diff --git a/src/ZSOLVER/mass_leak.f90 b/src/ZSOLVER/mass_leak.f90
index 9ffe52c67bd2b3bceed6459854309e30d6eb4468..6a6b7206dc5a60d53ac683957f3e8c672ef06732 100644
--- a/src/ZSOLVER/mass_leak.f90
+++ b/src/ZSOLVER/mass_leak.f90
@@ -132,7 +132,7 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! momentum tendencies
!
!JUAN16
REAL :: ZLEAK ! total leak of mass
-REAL, ALLOCATABLE, DIMENSION (:,:) :: ZLEAK_W_2D , ZLEAK_E_2D , ZLEAK_S_2D , ZLEAK_N_2D
+REAL, SAVE , ALLOCATABLE, DIMENSION (:,:) :: ZLEAK_W_2D , ZLEAK_E_2D , ZLEAK_S_2D , ZLEAK_N_2D
!JUAN16
REAL :: ZUSTOP ! wind correction!
@@ -151,6 +151,7 @@ INTEGER :: IINFO_ll ! return code of parallel routine
LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
REAL :: ZLEAK_W,ZLEAK_E,ZLEAK_S,ZLEAK_N
!
+LOGICAL , SAVE :: GFIRST_CALL_MASS_LEAK = .TRUE.
!-------------------------------------------------------------------------------
!
!* 1. COMPUTE DIMENSIONS OF ARRAYS AND OTHER INDICES:
@@ -177,9 +178,19 @@ ZLEAK_W=0.
ZLEAK_S=0.
ZLEAK_N=0.
!
-IF( HLBCY(1) /= 'CYCL' ) THEN
- ALLOCATE( ZLEAK_W_2D(IIB:IIB,IJB:IJE))
- ALLOCATE( ZLEAK_E_2D(IIE+1:IIE+1,IJB:IJE))
+IF (GFIRST_CALL_MASS_LEAK) THEN
+ GFIRST_CALL_MASS_LEAK = .FALSE.
+ IF( HLBCX(1) /= 'CYCL' ) THEN
+ ALLOCATE( ZLEAK_W_2D(IIB:IIB,IJB:IJE))
+ ALLOCATE( ZLEAK_E_2D(IIE+1:IIE+1,IJB:IJE))
+ END IF
+ IF( HLBCY(1) /= 'CYCL' ) THEN
+ ALLOCATE( ZLEAK_S_2D(IIB:IIE,IJB:IJB))
+ ALLOCATE( ZLEAK_N_2D(IIB:IIE,IJE+1:IJE+1))
+ END IF
+END IF
+!
+IF( HLBCX(1) /= 'CYCL' ) THEN
!$acc kernels async
ZLEAK_W_2D = 0.0
IF( GWEST ) THEN
@@ -209,8 +220,6 @@ IF( HLBCY(1) /= 'CYCL' ) THEN
END IF
!
IF( HLBCY(1) /= 'CYCL' ) THEN
- ALLOCATE( ZLEAK_S_2D(IIB:IIE,IJB:IJB))
- ALLOCATE( ZLEAK_N_2D(IIB:IIE,IJE+1:IJE+1))
!
!$acc kernels async
ZLEAK_S_2D = 0.0
@@ -242,10 +251,6 @@ IF( HLBCY(1) /= 'CYCL' ) THEN
END IF
!
ZLEAK = ZLEAK_E + ZLEAK_W + ZLEAK_S + ZLEAK_N
-!!$ZLEAK = ZLEAK_E
-!!$ZLEAK = ZLEAK + ZLEAK_W
-!!$ZLEAK = ZLEAK + ZLEAK_S
-!!$ZLEAK = ZLEAK + ZLEAK_N
!
!CALL REDUCESUM_ll(ZLEAK,IINFO_ll) ! we do the reducesum_ll in SUM_DD_R2_ll so we do not do it here
!
diff --git a/src/ZSOLVER/p_abs.f90 b/src/ZSOLVER/p_abs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..adfa745cb1665ad351177b31e3b00abef6d583b3
--- /dev/null
+++ b/src/ZSOLVER/p_abs.f90
@@ -0,0 +1,439 @@
+!MNH_LIC Copyright 1994-2014 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.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 solver 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+ MODULE MODI_P_ABS
+! #################
+!
+INTERFACE
+!
+ SUBROUTINE P_ABS (KRR, KRRL, KRRI, PDRYMASST, PREFMASS, PMASS_O_PHI0, &
+ PTHT, PRT, PRHODJ, PRHODREF, PTHETAV, PTHVREF, &
+ PRVREF, PEXNREF, PPHIT )
+!
+IMPLICIT NONE
+!
+INTEGER, INTENT(IN) :: KRR ! Total number of water var.
+INTEGER, INTENT(IN) :: KRRL ! Number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! Number of ice water var.
+!
+REAL, INTENT(IN) :: PDRYMASST ! Mass of dry air and of
+REAL, INTENT(IN) :: PREFMASS ! the ref. atmosphere
+ ! contained in the simulation domain
+REAL, INTENT(IN) :: PMASS_O_PHI0 ! Mass / Phi0
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Temperature and water
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! variables at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! dry Density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! dry Density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
+ ! of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! vapor mixing ratio
+ ! for the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF! Exner function of the
+ ! reference state
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHIT ! Perturbation of
+ ! either the Exner function Pi or Pi * Cpd * THvref
+!
+!
+END SUBROUTINE P_ABS
+!
+END INTERFACE
+!
+END MODULE MODI_P_ABS
+! #######################################################################
+ SUBROUTINE P_ABS (KRR, KRRL, KRRI, PDRYMASST, PREFMASS, PMASS_O_PHI0, &
+ PTHT, PRT, PRHODJ, PRHODREF, PTHETAV, PTHVREF, &
+ PRVREF, PEXNREF, PPHIT )
+! #######################################################################
+!
+!!**** *P_ABS * - routine to compute the absolute Exner pressure deviation PHI
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to compute the absolute Exner
+!! pressure Pi ( or Pi multiplied by Cpd*Thetavref) deviation PHI,
+!! which is not determined for an anelatic system.
+!! It also diagnozes the total mass of water Mw.
+!!
+!!
+!!** METHOD
+!! ------
+!! The knowledge of the total mass of dry air Md and of water Mw
+!! (including all water categories), allowed to diagnoze the absolute
+!! Exner pressure PHI. The equation of state is not anymore linearized.
+!!
+!! EXTERNAL
+!! --------
+!! none
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XRD,XRV Gaz constant for dry air Rd and wator vapor Rv
+!! XCPD Specific heat at constant pressure for dry air Cp
+!! XP00 Reference pressure
+!!
+!! Module MODD_PARAMETERS : contains parameters commun to all models
+!! JPHEXT : Horizontal EXTernal points number (JPHEXT=1 for this version)
+!! JPVEXT : Vertical EXTernal points number (JPVEXT=1 for this version)
+!! Module MODD_CONF :
+!! CEQNSYS
+!!
+!! REFERENCE
+!! ---------
+!! Book1 and book2 of documentation ( routine P_ABS )
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Lafore * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/12/94
+!! J.P. Lafore 10/02/95 Bug correction in ZMASSGUESS
+!! J. Stein 16/03/95 Remove R from the historical variables
+!! J.P. Lafore 14/01/97 Introduction of 2 anelastic systems:
+!! Modified Anelastic Equation and one derived
+!! from Durran (1989), MAE and DUR respectively
+!! 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! J. Colin 07/13 Add LBOUSS
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_CONF
+USE MODD_PARAMETERS
+USE MODD_REF, ONLY : LBOUSS
+!
+USE MODE_ll
+!JUAN
+USE MODE_REPRO_SUM
+!JUAN
+!
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#endif
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+#endif
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+INTEGER, INTENT(IN) :: KRR ! Total number of water var.
+INTEGER, INTENT(IN) :: KRRL ! Number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! Number of ice water var.
+!
+REAL, INTENT(IN) :: PDRYMASST ! Mass of dry air and of
+REAL, INTENT(IN) :: PREFMASS ! the ref. atmosphere
+ ! contained in the simulation domain
+REAL, INTENT(IN) :: PMASS_O_PHI0 ! Mass / Phi0
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Temperature and water
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! variables at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! dry Density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! dry Density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
+ ! of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! vapor mixing ratio
+ ! for the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF! Exner function of the
+ ! reference state
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHIT ! Perturbation of
+ ! either the Exner function Pi or Pi * Cpd * THvref
+!
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IKU ! Upper dimension in z direction
+INTEGER :: IIB ! indice I Beginning in x direction
+INTEGER :: IJB ! indice J Beginning in y direction
+INTEGER :: IKB ! indice K Beginning in z direction
+INTEGER :: IIE ! indice I End in x direction
+INTEGER :: IJE ! indice J End in y direction
+INTEGER :: IKE ! indice K End in z direction
+INTEGER :: JI ! Loop index in x direction
+INTEGER :: JJ ! Loop index in y direction
+INTEGER :: JK ! Loop index in z direction
+REAL :: ZP00_O_RD ! = P00 / Rd
+REAL :: ZCVD_O_RD ! = Cvd / Rd
+REAL :: ZRV_O_RD ! = Rv / Rd
+REAL :: ZCVD_O_RDCPD ! = Cvd / (Rd * Cpd)
+REAL :: ZMASS_O_PI ! Mass / Pi0
+REAL :: ZMASSGUESS ! guess of mass resulting of the pressure function
+ ! provided by the pressure solveur, to an arbitary constant
+REAL :: ZWATERMASST ! Total mass of water Mw
+!JUAN16
+REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZMASS_O_PI_2D,ZMASSGUESS_2D,ZWATERMASST_2D
+!JUAN16
+REAL :: ZPI0 ! constant to retrieve the absolute Exner pressure
+INTEGER :: JWATER ! loop index on the different types of water
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS &
+ :: ZRTOT, ZRHOREF, ZWORK
+INTEGER :: IZRTOT, IZRHOREF, IZWORK
+REAL :: ZPHI0
+!
+INTEGER :: IINFO_ll
+!
+LOGICAL :: GPRVREF0
+!
+INTEGER :: IIU,IJU
+!
+LOGICAL, SAVE :: GFIRST_CALL_P_ABS = .TRUE.
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTE DIMENSIONS OF ARRAYS AND OTHER INDICES:
+! ----------------------------------------------
+!
+IIU = SIZE(PTHT,1)
+IJU = SIZE(PTHT,2)
+IKU = SIZE(PTHT,3)
+IKB = 1 + JPVEXT
+IKE = IKU - JPVEXT
+!
+CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+!
+GPRVREF0 = ( SIZE(PRVREF,1) == 0 )
+!
+IF (GFIRST_CALL_P_ABS) THEN
+ GFIRST_CALL_P_ABS = .FALSE.
+ ALLOCATE(ZMASS_O_PI_2D(IIB:IIE,IJB:IJE))
+ ALLOCATE(ZMASSGUESS_2D(IIB:IIE,IJB:IJE))
+ ALLOCATE(ZWATERMASST_2D(IIB:IIE,IJB:IJE))
+END IF
+!
+ZP00_O_RD = XP00 / XRD
+ZCVD_O_RD = (XCPD - XRD) / XRD
+!
+#ifndef MNH_OPENACC
+ALLOCATE (ZRTOT(IIU,IJU,IKU), ZRHOREF(IIU,IJU,IKU), ZWORK(IIU,IJU,IKU))
+#else
+IZRTOT = MNH_ALLOCATE_ZT3D(ZRTOT,IIU,IJU,IKU )
+IZRHOREF = MNH_ALLOCATE_ZT3D(ZRHOREF,IIU,IJU,IKU )
+IZWORK = MNH_ALLOCATE_ZT3D(ZWORK,IIU,IJU,IKU )
+#endif
+
+!-------------------------------------------------------------------------------
+!
+!
+!* 2. COMPUTES THE ABSOLUTE EXNER FUNCTION (MAE+ DUR)
+! -----------------------------------------------
+!
+!
+!
+IF ( CEQNSYS=='DUR' .OR. CEQNSYS=='MAE' ) THEN
+ !
+ !$acc kernels
+ IF(KRR > 0) THEN
+ !
+ ! compute the mixing ratio of the total water (ZRTOT)
+ ZRTOT(:,:,:) = PRT(:,:,:,1)
+ !$acc loop seq
+ DO JWATER = 2 , 1+KRRL+KRRI
+ ZRTOT(:,:,:) = ZRTOT(:,:,:) + PRT(:,:,:,JWATER)
+ END DO
+ ELSE
+ ZRTOT(:,:,:) = 0.
+ END IF
+ !
+ ZMASSGUESS_2D = 0.
+ ZMASS_O_PI_2D = 0.
+ ZWATERMASST_2D = 0.
+ !$acc end kernels
+!
+ IF ( CEQNSYS == 'DUR' ) THEN
+ !$acc kernels
+ ! compute the Jacobian in ZWORK
+ IF ( GPRVREF0 ) THEN
+ ZWORK(:,:,:)= PRHODJ * XTH00 / ( PRHODREF * PTHVREF )
+ ELSE
+ ZWORK(:,:,:)=PRHODJ * XTH00 &
+ / ( PRHODREF * PTHVREF * (1. + PRVREF) )
+ END IF
+ !
+ !$acc loop seq
+ DO JK = IKB,IKE
+ !$acc loop independent collapse(2)
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
+#ifndef MNH_OPENACC
+ (PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
+#else
+ BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD) &
+#endif
+ * ZWORK(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
+ ZMASS_O_PI_2D(JI,JJ) = ZMASS_O_PI_2D(JI,JJ) + ZWORK(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
+ ZWATERMASST_2D(JI,JJ) = ZWATERMASST_2D(JI,JJ) + &
+ ZRTOT(JI,JJ,JK) * ZWORK(JI,JJ,JK) * PRHODREF(JI,JJ,JK)
+ END DO
+ END DO
+ END DO
+ !$acc end kernels
+ !
+ ELSE
+ DO JK = IKB,IKE
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
+ (PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
+ * PRHODJ(JI,JJ,JK) / PRHODREF(JI,JJ,JK) &
+ / PTHETAV(JI,JJ,JK)
+ ZMASS_O_PI_2D(JI,JJ) = ZMASS_O_PI_2D(JI,JJ) + &
+ PRHODJ(JI,JJ,JK) / PRHODREF(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
+ ZWATERMASST_2D(JI,JJ) = ZWATERMASST_2D(JI,JJ) + ZRTOT(JI,JJ,JK) * PRHODJ(JI,JJ,JK)
+ END DO
+ END DO
+ END DO
+ END IF
+!
+ !
+ ZMASSGUESS = SUM_DD_R2_ll(ZMASSGUESS_2D)
+ ZMASS_O_PI = SUM_DD_R2_ll(ZMASS_O_PI_2D)
+ ZWATERMASST = SUM_DD_R2_ll(ZWATERMASST_2D)
+ !
+ ZMASS_O_PI = ZMASS_O_PI*ZP00_O_RD*ZCVD_O_RD
+ ZPI0 = (PDRYMASST + ZWATERMASST - ZP00_O_RD*ZMASSGUESS ) / ZMASS_O_PI
+ !$acc kernels
+ PPHIT(:,:,:) = PPHIT(:,:,:) + ZPI0
+ !$acc end kernels
+!
+!
+ !
+ ! Second iteration
+ !
+ !$acc kernels
+ ZMASSGUESS_2D = 0.
+ !$acc end kernels
+ IF ( CEQNSYS == 'DUR' ) THEN
+ !$acc kernels
+ !$acc loop seq
+ DO JK = IKB,IKE
+ !$acc loop independent collapse(2)
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
+ (PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
+ * ZWORK(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
+ END DO
+ END DO
+ END DO
+ !$acc end kernels
+ ELSE
+ DO JK = IKB,IKE
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
+ (PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
+ * PRHODJ(JI,JJ,JK) / PRHODREF(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
+ END DO
+ END DO
+ END DO
+ END IF
+!
+
+ ZMASSGUESS = SUM_DD_R2_ll(ZMASSGUESS_2D)
+ !
+ ZPI0 = (PDRYMASST + ZWATERMASST - ZP00_O_RD*ZMASSGUESS ) / ZMASS_O_PI
+ !$acc kernels
+ PPHIT(:,:,:) = PPHIT(:,:,:) + ZPI0
+ !$acc end kernels
+!
+!
+ELSEIF( CEQNSYS == 'LHE' ) THEN
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 3. COMPUTES THE ABSOLUTE PRESSURE FUNCTION (LHE)
+! ---------------------------------------------
+!
+ ! compute the reference moist density
+ !
+ ZCVD_O_RDCPD = ZCVD_O_RD / XCPD
+ ZCVD_O_RD = (XCPD - XRD) / XRD
+ !
+ IF (LBOUSS) THEN
+ ZRHOREF(:,:,:) = PRHODREF(:,:,:)
+ ELSE
+ ZRHOREF(:,:,:) = PEXNREF(:,:,:) ** ZCVD_O_RD &
+ * XP00 / ( XRD * PTHVREF(:,:,:) )
+ ENDIF
+ !
+ !
+ ! compute the virtual potential temperature
+ !
+ !
+ IF(KRR > 0) THEN
+ !
+ ! compute the mixing ratio of the total water (ZRRTOT)
+ ZRV_O_RD = XRV / XRD
+ ZRTOT(:,:,:) = PRT(:,:,:,1)
+ !$acc loop seq
+ DO JWATER = 2 , 1+KRRL+KRRI
+ ZRTOT(:,:,:) = ZRTOT(:,:,:) + PRT(:,:,:,JWATER)
+ END DO
+ ! compute the virtual potential temperature in ZWORK
+ ZWORK(:,:,:) = PTHT(:,:,:) * (1. + PRT(:,:,:,1) * ZRV_O_RD) &
+ / (1. + ZRTOT(:,:,:))
+ ELSE
+ ! compute the virtual potential temperature when water is absent
+ ZWORK(:,:,:) = PTHT(:,:,:)
+ ZRTOT(:,:,:) = 0.
+ END IF
+ !
+ !
+ ! compute the absolute pressure function
+ !
+ !
+ !
+ ZMASSGUESS_2D = 0.
+ ZWATERMASST_2D = 0.
+!
+ DO JK = IKB,IKE
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + ZRHOREF(JI,JJ,JK) / PTHVREF(JI,JJ,JK) * &
+ ( ZWORK(JI,JJ,JK) &
+ - ZCVD_O_RDCPD * PPHIT(JI,JJ,JK) / PEXNREF(JI,JJ,JK) &
+ ) * PRHODJ(JI,JJ,JK) / PRHODREF(JI,JJ,JK)
+ ZWATERMASST_2D(JI,JJ) = ZWATERMASST_2D(JI,JJ) + ZRTOT(JI,JJ,JK) * PRHODJ(JI,JJ,JK)
+ END DO
+ END DO
+ END DO
+ !
+ ZMASSGUESS = SUM_DD_R2_ll(ZMASSGUESS_2D)
+ ZWATERMASST = SUM_DD_R2_ll(ZWATERMASST_2D)
+ !
+ ZPHI0 = (PDRYMASST + ZWATERMASST - 2. * PREFMASS + ZMASSGUESS ) / PMASS_O_PHI0
+ PPHIT(:,:,:) = PPHIT(:,:,:) + ZPHI0
+ !
+END IF
+!
+#ifndef MNH_OPENACC
+DEALLOCATE (ZRTOT, ZRHOREF, ZWORK)
+#else
+CALL MNH_REL_ZT3D ( IZRTOT, IZRHOREF, IZWORK )
+#endif
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE P_ABS
diff --git a/src/ZSOLVER/ppm.f90 b/src/ZSOLVER/ppm.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6c80487d465aecf2a6ddbc78f07daae49da0017f
--- /dev/null
+++ b/src/ZSOLVER/ppm.f90
@@ -0,0 +1,4897 @@
+!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
+
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#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
+!-------------------------------------------------------------------------------
+
+!$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
+!$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
+!
+#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
+#ifndef MNH_BITREP
+ 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,:)
+#ifndef MNH_BITREP
+ 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
+!
+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
+
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#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
+!-------------------------------------------------------------------------------
+
+!$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')
+!$acc kernels
+#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
+!$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
+!
+!* 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
+!
+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
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#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
+!
+!-------------------------------------------------------------------------------
+
+!$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
+#ifndef MNH_BITREP
+ELSEWHERE ( ZQ60*ZDQ < -(ZDQ)**2 )
+#else
+ELSEWHERE ( ZQ60*ZDQ < -BR_P2(ZDQ) )
+#endif
+ ZQ6 = 3.0*(ZQL0 - PSRC)
+ ZQR = ZQL0 - ZQ6
+ ZQL = ZQL0
+#ifndef MNH_BITREP
+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
+!!!
+!!! initialize final parabolae parameters
+!!!
+!!ZQL = ZQL0
+!!ZQR = ZQR0
+!!ZQ6 = ZQ60
+!!!
+!!! eliminate over and undershoots and create qL and qR as in Lin96
+!!!
+!!!PW: BUG: done like that because if using PGI (tested up to 16.10)
+!!! will cause crashes at run (address not mapped)
+!!! and problems at compilation
+!!$WHERE ( ZDMQ == 0.0 )
+!!$ ZQL = PSRC
+!!$ ZQR = PSRC
+!!$ ZQ6 = 0.0
+!!$END WHERE
+!!#ifndef MNH_BITREP
+!!$WHERE ( ( ZDMQ /= 0.0 ) .AND. ( ZQ60*ZDQ < -ZDQ**2 ) )
+!!#else
+!!$WHERE ( ( ZDMQ /= 0.0 ) .AND. ( ZQ60*ZDQ < -BR_P2(ZDQ) ) )
+!!#endif
+!!$WHERE ( ( ZDMQ /= 0.0 ) .AND. ( ZQ60*ZDQ < -BR_P2(ZDQ) ) )
+!!$ ZQ6 = 3.0*(ZQL0 - PSRC)
+!!$ ZQR = ZQL0 - ZQ6
+!!$ ZQL = ZQL0
+!!$END WHERE
+!!#ifndef MNH_BITREP
+!!$WHERE ( ( ZDMQ /= 0.0 ) .AND. ( ZQ60*ZDQ > ZDQ**2 ) )
+!!#else
+!!$WHERE ( ( ZDMQ /= 0.0 ) .AND. ( ZQ60*ZDQ > BR_P2(ZDQ) ) )
+!!#endif
+!!$WHERE ( ( ZDMQ /= 0.0 ) .AND. ( ZQ60*ZDQ > BR_P2(ZDQ) ) )
+!!$ ZQ6 = 3.0*(ZQR0 - PSRC)
+!!$ ZQL = ZQR0 - ZQ6
+!!$ ZQR = ZQR0
+!!$END WHERE
+!!!
+!!! recalculate coefficients of the parabolae
+!!!
+!!ZDQ = ZQR - ZQL
+!$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(1,1,1,ZQR,PR)
+#endif
+!
+#ifndef MNH_OPENACC
+!Unnecessary CALL GET_HALO(PR)
+#else
+!Unnecessary CALL GET_HALO_D(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
+!
+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
+!
+REAL, DIMENSION(:,:) :: ZPSRC_HALO2_WEST
+#endif
+
+TYPE(HALO2LIST_ll), SAVE , POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
+LOGICAL, SAVE :: GFIRST_CALL_PPM_S0_X = .TRUE.
+!
+REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZWEST
+
+!-------------------------------------------------------------------------------
+
+!$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()
+#endif
+!
+!BEG JUAN PPM_LL
+!
+!* initialise & update halo & halo2 for PSRC
+!
+!!$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)
+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(:,:)
+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
+!-------------------------------------------------------------------------------
+!!$CALL DEL_HALO2_ll(TZ_PSRC_HALO2_ll)
+
+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
+!
+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
+!
+TYPE(HALO2LIST_ll), SAVE ,POINTER :: TZ_PSRC_HALO2_ll ! halo2 for PSRC
+LOGICAL, SAVE :: GFIRST_CALL_PPM_S0_Y = .TRUE.
+
+TYPE(HALO2LIST_ll), POINTER :: TZ_PHAT_HALO2_ll ! halo2 for ZPHAT
+!
+REAL, DIMENSION(:,:,:) :: ZRHO_MYM , ZCR_MYM , ZCR_DYF
+!
+INTEGER :: I,J,K
+!
+REAL, DIMENSION(:,:) :: ZPSRC_HALO2_SOUTH
+#endif
+!
+REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZSOUTH
+!
+!-------------------------------------------------------------------------------
+
+!$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()
+#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
+ !
+!!$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)
+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(:,:)
+!
+! Initialize with relalistic value all work array
+!
+!$acc kernels
+ZPSRC_HALO2_SOUTH(:,:) = ZSOUTH(:,:)
+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
+!
+!!$CALL DEL_HALO2_ll(TZ_PSRC_HALO2_ll)
+!
+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(1,1,1,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
diff --git a/src/ZSOLVER/pressurez.f90 b/src/ZSOLVER/pressurez.f90
index a637645ae4e9cd3df13f6ec93fbff5a551d4338b..b7221fa4acb1ab350c0658a531032e553d8f22b5 100644
--- a/src/ZSOLVER/pressurez.f90
+++ b/src/ZSOLVER/pressurez.f90
@@ -366,8 +366,9 @@ REAL, OPTIONAL :: PRESIDUAL
!
! Metric coefficients:
!
-REAL, DIMENSION(SIZE(PPABST,1),SIZE(PPABST,2),SIZE(PPABST,3)) :: ZDV_SOURCE
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZDV_SOURCE
! ! divergence of the sources
+INTEGER :: IZDV_SOURCE
!
INTEGER :: IIB ! indice I for the first inner mass point along x
INTEGER :: IIE ! indice I for the last inner mass point along x
@@ -378,11 +379,12 @@ INTEGER :: IKE ! indice K for the last inner mass point along z
INTEGER :: ILUOUT ! Logical unit of output listing
INTEGER :: IRESP ! Return code of FM routines
!
-REAL, DIMENSION(SIZE(PPABST,1),SIZE(PPABST,2),SIZE(PPABST,3)) :: ZTHETAV, &
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZTHETAV, &
! virtual potential temperature
- ZPHIT
+ ZPHIT
! MAE + DUR => Exner function perturbation
! LHE => Exner function perturbation * CPD * THVREF
+INTEGER :: IZTHETAV,IZPHIT
!
REAL :: ZRV_OV_RD ! XRV / XRD
REAL :: ZMAXVAL, ZMAXRES, ZMAX,ZMAX_ll ! for print
@@ -392,10 +394,10 @@ INTEGER :: IIU,IJU,IKU ! array sizes in I,J,K
INTEGER :: JK ! loop index on the vertical levels
INTEGER :: JI,JJ
!
-REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,3)) :: ZPABS_S ! local pressure on southern side
-REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,3)) :: ZPABS_N ! local pressure on northern side
-REAL, DIMENSION(SIZE(PDYY,2),SIZE(PDXX,3)) :: ZPABS_E ! local pressure on eastern side
-REAL, DIMENSION(SIZE(PDYY,2),SIZE(PDXX,3)) :: ZPABS_W ! local pressure on western side
+REAL, SAVE , ALLOCATABLE , DIMENSION(:,:) :: ZPABS_S ! local pressure on southern side
+REAL, SAVE , ALLOCATABLE , DIMENSION(:,:) :: ZPABS_N ! local pressure on northern side
+REAL, SAVE , ALLOCATABLE , DIMENSION(:,:) :: ZPABS_E ! local pressure on eastern side
+REAL, SAVE , ALLOCATABLE , DIMENSION(:,:) :: ZPABS_W ! local pressure on western side
INTEGER :: IINFO_ll,KINFO
TYPE(LIST_ll), POINTER :: TZFIELDS_ll, TZFIELDS2_ll ! list of fields to exchange
!
@@ -411,6 +413,8 @@ INTEGER :: IZMYM_PRHODJ
LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
LOGICAL :: GSOUTH2D,GNORTH2D,GPRVREF0
!
+LOGICAL, SAVE :: GFIRST_CALL_PRESSUREZ = .TRUE.
+!
!------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
@@ -442,12 +446,20 @@ GNORTH2D = ( L2D .AND. LNORTH_ll() )
!
GPRVREF0 = ( SIZE(PRVREF,1) == 0 )
!
+IZDV_SOURCE = MNH_ALLOCATE_ZT3D(ZDV_SOURCE ,IIU,IJU,IKU )
+IZTHETAV = MNH_ALLOCATE_ZT3D(ZTHETAV ,IIU,IJU,IKU )
+IZPHIT = MNH_ALLOCATE_ZT3D(ZPHIT ,IIU,IJU,IKU )
+!
IZPRHODJ = MNH_ALLOCATE_ZT3D( ZPRHODJ,IIU,IJU,IKU )
IZMXM_PRHODJ = MNH_ALLOCATE_ZT3D( ZMXM_PRHODJ,IIU,IJU,IKU )
IZMZM_PRHODJ = MNH_ALLOCATE_ZT3D( ZMZM_PRHODJ,IIU,IJU,IKU )
IZGZ_M_W = MNH_ALLOCATE_ZT3D( ZGZ_M_W,IIU,IJU,IKU )
IZMYM_PRHODJ = MNH_ALLOCATE_ZT3D( ZMYM_PRHODJ,IIU,IJU,IKU )
!
+IF (GFIRST_CALL_PRESSUREZ) THEN
+ GFIRST_CALL_PRESSUREZ = .FALSE.
+ ALLOCATE ( ZPABS_S(IIU,IKU),ZPABS_N(IIU,IKU),ZPABS_E(IJU,IKU),ZPABS_W(IJU,IKU))
+END IF
!$acc kernels
ZPABS_S(:,:) = 0.
ZPABS_N(:,:) = 0.
@@ -532,6 +544,7 @@ IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
! compute the ratio : 1 + total water mass / dry air mass
ZRV_OV_RD = XRV / XRD
ZTHETAV(:,:,:) = 1. + PRT(:,:,:,1)
+ !$acc loop seq
DO JWATER = 2 , 1+KRRL+KRRI
ZTHETAV(:,:,:) = ZTHETAV(:,:,:) + PRT(:,:,:,JWATER)
END DO
@@ -548,7 +561,9 @@ IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
ZPHIT(:,:,:)=(PPABST(:,:,:)/XP00)**(XRD/XCPD)-PEXNREF(:,:,:)
#else
!$acc kernels
- ZPHIT(:,:,:)=BR_POW((PPABST(:,:,:)/XP00),(XRD/XCPD))-PEXNREF(:,:,:)
+ DO CONCURRENT ( JI=1:IIU,JJ=1:IJU,JK=1:IKU )
+ ZPHIT(JI,JJ,JK)=BR_POW((PPABST(JI,JJ,JK)/XP00),(XRD/XCPD))-PEXNREF(JI,JJ,JK)
+ END DO
!$acc end kernels
#endif
!
@@ -654,32 +669,33 @@ CALL GX_M_U_DEVICE(1,IKU,1,ZPHIT,PDXX,PDZZ,PDZX,ZDV_SOURCE)
IF ( GWEST ) THEN
!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
- !$acc kernels
- DO JK=2,IKU-1
- ZDV_SOURCE(IIB,:,JK)= &
- (ZPHIT(IIB,:,JK) - ZPHIT(IIB-1,:,JK) - 0.5 * ( &
- PDZX(IIB,:,JK) * (ZPHIT(IIB,:,JK)-ZPHIT(IIB,:,JK-1)) / PDZZ(IIB,:,JK) &
- +PDZX(IIB,:,JK+1) * (ZPHIT(IIB,:,JK+1)-ZPHIT(IIB,:,JK)) / PDZZ(IIB,:,JK+1) &
+ !$acc kernels loop independent collapse(2) async
+ DO CONCURRENT (JJ=1:IJU , JK=2:IKU-1)
+ ZDV_SOURCE(IIB,JJ,JK)= &
+ (ZPHIT(IIB,JJ,JK) - ZPHIT(IIB-1,JJ,JK) - 0.5 * ( &
+ PDZX(IIB,JJ,JK) * (ZPHIT(IIB,JJ,JK)-ZPHIT(IIB,JJ,JK-1)) / PDZZ(IIB,JJ,JK) &
+ +PDZX(IIB,JJ,JK+1) * (ZPHIT(IIB,JJ,JK+1)-ZPHIT(IIB,JJ,JK)) / PDZZ(IIB,JJ,JK+1) &
) &
- ) / PDXX(IIB,:,JK)
+ ) / PDXX(IIB,JJ,JK)
END DO
!$acc end kernels
ENDIF
!
IF( GEAST ) THEN
- !$acc kernels
- DO JK=2,IKU-1
- ZDV_SOURCE(IIE+1,:,JK)= &
- (ZPHIT(IIE+1,:,JK) - ZPHIT(IIE+1-1,:,JK) - 0.5 * ( &
- PDZX(IIE+1,:,JK) * (ZPHIT(IIE+1-1,:,JK)-ZPHIT(IIE+1-1,:,JK-1)) &
- / PDZZ(IIE+1-1,:,JK) &
- +PDZX(IIE+1,:,JK+1) * (ZPHIT(IIE+1-1,:,JK+1)-ZPHIT(IIE+1-1,:,JK)) &
- / PDZZ(IIE+1-1,:,JK+1) &
+ !$acc kernels loop independent collapse(2) async
+ DO CONCURRENT (JJ=1:IJU , JK=2:IKU-1)
+ ZDV_SOURCE(IIE+1,JJ,JK)= &
+ (ZPHIT(IIE+1,JJ,JK) - ZPHIT(IIE+1-1,JJ,JK) - 0.5 * ( &
+ PDZX(IIE+1,JJ,JK) * (ZPHIT(IIE+1-1,JJ,JK)-ZPHIT(IIE+1-1,JJ,JK-1)) &
+ / PDZZ(IIE+1-1,JJ,JK) &
+ +PDZX(IIE+1,JJ,JK+1) * (ZPHIT(IIE+1-1,JJ,JK+1)-ZPHIT(IIE+1-1,JJ,JK)) &
+ / PDZZ(IIE+1-1,JJ,JK+1) &
) &
- ) / PDXX(IIE+1,:,JK)
+ ) / PDXX(IIE+1,JJ,JK)
END DO
!$acc end kernels
END IF
+!$acc wait
!
CALL MPPDB_CHECK3DM("before MXM PRESSUREZ :PRU/V/WS",PRECISION,PRUS,PRVS,PRWS)
IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
@@ -711,31 +727,31 @@ IF(.NOT. L2D) THEN
IF ( GSOUTH ) THEN
!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
- !$acc kernels async
- DO JK=2,IKU-1
- ZDV_SOURCE(:,IJB,JK)= &
- (ZPHIT(:,IJB,JK) - ZPHIT(:,IJB-1,JK) - 0.5 * ( &
- PDZY(:,IJB,JK) * (ZPHIT(:,IJB,JK)-ZPHIT(:,IJB,JK-1)) / PDZZ(:,IJB,JK) &
- +PDZY(:,IJB,JK+1) * (ZPHIT(:,IJB,JK+1)-ZPHIT(:,IJB,JK)) / PDZZ(:,IJB,JK+1) &
- ) &
- ) / PDYY(:,IJB,JK)
- END DO
- !$acc end kernels
- END IF
- !
- IF ( GNORTH ) THEN
- !$acc kernels async
- DO JK=2,IKU-1
- ZDV_SOURCE(:,IJE+1,JK)= &
- (ZPHIT(:,IJE+1,JK) - ZPHIT(:,IJE+1-1,JK) - 0.5 * ( &
- PDZY(:,IJE+1,JK) * (ZPHIT(:,IJE+1-1,JK)-ZPHIT(:,IJE+1-1,JK-1)) &
- / PDZZ(:,IJE+1-1,JK) &
- +PDZY(:,IJE+1,JK+1) * (ZPHIT(:,IJE+1-1,JK+1)-ZPHIT(:,IJE+1-1,JK)) &
- / PDZZ(:,IJE+1-1,JK+1) &
- ) &
- ) / PDYY(:,IJE+1,JK)
- END DO
- !$acc end kernels
+ !$acc kernels loop independent collapse(2) async
+ DO CONCURRENT (JI=1:IIU , JK=2:IKU-1)
+ ZDV_SOURCE(JI,IJB,JK)= &
+ (ZPHIT(JI,IJB,JK) - ZPHIT(JI,IJB-1,JK) - 0.5 * ( &
+ PDZY(JI,IJB,JK) * (ZPHIT(JI,IJB,JK)-ZPHIT(JI,IJB,JK-1)) / PDZZ(JI,IJB,JK) &
+ +PDZY(JI,IJB,JK+1) * (ZPHIT(JI,IJB,JK+1)-ZPHIT(JI,IJB,JK)) / PDZZ(JI,IJB,JK+1) &
+ ) &
+ ) / PDYY(JI,IJB,JK)
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF ( GNORTH ) THEN
+ !$acc kernels loop independent collapse(2) async
+ DO CONCURRENT (JI=1:IIU , JK=2:IKU-1)
+ ZDV_SOURCE(JI,IJE+1,JK)= &
+ (ZPHIT(JI,IJE+1,JK) - ZPHIT(JI,IJE+1-1,JK) - 0.5 * ( &
+ PDZY(JI,IJE+1,JK) * (ZPHIT(JI,IJE+1-1,JK)-ZPHIT(JI,IJE+1-1,JK-1)) &
+ / PDZZ(JI,IJE+1-1,JK) &
+ +PDZY(JI,IJE+1,JK+1) * (ZPHIT(JI,IJE+1-1,JK+1)-ZPHIT(JI,IJE+1-1,JK)) &
+ / PDZZ(JI,IJE+1-1,JK+1) &
+ ) &
+ ) / PDYY(JI,IJE+1,JK)
+ END DO
+ !$acc end kernels
END IF
!$acc wait
!
@@ -922,6 +938,7 @@ END IF
!
#ifdef MNH_OPENACC
CALL MNH_REL_ZT3D ( IZPRHODJ,IZMXM_PRHODJ,IZMZM_PRHODJ,IZGZ_M_W,IZMYM_PRHODJ )
+CALL MNH_REL_ZT3D ( IZDV_SOURCE,IZTHETAV,IZPHIT)
#endif
!-------------------------------------------------------------------------------
!
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
index 794ac3a6f7c58f7c1bfdfb1baf02ed5b37386273..d95cde8d430bd5d5e0b35646118f3fd73e3cf1e3 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
@@ -547,12 +547,14 @@ contains
end if
if (LUseT) then
local_sumt = 0.0_rl
+ za_st => a%st
+ zb_st => b%st
!$acc kernels loop collapse(3)
do iz=0,nz+1
do iy=a%icompy_min,a%icompy_max
do ix=a%icompx_min,a%icompx_max
local_sumt = local_sumt &
- + a%st(ix,iy,iz)*b%st(ix,iy,iz)
+ + za_st(ix,iy,iz)*zb_st(ix,iy,iz)
end do
end do
end do
@@ -1056,6 +1058,10 @@ contains
real , pointer , contiguous , dimension(:,:,:) :: ztab_halo_nt_haloTout,ztab_halo_st_haloTout
real , pointer , contiguous , dimension(:,:,:) :: ztab_halo_wt_haloTout,ztab_halo_et_haloTout
+ INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+ LOGICAL :: Gneighbour_s,Gneighbour_n,Gneighbour_e,Gneighbour_w
+
halo_size = comm_param%halo_size
! Do nothing if we are only using one processor
@@ -1092,35 +1098,48 @@ contains
!
zst => a%st
!
+ Gneighbour_s = (neighbour_s_rank >= 0)
+ Gneighbour_n = (neighbour_n_rank >= 0)
+ Gneighbour_e = (neighbour_e_rank >= 0)
+ Gneighbour_w = (neighbour_w_rank >= 0)
+ !
#ifdef MNH_GPUDIRECT
if (LUseT) then
!
! Copy send buffer async to GPU
!
! Send to south
+ if (Gneighbour_s) then
ztab_halo_st_haloTin => tab_halo_st(level,m)%haloTin
- !$acc parallel loop collapse(3) async(1)
+ !$acc parallel loop collapse(3) async(IS_SOUTH)
do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
ztab_halo_st_haloTin(ii,ij,ik) = zst(ii,ij+a_n-halo_size,ik-1)
end do
+ end if
! Send to north
+ if (Gneighbour_n) then
ztab_halo_nt_haloTin => tab_halo_nt(level,m)%haloTin
- !$acc parallel loop collapse(3) async(1)
+ !$acc parallel loop collapse(3) async(IS_NORTH)
do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
ztab_halo_nt_haloTin(ii,ij,ik) = zst(ii,ij,ik-1)
end do
+ end if
! Send to east
+ if (Gneighbour_e) then
ztab_halo_et_haloTin => tab_halo_et(level,m)%haloTin
- !$acc parallel loop collapse(3) async(1)
+ !$acc parallel loop collapse(3) async(IS_EAST)
do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
ztab_halo_et_haloTin(ii,ij,ik) = zst(ii+a_n-halo_size,ij-halo_size,ik-1)
end do
+ end if
! Send to west
+ if (Gneighbour_w) then
ztab_halo_wt_haloTin => tab_halo_wt(level,m)%haloTin
- !$acc parallel loop collapse(3) async(1)
+ !$acc parallel loop collapse(3) async(IS_WEST)
do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
ztab_halo_wt_haloTin(ii,ij,ik) = zst(ii,ij-halo_size,ik-1)
- end do
+ end do
+ end if
end if
#endif
! Receive from north
@@ -1131,12 +1150,15 @@ contains
recvtag = 1012
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_n) then
ztab_halo_nt_haloTout => tab_halo_nt(level,m)%haloTout
!$acc host_data use_device(ztab_halo_nt_haloTout)
call mpi_irecv(ztab_halo_nt_haloTout,size(ztab_halo_nt_haloTout), &
MPI_DOUBLE_PRECISION,neighbour_n_rank,recvtag, &
MPI_COMM_HORIZ, requests_nsT(1), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_irecv(ztab_halo_nt_haloTout,neighbour_n_rank=",neighbour_n_rank
#else
call mpi_irecv(a%st(1,0-(halo_size-1),0),1, &
halo_nst(level,m),neighbour_n_rank,recvtag, &
@@ -1151,12 +1173,15 @@ contains
recvtag = 1013
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_s) then
ztab_halo_st_haloTout => tab_halo_st(level,m)%haloTout
!$acc host_data use_device (ztab_halo_st_haloTout)
call mpi_irecv(ztab_halo_st_haloTout,size(ztab_halo_st_haloTout), &
MPI_DOUBLE_PRECISION,neighbour_s_rank,recvtag, &
MPI_COMM_HORIZ, requests_nsT(2), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_irecv(ztab_halo_st_haloTout,neighbour_s_rank=",neighbour_s_rank
#else
call mpi_irecv(a%st(1,a_n+1,0),1, &
halo_nst(level,m),neighbour_s_rank,recvtag, &
@@ -1166,7 +1191,7 @@ contains
#ifdef MNH_GPUDIRECT
if (LUseT) then
! wait for async copy of send buffer to GPU
- !$acc wait(1)
+ call acc_wait_haloswap_mnh()
end if
#endif
! Send to south
@@ -1177,11 +1202,14 @@ contains
sendtag = 1012
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_s) then
!$acc host_data use_device(ztab_halo_st_haloTin)
call mpi_isend(ztab_halo_st_haloTin,size(ztab_halo_st_haloTin), &
MPI_DOUBLE_PRECISION,neighbour_s_rank,sendtag, &
MPI_COMM_HORIZ, requests_nsT(3), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_isend(ztab_halo_st_haloTin,neighbour_s_rank=",neighbour_s_rank
#else
call mpi_isend(a%st(1,a_n-(halo_size-1),0),1, &
halo_nst(level,m),neighbour_s_rank,sendtag, &
@@ -1196,11 +1224,14 @@ contains
sendtag = 1013
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_n) then
!$acc host_data use_device(ztab_halo_nt_haloTin)
call mpi_isend(ztab_halo_nt_haloTin,size(ztab_halo_nt_haloTin), &
MPI_DOUBLE_PRECISION,neighbour_n_rank,sendtag, &
MPI_COMM_HORIZ, requests_nsT(4), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_isend(ztab_halo_nt_haloTin,neighbour_n_rank=",neighbour_n_rank
#else
call mpi_isend(a%st(1,1,0),1, &
halo_nst(level,m),neighbour_n_rank,sendtag, &
@@ -1220,12 +1251,15 @@ contains
recvtag = 1010
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_w) then
ztab_halo_wt_haloTout => tab_halo_wt(level,m)%haloTout
!$acc host_data use_device(ztab_halo_wt_haloTout)
call mpi_irecv(ztab_halo_wt_haloTout,size(ztab_halo_wt_haloTout), &
MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
MPI_COMM_HORIZ, requests_ewT(1), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_irecv(ztab_halo_wt_haloTout,neighbour_w_rank=",neighbour_w_rank
#else
call mpi_irecv(a%st(0-(halo_size-1),0,0),1, &
halo_wet(level,m),neighbour_w_rank,recvtag, &
@@ -1240,12 +1274,15 @@ contains
sendtag = 1011
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_e) then
ztab_halo_et_haloTout => tab_halo_et(level,m)%haloTout
!$acc host_data use_device(ztab_halo_et_haloTout)
call mpi_irecv(ztab_halo_et_haloTout,size(ztab_halo_et_haloTout), &
MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
MPI_COMM_HORIZ, requests_ewT(2), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_irecv(ztab_halo_et_haloTout,neighbour_e_rank=",neighbour_e_rank
#else
call mpi_irecv(a%st(a_n+1,0,0),1, &
halo_wet(level,m),neighbour_e_rank,recvtag, &
@@ -1261,11 +1298,14 @@ contains
sendtag = 1010
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_e) then
!$acc host_data use_device(ztab_halo_et_haloTin)
call mpi_isend(ztab_halo_et_haloTin,size(ztab_halo_et_haloTin), &
MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
MPI_COMM_HORIZ, requests_ewT(3), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_isend(ztab_halo_et_haloTin,neighbour_e_rank=",neighbour_e_rank
#else
call mpi_isend(a%st(a_n-(halo_size-1),0,0),1, &
halo_wet(level,m),neighbour_e_rank,sendtag, &
@@ -1280,11 +1320,14 @@ contains
recvtag = 1011
if (LUseT) then
#ifdef MNH_GPUDIRECT
+ if (Gneighbour_w) then
!$acc host_data use_device(ztab_halo_wt_haloTin)
call mpi_isend(ztab_halo_wt_haloTin,size(ztab_halo_wt_haloTin), &
MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
MPI_COMM_HORIZ, requests_ewT(4), ierr)
!$acc end host_data
+ end if
+ !print*,"mpi_isend(ztab_halo_wt_haloTin,neighbour_w_rank=",neighbour_w_rank
#else
call mpi_isend(a%st(1,0,0),1, &
halo_wet(level,m),neighbour_w_rank,sendtag, &
@@ -1301,27 +1344,36 @@ contains
if (LUseT) call mpi_waitall(4,requests_ewT, MPI_STATUSES_IGNORE, ierr)
#ifdef MNH_GPUDIRECT
if (LUseT) then
+ if (Gneighbour_n) then
! copy north halo for GPU managed
- !$acc parallel loop collapse(3) async(3)
+ !$acc parallel loop collapse(3) async(IS_NORTH)
do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
zst(ii,ij-halo_size,ik-1) = ztab_halo_nt_haloTout(ii,ij,ik)
end do
+ end if
+ if (Gneighbour_s) then
! copy south halo for GPU managed
- !$acc parallel loop collapse(3) async(3)
+ !$acc parallel loop collapse(3) async(IS_SOUTH)
do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
zst(ii,ij+a_n,ik-1) = ztab_halo_st_haloTout(ii,ij,ik)
end do
+ end if
+ if (Gneighbour_w) then
! copy west halo for GPU managed
- !$acc parallel loop collapse(3) async(3)
+ !$acc parallel loop collapse(3) async(IS_WEST)
do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
zst(ii-halo_size,ij-halo_size,ik-1) = ztab_halo_wt_haloTout(ii,ij,ik)
end do
+ end if
+ if (Gneighbour_e) then
! copy east halo for GPU managed
- !$acc parallel loop collapse(3) async(3)
+ !$acc parallel loop collapse(3) async(IS_EAST)
do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
zst(ii+a_n,ij-halo_size,ik-1) = ztab_halo_et_haloTout(ii,ij,ik)
end do
- !$acc wait(3)
+ end if
+ ! wait for async copy of send buffer to GPU
+ call acc_wait_haloswap_mnh()
end if
#endif
end if! (stepsize == 1) ...
@@ -1330,6 +1382,22 @@ contains
end if
end if
+ contains
+ subroutine acc_wait_haloswap_mnh()
+ if (Gneighbour_s) then
+ !$acc wait(IS_SOUTH)
+ endif
+ if (Gneighbour_n) then
+ !$acc wait(IS_NORTH)
+ endif
+ if (Gneighbour_e) then
+ !$acc wait(IS_EAST)
+ endif
+ if (Gneighbour_w) then
+ !$acc wait(IS_WEST)
+ endif
+ end subroutine acc_wait_haloswap_mnh
+
end subroutine haloswap_mnh
!==================================================================
subroutine haloswap(level,m, & ! multigrid- and processor- level
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
index 30277d8625ad6735444ad7335b761ab6ed369b7a..34eacb6b86a7cf47e41a6b14a08ea2685e8c7206 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
@@ -206,10 +206,13 @@ contains
allocate(Ap%st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1) )
+ !$acc enter data create (r%st,z%st,p%st,Ap%st)
+ !$acc kernels
r%st = 0.0_rl
z%st = 0.0_rl
p%st = 0.0_rl
Ap%st = 0.0_rl
+ !$acc end kernels
endif
@@ -307,6 +310,7 @@ contains
end if
if (LUseT) then
+ !$acc exit data delete(r%st,z%st,p%st,Ap%st)
deallocate(r%st)
deallocate(z%st)
deallocate(p%st)
@@ -419,10 +423,13 @@ contains
allocate(Ap%st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1) )
+ !$acc enter data create (r%st,z%st,p%st,Ap%st)
+ !$acc kernels
r%st = 0.0_rl
z%st = 0.0_rl
p%st = 0.0_rl
Ap%st = 0.0_rl
+ !$acc end kernels
end if
! Initialise
@@ -518,6 +525,7 @@ contains
deallocate(Ap%s)
end if
if (LUseT) then
+ !$acc exit data delete(r%st,z%st,p%st,Ap%st)
deallocate(r%st)
deallocate(z%st)
deallocate(p%st)
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
index d0ddee6daae5fa031349db044389cb510c92b144..e4c2a370395eca6f76468299e4b9d01213ab4862 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
@@ -195,6 +195,7 @@ private
allocate(zphi_st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:grid_param%nz+1))
+ !$acc enter data create (zphi_st)
phi%st => zphi_st
!$acc kernels
zphi_st(:,:,:) = 0.0_rl
@@ -211,7 +212,10 @@ private
type(scalar3d), intent(inout) :: phi
if (LUseO) deallocate(phi%s)
- if (LUseT) deallocate(phi%st)
+ if (LUseT) then
+ !$acc exit data delete(phi%st)
+ deallocate(phi%st)
+ end if
end subroutine destroy_scalar3d
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
index 48d5dcdce4f328566fd6e968cd8ba21311c5dd30..a8363fa2fe153344ab182da8f86ed4a0d587ddfd 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
@@ -10,7 +10,15 @@ subroutine dcopy(n,sx,incx,sy,incy)
integer i,incx,incy,ix,iy,m,mp1,n
!
if(n.le.0)return
- if(incx.eq.1.and.incy.eq.1)go to 20
+!!$ if(incx.eq.1.and.incy.eq.1)go to 20
+ !
+ ! Juan Simplifaction for incx=1 & incy=1
+ !
+ if(incx.ne.1.or.incy.ne.1) STOP "DCOPY incx.ne.1.or.incy.ne.1 "
+ !$acc kernels
+ sy(1:n) = sx(1:n)
+ !$acc end kernels
+ return
!
! code for unequal increments or equal increments
! not equal to 1
@@ -84,7 +92,11 @@ SUBROUTINE DAXPY( N, SA, SX, INCX, SY, INCY )
SY(I) = SY(I) + SA * SX(I)
10 CONTINUE
- ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
+ ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
+ !$acc kernels
+ SY(1:N) = SY(1:N) + SA * SX(1:N)
+ !$acc end kernels
+ return
! ** EQUAL, UNIT INCREMENTS
M = MOD(N,4)
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
index 70d9063b2494dce63cf65cb43ce68cd9a379199b..1bd6d51d85bcd52b6a93103136e06caf8881a182 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
@@ -204,6 +204,7 @@ contains
allocate(vert_coeff%c(grid_param%nz))
allocate(vert_coeff%d(grid_param%nz))
call construct_vertical_coeff_mnh(PA_K,PB_K,PC_K,PD_K)
+ !$acc enter data copyin(vert_coeff%a,vert_coeff%b,vert_coeff%c,vert_coeff%d)
end subroutine discretisation_initialise_mnh
subroutine discretisation_initialise(grid_param_in, &
@@ -817,6 +818,7 @@ end subroutine construct_vertical_coeff
allocate(r%st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1))
+ !$acc enter data create (r%st)
end if
call calculate_residual(level,m,b,u,r)
@@ -843,7 +845,10 @@ end subroutine construct_vertical_coeff
+ (log_res_final - log_res_initial)
nsmooth_total(level) = nsmooth_total(level) + nsmooth
if (LUseO) deallocate(r%s)
- if (LUseT) deallocate(r%st)
+ if (LUseT) then
+ !$acc exit data delete(r%st)
+ deallocate(r%st)
+ end if
#endif
end subroutine smooth_mnh
!==================================================================
@@ -888,6 +893,7 @@ end subroutine construct_vertical_coeff
allocate(r%st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1) )
+ !$acc enter data create (r%st)
endif
log_res_initial = log(l2norm(r))
#endif
@@ -912,7 +918,10 @@ end subroutine construct_vertical_coeff
+ (log_res_final - log_res_initial)
nsmooth_total(level) = nsmooth_total(level) + nsmooth
if (LUseO) deallocate(r%s)
- if (LUseT) deallocate(r%st)
+ if (LUseT) then
+ !$acc exit data delete(r%st)
+ deallocate(r%st)
+ end if
#endif
end subroutine smooth
!==================================================================
@@ -1882,8 +1891,8 @@ end subroutine line_Jacobi_mnh
!local
!real(kind=rl), dimension(5) :: alpha_T
- real(kind=rl) :: Tij
- real(kind=rl) :: alpha_div_Tij ! b_k_tmp, c_k_tmp
+ real(kind=rl) ,pointer :: Tij
+ real(kind=rl) ,pointer :: alpha_div_Tij ! b_k_tmp, c_k_tmp
integer :: iz, nz
real, dimension(:,:,:) , pointer, contiguous :: zSr_st , zb_st , zSu_in_st , zSu_out_st
@@ -1898,20 +1907,17 @@ end subroutine line_Jacobi_mnh
type Temp_tridiag_mnh
real, dimension(:), pointer, contiguous :: tmp_k,c_k
+ real, pointer :: Tij , alpha_div_Tij
end type Temp_tridiag_mnh
type(Temp_tridiag_mnh) , save , dimension(max_lev) :: Ttridiag_mnh
if (LUseT ) then
+
+ ! Calculate r_i = b_i - A_{ij} u_i
- nz = b%grid_param%nz
-
- !call construct_alpha_T_cst_mnh(b%grid_param,alpha_T,Tij)
- Tij = ( b%grid_param%L/b%grid_param%n ) ** 2
- alpha_div_Tij = 4.0_rl / Tij
- !print*,"level=",level," Tij=",Tij," alpha_div_Tij=",alpha_div_Tij
- ! Calculate r_i = b_i - A_{ij} u_i
-
+ nz = b%grid_param%nz
+
zSr_st => Sr%st
zb_st => b%st
zSu_in_st => Su_in%st
@@ -1923,6 +1929,18 @@ end subroutine line_Jacobi_mnh
if ( Lfirst_call_level_tridiag_mnhallT(level) ) then
Lfirst_call_level_tridiag_mnhallT(level) = .false.
+
+ allocate(Ttridiag_mnh(level)%Tij)
+ allocate(Ttridiag_mnh(level)%alpha_div_Tij)
+
+ Tij=>Ttridiag_mnh(level)%Tij
+ alpha_div_Tij=>Ttridiag_mnh(level)%alpha_div_Tij
+ !call construct_alpha_T_cst_mnh(b%grid_param,alpha_T,Tij)
+ Tij = ( b%grid_param%L/b%grid_param%n ) ** 2
+ alpha_div_Tij = 4.0_rl / Tij
+ !$acc enter data copyin(Tij,alpha_div_Tij)
+ !print*,"level=",level," Tij=",Tij," alpha_div_Tij=",alpha_div_Tij
+
allocate(Ttridiag_mnh(level)%tmp_k(size(zb_k)))
allocate(Ttridiag_mnh(level)%c_k(size(zb_k)))
@@ -1948,6 +1966,9 @@ end subroutine line_Jacobi_mnh
!$acc enter data copyin(tmp_k,c_k)
endif
+
+ Tij=>Ttridiag_mnh(level)%Tij
+ alpha_div_Tij=>Ttridiag_mnh(level)%alpha_div_Tij
tmp_k => Ttridiag_mnh(level)%tmp_k
c_k => Ttridiag_mnh(level)%c_k
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
index bb1a7d3f7ea79fe25eba3090a39a93cf9d9415b9..b43fa68dd42e6783c41cae69e3396b0f145fdbb7 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
@@ -275,18 +275,20 @@ contains
allocate(zxu_mg_st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1))
+ !$acc enter data create (zxu_mg_st)
xu_mg(level,m)%st => zxu_mg_st
allocate(zxb_mg_st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1))
+ !$acc enter data create (zxb_mg_st)
xb_mg(level,m)%st => zxb_mg_st
allocate(zxr_mg_st(1-halo_size:nlocal+halo_size, &
1-halo_size:nlocal+halo_size, &
0:nz+1))
- xr_mg(level,m)%st => zxr_mg_st
-
+ !$acc enter data create (zxr_mg_st)
+ xr_mg(level,m)%st => zxr_mg_st
!$acc kernels
zxu_mg_st(:,:,:) = 0.0_rl
@@ -429,9 +431,14 @@ contains
endif
if (LUseT) then
- deallocate(xu_mg(level,m)%st)
- deallocate(xb_mg(level,m)%st)
- deallocate(xr_mg(level,m)%st)
+ !$acc exit data delete(xu_mg(level,m)%st)
+ deallocate(xu_mg(level,m)%st)
+ !
+ !$acc exit data delete(xb_mg(level,m)%st)
+ deallocate(xb_mg(level,m)%st)
+ !
+ !$acc exit data delete(xr_mg(level,m)%st)
+ deallocate(xr_mg(level,m)%st)
endif
! If we are below L_split, split data
@@ -466,7 +473,7 @@ contains
type(scalar3d), intent(inout) :: phicoarse
! local var
integer :: ix,iy,iz
- integer :: ix_min, ix_max, iy_min, iy_max, n
+ integer :: ix_min, ix_max, iy_min, iy_max, n ,nz
real(kind=rl) :: xn,xs,xw,xe
real , dimension(:,:,:) , pointer , contiguous :: zphifine_st , zphicoarse_st
@@ -476,13 +483,14 @@ contains
ix_max = phicoarse%icompx_max
iy_min = phicoarse%icompy_min
iy_max = phicoarse%icompy_max
+ nz = phicoarse%grid_param%nz
! three dimensional cell average
if (mg_param%restriction == REST_CELLAVERAGE) then
! Do not coarsen in z-direction
if (LUseO) then
do ix=ix_min,ix_max
do iy=iy_min,iy_max
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
phicoarse%s(iz,iy,ix) = &
phifine%s(iz ,2*iy ,2*ix ) + &
phifine%s(iz ,2*iy-1,2*ix ) + &
@@ -496,7 +504,7 @@ contains
zphifine_st => phifine%st
zphicoarse_st => phicoarse%st
!$acc kernels loop independent collapse(3)
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
do iy=iy_min,iy_max
do ix=ix_min,ix_max
zphicoarse_st(ix,iy,iz) = &
@@ -522,7 +530,7 @@ contains
xn=1.0
if (iy==1) xs=0.0
if (iy==n) xn=0.0
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
phicoarse%s(iz,iy,ix) = 0.25_rl * ( &
phifine%s(iz,2*iy+1,2*ix-1) * xn + &
phifine%s(iz,2*iy+1,2*ix ) * xn + &
@@ -541,7 +549,7 @@ contains
end do
end if
if (LUseT) then
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
do iy=iy_min,iy_max
xs=1.0
xn=1.0
@@ -580,19 +588,21 @@ contains
type(scalar3d), intent(in) :: phifine
type(scalar3d), intent(inout) :: phicoarse
integer :: ix,iy,iz
- integer :: ix_min, ix_max, iy_min, iy_max
+ integer :: ix_min, ix_max, iy_min, iy_max , nz
ix_min = phicoarse%icompx_min
ix_max = phicoarse%icompx_max
iy_min = phicoarse%icompy_min
iy_max = phicoarse%icompy_max
+ nz = phicoarse%grid_param%nz
+
! three dimensional cell average
if (mg_param%restriction == REST_CELLAVERAGE) then
! Do not coarsen in z-direction
if (LUseO) then
do ix=ix_min,ix_max
do iy=iy_min,iy_max
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
phicoarse%s(iz,iy,ix) = &
phifine%s(iz ,2*iy ,2*ix ) + &
phifine%s(iz ,2*iy-1,2*ix ) + &
@@ -603,7 +613,7 @@ contains
end do
end if
if (LUseT) then
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
do iy=iy_min,iy_max
do ix=ix_min,ix_max
phicoarse%st(ix,iy,iz) = &
@@ -748,14 +758,16 @@ contains
subroutine loop_over_grid_constant_mnh(iblock)
implicit none
integer, intent(in) :: iblock
- integer :: ix,iy,iz
+ integer :: ix,iy,iz, nz
+
+ nz = phicoarse%grid_param%nz
if (LUseO) then
do ix=ixmin(iblock),ixmax(iblock)
do iy=iymin(iblock),iymax(iblock)
do dix = -1,0
do diy = -1,0
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
phifine%s(iz,2*iy+diy,2*ix+dix) = phicoarse%s(iz,iy,ix)
end do
end do
@@ -768,7 +780,7 @@ contains
do iy=iymin(iblock),iymax(iblock)
do dix = -1,0
do diy = -1,0
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
phifine%st(2*ix+dix,2*iy+diy,iz) = phicoarse%st(ix,iy,iz)
end do
end do
@@ -790,6 +802,10 @@ contains
real , dimension(:,:,:) , pointer , contiguous :: zphifine_st , zphicoarse_st
+ integer :: nz
+
+ nz = phicoarse%grid_param%nz
+
! optimisation for newman MNH case : all coef constant
rhox = 0.25_rl
rhoy = 0.25_rl
@@ -798,7 +814,7 @@ contains
do ix=ixmin(iblock),ixmax(iblock)
do iy=iymin(iblock),iymax(iblock)
! Piecewise linear interpolation
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
do dix = -1,0
do diy = -1,0
phifine%s(iz,2*iy+diy,2*ix+dix) = &
@@ -820,7 +836,7 @@ contains
zphicoarse_st => phicoarse%st
!$acc kernels loop independent collapse(5)
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
do diy = -1,0
do dix = -1,0
do iy=iymin(iblock),iymax(iblock)
@@ -974,7 +990,7 @@ contains
do iy=iymin(iblock),iymax(iblock)
do dix = -1,0
do diy = -1,0
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
phifine%s(iz,2*iy+diy,2*ix+dix) = phicoarse%s(iz,iy,ix)
end do
end do
@@ -994,7 +1010,7 @@ contains
do iy=iymin(iblock),iymax(iblock)
#ifdef PIECEWISELINEAR
! Piecewise linear interpolation
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
do dix = -1,0
do diy = -1,0
if ( (ix+(2*dix+1)+phicoarse%ix_min-1 < 1 ) .or. &
@@ -1098,7 +1114,7 @@ contains
end do
! invert A
call invertA(A)
- do iz=1,phicoarse%grid_param%nz
+ do iz=1,nz
! Calculate gradient on each level
dxu(1:2) = dx(1,1:2)*phicoarse%s(iz,iy ,ix-1) &
+ dx(2,1:2)*phicoarse%s(iz,iy ,ix+1) &
@@ -1491,6 +1507,7 @@ contains
real(kind=rl) :: alpha, beta, pq, rz, rz_old
integer :: ierr
real(kind=rl) , pointer , contiguous , dimension(:,:,:) :: z_one_st
+ integer :: icompx_max, icompy_max, nz
solvertype = solver_param%solvertype
resreduction = solver_param%resreduction
@@ -1517,22 +1534,27 @@ contains
!
! Init 1 vector = z_one
call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,z_one)
+ !
+ icompx_max = z_one%icompx_max
+ icompy_max = z_one%icompy_max
+ nz = z_one%grid_param%nz
+ !
if (LUseO) then
z_one%s(:,:,:) = 0.0_rl
- z_one%s(1:z_one%grid_param%nz,1:z_one%icompy_max,1:z_one%icompx_max) = 1.0_rl
+ z_one%s(1:nz,1:icompy_max,1:icompx_max) = 1.0_rl
end if
if (LUseT) then
z_one_st => z_one%st
!$acc kernels
z_one_st(:,:,:) = 0.0_rl
- z_one_st(1:z_one%icompx_max,1:z_one%icompy_max,1:z_one%grid_param%nz) = 1.0_rl
+ z_one_st(1:icompx_max,1:icompy_max,1:nz) = 1.0_rl
!$acc end kernels
end if
! Mean / Norm of B
call scalarprod_mnh(pproc,z_one,z_one, mean_initial )
call scalarprod_mnh(pproc,z_one,bRHS, mean_initial )
norm_initial = l2norm_mnh(bRHS,.true.)
- mean_initial = mean_initial / (( z_one%grid_param%nz ) * ( z_one%grid_param%n )**2)
+ mean_initial = mean_initial / (( nz ) * ( z_one%grid_param%n )**2)
norm_initial = mean_initial / norm_initial
if (LMean) then
! b <- b -mean_initial * z_one
@@ -1709,7 +1731,7 @@ contains
call print_elapsed(t_l2norm,.True.,1.0_rl)
call print_elapsed(t_scalprod,.True.,1.0_rl)
call print_elapsed(t_mainloop,.True.,1.0_rl)
- if (i_am_master_mpi) write(STDOUT,'("")')
+!!$ if (i_am_master_mpi) write(STDOUT,'("")')
end subroutine mg_solve_mnh
subroutine mg_solve(bRHS,usolution,solver_param)
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
index 72338e703e1ab7a938de88d82c72d8b43c2ac763..70e7508d52411b9bd9e9c28b5dd81054d9f7a86f 100644
--- a/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
@@ -58,7 +58,7 @@ private
type(grid_parameters), intent(in) :: grid_param
type(model_parameters), intent(in) :: model_param
type(scalar3d), intent(inout) :: u
- integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max, nz
real(kind=rl) :: x, y, z
real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
@@ -71,12 +71,14 @@ private
ix_max = u%ix_max
iy_min = u%iy_min
iy_max = u%iy_max
+ nz = u%grid_param%nz
+
IF (.NOT. PRESENT(KIB) ) THEN
! Initialise RHS
if (LUseO) then
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,u%grid_param%nz
+ do iz=1,nz
u%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
@@ -87,7 +89,7 @@ private
if (LUseT) then
zu_st => u%st
!$acc kernels loop independent collapse(3)
- do iz=1,u%grid_param%nz
+ do iz=1,nz
do iy=iy_min, iy_max
do ix=ix_min, ix_max
@@ -103,7 +105,7 @@ private
if (LUseO) then
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,u%grid_param%nz
+ do iz=1,nz
u%s(iz,iy-iy_min+1,ix-ix_min+1) = PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
end do
end do
@@ -112,7 +114,7 @@ private
if (LUseT) then
zu_st => u%st
!$acc kernels loop independent collapse(3)
- do iz=1,u%grid_param%nz
+ do iz=1,nz
do iy=iy_min, iy_max
do ix=ix_min, ix_max
zu_st(ix-ix_min+1,iy-iy_min+1,iz) = PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
@@ -131,7 +133,7 @@ private
type(grid_parameters), intent(in) :: grid_param
type(model_parameters), intent(in) :: model_param
type(scalar3d), intent(inout) :: u
- integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max, nz
real(kind=rl) :: x, y, z
real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
@@ -144,6 +146,8 @@ private
ix_max = u%ix_max
iy_min = u%iy_min
iy_max = u%iy_max
+ nz = u%grid_param%nz
+
IF (.NOT. PRESENT(KIB) ) THEN
!
ELSE
@@ -151,7 +155,7 @@ private
if (LUseO) then
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,u%grid_param%nz
+ do iz=1,nz
PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ) = u%s(iz,iy-iy_min+1,ix-ix_min+1)
end do
end do
@@ -159,7 +163,7 @@ private
else
zu_st => u%st
!$acc kernels loop independent collapse(3)
- do iz=1,u%grid_param%nz
+ do iz=1,nz
do iy=iy_min, iy_max
do ix=ix_min, ix_max
PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ) = zu_st(ix-ix_min+1,iy-iy_min+1,iz)
@@ -178,7 +182,7 @@ private
type(grid_parameters), intent(in) :: grid_param
type(model_parameters), intent(in) :: model_param
type(scalar3d), intent(inout) :: b
- integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max, nz, n
real(kind=rl) :: x, y, z
real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
@@ -191,15 +195,18 @@ private
ix_max = b%ix_max
iy_min = b%iy_min
iy_max = b%iy_max
+ nz = b%grid_param%nz
+ n = b%grid_param%n
+ !
IF (.NOT. PRESENT(KIB) ) THEN
! Initialise RHS
if (LUseO) then
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,b%grid_param%nz
- x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
- y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
- z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+ do iz=1,nz
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*nz))
b%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
@@ -219,12 +226,12 @@ private
if (LUseT) then
zb_st => b%st
!$acc kernels loop independent collapse(3)
- do iz=1,b%grid_param%nz
+ do iz=1,nz
do iy=iy_min, iy_max
do ix=ix_min, ix_max
- x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
- y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
- z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*nz))
zb_st(ix-ix_min+1,iy-iy_min+1,iz) = 0.0_rl
@@ -247,7 +254,7 @@ private
if (LUseO) then
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,b%grid_param%nz
+ do iz=1,nz
b%s(iz,iy-iy_min+1,ix-ix_min+1) = PY(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
end do
end do
@@ -256,7 +263,7 @@ private
if (LUseT) then
zb_st => b%st
!$acc kernels loop independent collapse(3)
- do iz=1,b%grid_param%nz
+ do iz=1,nz
do iy=iy_min, iy_max
do ix=ix_min, ix_max
zb_st(ix-ix_min+1,iy-iy_min+1,iz) = PY(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
@@ -275,7 +282,7 @@ private
type(grid_parameters), intent(in) :: grid_param
type(model_parameters), intent(in) :: model_param
type(scalar3d), intent(inout) :: b
- integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max, nz, n
real(kind=rl) :: x, y, z
real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
@@ -287,16 +294,18 @@ private
ix_max = b%ix_max
iy_min = b%iy_min
iy_max = b%iy_max
+ nz = b%grid_param%nz
+ n = b%grid_param%n
b_low = 1.0_rl+0.25*b%grid_param%H
b_up = 1.0_rl+0.75*b%grid_param%H
pi = 4.0_rl*atan2(1.0_rl,1.0_rl)
! Initialise RHS
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,b%grid_param%nz
- x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
- y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
- z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+ do iz=1,nz
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*nz))
#ifdef TESTCONVERGENCE
! RHS for analytical solution x*(1-x)*y*(1-y)*z*(1-z)
if (grid_param%vertbc == VERTBC_DIRICHLET) then
@@ -359,21 +368,23 @@ private
implicit none
type(grid_parameters), intent(in) :: grid_param
type(scalar3d), intent(inout) :: u
- integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max, nz, n
real(kind=rl) :: x, y, z
ix_min = u%ix_min
ix_max = u%ix_max
iy_min = u%iy_min
iy_max = u%iy_max
+ nz = u%grid_param%nz
+ n = u%grid_param%n
! Initialise RHS
do ix=ix_min, ix_max
do iy=iy_min, iy_max
- do iz=1,u%grid_param%nz
- x = u%grid_param%L*((ix-0.5_rl)/(1.0_rl*u%grid_param%n))
- y = u%grid_param%L*((iy-0.5_rl)/(1.0_rl*u%grid_param%n))
- z = u%grid_param%H*((iz-0.5_rl)/(1.0_rl*u%grid_param%nz))
+ do iz=1,nz
+ x = u%grid_param%L*((ix-0.5_rl)/(1.0_rl*n))
+ y = u%grid_param%L*((iy-0.5_rl)/(1.0_rl*n))
+ z = u%grid_param%H*((iz-0.5_rl)/(1.0_rl*nz))
if (grid_param%vertbc == VERTBC_DIRICHLET) then
u%s(iz,iy-iy_min+1,ix-ix_min+1) &
= x*(1.0_rl-x) &
diff --git a/src/ZSOLVER/tridiag_thermo.f90 b/src/ZSOLVER/tridiag_thermo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7ba28585cf889c05a029487228b15e8dcdc5a908
--- /dev/null
+++ b/src/ZSOLVER/tridiag_thermo.f90
@@ -0,0 +1,460 @@
+!MNH_LIC Copyright 2003-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.
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_TRIDIAG_THERMO
+! ###################
+!
+INTERFACE
+!
+ SUBROUTINE TRIDIAG_THERMO(KKA,KKU,KKL,PVARM,PF,PDFDDTDZ,PTSTEP,PIMPL, &
+ PDZZ,PRHODJ,PVARP )
+!
+INTEGER, INTENT(IN) :: KKA !near ground array index
+INTEGER, INTENT(IN) :: KKU !uppest atmosphere array index
+INTEGER, INTENT(IN) :: KKL !vert. levels type 1=MNH -1=AR
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PVARM ! variable at t-1 at mass point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PF ! flux in dT/dt=-dF/dz at flux point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDFDDTDZ! dF/d(dT/dz) at flux point
+REAL, INTENT(IN) :: PTSTEP ! Double time step
+REAL, INTENT(IN) :: PIMPL ! implicit weight
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Dz at flux point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! (dry rho)*J at mass point
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PVARP ! variable at t+1 at mass point
+!
+END SUBROUTINE TRIDIAG_THERMO
+!
+END INTERFACE
+!
+END MODULE MODI_TRIDIAG_THERMO
+!
+! #################################################
+ SUBROUTINE TRIDIAG_THERMO(KKA,KKU,KKL,PVARM,PF,PDFDDTDZ,PTSTEP,PIMPL, &
+ PDZZ,PRHODJ,PVARP )
+! #################################################
+!
+!
+!!**** *TRIDIAG_THERMO* - routine to solve a time implicit scheme
+!!
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to give a field PVARP at t+1, by
+! solving an implicit TRIDIAGonal system obtained by the
+! discretization of the vertical turbulent diffusion. It should be noted
+! that the degree of implicitness can be varied (PIMPL parameter) and that
+! the function of F(dT/dz) must have been linearized.
+! PVARP is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!!
+!! [T(+) - T(-)]/2Dt = -d{ F + dF/d(dT/dz) * [impl*dT/dz(+) + expl* dT/dz(-)] }/dz
+!!
+!! It is discretized as follows:
+!!
+!! PRHODJ(k)*PVARP(k)/PTSTEP
+!! =
+!! PRHODJ(k)*PVARM(k)/PTSTEP
+!! - (PRHODJ(k+1)+PRHODJ(k) )/2. * PF(k+1)/PDZZ(k+1)
+!! + (PRHODJ(k) +PRHODJ(k-1))/2. * PF(k) /PDZZ(k)
+!! + (PRHODJ(k+1)+PRHODJ(k) )/2. * ZEXPL* PDFDDTDZ(k+1) * PVARM(k+1)/PDZZ(k+1)**2
+!! - (PRHODJ(k+1)+PRHODJ(k) )/2. * PIMPL* PDFDDTDZ(k+1) * PVARP(k+1)/PDZZ(k+1)**2
+!! - (PRHODJ(k+1)+PRHODJ(k) )/2. * ZEXPL* PDFDDTDZ(k+1) * PVARM(k) /PDZZ(k+1)**2
+!! + (PRHODJ(k+1)+PRHODJ(k) )/2. * PIMPL* PDFDDTDZ(k+1) * PVARP(k) /PDZZ(k+1)**2
+!! - (PRHODJ(k) +PRHODJ(k-1))/2. * ZEXPL* PDFDDTDZ(k) * PVARM(k) /PDZZ(k)**2
+!! + (PRHODJ(k) +PRHODJ(k-1))/2. * PIMPL* PDFDDTDZ(k) * PVARP(k) /PDZZ(k)**2
+!! + (PRHODJ(k) +PRHODJ(k-1))/2. * ZEXPL* PDFDDTDZ(k) * PVARM(k-1)/PDZZ(k)**2
+!! - (PRHODJ(k) +PRHODJ(k-1))/2. * PIMPL* PDFDDTDZ(k) * PVARP(k-1)/PDZZ(k)**2
+!!
+!!
+!! The system to solve is:
+!!
+!! A*PVARP(k-1) + B*PVARP(k) + C*PVARP(k+1) = Y(k)
+!!
+!!
+!! The RHS of the linear system in PVARP writes:
+!!
+!! y(k) = PRHODJ(k)*PVARM(k)/PTSTEP
+!! - (PRHODJ(k+1)+PRHODJ(k) )/2. * PF(k+1)/PDZZ(k+1)
+!! + (PRHODJ(k) +PRHODJ(k-1))/2. * PF(k) /PDZZ(k)
+!! + (PRHODJ(k+1)+PRHODJ(k) )/2. * ZEXPL* PDFDDTDZ(k+1) * PVARM(k+1)/PDZZ(k+1)**2
+!! - (PRHODJ(k+1)+PRHODJ(k) )/2. * ZEXPL* PDFDDTDZ(k+1) * PVARM(k) /PDZZ(k+1)**2
+!! - (PRHODJ(k) +PRHODJ(k-1))/2. * ZEXPL* PDFDDTDZ(k) * PVARM(k) /PDZZ(k)**2
+!! + (PRHODJ(k) +PRHODJ(k-1))/2. * ZEXPL* PDFDDTDZ(k) * PVARM(k-1)/PDZZ(k)**2
+!!
+!!
+!! Then, the classical TRIDIAGonal algorithm is used to invert the
+!! implicit operator. Its matrix is given by:
+!!
+!! ( b(ikb) c(ikb) 0 0 0 0 0 0 )
+!! ( 0 a(ikb+1) b(ikb+1) c(ikb+1) 0 ... 0 0 0 )
+!! ( 0 0 a(ikb+2) b(ikb+2) c(ikb+2). 0 0 0 )
+!! .......................................................................
+!! ( 0 ... 0 a(k) b(k) c(k) 0 ... 0 0 )
+!! .......................................................................
+!! ( 0 0 0 0 0 ...a(ike-1) b(ike-1) c(ike-1))
+!! ( 0 0 0 0 0 ... 0 a(ike) b(ike) )
+!!
+!! ikb and ike represent the first and the last inner mass levels of the
+!! model. The coefficients are:
+!!
+!! a(k) = + (PRHODJ(k) +PRHODJ(k-1))/2. * PIMPL* PDFDDTDZ(k) /PDZZ(k)**2
+!! b(k) = PRHODJ(k) / PTSTEP
+!! - (PRHODJ(k+1)+PRHODJ(k) )/2. * PIMPL* PDFDDTDZ(k+1)/PDZZ(k+1)**2
+!! - (PRHODJ(k) +PRHODJ(k-1))/2. * PIMPL* PDFDDTDZ(k) /PDZZ(k)**2
+!! c(k) = + (PRHODJ(k+1)+PRHODJ(k) )/2. * PIMPL* PDFDDTDZ(k+1)/PDZZ(k+1)**2
+!!
+!! for all k /= ikb or ike
+!!
+!!
+!! b(ikb) = PRHODJ(ikb) / PTSTEP
+!! -(PRHODJ(ikb+1)+PRHODJ(ikb))/2.*PIMPL*PDFDDTDZ(ikb+1)/PDZZ(ikb+1)**2
+!! c(ikb) = +(PRHODJ(ikb+1)+PRHODJ(ikb))/2.*PIMPL*PDFDDTDZ(ikb+1)/PDZZ(ikb+1)**2
+!!
+!! b(ike) = PRHODJ(ike) / PTSTEP
+!! -(PRHODJ(ike)+PRHODJ(ike-1))/2.*PIMPL*PDFDDTDZ(ike)/PDZZ(ike)**2
+!! a(ike) = +(PRHODJ(ike)+PRHODJ(ike-1))/2.*PIMPL*PDFDDTDZ(ike)/PDZZ(ike)**2
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Press et al: Numerical recipes (1986) Cambridge Univ. Press
+!!
+!! AUTHOR
+!! ------
+!! V. Masson * Meteo-France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/2003 (from tridiag.f90)
+!! M.Moge 04/2016 Use openACC directives to port the TURB part of Meso-NH on GPU
+!! ---------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+USE MODD_PARAMETERS, ONLY : JPVEXT_TURB
+
+use mode_mppdb
+
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#endif
+!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D , MNH_ALLOCATE_ZT2D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 declarations of arguments
+!
+INTEGER, INTENT(IN) :: KKA !near ground array index
+INTEGER, INTENT(IN) :: KKU !uppest atmosphere array index
+INTEGER, INTENT(IN) :: KKL !vert. levels type 1=MNH -1=ARO
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PVARM ! variable at t-1 at mass point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PF ! flux in dT/dt=-dF/dz at flux point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDFDDTDZ! dF/d(dT/dz) at flux point
+REAL, INTENT(IN) :: PTSTEP ! Double time step
+REAL, INTENT(IN) :: PIMPL ! implicit weight
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Dz at flux point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! (dry rho)*J at mass point
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PVARP ! variable at t+1 at mass point
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZRHODJ_DFDDTDZ_O_DZ2
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZMZM_RHODJ
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZA, ZB, ZC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZY ,ZGAM
+ ! RHS of the equation, 3D work array
+INTEGER :: IZRHODJ_DFDDTDZ_O_DZ2,IZMZM_RHODJ,IZA,IZB,IZC,IZY,IZGAM
+REAL, DIMENSION(:,:), pointer , contiguous :: ZBET
+INTEGER :: IZBET
+ ! 2D work array
+INTEGER :: JI,JJ,JK ! loop counter
+INTEGER :: IKB,IKE ! inner vertical limits
+INTEGER :: IKT ! array size in k direction
+INTEGER :: IKTB,IKTE ! start, end of k loops in physical domain
+!
+!
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+INTEGER :: IZTMP1_DEVICE
+#endif
+
+INTEGER :: JIU,JJU,JKU
+
+! ---------------------------------------------------------------------------
+
+!$acc data present( PVARM, PF, PDFDDTDZ, PDZZ, PRHODJ, PVARP )
+
+if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pvarm, "Tridiag_thermo beg:pvarm" )
+ call Mppdb_check( pf, "Tridiag_thermo beg:pf" )
+ call Mppdb_check( pdfddtdz, "Tridiag_thermo beg:pdfddtdz" )
+ call Mppdb_check( pdzz, "Tridiag_thermo beg:pdzz" )
+ call Mppdb_check( prhodj, "Tridiag_thermo beg:prhodj" )
+end if
+
+JIU = size( pvarm, 1 )
+JJU = size( pvarm, 2 )
+JKU = size( pvarm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zrhodj_dfddtdz_o_dz2(JIU,JJU,JKU ) )
+allocate( zmzm_rhodj (JIU,JJU,JKU ) )
+allocate( za (JIU,JJU,JKU ) )
+allocate( zb (JIU,JJU,JKU ) )
+allocate( zc (JIU,JJU,JKU ) )
+allocate( zy (JIU,JJU,JKU ) )
+allocate( zgam (JIU,JJU,JKU ) )
+allocate( zbet (JIU,JJU ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("TRIDIAG_THERMO")
+izrhodj_dfddtdz_o_dz2 = MNH_ALLOCATE_ZT3D( zrhodj_dfddtdz_o_dz2,JIU,JJU,JKU )
+izmzm_rhodj = MNH_ALLOCATE_ZT3D( zmzm_rhodj ,JIU,JJU,JKU )
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU )
+izb = MNH_ALLOCATE_ZT3D( zb ,JIU,JJU,JKU )
+izc = MNH_ALLOCATE_ZT3D( zc ,JIU,JJU,JKU )
+izy = MNH_ALLOCATE_ZT3D( zy ,JIU,JJU,JKU )
+izgam = MNH_ALLOCATE_ZT3D( zgam ,JIU,JJU,JKU )
+izbet = MNH_ALLOCATE_ZT2D( zbet ,JIU,JJU )
+#endif
+
+#ifdef MNH_OPENACC
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+#endif
+
+!$acc data present( zrhodj_dfddtdz_o_dz2, zmzm_rhodj, za, zb, zc, zy, zgam, zbet, ztmp1_device )
+!
+!* 1. Preliminaries
+! -------------
+!
+IKT=SIZE(PVARM,3)
+IKTB=1+JPVEXT_TURB
+IKTE=IKT-JPVEXT_TURB
+IKB=KKA+JPVEXT_TURB*KKL
+IKE=KKU-JPVEXT_TURB*KKL
+!
+#ifndef MNH_OPENACC
+ZMZM_RHODJ = MZM(PRHODJ)
+#else
+CALL MZM_DEVICE(PRHODJ,ZMZM_RHODJ)
+#endif
+!$acc kernels ! async
+#ifndef MNH_BITREP
+ZRHODJ_DFDDTDZ_O_DZ2 = ZMZM_RHODJ*PDFDDTDZ/PDZZ**2
+#else
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK) = ZMZM_RHODJ(JI,JJ,JK)*PDFDDTDZ(JI,JJ,JK)/BR_P2(PDZZ(JI,JJ,JK))
+END DO !CONCURRENT
+#endif
+!$acc end kernels
+!
+!$acc kernels ! async
+ZA=0.
+ZB=0.
+ZC=0.
+ZY=0.
+!$acc end kernels
+! acc wait
+!
+!
+!* 2. COMPUTE THE RIGHT HAND SIDE
+! ---------------------------
+!
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ZY(JI,JJ,IKB) = PRHODJ(JI,JJ,IKB)*PVARM(JI,JJ,IKB)/PTSTEP &
+ - ZMZM_RHODJ(JI,JJ,IKB+KKL) * PF(JI,JJ,IKB+KKL)/PDZZ(JI,JJ,IKB+KKL) &
+ + ZMZM_RHODJ(JI,JJ,IKB ) * PF(JI,JJ,IKB )/PDZZ(JI,JJ,IKB ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL * PVARM(JI,JJ,IKB+KKL) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL * PVARM(JI,JJ,IKB )
+END DO !CONCURRENT
+!$acc end kernels
+!
+!$acc kernels ! async
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB+1:IKTE-1)
+ ZY(JI,JJ,JK) = PRHODJ(JI,JJ,JK)*PVARM(JI,JJ,JK)/PTSTEP &
+ - ZMZM_RHODJ(JI,JJ,JK+KKL) * PF(JI,JJ,JK+KKL)/PDZZ(JI,JJ,JK+KKL) &
+ + ZMZM_RHODJ(JI,JJ,JK ) * PF(JI,JJ,JK )/PDZZ(JI,JJ,JK ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL * PVARM(JI,JJ,JK+KKL) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL * PVARM(JI,JJ,JK ) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK ) * PIMPL * PVARM(JI,JJ,JK ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK ) * PIMPL * PVARM(JI,JJ,JK-KKL)
+END DO !CONCURRENT
+!$acc end kernels
+!
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ZY(JI,JJ,IKE) = PRHODJ(JI,JJ,IKE)*PVARM(JI,JJ,IKE)/PTSTEP &
+ - ZMZM_RHODJ(JI,JJ,IKE+KKL) * PF(JI,JJ,IKE+KKL)/PDZZ(JI,JJ,IKE+KKL) &
+ + ZMZM_RHODJ(JI,JJ,IKE ) * PF(JI,JJ,IKE )/PDZZ(JI,JJ,IKE ) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL * PVARM(JI,JJ,IKE ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL * PVARM(JI,JJ,IKE-KKL)
+END DO !CONCURRENT
+!$acc end kernels
+!
+! acc wait
+!
+!* 3. INVERSION OF THE TRIDIAGONAL SYSTEM
+! -----------------------------------
+!
+IF ( PIMPL > 1.E-10 ) THEN
+!
+!* 3.1 arrays A, B, C
+! --------------
+!
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZB(JI,JJ,IKB) = PRHODJ(JI,JJ,IKB)/PTSTEP &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL
+END DO !CONCURRENT
+!$acc end kernels
+!
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZC(JI,JJ,IKB) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL
+END DO !CONCURRENT
+!$acc end kernels
+!
+!$acc kernels ! async
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB+1:IKTE-1)
+ ZA(JI,JJ,JK) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK) * PIMPL
+ ZB(JI,JJ,JK) = PRHODJ(JI,JJ,JK)/PTSTEP &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK) * PIMPL
+ ZC(JI,JJ,JK) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL
+END DO !CONCURRENT
+!$acc end kernels
+!
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZA(JI,JJ,IKE) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL
+ ZB(JI,JJ,IKE) = PRHODJ(JI,JJ,IKE)/PTSTEP &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL
+END DO !CONCURRENT
+!$acc end kernels
+!
+! acc wait
+!
+!
+!* 3.2 going up
+! --------
+!
+!$acc kernels
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZBET(JI,JJ) = ZB(JI,JJ,IKB) ! bet = b(ikb)
+ PVARP(JI,JJ,IKB) = ZY(JI,JJ,IKB) / ZBET(JI,JJ)
+END DO !CONCURRENT
+!
+!$acc loop seq
+DO JK = IKB+KKL,IKE-KKL,KKL
+ ! gang+vector needed or parallisation vector only
+ !$acc loop independent gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZGAM(JI,JJ,JK) = ZC(JI,JJ,JK-KKL) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = ZB(JI,JJ,JK) - ZA(JI,JJ,JK) * ZGAM(JI,JJ,JK)
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,JK)= ( ZY(JI,JJ,JK) - ZA(JI,JJ,JK) * PVARP(JI,JJ,JK-KKL) ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ END DO !CONCURRENT
+END DO
+! special treatment for the last level
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZGAM(JI,JJ,IKE) = ZC(JI,JJ,IKE-KKL) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = ZB(JI,JJ,IKE) - ZA(JI,JJ,IKE) * ZGAM(JI,JJ,IKE)
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,IKE)= ( ZY(JI,JJ,IKE) - ZA(JI,JJ,IKE) * PVARP(JI,JJ,IKE-KKL) ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+END DO !CONCURRENT
+!
+!* 3.3 going down
+! ----------
+!
+!$acc loop seq
+DO JK = IKE-KKL,IKB,-1*KKL
+ ! gang+vector needed or parallisation vector only
+ !$acc loop independent gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,JK) = PVARP(JI,JJ,JK) - ZGAM(JI,JJ,JK+KKL) * PVARP(JI,JJ,JK+KKL)
+ END DO !CONCURRENT
+END DO
+!$acc end kernels
+!
+ELSE
+!
+!$acc kernels
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB:IKTE)
+ PVARP(JI,JJ,JK) = ZY(JI,JJ,JK) * PTSTEP / PRHODJ(JI,JJ,JK)
+END DO !CONCURRENT
+!$acc end kernels
+!
+END IF
+!
+!
+!* 4. FILL THE UPPER AND LOWER EXTERNAL VALUES
+! ----------------------------------------
+!
+!$acc kernels
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,KKA)=PVARP(JI,JJ,IKB)
+ PVARP(JI,JJ,KKU)=PVARP(JI,JJ,IKE)
+END DO !CONCURRENT
+!$acc end kernels
+
+if ( mppdb_initialized ) then
+ !Check all out arrays
+ call Mppdb_check( pvarp, "Tridiag_thermo end:pvarp" )
+end if
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+deallocate (zrhodj_dfddtdz_o_dz2,zmzm_rhodj,za,zb,zc,zy,zgam,zbet)
+#else
+CALL MNH_REL_ZT3D(IZRHODJ_DFDDTDZ_O_DZ2,IZMZM_RHODJ,IZA,IZB,IZC,IZY,IZGAM,&
+ IZBET,iztmp1_device)
+CALL MNH_CHECK_OUT_ZT3D("TRIDIAG_THERMO")
+#endif
+
+!$acc end data
+
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE TRIDIAG_THERMO
diff --git a/src/ZSOLVER/turb.f90 b/src/ZSOLVER/turb.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9d5f3bfa99c5c9e6b916e628f882e8bb9f8e6d7c
--- /dev/null
+++ b/src/ZSOLVER/turb.f90
@@ -0,0 +1,2461 @@
+!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.
+!-----------------------------------------------------------------
+!###############
+module mode_turb
+!###############
+
+#ifdef MNH_OPENACC
+ use mode_msg
+ USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D, &
+ MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D , &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+
+#ifdef MNH_BITREP
+use modi_bitrep
+#endif
+
+implicit none
+
+private
+
+public :: turb
+
+contains
+
+! #################################################################
+SUBROUTINE TURB(KKA,KKU,KKL,KMI,KRR,KRRL,KRRI,HLBCX,HLBCY,KSPLIT,KMODEL_CL, &
+ OCLOSE_OUT,OTURB_FLX,OTURB_DIAG,OSUBG_COND,ORMC01, &
+ HTURBDIM,HTURBLEN,HTOM,HTURBLEN_CL,HCLOUD,PIMPL, &
+ PTSTEP,TPFILE,PDXX,PDYY,PDZZ,PDZX,PDZY,PZZ, &
+ PDIRCOSXW,PDIRCOSYW,PDIRCOSZW,PCOSSLOPE,PSINSLOPE, &
+ PRHODJ,PTHVREF, &
+ PSFTH,PSFRV,PSFSV,PSFU,PSFV, &
+ PPABST,PUT,PVT,PWT,PTKET,PSVT,PSRCT, &
+ PBL_DEPTH,PSBL_DEPTH, &
+ PCEI,PCEI_MIN,PCEI_MAX,PCOEF_AMPL_SAT, &
+ PTHLT,PRT, &
+ PRUS,PRVS,PRWS,PRTHLS,PRRS,PRSVS,PRTKES,PRTKEMS,PSIGS,&
+ PFLXZTHVMF,PWTH,PWRC,PWSV,PDYP,PTHP,PTR,PDISS,PLEM )
+! #################################################################
+!
+!
+!!**** *TURB* - computes the turbulent source terms for the prognostic
+!! variables.
+!!
+!! PURPOSE
+!! -------
+!!**** The purpose of this routine is to compute the source terms in
+!! the evolution equations due to the turbulent mixing.
+!! The source term is computed as the divergence of the turbulent fluxes.
+!! The cartesian fluxes are obtained by a one and a half order closure, based
+!! on a prognostic equation for the Turbulence Kinetic Energy( TKE ). The
+!! system is closed by prescribing a turbulent mixing length. Different
+!! choices are available for this length.
+!
+!!** METHOD
+!! ------
+!!
+!! The dimensionality of the turbulence parameterization can be chosen by
+!! means of the parameter HTURBDIM:
+!! * HTURBDIM='1DIM' the parameterization is 1D but can be used in
+!! 3D , 2D or 1D simulations. Only the sources associated to the vertical
+!! turbulent fluxes are taken into account.
+!! * HTURBDIM='3DIM' the parameterization is fully 2D or 3D depending
+!! on the model dimensionality. Of course, it does not make any sense to
+!! activate this option with a 1D model.
+!!
+!! The following steps are made:
+!! 1- Preliminary computations.
+!! 2- The metric coefficients are recovered from the grid knowledge.
+!! 3- The mixing length is computed according to its choice:
+!! * HTURBLEN='BL89' the Bougeault and Lacarrere algorithm is used.
+!! The mixing length is given by the vertical displacement from its
+!! original level of an air particule having an initial internal
+!! energy equal to its TKE and stopped by the buoyancy forces.
+!! The discrete formulation is second order accurate.
+!! * HTURBLEN='DELT' the mixing length is given by the mesh size
+!! depending on the model dimensionality, this length is limited
+!! with the ground distance.
+!! * HTURBLEN='DEAR' the mixing length is given by the mesh size
+!! depending on the model dimensionality, this length is limited
+!! with the ground distance and also by the Deardorff mixing length
+!! pertinent in the stable cases.
+!! * HTURBLEN='KEPS' the mixing length is deduced from the TKE
+!! dissipation, which becomes a prognostic variable of the model (
+!! Duynkerke formulation).
+!! 3'- The cloud mixing length is computed according to HTURBLEN_CLOUD
+!! and emphasized following the CEI index
+!! 4- The conservative variables are computed along with Lv/Cp.
+!! 5- The turbulent Prandtl numbers are computed from the resolved fields
+!! and TKE
+!! 6- The sources associated to the vertical turbulent fluxes are computed
+!! with a temporal scheme allowing a degree of implicitness given by
+!! PIMPL, varying from PIMPL=0. ( purely explicit scheme) to PIMPL=1.
+!! ( purely implicit scheme)
+!! The sources associated to the horizontal fluxes are computed with a
+!! purely explicit temporal scheme. These sources are only computed when
+!! the turbulence parameterization is 2D or 3D( HTURBDIM='3DIM' ).
+!! 7- The sources for TKE are computed, along with the dissipation of TKE
+!! if HTURBLEN='KEPS'.
+!! 8- Some turbulence-related quantities are stored in the synchronous
+!! FM-file.
+!! 9- The non-conservative variables are retrieved.
+!!
+!!
+!! The saving of the fields in the synchronous FM-file is controlled by:
+!! * OTURB_FLX => saves all the turbulent fluxes and correlations
+!! * OTURB_DIAG=> saves the turbulent Prandtl and Schmidt numbers, the
+!! source terms of TKE and dissipation of TKE
+!!
+!! EXTERNAL
+!! --------
+!! SUBROUTINE PRANDTL : computes the turbulent Prandtl number
+!! SUBROUTINE TURB_VER : computes the sources from the vertical fluxes
+!! SUBROUTINE TURB_HOR : computes the sources from the horizontal fluxes
+!! SUBROUTINE TKE_EPS_SOURCES : computes the sources for TKE and its
+!! dissipation
+!! SUBROUTINE BUDGET : computes and stores the budgets
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODD_PARAMETERS : JPVEXT number of marginal vertical points
+!!
+!! MODD_CONF : CCONF model configuration (start/restart)
+!! L1D switch for 1D model version
+!! L2D switch for 2D model version
+!!
+!! MODD_CST : contains physical constants
+!! XG gravity constant
+!! XRD Gas constant for dry air
+!! XRV Gas constant for vapor
+!!
+!! MODD_CTURB : contains turbulence scheme constants
+!! XCMFS,XCED to compute the dissipation mixing length
+!! XTKEMIN minimum values for the TKE
+!! XLINI,XLINF to compute Bougeault-Lacarrere mixing
+!! length
+!! Module MODD_BUDGET:
+!! NBUMOD
+!! CBUTYPE
+!! NBUPROCCTR
+!! LBU_RU
+!! LBU_RV
+!! LBU_RW
+!! LBU_RTH
+!! LBU_RSV1
+!! LBU_RRV
+!! LBU_RRC
+!! LBU_RRR
+!! LBU_RRI
+!! LBU_RRS
+!! LBU_RRG
+!! LBU_RRH
+!!
+!! REFERENCE
+!! ---------
+!! Book 2 of documentation (routine TURB)
+!! Book 1 of documentation (Chapter: Turbulence)
+!!
+!! AUTHOR
+!! ------
+!! Joan Cuxart * INM and Meteo-France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/10/94
+!! Modifications: Feb 14, 1995 (J.Cuxart and J.Stein)
+!! Doctorization and Optimization
+!! Modifications: March 21, 1995 (J.M. Carriere)
+!! Introduction of cloud water
+!! Modifications: June 1, 1995 (J.Cuxart )
+!! take min(Kz,delta)
+!! Modifications: June 1, 1995 (J.Stein J.Cuxart)
+!! remove unnecessary arrays and change Prandtl
+!! and Schmidt numbers localizations
+!! Modifications: July 20, 1995 (J.Stein) remove MODI_ground_ocean +
+!! TZDTCUR + MODD_TIME because they are not used
+!! change RW in RNP for the outputs
+!! Modifications: August 21, 1995 (Ph. Bougeault)
+!! take min(K(z-zsol),delta)
+!! Modifications: Sept 14, 1995 (Ph Bougeault, J. Cuxart)
+!! second order BL89 mixing length computations + add Deardorff length
+!! in the Delta case for stable cases
+!! Modifications: Sept 19, 1995 (J. Stein, J. Cuxart)
+!! define a DEAR case for the mixing length, add MODI_BUDGET and change
+!! some BUDGET calls, add LES tools
+!! Modifications: Oct 16, 1995 (J. Stein) change the budget calls
+!! Modifications: Feb 28, 1996 (J. Stein) optimization +
+!! remove min(K(z-zsol),delta)+
+!! bug in the tangential fluxes
+!! Modifications: Oct 16, 1996 (J. Stein) change the subgrid condensation
+!! scheme + temporal discretization
+!! Modifications: Dec 19, 1996 (J.-P. Pinty) update the budget calls
+!! Jun 22, 1997 (J. Stein) use the absolute pressure and
+!! change the Deardorf length at the surface
+!! Modifications: Apr 27, 1997 (V. Masson) BL89 mix. length computed in
+!! a separate routine
+!! Oct 13, 1999 (J. Stein) switch for the tgt fluxes
+!! Jun 24, 1999 (P Jabouille) Add routine UPDATE_ROTATE_WIND
+!! Feb 15, 2001 (J. Stein) remove tgt fluxes
+!! Mar 8, 2001 (V. Masson) forces the same behaviour near the surface
+!! for all mixing lengths
+!! Nov 06, 2002 (V. Masson) LES budgets
+!! Nov, 2002 (V. Masson) implement modifications of
+!! mixing and dissipative lengths
+!! near the surface (according
+!! Redelsperger et al 2001)
+!! Apr, 2003 (V. Masson) bug in Blackadar length
+!! bug in LES in 1DIM case
+!! Feb 20, 2003 (J.-P. Pinty) Add reversible ice processes
+!! May,26 2004 (P Jabouille) coef for computing dissipative heating
+!! Sept 2004 (M.Tomasini) Cloud Mixing length modification
+!! following the instability
+!! criterium CEI calculated in modeln
+!! May 2006 Remove KEPS
+!! Sept.2006 (I.Sandu): Modification of the stability criterion for
+!! DEAR (theta_v -> theta_l)
+!! Oct 2007 (J.Pergaud) Add MF contribution for vert. turb. transport
+!! Oct.2009 (C.Lac) Introduction of different PTSTEP according to the
+!! advection schemes
+!! October 2009 (G. Tanguy) add ILENCH=LEN(YCOMMENT) after
+!! change of YCOMMENT
+!! 06/2011 (J.escobar ) Bypass Bug with ifort11/12 on HLBCX,HLBC
+!! 2012-02 Y. Seity, add possibility to run with reversed
+!! vertical levels
+!! 10/2012 (J. Colin) Correct bug in DearDoff for dry simulations
+!! 10/2012 J.Escobar Bypass PGI bug , redefine some allocatable array inplace of automatic
+!! 04/2016 (C.Lac) correction of negativity for KHKO
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! 01/2018 (Q.Rodier) Introduction of RM17
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+! P. Wautelet 20/06/2019: take DELT and DEAR subroutines out of the TURB one (PGI compiler bug workaround) + transform into a mode_ module
+!! --------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS, ONLY: JPVEXT_TURB
+USE MODD_CST
+USE MODD_CTURB
+USE MODD_CONF
+USE MODD_BUDGET
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LES
+USE MODD_NSV
+!
+USE MODI_GRADIENT_M
+USE MODI_GRADIENT_U
+USE MODI_GRADIENT_V
+USE MODI_BL89
+USE MODI_TURB_VER
+USE MODI_ROTATE_WIND
+USE MODI_TURB_HOR_SPLT
+USE MODI_TKE_EPS_SOURCES
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+!PW: TODO: remove use modi_shuman
+USE MODI_SHUMAN
+USE MODI_SHUMAN_DEVICE
+#endif
+USE MODI_GRADIENT_M
+USE MODI_BUDGET
+USE MODI_LES_MEAN_SUBGRID
+USE MODI_RMC01
+USE MODI_GRADIENT_W
+USE MODI_TM06
+USE MODI_UPDATE_LM
+USE MODI_GET_HALO
+!
+USE MODE_FIELD, ONLY: TFIELDDATA, TYPEREAL
+USE MODE_IO_FIELD_WRITE, only: IO_Field_write
+USE MODE_SBL
+!
+USE MODI_EMOIST
+USE MODI_ETHETA
+!
+USE MODI_SECOND_MNH
+!
+USE MODE_MPPDB
+!
+!! use, intrinsic :: ISO_C_BINDING
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 declarations of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KKA !near ground array index
+INTEGER, INTENT(IN) :: KKU !uppest atmosphere array index
+INTEGER, INTENT(IN) :: KKL !vert. levels type 1=MNH -1=ARO
+INTEGER, INTENT(IN) :: KMI ! model index number
+INTEGER, INTENT(IN) :: KRR ! number of moist var.
+INTEGER, INTENT(IN) :: KRRL ! number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! number of ice water var.
+CHARACTER(LEN=*),DIMENSION(:),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
+INTEGER, INTENT(IN) :: KSPLIT ! number of time-splitting
+INTEGER, INTENT(IN) :: KMODEL_CL ! model number for cloud mixing length
+LOGICAL, INTENT(IN) :: OCLOSE_OUT ! switch for syncronous
+ ! file opening
+LOGICAL, INTENT(IN) :: OTURB_FLX ! switch to write the
+ ! turbulent fluxes in the syncronous FM-file
+LOGICAL, INTENT(IN) :: OTURB_DIAG ! switch to write some
+ ! diagnostic fields in the syncronous FM-file
+LOGICAL, INTENT(IN) :: OSUBG_COND ! switch for SUBGrid
+ ! CONDensation
+LOGICAL, INTENT(IN) :: ORMC01 ! switch for RMC01 lengths in SBL
+CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! dimensionality of the
+ ! turbulence scheme
+CHARACTER(len=4), INTENT(IN) :: HTURBLEN ! kind of mixing length
+CHARACTER(len=4), INTENT(IN) :: HTOM ! kind of Third Order Moment
+CHARACTER(len=4), INTENT(IN) :: HTURBLEN_CL ! kind of cloud mixing length
+REAL, INTENT(IN) :: PIMPL ! degree of implicitness
+CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of microphysical scheme
+REAL, INTENT(IN) :: PTSTEP ! timestep
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! physical distance
+! between 2 succesive grid points along the K direction
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSXW, PDIRCOSYW, PDIRCOSZW
+! Director Cosinus along x, y and z directions at surface w-point
+REAL, DIMENSION(:,:), INTENT(IN) :: PCOSSLOPE ! cosinus of the angle
+ ! between i and the slope vector
+REAL, DIMENSION(:,:), INTENT(IN) :: PSINSLOPE ! sinus of the angle
+ ! between i and the slope vector
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! dry density * Grid size
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Potential
+ ! Temperature of the reference state
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PSFTH,PSFRV, &
+! normal surface fluxes of theta and Rv
+ PSFU,PSFV
+! normal surface fluxes of (u,v) parallel to the orography
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSFSV
+! normal surface fluxes of Scalar var.
+!
+! prognostic variables at t- deltat
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Pressure at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT,PVT,PWT ! wind components
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKET ! TKE
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! passive scal. var.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRCT ! Second-order flux
+ ! s'rc'/2Sigma_s2 at time t-1 multiplied by Lambda_3
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PBL_DEPTH ! BL height for TOMS
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PSBL_DEPTH ! SBL depth for RMC01
+!
+! variables for cloud mixing length
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCEI ! Cloud Entrainment instability
+ ! index to emphasize localy
+ ! turbulent fluxes
+REAL, INTENT(IN) :: PCEI_MIN ! minimum threshold for the instability index CEI
+REAL, INTENT(IN) :: PCEI_MAX ! maximum threshold for the instability index CEI
+REAL, INTENT(IN) :: PCOEF_AMPL_SAT ! saturation of the amplification coefficient
+!
+! thermodynamical variables which are transformed in conservative var.
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHLT ! conservative pot. temp.
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRT ! water var. where
+ ! PRT(:,:,:,1) is the conservative mixing ratio
+! sources of momentum, conservative potential temperature, Turb. Kin. Energy,
+! TKE dissipation
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS,PRVS,PRWS,PRTHLS,PRTKES
+! Source terms for all water kinds, PRRS(:,:,:,1) is used for the conservative
+! mixing ratio
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRTKEMS
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRRS
+! Source terms for all passive scalar variables
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRSVS
+! Sigma_s at time t+1 : square root of the variance of the deviation to the
+! saturation
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSIGS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFLXZTHVMF
+! MF contribution for vert. turb. transport
+! used in the buoy. prod. of TKE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PWTH ! heat flux
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PWRC ! cloud water flux
+REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: PWSV ! scalar flux
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PDYP ! Dynamical production of TKE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHP ! Thermal production of TKE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTR ! Transport production of TKE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PDISS ! Dissipation of TKE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLEM ! Mixing length
+!
+!-------------------------------------------------------------------------------
+!
+! 0.2 declaration of local variables
+!
+REAL, POINTER , CONTIGUOUS, DIMENSION(:,:,:) ::&
+ ZCP, & ! Cp at t-1
+ ZEXN, & ! EXN at t-1
+ ZT, & ! T at t-1
+ ZLOCPEXNM, & ! Lv/Cp/EXNREF at t-1
+ ZLEPS, & ! Dissipative length
+ ZTRH, & ! Dynamic and Thermal Production of TKE
+ ZATHETA,ZAMOIST, & ! coefficients for s = f (Thetal,Rnp)
+ ZCOEF_DISS, & ! 1/(Cph*Exner) for dissipative heating
+ ZFRAC_ICE, & ! ri fraction of rc+ri
+ ZMWTH,ZMWR,ZMTH2,ZMR2,ZMTHR,& ! 3rd order moments
+ ZFWTH,ZFWR,ZFTH2,ZFR2,ZFTHR,& ! opposite of verticale derivate of 3rd order moments
+ ZTHLM ! initial potential temp.
+INTEGER :: IZCP,IZEXN,IZT,IZLOCPEXNM,IZLEPS,IZTRH,IZATHETA,IZAMOIST &
+ ,IZCOEF_DISS,IZFRAC_ICE,IZMWTH,IZMWR,IZMTH2,IZMR2,IZMTHR &
+ ,IZFWTH,IZFWR,IZFTH2,IZFR2,IZFTHR,IZTHLM
+!
+REAL, POINTER , CONTIGUOUS, DIMENSION(:,:,:,:) :: &
+ ZRM ! initial mixing ratio
+REAL, POINTER , CONTIGUOUS, DIMENSION(:,:) :: ZTAU11M,ZTAU12M, &
+ ZTAU22M,ZTAU33M, &
+ ! tangential surface fluxes in the axes following the orography
+ ZUSLOPE,ZVSLOPE, &
+ ! wind components at the first mass level parallel
+ ! to the orography
+ ZCDUEFF, &
+ ! - Cd*||u|| where ||u|| is the module of the wind tangential to
+ ! orography (ZUSLOPE,ZVSLOPE) at the surface.
+ ZUSTAR, ZLMO, &
+ ZRVM, ZSFRV
+ ! friction velocity, Monin Obuhkov length, work arrays for vapor
+!
+ ! Virtual Potential Temp. used
+ ! in the Deardorff mixing length computation
+INTEGER :: IZRM,IZTAU11M,IZTAU12M,IZTAU22M,IZTAU33M,IZUSLOPE,IZVSLOPE &
+ ,IZCDUEFF,IZUSTAR,IZLMO,IZRVM,IZSFRV
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: &
+ ZLVOCPEXNM,ZLSOCPEXNM, & ! Lv/Cp/EXNREF and Ls/Cp/EXNREF at t-1
+ ZATHETA_ICE,ZAMOIST_ICE ! coefficients for s = f (Thetal,Rnp)
+INTEGER :: IZLVOCPEXNM,IZLSOCPEXNM,IZATHETA_ICE,IZAMOIST_ICE
+!
+REAL :: ZEXPL ! 1-PIMPL deg of expl.
+REAL :: ZRVORD ! RV/RD
+!
+INTEGER :: IKB,IKE ! index value for the
+! Beginning and the End of the physical domain for the mass points
+INTEGER :: IKT ! array size in k direction
+INTEGER :: IKTB,IKTE ! start, end of k loops in physical domain
+INTEGER :: JRR,JK,JSV ! loop counters
+INTEGER :: JI,JJ ! loop counters
+REAL :: ZL0 ! Max. Mixing Length in Blakadar formula
+REAL :: ZALPHA ! proportionnality constant between Dz/2 and
+! ! BL89 mixing length near the surface
+!
+REAL :: ZTIME1, ZTIME2
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTT,ZEXNE,ZLV,ZCPH
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZSHEAR, ZDUDZ, ZDVDZ
+INTEGER :: IZTT,IZEXNE,IZLV,IZCPH,IZSHEAR, IZDUDZ, IZDVDZ
+TYPE(TFIELDDATA) :: TZFIELD
+!
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE
+#endif
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JLU_ZRM, JLU_TURB, JJU_ORMC01, JKU_CLOUD, JKU_TURB
+!
+!------------------------------------------------------------------------------------------
+!
+! IN variables
+!
+!$acc data present( PDXX, PDYY, PDZZ, PDZX, PDZY, PRHODJ) &
+!$acc & copyin ( PZZ, PDIRCOSXW, PDIRCOSYW, PDIRCOSZW, &
+!$acc & PCOSSLOPE, PSINSLOPE, PTHVREF, PSFTH, PSFRV, PSFU, PSFV, PSFSV, &
+!$acc & PPABST, PUT, PVT, PWT, PTKET, PSVT, PSRCT, PCEI, PRTKEMS, PFLXZTHVMF ) &
+!
+! INOUT variables
+!
+!$acc & create ( PBL_DEPTH, PSBL_DEPTH, PTHLT, PRT, &
+!$acc & PRUS, PRVS, PRWS, PRTHLS, PRTKES, PRRS, PRSVS ) &
+!
+! OUT variables
+!
+!$acc & create ( PSIGS, PWTH, PWRC, PWSV, PDYP, PTHP, PTR, PDISS, PLEM )
+!
+! Local variables
+!
+! !$acc & create ( ZSHEAR )
+
+if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pdxx, "Turb beg:pdxx" )
+ call Mppdb_check( pdyy, "Turb beg:pdyy" )
+ call Mppdb_check( pdzz, "Turb beg:pdzz" )
+ call Mppdb_check( pdzx, "Turb beg:pdzx" )
+ call Mppdb_check( pdzy, "Turb beg:pdzy" )
+ call Mppdb_check( prhodj, "Turb beg:prhodj" )
+ call Mppdb_check( pzz, "Turb beg:pzz" )
+ call Mppdb_check( pdircosxw, "Turb beg:pdircosxw" )
+ call Mppdb_check( pdircosyw, "Turb beg:pdircosyw" )
+ call Mppdb_check( pdircoszw, "Turb beg:pdircoszw" )
+ call Mppdb_check( pcosslope, "Turb beg:pcosslope" )
+ call Mppdb_check( psinslope, "Turb beg:psinslope" )
+ call Mppdb_check( pthvref, "Turb beg:pthvref" )
+ call Mppdb_check( psfth, "Turb beg:psfth" )
+ call Mppdb_check( psfrv, "Turb beg:psfrv" )
+ call Mppdb_check( psfu, "Turb beg:psfu" )
+ call Mppdb_check( psfv, "Turb beg:psfv" )
+ call Mppdb_check( psfsv, "Turb beg:psfsv" )
+ call Mppdb_check( ppabst, "Turb beg:ppabst" )
+ call Mppdb_check( put, "Turb beg:put" )
+ call Mppdb_check( pvt, "Turb beg:pvt" )
+ call Mppdb_check( pwt, "Turb beg:pwt" )
+ call Mppdb_check( ptket, "Turb beg:ptket" )
+ call Mppdb_check( psvt, "Turb beg:psvt" )
+ call Mppdb_check( psrct, "Turb beg:psrct" )
+ call Mppdb_check( pcei, "Turb beg:pcei" )
+ call Mppdb_check( prtkems, "Turb beg:prtkems" )
+ call Mppdb_check( pflxzthvmf, "Turb beg:pflxzthvmf" )
+ !check all inout arrays
+ call Mppdb_check( pbl_depth, "Turb beg:pbl_depth" )
+ call Mppdb_check( psbl_depth, "Turb beg:psbl_depth" )
+ call Mppdb_check( pthlt, "Turb beg:pthlt" )
+ call Mppdb_check( prt, "Turb beg:prt" )
+ call Mppdb_check( prus, "Turb beg:prus" )
+ call Mppdb_check( prvs, "Turb beg:prvs" )
+ call Mppdb_check( prws, "Turb beg:prws" )
+ call Mppdb_check( prthls, "Turb beg:prthls" )
+ call Mppdb_check( prtkes, "Turb beg:prtkes" )
+ call Mppdb_check( prrs, "Turb beg:prrs" )
+ call Mppdb_check( prsvs, "Turb beg:prsvs" )
+end if
+
+JIU = size(pthlt, 1 )
+JJU = size(pthlt, 2 )
+JKU = size(pthlt, 3 )
+
+#ifndef MNH_OPENACC
+ALLOCATE (ZCP (JIU,JJU,JKU) )
+ALLOCATE (ZEXN (JIU,JJU,JKU) )
+ALLOCATE (ZT (JIU,JJU,JKU) )
+ALLOCATE (ZLOCPEXNM (JIU,JJU,JKU) )
+ALLOCATE (ZLEPS (JIU,JJU,JKU) )
+ALLOCATE (ZTRH (JIU,JJU,JKU) )
+ALLOCATE (ZATHETA (JIU,JJU,JKU) )
+ALLOCATE (ZAMOIST (JIU,JJU,JKU) )
+ALLOCATE (ZCOEF_DISS(JIU,JJU,JKU) )
+ALLOCATE (ZFRAC_ICE (JIU,JJU,JKU) )
+
+ALLOCATE (ZMWTH (JIU,JJU,JKU) )
+ALLOCATE (ZMWR (JIU,JJU,JKU) )
+ALLOCATE (ZMTH2 (JIU,JJU,JKU) )
+ALLOCATE (ZMR2 (JIU,JJU,JKU) )
+ALLOCATE (ZMTHR (JIU,JJU,JKU) )
+
+ALLOCATE (ZFWTH (JIU,JJU,JKU) )
+ALLOCATE (ZFWR (JIU,JJU,JKU) )
+ALLOCATE (ZFTH2 (JIU,JJU,JKU) )
+ALLOCATE (ZFR2 (JIU,JJU,JKU) )
+ALLOCATE (ZFTHR (JIU,JJU,JKU) )
+ALLOCATE (ZTHLM (JIU,JJU,JKU) )
+
+JLU_TURB = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' .OR. ORMC01 ) JLU_TURB = SIZE(PRT,4)
+ALLOCATE ( ZRM(JIU,JJU,JKU, JLU_TURB ) )
+
+ALLOCATE ( ZTAU11M(JIU,JJU) )
+ALLOCATE ( ZTAU12M(JIU,JJU) )
+ALLOCATE ( ZTAU22M(JIU,JJU) )
+ALLOCATE ( ZTAU33M(JIU,JJU) )
+ALLOCATE ( ZUSLOPE(JIU,JJU) )
+ALLOCATE ( ZVSLOPE(JIU,JJU) )
+ALLOCATE ( ZCDUEFF(JIU,JJU) )
+ALLOCATE ( ZLMO (JIU,JJU) )
+
+JJU_ORMC01 = 0
+IF (ORMC01) JJU_ORMC01 = SIZE(PTHLT,2)
+ALLOCATE ( ZUSTAR (JIU,JJU_ORMC01) )
+ALLOCATE ( ZRVM (JIU,JJU_ORMC01) )
+ALLOCATE ( ZSFRV (JIU,JJU_ORMC01) )
+
+JKU_CLOUD = 0
+IF ( HCLOUD == 'KHKO' .OR. HCLOUD == 'C2R2' ) JKU_CLOUD = size( put, 3 )
+allocate( ztt (JIU,JJU, JKU_CLOUD ) )
+allocate( zexne (JIU,JJU, JKU_CLOUD ) )
+allocate( zlv (JIU,JJU, JKU_CLOUD ) )
+allocate( zcph (JIU,JJU, JKU_CLOUD ) )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+allocate( zshear(JIU,JJU, JKU_TURB ) )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+allocate( zdudz (JIU,JJU, JKU_TURB ) )
+allocate( zdvdz (JIU,JJU, JKU_TURB ) )
+
+#else
+CALL MNH_CHECK_IN_ZT3D("TURB")
+IZCP = MNH_ALLOCATE_ZT3D (ZCP ,JIU,JJU,JKU )
+IZEXN = MNH_ALLOCATE_ZT3D (ZEXN ,JIU,JJU,JKU )
+IZT = MNH_ALLOCATE_ZT3D (ZT ,JIU,JJU,JKU )
+IZLOCPEXNM = MNH_ALLOCATE_ZT3D (ZLOCPEXNM ,JIU,JJU,JKU )
+IZLEPS = MNH_ALLOCATE_ZT3D (ZLEPS ,JIU,JJU,JKU )
+IZTRH = MNH_ALLOCATE_ZT3D (ZTRH ,JIU,JJU,JKU )
+IZATHETA = MNH_ALLOCATE_ZT3D (ZATHETA ,JIU,JJU,JKU )
+IZAMOIST = MNH_ALLOCATE_ZT3D (ZAMOIST ,JIU,JJU,JKU )
+IZCOEF_DISS = MNH_ALLOCATE_ZT3D (ZCOEF_DISS,JIU,JJU,JKU )
+IZFRAC_ICE = MNH_ALLOCATE_ZT3D (ZFRAC_ICE ,JIU,JJU,JKU )
+
+IZMWTH = MNH_ALLOCATE_ZT3D (ZMWTH ,JIU,JJU,JKU )
+IZMWR = MNH_ALLOCATE_ZT3D (ZMWR ,JIU,JJU,JKU )
+IZMTH2 = MNH_ALLOCATE_ZT3D (ZMTH2 ,JIU,JJU,JKU )
+IZMR2 = MNH_ALLOCATE_ZT3D (ZMR2 ,JIU,JJU,JKU )
+IZMTHR = MNH_ALLOCATE_ZT3D (ZMTHR ,JIU,JJU,JKU )
+
+IZFWTH = MNH_ALLOCATE_ZT3D (ZFWTH ,JIU,JJU,JKU )
+IZFWR = MNH_ALLOCATE_ZT3D (ZFWR ,JIU,JJU,JKU )
+IZFTH2 = MNH_ALLOCATE_ZT3D (ZFTH2 ,JIU,JJU,JKU )
+IZFR2 = MNH_ALLOCATE_ZT3D (ZFR2 ,JIU,JJU,JKU )
+IZFTHR = MNH_ALLOCATE_ZT3D (ZFTHR ,JIU,JJU,JKU )
+IZTHLM = MNH_ALLOCATE_ZT3D (ZTHLM ,JIU,JJU,JKU )
+
+JLU_ZRM = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' .OR. ORMC01 ) JLU_ZRM = SIZE(PRT,4)
+IZRM = MNH_ALLOCATE_ZT4D ( ZRM,JIU,JJU,JKU, JLU_ZRM )
+
+IZTAU11M = MNH_ALLOCATE_ZT2D ( ZTAU11M,JIU,JJU )
+IZTAU12M = MNH_ALLOCATE_ZT2D ( ZTAU12M,JIU,JJU )
+IZTAU22M = MNH_ALLOCATE_ZT2D ( ZTAU22M,JIU,JJU )
+IZTAU33M = MNH_ALLOCATE_ZT2D ( ZTAU33M,JIU,JJU )
+IZUSLOPE = MNH_ALLOCATE_ZT2D ( ZUSLOPE,JIU,JJU )
+IZVSLOPE = MNH_ALLOCATE_ZT2D ( ZVSLOPE,JIU,JJU )
+IZCDUEFF = MNH_ALLOCATE_ZT2D ( ZCDUEFF,JIU,JJU )
+IZLMO = MNH_ALLOCATE_ZT2D ( ZLMO ,JIU,JJU )
+
+JJU_ORMC01 = 0
+IF (ORMC01) JJU_ORMC01 = SIZE(PTHLT,2)
+IZUSTAR = MNH_ALLOCATE_ZT2D ( ZUSTAR ,JIU,JJU_ORMC01 )
+IZRVM = MNH_ALLOCATE_ZT2D ( ZRVM ,JIU,JJU_ORMC01 )
+IZSFRV = MNH_ALLOCATE_ZT2D ( ZSFRV ,JIU,JJU_ORMC01 )
+
+JKU_CLOUD = 0
+IF ( HCLOUD == 'KHKO' .OR. HCLOUD == 'C2R2' ) JKU_CLOUD = size( put, 3 )
+iztt = MNH_ALLOCATE_ZT3D( ztt ,JIU,JJU,JKU_CLOUD )
+izexne = MNH_ALLOCATE_ZT3D( zexne ,JIU,JJU,JKU_CLOUD )
+izlv = MNH_ALLOCATE_ZT3D( zlv ,JIU,JJU,JKU_CLOUD )
+izcph = MNH_ALLOCATE_ZT3D( zcph ,JIU,JJU,JKU_CLOUD )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+izshear = MNH_ALLOCATE_ZT3D( zshear,JIU,JJU, JKU_TURB )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+izdudz = MNH_ALLOCATE_ZT3D( zdudz ,JIU,JJU, JKU_TURB )
+izdvdz = MNH_ALLOCATE_ZT3D( zdvdz ,JIU,JJU, JKU_TURB )
+
+#endif
+
+#ifdef MNH_OPENACC
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+
+JKU_TURB = 0
+IF (HTURBDIM=="1DIM") JKU_TURB = size( pthlt, 3 )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU, JKU_TURB )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU, JKU_TURB )
+
+#endif
+
+!$acc data present( zcp, zexn, zt, zlocpexnm, zleps, ztrh, &
+!$acc & zatheta, zamoist, zcoef_diss, zfrac_ice, &
+!$acc & zmwth, zmwr, zmth2, zmr2, zmthr, &
+!$acc & zfwth, zfwr, zfth2, zfr2, zfthr, zthlm, &
+!$acc & zrm, &
+!$acc & ztau11m, ztau12m, ztau22m, ztau33m, &
+!$acc & zuslope, zvslope, zcdueff, zlmo, &
+!$acc & zustar, zrvm, zsfrv, &
+!$acc & ztt, zexne, zlv, zcph, zshear, zdudz, zdvdz, &
+!$acc & ztmp1_device, ztmp2_device, ztmp3_device )
+
+!------------------------------------------------------------------------------------------
+!
+!* 1.PRELIMINARIES
+! -------------
+!
+!* 1.1 Set the internal domains, ZEXPL
+!
+!
+IKT=SIZE(PTHLT,3)
+IKTB=1+JPVEXT_TURB
+IKTE=IKT-JPVEXT_TURB
+IKB=KKA+JPVEXT_TURB*KKL
+IKE=KKU-JPVEXT_TURB*KKL
+!
+ZEXPL = 1.- PIMPL
+ZRVORD= XRV / XRD
+!
+!
+!$acc update device(PTHLT,PRT)
+!$acc kernels
+!Copy data into ZTHLM and ZRM only if needed
+IF (HTURBLEN=='BL89' .OR. HTURBLEN=='RM17' .OR. ORMC01) THEN
+ ZTHLM(:,:,:) = PTHLT(:,:,:)
+ ZRM(:,:,:,:) = PRT(:,:,:,:)
+END IF
+!
+ZTRH(:, :, : ) = XUNDEF
+!
+!----------------------------------------------------------------------------
+!
+!* 2. COMPUTE CONSERVATIVE VARIABLES AND RELATED QUANTITIES
+! -----------------------------------------------------
+!
+!* 2.1 Cph at t
+!
+ZCP(:,:,:)=XCPD
+!
+IF (KRR > 0) ZCP(:,:,:) = ZCP(:,:,:) + XCPV * PRT(:,:,:,1)
+! PGI20.5 BUG or reproductibility problem , with pointer this loop on JRR parallelize whitout reduction
+!$acc loop seq
+DO JRR = 2,1+KRRL ! loop on the liquid components
+ ZCP(:,:,:) = ZCP(:,:,:) + XCL * PRT(:,:,:,JRR)
+END DO
+!
+!$acc loop seq
+DO JRR = 2+KRRL,1+KRRL+KRRI ! loop on the solid components
+ ZCP(:,:,:) = ZCP(:,:,:) + XCI * PRT(:,:,:,JRR)
+END DO
+!
+!* 2.2 Exner function at t
+!
+!PW: "BUG" PGI : results different on CPU and GPU due to the power function
+!See http://www.pgroup.com/userforum/viewtopic.php?t=5364&sid=ec7b762b17fb9bb3332a47f0db57af55
+!Use of own functions allows bit-reproducible results
+#ifndef MNH_BITREP
+ZEXN(:,:,:) = (PPABST(:,:,:)/XP00) ** (XRD/XCPD)
+#else
+ZEXN(:,:,:) = BR_POW(PPABST(:,:,:)/XP00,XRD/XCPD)
+#endif
+!
+!* 2.3 dissipative heating coeff a t
+!
+ZCOEF_DISS(:,:,:) = 1/(ZCP(:,:,:) * ZEXN(:,:,:))
+!
+!
+ZFRAC_ICE(:,:,:) = 0.0
+ZATHETA(:,:,:) = 0.0
+ZAMOIST(:,:,:) = 0.0
+!$acc end kernels
+!
+IF (KRRL >=1) THEN
+!
+!* 2.4 Temperature at t
+!
+!$acc kernels
+ ZT(:,:,:) = PTHLT(:,:,:) * ZEXN(:,:,:)
+!$acc end kernels
+!
+!* 2.5 Lv/Cph/Exn
+!
+ IF ( KRRI >= 1 ) THEN
+ ALLOCATE(ZLVOCPEXNM(JIU,JJU,JKU))
+ ALLOCATE(ZLSOCPEXNM(JIU,JJU,JKU))
+ ALLOCATE(ZAMOIST_ICE(JIU,JJU,JKU))
+ ALLOCATE(ZATHETA_ICE(JIU,JJU,JKU))
+
+!$acc enter data create( zlvocpexnm, zlsocpexnm )
+!$acc data create( zamoist_ice, zatheta_ice )
+
+ CALL COMPUTE_FUNCTION_THERMO(XALPW,XBETAW,XGAMW,XLVTT,XCL,ZT,ZEXN,ZCP, &
+ ZLVOCPEXNM,ZAMOIST,ZATHETA)
+ CALL COMPUTE_FUNCTION_THERMO(XALPI,XBETAI,XGAMI,XLSTT,XCI,ZT,ZEXN,ZCP, &
+ ZLSOCPEXNM,ZAMOIST_ICE,ZATHETA_ICE)
+!
+!$acc kernels
+ WHERE(PRT(:,:,:,2)+PRT(:,:,:,4)>0.0)
+ ZFRAC_ICE(:,:,:) = PRT(:,:,:,4) / ( PRT(:,:,:,2)+PRT(:,:,:,4) )
+ END WHERE
+!
+ ZLOCPEXNM(:,:,:) = (1.0-ZFRAC_ICE(:,:,:))*ZLVOCPEXNM(:,:,:) &
+ +ZFRAC_ICE(:,:,:) *ZLSOCPEXNM(:,:,:)
+ ZAMOIST(:,:,:) = (1.0-ZFRAC_ICE(:,:,:))*ZAMOIST(:,:,:) &
+ +ZFRAC_ICE(:,:,:) *ZAMOIST_ICE(:,:,:)
+ ZATHETA(:,:,:) = (1.0-ZFRAC_ICE(:,:,:))*ZATHETA(:,:,:) &
+ +ZFRAC_ICE(:,:,:) *ZATHETA_ICE(:,:,:)
+!$acc end kernels
+
+!$acc end data
+ DEALLOCATE(ZAMOIST_ICE)
+ DEALLOCATE(ZATHETA_ICE)
+ ELSE
+ CALL COMPUTE_FUNCTION_THERMO(XALPW,XBETAW,XGAMW,XLVTT,XCL,ZT,ZEXN,ZCP, &
+ ZLOCPEXNM,ZAMOIST,ZATHETA)
+ END IF
+!
+!
+ IF (OCLOSE_OUT .AND. OTURB_DIAG) THEN
+!$acc update self(ZAMOIST,ZATHETA)
+ TZFIELD%CMNHNAME = 'ATHETA'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'ATHETA'
+ TZFIELD%CUNITS = 'm'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_ATHETA'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZATHETA)
+!
+ TZFIELD%CMNHNAME = 'AMOIST'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'AMOIST'
+ TZFIELD%CUNITS = 'm'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_AMOIST'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZAMOIST)
+ END IF
+!
+ELSE
+!$acc kernels
+ ZLOCPEXNM=0.
+!$acc end kernels
+END IF ! loop end on KRRL >= 1
+!
+! computes conservative variables
+!
+!$acc update device(PRRS,PRTHLS)
+IF ( KRRL >= 1 ) THEN
+!$acc kernels
+ IF ( KRRI >= 1 ) THEN
+ ! Rnp at t
+ PRT(:,:,:,1) = PRT(:,:,:,1) + PRT(:,:,:,2) + PRT(:,:,:,4)
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) + PRRS(:,:,:,2) + PRRS(:,:,:,4)
+ ! Theta_l at t
+ PTHLT(:,:,:) = PTHLT(:,:,:) - ZLVOCPEXNM(:,:,:) * PRT(:,:,:,2) &
+ - ZLSOCPEXNM(:,:,:) * PRT(:,:,:,4)
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - ZLVOCPEXNM(:,:,:) * PRRS(:,:,:,2) &
+ - ZLSOCPEXNM(:,:,:) * PRRS(:,:,:,4)
+ ELSE
+ ! Rnp at t
+ PRT(:,:,:,1) = PRT(:,:,:,1) + PRT(:,:,:,2)
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) + PRRS(:,:,:,2)
+ ! Theta_l at t
+ PTHLT(:,:,:) = PTHLT(:,:,:) - ZLOCPEXNM(:,:,:) * PRT(:,:,:,2)
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - ZLOCPEXNM(:,:,:) * PRRS(:,:,:,2)
+ END IF
+!$acc end kernels
+END IF
+!
+!----------------------------------------------------------------------------
+!
+!* 3. MIXING LENGTH : SELECTION AND COMPUTATION
+! -----------------------------------------
+!
+!
+SELECT CASE (HTURBLEN)
+!
+!* 3.1 BL89 mixing length
+! ------------------
+
+ CASE ('BL89')
+!$acc kernels
+ ZSHEAR(:, :, : ) = 0.
+!$acc end kernels
+ CALL BL89(KKA,KKU,KKL,PZZ,PDZZ,PTHVREF,ZTHLM,KRR,ZRM,PTKET,ZSHEAR,PLEM)
+!
+!* 3.2 RM17 mixing length
+! ------------------
+
+ CASE ('RM17')
+#ifdef MNH_OPENACC
+ call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: HTURBLEN=RM17 not yet implemented' )
+#endif
+ ZDUDZ = MXF(MZF(GZ_U_UW(PUT,PDZZ)))
+ ZDVDZ = MYF(MZF(GZ_V_VW(PVT,PDZZ)))
+ ZSHEAR = SQRT(ZDUDZ*ZDUDZ + ZDVDZ*ZDVDZ)
+ CALL BL89(KKA,KKU,KKL,PZZ,PDZZ,PTHVREF,ZTHLM,KRR,ZRM,PTKET,ZSHEAR,PLEM)
+!
+!* 3.3 Delta mixing length
+! -------------------
+!
+ CASE ('DELT')
+ CALL DELT(KKA,KKU,KKL,IKB, IKE,IKTB, IKTE,ORMC01,HTURBDIM,PDXX, PDYY,PZZ,PDIRCOSZW,PLEM)
+!
+!* 3.4 Deardorff mixing length
+! -----------------------
+!
+ CASE ('DEAR')
+ CALL DEAR(KKA,KKU,KKL,KRR, KRRI, IKB, IKE,IKTB, IKTE, &
+ ORMC01,HTURBDIM,PDXX, PDYY, PDZZ,PZZ,PDIRCOSZW,PTHLT,PTHVREF,PTKET,PSRCT,PRT,&
+ ZLOCPEXNM,ZATHETA, ZAMOIST, PLEM)
+!* 3.5 Blackadar mixing length
+! -----------------------
+!
+ CASE ('BLKR')
+#ifdef MNH_OPENACC
+ call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: HTURBLEN=BLKR not yet implemented' )
+#endif
+ ZL0 = 100.
+ PLEM(:,:,:) = ZL0
+
+ ZALPHA=0.5**(-1.5)
+ !
+ DO JK=IKTB,IKTE
+ PLEM(:,:,JK) = ( 0.5*(PZZ(:,:,JK)+PZZ(:,:,JK+KKL)) - &
+ & PZZ(:,:,KKA+JPVEXT_TURB*KKL) ) * PDIRCOSZW(:,:)
+ PLEM(:,:,JK) = ZALPHA * PLEM(:,:,JK) * ZL0 / ( ZL0 + ZALPHA*PLEM(:,:,JK) )
+ END DO
+!
+ PLEM(:,:,IKTB-1) = PLEM(:,:,IKTB)
+ PLEM(:,:,IKTE+1) = PLEM(:,:,IKTE)
+!
+!
+!
+END SELECT
+!
+!
+!
+!* 3.5 Mixing length modification for cloud
+! -----------------------
+IF (KMODEL_CL==KMI .AND. HTURBLEN_CL/='NONE') THEN
+#ifdef MNH_OPENACC
+ call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: CLOUD_MODIF_LM not yet implemented' )
+#endif
+ CALL CLOUD_MODIF_LM
+END IF
+
+!
+!* 3.6 Dissipative length
+! ------------------
+!
+!$acc kernels
+ZLEPS(:,:,:)=PLEM(:,:,:)
+!
+!* 3.7 Correction in the Surface Boundary Layer (Redelsperger 2001)
+! ----------------------------------------
+!
+ZLMO=XUNDEF
+!$acc end kernels
+IF (ORMC01) THEN
+!$acc update self(PLEM,ZLEPS)
+#ifdef MNH_OPENACC
+ call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: ORMC01 not yet implemented' )
+#endif
+#ifndef MNH_BITREP
+ ZUSTAR=(PSFU**2+PSFV**2)**(0.25)
+#else
+ ZUSTAR=BR_POW(BR_P2(PSFU)+BR_P2(PSFV),0.25)
+#endif
+ IF (KRR>0) THEN
+ ZLMO=LMO(ZUSTAR,ZTHLM(:,:,IKB),ZRM(:,:,IKB,1),PSFTH,PSFRV)
+ ELSE
+ ZRVM=0.
+ ZSFRV=0.
+ ZLMO=LMO(ZUSTAR,ZTHLM(:,:,IKB),ZRVM,PSFTH,ZSFRV)
+ END IF
+ CALL RMC01(HTURBLEN,KKA,KKU,KKL,PZZ,PDXX,PDYY,PDZZ,PDIRCOSZW,PSBL_DEPTH,ZLMO,PLEM,ZLEPS)
+!$acc update device(PLEM,ZLEPS)
+END IF
+!
+!* 3.8 Mixing length in external points (used if HTURBDIM="3DIM")
+! ----------------------------------------------------------
+!
+IF (HTURBDIM=="3DIM") THEN
+ CALL UPDATE_LM(HLBCX,HLBCY,PLEM,ZLEPS)
+END IF
+!----------------------------------------------------------------------------
+!
+!* 4. GO INTO THE AXES FOLLOWING THE SURFACE
+! --------------------------------------
+!
+!
+!* 4.1 rotate the wind at time t
+!
+!
+!
+ IF (CPROGRAM/='AROME ') THEN
+ CALL ROTATE_WIND(PUT,PVT,PWT, &
+ PDIRCOSXW, PDIRCOSYW, PDIRCOSZW, &
+ PCOSSLOPE,PSINSLOPE, &
+ PDXX,PDYY,PDZZ, &
+ ZUSLOPE,ZVSLOPE )
+!
+ CALL UPDATE_ROTATE_WIND(ZUSLOPE,ZVSLOPE)
+ ELSE
+!$acc kernels
+ ZUSLOPE=PUT(:,:,KKA)
+ ZVSLOPE=PVT(:,:,KKA)
+!$acc end kernels
+ END IF
+!
+!
+!* 4.2 compute the proportionality coefficient between wind and stress
+!
+!$acc kernels
+#ifndef MNH_BITREP
+ ZCDUEFF(:,:) =-SQRT ( (PSFU(:,:)**2 + PSFV(:,:)**2) / &
+ (XMNH_TINY + ZUSLOPE(:,:)**2 + ZVSLOPE(:,:)**2 ) )
+#else
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZCDUEFF(JI,JJ) =-SQRT ( (BR_P2(PSFU(JI,JJ)) + BR_P2(PSFV(JI,JJ))) / &
+ (XMNH_TINY + BR_P2(ZUSLOPE(JI,JJ)) + BR_P2(ZVSLOPE(JI,JJ)) ) )
+ END DO
+#endif
+!$acc end kernels
+!
+!* 4.6 compute the surface tangential fluxes
+!
+!$acc kernels
+ZTAU11M(:,:) =2./3.*( (1.+ (PZZ (:,:,IKB+KKL)-PZZ (:,:,IKB)) &
+ /(PDZZ(:,:,IKB+KKL)+PDZZ(:,:,IKB)) &
+ ) *PTKET(:,:,IKB) &
+ -0.5 *PTKET(:,:,IKB+KKL) &
+ )
+ZTAU12M(:,:) =0.0
+ZTAU22M(:,:) =ZTAU11M(:,:)
+ZTAU33M(:,:) =ZTAU11M(:,:)
+!
+!* 4.7 third order terms in temperature and water fluxes and correlations
+! ------------------------------------------------------------------
+!
+!
+ZMWTH = 0. ! w'2th'
+ZMWR = 0. ! w'2r'
+ZMTH2 = 0. ! w'th'2
+ZMR2 = 0. ! w'r'2
+ZMTHR = 0. ! w'th'r'
+!$acc end kernels
+
+IF (HTOM=='TM06') THEN
+#ifndef MNH_OPENACC
+ CALL TM06(KKA,KKU,KKL,PTHVREF,PBL_DEPTH,PZZ,PSFTH,ZMWTH,ZMTH2)
+!
+ ZFWTH = -GZ_M_W(KKA,KKU,KKL,ZMWTH,PDZZ) ! -d(w'2th' )/dz
+ !ZFWR = -GZ_M_W(KKA,KKU,KKL,ZMWR, PDZZ) ! -d(w'2r' )/dz
+ ZFTH2 = -GZ_W_M(ZMTH2,PDZZ) ! -d(w'th'2 )/dz
+ !ZFR2 = -GZ_W_M(ZMR2, PDZZ) ! -d(w'r'2 )/dz
+ !ZFTHR = -GZ_W_M(ZMTHR,PDZZ) ! -d(w'th'r')/dz
+#else
+ call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: TM06 not yet implemented' )
+ CALL TM06(KKA,KKU,KKL,PTHVREF,PBL_DEPTH,PZZ,PSFTH,ZMWTH,ZMTH2)
+!
+ CALL GZ_M_W_DEVICE(KKA,KKU,KKL,ZMWTH,PDZZ,ZFWTH) ! -d(w'2th' )/dz
+ !CALL GZ_M_W_DEVICE(KKA,KKU,KKL,ZMWR, PDZZ,ZFWR) ! -d(w'2r' )/dz
+ CALL GZ_W_M_DEVICE(KKA,KKU,KKL,ZMTH2,PDZZ,ZFTH2) ! -d(w'th'2 )/dz
+ !CALL GZ_W_M_DEVICE(KKA,KKU,KKL,ZMR2, PDZZ,ZFR2) ! -d(w'r'2 )/dz
+ !CALL GZ_W_M_DEVICE(KKA,KKU,KKL,ZMTHR,PDZZ,ZFTHR) ! -d(w'th'r')/dz
+!$acc kernels
+ ZFWTH = -ZFWTH
+ !ZFWR = -ZFWR
+ ZFTH2 = -ZFTH2
+ !ZFR2 = -ZFR2
+ !ZFTHR = -ZFTHR
+#endif
+!
+ ZFWTH(:,:,IKTE:) = 0.
+ ZFWTH(:,:,:IKTB) = 0.
+ !ZFWR (:,:,IKTE:) = 0.
+ !ZFWR (:,:,:IKTB) = 0.
+ ZFWR = 0.
+ ZFTH2(:,:,IKTE:) = 0.
+ ZFTH2(:,:,:IKTB) = 0.
+ !ZFR2 (:,:,IKTE:) = 0.
+ !ZFR2 (:,:,:IKTB) = 0.
+ ZFR2 = 0.
+ !ZFTHR(:,:,IKTE:) = 0.
+ !ZFTHR(:,:,:IKTB) = 0.
+ ZFTHR = 0.
+!$acc end kernels
+ELSE
+!$acc kernels
+ ZFWTH = 0.
+ ZFWR = 0.
+ ZFTH2 = 0.
+ ZFR2 = 0.
+ ZFTHR = 0.
+!$acc end kernels
+ENDIF
+!
+!----------------------------------------------------------------------------
+!
+!* 5. TURBULENT SOURCES
+! -----------------
+!
+!$acc update device(PRHODJ)
+!$acc update device(PRUS,PRVS,PRWS,PRSVS)
+CALL TURB_VER(KKA,KKU,KKL,KRR, KRRL, KRRI, &
+ OCLOSE_OUT,OTURB_FLX, &
+ HTURBDIM,HTOM,PIMPL,ZEXPL, &
+ PTSTEP,TPFILE, &
+ PDXX,PDYY,PDZZ,PDZX,PDZY,PDIRCOSZW,PZZ, &
+ PCOSSLOPE,PSINSLOPE, &
+ PRHODJ,PTHVREF, &
+ PSFTH,PSFRV,PSFSV,PSFTH,PSFRV,PSFSV, &
+ ZCDUEFF,ZTAU11M,ZTAU12M,ZTAU33M, &
+ PUT,PVT,PWT,ZUSLOPE,ZVSLOPE,PTHLT,PRT,PSVT, &
+ PTKET,PLEM,ZLEPS, &
+ ZLOCPEXNM,ZATHETA,ZAMOIST,PSRCT,ZFRAC_ICE, &
+ ZFWTH,ZFWR,ZFTH2,ZFR2,ZFTHR,PBL_DEPTH, &
+ PSBL_DEPTH,ZLMO, &
+ PRUS,PRVS,PRWS,PRTHLS,PRRS,PRSVS, &
+ PDYP,PTHP,PSIGS,PWTH,PWRC,PWSV )
+!$acc update self(PWTH,PWRC,PWSV)
+!
+#ifdef MNH_OPENACC
+IF ( ( LBUDGET_TH .AND. ( ( KRRI >= 1 .AND. KRRL >= 1 ) .OR. ( KRRL >= 1 ) ) ) .OR. &
+ LBUDGET_RV .OR. LBUDGET_RC .OR. LBUDGET_RI ) THEN
+!$acc update self(PRRS)
+ENDIF
+#endif
+!
+IF (LBUDGET_U) THEN
+!$acc update self(PRUS)
+ CALL BUDGET (PRUS,1,'VTURB_BU_RU')
+END IF
+IF (LBUDGET_V) THEN
+!$acc update self(PRVS)
+ CALL BUDGET (PRVS,2,'VTURB_BU_RV')
+END IF
+IF (LBUDGET_W) THEN
+!$acc update self(PRWS)
+ CALL BUDGET (PRWS,3,'VTURB_BU_RW')
+END IF
+IF (LBUDGET_TH) THEN
+!$acc update self(PRTHLS)
+ IF ( KRRI >= 1 .AND. KRRL >= 1 ) THEN
+!$acc update self(ZLVOCPEXNM,ZLSOCPEXNM)
+ CALL BUDGET (PRTHLS+ ZLVOCPEXNM * PRRS(:,:,:,2) + ZLSOCPEXNM * PRRS(:,:,:,4),4,'VTURB_BU_RTH')
+ ELSE IF ( KRRL >= 1 ) THEN
+!$acc update self(ZLOCPEXNM)
+ CALL BUDGET (PRTHLS+ ZLOCPEXNM * PRRS(:,:,:,2),4,'VTURB_BU_RTH')
+ ELSE
+ CALL BUDGET (PRTHLS,4,'VTURB_BU_RTH')
+ END IF
+END IF
+IF (LBUDGET_SV) THEN
+!$acc update self(PRSVS)
+ DO JSV = 1,NSV
+ CALL BUDGET (PRSVS(:,:,:,JSV),JSV+12,'VTURB_BU_RSV')
+ END DO
+END IF
+IF (LBUDGET_RV) THEN
+ IF ( KRRI >= 1 .AND. KRRL >= 1) THEN
+ CALL BUDGET (PRRS(:,:,:,1)-PRRS(:,:,:,2)-PRRS(:,:,:,4),6,'VTURB_BU_RRV')
+ ELSE IF ( KRRL >= 1 ) THEN
+ CALL BUDGET (PRRS(:,:,:,1)-PRRS(:,:,:,2),6,'VTURB_BU_RRV')
+ ELSE
+ CALL BUDGET (PRRS(:,:,:,1),6,'VTURB_BU_RRV')
+ END IF
+END IF
+IF (LBUDGET_RC) CALL BUDGET (PRRS(:,:,:,2),7,'VTURB_BU_RRC')
+IF (LBUDGET_RI) CALL BUDGET (PRRS(:,:,:,4),9,'VTURB_BU_RRI')
+!
+!
+IF (HTURBDIM=='3DIM') THEN
+ CALL TURB_HOR_SPLT(KSPLIT, KRR, KRRL, KRRI, PTSTEP, &
+ HLBCX,HLBCY,OCLOSE_OUT,OTURB_FLX,OSUBG_COND, &
+ TPFILE, &
+ PDXX,PDYY,PDZZ,PDZX,PDZY,PZZ, &
+ PDIRCOSXW,PDIRCOSYW,PDIRCOSZW, &
+ PCOSSLOPE,PSINSLOPE, &
+ PRHODJ,PTHVREF, &
+ PSFTH,PSFRV,PSFSV, &
+ ZCDUEFF,ZTAU11M,ZTAU12M,ZTAU22M,ZTAU33M, &
+ PUT,PVT,PWT,ZUSLOPE,ZVSLOPE,PTHLT,PRT,PSVT, &
+ PTKET,PLEM,ZLEPS, &
+ ZLOCPEXNM,ZATHETA,ZAMOIST,PSRCT,ZFRAC_ICE, &
+ PDYP,PTHP,PSIGS, &
+ ZTRH, &
+ PRUS,PRVS,PRWS,PRTHLS,PRRS,PRSVS )
+END IF
+!$acc update self(PSIGS,PRUS,PRVS,PRWS,PRSVS)
+!
+!
+#ifdef MNH_OPENACC
+IF ( ( LBUDGET_TH .AND. ( ( KRRI >= 1 .AND. KRRL >= 1 ) .OR. ( KRRL >= 1 ) ) ) .OR. &
+ LBUDGET_RV .OR. LBUDGET_RC .OR. LBUDGET_RI ) THEN
+!$acc update self(PRRS)
+ENDIF
+#endif
+!
+IF (LBUDGET_U) CALL BUDGET (PRUS,1,'HTURB_BU_RU')
+IF (LBUDGET_V) CALL BUDGET (PRVS,2,'HTURB_BU_RV')
+IF (LBUDGET_W) CALL BUDGET (PRWS,3,'HTURB_BU_RW')
+IF (LBUDGET_TH) THEN
+!$acc update self(PRTHLS)
+ IF ( KRRI >= 1 .AND. KRRL >= 1 ) THEN
+ CALL BUDGET (PRTHLS+ZLVOCPEXNM*PRRS(:,:,:,2)+ZLSOCPEXNM*PRRS(:,:,:,4) &
+ ,4,'HTURB_BU_RTH')
+ ELSE IF ( KRRL >= 1 ) THEN
+ CALL BUDGET (PRTHLS+ ZLOCPEXNM * PRRS(:,:,:,2),4,'HTURB_BU_RTH')
+ ELSE
+ CALL BUDGET (PRTHLS,4,'HTURB_BU_RTH')
+ END IF
+END IF
+IF (LBUDGET_SV) THEN
+ DO JSV = 1,NSV
+ CALL BUDGET (PRSVS(:,:,:,JSV),JSV+12,'HTURB_BU_RSV')
+ END DO
+END IF
+IF (LBUDGET_RV) THEN
+ IF ( KRRI >= 1 .AND. KRRL >= 1) THEN
+ CALL BUDGET (PRRS(:,:,:,1)-PRRS(:,:,:,2)-PRRS(:,:,:,4),6,'HTURB_BU_RRV')
+ ELSE IF ( KRRL >= 1 ) THEN
+ CALL BUDGET (PRRS(:,:,:,1)-PRRS(:,:,:,2),6,'HTURB_BU_RRV')
+ ELSE
+ CALL BUDGET (PRRS(:,:,:,1),6,'HTURB_BU_RRV')
+ END IF
+END IF
+IF (LBUDGET_RC) CALL BUDGET (PRRS(:,:,:,2),7,'HTURB_BU_RRC')
+IF (LBUDGET_RI) CALL BUDGET (PRRS(:,:,:,4),9,'HTURB_BU_RRI')
+!
+!----------------------------------------------------------------------------
+!
+!* 6. EVOLUTION OF THE TKE AND ITS DISSIPATION
+! ----------------------------------------
+!
+! 6.1 Contribution of mass-flux in the TKE buoyancy production if
+! cloud computation is not statistical
+#ifndef MNH_OPENACC
+ PTHP = PTHP + XG / PTHVREF * MZF( PFLXZTHVMF )
+#else
+ CALL MZF_DEVICE(KKA,KKU,KKL,PFLXZTHVMF,ZTMP1_DEVICE)
+!$acc kernels
+ PTHP(:,:,:) = PTHP(:,:,:) + XG / PTHVREF(:,:,:) * ZTMP1_DEVICE(:,:,:)
+!$acc end kernels
+#endif
+
+! 6.2 TKE evolution equation
+!$acc update device(PRTKES)
+CALL TKE_EPS_SOURCES(KKA,KKU,KKL,KMI,PTKET,PLEM,ZLEPS,PDYP,ZTRH, &
+ PRHODJ,PDZZ,PDXX,PDYY,PDZX,PDZY,PZZ, &
+ PTSTEP,PIMPL,ZEXPL, &
+ HTURBLEN,HTURBDIM, &
+ TPFILE,OCLOSE_OUT,OTURB_DIAG, &
+ PTHP,PRTKES,PRTKEMS,PRTHLS,ZCOEF_DISS,PTR,PDISS )
+!
+!$acc update self(PTR,PDISS)
+!$acc update self(PDYP,PTHP)
+!
+!$acc update self(PRTKES)
+IF (LBUDGET_TH) THEN
+!$acc update self(PRTHLS)
+ IF ( KRRI >= 1 .AND. KRRL >= 1 ) THEN
+ CALL BUDGET (PRTHLS+ZLVOCPEXNM*PRRS(:,:,:,2)+ZLSOCPEXNM*PRRS(:,:,:,4) &
+ ,4,'DISSH_BU_RTH')
+ ELSE IF ( KRRL >= 1 ) THEN
+ CALL BUDGET (PRTHLS+ZLOCPEXNM* PRRS(:,:,:,2),4,'DISSH_BU_RTH')
+ ELSE
+ CALL BUDGET (PRTHLS,4,'DISSH_BU_RTH')
+ END IF
+END IF
+!
+!----------------------------------------------------------------------------
+!
+!* 7. STORES SOME INFORMATIONS RELATED TO THE TURBULENCE SCHEME
+! ---------------------------------------------------------
+!
+!$acc update self(PLEM)
+!
+IF ( OTURB_DIAG .AND. OCLOSE_OUT ) THEN
+!
+! stores the mixing length
+!
+ TZFIELD%CMNHNAME = 'LM'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'LM'
+ TZFIELD%CUNITS = 'm'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'Mixing length'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,PLEM)
+!
+ IF (KRR /= 0) THEN
+!
+! stores the conservative potential temperature
+!
+ TZFIELD%CMNHNAME = 'THLM'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'THLM'
+ TZFIELD%CUNITS = 'K'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'Conservative potential temperature'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+!$acc update self(PTHLT)
+ CALL IO_Field_write(TPFILE,TZFIELD,PTHLT)
+!
+! stores the conservative mixing ratio
+!
+ TZFIELD%CMNHNAME = 'RNPM'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'RNPM'
+ TZFIELD%CUNITS = 'kg kg-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'Conservative mixing ratio'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+!$acc update self(PRT)
+ CALL IO_Field_write(TPFILE,TZFIELD,PRT(:,:,:,1))
+ END IF
+END IF
+!
+!----------------------------------------------------------------------------
+!
+!* 8. RETRIEVE NON-CONSERVATIVE VARIABLES
+! -----------------------------------
+!
+IF ( KRRL >= 1 ) THEN
+ IF ( KRRI >= 1 ) THEN
+!$acc kernels
+ PRT(:,:,:,1) = PRT(:,:,:,1) - PRT(:,:,:,2) - PRT(:,:,:,4)
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) - PRRS(:,:,:,2) - PRRS(:,:,:,4)
+ PTHLT(:,:,:) = PTHLT(:,:,:) + ZLVOCPEXNM(:,:,:) * PRT(:,:,:,2) &
+ + ZLSOCPEXNM(:,:,:) * PRT(:,:,:,4)
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) + ZLVOCPEXNM(:,:,:) * PRRS(:,:,:,2) &
+ + ZLSOCPEXNM(:,:,:) * PRRS(:,:,:,4)
+!$acc end kernels
+!$acc update self(PRT(:,:,:,1))
+!
+!$acc exit data delete( zlvocpexnm, zlsocpexnm )
+ DEALLOCATE(ZLVOCPEXNM)
+ DEALLOCATE(ZLSOCPEXNM)
+ ELSE
+!$acc kernels
+ PRT(:,:,:,1) = PRT(:,:,:,1) - PRT(:,:,:,2)
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) - PRRS(:,:,:,2)
+ PTHLT(:,:,:) = PTHLT(:,:,:) + ZLOCPEXNM(:,:,:) * PRT(:,:,:,2)
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) + ZLOCPEXNM(:,:,:) * PRRS(:,:,:,2)
+!$acc end kernels
+!$acc update self(PRT(:,:,:,1))
+ END IF
+END IF
+!$acc update self(PRRS,PTHLT,PRTHLS)
+!
+IF ((HCLOUD == 'KHKO') .OR. (HCLOUD == 'C2R2')) THEN
+#ifdef MNH_OPENACC
+ call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: HCLOUD=KHKO or C2R2 not yet implemented' )
+#endif
+ ZEXNE(:,:,:)= (PPABST(:,:,:)/XP00)**(XRD/XCPD)
+ ZTT(:,:,:)= PTHLT(:,:,:)*ZEXNE(:,:,:)
+ ZLV(:,:,:)=XLVTT +(XCPV-XCL) *(ZTT(:,:,:)-XTT)
+ ZCPH(:,:,:)=XCPD +XCPV*PRT(:,:,:,1)
+! CALL GET_HALO(PRRS(:,:,:,2))
+! CALL GET_HALO(PRSVS(:,:,:,2))
+! CALL GET_HALO(PRSVS(:,:,:,3))
+ WHERE (PRRS(:,:,:,2) < 0. .OR. PRSVS(:,:,:,2) < 0.)
+ PRSVS(:,:,:,1) = 0.0
+ END WHERE
+ DO JSV = 2, 3
+ WHERE (PRRS(:,:,:,JSV) < 0. .OR. PRSVS(:,:,:,JSV) < 0.)
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) + PRRS(:,:,:,JSV)
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - PRRS(:,:,:,JSV) * ZLV(:,:,:) / &
+ ZCPH(:,:,:) / ZEXNE(:,:,:)
+ PRRS(:,:,:,JSV) = 0.0
+ PRSVS(:,:,:,JSV) = 0.0
+ END WHERE
+ END DO
+!
+ IF (LBUDGET_TH) CALL BUDGET (PRTHLS(:,:,:), 4,'NETUR_BU_RTH')
+ IF (LBUDGET_RV) CALL BUDGET (PRRS(:,:,:,1), 6,'NETUR_BU_RRV')
+ IF (LBUDGET_RC) CALL BUDGET (PRRS(:,:,:,2), 7,'NETUR_BU_RRC')
+END IF
+!
+!----------------------------------------------------------------------------
+!
+!* 9. LES averaged surface fluxes
+! ---------------------------
+!
+IF (LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+!$acc data copy(X_LES_Q0,X_LES_E0,X_LES_SV0,X_LES_UW0,X_LES_VW0,X_LES_USTAR)
+ CALL LES_MEAN_SUBGRID(PSFTH,X_LES_Q0)
+ CALL LES_MEAN_SUBGRID(PSFRV,X_LES_E0)
+ DO JSV=1,NSV
+ CALL LES_MEAN_SUBGRID(PSFSV(:,:,JSV),X_LES_SV0(:,JSV))
+ END DO
+ CALL LES_MEAN_SUBGRID(PSFU,X_LES_UW0)
+ CALL LES_MEAN_SUBGRID(PSFV,X_LES_VW0)
+#ifndef MNH_OPENACC
+ CALL LES_MEAN_SUBGRID((PSFU*PSFU+PSFV*PSFV)**0.25,X_LES_USTAR)
+#else
+!$acc kernels
+ ZTMP1_DEVICE(:,:,1) = (PSFU*PSFU+PSFV*PSFV)**0.25
+!$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP1_DEVICE(:,:,1),X_LES_USTAR)
+#endif
+!$acc end data
+!----------------------------------------------------------------------------
+!
+!* 10. LES for 3rd order moments
+! -------------------------
+!
+!$acc data copy(X_LES_SUBGRID_W2Thl,X_LES_SUBGRID_WThl2)
+ CALL LES_MEAN_SUBGRID(ZMWTH,X_LES_SUBGRID_W2Thl)
+ CALL LES_MEAN_SUBGRID(ZMTH2,X_LES_SUBGRID_WThl2)
+!$acc end data
+ IF (KRR>0) THEN
+!$acc data copy(X_LES_SUBGRID_W2Rt,X_LES_SUBGRID_WThlRt,X_LES_SUBGRID_WRt2)
+ CALL LES_MEAN_SUBGRID(ZMWR,X_LES_SUBGRID_W2Rt)
+ CALL LES_MEAN_SUBGRID(ZMTHR,X_LES_SUBGRID_WThlRt)
+ CALL LES_MEAN_SUBGRID(ZMR2,X_LES_SUBGRID_WRt2)
+!$acc end data
+ END IF
+!
+!----------------------------------------------------------------------------
+!
+!* 11. LES quantities depending on <w'2> in "1DIM" mode
+! ------------------------------------------------
+!
+#ifndef MNH_OPENACC
+ IF (HTURBDIM=="1DIM") THEN
+ CALL LES_MEAN_SUBGRID(2./3.*PTKET,X_LES_SUBGRID_U2)
+ X_LES_SUBGRID_V2 = X_LES_SUBGRID_U2
+ X_LES_SUBGRID_W2 = X_LES_SUBGRID_U2
+ CALL LES_MEAN_SUBGRID(2./3.*PTKET*MZF(&
+ & GZ_M_W(KKA,KKU,KKL,PTHLT,PDZZ)),X_LES_RES_ddz_Thl_SBG_W2)
+ IF (KRR>=1) &
+ CALL LES_MEAN_SUBGRID(2./3.*PTKET*MZF(&
+ & GZ_M_W(KKA,KKU,KKL,PRT(:,:,:,1),PDZZ)),X_LES_RES_ddz_Rt_SBG_W2)
+ DO JSV=1,NSV
+ CALL LES_MEAN_SUBGRID(2./3.*PTKET*MZF(&
+ & GZ_M_W(KKA,KKU,KKL,PSVT(:,:,:,JSV),PDZZ)),X_LES_RES_ddz_Sv_SBG_W2(:,:,:,JSV))
+ END DO
+ END IF
+#else
+ IF (HTURBDIM=="1DIM") THEN
+!$acc data copy(X_LES_SUBGRID_U2,X_LES_SUBGRID_V2,X_LES_SUBGRID_W2,X_LES_RES_ddz_Thl_SBG_W2)
+!$acc kernels
+ ZTMP1_DEVICE = 2./3.*PTKET
+!$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP1_DEVICE,X_LES_SUBGRID_U2)
+!$acc kernels
+ X_LES_SUBGRID_V2 = X_LES_SUBGRID_U2
+ X_LES_SUBGRID_W2 = X_LES_SUBGRID_U2
+!$acc end kernels
+ CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PTHLT,PDZZ,ZTMP2_DEVICE)
+ CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE,ZTMP3_DEVICE)
+!$acc kernels
+ ZTMP2_DEVICE = ZTMP1_DEVICE*ZTMP3_DEVICE
+!$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP2_DEVICE,X_LES_RES_ddz_Thl_SBG_W2)
+!$acc end data
+ IF (KRR>=1) THEN
+!$acc data copy(X_LES_RES_ddz_Rt_SBG_W2)
+ CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PRT(:,:,:,1),PDZZ,ZTMP2_DEVICE)
+ CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE,ZTMP3_DEVICE)
+!$acc kernels
+ ZTMP2_DEVICE = ZTMP1_DEVICE*PTKET*ZTMP3_DEVICE
+!$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP2_DEVICE,X_LES_RES_ddz_Rt_SBG_W2)
+!$acc end data
+ END IF
+!$acc data copy(X_LES_RES_ddz_Sv_SBG_W2(:,:,:,1:NSV))
+ DO JSV=1,NSV
+ CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PSVT(:,:,:,JSV),PDZZ,ZTMP2_DEVICE)
+ CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE,ZTMP3_DEVICE)
+!$acc kernels
+ ZTMP2_DEVICE = ZTMP1_DEVICE*PTKET*ZTMP3_DEVICE
+!$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP2_DEVICE,X_LES_RES_ddz_Sv_SBG_W2(:,:,:,JSV))
+ END DO
+!$acc end data
+ END IF
+#endif
+!----------------------------------------------------------------------------
+!
+!* 12. LES mixing end dissipative lengths, presso-correlations
+! -------------------------------------------------------
+!
+!$acc data copy(X_LES_SUBGRID_LMix,X_LES_SUBGRID_LDiss,X_LES_SUBGRID_WP)
+ CALL LES_MEAN_SUBGRID(PLEM,X_LES_SUBGRID_LMix)
+ CALL LES_MEAN_SUBGRID(ZLEPS,X_LES_SUBGRID_LDiss)
+!
+!* presso-correlations for subgrid Tke are equal to zero.
+!
+!$acc kernels
+ ZLEPS = 0. !ZLEPS is used as a work array (not used anymore)
+!$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZLEPS,X_LES_SUBGRID_WP)
+!$acc end data
+!
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( pbl_depth, "Turb end:pbl_depth" )
+ call Mppdb_check( psbl_depth, "Turb end:psbl_depth" )
+ call Mppdb_check( pthlt, "Turb end:pthlt" )
+ call Mppdb_check( prt, "Turb end:prt" )
+ call Mppdb_check( prus, "Turb end:prus" )
+ call Mppdb_check( prvs, "Turb end:prvs" )
+ call Mppdb_check( prws, "Turb end:prws" )
+ call Mppdb_check( prthls, "Turb end:prthls" )
+ call Mppdb_check( prtkes, "Turb end:prtkes" )
+ call Mppdb_check( prrs, "Turb end:prrs" )
+ call Mppdb_check( prsvs, "Turb end:prsvs" )
+ !check all out arrays
+ call Mppdb_check( psigs, "Turb end:psigs" )
+ call Mppdb_check( pwth, "Turb end:pwth" )
+ call Mppdb_check( pwrc, "Turb end:pwrc" )
+ call Mppdb_check( pwsv, "Turb end:pwsv" )
+ call Mppdb_check( pdyp, "Turb end:pdyp" )
+ call Mppdb_check( pthp, "Turb end:pthp" )
+ call Mppdb_check( ptr, "Turb end:ptr" )
+ call Mppdb_check( pdiss, "Turb end:pdiss" )
+ call Mppdb_check( plem, "Turb end:plem" )
+end if
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+deallocate( zcp, zexn, zt, zlocpexnm, zleps, ztrh, &
+ zatheta, zamoist, zcoef_diss, zfrac_ice, &
+ zmwth, zmwr, zmth2, zmr2, zmthr, &
+ zfwth, zfwr, zfth2, zfr2, zfthr, zthlm, &
+ zrm, &
+ ztau11m, ztau12m, ztau22m, ztau33m, &
+ zuslope, zvslope, zcdueff, zlmo, &
+ zustar, zrvm, zsfrv, &
+ ztt, zexne, zlv, zcph, zshear, zdudz, zdvdz )
+#else
+
+CALL MNH_REL_ZT3D ( iztt, izexne, izlv, izcph, izshear, izdudz, izdvdz, &
+ iztmp1_device, iztmp2_device, iztmp3_device )
+
+CALL MNH_REL_ZT3D ( iztau11m, iztau12m, iztau22m, iztau33m, &
+ izuslope, izvslope, izcdueff, izlmo, &
+ izustar, izrvm, izsfrv )
+
+CALL MNH_REL_ZT3D ( izrm)
+
+CALL MNH_REL_ZT3D ( izmwth, izmwr, izmth2, izmr2, izmthr, &
+ izfwth, izfwr, izfth2, izfr2, izfthr, izthlm )
+
+CALL MNH_REL_ZT3D ( izcp, izexn, izt, izlocpexnm, izleps, iztrh, &
+ izatheta, izamoist, izcoef_diss, izfrac_ice )
+
+CALL MNH_CHECK_OUT_ZT3D("TURB")
+#endif
+
+!$acc end data
+
+!----------------------------------------------------------------------------
+!
+CONTAINS
+!
+!
+! ##############################################
+ SUBROUTINE UPDATE_ROTATE_WIND(PUSLOPE,PVSLOPE)
+! ##############################################
+!!
+!!**** *UPDATE_ROTATE_WIND* routine to set rotate wind values at the border
+!
+!! AUTHOR
+!! ------
+!!
+!! P Jabouille *CNRM METEO-FRANCE
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/06/99
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_CONF
+!
+USE MODI_GET_HALO
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PUSLOPE,PVSLOPE
+! tangential surface fluxes in the axes following the orography
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IIB,IIE,IJB,IJE ! index values for the physical subdomain
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+INTEGER :: IINFO_ll ! return code of parallel routine
+logical :: gwest, geast, gnorth, gsouth
+!
+!* 1 PROLOGUE
+!
+!$acc data present( PUSLOPE, PVSLOPE )
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( puslope, "Update_rotate_wind beg:puslope" )
+ call Mppdb_check( pvslope, "Update_rotate_wind beg:pvslope" )
+end if
+
+NULLIFY(TZFIELDS_ll)
+!
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+!
+! 2 Update halo if necessary
+!
+!!$IF (NHALO == 1) THEN
+!!$!$acc update self(PUSLOPE,PVSLOPE)
+!!$ CALL ADD2DFIELD_ll( TZFIELDS_ll, PUSLOPE, 'UPDATE_ROTATE_WIND::PUSLOPE' )
+!!$ CALL ADD2DFIELD_ll( TZFIELDS_ll, PVSLOPE, 'UPDATE_ROTATE_WIND::PVSLOPE' )
+!!$ CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+!!$ CALL CLEANLIST_ll(TZFIELDS_ll)
+!!$!$acc update device(PUSLOPE,PVSLOPE)
+!
+! /!\ warning conner needed -> GET_HALO...C
+!
+CALL GET_2D_HALO_DDC( PUSLOPE, HNAME='UPDATE_ROTATE_WIND::PUSLOPE' )
+CALL GET_2D_HALO_DDC( PVSLOPE, HNAME='UPDATE_ROTATE_WIND::PVSLOPE' )
+!!$ENDIF
+!
+! 3 Boundary conditions for non cyclic case
+!
+gwest = HLBCX(1) /= "CYCL" .AND. LWEST_ll()
+geast = HLBCX(2) /= "CYCL" .AND. LEAST_ll()
+gsouth = HLBCY(1) /= "CYCL" .AND. LSOUTH_ll()
+gnorth = HLBCY(2) /= "CYCL" .AND. LNORTH_ll()
+
+!$acc kernels
+IF ( gwest ) THEN
+ PUSLOPE(IIB-1,:)=PUSLOPE(IIB,:)
+ PVSLOPE(IIB-1,:)=PVSLOPE(IIB,:)
+END IF
+IF ( geast ) THEN
+ PUSLOPE(IIE+1,:)=PUSLOPE(IIE,:)
+ PVSLOPE(IIE+1,:)=PVSLOPE(IIE,:)
+END IF
+IF ( gsouth ) THEN
+ PUSLOPE(:,IJB-1)=PUSLOPE(:,IJB)
+ PVSLOPE(:,IJB-1)=PVSLOPE(:,IJB)
+END IF
+IF ( gnorth ) THEN
+ PUSLOPE(:,IJE+1)=PUSLOPE(:,IJE)
+ PVSLOPE(:,IJE+1)=PVSLOPE(:,IJE)
+END IF
+!$acc end kernels
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( puslope, "Update_rotate_wind end:puslope" )
+ call Mppdb_check( pvslope, "Update_rotate_wind end:pvslope" )
+end if
+
+!$acc end data
+
+END SUBROUTINE UPDATE_ROTATE_WIND
+!
+! ########################################################################
+ SUBROUTINE COMPUTE_FUNCTION_THERMO(PALP,PBETA,PGAM,PLTT,PC,PT,PEXN,PCP,&
+ PLOCPEXN,PAMOIST,PATHETA )
+! ########################################################################
+!!
+!!**** *COMPUTE_FUNCTION_THERMO* routine to compute several thermo functions
+!
+!! AUTHOR
+!! ------
+!!
+!! JP Pinty *LA*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/02/03
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_CST
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments
+!
+REAL, INTENT(IN) :: PALP,PBETA,PGAM,PLTT,PC
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PT,PEXN,PCP
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLOCPEXN
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAMOIST,PATHETA
+!
+!* 0.2 Declarations of local variables
+!
+REAL :: ZEPS ! XMV / XMD
+real, dimension(:,:,:), pointer , contiguous :: zrvsat
+real, dimension(:,:,:), pointer , contiguous :: zdrvsatdt
+INTEGER :: izrvsat, izdrvsatdt
+!
+!-------------------------------------------------------------------------------
+
+!$acc data present( PT, PEXN, PCP, PLOCPEXN, PAMOIST, PATHETA )
+
+ if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pt, "Compute_function_thermo beg:pt" )
+ call Mppdb_check( pexn, "Compute_function_thermo beg:pexn" )
+ call Mppdb_check( pcp, "Compute_function_thermo beg:pcp" )
+ end if
+
+#ifndef MNH_OPENACC
+ allocate( zrvsat ( size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) ) )
+ allocate( zdrvsatdt( size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) ) )
+#else
+izrvsat = MNH_ALLOCATE_ZT3D( zrvsat , size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
+izdrvsatdt = MNH_ALLOCATE_ZT3D( zdrvsatdt, size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
+#endif
+
+!$acc data present( zrvsat, zdrvsatdt )
+
+ ZEPS = XMV / XMD
+!
+!* 1.1 Lv/Cph at t
+!
+!$acc kernels
+ PLOCPEXN(:,:,:) = ( PLTT + (XCPV-PC) * (PT(:,:,:)-XTT) ) / PCP(:,:,:)
+!
+!* 1.2 Saturation vapor pressure at t
+!
+!PW: "BUG" PGI : results different on CPU and GPU due to the EXP and LOG functions
+!See http://www.pgroup.com/userforum/viewtopic.php?t=5364&sid=ec7b762b17fb9bb3332a47f0db57af55
+!Use of own functions allows bit-reproducible results
+#ifndef MNH_BITREP
+ ZRVSAT(:,:,:) = EXP( PALP - PBETA/PT(:,:,:) - PGAM*ALOG( PT(:,:,:) ) )
+#else
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZRVSAT(JI,JJ,JK) = BR_EXP( PALP - PBETA/PT(JI,JJ,JK) - PGAM*BR_LOG( PT(JI,JJ,JK) ) )
+ END DO
+#endif
+!
+!* 1.3 saturation mixing ratio at t
+!
+ ZRVSAT(:,:,:) = ZRVSAT(:,:,:) * ZEPS / ( PPABST(:,:,:) - ZRVSAT(:,:,:) )
+!
+!* 1.4 compute the saturation mixing ratio derivative (rvs')
+!
+ ZDRVSATDT(:,:,:) = ( PBETA / PT(:,:,:) - PGAM ) / PT(:,:,:) &
+ * ZRVSAT(:,:,:) * ( 1. + ZRVSAT(:,:,:) / ZEPS )
+!
+!* 1.5 compute Amoist
+!
+ PAMOIST(:,:,:)= 0.5 / ( 1.0 + ZDRVSATDT(:,:,:) * PLOCPEXN(:,:,:) )
+!
+!* 1.6 compute Atheta
+!
+ PATHETA(:,:,:)= PAMOIST(:,:,:) * PEXN(:,:,:) * &
+ ( ( ZRVSAT(:,:,:) - PRT(:,:,:,1) ) * PLOCPEXN(:,:,:) / &
+ ( 1. + ZDRVSATDT(:,:,:) * PLOCPEXN(:,:,:) ) * &
+ ( &
+ ZRVSAT(:,:,:) * (1. + ZRVSAT(:,:,:)/ZEPS) &
+#ifndef MNH_BITREP
+ * ( -2.*PBETA/PT(:,:,:) + PGAM ) / PT(:,:,:)**2 &
+#else
+ * ( -2.*PBETA/PT(:,:,:) + PGAM ) / BR_P2(PT(:,:,:)) &
+#endif
+ +ZDRVSATDT(:,:,:) * (1. + 2. * ZRVSAT(:,:,:)/ZEPS) &
+ * ( PBETA/PT(:,:,:) - PGAM ) / PT(:,:,:) &
+ ) &
+ - ZDRVSATDT(:,:,:) &
+ )
+!
+!* 1.7 Lv/Cph/Exner at t-1
+!
+ PLOCPEXN(:,:,:) = PLOCPEXN(:,:,:) / PEXN(:,:,:)
+!$acc end kernels
+
+
+
+ if ( mppdb_initialized ) then
+ !Check all out arrays
+ call Mppdb_check( plocpexn, "Compute_function_thermo end:plocpexn" )
+ call Mppdb_check( pamoist, "Compute_function_thermo end:pamoist" )
+ call Mppdb_check( patheta, "Compute_function_thermo end:patheta" )
+ end if
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+ deallocate( zrvsat, zdrvsatdt )
+#else
+ CALL MNH_REL_ZT3D(izrvsat, izdrvsatdt )
+#endif
+
+!$acc end data
+
+END SUBROUTINE COMPUTE_FUNCTION_THERMO
+!
+!
+! #########################
+ SUBROUTINE CLOUD_MODIF_LM
+! #########################
+!!
+!!*****CLOUD_MODIF_LM routine to:
+!! 1/ change the mixing length in the clouds
+!! 2/ emphasize the mixing length in the cloud
+!! by the coefficient ZCOEF_AMPL calculated here
+!! when the CEI index is above ZCEI_MIN.
+!!
+!!
+!! ZCOEF_AMPL ^
+!! |
+!! |
+!! ZCOEF_AMPL_SAT - ---------- Saturation
+!! (XDUMMY1) | -
+!! | -
+!! | -
+!! | -
+!! | - Amplification
+!! | - straight
+!! | - line
+!! | -
+!! | -
+!! | -
+!! | -
+!! | -
+!! 1 ------------
+!! |
+!! |
+!! 0 -----------|------------|----------> PCEI
+!! 0 ZCEI_MIN ZCEI_MAX
+!! (XDUMMY2) (XDUMMY3)
+!!
+!!
+!!
+!! AUTHOR
+!! ------
+!! M. Tomasini *CNRM METEO-FRANCE
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 09/07/04
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+REAL :: ZPENTE ! Slope of the amplification straight line
+REAL :: ZCOEF_AMPL_CEI_NUL! Ordonnate at the origin of the
+ ! amplification straight line
+real, dimension(:,:,:), pointer , contiguous :: zcoef_ampl
+ ! Amplification coefficient of the mixing length
+ ! when the instability criterium is verified
+real, dimension(:,:,:), pointer , contiguous :: zlm_cloud
+ ! Turbulent mixing length in the clouds
+!
+!-------------------------------------------------------------------------------
+#ifdef MNH_OPENACC
+call Print_msg( NVERB_FATAL, 'GEN', 'TURB', 'OpenACC: CLOUD_MODIF_LM not yet implemented' )
+#endif
+
+allocate( zcoef_ampl(size( put, 1 ), size( put, 2 ), size( put, 3) ) )
+allocate( zlm_cloud (size( put, 1 ), size( put, 2 ), size( put, 3) ) )
+!
+!* 1. INITIALISATION
+! --------------
+!
+ZPENTE = ( PCOEF_AMPL_SAT - 1. ) / ( PCEI_MAX - PCEI_MIN )
+ZCOEF_AMPL_CEI_NUL = 1. - ZPENTE * PCEI_MIN
+!
+ZCOEF_AMPL(:,:,:) = 1.
+!
+!* 2. CALCULATION OF THE AMPLIFICATION COEFFICIENT
+! --------------------------------------------
+!
+! Saturation
+!
+WHERE ( PCEI(:,:,:)>=PCEI_MAX ) ZCOEF_AMPL(:,:,:)=PCOEF_AMPL_SAT
+!
+! Between the min and max limits of CEI index, linear variation of the
+! amplification coefficient ZCOEF_AMPL as a function of CEI
+!
+WHERE ( PCEI(:,:,:) < PCEI_MAX .AND. &
+ PCEI(:,:,:) > PCEI_MIN ) &
+ ZCOEF_AMPL(:,:,:) = ZPENTE * PCEI(:,:,:) + ZCOEF_AMPL_CEI_NUL
+!
+!
+!* 3. CALCULATION OF THE MIXING LENGTH IN CLOUDS
+! ------------------------------------------
+!
+IF (HTURBLEN_CL == HTURBLEN) THEN
+ ZLM_CLOUD(:,:,:) = PLEM(:,:,:)
+ELSE
+ SELECT CASE (HTURBLEN_CL)
+!
+!* 3.1 BL89 mixing length
+! ------------------
+ CASE ('BL89','RM17')
+!$acc kernels
+ ZSHEAR(:, :, : ) = 0.
+!$acc end kernels
+ CALL BL89(KKA,KKU,KKL,PZZ,PDZZ,PTHVREF,ZTHLM,KRR,ZRM,PTKET,ZSHEAR,ZLM_CLOUD)
+!
+!* 3.2 Delta mixing length
+! -------------------
+ CASE ('DELT')
+ CALL DELT(KKA,KKU,KKL,IKB, IKE,IKTB, IKTE,ORMC01,HTURBDIM,PDXX, PDYY,PZZ,PDIRCOSZW,ZLM_CLOUD)
+!
+!* 3.3 Deardorff mixing length
+! -----------------------
+ CASE ('DEAR')
+ CALL DEAR(KKA,KKU,KKL,KRR, KRRI, IKB, IKE,IKTB, IKTE, &
+ ORMC01,HTURBDIM,PDXX, PDYY, PDZZ,PZZ,PDIRCOSZW,PTHLT,PTHVREF,PTKET,PSRCT,PRT,&
+ ZLOCPEXNM,ZATHETA, ZAMOIST, ZLM_CLOUD)
+!
+ END SELECT
+ENDIF
+!
+!* 4. MODIFICATION OF THE MIXING LENGTH IN THE CLOUDS
+! -----------------------------------------------
+!
+! Impression before modification of the mixing length
+IF ( OTURB_DIAG .AND. OCLOSE_OUT ) THEN
+ TZFIELD%CMNHNAME = 'LM_CLEAR_SKY'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'LM_CLEAR_SKY'
+ TZFIELD%CUNITS = 'm'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_LM CLEAR SKY'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,PLEM)
+ENDIF
+!
+! Amplification of the mixing length when the criteria are verified
+!
+WHERE (ZCOEF_AMPL(:,:,:) /= 1.) PLEM(:,:,:) = ZCOEF_AMPL(:,:,:)*ZLM_CLOUD(:,:,:)
+!
+! Cloud mixing length in the clouds at the points which do not verified the CEI
+!
+WHERE (PCEI(:,:,:) == -1.) PLEM(:,:,:) = ZLM_CLOUD(:,:,:)
+!
+!
+!* 5. IMPRESSION
+! ----------
+!
+IF ( OTURB_DIAG .AND. OCLOSE_OUT ) THEN
+ TZFIELD%CMNHNAME = 'COEF_AMPL'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'COEF_AMPL'
+ TZFIELD%CUNITS = '1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_COEF AMPL'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZCOEF_AMPL)
+ !
+ TZFIELD%CMNHNAME = 'LM_CLOUD'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'LM_CLOUD'
+ TZFIELD%CUNITS = 'm'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_LM CLOUD'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ CALL IO_Field_write(TPFILE,TZFIELD,ZLM_CLOUD)
+ !
+ENDIF
+
+deallocate( zcoef_ampl, zlm_cloud )
+
+END SUBROUTINE CLOUD_MODIF_LM
+!
+END SUBROUTINE TURB
+
+
+
+!###################
+SUBROUTINE DELT(KKA,KKU,KKL,KKB, KKE,KKTB, KKTE,ORMC01,HTURBDIM,PDXX, PDYY,PZZ,PDIRCOSZW,PLM)
+!###################
+!!
+!!**** *DELT* routine to compute mixing length for DELT case
+!
+!! AUTHOR
+!! ------
+!!
+!! M Tomasini *Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/05
+!!
+! P. Wautelet 18/07/2019: add OpenACC directives
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+use modd_conf, only: l2d
+
+use mode_mppdb
+
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+
+implicit none
+!
+!* 0.1 Declarations of dummy arguments
+!
+INTEGER, INTENT(IN) :: KKA !near ground array index
+INTEGER, INTENT(IN) :: KKU !uppest atmosphere array index
+INTEGER, INTENT(IN) :: KKL !vert. levels type 1=MNH -1=ARO
+INTEGER, intent(in) :: KKB, KKE ! index value for the
+! Beginning and the End of the physical domain for the mass points
+INTEGER, intent(in) :: KKTB, KKTE ! start, end of k loops in physical domain
+LOGICAL, INTENT(IN) :: ORMC01 ! switch for RMC01 lengths in SBL
+CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! dimensionality of the
+ ! turbulence scheme
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX, PDYY
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! physical distance
+! between 2 succesive grid points along the K direction
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSZW
+! Director Cosinus along x, y and z directions at surface w-point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLM
+!
+!
+!* 0.2 Declarations of local variables
+!
+
+integer :: ji, jj, jk
+REAL :: ZALPHA ! proportionnality constant between Dz/2 and
+! ! BL89 mixing length near the surface
+REAL :: ZD ! distance to the surface
+#ifdef MNH_OPENACC
+real, dimension(:,:,:), pointer , contiguous :: ztmp1_device, ztmp2_device
+#endif
+!
+!-------------------------------------------------------------------------------
+
+!$acc data present( PDXX, PDYY, PZZ, PDIRCOSZW, PLM )
+
+if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pdxx, "Delt beg:pdxx" )
+ call Mppdb_check( pdyy, "Delt beg:pdyy" )
+ call Mppdb_check( pzz, "Delt beg:pzz" )
+ call Mppdb_check( pdircoszw, "Delt beg:pdircoszw" )
+end if
+
+#ifdef MNH_OPENACC
+allocate( ztmp1_device( size( pdxx, 1 ), size( pdxx, 2 ), size( pdxx, 3 ) ) )
+allocate( ztmp2_device( size( pdxx, 1 ), size( pdxx, 2 ), size( pdxx, 3 ) ) )
+#endif
+
+!$acc data create( ztmp1_device, ztmp2_device )
+
+!$acc kernels
+DO JK = KKTB,KKTE ! 1D turbulence scheme
+ PLM(:,:,JK) = PZZ(:,:,JK+KKL) - PZZ(:,:,JK)
+END DO
+PLM(:,:,KKU) = PLM(:,:,KKE)
+PLM(:,:,KKA) = PZZ(:,:,KKB) - PZZ(:,:,KKA)
+!$acc end kernels
+IF ( HTURBDIM /= '1DIM' ) THEN ! 3D turbulence scheme
+ IF ( L2D ) THEN
+#ifndef MNH_OPENACC
+ PLM(:,:,:) = SQRT( PLM(:,:,:)*MXF(PDXX(:,:,:)) )
+#else
+ CALL MXF_DEVICE( PDXX, ZTMP1_DEVICE )
+!$acc kernels
+ PLM(:,:,:) = SQRT( PLM(:,:,:) * ZTMP1_DEVICE )
+!$acc end kernels
+#endif
+ ELSE
+#ifndef MNH_OPENACC
+#ifndef MNH_BITREP
+ PLM(:,:,:) = (PLM(:,:,:)*MXF(PDXX(:,:,:))*MYF(PDYY(:,:,:)) ) ** (1./3.)
+#else
+ PLM(:,:,:) = BR_POW( PLM(:, :, : ) * MXF( PDXX(:, :, : ) ) * MYF( PDYY(:, :, : ) ), 1. / 3. )
+#endif
+#else
+ CALL MXF_DEVICE( PDXX, ZTMP1_DEVICE )
+ CALL MYF_DEVICE( PDYY, ZTMP2_DEVICE )
+!$acc kernels
+#ifndef MNH_BITREP
+ PLM(:,:,:) = ( PLM(:,:,:) * ZTMP1_DEVICE * ZTMP2_DEVICE ) ** (1./3.)
+#else
+ PLM(:,:,:) = BR_POW( PLM(:,:,:) * ZTMP1_DEVICE * ZTMP2_DEVICE, 1./3. )
+#endif
+!$acc end kernels
+#endif
+ END IF
+END IF
+!
+! mixing length limited by the distance normal to the surface
+! (with the same factor as for BL89)
+!
+!$acc kernels
+IF (.NOT. ORMC01) THEN
+#ifndef MNH_BITREP
+ ZALPHA = 0.5**(-1.5)
+#else
+ ZALPHA = BR_POW( 0.5, -1.5 )
+#endif
+ !
+ DO JJ=1,SIZE(PLM,2)
+ DO JI=1,SIZE(PLM,1)
+ DO JK=KKTB,KKTE
+ ZD = ZALPHA * ( 0.5 * ( PZZ(JI, JJ, JK ) + PZZ(JI, JJ, JK+KKL ) ) - PZZ(JI, JJ, KKB ) ) * PDIRCOSZW(JI, JJ )
+ IF ( PLM(JI,JJ,JK) > ZD ) THEN
+ PLM(JI,JJ,JK) = ZD
+ ELSE
+ EXIT
+ ENDIF
+ END DO
+ END DO
+ END DO
+END IF
+!
+PLM(:,:,KKA) = PLM(:,:,KKB )
+PLM(:,:,KKU ) = PLM(:,:,KKE)
+!$acc end kernels
+
+if ( mppdb_initialized ) then
+ !Check all out arrays
+ call Mppdb_check( plm, "Delt end:plm" )
+end if
+
+!$acc end data
+
+!$acc end data
+
+END SUBROUTINE DELT
+
+
+
+!###################
+SUBROUTINE DEAR(KKA,KKU,KKL,KRR, KRRI, KKB, KKE,KKTB, KKTE, &
+ ORMC01,HTURBDIM,PDXX, PDYY, PDZZ,PZZ,PDIRCOSZW,PTHLT,PTHVREF,PTKET,PSRCT,PRT,&
+ PLOCPEXNM,PATHETA, PAMOIST, PLM)
+!###################
+!!
+!!**** *DEAR* routine to compute mixing length for DEARdorff case
+!
+!! AUTHOR
+!! ------
+!!
+!! M Tomasini *Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/05
+!! I.Sandu (Sept.2006) : Modification of the stability criterion
+!! (theta_v -> theta_l)
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+use modd_conf, only: l2d
+use modd_cst, only: XG, XMNH_EPSILON
+
+use mode_mppdb
+
+USE MODI_EMOIST
+USE MODI_ETHETA
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+
+implicit none
+!
+!* 0.1 Declarations of dummy arguments
+!
+INTEGER, INTENT(IN) :: KKA !near ground array index
+INTEGER, INTENT(IN) :: KKU !uppest atmosphere array index
+INTEGER, INTENT(IN) :: KKL !vert. levels type 1=MNH -1=ARO
+INTEGER, INTENT(IN) :: KRR ! number of moist var.
+INTEGER, INTENT(IN) :: KRRI ! number of ice water var.
+INTEGER, intent(in) :: KKB, KKE ! index value for the
+! Beginning and the End of the physical domain for the mass points
+INTEGER, intent(in) :: KKTB, KKTE ! start, end of k loops in physical domain
+LOGICAL, INTENT(IN) :: ORMC01 ! switch for RMC01 lengths in SBL
+CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! dimensionality of the
+ ! turbulence scheme
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX, PDYY, PDZZ
+ ! metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! physical distance
+! between 2 succesive grid points along the K direction
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSZW
+! Director Cosinus along x, y and z directions at surface w-point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLT ! conservative pot. temp.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Potential
+ ! Temperature of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKET ! TKE
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRCT ! Second-order flux
+ ! s'rc'/2Sigma_s2 at time t-1 multiplied by Lambda_3
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! water var. where
+ ! PRT(:,:,:,1) is the conservative mixing ratio
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PLOCPEXNM ! Lv/Cp/EXNREF at t-1
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PATHETA, PAMOIST ! coefficients for s = f (Thetal,Rnp)
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLM
+!
+!* 0.2 Declarations of local variables
+!
+integer :: ji, jj, jk
+REAL :: ZALPHA ! proportionnality constant between Dz/2 and
+! ! BL89 mixing length near the surface
+REAL :: ZD ! distance to the surface
+REAL :: ZVAR ! Intermediary variable
+REAL, DIMENSION(:,:), POINTER , CONTIGUOUS :: ZWORK2D
+!
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: &
+ ZDTHLDZ,ZDRTDZ, &!dtheta_l/dz, drt_dz used for computing the stablity
+! ! criterion
+ ZETHETA,ZEMOIST !coef ETHETA and EMOIST
+INTEGER :: IZWORK2D,IZDTHLDZ,IZDRTDZ,IZETHETA,IZEMOIST
+!
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZTMP1_DEVICE,ZTMP2_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE
+#endif
+INTEGER :: JIU,JJU,JKU
+!----------------------------------------------------------------------------
+
+!$acc data present( PDXX, PDYY, PDZZ, PZZ, PDIRCOSZW, PTHLT, PTHVREF, PTKET, PSRCT, PRT, PLOCPEXNM, PATHETA, PAMOIST, PLM )
+
+if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pdxx, "Dear beg:pdxx" )
+ call Mppdb_check( pdyy, "Dear beg:pdyy" )
+ call Mppdb_check( pdzz, "Dear beg:pdzz" )
+ call Mppdb_check( pzz, "Dear beg:pzz" )
+ call Mppdb_check( pdircoszw, "Dear beg:pdircoszw" )
+ call Mppdb_check( pthlt, "Dear beg:pthlt" )
+ call Mppdb_check( pthvref, "Dear beg:pthvref" )
+ call Mppdb_check( ptket, "Dear beg:ptket" )
+ call Mppdb_check( psrct, "Dear beg:psrct" )
+ call Mppdb_check( prt, "Dear beg:prt" )
+ call Mppdb_check( plocpexnm, "Dear beg:plocpexnm" )
+ call Mppdb_check( patheta, "Dear beg:patheta" )
+ call Mppdb_check( pamoist, "Dear beg:pamoist" )
+end if
+
+JIU = size(pthlt, 1 )
+JJU = size(pthlt, 2 )
+JKU = size(pthlt, 3 )
+
+!-------------------------------------------------------------------------------
+#ifndef MNH_OPENACC
+allocate( ZWORK2D(JIU,JJU) )
+allocate( ZDTHLDZ(JIU,JJU,JKU) )
+allocate( ZDRTDZ (JIU,JJU,JKU) )
+allocate( ZETHETA(JIU,JJU,JKU) )
+allocate( ZEMOIST(JIU,JJU,JKU) )
+#else
+IZWORK2D = MNH_ALLOCATE_ZT2D( ZWORK2D,JIU,JJU)
+IZDTHLDZ = MNH_ALLOCATE_ZT3D( ZDTHLDZ,JIU,JJU,JKU)
+IZDRTDZ = MNH_ALLOCATE_ZT3D( ZDRTDZ ,JIU,JJU,JKU)
+IZETHETA = MNH_ALLOCATE_ZT3D( ZETHETA,JIU,JJU,JKU)
+IZEMOIST = MNH_ALLOCATE_ZT3D( ZEMOIST,JIU,JJU,JKU)
+#endif
+
+#ifdef MNH_OPENACC
+IZTMP1_DEVICE = MNH_ALLOCATE_ZT3D( ZTMP1_DEVICE,JIU,JJU,JKU)
+IZTMP2_DEVICE = MNH_ALLOCATE_ZT3D( ZTMP2_DEVICE,JIU,JJU,JKU)
+#endif
+
+!$acc data present(zwork2d, zdthldz, zdrtdz, zetheta, zemoist, &
+!$acc & ztmp1_device, ztmp2_device )
+
+!
+! initialize the mixing length with the mesh grid
+!$acc kernels
+! 1D turbulence scheme
+PLM(:,:,KKTB:KKTE) = PZZ(:,:,KKTB+KKL:KKTE+KKL) - PZZ(:,:,KKTB:KKTE)
+PLM(:,:,KKU) = PLM(:,:,KKE)
+PLM(:,:,KKA) = PZZ(:,:,KKB) - PZZ(:,:,KKA)
+!$acc end kernels
+IF ( HTURBDIM /= '1DIM' ) THEN ! 3D turbulence scheme
+ IF ( L2D) THEN
+#ifndef MNH_OPENACC
+ PLM(:,:,:) = SQRT( PLM(:,:,:)*MXF(PDXX(:,:,:)) )
+#else
+ CALL MXF_DEVICE(PDXX,ZTMP1_DEVICE)
+!$acc kernels
+ PLM(:,:,:) = SQRT( PLM(:,:,:)*ZTMP1_DEVICE )
+!$acc end kernels
+ if ( mppdb_initialized ) then
+ call Mppdb_check( ZTMP1_DEVICE , "Dear mid: ZTMP1_DEVICE=Mxf" )
+ call Mppdb_check( plm, "Dear mid:plm" )
+ end if
+#endif
+ ELSE
+!PW: "BUG" PGI : results different on CPU and GPU due to the power function
+!See http://www.pgroup.com/userforum/viewtopic.php?t=5364&sid=ec7b762b17fb9bb3332a47f0db57af55
+!Use of own functions allows bit-reproducible results
+#ifndef MNH_BITREP
+!
+#ifndef MNH_OPENACC
+ PLM(:,:,:) = (PLM(:,:,:)*MXF(PDXX(:,:,:))*MYF(PDYY(:,:,:)) ) ** (1./3.)
+#else
+ CALL MXF_DEVICE(PDXX,ZTMP1_DEVICE)
+ CALL MYF_DEVICE(PDYY,ZTMP2_DEVICE)
+!$acc kernels
+ PLM(:,:,:) = (PLM(:,:,:)*ZTMP1_DEVICE*ZTMP2_DEVICE ) ** (1./3.)
+!$acc end kernels
+ if ( mppdb_initialized ) then
+ call Mppdb_check( ZTMP1_DEVICE , "Dear mid: ZTMP1_DEVICE=Mxf" )
+ call Mppdb_check( ZTMP2_DEVICE , "Dear mid: ZTMP2_DEVICE=Myf" )
+ call Mppdb_check( plm, "Dear mid:plm" )
+ end if
+#endif
+!
+#else
+!
+#ifndef MNH_OPENACC
+ PLM(:,:,:) = BR_POW( PLM(:,:,:)*MXF(PDXX(:,:,:))*MYF(PDYY(:,:,:)) , 1./3. )
+#else
+ CALL MXF_DEVICE(PDXX,ZTMP1_DEVICE)
+ CALL MYF_DEVICE(PDYY,ZTMP2_DEVICE)
+ if ( mppdb_initialized ) then
+ call Mppdb_check( ZTMP1_DEVICE , "Dear mid: ZTMP1_DEVICE=Mxf" )
+ call Mppdb_check( ZTMP2_DEVICE , "Dear mid: ZTMP2_DEVICE=Myf" )
+ call Mppdb_check( plm, "Dear mid1:plm" )
+ end if
+!$acc kernels
+ PLM(:,:,:) = BR_POW( PLM(:,:,:)*ZTMP1_DEVICE *ZTMP2_DEVICE , 1./3. )
+!$acc end kernels
+ if ( mppdb_initialized ) then
+ call Mppdb_check( plm, "Dear mid2:plm" )
+ end if
+#endif
+#endif
+ END IF
+END IF
+! compute a mixing length limited by the stability
+!
+#ifndef MNH_OPENACC
+ZETHETA(:,:,:) = ETHETA(KRR,KRRI,PTHLT,PRT,PLOCPEXNM,PATHETA,PSRCT)
+ZEMOIST(:,:,:) = EMOIST(KRR,KRRI,PTHLT,PRT,PLOCPEXNM,PAMOIST,PSRCT)
+#else
+CALL ETHETA(KRR,KRRI,PTHLT,PRT,PLOCPEXNM,PATHETA,PSRCT,ZETHETA)
+CALL EMOIST(KRR,KRRI,PTHLT,PRT,PLOCPEXNM,PAMOIST,PSRCT,ZEMOIST)
+#endif
+!
+!$acc kernels
+! For dry simulations
+IF (KRR>0) THEN
+!$acc loop independent collapse(3) private(ZVAR)
+ DO JK = KKTB+1,KKTE-1
+ DO JJ=1,SIZE(PLM,2)
+ DO JI=1,SIZE(PLM,1)
+ ZDTHLDZ(JI,JJ,JK)= 0.5*((PTHLT(JI,JJ,JK+KKL)-PTHLT(JI,JJ,JK ))/PDZZ(JI,JJ,JK+KKL)+ &
+ (PTHLT(JI,JJ,JK )-PTHLT(JI,JJ,JK-KKL))/PDZZ(JI,JJ,JK ))
+ ZDRTDZ(JI,JJ,JK) = 0.5*((PRT(JI,JJ,JK+KKL,1)-PRT(JI,JJ,JK ,1))/PDZZ(JI,JJ,JK+KKL)+ &
+ (PRT(JI,JJ,JK ,1)-PRT(JI,JJ,JK-KKL,1))/PDZZ(JI,JJ,JK ))
+ ZVAR=XG/PTHVREF(JI,JJ,JK)* &
+ (ZETHETA(JI,JJ,JK)*ZDTHLDZ(JI,JJ,JK)+ZEMOIST(JI,JJ,JK)*ZDRTDZ(JI,JJ,JK))
+ !
+ IF (ZVAR>0.) THEN
+ PLM(JI,JJ,JK)=MAX(XMNH_EPSILON,MIN(PLM(JI,JJ,JK), &
+ 0.76* SQRT(PTKET(JI,JJ,JK)/ZVAR)))
+ END IF
+ END DO
+ END DO
+ END DO
+ELSE
+!$acc loop independent collapse(3) private(ZVAR)
+ DO JK = KKTB+1,KKTE-1
+ DO JJ=1,SIZE(PLM,2)
+ DO JI=1,SIZE(PLM,1)
+ ZDTHLDZ(JI,JJ,JK)= 0.5*((PTHLT(JI,JJ,JK+KKL)-PTHLT(JI,JJ,JK ))/PDZZ(JI,JJ,JK+KKL)+ &
+ (PTHLT(JI,JJ,JK )-PTHLT(JI,JJ,JK-KKL))/PDZZ(JI,JJ,JK ))
+ ZVAR=XG/PTHVREF(JI,JJ,JK)*ZETHETA(JI,JJ,JK)*ZDTHLDZ(JI,JJ,JK)
+ !
+ IF (ZVAR>0.) THEN
+ PLM(JI,JJ,JK)=MAX(XMNH_EPSILON,MIN(PLM(JI,JJ,JK), &
+ 0.76* SQRT(PTKET(JI,JJ,JK)/ZVAR)))
+ END IF
+ END DO
+ END DO
+ END DO
+END IF
+! special case near the surface
+ZDTHLDZ(:,:,KKB)=(PTHLT(:,:,KKB+KKL)-PTHLT(:,:,KKB))/PDZZ(:,:,KKB+KKL)
+! For dry simulations
+IF (KRR>0) THEN
+ ZDRTDZ(:,:,KKB)=(PRT(:,:,KKB+KKL,1)-PRT(:,:,KKB,1))/PDZZ(:,:,KKB+KKL)
+ELSE
+ ZDRTDZ(:,:,KKB)=0
+ENDIF
+!
+ZWORK2D(:,:)=XG/PTHVREF(:,:,KKB)* &
+ (ZETHETA(:,:,KKB)*ZDTHLDZ(:,:,KKB)+ZEMOIST(:,:,KKB)*ZDRTDZ(:,:,KKB))
+WHERE(ZWORK2D(:,:)>0.)
+ PLM(:,:,KKB)=MAX(XMNH_EPSILON,MIN( PLM(:,:,KKB), &
+ 0.76* SQRT(PTKET(:,:,KKB)/ZWORK2D(:,:))))
+END WHERE
+!
+! mixing length limited by the distance normal to the surface (with the same factor as for BL89)
+!
+IF (.NOT. ORMC01) THEN
+ ZALPHA=0.5**(-1.5)
+ !
+ DO JJ=1,SIZE(PLM,2)
+ DO JI=1,SIZE(PLM,1)
+ DO JK=KKTB,KKTE
+ ZD=ZALPHA*(0.5*(PZZ(JI,JJ,JK)+PZZ(JI,JJ,JK+KKL))-PZZ(JI,JJ,KKB)) &
+ *PDIRCOSZW(JI,JJ)
+ IF ( PLM(JI,JJ,JK)>ZD) THEN
+ PLM(JI,JJ,JK)=ZD
+ ELSE
+ EXIT
+ ENDIF
+ END DO
+ END DO
+ END DO
+END IF
+!
+PLM(:,:,KKA) = PLM(:,:,KKB )
+PLM(:,:,KKE ) = PLM(:,:,KKE-KKL)
+PLM(:,:,KKU ) = PLM(:,:,KKU-KKL)
+!$acc end kernels
+
+if ( mppdb_initialized ) then
+ !Check all out arrays
+ call Mppdb_check( plm, "Dear end:plm" )
+end if
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+deallocate(zwork2d, zdthldz, zdrtdz, zetheta, zemoist )
+#else
+CALL MNH_REL_ZT3D(izwork2d, izdthldz, izdrtdz, izetheta, izemoist, &
+ iztmp1_device, iztmp2_device )
+#endif
+
+!$acc end data
+
+END SUBROUTINE DEAR
+
+end module mode_turb
diff --git a/src/ZSOLVER/turb_hor_dyn_corr.f90 b/src/ZSOLVER/turb_hor_dyn_corr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b59a3dfaa26314a1a3360157b626ff755290bc70
--- /dev/null
+++ b/src/ZSOLVER/turb_hor_dyn_corr.f90
@@ -0,0 +1,1300 @@
+!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.
+!-----------------------------------------------------------------
+MODULE MODI_TURB_HOR_DYN_CORR
+!
+INTERFACE
+!
+ SUBROUTINE TURB_HOR_DYN_CORR(KSPLT, PTSTEP, &
+ OCLOSE_OUT,OTURB_FLX,KRR, &
+ TPFILE, &
+ PK,PINV_PDZZ, &
+ PDXX,PDYY,PDZZ,PDZX,PDZY,PZZ, &
+ PDIRCOSZW, &
+ PCOSSLOPE,PSINSLOPE, &
+ PRHODJ, &
+ PCDUEFF,PTAU11M,PTAU12M,PTAU22M,PTAU33M, &
+ PUM,PVM,PWM,PUSLOPEM,PVSLOPEM, &
+ PTHLM,PRM,PSVM, &
+ PTKEM,PLM, &
+ PDP,PTP, &
+ PRUS,PRVS,PRWS )
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KSPLT ! split process index
+REAL, INTENT(IN) :: PTSTEP ! timestep
+LOGICAL, INTENT(IN) :: OCLOSE_OUT ! switch for syncronous
+ ! file opening
+LOGICAL, INTENT(IN) :: OTURB_FLX ! switch to write the
+ ! turbulent fluxes in the syncronous FM-file
+INTEGER, INTENT(IN) :: KRR ! number of moist var.
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PK ! Turbulent diffusion doef.
+ ! PK = PLM * SQRT(PTKEM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDZZ ! 1./PDZZ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX, PDYY, PDZZ, PDZX, PDZY
+ ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! vertical grid
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSZW
+! Director Cosinus along z directions at surface w-point
+REAL, DIMENSION(:,:), INTENT(IN) :: PCOSSLOPE ! cosinus of the angle
+ ! between i and the slope vector
+REAL, DIMENSION(:,:), INTENT(IN) :: PSINSLOPE ! sinus of the angle
+ ! between i and the slope vector
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density * grid volume
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PCDUEFF ! Cd * || u || at time t
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU11M ! <uu> in the axes linked
+ ! to the maximum slope direction and the surface normal and the binormal
+ ! at time t - dt
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU12M ! <uv> in the same axes
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU22M ! <vv> in the same axes
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU33M ! <ww> in the same axes
+!
+! Variables at t-1
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM,PVM,PWM,PTHLM
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVM
+REAL, DIMENSION(:,:), INTENT(IN) :: PUSLOPEM ! wind component along the
+ ! maximum slope direction
+REAL, DIMENSION(:,:), INTENT(IN) :: PVSLOPEM ! wind component along the
+ ! direction normal to the maximum slope one
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKEM ! TKE at time t- dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PLM ! Turb. mixing length
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDP,PTP ! TKE production terms
+!
+END SUBROUTINE TURB_HOR_DYN_CORR
+!
+END INTERFACE
+!
+END MODULE MODI_TURB_HOR_DYN_CORR
+! ################################################################
+ SUBROUTINE TURB_HOR_DYN_CORR(KSPLT, PTSTEP, &
+ OCLOSE_OUT,OTURB_FLX,KRR, &
+ TPFILE, &
+ PK,PINV_PDZZ, &
+ PDXX,PDYY,PDZZ,PDZX,PDZY,PZZ, &
+ PDIRCOSZW, &
+ PCOSSLOPE,PSINSLOPE, &
+ PRHODJ, &
+ PCDUEFF,PTAU11M,PTAU12M,PTAU22M,PTAU33M, &
+ PUM,PVM,PWM,PUSLOPEM,PVSLOPEM, &
+ PTHLM,PRM,PSVM, &
+ PTKEM,PLM, &
+ PDP,PTP, &
+ PRUS,PRVS,PRWS )
+! ################################################################
+!
+!!**** *TURB_HOR* -routine to compute the source terms in the meso-NH
+!! model equations due to the non-vertical turbulent fluxes.
+!!
+!! PURPOSE
+!! -------
+!!
+!! see TURB_HOR
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! Joan Cuxart * INM and Meteo-France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Aug , 1997 (V. Saravane) spliting of TURB_HOR
+!! Nov 27, 1997 (V. Masson) clearing of the routine
+!! Oct 18, 2000 (V. Masson) LES computations + LFLAT switch
+!! Feb 15, 2001 (J. Stein) remove the use of w=0 at the
+!! ground
+!! Mar 12, 2001 (V. Masson and J. Stein) major bugs
+!! + change of discretization at the surface
+!! Nov 06, 2002 (V. Masson) LES budgets
+!! October 2009 (G. Tanguy) add ILENCH=LEN(YCOMMENT) after
+!! change of YCOMMENT
+!! July 2012 (V.Masson) Implicitness of W
+!! March 2014 (V.Masson) tridiag_w : bug between
+!! mass and flux position
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! M.Moge 04/2016 Use openACC directives to port the TURB part of Meso-NH on GPU
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+! J.Escobar 13/08/2020: PGI/NVHPC BUG , extend DO CONCURRENT to 3D indexes
+!! --------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ARGSLIST_ll, ONLY: LIST_ll
+USE MODD_CST
+USE MODD_CONF
+USE MODD_CTURB
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_PARAMETERS
+USE MODD_LES
+USE MODD_NSV
+!
+USE MODE_ll
+USE MODE_FIELD, ONLY: TFIELDDATA, TYPEREAL
+USE MODE_IO_FIELD_WRITE, only: IO_Field_write
+use mode_mppdb
+!
+USE MODI_GRADIENT_M
+USE MODI_GRADIENT_U
+USE MODI_GRADIENT_V
+USE MODI_GRADIENT_W
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+USE MODI_COEFJ
+USE MODI_LES_MEAN_SUBGRID
+USE MODI_TRIDIAG_W
+!
+USE MODI_SECOND_MNH
+USE MODE_MPPDB
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#endif
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+USE MODI_GET_HALO
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 declaration of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KSPLT ! split process index
+REAL, INTENT(IN) :: PTSTEP ! timestep
+LOGICAL, INTENT(IN) :: OCLOSE_OUT ! switch for syncronous
+ ! file opening
+LOGICAL, INTENT(IN) :: OTURB_FLX ! switch to write the
+ ! turbulent fluxes in the syncronous FM-file
+INTEGER, INTENT(IN) :: KRR ! number of moist var.
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PK ! Turbulent diffusion doef.
+ ! PK = PLM * SQRT(PTKEM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDZZ ! 1./PDZZ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX, PDYY, PDZZ, PDZX, PDZY
+ ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! vertical grid
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSZW
+! Director Cosinus along z directions at surface w-point
+REAL, DIMENSION(:,:), INTENT(IN) :: PCOSSLOPE ! cosinus of the angle
+ ! between i and the slope vector
+REAL, DIMENSION(:,:), INTENT(IN) :: PSINSLOPE ! sinus of the angle
+ ! between i and the slope vector
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density * grid volume
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PCDUEFF ! Cd * || u || at time t
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU11M ! <uu> in the axes linked
+ ! to the maximum slope direction and the surface normal and the binormal
+ ! at time t - dt
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU12M ! <uv> in the same axes
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU22M ! <vv> in the same axes
+REAL, DIMENSION(:,:), INTENT(IN) :: PTAU33M ! <ww> in the same axes
+!
+! Variables at t-1
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM,PVM,PWM,PTHLM
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVM
+REAL, DIMENSION(:,:), INTENT(IN) :: PUSLOPEM ! wind component along the
+ ! maximum slope direction
+REAL, DIMENSION(:,:), INTENT(IN) :: PVSLOPEM ! wind component along the
+ ! direction normal to the maximum slope one
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKEM ! TKE at time t- dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PLM ! Turb. mixing length
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDP,PTP ! TKE production terms
+!
+!* 0.2 declaration of local variables
+!
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZWORK ! work arrays, PK is the turb. mixing coef.
+!
+REAL, DIMENSION(:,:), pointer , contiguous :: ZDIRSINZW
+INTEGER :: IZFLX,IZWORK,IZDIRSINZW
+ ! sinus of the angle between the vertical and the normal to the orography
+INTEGER :: IKB,IKE
+ ! Index values for the Beginning and End
+ ! mass points of the domain
+INTEGER :: IKU
+INTEGER :: JSV ! scalar loop counter
+!
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GX_U_M_PUM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GY_V_M_PVM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GZ_W_M_PWM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GZ_W_M_ZWP
+INTEGER :: IGX_U_M_PUM,IGY_V_M_PVM,IGZ_W_M_PWM,IGZ_W_M_ZWP
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZMZF_DZZ ! MZF(PDZZ)
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDFDDWDZ ! formal derivative of the
+! ! flux (variable: dW/dz)
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZWP ! W at future time-step
+!
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDU_DZ_DZS_DX ! du/dz*dzs/dx surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDV_DZ_DZS_DY ! dv/dz*dzs/dy surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDU_DX ! du/dx surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDV_DY ! dv/dy surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDW_DZ ! dw/dz surf
+INTEGER :: IZMZF_DZZ,IZDFDDWDZ,IZWP,IZDU_DZ_DZS_DX,IZDV_DZ_DZS_DY &
+ ,IZDU_DX,IZDV_DY,IZDW_DZ
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+
+REAL :: ZTIME1, ZTIME2
+
+
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF , ZDZZ
+ ! coefficients for the uncentred gradient
+ ! computation near the ground
+INTEGER :: IZCOEFF , IZDZZ
+!
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
+#endif
+TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
+! --------------------------------------------------------------------------
+
+!$acc data present( PK, PINV_PDZZ, PDXX, PDYY, PDZZ, PDZX, PDZY, PZZ, PDIRCOSZW, &
+!$acc & PCOSSLOPE, PSINSLOPE, PRHODJ, PCDUEFF, &
+!$acc & PTAU11M, PTAU12M, PTAU22M, PTAU33M, &
+!$acc & PUM, PVM, PWM, PTHLM, PRM, PSVM, PUSLOPEM, PVSLOPEM, PTKEM, PLM, &
+!$acc & PRUS, PRVS, PRWS, PDP, PTP )
+
+if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pk, "Turb_hor_dyn_corr beg:pk" )
+ call Mppdb_check( pinv_pdzz, "Turb_hor_dyn_corr beg:pinv_pdzz" )
+ call Mppdb_check( pdxx, "Turb_hor_dyn_corr beg:pdxx" )
+ call Mppdb_check( pdyy, "Turb_hor_dyn_corr beg:pdyy" )
+ call Mppdb_check( pdzz, "Turb_hor_dyn_corr beg:pdzz" )
+ call Mppdb_check( pdzx, "Turb_hor_dyn_corr beg:pdzx" )
+ call Mppdb_check( pdzy, "Turb_hor_dyn_corr beg:pdzy" )
+ call Mppdb_check( pzz, "Turb_hor_dyn_corr beg:pzz" )
+ call Mppdb_check( pdircoszw, "Turb_hor_dyn_corr beg:pdircoszw" )
+ call Mppdb_check( pcosslope, "Turb_hor_dyn_corr beg:pcosslope" )
+ call Mppdb_check( psinslope, "Turb_hor_dyn_corr beg:psinslope" )
+ call Mppdb_check( prhodj, "Turb_hor_dyn_corr beg:prhodj" )
+ call Mppdb_check( pcdueff, "Turb_hor_dyn_corr beg:pcdueff" )
+ call Mppdb_check( ptau11m, "Turb_hor_dyn_corr beg:ptau11m" )
+ call Mppdb_check( ptau12m, "Turb_hor_dyn_corr beg:ptau12m" )
+ call Mppdb_check( ptau22m, "Turb_hor_dyn_corr beg:ptau22m" )
+ call Mppdb_check( ptau33m, "Turb_hor_dyn_corr beg:ptau33m" )
+ call Mppdb_check( pum, "Turb_hor_dyn_corr beg:pum" )
+ call Mppdb_check( pvm, "Turb_hor_dyn_corr beg:pvm" )
+ call Mppdb_check( pwm, "Turb_hor_dyn_corr beg:pwm" )
+ call Mppdb_check( pthlm, "Turb_hor_dyn_corr beg:pthlm" )
+ call Mppdb_check( prm, "Turb_hor_dyn_corr beg:prm" )
+ call Mppdb_check( psvm, "Turb_hor_dyn_corr beg:psvm" )
+ call Mppdb_check( puslopem, "Turb_hor_dyn_corr beg:puslopem" )
+ call Mppdb_check( pvslopem, "Turb_hor_dyn_corr beg:pvslopem" )
+ call Mppdb_check( ptkem, "Turb_hor_dyn_corr beg:ptkem" )
+ call Mppdb_check( plm, "Turb_hor_dyn_corr beg:plm" )
+ !Check all inout arrays
+ call Mppdb_check( prus, "Turb_hor_dyn_corr beg:prus" )
+ call Mppdb_check( prvs, "Turb_hor_dyn_corr beg:prvs" )
+ call Mppdb_check( prws, "Turb_hor_dyn_corr beg:prws" )
+ call Mppdb_check( pdp, "Turb_hor_dyn_corr beg:pdp" )
+ call Mppdb_check( ptp, "Turb_hor_dyn_corr beg:ptp" )
+end if
+
+JIU = size(pum, 1 )
+JJU = size(pum, 2 )
+JKU = size(pum, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zwork(JIU,JJU,JKU ) )
+
+allocate( zdirsinzw(JIU,JJU ) )
+
+allocate( gx_u_m_pum(JIU,JJU,JKU ) )
+allocate( gy_v_m_pvm(JIU,JJU,JKU ) )
+allocate( gz_w_m_pwm(JIU,JJU,JKU ) )
+allocate( gz_w_m_zwp(JIU,JJU,JKU ) )
+allocate( zmzf_dzz (JIU,JJU,JKU ) )
+allocate( zdfddwdz (JIU,JJU,JKU ) )
+allocate( zwp (JIU,JJU,JKU ) )
+
+allocate( zdu_dz_dzs_dx(JIU,JJU, 1 ) )
+allocate( zdv_dz_dzs_dy(JIU,JJU, 1 ) )
+allocate( zdu_dx (JIU,JJU, 1 ) )
+allocate( zdv_dy (JIU,JJU, 1 ) )
+allocate( zdw_dz (JIU,JJU, 1 ) )
+
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+allocate( zdzz (JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+izwork = MNH_ALLOCATE_ZT3D( zwork,JIU,JJU,JKU )
+
+izdirsinzw = MNH_ALLOCATE_ZT2D( zdirsinzw,JIU,JJU )
+
+igx_u_m_pum = MNH_ALLOCATE_ZT3D( gx_u_m_pum,JIU,JJU,JKU )
+igy_v_m_pvm = MNH_ALLOCATE_ZT3D( gy_v_m_pvm,JIU,JJU,JKU )
+igz_w_m_pwm = MNH_ALLOCATE_ZT3D( gz_w_m_pwm,JIU,JJU,JKU )
+igz_w_m_zwp = MNH_ALLOCATE_ZT3D( gz_w_m_zwp,JIU,JJU,JKU )
+izmzf_dzz = MNH_ALLOCATE_ZT3D( zmzf_dzz ,JIU,JJU,JKU )
+izdfddwdz = MNH_ALLOCATE_ZT3D( zdfddwdz ,JIU,JJU,JKU )
+izwp = MNH_ALLOCATE_ZT3D( zwp ,JIU,JJU,JKU )
+
+izdu_dz_dzs_dx = MNH_ALLOCATE_ZT3DP( zdu_dz_dzs_dx,JIU,JJU, 1 , 1 )
+izdv_dz_dzs_dy = MNH_ALLOCATE_ZT3DP( zdv_dz_dzs_dy,JIU,JJU, 1 , 1 )
+izdu_dx = MNH_ALLOCATE_ZT3DP( zdu_dx ,JIU,JJU, 1 , 1 )
+izdv_dy = MNH_ALLOCATE_ZT3DP( zdv_dy ,JIU,JJU, 1 , 1 )
+izdw_dz = MNH_ALLOCATE_ZT3DP( zdw_dz ,JIU,JJU, 1 , 1 )
+
+izcoeff = MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+izdzz = MNH_ALLOCATE_ZT3DP( zdzz ,JIU,JJU, 1 + jpvext , 3 + jpvext )
+#endif
+
+#ifdef MNH_OPENACC
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+#endif
+
+!$acc data present(ZFLX, ZWORK, ZDIRSINZW, ZCOEFF, ZDZZ, &
+!$acc & GX_U_M_PUM, GY_V_M_PVM, GZ_W_M_PWM, GZ_W_M_ZWP, &
+!$acc & ZMZF_DZZ, ZDFDDWDZ, ZWP, &
+!$acc & ZDU_DZ_DZS_DX, ZDV_DZ_DZS_DY, ZDU_DX, ZDV_DY, ZDW_DZ, &
+!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
+
+!
+!* 1. PRELIMINARY COMPUTATIONS
+! ------------------------
+NULLIFY(TZFIELDS_ll)
+!
+IKB = 1+JPVEXT
+IKE = SIZE(PUM,3)-JPVEXT
+IKU = SIZE(PUM,3)
+!
+!
+!$acc kernels async(1)
+#ifndef MNH_BITREP
+ZDIRSINZW(:,:) = SQRT( 1. - PDIRCOSZW(:,:)**2 )
+#else
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZDIRSINZW(JI,JJ) = SQRT( 1. - BR_P2(PDIRCOSZW(JI,JJ)) )
+END DO
+#endif
+!$acc end kernels
+!
+#ifndef MNH_OPENACC
+GX_U_M_PUM = GX_U_M(PUM,PDXX,PDZZ,PDZX)
+IF (.NOT. L2D) THEN
+ GY_V_M_PVM = GY_V_M(PVM,PDYY,PDZZ,PDZY)
+END IF
+GZ_W_M_PWM = GZ_W_M(PWM,PDZZ)
+!
+ZMZF_DZZ = MZF(PDZZ)
+#else
+CALL GX_U_M_DEVICE(1,IKU,1,PUM,PDXX,PDZZ,PDZX,GX_U_M_PUM)
+IF (.NOT. L2D) THEN
+ CALL GY_V_M_DEVICE(1,IKU,1,PVM,PDYY,PDZZ,PDZY,GY_V_M_PVM)
+END IF
+CALL GZ_W_M_DEVICE(1,IKU,1,PWM,PDZZ,GZ_W_M_PWM)
+!
+CALL MZF_DEVICE(1,IKU,1,PDZZ,ZMZF_DZZ)
+#endif
+!
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZFLX, 'TURB_HOR_DYN_CORR::ZFLX' )
+
+
+! compute the coefficients for the uncentred gradient computation near the
+! ground
+!
+!* 9. < U'U'>
+! -------
+!
+! Computes the U variance
+IF (.NOT. L2D) THEN
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK)= (2./3.) * PTKEM(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) *( (4./3.) * GX_U_M_PUM(JI,JJ,JK) &
+ -(2./3.) * ( GY_V_M_PVM(JI,JJ,JK) &
+ +GZ_W_M_PWM(JI,JJ,JK) ) )
+ END DO !CONCURRENT
+ !$acc end kernels
+ !! & to be tested later
+ !! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
+ELSE
+ !$acc kernels async(2)
+ ZFLX(:,:,:)= (2./3.) * PTKEM &
+ - XCMFS * PK *( (4./3.) * GX_U_M_PUM &
+ -(2./3.) * ( GZ_W_M_PWM ) )
+ !$acc end kernels
+ !! & to be tested later
+ !! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
+END IF
+!
+!$acc kernels async(2)
+ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+!$acc end kernels
+!
+!* prescription of du/dz and dv/dz with uncentered gradient at the surface
+! prescription of dw/dz at Dz/2 above ground using the continuity equation
+! using a Boussinesq hypothesis to remove the z dependance of rhod_ref
+! (div u = 0)
+!
+#ifndef MNH_OPENACC
+ZDZZ(:,:,:) = MXM(PDZZ(:,:,IKB:IKB+2))
+#else
+CALL MXM_DEVICE(PDZZ(:,:,IKB:IKB+2),ZDZZ(:,:,:))
+#endif
+!$acc kernels async(3)
+ZCOEFF(:,:,IKB+2)= - ZDZZ(:,:,2) / &
+ ( (ZDZZ(:,:,3)+ZDZZ(:,:,2)) * ZDZZ(:,:,3) )
+ZCOEFF(:,:,IKB+1)= (ZDZZ(:,:,3)+ZDZZ(:,:,2)) / &
+ ( ZDZZ(:,:,2) * ZDZZ(:,:,3) )
+ZCOEFF(:,:,IKB)= - (ZDZZ(:,:,3)+2.*ZDZZ(:,:,2)) / &
+ ( (ZDZZ(:,:,3)+ZDZZ(:,:,2)) * ZDZZ(:,:,2) )
+!$acc end kernels
+!
+#ifndef MNH_OPENACC
+ZDU_DZ_DZS_DX(:,:,:)=MXF ((ZCOEFF(:,:,IKB+2:IKB+2)*PUM(:,:,IKB+2:IKB+2) &
+ +ZCOEFF(:,:,IKB+1:IKB+1)*PUM(:,:,IKB+1:IKB+1) &
+ +ZCOEFF(:,:,IKB :IKB )*PUM(:,:,IKB :IKB ) &
+ )* 0.5 * ( PDZX(:,:,IKB+1:IKB+1)+PDZX(:,:,IKB:IKB)) &
+ )/ MXF(PDXX(:,:,IKB:IKB))
+!
+ZDZZ(:,:,:) = MYM(PDZZ(:,:,IKB:IKB+2))
+#else
+!$acc kernels async(3)
+ZTMP1_DEVICE(:,:,1) = (ZCOEFF(:,:,IKB+2)*PUM(:,:,IKB+2) &
+ +ZCOEFF(:,:,IKB+1)*PUM(:,:,IKB+1) &
+ +ZCOEFF(:,:,IKB )*PUM(:,:,IKB) &
+ )* 0.5 * ( PDZX(:,:,IKB+1)+PDZX(:,:,IKB))
+!$acc end kernels
+!
+!!! wait for the computation of ZCOEFF and ZTMP1_DEVICE
+!$acc wait(3)
+!
+CALL MXF_DEVICE(ZTMP1_DEVICE(:,:,1:1), ZTMP2_DEVICE(:,:,1:1))
+CALL MXF_DEVICE(PDXX(:,:,IKB:IKB), ZTMP1_DEVICE(:,:,1:1))
+!$acc kernels async(3)
+ZDU_DZ_DZS_DX(:,:,1) = ZTMP2_DEVICE(:,:,1) / ZTMP1_DEVICE(:,:,1)
+!$acc end kernels
+!
+CALL MYM_DEVICE(PDZZ(:,:,IKB:IKB+2),ZDZZ(:,:,:))
+#endif
+!$acc kernels async(4)
+ZCOEFF(:,:,IKB+2)= - ZDZZ(:,:,2) / &
+ ( (ZDZZ(:,:,3)+ZDZZ(:,:,2)) * ZDZZ(:,:,3) )
+ZCOEFF(:,:,IKB+1)= (ZDZZ(:,:,3)+ZDZZ(:,:,2)) / &
+ ( ZDZZ(:,:,2) * ZDZZ(:,:,3) )
+ZCOEFF(:,:,IKB)= - (ZDZZ(:,:,3)+2.*ZDZZ(:,:,2)) / &
+ ( (ZDZZ(:,:,3)+ZDZZ(:,:,2)) * ZDZZ(:,:,2) )
+!$acc end kernels
+!
+#ifndef MNH_OPENACC
+ZDV_DZ_DZS_DY(:,:,:)=MYF ((ZCOEFF(:,:,IKB+2:IKB+2)*PVM(:,:,IKB+2:IKB+2) &
+ +ZCOEFF(:,:,IKB+1:IKB+1)*PVM(:,:,IKB+1:IKB+1) &
+ +ZCOEFF(:,:,IKB :IKB )*PVM(:,:,IKB :IKB ) &
+ )* 0.5 * ( PDZY(:,:,IKB+1:IKB+1)+PDZY(:,:,IKB:IKB)) &
+ )/ MYF(PDYY(:,:,IKB:IKB))
+#else
+!$acc kernels async(4)
+ZTMP3_DEVICE(:,:,1) = (ZCOEFF(:,:,IKB+2)*PVM(:,:,IKB+2) &
+ +ZCOEFF(:,:,IKB+1)*PVM(:,:,IKB+1) &
+ +ZCOEFF(:,:,IKB)*PVM(:,:,IKB) &
+ )* 0.5 * ( PDZY(:,:,IKB+1)+PDZY(:,:,IKB))
+!$acc end kernels
+!
+!!! wait for the computation of ZCOEFF and ZTMP3_DEVICE
+!$acc wait(4)
+#endif
+!
+#ifndef MNH_OPENACC
+ZDU_DX(:,:,:)= DXF(PUM(:,:,IKB:IKB)) / MXF(PDXX(:,:,IKB:IKB)) &
+ - ZDU_DZ_DZS_DX(:,:,:)
+
+ZDV_DY(:,:,:)= DYF(PVM(:,:,IKB:IKB)) / MYF(PDYY(:,:,IKB:IKB)) &
+ - ZDV_DZ_DZS_DY(:,:,:)
+#else
+CALL MYF_DEVICE(ZTMP3_DEVICE(:,:,1:1), ZTMP4_DEVICE(:,:,1:1))
+CALL MYF_DEVICE(PDYY(:,:,IKB:IKB), ZTMP3_DEVICE(:,:,1:1))
+!$acc kernels async(4)
+ZDV_DZ_DZS_DY(:,:,1)= ZTMP4_DEVICE(:,:,1) / ZTMP3_DEVICE(:,:,1)
+!$acc end kernels
+!
+!
+!!! wait for the computation of ZDU_DZ_DZS_DX
+!$acc wait(3)
+!
+CALL DXF_DEVICE(PUM(:,:,IKB:IKB),ZTMP1_DEVICE(:,:,1:1))
+CALL MXF_DEVICE(PDXX(:,:,IKB:IKB),ZTMP2_DEVICE(:,:,1:1))
+!$acc kernels async(3)
+ZDU_DX(:,:,1)= ZTMP1_DEVICE(:,:,1) / ZTMP2_DEVICE(:,:,1) - ZDU_DZ_DZS_DX(:,:,1)
+!$acc end kernels
+
+!!! wait for the computation of ZDV_DZ_DZS_DY
+!$acc wait(4)
+!
+CALL DYF_DEVICE(PVM(:,:,IKB:IKB),ZTMP3_DEVICE(:,:,1:1))
+CALL MYF_DEVICE(PDYY(:,:,IKB:IKB),ZTMP4_DEVICE(:,:,1:1))
+!$acc kernels! async(4)
+ZDV_DY(:,:,1)= ZTMP3_DEVICE(:,:,1) / ZTMP4_DEVICE(:,:,1) - ZDV_DZ_DZS_DY(:,:,1)
+!$acc end kernels
+!
+!
+!!! wait for the computation of ZDU_DX and ZDV_DY
+!$acc wait(3) async(4)
+#endif
+!
+!$acc kernels async(4)
+ZDW_DZ(:,:,:)=-ZDU_DX(:,:,:)-ZDV_DY(:,:,:)
+!$acc end kernels
+!
+!* computation
+!
+!!! wait for the computation of ZFLX
+!$acc wait(2) async(4)
+!!! wait for the computation of ZDW_DZ
+!$acc wait(4)
+!
+! ! !!! we can launch the update of ZFLX on the part that has already been computed
+! ! !$acc update self(ZFLX(:,:,IKB+1:)) async(10)
+!attention !!!!! je ne comprends pas pourquoi mais ce update plante à l'execution...
+! du coup je ne peux pas faire de update self asynchrone...
+!
+!$acc kernels async(3)
+ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
+ - XCMFS * PK(:,:,IKB) * 2. * ZDU_DX(:,:,1)
+!$acc end kernels
+
+
+!! & to be tested later
+!! + XCMFB * PLM(:,:,IKB:IKB) /SQRT(PTKEM(:,:,IKB:IKB)) * &
+!! (-2./3.) * PTP(:,:,IKB:IKB)
+!
+! extrapolates this flux under the ground with the surface flux
+!
+!
+!!! wait for the computation of ZDIRSINZW
+!$acc wait(1)
+!
+!$acc kernels async(4)
+#ifndef MNH_BITREP
+ZFLX(:,:,IKB-1) = &
+ PTAU11M(:,:) * PCOSSLOPE(:,:)**2 * PDIRCOSZW(:,:)**2 &
+ -2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
+ + PTAU22M(:,:) * PSINSLOPE(:,:)**2 &
+ + PTAU33M(:,:) * PCOSSLOPE(:,:)**2 * ZDIRSINZW(:,:)**2 &
+ +2. * PCDUEFF(:,:) * ( &
+ PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) &
+ - PUSLOPEM(:,:) * PCOSSLOPE(:,:)**2 * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) )
+#else
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ -2. * PTAU12M(JI,JJ) * PCOSSLOPE(JI,JJ)* PSINSLOPE(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ + PTAU22M(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) &
+ + PTAU33M(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ +2. * PCDUEFF(JI,JJ) * ( &
+ PVSLOPEM(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * ZDIRSINZW(JI,JJ) &
+ - PUSLOPEM(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) * ZDIRSINZW(JI,JJ) * PDIRCOSZW(JI,JJ) )
+END DO ! CONCURRENT
+#endif
+!$acc end kernels
+!
+!!! wait for the computation of ZFLX(:,:,IKB) and ZFLX(:,:,IKB-1)
+!$acc wait(3) async(4)
+!
+!$acc kernels async(4)
+ZFLX(:,:,IKB-1) = 2. * ZFLX(:,:,IKB-1) - ZFLX(:,:,IKB)
+!$acc end kernels
+!
+!
+!!! wait for the computation of ZFLX(:,:,IKB-1)
+!$acc wait(4)
+!
+
+
+! ! !!! we can launch the update of ZFLX on the rest
+! ! !$acc update self(ZFLX(:,:,1:IKB)) async(11)
+! ! !
+! ! !!! and wait for the update self(ZFLX(...)) to complete
+! ! !$acc wait(10)
+! ! !$acc wait(11)
+!attention !!!!! je ne comprends pas pourquoi mais le update self(ZFLX(:,:,IKB+1:)) plante à l'execution...
+! du coup je ne peux pas faire de update self asynchrone...
+
+
+!
+!!! at this point there are no more async operations running
+!!! to be absolutely sure, we do a wait
+!$acc wait
+!
+!!$!$acc update self(ZFLX)
+!!$CALL UPDATE_HALO_ll(TZFIELDS_ll, IINFO_ll)
+!!$!$acc update device(ZFLX) async(10)
+CALL GET_HALO_D(ZFLX)
+!
+IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ ! stores <U U>
+ TZFIELD%CMNHNAME = 'U_VAR'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'U_VAR'
+ TZFIELD%CUNITS = 'm2 s-2'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_U_VAR'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX)
+END IF
+!
+! Complete the U tendency
+#ifndef MNH_OPENACC
+IF (.NOT. LFLAT) THEN
+ PRUS(:,:,:)=PRUS &
+ -DXM(PRHODJ * ZFLX / MXF(PDXX) ) &
+ +DZF( PDZX / MZM(PDXX) * MXM( MZM(PRHODJ*ZFLX) * PINV_PDZZ ) )
+ELSE
+ PRUS(:,:,:)=PRUS -DXM(PRHODJ * ZFLX / MXF(PDXX) )
+END IF
+#else
+CALL MXF_DEVICE(PDXX, ZTMP1_DEVICE)
+!$acc kernels async(10)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK)
+END DO !CONCURRENT
+!$acc end kernels
+!
+!!! wait for the computation of ZTMP2_DEVICE and the update of ZFLX
+!$acc wait(10)
+!
+CALL DXM_DEVICE(ZTMP2_DEVICE, ZTMP3_DEVICE)
+IF (.NOT. LFLAT) THEN
+ CALL MZM_DEVICE(PDXX,ZTMP1_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL MXM_DEVICE( ZTMP2_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP1_DEVICE)
+ !$acc kernels async(1)
+ PRUS(:,:,:)=PRUS(:,:,:) &
+ -ZTMP3_DEVICE(:,:,:) &
+ +ZTMP1_DEVICE(:,:,:)
+ !$acc end kernels
+ELSE
+ !$acc kernels async(1)
+ PRUS(:,:,:)=PRUS(:,:,:) - ZTMP3_DEVICE(:,:,:)
+ !$acc end kernels
+END IF
+#endif
+!
+IF (KSPLT==1) THEN
+ ! Contribution to the dynamic production of TKE:
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZFLX(JI,JJ,JK) * GX_U_M_PUM(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ !
+ ! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
+ !
+ !$acc kernels async(2)
+ ZWORK(:,:,IKB) = 0.5* ( -ZFLX(:,:,IKB)*ZDU_DX(:,:,1) + ZWORK(:,:,IKB+1) )
+ !$acc end kernels
+ !
+ !$acc kernels async(2)
+ PDP(:,:,:) = PDP(:,:,:) + ZWORK(:,:,:)
+ !$acc end kernels
+END IF
+!
+! Storage in the LES configuration
+!
+IF (LLES_CALL .AND. KSPLT==1) THEN
+ CALL SECOND_MNH(ZTIME1)
+!$acc data copy(X_LES_SUBGRID_U2,X_LES_RES_ddxa_U_SBG_UaU)
+ CALL LES_MEAN_SUBGRID( ZFLX, X_LES_SUBGRID_U2 )
+#ifndef MNH_OPENACC
+ CALL LES_MEAN_SUBGRID( -ZWORK, X_LES_RES_ddxa_U_SBG_UaU , .TRUE.)
+#else
+ !
+ !!! wait for the computation of ZWORK and PDP
+ !$acc wait(2)
+ !
+ !$acc kernels
+ ZTMP1_DEVICE = -ZWORK
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_RES_ddxa_U_SBG_UaU , .TRUE.)
+ !
+#endif
+!$acc end data
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+
+!
+!* 10. < V'V'>
+! -------
+!
+!!! wait for the computation of ZWORK and PDP (that uses ZFLX)
+!$acc wait(2)
+!
+! Computes the V variance
+IF (.NOT. L2D) THEN
+ !$acc kernels async(3)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK)= (2./3.) * PTKEM(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) *( (4./3.) * GY_V_M_PVM(JI,JJ,JK) &
+ -(2./3.) * ( GX_U_M_PUM(JI,JJ,JK) &
+ +GZ_W_M_PWM(JI,JJ,JK) ) )
+ END DO !CONCURRENT
+ !$acc end kernels
+ !! & to be tested
+ !! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
+ !
+ELSE
+ !$acc kernels async(3)
+ ZFLX(:,:,:)= (2./3.) * PTKEM &
+ - XCMFS * PK *(-(2./3.) * ( GX_U_M_PUM &
+ +GZ_W_M_PWM ) )
+ !$acc end kernels
+ !! & to be tested
+ !! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
+ !
+END IF
+!
+!$acc kernels async(3)
+ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+!$acc end kernels
+!
+! ! !!! wait for the computation of ZFLX to begin the update
+! ! !$acc wait(3)
+! ! !$acc update self(ZFLX(:,:,IKB+1:)) async(10)
+!
+!$acc kernels async(3)
+ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
+ - XCMFS * PK(:,:,IKB) * 2. * ZDV_DY(:,:,1)
+!$acc end kernels
+
+!! & to be tested
+!! + XCMFB * PLM(:,:,IKB:IKB) /SQRT(PTKEM(:,:,IKB:IKB)) * &
+!! (-2./3.) * PTP(:,:,IKB:IKB)
+!
+! extrapolates this flux under the ground with the surface flux
+!$acc kernels async(3)
+#ifndef MNH_BITREP
+ZFLX(:,:,IKB-1) = &
+ PTAU11M(:,:) * PSINSLOPE(:,:)**2 * PDIRCOSZW(:,:)**2 &
+ +2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
+ + PTAU22M(:,:) * PCOSSLOPE(:,:)**2 &
+ + PTAU33M(:,:) * PSINSLOPE(:,:)**2 * ZDIRSINZW(:,:)**2 &
+ -2. * PCDUEFF(:,:)* ( &
+ PUSLOPEM(:,:) * PSINSLOPE(:,:)**2 * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) &
+ + PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) )
+#else
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ +2. * PTAU12M(JI,JJ) * PCOSSLOPE(JI,JJ)* PSINSLOPE(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ + PTAU22M(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) &
+ + PTAU33M(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ -2. * PCDUEFF(JI,JJ)* ( &
+ PUSLOPEM(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) * ZDIRSINZW(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ + PVSLOPEM(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * ZDIRSINZW(JI,JJ) )
+END DO ! CONCURRENT
+#endif
+!$acc end kernels
+!
+!$acc kernels async(3)
+ZFLX(:,:,IKB-1) = 2. * ZFLX(:,:,IKB-1) - ZFLX(:,:,IKB)
+!$acc end kernels
+!
+!
+! ! !!! wait for the computation of ZFLX(:,:,1:IKB) to begin the update
+! ! !$acc update self(ZFLX(:,:,IKB+1:)) async(3)
+! ! !
+! ! !!! and wait for the update self(ZFLX(...)) to complete
+! ! !$acc wait(10)
+! ! !$acc wait(3)
+!
+!$acc wait(3)
+!!$!$acc update self(ZFLX)
+!!$CALL UPDATE_HALO_ll(TZFIELDS_ll, IINFO_ll)
+!!$!$acc update device(ZFLX) async(10)
+CALL GET_HALO_D(ZFLX)
+!
+IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ ! stores <V V>
+ TZFIELD%CMNHNAME = 'V_VAR'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'V_VAR'
+ TZFIELD%CUNITS = 'm2 s-2'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_V_VAR'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX)
+END IF
+!
+!!! wait for the computation of PRUS (that uses ZTMP1_DEVICE and ZTMP3_DEVICE)
+!$acc wait(1)
+!
+!
+!
+! Complete the V tendency
+IF (.NOT. L2D) THEN
+#ifndef MNH_OPENACC
+ IF (.NOT. LFLAT) THEN
+ PRVS(:,:,:)=PRVS &
+ -DYM(PRHODJ * ZFLX / MYF(PDYY) ) &
+ +DZF( PDZY / MZM(PDYY) * &
+ MYM( MZM(PRHODJ*ZFLX) * PINV_PDZZ ) )
+ ELSE
+ PRVS(:,:,:)=PRVS -DYM(PRHODJ * ZFLX / MYF(PDYY) )
+ END IF
+!
+! Contribution to the dynamic production of TKE:
+ IF (KSPLT==1) ZWORK(:,:,:) = - ZFLX(:,:,:) * GY_V_M_PVM
+#else
+ CALL MYF_DEVICE(PDYY, ZTMP1_DEVICE)
+ !$acc kernels async(10)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ !
+ !!! wait for the computation of ZTMP2_DEVICE and the update of ZFLX
+ !$acc wait(10)
+ !
+ CALL DYM_DEVICE( ZTMP2_DEVICE,ZTMP3_DEVICE )
+ IF (.NOT. LFLAT) THEN
+ CALL MZM_DEVICE(PDYY,ZTMP1_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP2_DEVICE,ZTMP4_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP4_DEVICE )
+ !$acc kernels async(1)
+ PRVS(:,:,:)=PRVS(:,:,:) &
+ -ZTMP3_DEVICE(:,:,:) &
+ +ZTMP4_DEVICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels async(1)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRVS(JI,JJ,JK)=PRVS(JI,JJ,JK) - ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ END IF
+! Contribution to the dynamic production of TKE:
+ IF (KSPLT==1) THEN
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZFLX(JI,JJ,JK) * GY_V_M_PVM(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ ENDIF
+#endif
+ELSE
+ !$acc kernels async(2)
+ ZWORK(:,:,:) = 0.
+ !$acc end kernels
+END IF
+!
+IF (KSPLT==1) THEN
+ !
+ ! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
+ !
+ !$acc kernels async(2)
+ ZWORK(:,:,IKB) = 0.5* ( -ZFLX(:,:,IKB)*ZDV_DY(:,:,1) + ZWORK(:,:,IKB+1) )
+ !$acc end kernels
+ !
+ !$acc kernels async(2)
+ PDP(:,:,:) = PDP(:,:,:) + ZWORK(:,:,:)
+ !$acc end kernels
+END IF
+!
+! Storage in the LES configuration
+!
+IF (LLES_CALL .AND. KSPLT==1) THEN
+ CALL SECOND_MNH(ZTIME1)
+!$acc data copy(X_LES_SUBGRID_V2,X_LES_RES_ddxa_V_SBG_UaV)
+ CALL LES_MEAN_SUBGRID( ZFLX, X_LES_SUBGRID_V2 )
+#ifndef MNH_OPENACC
+ CALL LES_MEAN_SUBGRID( -ZWORK, X_LES_RES_ddxa_V_SBG_UaV , .TRUE.)
+#else
+ !
+ !!! wait for the computation of ZWORK and PDP
+ !$acc wait(2)
+ !
+ !$acc kernels
+ ZTMP1_DEVICE = -ZWORK
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_RES_ddxa_V_SBG_UaV , .TRUE.)
+ !
+#endif
+!$acc end data
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+!
+!* 11. < W'W'>
+! -------
+!
+! Computes the W variance
+IF (.NOT. L2D) THEN
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = (2./3.) * PTKEM(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) *( (4./3.) * GZ_W_M_PWM(JI,JJ,JK) &
+ -(2./3.) * ( GX_U_M_PUM(JI,JJ,JK) &
+ +GY_V_M_PVM(JI,JJ,JK) ) )
+ END DO !CONCURRENT
+ !$acc end kernels
+ !! & to be tested
+ !! -2.* XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
+ELSE
+ !$acc kernels async(2)
+ ZFLX(:,:,:)= (2./3.) * PTKEM &
+ - XCMFS * PK *( (4./3.) * GZ_W_M_PWM &
+ -(2./3.) * ( GX_U_M_PUM ) )
+ !$acc end kernels
+ !! & to be tested
+ !! -2.* XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
+END IF
+!
+!$acc kernels async(2)
+ZFLX(:,:,IKE+1)= ZFLX(:,:,IKE)
+!$acc end kernels
+!
+!!! wait for the computation of ZWORK, PDP and ZFLX
+!$acc wait(2)
+!
+!
+!$acc kernels async(2)
+ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
+ - XCMFS * PK(:,:,IKB) * 2. * ZDW_DZ(:,:,1)
+!$acc end kernels
+!
+
+! & to be tested
+! - 2.* XCMFB * PLM(:,:,IKB:IKB) /SQRT(PTKEM(:,:,IKB:IKB)) * &
+! (-2./3.) * PTP(:,:,IKB:IKB)
+! extrapolates this flux under the ground with the surface flux
+!$acc kernels async(3)
+#ifndef MNH_BITREP
+ZFLX(:,:,IKB-1) = &
+ PTAU11M(:,:) * ZDIRSINZW(:,:)**2 &
+ + PTAU33M(:,:) * PDIRCOSZW(:,:)**2 &
+ +2. * PCDUEFF(:,:)* PUSLOPEM(:,:) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:)
+#else
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ + PTAU33M(JI,JJ) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ +2. * PCDUEFF(JI,JJ)* PUSLOPEM(JI,JJ) * ZDIRSINZW(JI,JJ) * PDIRCOSZW(JI,JJ)
+END DO ! CONCURRENT
+#endif
+!$acc end kernels
+ !
+!
+!!! wait for the computation of ZFLX(:,:,IKB-1) and ZFLX(:,:,IKB)
+!$acc wait(2) async(3)
+!
+!$acc kernels async(3)
+ZFLX(:,:,IKB-1) = 2. * ZFLX(:,:,IKB-1) - ZFLX(:,:,IKB)
+!$acc end kernels
+!
+IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ !$acc wait(3)
+ !$acc update self(ZFLX)
+ ! stores <W W>
+ TZFIELD%CMNHNAME = 'W_VAR'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'W_VAR'
+ TZFIELD%CUNITS = 'm2 s-2'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_W_VAR'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX)
+END IF
+!
+!
+!!! wait for the computation of PRVS (that uses ZTMP1_DEVICE and ZTMP3_DEVICE)
+!$acc wait(1)
+!
+
+!
+! Complete the W tendency
+!
+!PRWS(:,:,:)=PRWS(:,:,:) - DZM( PRHODJ*ZFLX/MZF(PDZZ) )
+!$acc kernels async(2)
+ZDFDDWDZ(:,:,:) = - XCMFS * PK(:,:,:) * (4./3.)
+!$acc end kernels
+!$acc kernels async(2)
+ZDFDDWDZ(:,:,:IKB) = 0.
+!$acc end kernels
+!
+!!! wait for the computation of ZFLX(:,:,IKB-1) and ZDFDDWDZ
+!$acc wait(3) async(2)
+!$acc wait(2)
+!
+CALL TRIDIAG_W(PWM,ZFLX,ZDFDDWDZ,PTSTEP,ZMZF_DZZ,PRHODJ,ZWP)
+!
+#ifndef MNH_OPENACC
+PRWS = PRWS(:,:,:) + MZM(PRHODJ(:,:,:))*(ZWP(:,:,:)-PWM(:,:,:))/PTSTEP
+#else
+CALL MZM_DEVICE(PRHODJ(:,:,:),ZTMP1_DEVICE)
+!$acc kernels async(1)
+PRWS = PRWS(:,:,:) + ZTMP1_DEVICE *(ZWP(:,:,:)-PWM(:,:,:))/PTSTEP
+!$acc end kernels
+#endif
+!
+!* recomputes flux using guess of W
+!
+#ifndef MNH_OPENACC
+GZ_W_M_ZWP = GZ_W_M(ZWP,PDZZ)
+#else
+CALL GZ_W_M_DEVICE(1,IKU,1,ZWP,PDZZ,GZ_W_M_ZWP)
+#endif
+!$acc kernels async(2)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKB+1:JKU)
+ ZFLX(JI,JJ,JK)=ZFLX(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) * (4./3.) * (GZ_W_M_ZWP(JI,JJ,JK) - GZ_W_M_PWM(JI,JJ,JK))
+END DO !CONCURRENT
+!$acc end kernels
+!
+IF (KSPLT==1) THEN
+ !Contribution to the dynamic production of TKE:
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZFLX(JI,JJ,JK) * GZ_W_M_ZWP(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ !
+ ! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
+ !
+ !$acc kernels async(2)
+ ZWORK(:,:,IKB) = 0.5* ( -ZFLX(:,:,IKB)*ZDW_DZ(:,:,1) + ZWORK(:,:,IKB+1) )
+ !$acc end kernels
+ !
+ !$acc kernels async(2)
+ PDP(:,:,:) = PDP(:,:,:) + ZWORK(:,:,:)
+ !$acc end kernels
+END IF
+!
+! Storage in the LES configuration
+!
+!
+IF (LLES_CALL .AND. KSPLT==1) THEN
+ CALL SECOND_MNH(ZTIME1)
+#ifndef MNH_OPENACC
+ CALL LES_MEAN_SUBGRID( ZFLX, X_LES_SUBGRID_W2 )
+ CALL LES_MEAN_SUBGRID( -ZWORK, X_LES_RES_ddxa_W_SBG_UaW , .TRUE.)
+ CALL LES_MEAN_SUBGRID( GZ_M_M(PTHLM,PDZZ)*ZFLX, X_LES_RES_ddxa_Thl_SBG_UaW , .TRUE.)
+ CALL LES_MEAN_SUBGRID(ZFLX*MZF(GZ_M_W(1,IKU,1,PTHLM,PDZZ)),X_LES_RES_ddz_Thl_SBG_W2)
+ IF (KRR>=1) THEN
+ CALL LES_MEAN_SUBGRID( GZ_M_M(PRM(:,:,:,1),PDZZ)*ZFLX, &
+ X_LES_RES_ddxa_Rt_SBG_UaW , .TRUE.)
+ CALL LES_MEAN_SUBGRID(ZFLX*MZF(GZ_M_W(1,IKU,1,PRM(:,:,:,1),PDZZ)), &
+ X_LES_RES_ddz_Rt_SBG_W2)
+ END IF
+ DO JSV=1,NSV
+ CALL LES_MEAN_SUBGRID( GZ_M_M(PSVM(:,:,:,JSV),PDZZ)*ZFLX, &
+ X_LES_RES_ddxa_Sv_SBG_UaW(:,:,:,JSV) , .TRUE.)
+ CALL LES_MEAN_SUBGRID(ZFLX*MZF(GZ_M_W(1,IKU,1,PSVM(:,:,:,JSV),PDZZ)), &
+ X_LES_RES_ddz_Sv_SBG_W2(:,:,:,JSV))
+ END DO
+#else
+!$acc data copy(X_LES_SUBGRID_W2,X_LES_RES_ddxa_W_SBG_UaW,X_LES_RES_ddxa_Thl_SBG_UaW,X_LES_RES_ddz_Thl_SBG_W2)
+ !
+ CALL LES_MEAN_SUBGRID( ZFLX, X_LES_SUBGRID_W2 )
+ !
+ !
+ !!! wait for the computation of ZFLX, ZDP and ZWORK
+ !$acc wait(2)
+ !
+ !$acc kernels
+ ZTMP1_DEVICE = -ZWORK
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_RES_ddxa_W_SBG_UaW , .TRUE.)
+ !
+ CALL GZ_M_M_DEVICE(1,IKU,1,PTHLM,PDZZ,ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP2_DEVICE = ZTMP1_DEVICE * ZFLX
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP2_DEVICE, X_LES_RES_ddxa_Thl_SBG_UaW , .TRUE.)
+ !
+ CALL GZ_M_W_DEVICE(1,IKU,1,PTHLM,PDZZ,ZTMP1_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE = ZFLX*ZTMP2_DEVICE
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP3_DEVICE,X_LES_RES_ddz_Thl_SBG_W2)
+ !
+!$acc end data
+ !
+ IF (KRR>=1) THEN
+!$acc data copy(X_LES_RES_ddxa_Rt_SBG_UaW,X_LES_RES_ddz_Rt_SBG_W2)
+ !
+ CALL GZ_M_M_DEVICE(1,IKU,1,PRM(:,:,:,1),PDZZ,ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP2_DEVICE = ZTMP1_DEVICE*ZFLX
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP2_DEVICE, X_LES_RES_ddxa_Rt_SBG_UaW , .TRUE.)
+ !
+ CALL GZ_M_W_DEVICE(1,IKU,1,PRM(:,:,:,1),PDZZ,ZTMP1_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE = ZFLX*ZTMP2_DEVICE
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP3_DEVICE, X_LES_RES_ddz_Rt_SBG_W2)
+ !
+!$acc end data
+ END IF
+!$acc data copy(X_LES_RES_ddxa_Sv_SBG_UaW,X_LES_RES_ddz_Sv_SBG_W2)
+ DO JSV=1,NSV
+ !
+ !
+ CALL GZ_M_M_DEVICE(1,IKU,1,PSVM(:,:,:,JSV),PDZZ,ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP2_DEVICE = ZTMP1_DEVICE*ZFLX
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP2_DEVICE, &
+ X_LES_RES_ddxa_Sv_SBG_UaW(:,:,:,JSV) , .TRUE.)
+ !
+ CALL GZ_M_W_DEVICE(1,IKU,1,PSVM(:,:,:,JSV),PDZZ,ZTMP1_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE = ZFLX*ZTMP2_DEVICE
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID(ZTMP3_DEVICE, X_LES_RES_ddz_Sv_SBG_W2(:,:,:,JSV))
+ !
+ !
+ END DO
+!$acc end data
+#endif
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+!
+!
+!!! wait for the computation of ZFLX, ZDP and ZWORK
+!$acc wait(2)
+!!! wait for the computation of PRWS
+!$acc wait(1)
+!
+!!! et un dernier wait pour etre sur
+!$acc wait
+!
+CALL CLEANLIST_ll(TZFIELDS_ll)
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( prus, "Turb_hor_dyn_corr end:prus" )
+ call Mppdb_check( prvs, "Turb_hor_dyn_corr end:prvs" )
+ call Mppdb_check( prws, "Turb_hor_dyn_corr end:prws" )
+ call Mppdb_check( pdp, "Turb_hor_dyn_corr end:pdp" )
+ call Mppdb_check( ptp, "Turb_hor_dyn_corr end:ptp" )
+end if
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+DEALLOCATE (ZFLX, ZWORK, ZDIRSINZW, ZCOEFF, ZDZZ, &
+ GX_U_M_PUM, GY_V_M_PVM, GZ_W_M_PWM, GZ_W_M_ZWP, &
+ ZMZF_DZZ, ZDFDDWDZ, ZWP, &
+ ZDU_DZ_DZS_DX, ZDV_DZ_DZS_DY, ZDU_DX, ZDV_DY, ZDW_DZ )
+#else
+CALL MNH_REL_ZT3D(IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+CALL MNH_REL_ZT3D(IZFLX, IZWORK, IZDIRSINZW, &
+ IGX_U_M_PUM, IGY_V_M_PVM, IGZ_W_M_PWM, IGZ_W_M_ZWP, &
+ IZMZF_DZZ, IZDFDDWDZ, IZWP, &
+ IZDU_DZ_DZS_DX, IZDV_DZ_DZS_DY, IZDU_DX, IZDV_DY, IZDW_DZ, &
+ IZCOEFF, IZDZZ )
+
+#endif
+
+
+!$acc end data
+
+END SUBROUTINE TURB_HOR_DYN_CORR
diff --git a/src/ZSOLVER/turb_hor_thermo_flux.f90 b/src/ZSOLVER/turb_hor_thermo_flux.f90
new file mode 100644
index 0000000000000000000000000000000000000000..76a1d60c284b3896f10722e6bf4f6a0112c2f37c
--- /dev/null
+++ b/src/ZSOLVER/turb_hor_thermo_flux.f90
@@ -0,0 +1,1814 @@
+!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.
+!-----------------------------------------------------------------
+! ################################
+ MODULE MODI_TURB_HOR_THERMO_FLUX
+! ################################
+!
+INTERFACE
+!
+ SUBROUTINE TURB_HOR_THERMO_FLUX(KSPLT, KRR, KRRL, KRRI, &
+ OCLOSE_OUT,OTURB_FLX,OSUBG_COND, &
+ TPFILE, &
+ PK,PINV_PDXX,PINV_PDYY,PINV_PDZZ,PMZM_PRHODJ, &
+ PDXX,PDYY,PDZZ,PDZX,PDZY, &
+ PDIRCOSXW,PDIRCOSYW, &
+ PRHODJ, &
+ PSFTHM,PSFRM, &
+ PWM,PTHLM,PRM, &
+ PATHETA,PAMOIST,PSRCM,PFRAC_ICE, &
+ PRTHLS,PRRS )
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KSPLT ! split process index
+INTEGER, INTENT(IN) :: KRR ! number of moist var.
+INTEGER, INTENT(IN) :: KRRL ! number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! number of ice water var.
+LOGICAL, INTENT(IN) :: OCLOSE_OUT ! switch for syncronous
+ ! file opening
+LOGICAL, INTENT(IN) :: OTURB_FLX ! switch to write the
+ ! turbulent fluxes in the syncronous FM-file
+LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for sub-grid
+! condensation
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PK ! Turbulent diffusion doef.
+ ! PK = PLM * SQRT(PTKEM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDXX ! 1./PDXX
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDYY ! 1./PDYY
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDZZ ! 1./PDZZ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMZM_PRHODJ ! MZM(PRHODJ)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX, PDYY, PDZZ, PDZX, PDZY
+ ! Metric coefficients
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSXW, PDIRCOSYW
+! Director Cosinus along x, y and z directions at surface w-point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density * grid volume
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PSFTHM,PSFRM
+!
+! Variables at t-1
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PWM
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLM
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM ! mixing ratios at t-1,
+ ! where PRM(:,:,:,1) = conservative mixing ratio
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PATHETA ! coefficients between
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAMOIST ! s and Thetal and Rnp
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRCM
+ ! normalized 2nd-order flux
+ ! s'r'c/2Sigma_s2 at t-1 multiplied by Lambda_3
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFRAC_ICE ! ri fraction of rc+ri
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRTHLS
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRRS ! var. at t+1 -split-
+!
+END SUBROUTINE TURB_HOR_THERMO_FLUX
+!
+END INTERFACE
+!
+END MODULE MODI_TURB_HOR_THERMO_FLUX
+! ################################################################
+ SUBROUTINE TURB_HOR_THERMO_FLUX(KSPLT, KRR, KRRL, KRRI, &
+ OCLOSE_OUT,OTURB_FLX,OSUBG_COND, &
+ TPFILE, &
+ PK,PINV_PDXX,PINV_PDYY,PINV_PDZZ,PMZM_PRHODJ, &
+ PDXX,PDYY,PDZZ,PDZX,PDZY, &
+ PDIRCOSXW,PDIRCOSYW, &
+ PRHODJ, &
+ PSFTHM,PSFRM, &
+ PWM,PTHLM,PRM, &
+ PATHETA,PAMOIST,PSRCM,PFRAC_ICE, &
+ PRTHLS,PRRS )
+! ################################################################
+!
+!
+!!**** *TURB_HOR* -routine to compute the source terms in the meso-NH
+!! model equations due to the non-vertical turbulent fluxes.
+!!
+!! PURPOSE
+!! -------
+!!
+!! see TURB_HOR
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! Joan Cuxart * INM and Meteo-France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Aug , 1997 (V. Saravane) spliting of TURB_HOR
+!! Nov 27, 1997 (V. Masson) clearing of the routine
+!! Feb. 18, 1998 (J. Stein) bug for v'RC'
+!! Oct 18, 2000 (V. Masson) LES computations + LFLAT switch
+!! Nov 06, 2002 (V. Masson) LES budgets
+!! Feb 20, 2003 (JP Pinty) Add PFRAC_ICE
+!! October 2009 (G. Tanguy) add ILENCH=LEN(YCOMMENT) after
+!! change of YCOMMENT
+!! 04/2016 (M.Moge) Use openACC directives to port the TURB part of Meso-NH on GPU
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! --------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_CONF
+USE MODD_CTURB
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_PARAMETERS
+USE MODD_LES
+!
+USE MODE_FIELD, ONLY: TFIELDDATA, TYPEREAL
+USE MODE_IO_FIELD_WRITE, only: IO_Field_write
+use mode_mppdb
+!
+USE MODI_GRADIENT_M
+USE MODI_GRADIENT_U
+USE MODI_GRADIENT_V
+USE MODI_GRADIENT_W
+#ifndef MNH_OPENACC
+USE MODI_SHUMAN
+#else
+USE MODI_SHUMAN_DEVICE
+#endif
+USE MODI_LES_MEAN_SUBGRID
+!
+USE MODI_SECOND_MNH
+!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D, &
+ MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 declaration of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KSPLT ! split process index
+INTEGER, INTENT(IN) :: KRR ! number of moist var.
+INTEGER, INTENT(IN) :: KRRL ! number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! number of ice water var.
+LOGICAL, INTENT(IN) :: OCLOSE_OUT ! switch for syncronous
+ ! file opening
+LOGICAL, INTENT(IN) :: OTURB_FLX ! switch to write the
+ ! turbulent fluxes in the syncronous FM-file
+LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for sub-grid
+! condensation
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PK ! Turbulent diffusion doef.
+ ! PK = PLM * SQRT(PTKEM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDXX ! 1./PDXX
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDYY ! 1./PDYY
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PINV_PDZZ ! 1./PDZZ
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMZM_PRHODJ ! MZM(PRHODJ)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX, PDYY, PDZZ, PDZX, PDZY
+ ! Metric coefficients
+REAL, DIMENSION(:,:), INTENT(IN) :: PDIRCOSXW, PDIRCOSYW
+! Director Cosinus along x, y and z directions at surface w-point
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density * grid volume
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PSFTHM,PSFRM
+!
+! Variables at t-1
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PWM
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLM
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM ! mixing ratios at t-1,
+ ! where PRM(:,:,:,1) = conservative mixing ratio
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PATHETA ! coefficients between
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAMOIST ! s and Thetal and Rnp
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRCM
+ ! normalized 2nd-order flux
+ ! s'r'c/2Sigma_s2 at t-1 multiplied by Lambda_3
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFRAC_ICE ! ri fraction of rc+ri
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRTHLS
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRRS ! var. at t+1 -split-
+!
+!
+!* 0.2 declaration of local variables
+!
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZFLXC ! work arrays
+!! REAL, DIMENSION(:,:,:), pointer , contiguous :: ZVPTV
+INTEGER :: IKB,IKE,IKU
+ ! Index values for the Beginning and End
+ ! mass points of the domain
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF
+ ! coefficients for the uncentred gradient
+ ! computation near the ground
+INTEGER :: IZFLX,IZFLXC,IZCOEFF
+!
+REAL :: ZTIME1, ZTIME2
+!
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, &
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE, IZTMP8_DEVICE
+#endif
+!
+TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
+!
+! ---------------------------------------------------------------------------
+
+!$acc data present( PK, PINV_PDXX, PINV_PDYY, PINV_PDZZ, PMZM_PRHODJ, &
+!$acc & PDXX, PDYY, PDZZ, PDZX, PDZY, &
+!$acc & PDIRCOSXW, PDIRCOSYW, &
+!$acc & PRHODJ, &
+!$acc & PSFTHM, PSFRM, &
+!$acc & PWM, PTHLM, PRM, &
+!$acc & PATHETA, PAMOIST, PSRCM, PFRAC_ICE, &
+!$acc & PRTHLS, PRRS )
+
+if ( mppdb_initialized ) then
+ !Check all in arrays
+ call Mppdb_check( pinv_pdxx, "Turb_hor_thermo_flux beg:pinv_pdxx" )
+ call Mppdb_check( pinv_pdyy, "Turb_hor_thermo_flux beg:pinv_pdyy" )
+ call Mppdb_check( pinv_pdzz, "Turb_hor_thermo_flux beg:pinv_pdzz" )
+ call Mppdb_check( pmzm_prhodj, "Turb_hor_thermo_flux beg:pmzm_prhodj" )
+ call Mppdb_check( pdxx, "Turb_hor_thermo_flux beg:pdxx" )
+ call Mppdb_check( pdyy, "Turb_hor_thermo_flux beg:pdyy" )
+ call Mppdb_check( pdzz, "Turb_hor_thermo_flux beg:pdzz" )
+ call Mppdb_check( pdzx, "Turb_hor_thermo_flux beg:pdzx" )
+ call Mppdb_check( pdzy, "Turb_hor_thermo_flux beg:pdzy" )
+ call Mppdb_check( pdircosxw, "Turb_hor_thermo_flux beg:pdircosxw" )
+ call Mppdb_check( pdircosyw, "Turb_hor_thermo_flux beg:pdircosyw" )
+ call Mppdb_check( prhodj, "Turb_hor_thermo_flux beg:prhodj" )
+ call Mppdb_check( psfthm, "Turb_hor_thermo_flux beg:psfthm" )
+ call Mppdb_check( psfrm, "Turb_hor_thermo_flux beg:psfrm" )
+ call Mppdb_check( pwm, "Turb_hor_thermo_flux beg:pwm" )
+ call Mppdb_check( pthlm, "Turb_hor_thermo_flux beg:pthlm" )
+ call Mppdb_check( prm, "Turb_hor_thermo_flux beg:prm" )
+ call Mppdb_check( patheta, "Turb_hor_thermo_flux beg:patheta" )
+ call Mppdb_check( pamoist, "Turb_hor_thermo_flux beg:pamoist" )
+ call Mppdb_check( psrcm, "Turb_hor_thermo_flux beg:psrcm" )
+ call Mppdb_check( pfrac_ice, "Turb_hor_thermo_flux beg:pfrac_ice" )
+ !Check all inout arrays
+ call Mppdb_check( prthls, "Turb_hor_thermo_flux beg:prthls" )
+ call Mppdb_check( prrs, "Turb_hor_thermo_flux beg:prrs" )
+end if
+
+JIU = size(pthlm, 1 )
+JJU = size(pthlm, 2 )
+JKU = size(pthlm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU) )
+allocate( zflxc(JIU,JJU,JKU) )
+! allocate( zvptv(JIU,JJU,JKU) )
+
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("TURB_HOR_THERMO_FLUX")
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+izflxc = MNH_ALLOCATE_ZT3D( zflxc,JIU,JJU,JKU )
+! izvptv= MNH_ALLOCATE_ZT3D( zvptv,JIU,JJU,JKU )
+
+izcoeff= MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+
+#endif
+
+#ifdef MNH_OPENACC
+iztmp1_device= MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device= MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device= MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device= MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device= MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+iztmp6_device= MNH_ALLOCATE_ZT3D( ztmp6_device,JIU,JJU,JKU )
+iztmp7_device= MNH_ALLOCATE_ZT3D( ztmp7_device,JIU,JJU,JKU )
+iztmp8_device= MNH_ALLOCATE_ZT3D( ztmp8_device,JIU,JJU,JKU )
+#endif
+
+!$acc data present( ZFLX, ZFLXC, ZCOEFF, &
+!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, &
+!$acc & ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE )
+
+!
+!* 1. PRELIMINARY COMPUTATIONS
+! ------------------------
+!
+IKB = 1+JPVEXT
+IKE = SIZE(PTHLM,3)-JPVEXT
+IKU = SIZE(PTHLM,3)
+!
+!
+! compute the coefficients for the uncentred gradient computation near the
+! ground
+!$acc kernels
+ZCOEFF(:,:,IKB+2)= - PDZZ(:,:,IKB+1) / &
+ ( (PDZZ(:,:,IKB+2)+PDZZ(:,:,IKB+1)) * PDZZ(:,:,IKB+2) )
+ZCOEFF(:,:,IKB+1)= (PDZZ(:,:,IKB+2)+PDZZ(:,:,IKB+1)) / &
+ ( PDZZ(:,:,IKB+1) * PDZZ(:,:,IKB+2) )
+ZCOEFF(:,:,IKB)= - (PDZZ(:,:,IKB+2)+2.*PDZZ(:,:,IKB+1)) / &
+ ( (PDZZ(:,:,IKB+2)+PDZZ(:,:,IKB+1)) * PDZZ(:,:,IKB+1) )
+!$acc end kernels
+!
+!* 2. < U' THETA'l >
+! --------------
+!
+!
+#ifndef MNH_OPENACC
+ZFLX(:,:,:) = -XCSHF * MXM( PK ) * GX_M_U(1,IKU,1,PTHLM,PDXX,PDZZ,PDZX)
+ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+#else
+CALL MXM_DEVICE( PK, ZTMP1_DEVICE )
+CALL GX_M_U_DEVICE(1,IKU,1,PTHLM,PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
+!$acc kernels
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCSHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+END DO
+ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+!$acc end kernels
+#endif
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+#ifndef MNH_OPENACC
+ZFLX(:,:,IKB:IKB) = -XCSHF * MXM( PK(:,:,IKB:IKB) ) * &
+ ( DXM(PTHLM(:,:,IKB:IKB)) * PINV_PDXX(:,:,IKB:IKB) &
+ -MXM( ZCOEFF(:,:,IKB+2:IKB+2)*PTHLM(:,:,IKB+2:IKB+2) &
+ +ZCOEFF(:,:,IKB+1:IKB+1)*PTHLM(:,:,IKB+1:IKB+1) &
+ +ZCOEFF(:,:,IKB :IKB )*PTHLM(:,:,IKB :IKB )) &
+ *0.5* ( PDZX(:,:,IKB+1:IKB+1)+PDZX(:,:,IKB:IKB)) &
+ * PINV_PDXX(:,:,IKB:IKB) )
+#else
+CALL MXM_DEVICE( PK(:,:,IKB:IKB), ZTMP1_DEVICE(:,:,1:1) )
+CALL DXM_DEVICE( PTHLM(:,:,IKB:IKB), ZTMP2_DEVICE(:,:,1:1) )
+!$acc kernels
+ZTMP3_DEVICE(:,:,1) = ZCOEFF(:,:,IKB+2)*PTHLM(:,:,IKB+2) &
+ +ZCOEFF(:,:,IKB+1)*PTHLM(:,:,IKB+1) &
+ +ZCOEFF(:,:,IKB )*PTHLM(:,:,IKB )
+!$acc end kernels
+CALL MXM_DEVICE( ZTMP3_DEVICE(:,:,1:1), ZTMP4_DEVICE(:,:,1:1))
+!$acc kernels
+ZFLX(:,:,IKB) = -XCSHF * ZTMP1_DEVICE(:,:,1) * &
+ ( ZTMP2_DEVICE(:,:,1) * PINV_PDXX(:,:,IKB) - ZTMP4_DEVICE(:,:,1) &
+ *0.5* ( PDZX(:,:,IKB+1)+PDZX(:,:,IKB)) &
+ * PINV_PDXX(:,:,IKB) )
+! acc end kernels
+#endif
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+#ifndef MNH_OPENACC
+ZFLX(:,:,IKB-1:IKB-1) = 2. * MXM( SPREAD( PSFTHM(:,:)* PDIRCOSXW(:,:), 3,1) ) &
+ - ZFLX(:,:,IKB:IKB)
+#else
+! acc kernels
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZTMP1_DEVICE(JI,JJ,1) = PSFTHM(JI,JJ)* PDIRCOSXW(JI,JJ)
+END DO
+!$acc end kernels
+ CALL MXM_DEVICE( ZTMP1_DEVICE(:,:,1:1), ZTMP2_DEVICE(:,:,1:1) )
+!$acc kernels
+ ZFLX(:,:,IKB-1) = 2. * ZTMP2_DEVICE(:,:,1) - ZFLX(:,:,IKB)
+!$acc end kernels
+#endif
+!
+! Add this source to the Theta_l sources
+!
+#ifndef MNH_OPENACC
+IF (.NOT. LFLAT) THEN
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) &
+ - DXF( MXM(PRHODJ) * ZFLX(:,:,:) * PINV_PDXX(:,:,:) ) &
+ + DZF( PMZM_PRHODJ(:,:,:) *MXF(PDZX*(MZM(ZFLX(:,:,:) * PINV_PDXX(:,:,:)))) * PINV_PDZZ(:,:,:) )
+ELSE
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - DXF( MXM(PRHODJ) * ZFLX(:,:,:) * PINV_PDXX(:,:,:) )
+END IF
+#else
+IF (.NOT. LFLAT) THEN
+ CALL MXM_DEVICE(PRHODJ, ZTMP1_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DXF_DEVICE(ZTMP2_DEVICE, ZTMP3_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
+!$acc end kernels
+ CALL MXF_DEVICE(ZTMP2_DEVICE, ZTMP4_DEVICE)
+!$acc kernels
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+END DO
+!$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP4_DEVICE )
+!$acc kernels
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:)
+!$acc end kernels
+ELSE
+ CALL MXM_DEVICE(PRHODJ, ZTMP1_DEVICE)
+!$acc kernels
+ ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDXX(:,:,:)
+!$acc end kernels
+ CALL DXF_DEVICE(ZTMP2_DEVICE, ZTMP3_DEVICE)
+!$acc kernels
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - ZTMP3_DEVICE(:,:,:)
+!$acc end kernels
+END IF
+#endif
+!
+! Compute the equivalent tendancy for Rc and Ri
+!
+#ifndef MNH_OPENACC
+IF ( KRRL >= 1 ) THEN
+ IF (.NOT. LFLAT) THEN
+ ZFLXC(:,:,:) = 2.*( MXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:) ) &
+ +MZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*MXF( &
+ PDZX*(MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) ) )&
+ )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )* &
+ MXF( PDZX*(MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) + 2. * &
+ (- DXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )* &
+ MXF( PDZX*(MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )* &
+ MXF( PDZX*(MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )
+ END IF
+ ELSE
+ ZFLXC(:,:,:) = 2.*MXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * &
+ DXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DXF( MXM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) )
+ END IF
+ END IF
+END IF
+#else
+IF ( KRRL >= 1 ) THEN
+ IF (.NOT. LFLAT) THEN
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MZM_DEVICE( ZTMP1_DEVICE, ZTMP4_DEVICE )
+ CALL MXM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:) *ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL MZM_DEVICE( ZTMP1_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ ZTMP6_DEVICE(:,:,:) = PDZX(:,:,:)*ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP6_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ ZTMP6_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:)*ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MZF_DEVICE(1,IKU,1, ZTMP6_DEVICE,ZTMP7_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = 2.*( ZTMP2_DEVICE(:,:,:) +ZTMP7_DEVICE(:,:,:) )
+ !$acc end kernels
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MXM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP6_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE( ZTMP6_DEVICE, ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:)*ZTMP5_DEVICE(:,:,:)*PINV_PDZZ(:,:,:)
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP3_DEVICE, ZTMP4_DEVICE )
+!$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP2_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) + 2. * (- ZTMP2_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )*PFRAC_ICE(:,:,:)
+!$acc end kernels
+ ELSE
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MXM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:) *ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE( ZTMP6_DEVICE, ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:)*ZTMP5_DEVICE(:,:,:)*PINV_PDZZ(:,:,:)
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP3_DEVICE, ZTMP4_DEVICE )
+!$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP2_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )
+!$acc end kernels
+ END IF
+ ELSE
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MXM_DEVICE( ZTMP1_DEVICE,ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP3_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = 2.*ZTMP4_DEVICE(:,:,:)
+ !$acc end kernels
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP2_DEVICE(:,:,:)*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * ZTMP2_DEVICE(:,:,:)*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+ END IF
+END IF
+#endif
+!
+!! stores this flux in ZWORK to compute later <U' VPT'>
+!!ZWORK(:,:,:) = ZFLX(:,:,:)
+!
+! stores the horizontal <U THl>
+IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ TZFIELD%CMNHNAME = 'UTHL_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'UTHL_FLX'
+ TZFIELD%CUNITS = 'K m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_UTHL_FLX'
+ TZFIELD%NGRID = 2
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+!$acc update self(ZFLX)
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+END IF
+!
+IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+#ifndef MNH_OPENACC
+ CALL LES_MEAN_SUBGRID( MXF(ZFLX), X_LES_SUBGRID_UThl )
+ CALL LES_MEAN_SUBGRID( MZF(MXF(GX_W_UW(PWM,PDXX,PDZZ,PDZX)*MZM(ZFLX))),&
+ X_LES_RES_ddxa_W_SBG_UaThl , .TRUE. )
+ CALL LES_MEAN_SUBGRID( GX_M_M(PTHLM,PDXX,PDZZ,PDZX)*MXF(ZFLX),&
+ X_LES_RES_ddxa_Thl_SBG_UaThl , .TRUE. )
+ IF (KRR>=1) THEN
+ CALL LES_MEAN_SUBGRID( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)*MXF(ZFLX), &
+ X_LES_RES_ddxa_Rt_SBG_UaThl , .TRUE. )
+ END IF
+#else
+!$acc data copy(X_LES_SUBGRID_UThl,X_LES_RES_ddxa_W_SBG_UaThl, &
+!$acc & X_LES_RES_ddxa_Thl_SBG_UaThl,X_LES_RES_ddxa_Rt_SBG_UaThl)
+ !
+ CALL MXF_DEVICE(ZFLX,ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_SUBGRID_UThl )
+ !
+ CALL GX_W_UW_DEVICE(1,IKU,1,PWM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
+ CALL MZM_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE(ZTMP3_DEVICE,ZTMP1_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP2_DEVICE,X_LES_RES_ddxa_W_SBG_UaThl , .TRUE. )
+ !
+ CALL GX_M_M_DEVICE(1,IKU,1,PTHLM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
+ CALL MXF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE,X_LES_RES_ddxa_Thl_SBG_UaThl , .TRUE. )
+ !
+ IF (KRR>=1) THEN
+ CALL GX_M_M_DEVICE(1,IKU,1,PRM(:,:,:,1),PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE,X_LES_RES_ddxa_Rt_SBG_UaThl , .TRUE. )
+ END IF
+!$acc end data
+
+#endif
+
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+!
+!* 3. < U' R'np >
+! -----------
+IF (KRR/=0) THEN
+ !
+#ifndef MNH_OPENACC
+ ZFLX(:,:,:) = -XCHF * MXM( PK ) * GX_M_U(1,IKU,1,PRM(:,:,:,1),PDXX,PDZZ,PDZX)
+ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+ ZFLX(:,:,IKB:IKB) = -XCHF * MXM( PK(:,:,IKB:IKB) ) * &
+ ( DXM(PRM(:,:,IKB:IKB,1)) * PINV_PDXX(:,:,IKB:IKB) &
+ -MXM( ZCOEFF(:,:,IKB+2:IKB+2)*PRM(:,:,IKB+2:IKB+2,1) &
+ +ZCOEFF(:,:,IKB+1:IKB+1)*PRM(:,:,IKB+1:IKB+1,1) &
+ +ZCOEFF(:,:,IKB :IKB )*PRM(:,:,IKB :IKB ,1)) &
+ *0.5* ( PDZX(:,:,IKB+1:IKB+1)+PDZX(:,:,IKB:IKB)) &
+ * PINV_PDXX(:,:,IKB:IKB) )
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+ ZFLX(:,:,IKB-1:IKB-1) = 2. * MXM( SPREAD( PSFRM(:,:)* PDIRCOSXW(:,:), 3,1) ) &
+ - ZFLX(:,:,IKB:IKB)
+ !
+ ! Add this source to the conservative mixing ratio sources
+ !
+ IF (.NOT. LFLAT) THEN
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) &
+ - DXF( MXM(PRHODJ) * ZFLX(:,:,:) * PINV_PDXX(:,:,:) ) &
+ + DZF( PMZM_PRHODJ(:,:,:) *MXF(PDZX*(MZM(ZFLX * PINV_PDXX(:,:,:)))) * PINV_PDZZ(:,:,:) )
+ ELSE
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) - DXF( MXM(PRHODJ) * ZFLX(:,:,:) * PINV_PDXX(:,:,:) )
+ END IF
+ !
+ ! Compute the equivalent tendancy for Rc and Ri
+ !
+ IF ( KRRL >= 1 ) THEN
+ IF (.NOT. LFLAT) THEN
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) &
+ + 2.*( MXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:) ) &
+ +MZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MXF( &
+ PDZX(:,:,:)*(MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) ) )&
+ )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MXF( PDZX(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MXF( PDZX(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MXF( PDZX(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDXX(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )
+ END IF
+ ELSE
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) + 2.*MXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:) )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * &
+ DXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DXF( MXM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDXX(:,:,:) )
+ END IF
+ END IF
+ END IF
+ !
+ ! stores the horizontal <U Rnp>
+ IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ TZFIELD%CMNHNAME = 'UR_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'UR_FLX'
+ TZFIELD%CUNITS = 'kg kg-1 m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_UR_FLX'
+ TZFIELD%NGRID = 2
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+ END IF
+ !
+ IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ CALL LES_MEAN_SUBGRID( MXF(ZFLX), X_LES_SUBGRID_URt )
+ CALL LES_MEAN_SUBGRID( MZF(MXF(GX_W_UW(PWM,PDXX,PDZZ,PDZX)*MZM(ZFLX))),&
+ X_LES_RES_ddxa_W_SBG_UaRt , .TRUE. )
+ CALL LES_MEAN_SUBGRID( GX_M_M(PTHLM,PDXX,PDZZ,PDZX)*MXF(ZFLX),&
+ X_LES_RES_ddxa_Thl_SBG_UaRt , .TRUE. )
+ CALL LES_MEAN_SUBGRID( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)*MXF(ZFLX),&
+ X_LES_RES_ddxa_Rt_SBG_UaRt , .TRUE. )
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+!
+ !
+ IF (KRRL>0 .AND. KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ CALL LES_MEAN_SUBGRID(MXF(ZFLXC), X_LES_SUBGRID_URc )
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+!
+END IF
+#else
+ CALL MXM_DEVICE( PK, ZTMP1_DEVICE )
+ CALL GX_M_U_DEVICE(1,IKU,1,PRM(:,:,:,1),PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
+!$acc kernels
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+END DO
+ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+!$acc end kernels
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+ CALL MXM_DEVICE( PK(:,:,IKB:IKB), ZTMP1_DEVICE(:,:,1:1) )
+ CALL DXM_DEVICE(PRM(:,:,IKB:IKB,1), ZTMP2_DEVICE(:,:,1:1))
+!$acc kernels
+ ZTMP3_DEVICE(:,:,1) = ZCOEFF(:,:,IKB+2)*PRM(:,:,IKB+2,1) &
+ +ZCOEFF(:,:,IKB+1)*PRM(:,:,IKB+1,1) &
+ +ZCOEFF(:,:,IKB )*PRM(:,:,IKB ,1)
+!$acc end kernels
+ CALL MXM_DEVICE(ZTMP3_DEVICE(:,:,1:1),ZTMP4_DEVICE(:,:,1:1))
+!$acc kernels
+ ZFLX(:,:,IKB) = -XCHF * ZTMP1_DEVICE(:,:,1) * &
+ ( ZTMP2_DEVICE(:,:,1) * PINV_PDXX(:,:,IKB) &
+ -ZTMP4_DEVICE(:,:,1) &
+ *0.5* ( PDZX(:,:,IKB+1)+PDZX(:,:,IKB)) &
+ * PINV_PDXX(:,:,IKB) )
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+ ZTMP1_DEVICE(:,:,1) = PSFRM(:,:)* PDIRCOSXW(:,:)
+!$acc end kernels
+ CALL MXM_DEVICE(ZTMP1_DEVICE(:,:,1:1),ZTMP2_DEVICE(:,:,1:1))
+ !$acc kernels
+ ZFLX(:,:,IKB-1) = 2. * ZTMP2_DEVICE(:,:,1) - ZFLX(:,:,IKB)
+ !$acc end kernels
+
+ !
+ ! Add this source to the conservative mixing ratio sources
+ !
+ IF (.NOT. LFLAT) THEN
+ CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DXF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MXF_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP2_DEVICE, ZTMP4_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRRS(JI,JJ,JK,1) = PRRS(JI,JJ,JK,1) - ZTMP3_DEVICE(JI,JJ,JK) + ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ ELSE
+ CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) - ZTMP3_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+ !
+ ! Compute the equivalent tendancy for Rc and Ri
+ !
+ IF ( KRRL >= 1 ) THEN
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:)
+ ZTMP2_DEVICE(:,:,:) = ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL MXM_DEVICE( ZTMP1_DEVICE, ZTMP8_DEVICE )
+ IF (.NOT. LFLAT) THEN
+ !$acc kernels
+ ZTMP4_DEVICE(:,:,:) = ZTMP8_DEVICE(:,:,:) * ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP4_DEVICE, ZTMP3_DEVICE )
+ CALL MZM_DEVICE( ZTMP1_DEVICE, ZTMP4_DEVICE )
+ CALL MZM_DEVICE( ZTMP2_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ ZTMP6_DEVICE(:,:,:) = PDZX(:,:,:)*ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP6_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ ZTMP6_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:)*ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MZF_DEVICE(1,IKU,1, ZTMP6_DEVICE, ZTMP7_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) + 2.*( ZTMP3_DEVICE(:,:,:) + ZTMP7_DEVICE(:,:,:) )
+ !
+ ZTMP6_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:)*ZTMP5_DEVICE(:,:,:)*PINV_PDZZ(:,:,:)
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP6_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ ZTMP4_DEVICE(:,:,:) = ZTMP8_DEVICE(:,:,:) * ZFLX(:,:,:)*PINV_PDXX(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE(ZTMP4_DEVICE, ZTMP5_DEVICE)
+ !
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP5_DEVICE(:,:,:)+ ZTMP3_DEVICE(:,:,:))*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP5_DEVICE(:,:,:)+ ZTMP3_DEVICE(:,:,:))*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP5_DEVICE(:,:,:) + ZTMP3_DEVICE(:,:,:))
+ !$acc end kernels
+ END IF
+ ELSE
+ !$acc kernels
+ ZTMP4_DEVICE(:,:,:) = ZTMP8_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL DXF_DEVICE(ZTMP4_DEVICE, ZTMP5_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP8_DEVICE(:,:,:)*ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP3_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) + 2.*ZTMP4_DEVICE(:,:,:)
+ !$acc end kernels
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP5_DEVICE(:,:,:)*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * ZTMP5_DEVICE(:,:,:)*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+ END IF
+ END IF
+ !
+ ! stores the horizontal <U Rnp>
+ IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+!$acc update self(ZFLX)
+ TZFIELD%CMNHNAME = 'UR_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'UR_FLX'
+ TZFIELD%CUNITS = 'kg kg-1 m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_UR_FLX'
+ TZFIELD%NGRID = 2
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+ END IF
+ !
+ IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ !
+!$acc data copy(X_LES_SUBGRID_URt,X_LES_RES_ddxa_W_SBG_UaRt, &
+!$acc & X_LES_RES_ddxa_Thl_SBG_UaRt,X_LES_RES_ddxa_Rt_SBG_UaRt)
+ !
+ CALL MXF_DEVICE(ZFLX,ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_SUBGRID_URt )
+ !
+ CALL GX_W_UW_DEVICE(1,IKU,1,PWM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
+ CALL MZM_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE(ZTMP3_DEVICE,ZTMP4_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP4_DEVICE,ZTMP3_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE, X_LES_RES_ddxa_W_SBG_UaRt , .TRUE. )
+ !
+ CALL GX_M_M_DEVICE(1,IKU,1,PTHLM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
+ CALL MXF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE, X_LES_RES_ddxa_Thl_SBG_UaRt , .TRUE. )
+ !
+ CALL GX_M_M_DEVICE(1,IKU,1,PRM(:,:,:,1),PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
+ CALL MXF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE, X_LES_RES_ddxa_Rt_SBG_UaRt , .TRUE. )
+ !
+!$acc end data
+ !
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+!
+ !
+ IF (KRRL>0 .AND. KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ !
+ !$acc data copy(X_LES_SUBGRID_URc)
+ !
+ CALL MXF_DEVICE(ZFLXC,ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID(ZTMP1_DEVICE, X_LES_SUBGRID_URc )
+ !
+ !$acc end data
+ !
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+!
+END IF
+#endif
+!
+!* 4. < U' TPV' >
+! -----------
+!
+!! to be tested later
+!!IF (KRR/=0) THEN
+!! ! here ZFLX= <U'Rnp'> and ZWORK= <U'Thetal'>
+!! !
+!! ZVPTU(:,:,:) = &
+!! ZWORK(:,:,:)*MXM(ETHETA(KRR,KRRI,PTHLT,PEXNREF,PRT,PLOCPT,PSRCM)) + &
+!! ZFLX(:,:,:)*MXM(EMOIST(KRR,KRRI,PTHLT,PEXNREF,PRT,PLOCPT,PSRCM))
+!! !
+!! ! stores the horizontal <U VPT>
+!! IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+!! TZFIELD%CMNHNAME = 'UVPT_FLX'
+!! TZFIELD%CSTDNAME = ''
+!! TZFIELD%CLONGNAME = 'UVPT_FLX'
+!! TZFIELD%CUNITS = 'K m s-1'
+!! TZFIELD%CDIR = 'XY'
+!! TZFIELD%CCOMMENT = 'X_Y_Z_UVPT_FLX'
+!! TZFIELD%NGRID = 2
+!! TZFIELD%NTYPE = TYPEREAL
+!! TZFIELD%NDIMS = 3
+!! TZFIELD%LTIMEDEP = .TRUE.
+!! CALL IO_Field_write(TPFILE,TZFIELD,ZVPTU)
+!! END IF
+!!!
+!!ELSE
+!! ZVPTU(:,:,:)=ZWORK(:,:,:)
+!!END IF
+!
+!
+!* 5. < V' THETA'l >
+! --------------
+!
+!
+IF (.NOT. L2D) THEN
+#ifndef MNH_OPENACC
+ ZFLX(:,:,:) = -XCSHF * MYM( PK ) * GY_M_V(1,IKU,1,PTHLM,PDYY,PDZZ,PDZY)
+ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+ELSE
+ ZFLX(:,:,:) = 0.
+END IF
+!
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+ZFLX(:,:,IKB:IKB) = -XCSHF * MYM( PK(:,:,IKB:IKB) ) * &
+ ( DYM(PTHLM(:,:,IKB:IKB)) * PINV_PDYY(:,:,IKB:IKB) &
+ -MYM( ZCOEFF(:,:,IKB+2:IKB+2)*PTHLM(:,:,IKB+2:IKB+2) &
+ +ZCOEFF(:,:,IKB+1:IKB+1)*PTHLM(:,:,IKB+1:IKB+1) &
+ +ZCOEFF(:,:,IKB :IKB )*PTHLM(:,:,IKB :IKB ) ) &
+ *0.5* ( PDZY(:,:,IKB+1:IKB+1)+PDZY(:,:,IKB:IKB)) &
+ * PINV_PDYY(:,:,IKB:IKB) )
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+ZFLX(:,:,IKB-1:IKB-1) = 2. * MYM( SPREAD( PSFTHM(:,:)* PDIRCOSYW(:,:), 3,1) ) &
+ - ZFLX(:,:,IKB:IKB)
+!
+! Add this source to the Theta_l sources
+!
+IF (.NOT. L2D) THEN
+ IF (.NOT. LFLAT) THEN
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) &
+ - DYF( MYM(PRHODJ) * ZFLX(:,:,:) * PINV_PDYY(:,:,:) ) &
+ + DZF( PMZM_PRHODJ *MYF(PDZY(:,:,:)*(MZM(ZFLX(:,:,:) * PINV_PDYY(:,:,:)))) * PINV_PDZZ(:,:,:) )
+ ELSE
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - DYF( MYM(PRHODJ) * ZFLX(:,:,:) * PINV_PDYY(:,:,:) )
+ END IF
+END IF
+!
+! Compute the equivalent tendancy for Rc and Ri
+!
+!IF ( OSUBG_COND .AND. KRRL > 0 .AND. .NOT. L2D) THEN
+IF ( KRRL >= 1 .AND. .NOT. L2D) THEN
+ IF (.NOT. LFLAT) THEN
+ ZFLXC(:,:,:) = 2.*( MYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:) ) &
+ +MZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*MYF( &
+ PDZY(:,:,:)*(MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) ) )&
+ )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDYY(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*MYF( PDZY(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) + 2. * &
+ (- DYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDYY(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*MYF( PDZY(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDYY(:,:,:) ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*MYF( PDZY(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) )&
+ *PINV_PDZZ(:,:,:) ) &
+ )
+ END IF
+ ELSE
+ ZFLXC(:,:,:) = 2.*MYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:) )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDYY(:,:,:) )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * &
+ DYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDYY(:,:,:) )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DYF( MYM( PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)*PINV_PDYY(:,:,:) )
+ END IF
+ END IF
+END IF
+!
+!! stores this flux in ZWORK to compute later <V' VPT'>
+!!ZWORK(:,:,:) = ZFLX(:,:,:)
+!
+! stores the horizontal <V THl>
+IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ TZFIELD%CMNHNAME = 'VTHL_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'VTHL_FLX'
+ TZFIELD%CUNITS = 'K m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_VTHL_FLX'
+ TZFIELD%NGRID = 3
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+END IF
+!
+IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ CALL LES_MEAN_SUBGRID( MYF(ZFLX), X_LES_SUBGRID_VThl )
+ CALL LES_MEAN_SUBGRID( MZF(MYF(GY_W_VW(PWM,PDYY,PDZZ,PDZY)*MZM(ZFLX))),&
+ X_LES_RES_ddxa_W_SBG_UaThl , .TRUE. )
+ CALL LES_MEAN_SUBGRID( GY_M_M(PTHLM,PDYY,PDZZ,PDZY)*MYF(ZFLX),&
+ X_LES_RES_ddxa_Thl_SBG_UaThl , .TRUE. )
+ IF (KRR>=1) THEN
+ CALL LES_MEAN_SUBGRID( GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)*MYF(ZFLX),&
+ X_LES_RES_ddxa_Rt_SBG_UaThl , .TRUE. )
+ END IF
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+#else
+ CALL MYM_DEVICE( PK, ZTMP1_DEVICE )
+ CALL GY_M_V_DEVICE(1,IKU,1,PTHLM,PDYY,PDZZ,PDZY,ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCSHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+ !$acc end kernels
+ELSE
+ !$acc kernels
+ ZFLX(:,:,:) = 0.
+ !$acc end kernels
+END IF
+!
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+CALL MYM_DEVICE( PK(:,:,IKB:IKB), ZTMP1_DEVICE(:,:,1:1) )
+CALL DYM_DEVICE(PTHLM(:,:,IKB:IKB), ZTMP2_DEVICE(:,:,1:1) )
+!$acc kernels
+ZTMP3_DEVICE(:,:,1) = ZCOEFF(:,:,IKB+2)*PTHLM(:,:,IKB+2) &
+ +ZCOEFF(:,:,IKB+1)*PTHLM(:,:,IKB+1) &
+ +ZCOEFF(:,:,IKB )*PTHLM(:,:,IKB )
+!$acc end kernels
+CALL MYM_DEVICE( ZTMP3_DEVICE(:,:,1:1), ZTMP4_DEVICE(:,:,1:1) )
+!$acc kernels
+ZFLX(:,:,IKB) = -XCSHF * ZTMP1_DEVICE(:,:,1) * &
+ ( ZTMP2_DEVICE(:,:,1) * PINV_PDYY(:,:,IKB) &
+ - ZTMP4_DEVICE(:,:,1) &
+ *0.5* ( PDZY(:,:,IKB+1)+PDZY(:,:,IKB)) &
+ * PINV_PDYY(:,:,IKB) )
+!$acc end kernels
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+!$acc kernels
+ZTMP1_DEVICE(:,:,1) = PSFTHM(:,:)* PDIRCOSYW(:,:)
+!$acc end kernels
+CALL MYM_DEVICE( ZTMP1_DEVICE(:,:,1:1), ZTMP2_DEVICE(:,:,1:1) )
+!$acc kernels
+ZFLX(:,:,IKB-1) = 2. * ZTMP2_DEVICE(:,:,1) - ZFLX(:,:,IKB)
+!$acc end kernels
+!
+! Add this source to the Theta_l sources
+!
+IF (.NOT. L2D) THEN
+ IF (.NOT. LFLAT) THEN
+ CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MZM_DEVICE(ZTMP1_DEVICE, ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MYF_DEVICE(ZTMP1_DEVICE, ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRTHLS(JI,JJ,JK) = PRTHLS(JI,JJ,JK) - ZTMP3_DEVICE(JI,JJ,JK) + ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ ELSE
+ CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ PRTHLS(:,:,:) = PRTHLS(:,:,:) - ZTMP3_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+END IF
+!
+! Compute the equivalent tendancy for Rc and Ri
+!
+!IF ( OSUBG_COND .AND. KRRL > 0 .AND. .NOT. L2D) THEN
+IF ( KRRL >= 1 .AND. .NOT. L2D) THEN
+ IF (.NOT. LFLAT) THEN
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP4_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MYF_DEVICE( ZTMP4_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ ZTMP4_DEVICE(:,:,:) = ZFLX(:,:,:)*PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL MZM_DEVICE( ZTMP4_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ ZTMP4_DEVICE(:,:,:) = PDZY(:,:,:)*ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MYF_DEVICE( ZTMP4_DEVICE, ZTMP5_DEVICE)
+ CALL MZM_DEVICE( ZTMP1_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZTMP6_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:)*ZTMP5_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MZF_DEVICE(1,IKU,1, ZTMP6_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = 2.*( ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )
+ !$acc end kernels
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)*PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP3_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP6_DEVICE(:,:,:)*PINV_PDZZ(:,:,:)
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP3_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP4_DEVICE(:,:,:) + ZTMP5_DEVICE(:,:,:) )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) + 2. * (- ZTMP4_DEVICE(:,:,:) + ZTMP5_DEVICE(:,:,:) )*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)*PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP3_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP6_DEVICE(:,:,:)*PINV_PDZZ(:,:,:)
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP3_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP4_DEVICE(:,:,:) + ZTMP5_DEVICE(:,:,:) )
+ !$acc end kernels
+ END IF
+ ELSE
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PATHETA(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MYF_DEVICE( ZTMP1_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = 2.*ZTMP3_DEVICE(:,:,:)
+ !$acc end kernels
+ !
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)*PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP2_DEVICE(:,:,:)*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * ZTMP2_DEVICE(:,:,:)*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+ END IF
+END IF
+!! stores this flux in ZWORK to compute later <V' VPT'>
+!!ZWORK(:,:,:) = ZFLX(:,:,:)
+!
+! stores the horizontal <V THl>
+IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+!$acc update self(ZFLX)
+ TZFIELD%CMNHNAME = 'VTHL_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'VTHL_FLX'
+ TZFIELD%CUNITS = 'K m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_VTHL_FLX'
+ TZFIELD%NGRID = 3
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+END IF
+!
+IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ !
+!$acc data copy(X_LES_SUBGRID_VThl,X_LES_RES_ddxa_W_SBG_UaThl,X_LES_RES_ddxa_Thl_SBG_UaThl)
+ !
+ CALL MYF_DEVICE(ZFLX, ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_SUBGRID_VThl )
+ !
+ CALL GY_W_VW_DEVICE(1,IKU,1,PWM,PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
+ CALL MZM_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MYF_DEVICE(ZTMP3_DEVICE, ZTMP4_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP4_DEVICE, ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_RES_ddxa_W_SBG_UaThl , .TRUE. )
+ !
+ CALL GY_M_M_DEVICE(1,IKU,1,PTHLM,PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
+ CALL MYF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE, X_LES_RES_ddxa_Thl_SBG_UaThl , .TRUE. )
+ !
+!$acc end data
+ !
+ IF (KRR>=1) THEN
+!$acc data copy(X_LES_RES_ddxa_Rt_SBG_UaThl)
+ CALL GY_M_M_DEVICE(1,IKU,1,PRM(:,:,:,1),PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
+ CALL MYF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE,X_LES_RES_ddxa_Rt_SBG_UaThl , .TRUE. )
+!$acc end data
+ END IF
+ !
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+END IF
+#endif
+!
+!
+!* 6. < V' R'np >
+! -----------
+!
+#ifndef MNH_OPENACC
+IF (KRR/=0) THEN
+ !
+ IF (.NOT. L2D) THEN
+ ZFLX(:,:,:) = -XCHF * MYM( PK ) * GY_M_V(1,IKU,1,PRM(:,:,:,1),PDYY,PDZZ,PDZY)
+ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+ ELSE
+ ZFLX(:,:,:) = 0.
+ END IF
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+ ZFLX(:,:,IKB:IKB) = -XCHF * MYM( PK(:,:,IKB:IKB) ) * &
+ ( DYM(PRM(:,:,IKB:IKB,1)) * PINV_PDYY(:,:,IKB:IKB) &
+ -MYM( ZCOEFF(:,:,IKB+2:IKB+2)*PRM(:,:,IKB+2:IKB+2,1) &
+ +ZCOEFF(:,:,IKB+1:IKB+1)*PRM(:,:,IKB+1:IKB+1,1) &
+ +ZCOEFF(:,:,IKB :IKB )*PRM(:,:,IKB :IKB ,1) ) &
+ *0.5* ( PDZY(:,:,IKB+1:IKB+1)+PDZY(:,:,IKB:IKB)) &
+ * PINV_PDYY(:,:,IKB:IKB) )
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+ ZFLX(:,:,IKB-1:IKB-1) = 2. * MYM( SPREAD( PSFRM(:,:)* PDIRCOSYW(:,:), 3,1) ) &
+ - ZFLX(:,:,IKB:IKB)
+ !
+ ! Add this source to the conservative mixing ratio sources
+ !
+ IF (.NOT. L2D) THEN
+ IF (.NOT. LFLAT) THEN
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) &
+ - DYF( MYM(PRHODJ) * ZFLX(:,:,:) * PINV_PDYY(:,:,:) ) &
+ + DZF( PMZM_PRHODJ(:,:,:) *MYF(PDZY(:,:,:)* &
+ (MZM(ZFLX(:,:,:) * PINV_PDYY(:,:,:)))) * PINV_PDZZ(:,:,:) )
+ ELSE
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) - DYF( MYM(PRHODJ) * ZFLX(:,:,:) * PINV_PDYY(:,:,:) )
+ END IF
+ END IF
+ !
+ ! Compute the equivalent tendancy for Rc and Ri
+ !
+ IF ( KRRL >= 1 .AND. .NOT. L2D) THEN ! Sub-grid condensation
+ IF (.NOT. LFLAT) THEN
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) &
+ + 2.*( MXF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:) ) &
+ + MZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MYF( &
+ PDZY(:,:,:)*(MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) ) )&
+ )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DYF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)/PDYY ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MYF( PDZY(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) )&
+ * PINV_PDZZ(:,:,:) ) &
+ )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) + 2. * &
+ (- DYF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)/PDYY ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MYF( PDZY(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) )&
+ * PINV_PDZZ(:,:,:) ) &
+ )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * &
+ (- DYF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)/PDYY ) &
+ + DZF( MZM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*MYF( PDZY(:,:,:)* &
+ (MZM( ZFLX(:,:,:)*PINV_PDYY(:,:,:) )) )&
+ * PINV_PDZZ(:,:,:) ) &
+ )
+ END IF
+ ELSE
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) + 2.*MXF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX )
+ IF ( KRRI >= 1 ) THEN
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DYF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)/PDYY )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * &
+ DYF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)/PDYY )*PFRAC_ICE(:,:,:)
+ ELSE
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * &
+ DYF( MYM( PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:) )*ZFLX(:,:,:)/PDYY )
+ END IF
+ END IF
+ END IF
+ !
+ ! stores the horizontal <V Rnp>
+ IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ TZFIELD%CMNHNAME = 'VR_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'VR_FLX'
+ TZFIELD%CUNITS = 'kg kg-1 m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_VR_FLX'
+ TZFIELD%NGRID = 3
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+ END IF
+ !
+ IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ CALL LES_MEAN_SUBGRID( MYF(ZFLX), X_LES_SUBGRID_VRt )
+ CALL LES_MEAN_SUBGRID( MZF(MYF(GY_W_VW(PWM,PDYY,PDZZ,PDZY)*MZM(ZFLX))),&
+ X_LES_RES_ddxa_W_SBG_UaRt , .TRUE. )
+ CALL LES_MEAN_SUBGRID( GY_M_M(PTHLM,PDYY,PDZZ,PDZY)*MYF(ZFLX), &
+ X_LES_RES_ddxa_Thl_SBG_UaRt , .TRUE. )
+ CALL LES_MEAN_SUBGRID( GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)*MYF(ZFLX), &
+ X_LES_RES_ddxa_Rt_SBG_UaRt , .TRUE. )
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+!
+ !
+ IF (KRRL>0 .AND. KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ CALL LES_MEAN_SUBGRID(MYF(ZFLXC), X_LES_SUBGRID_VRc )
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+ !
+END IF
+#else
+IF (KRR/=0) THEN
+ !
+ IF (.NOT. L2D) THEN
+ CALL MYM_DEVICE( PK, ZTMP1_DEVICE )
+ CALL GY_M_V_DEVICE(1,IKU,1,PRM(:,:,:,1),PDYY,PDZZ,PDZY, ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ ZFLX(:,:,:) = 0.
+ !$acc end kernels
+ END IF
+!
+! Compute the flux at the first inner U-point with an uncentred vertical
+! gradient
+ CALL MYM_DEVICE( PK(:,:,IKB:IKB), ZTMP1_DEVICE(:,:,1:1) )
+ CALL DYM_DEVICE(PRM(:,:,IKB:IKB,1), ZTMP2_DEVICE(:,:,1:1))
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,1) = ZCOEFF(:,:,IKB+2)*PRM(:,:,IKB+2,1) &
+ +ZCOEFF(:,:,IKB+1)*PRM(:,:,IKB+1,1) &
+ +ZCOEFF(:,:,IKB )*PRM(:,:,IKB ,1)
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP3_DEVICE(:,:,1:1), ZTMP4_DEVICE(:,:,1:1) )
+ !$acc kernels
+ ZFLX(:,:,IKB) = -XCHF * ZTMP1_DEVICE(:,:,1) * &
+ ( ZTMP2_DEVICE(:,:,1) * PINV_PDYY(:,:,IKB) &
+ - ZTMP4_DEVICE(:,:,1) &
+ *0.5* ( PDZY(:,:,IKB+1)+PDZY(:,:,IKB)) &
+ * PINV_PDYY(:,:,IKB) )
+ !$acc end kernels
+! extrapolates the flux under the ground so that the vertical average with
+! the IKB flux gives the ground value ( warning the tangential surface
+! flux has been set to 0 for the moment !! to be improved )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,1) = PSFRM(:,:)* PDIRCOSYW(:,:)
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP1_DEVICE(:,:,1:1), ZTMP2_DEVICE(:,:,1:1) )
+ !$acc kernels
+ ZFLX(:,:,IKB-1) = 2. * ZTMP2_DEVICE(:,:,1) - ZFLX(:,:,IKB)
+ !$acc end kernels
+ !
+ ! Add this source to the conservative mixing ratio sources
+ !
+ IF (.NOT. L2D) THEN
+ IF (.NOT. LFLAT) THEN
+ CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL MYF_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE )
+ !
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRRS(JI,JJ,JK,1) = PRRS(JI,JJ,JK,1) - ZTMP3_DEVICE(JI,JJ,JK) + ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
+ ELSE
+ CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
+ !$acc kernels
+ ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,1) = PRRS(:,:,:,1) - ZTMP3_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+ END IF
+ !
+ ! Compute the equivalent tendancy for Rc and Ri
+ !
+ IF ( KRRL >= 1 .AND. .NOT. L2D) THEN ! Sub-grid condensation
+ IF (.NOT. LFLAT) THEN
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP3_DEVICE, ZTMP4_DEVICE )
+ CALL MZM_DEVICE( ZTMP1_DEVICE, ZTMP5_DEVICE )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZFLX(:,:,:)*PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL MZM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PDZY(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MYF_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP5_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MZF_DEVICE(1,IKU,1, ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) + 2.*( ZTMP4_DEVICE(:,:,:) + ZTMP2_DEVICE(:,:,:) )
+ !$acc end kernels
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ ZTMP2_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)* PINV_PDZZ(:,:,:)
+ !$acc end kernels
+ CALL DZF_DEVICE(1,IKU,1, ZTMP2_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) + 2. * (- ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) + 2. * (- ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:) )
+ !$acc end kernels
+ END IF
+ ELSE
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = PRHODJ(:,:,:)*PAMOIST(:,:,:)*PSRCM(:,:,:)
+ !$acc end kernels
+ CALL MYM_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)*ZFLX(:,:,:)
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP3_DEVICE, ZTMP4_DEVICE )
+ !$acc kernels
+ ZFLXC(:,:,:) = ZFLXC(:,:,:) + 2.*ZTMP4_DEVICE(:,:,:)
+ !$acc end kernels
+ !
+ !$acc kernels
+ ZTMP1_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:)* PINV_PDYY(:,:,:)
+ !$acc end kernels
+ CALL DYF_DEVICE( ZTMP1_DEVICE, ZTMP2_DEVICE )
+ IF ( KRRI >= 1 ) THEN
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP2_DEVICE(:,:,:)*(1.0-PFRAC_ICE(:,:,:))
+ PRRS(:,:,:,4) = PRRS(:,:,:,4) - 2. * ZTMP2_DEVICE(:,:,:)*PFRAC_ICE(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ PRRS(:,:,:,2) = PRRS(:,:,:,2) - 2. * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ END IF
+ END IF
+ END IF
+ !
+ ! stores the horizontal <V Rnp>
+ IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+ !$acc update self(ZFLX)
+ TZFIELD%CMNHNAME = 'VR_FLX'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'VR_FLX'
+ TZFIELD%CUNITS = 'kg kg-1 m s-1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_VR_FLX'
+ TZFIELD%NGRID = 3
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZFLX(:,:,:))
+ END IF
+ !
+ IF (KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ !
+!$acc data copy(X_LES_SUBGRID_VRt,X_LES_RES_ddxa_W_SBG_UaRt, &
+!$acc & X_LES_RES_ddxa_Thl_SBG_UaRt,X_LES_RES_ddxa_Rt_SBG_UaRt)
+ !
+ CALL MYF_DEVICE(ZFLX,ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_SUBGRID_VRt )
+ !
+ CALL GY_W_VW_DEVICE(1,IKU,1,PWM,PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
+ CALL MZM_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL MYF_DEVICE(ZTMP3_DEVICE, ZTMP4_DEVICE)
+ CALL MZF_DEVICE(1,IKU,1,ZTMP4_DEVICE,ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE,X_LES_RES_ddxa_W_SBG_UaRt , .TRUE. )
+ !
+ CALL GY_M_M_DEVICE(1,IKU,1,PTHLM,PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
+ CALL MYF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE, X_LES_RES_ddxa_Thl_SBG_UaRt , .TRUE. )
+ !
+ CALL GY_M_M_DEVICE(1,IKU,1,PRM(:,:,:,1),PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
+ CALL MYF_DEVICE(ZFLX,ZTMP2_DEVICE)
+ !$acc kernels
+ ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc end kernels
+ CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE, X_LES_RES_ddxa_Rt_SBG_UaRt , .TRUE. )
+ !
+!$acc end data
+ !
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+!
+ !
+ IF (KRRL>0 .AND. KSPLT==1 .AND. LLES_CALL) THEN
+ CALL SECOND_MNH(ZTIME1)
+ !
+!$acc data copy(X_LES_SUBGRID_VRc)
+ !
+ CALL MYF_DEVICE(ZFLXC,ZTMP1_DEVICE)
+ CALL LES_MEAN_SUBGRID(ZTMP1_DEVICE, X_LES_SUBGRID_VRc )
+ !
+!$acc end data
+ !
+ CALL SECOND_MNH(ZTIME2)
+ XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
+ END IF
+ !
+END IF
+#endif
+!
+!* 7. < V' TPV' >
+! -----------
+!
+!! to be tested later
+!!IF (KRR/=0) THEN
+!! ! here ZFLX= <V'R'np> and ZWORK= <V'Theta'l>
+!! !
+!! IF (.NOT. L2D) THEN &
+!! ZVPTV(:,:,:) = &
+!! ZWORK(:,:,:)*MYM(ETHETA(KRR,KRRI,PTHLT,PEXNREF,PRT,PLOCPT,PSRCM)) + &
+!! ZFLX(:,:,:)*MYM(EMOIST(KRR,KRRI,PTHLT,PEXNREF,PRT,PLOCPT,PSRCM))
+!! ELSE
+!! ZVPTV(:,:,:) = 0.
+!! END IF
+!! !
+!! ! stores the horizontal <V VPT>
+!! IF ( OCLOSE_OUT .AND. OTURB_FLX ) THEN
+!! TZFIELD%CMNHNAME = 'VVPT_FLX'
+!! TZFIELD%CSTDNAME = ''
+!! TZFIELD%CLONGNAME = 'VVPT_FLX'
+!! TZFIELD%CUNITS = 'K m s-1'
+!! TZFIELD%CDIR = 'XY'
+!! TZFIELD%CCOMMENT = 'X_Y_Z_VVPT_FLX'
+!! TZFIELD%NGRID = 3
+!! TZFIELD%NTYPE = TYPEREAL
+!! TZFIELD%NDIMS = 3
+!! TZFIELD%LTIMEDEP = .TRUE.
+!! CALL IO_Field_write(TPFILE,TZFIELD,ZVPTV)
+!! END IF
+!!!
+!!ELSE
+!! ZVPTV(:,:,:)=ZWORK(:,:,:)
+!!END IF
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( prthls, "Turb_hor_thermo_flux end:prthls" )
+ call Mppdb_check( prrs, "Turb_hor_thermo_flux end:prrs" )
+end if
+
+!$acc end data
+
+#ifndef MNH_OPENACC
+deallocate (zflx,zflxc,zcoeff)
+#else
+CALL MNH_REL_ZT3D ( IZFLX, IZFLXC, IZCOEFF, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, &
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE, IZTMP8_DEVICE )
+CALL MNH_CHECK_OUT_ZT3D("TURB_HOR_THERMO_FLUX")
+#endif
+
+!$acc end data
+
+END SUBROUTINE TURB_HOR_THERMO_FLUX
diff --git a/src/ZSOLVER/update_lm.f90 b/src/ZSOLVER/update_lm.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7b82c64c7d766f33f34af358abd3c5c5cb3b37ae
--- /dev/null
+++ b/src/ZSOLVER/update_lm.f90
@@ -0,0 +1,173 @@
+!MNH_LIC Copyright 2006-2019 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.
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_UPDATE_LM
+! ###################
+INTERFACE
+!
+SUBROUTINE UPDATE_LM(HLBCX,HLBCY,PLM,PLEPS)
+!
+CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X boundary type
+CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y boundary type
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PLM ! mixing length
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PLEPS ! dissipative length
+!
+END SUBROUTINE UPDATE_LM
+!
+END INTERFACE
+!
+END MODULE MODI_UPDATE_LM
+!
+!
+!
+! #################################################################
+ SUBROUTINE UPDATE_LM(HLBCX,HLBCY,PLM,PLEPS)
+! #################################################################
+!
+!!**** *UPDATE_LM* - routine to set external points for mixing length
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine UPDATE_LM)
+!!
+!! AUTHOR
+!! ------
+!! V. Masson * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original april 2006
+!! V.Masson : Exchange of East and North sides
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_CONF
+USE MODD_PARAMETERS
+!
+USE MODE_ll
+use mode_mppdb
+USE MODI_GET_HALO
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 declarations of arguments
+!
+CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X boundary type
+CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y boundary type
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PLM ! mixing length
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PLEPS ! dissipative length
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: IIB ! First physical index in x direction
+INTEGER :: IJB ! First physical index in y direction
+INTEGER :: IIE ! last physical index in x direction
+INTEGER :: IJE ! last physical index in y direction
+INTEGER :: JI ! loop index
+!
+TYPE(LIST_ll), POINTER :: TZLM_ll ! list of fields to exchange
+INTEGER :: IINFO_ll ! return code of parallel routine
+!
+!-------------------------------------------------------------------------------
+
+!$acc data present(PLM,PLEPS)
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( plm, "Update_lm beg:plm" )
+ call Mppdb_check( pleps, "Update_lm beg:pleps" )
+end if
+!
+!* 1. COMPUTE DIMENSIONS OF ARRAYS :
+! ----------------------------
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+!!$NULLIFY(TZLM_ll)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. UPDATE HALOs :
+! -------------
+!
+!
+!!$IF(NHALO == 1) THEN
+!!$!$acc update self(PLM,PLEPS)
+!!$ CALL ADD3DFIELD_ll( TZLM_ll, PLM, 'UPDATE_LM::PLM' )
+!!$ CALL ADD3DFIELD_ll( TZLM_ll, PLEPS, 'UPDATE_LM::PLEPS' )
+!!$ CALL UPDATE_HALO_ll(TZLM_ll,IINFO_ll)
+!!$ CALL CLEANLIST_ll(TZLM_ll)
+!!$!$acc update device(PLM,PLEPS)
+!
+! /!\ Corner update needed ! -> GET_HALO_DDC
+!
+CALL GET_HALO_DDC( PLM, HNAME='UPDATE_LM::PLM' )
+CALL GET_HALO_DDC( PLEPS, HNAME='UPDATE_LM::PLEPS' )
+!!$END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. UPDATE EXTERNAL POINTS OF GLOBAL DOMAIN:
+! ---------------------------------------
+!
+
+IF ( HLBCX(1) /= "CYCL" .AND. LWEST_ll()) THEN
+ !$acc kernels async
+ PLM (IIB-1,:,:) = PLM (IIB,:,:)
+ PLEPS(IIB-1,:,:) = PLEPS(IIB,:,:)
+ !$acc end kernels
+END IF
+IF ( HLBCX(2) /= "CYCL" .AND. LEAST_ll()) THEN
+ !$acc kernels async
+ PLM (IIE+1,:,:) = PLM (IIE,:,:)
+ PLEPS(IIE+1,:,:) = PLEPS(IIE,:,:)
+ !$acc end kernels
+END IF
+IF ( HLBCY(1) /= "CYCL" .AND. LSOUTH_ll()) THEN
+ !$acc kernels async
+ DO JI=1,SIZE(PLM,1)
+ PLM (JI,IJB-1,:) = PLM (JI,IJB,:)
+ PLEPS(JI,IJB-1,:) = PLEPS(JI,IJB,:)
+ END DO
+ !$acc end kernels
+END IF
+IF ( HLBCY(2) /= "CYCL" .AND. LNORTH_ll()) THEN
+ !$acc kernels async
+ DO JI=1,SIZE(PLM,1)
+ PLM (JI,IJE+1,:) = PLM (JI,IJE,:)
+ PLEPS(JI,IJE+1,:) = PLEPS(JI,IJE,:)
+ END DO
+ !$acc end kernels
+END IF
+!$acc wait
+
+if ( mppdb_initialized ) then
+ !Check all inout arrays
+ call Mppdb_check( plm, "Update_lm end:plm" )
+ call Mppdb_check( pleps, "Update_lm end:pleps" )
+end if
+
+!$acc end data
+
+!-----------------------------------------------------------------------------
+END SUBROUTINE UPDATE_LM
diff --git a/src/ZSOLVER/zsolver.f90 b/src/ZSOLVER/zsolver.f90
index 779a6b5685912b69249552d79b93337d17edd1bf..846c7fb7761cab5ef0b8caec2d474fd7a202a6d6 100644
--- a/src/ZSOLVER/zsolver.f90
+++ b/src/ZSOLVER/zsolver.f90
@@ -153,6 +153,11 @@ USE MODI_FLAT_INV
USE MODI_ZSOLVER_INV
USE MODI_DOTPROD
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+#endif
+!
+!
IMPLICIT NONE
!
!* 0.1 declarations of arguments
@@ -209,23 +214,39 @@ REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
!
INTEGER :: JM ! loop index
!
-REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZDELTA, ZKSI
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDELTA, ZKSI
! array containing the auxilary fields DELTA and KSI of the CR method
-REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZP, ZQ
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZP, ZQ
! array containing the auxilary fields P and Q of the CR method
-REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZRESIDUE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZRESIDUE
! array containing the error field at each iteration Q(PHI) - Y
+INTEGER :: IZDELTA, IZKSI, IZP, IZQ, IZRESIDUE
!
REAL :: ZALPHA, ZLAMBDA ! amplitude of the descent in the Conjugate
! directions
REAL :: ZDOT_DELTA ! dot product of ZDELTA by itself
!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!-------------------------------------------------------------------------------
!
!* 1. INITIALIZATIONS
! ---------------
!
-!
+JIU = size(PPHI, 1 )
+JJU = size(PPHI, 2 )
+JKU = size(PPHI, 3 )
+!
+#ifndef MNH_OPENACC
+ALLOCATE(ZDELTA(JIU,JJU,JKU),ZKSI(JIU,JJU,JKU),ZP(JIU,JJU,JKU),ZQ(JIU,JJU,JKU),ZRESIDUE(JIU,JJU,JKU))
+#else
+IZDELTA = MNH_ALLOCATE_ZT3D(ZDELTA ,JIU,JJU,JKU )
+IZKSI = MNH_ALLOCATE_ZT3D(ZKSI ,JIU,JJU,JKU )
+IZP = MNH_ALLOCATE_ZT3D(ZP ,JIU,JJU,JKU )
+IZQ = MNH_ALLOCATE_ZT3D(ZQ ,JIU,JJU,JKU )
+IZRESIDUE = MNH_ALLOCATE_ZT3D(ZRESIDUE ,JIU,JJU,JKU )
+
+#endif
!* 1.1 compute the vector: r^(0) = Q(PHI) - Y
!
#ifndef MNH_OPENACC
@@ -308,7 +329,12 @@ DO JM = 1,KITR
!
END DO ! end of the loop for the iterative solver
!
-!
+!
+#ifndef MNH_OPENACC
+DEALLOCATE(ZDELTA,ZKSI,ZP,ZQ,ZRESIDUE)
+#else
+CALL MNH_REL_ZT3D(IZDELTA,IZKSI,IZP,IZQ,IZRESIDUE)
+#endif
!-------------------------------------------------------------------------------
!
END SUBROUTINE ZSOLVER
diff --git a/src/ZSOLVER/zsolver_inv.f90 b/src/ZSOLVER/zsolver_inv.f90
index e6cfc214eef4a48d8064037fd25c42d35fee1078..29965951e8ee7546dad9e2e27d6f93e6a1cd3e1e 100644
--- a/src/ZSOLVER/zsolver_inv.f90
+++ b/src/ZSOLVER/zsolver_inv.f90
@@ -150,6 +150,9 @@ SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
USE MODI_DOTPROD
!
USE mode_mg_main_mnh
+#ifdef MNH_OPENACC
+ USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+#endif
!
IMPLICIT NONE
!
@@ -191,14 +194,10 @@ SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
!
!* 0.2 declaration of local variables
!
- REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZY ! work array to store
- ! the RHS of the equation
- !
- !REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZWORK ! work array used by
- ! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
- !
- REAL, DIMENSION(SIZE(PBF,1),SIZE(PBF,2),SIZE(PBF,3)) :: ZAF ! work array to
- ! ! expand PAF
+ REAL, DIMENSION(:,:,:), pointer , contiguous :: ZY ! work array to store
+ ! the RHS of the equation
+ INTEGER :: IZY
+ !
INTEGER :: IIB ! indice I for the first inner mass point along x
INTEGER :: IIE ! indice I for the last inner mass point along x
INTEGER :: IJB ! indice J for the first inner mass point along y
@@ -222,6 +221,11 @@ SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
IKB=1+JPVEXT
IKE=IKU - JPVEXT
!
+#ifndef MNH_OPENACC
+ ALLOCATE(ZY(IIU,IJU,IKU))
+#else
+ IZY = MNH_ALLOCATE_ZT3D(ZY ,IIU,IJU,IKU )
+#endif
!
!-------------------------------------------------------------------------------
!
@@ -308,10 +312,15 @@ SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
!
! WARNING WITH GET_HALO_D not BITREPROD !!!
!
- CALL GET_HALO(PF_1_Y)
+ CALL GET_HALO_DDC(PF_1_Y)
!
CALL PF_1_Y_BOUND(PF_1_Y)
!-------------------------------------------------------------------------------
+#ifndef MNH_OPENACC
+ DEALLOCATE(ZY)
+#else
+ CALL MNH_REL_ZT3D(IZY)
+#endif
!
CONTAINS