From 36d63a9ad6eb0656ecae7e08cb60872b6b34b531 Mon Sep 17 00:00:00 2001
From: Philippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Date: Mon, 13 Feb 2023 17:04:17 +0100
Subject: [PATCH] Philippe 13/02/2023: OpenACC: integration of ZSOLVER/
optimisations into MNH/ + remove now similar source files
---
src/MNH/advection_metsv.f90 | 107 +-
src/MNH/advection_uvw.f90 | 17 +-
src/MNH/dotprod.f90 | 21 +-
src/MNH/p_abs.f90 | 63 +-
src/MNH/rain_ice_red.f90 | 145 +-
src/MNH/turb.f90 | 127 +-
src/MNH/turb_hor_dyn_corr.f90 | 42 +-
src/MNH/update_lm.f90 | 14 +-
src/ZSOLVER/advection_metsv.f90 | 1142 -----------
src/ZSOLVER/advection_uvw.f90 | 513 -----
src/ZSOLVER/dotprod.f90 | 209 --
src/ZSOLVER/flat_inv.f90 | 702 -------
src/ZSOLVER/p_abs.f90 | 519 -----
src/ZSOLVER/rain_ice_red.f90 | 2977 -----------------------------
src/ZSOLVER/set_ref.f90 | 603 ------
src/ZSOLVER/turb_hor_dyn_corr.f90 | 1336 -------------
16 files changed, 371 insertions(+), 8166 deletions(-)
delete mode 100644 src/ZSOLVER/advection_metsv.f90
delete mode 100644 src/ZSOLVER/advection_uvw.f90
delete mode 100644 src/ZSOLVER/dotprod.f90
delete mode 100644 src/ZSOLVER/flat_inv.f90
delete mode 100644 src/ZSOLVER/p_abs.f90
delete mode 100644 src/ZSOLVER/rain_ice_red.f90
delete mode 100644 src/ZSOLVER/set_ref.f90
delete mode 100644 src/ZSOLVER/turb_hor_dyn_corr.f90
diff --git a/src/MNH/advection_metsv.f90 b/src/MNH/advection_metsv.f90
index 2fb15696c..faab6f654 100644
--- a/src/MNH/advection_metsv.f90
+++ b/src/MNH/advection_metsv.f90
@@ -191,9 +191,9 @@ USE MODI_ADV_BOUNDARIES
#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
USE MODI_BITREP
#endif
-#ifdef MNH_COMPILER_CCE
-!$mnh_undef(LOOP)
-!$mnh_undef(OPENACC)
+#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
+! mnh_undef(LOOP)
+! mnh_undef(OPENACC)
#endif
USE MODI_CONTRAV
@@ -531,37 +531,50 @@ END IF
!PW: not necessary: data already on device due to contrav_device !$acc update device(ZRUCPPM,ZRVCPPM,ZRWCPPM)
! acc kernels
IF (.NOT. L1D) THEN
- !$acc kernels present_cr(ZCFLU,ZCFLV,ZCFLW)
+ !$acc kernels present_cr(ZCFLU,ZCFLV,ZCFLW)
ZCFLU(:,:,:) = 0.0 ; ZCFLV(:,:,:) = 0.0 ; ZCFLW(:,:,:) = 0.0
+! !$acc end kernels
+! !$acc kernels
ZCFLU(IIB:IIE,IJB:IJE,:) = ABS(ZRUCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
ZCFLV(IIB:IIE,IJB:IJE,:) = ABS(ZRVCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
ZCFLW(IIB:IIE,IJB:IJE,:) = ABS(ZRWCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
!$acc end kernels
IF (LIBM) THEN
!$acc kernels
-!$mnh_expand_array(JI=IIB:IIE,JJ=IJB:IJE,JK=1:JKU)
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
+!$mnh_expand_array(JI=IIB:IIE,JJ=IJB:IJE,JK=1:JKU)
ZCFLU(IIB:IIE,IJB:IJE,:) = ZCFLU(IIB:IIE,IJB:IJE,:)*(1.-exp(-(XIBM_LS(IIB:IIE,IJB:IJE,:,2)/&
(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:))**(1./3.))**2.))
ZCFLV(IIB:IIE,IJB:IJE,:) = ZCFLV(IIB:IIE,IJB:IJE,:)*(1.-exp(-(XIBM_LS(IIB:IIE,IJB:IJE,:,3)/&
(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:))**(1./3.))**2.))
ZCFLW(IIB:IIE,IJB:IJE,:) = ZCFLW(IIB:IIE,IJB:IJE,:)*(1.-exp(-(XIBM_LS(IIB:IIE,IJB:IJE,:,4)/&
(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:))**(1./3.))**2.))
+!$mnh_end_expand_array()
#else
+#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
+DO CONCURRENT (JK=1:JKU,JJ=IJB:IJE,JI=IIB:IIE)
+#else
+!$mnh_expand_array(JI=IIB:IIE,JJ=IJB:IJE,JK=1:JKU)
+#endif
ZCFLU(IIB:IIE,IJB:IJE,:) = ZCFLU(IIB:IIE,IJB:IJE,:)*(1.-Br_exp(-Br_pow(XIBM_LS(IIB:IIE,IJB:IJE,:,2)/&
Br_pow(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:),1./3.),2.)))
ZCFLV(IIB:IIE,IJB:IJE,:) = ZCFLV(IIB:IIE,IJB:IJE,:)*(1.-Br_exp(-Br_pow(XIBM_LS(IIB:IIE,IJB:IJE,:,3)/&
Br_pow(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:),1./3.),2.)))
ZCFLW(IIB:IIE,IJB:IJE,:) = ZCFLW(IIB:IIE,IJB:IJE,:)*(1.-Br_exp(-Br_pow(XIBM_LS(IIB:IIE,IJB:IJE,:,4)/&
Br_pow(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:),1./3.),2.)))
-#endif
+#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
+END DO ! CONCURRENT
+#else
!$mnh_end_expand_array()
+#endif
+#endif
WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,2).GT.(-ZIBM_EPSI)) ZCFLU(IIB:IIE,IJB:IJE,:)=0.
WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,3).GT.(-ZIBM_EPSI)) ZCFLV(IIB:IIE,IJB:IJE,:)=0.
WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,4).GT.(-ZIBM_EPSI)) ZCFLW(IIB:IIE,IJB:IJE,:)=0.
!$acc end kernels
ENDIF
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
+!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
+#if !defined(MNH_BITREP)
IF (.NOT. L2D) THEN
!$acc kernels present_cr(ZCFL)
ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLV(:,:,:)**2+ZCFLW(:,:,:)**2)
@@ -574,17 +587,15 @@ IF (.NOT. L1D) THEN
#else
IF (.NOT. L2D) THEN
!$acc kernels
- !$acc_nv loop independent collapse(3)
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLU(JI,JJ,JK))+BR_P2(ZCFLV(JI,JJ,JK))+BR_P2(ZCFLW(JI,JJ,JK)))
- END DO
+ !$mnh_end_do()
!$acc end kernels
ELSE
!$acc kernels
- !$acc_nv loop independent collapse(3)
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ !$mnh_do_concurrent( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLU(JI,JJ,JK))+BR_P2(ZCFLW(JI,JJ,JK)))
- END DO
+ !$mnh_end_do()
!$acc end kernels
END IF
#endif
@@ -592,13 +603,13 @@ ELSE
!$acc kernels
ZCFLU(:,:,:) = 0.0 ; ZCFLV(:,:,:) = 0.0 ; ZCFLW(:,:,:) = 0.0
ZCFLW(IIB:IIE,IJB:IJE,:) = ABS(ZRWCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
+!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
+#if !defined(MNH_BITREP)
ZCFL(:,:,:) = SQRT(ZCFLW(:,:,:)**2)
-#else
- !$acc_nv loop independent collapse(3)
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+#else
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU )
ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLW(JI,JJ,JK)))
- END DO
+ !$mnh_end_do()
#endif
!$acc end kernels
END IF
@@ -668,12 +679,24 @@ ZCFLW_MAX = MAX_ll(ZCFLW,IINFO_ll)
ZCFL_MAX = MAX_ll(ZCFL,IINFO_ll)
#else
!
+#ifndef MNH_COMPILER_NVHPC
!$acc kernels
ZCFLU_MAX = MAXVAL(ZCFLU(IIB:IIE,IJB:IJE,IKB:IKE))
ZCFLV_MAX = MAXVAL(ZCFLV(IIB:IIE,IJB:IJE,IKB:IKE))
ZCFLW_MAX = MAXVAL(ZCFLW(IIB:IIE,IJB:IJE,IKB:IKE))
ZCFL_MAX = MAXVAL(ZCFL (IIB:IIE,IJB:IJE,IKB:IKE))
!$acc end kernels
+#else
+ZCFLU_MAX = 0.0 ; ZCFLV_MAX = 0.0 ; ZCFLW_MAX = 0.0 ; ZCFL_MAX = 0.0
+!$acc parallel reduction(max:ZCFLU_MAX,ZCFLV_MAX,ZCFLW_MAX,ZCFL_MAX)
+!$mnh_do_concurrent(JI=IIB:IIE,JJ=IJB:IJE,JK=IKB:IKE)
+ ZCFLU_MAX = MAX(ZCFLU_MAX,ZCFLU(JI,JJ,JK))
+ ZCFLV_MAX = MAX(ZCFLV_MAX,ZCFLV(JI,JJ,JK))
+ ZCFLW_MAX = MAX(ZCFLW_MAX,ZCFLW(JI,JJ,JK))
+ ZCFL_MAX = MAX(ZCFL_MAX,ZCFL (JI,JJ,JK))
+!$mnh_end_do()
+!$acc end parallel
+#endif
!
CALL MPI_ALLREDUCE(MPI_IN_PLACE,ZCFLU_MAX,1,MNHREAL_MPI,MPI_MAX,NMNH_COMM_WORLD,IINFO_ll)
CALL MPI_ALLREDUCE(MPI_IN_PLACE,ZCFLV_MAX,1,MNHREAL_MPI,MPI_MAX,NMNH_COMM_WORLD,IINFO_ll)
@@ -852,10 +875,18 @@ CALL PPM_RHODJ(HLBCX,HLBCY, ZRUCPPM, ZRVCPPM, ZRWCPPM, &
!$acc kernels
!dir$ concurrent
ZTH(:,:,:) = PTHT(:,:,:)
-!dir$ concurrent
-IF (KRR /=0 ) ZR(:,:,:,:) = PRT(:,:,:,:)
-!dir$ concurrent
-IF (KSV /=0 ) ZSV(:,:,:,:) = PSVT(:,:,:,:)
+!dir concurrent
+IF (KRR /=0 ) THEN
+ !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JR=1:KRR )
+ ZR(:,:,:,:) = PRT(:,:,:,:)
+ !$mnh_end_expand_array()
+END IF
+!dir concurrent
+IF (KSV /=0 ) THEN
+ !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JSV=1:KSV)
+ ZSV(:,:,:,:) = PSVT(:,:,:,:)
+ !$mnh_end_expand_array()
+END IF
!
IF (GTKE) THEN
PRTKES_ADV(:,:,:) = 0.
@@ -902,15 +933,21 @@ DO JSPL=1,KSPLIT
! Tendencies of PPM
!
! acc kernels
- !$acc kernels
- !dir$ concurrent
+ !$acc kernels present_cr(PRTHS,ZRTHS_PPM)
PRTHS(:,:,:) = PRTHS (:,:,:) + ZRTHS_PPM (:,:,:) / KSPLIT
- !dir$ concurrent
- IF (GTKE) PRTKES_ADV(:,:,:) = PRTKES_ADV(:,:,:) + ZRTKES_PPM(:,:,:) / KSPLIT
- !dir$ concurrent
- IF (KRR /=0) PRRS (:,:,:,:) = PRRS (:,:,:,:) + ZRRS_PPM (:,:,:,:) / KSPLIT
- !dir$ concurrent
- IF (KSV /=0 ) PRSVS (:,:,:,:) = PRSVS (:,:,:,:) + ZRSVS_PPM (:,:,:,:) / KSPLIT
+ IF (GTKE) THEN
+ PRTKES_ADV(:,:,:) = PRTKES_ADV(:,:,:) + ZRTKES_PPM(:,:,:) / KSPLIT
+ END IF
+ IF (KRR /=0) THEN
+ !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JR=1:KRR)
+ PRRS (:,:,:,:) = PRRS (:,:,:,:) + ZRRS_PPM (:,:,:,:) / KSPLIT
+ !$mnh_end_expand_array()
+ END IF
+ IF (KSV /=0 ) THEN
+ !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JSV=1:KSV)
+ PRSVS (:,:,:,:) = PRSVS (:,:,:,:) + ZRSVS_PPM (:,:,:,:) / KSPLIT
+ !$mnh_end_expand_array()
+ END IF
!$acc end kernels
!
IF (JSPL<KSPLIT) THEN
@@ -927,18 +964,16 @@ DO JSPL=1,KSPLIT
!$acc end kernels
END IF
!$acc kernels
- !$acc_nv loop independent collapse(4)
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU, JR=1:KRR )
+ !$mnh_do_concurrent( JI=1:JIU,JJ=1:JJU,JK=1:JKU, JR=1:KRR )
ZR(JI,JJ,JK,JR) = ZR(JI,JJ,JK,JR) + ( ZRRS_PPM(JI,JJ,JK,JR) + ZRRS_OTHER(JI,JJ,JK,JR) + PRRS_CLD(JI,JJ,JK,JR) ) &
* ZTSTEP_PPM / PRHODJ(JI,JJ,JK)
- END DO !CONCURRENT
+ !$mnh_end_do() !CONCURRENT
!$acc loop seq
DO JSV = 1, KSV
- !$acc_nv loop independent collapse(3)
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ !$mnh_do_concurrent ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
ZSV(JI,JJ,JK,JSV) = ZSV(JI,JJ,JK,JSV) + ( ZRSVS_PPM(JI,JJ,JK,JSV) + ZRSVS_OTHER(JI,JJ,JK,JSV) + &
PRSVS_CLD(JI,JJ,JK,JSV) ) * ZTSTEP_PPM / PRHODJ(JI,JJ,JK)
- END DO !CONCURRENT
+ !$mnh_end_do() !CONCURRENT
END DO
!$acc end kernels
END IF
diff --git a/src/MNH/advection_uvw.f90 b/src/MNH/advection_uvw.f90
index d41bc35c8..f80649a88 100644
--- a/src/MNH/advection_uvw.f90
+++ b/src/MNH/advection_uvw.f90
@@ -437,33 +437,26 @@ DO JSPL=1,ISPLIT
! Tendencies on wind
!$acc update device(ZRUS_ADV,ZRVS_ADV,ZRWS_ADV)
!$acc kernels
-#ifdef MNH_COMPILER_NVHPC
-!$acc loop independent collapse(3)
-#endif
-DO CONCURRENT (JI=1:IIU , JJ=1:IJU , JK=1:IKU )
+!$mnh_do_concurrent(JI=1:IIU,JJ=1:IJU,JK=1:IKU )
PRUS(JI,JJ,JK) = PRUS(JI,JJ,JK) + ZRUS_ADV(JI,JJ,JK) / ISPLIT
PRVS(JI,JJ,JK) = PRVS(JI,JJ,JK) + ZRVS_ADV(JI,JJ,JK) / ISPLIT
PRWS(JI,JJ,JK) = PRWS(JI,JJ,JK) + ZRWS_ADV(JI,JJ,JK) / ISPLIT
-END DO
-!$acc end kernels
-
+!$mnh_end_do()
IF (JSPL<ISPLIT) THEN
-!$acc kernels
!
! Guesses for next time splitting loop
!
!
-!$acc_nv loop independent collapse(3)
-DO CONCURRENT (JI=1:IIU , JJ=1:IJU , JK=1:IKU )
+!$mnh_do_concurrent(JI=1:IIU,JJ=1:IJU,JK=1:IKU)
ZU(JI,JJ,JK) = ZU(JI,JJ,JK) + ZTSTEP / ZMXM_RHODJ(JI,JJ,JK) * &
(ZRUS_OTHER(JI,JJ,JK) + ZRUS_ADV(JI,JJ,JK))
ZV(JI,JJ,JK) = ZV(JI,JJ,JK) + ZTSTEP / ZMYM_RHODJ(JI,JJ,JK) * &
(ZRVS_OTHER(JI,JJ,JK) + ZRVS_ADV(JI,JJ,JK))
ZW(JI,JJ,JK) = ZW(JI,JJ,JK) + ZTSTEP / ZMZM_RHODJ(JI,JJ,JK) * &
(ZRWS_OTHER(JI,JJ,JK) + ZRWS_ADV(JI,JJ,JK))
-END DO
+!$mnh_end_do()
+END IF
!$acc end kernels
- END IF
!
! Top and bottom Boundaries
!
diff --git a/src/MNH/dotprod.f90 b/src/MNH/dotprod.f90
index 2d0ac3e21..3b144b8c7 100644
--- a/src/MNH/dotprod.f90
+++ b/src/MNH/dotprod.f90
@@ -184,18 +184,17 @@ CALL MNH_MEM_GET(ZDOTPROD, ILBXB,ILBXE ,ILBYB,ILBYE )
#endif
!$acc kernels present(ZDOTPROD)
ZDOTPROD(:,:) = 0.
-#ifdef MNH_COMPILER_NVHPC
- !$acc loop independent collapse(2)
-#endif
- DO CONCURRENT (JI=ILBXB:ILBXE,JJ=ILBYB:ILBYE)
- !$acc loop seq
- DO JK = IKB-1,IKE+1
- ZDOTPROD(JI,JJ) = ZDOTPROD(JI,JJ) + PA(JI,JJ,JK) * PB(JI,JJ,JK)
- END DO
- END DO
!$acc end kernels
-!$acc update host(ZDOTPROD)
-PDOTPROD = SUM_DD_R2_ll(ZDOTPROD)
+!$acc parallel
+!$mnh_do_concurrent(JI=ILBXB:ILBXE,JJ=ILBYB:ILBYE)
+ !dir$ nextscalar
+ !$acc loop seq
+ DO JK = IKB-1,IKE+1
+ ZDOTPROD(JI,JJ) = ZDOTPROD(JI,JJ) + PA(JI,JJ,JK) * PB(JI,JJ,JK)
+ END DO
+!$mnh_end_do()
+!$acc end parallel
+PDOTPROD = SUM_DD_R2_ll_DEVICE(ZDOTPROD)
!JUAN16
#ifndef MNH_OPENACC
DEALLOCATE(ZDOTPROD)
diff --git a/src/MNH/p_abs.f90 b/src/MNH/p_abs.f90
index d615c4ccd..88d50e09c 100644
--- a/src/MNH/p_abs.f90
+++ b/src/MNH/p_abs.f90
@@ -126,6 +126,10 @@ USE MODE_REPRO_SUM
#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
USE MODI_BITREP
#endif
+#ifdef MNH_COMPILER_CCE
+!$mnh_undef(LOOP)
+!$mnh_undef(OPENACC)
+#endif
!
USE MODE_MPPDB
!
@@ -155,6 +159,9 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! vapor mixing ratio
! for the reference state
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF! Exner function of the
! reference state
+#ifdef MNH_COMPILER_CCE_1403 && defined(MNH_BITREP_OMP)
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: PEXNREF_BR
+#endif
!
REAL, INTENT(INOUT) :: PPHI0 ! PHI0 at t
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHIT ! Perturbation of
@@ -243,6 +250,9 @@ ALLOCATE (ZRTOT(IIU,IJU,IKU), ZRHOREF(IIU,IJU,IKU), ZWORK(IIU,IJU,IKU))
!Pin positions in the pools of MNH memory
CALL MNH_MEM_POSITION_PIN()
+#ifdef MNH_COMPILER_CCE_1403 && defined(MNH_BITREP_OMP)
+CALL MNH_MEM_GET( PEXNREF_BR, IIB, IIE, IJB, IJE, IKB, IKE )
+#endif
CALL MNH_MEM_GET(ZMASS_O_PI_2D , IIB,IIE , IJB,IJE)
CALL MNH_MEM_GET(ZMASSGUESS_2D , IIB,IIE , IJB,IJE)
CALL MNH_MEM_GET(ZWATERMASST_2D , IIB,IIE , IJB,IJE)
@@ -288,24 +298,35 @@ IF ( CEQNSYS=='DUR' .OR. CEQNSYS=='MAE' ) THEN
ZWORK(:,:,:)=PRHODJ * XTH00 &
/ ( PRHODREF * PTHVREF * (1. + PRVREF) )
END IF
- !
+#if defined(MNH_COMPILER_CCE_1403) && defined(MNH_BITREP_OMP)
+ !$acc loop
+ !$mnh_do_concurrent(JI=IIB:IIE,JJ=IJB:IJE,JK=IKB:IKE )
+ PEXNREF_BR(JI,JJ,JK)=BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD)
+ !$mnh_end_do()
+#endif
+ !$acc end kernels
+ !$acc parallel
!$acc loop seq
DO JK = IKB,IKE
- !$acc_nv loop independent collapse(2)
- DO CONCURRENT (JI = IIB:IIE , JJ = IJB:IJE )
+ !$acc loop independent
+ DO CONCURRENT ( JJ = IJB:IJE , JI = IIB:IIE )
ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
(PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
#else
+#if !defined(MNH_COMPILER_CCE_1403) || !defined(MNH_BITREP_OMP)
BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD) &
+#else
+ PEXNREF_BR(JI,JJ,JK) &
+#endif
#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
+ !$acc end parallel
!
ELSE
DO JK = IKB,IKE
@@ -328,10 +349,10 @@ IF ( CEQNSYS=='DUR' .OR. CEQNSYS=='MAE' ) THEN
END IF
!
!
- !$acc update host(ZMASSGUESS_2D,ZMASS_O_PI_2D,ZWATERMASST_2D)
- 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)
+ ! acc update host(ZMASSGUESS_2D,ZMASS_O_PI_2D,ZWATERMASST_2D)
+ ZMASSGUESS = SUM_DD_R2_ll_DEVICE(ZMASSGUESS_2D)
+ ZMASS_O_PI = SUM_DD_R2_ll_DEVICE(ZMASS_O_PI_2D)
+ ZWATERMASST = SUM_DD_R2_ll_DEVICE(ZWATERMASST_2D)
!
ZMASS_O_PI = ZMASS_O_PI*ZP00_O_RD*ZCVD_O_RD
ZPI0 = (PDRYMASST + ZWATERMASST - ZP00_O_RD*ZMASSGUESS ) / ZMASS_O_PI
@@ -347,21 +368,33 @@ IF ( CEQNSYS=='DUR' .OR. CEQNSYS=='MAE' ) THEN
ZMASSGUESS_2D = 0.
!$acc end kernels
IF ( CEQNSYS == 'DUR' ) THEN
+#if defined(MNH_COMPILER_CCE_1403) && defined(MNH_BITREP_OMP)
!$acc kernels
+ !$acc loop
+ !$mnh_do_concurrent(JI=IIB:IIE,JJ=IJB:IJE,JK=IKB:IKE )
+ PEXNREF_BR(JI,JJ,JK)=BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD)
+ !$mnh_end_do()
+ !$acc end kernels
+#endif
+ !$acc parallel
!$acc loop seq
DO JK = IKB,IKE
- !$acc_nv loop independent collapse(2)
- DO CONCURRENT (JI = IIB:IIE , JJ = IJB:IJE )
+ !$acc loop independent
+ DO CONCURRENT ( JJ = IJB:IJE , JI = IIB:IIE )
ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
(PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
#else
+#if !defined(MNH_COMPILER_CCE_1403) || !defined(MNH_BITREP_OMP)
BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD) &
+#else
+ PEXNREF_BR(JI,JJ,JK) &
+#endif
#endif
* ZWORK(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
- END DO
+ END DO
END DO
- !$acc end kernels
+ !$acc end parallel
ELSE
DO JK = IKB,IKE
DO JJ = IJB,IJE
@@ -378,8 +411,8 @@ IF ( CEQNSYS=='DUR' .OR. CEQNSYS=='MAE' ) THEN
END DO
END IF
!
- !$acc update host(ZMASSGUESS_2D)
- ZMASSGUESS = SUM_DD_R2_ll(ZMASSGUESS_2D)
+ ! acc update host(ZMASSGUESS_2D)
+ ZMASSGUESS = SUM_DD_R2_ll_DEVICE(ZMASSGUESS_2D)
!
ZPI0 = (PDRYMASST + ZWATERMASST - ZP00_O_RD*ZMASSGUESS ) / ZMASS_O_PI
!$acc kernels
diff --git a/src/MNH/rain_ice_red.f90 b/src/MNH/rain_ice_red.f90
index c598b4c69..221cd5fc7 100644
--- a/src/MNH/rain_ice_red.f90
+++ b/src/MNH/rain_ice_red.f90
@@ -682,6 +682,8 @@ REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZSSI
!For total tendencies computation
REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: &
&ZW_RVS, ZW_RCS, ZW_RRS, ZW_RIS, ZW_RSS, ZW_RGS, ZW_RHS, ZW_THS
+!
+REAL, DIMENSION(:,:,:), pointer, contiguous :: ZTEMP_BUD
#endif
!
LOGICAL :: GTEST ! temporary variable for OpenACC character limitation (Cray CCE)
@@ -1151,6 +1153,8 @@ CALL MNH_MEM_GET( zw_rgs, jiu, jju, jku )
CALL MNH_MEM_GET( zw_rhs, jiu, jju, jku )
CALL MNH_MEM_GET( zw_ths, jiu, jju, jku )
+CALL MNH_MEM_GET( ZTEMP_BUD, JIU, JJU, JKU )
+
!$acc data present( I1, I2, I3, &
!$acc & ZW, ZT, ZZ_RVHENI_MR, ZZ_RVHENI, ZZ_LVFACT, ZZ_LSFACT, ZLSFACT3D, ZINPRI, &
!$acc & ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZRHT, ZCIT, ZTHT, ZRHODREF, ZZT, ZPRES, ZEXN, &
@@ -1174,13 +1178,29 @@ CALL MNH_MEM_GET( zw_ths, jiu, jju, jku )
!$acc & ZB_TH, ZB_RV, ZB_RC, ZB_RR, ZB_RI, ZB_RS, ZB_RG, ZB_RH, &
!$acc & ZEXT_RV, ZEXT_RC, ZEXT_RR, ZEXT_RI, ZEXT_RS, ZEXT_RG, ZEXT_RH, ZEXT_TH, &
!$acc & IITER, ZTIME, ZMAXTIME, ZTIME_THRESHOLD, ZTIME_LASTCALL, ZW1D, ZCOMPUTE, GDNOTMICRO, &
-!$acc & ZRS_TEND, ZRG_TEND, ZRH_TEND, ZSSI, ZW_RVS, ZW_RCS, ZW_RRS, ZW_RIS, ZW_RSS, ZW_RGS, ZW_RHS, ZW_THS )
+!$acc & ZRS_TEND, ZRG_TEND, ZRH_TEND, ZSSI, ZW_RVS, ZW_RCS, ZW_RRS, ZW_RIS, ZW_RSS, ZW_RGS, ZW_RHS, ZW_THS, &
+!$acc & ZTEMP_BUD )
#endif
!-------------------------------------------------------------------------------
if ( lbu_enable ) then
+#ifndef MNH_OPENACC
if ( lbudget_th ) call Budget_store_init( tbudgets(NBUDGET_TH), 'HENU', pths(:, :, :) * prhodj(:, :, :) )
if ( lbudget_rv ) call Budget_store_init( tbudgets(NBUDGET_RV), 'HENU', prvs(:, :, :) * prhodj(:, :, :) )
+#else
+ if ( lbudget_th ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = pths(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_TH), 'HENU', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rv ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prvs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RV), 'HENU', ZTEMP_BUD(:,:,:) )
+ end if
+#endif
end if
!-------------------------------------------------------------------------------
!
@@ -1241,7 +1261,7 @@ IF(KRR==7) THEN
ENDDO
ENDDO
ELSE
-#if 0
+#if 1
!$acc loop independent collapse(3)
DO JK = 1, KKT
DO JJ = 1, KJT
@@ -1279,6 +1299,7 @@ IF(.NOT. LSEDIM_AFTER) THEN
!
!* 2.1 sedimentation
!
+#ifndef MNH_OPENACC
if ( lbudget_rc .and. osedic ) call Budget_store_init( tbudgets(NBUDGET_RC), 'SEDI', prcs(:, :, :) * prhodj(:, :, :) )
if ( lbudget_rr ) call Budget_store_init( tbudgets(NBUDGET_RR), 'SEDI', prrs(:, :, :) * prhodj(:, :, :) )
if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'SEDI', pris(:, :, :) * prhodj(:, :, :) )
@@ -1291,7 +1312,54 @@ IF(.NOT. LSEDIM_AFTER) THEN
! if osedic=T and ldeposc=T (a warning is printed in ini_budget in that case)
if ( lbudget_rc .and. ldeposc .and. .not.osedic ) &
call Budget_store_init( tbudgets(NBUDGET_RC), 'DEPO', prcs(:, :, :) * prhodj(:, :, :) )
+#else
+ if ( lbudget_rc .and. osedic ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RC), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rr ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prrs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RR), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_ri ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = pris(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RI), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rs ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prss(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RS), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rg ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prgs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RG), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rh ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prhs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RH), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ !Init only if not osedic (to prevent crash with double init)
+ !Remark: the 2 source terms SEDI and DEPO could be mixed and stored in the same source term (SEDI)
+ ! if osedic=T and ldeposc=T (a warning is printed in ini_budget in that case)
+ if ( lbudget_rc .and. ldeposc .and. .not.osedic ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_init( tbudgets(NBUDGET_RC), 'DEPO', ZTEMP_BUD(:,:,:) )
+ end if
+#endif
IF(HSEDIM=='STAT') THEN
#ifdef MNH_OPENACC
CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_RED','OpenACC: HSEDIM=STAT not yet implemented')
@@ -1362,6 +1430,7 @@ IF(.NOT. LSEDIM_AFTER) THEN
!
!* 2.2 budget storage
!
+#ifndef MNH_OPENACC
if ( lbudget_rc .and. osedic ) call Budget_store_end( tbudgets(NBUDGET_RC), 'SEDI', prcs(:, :, :) * prhodj(:, :, :) )
if ( lbudget_rr ) call Budget_store_end( tbudgets(NBUDGET_RR), 'SEDI', prrs(:, :, :) * prhodj(:, :, :) )
if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI), 'SEDI', pris(:, :, :) * prhodj(:, :, :) )
@@ -1373,6 +1442,53 @@ IF(.NOT. LSEDIM_AFTER) THEN
!(a warning is printed in ini_budget in that case)
if ( lbudget_rc .and. ldeposc .and. .not.osedic) &
call Budget_store_end( tbudgets(NBUDGET_RC), 'DEPO', prcs(:, :, :) * prhodj(:, :, :) )
+#else
+ if ( lbudget_rc .and. osedic ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RC), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rr ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prrs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RR), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_ri ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = pris(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RI), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rs ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prss(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RS), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rg ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prgs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RG), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rh ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prhs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RH), 'SEDI', ZTEMP_BUD(:,:,:) )
+ end if
+
+ !If osedic=T and ldeposc=T, DEPO is in fact mixed and stored with the SEDI source term
+ !(a warning is printed in ini_budget in that case)
+ if ( lbudget_rc .and. ldeposc .and. .not.osedic) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RC), 'DEPO', ZTEMP_BUD(:,:,:) )
+ end if
+#endif
ENDIF
!
!-------------------------------------------------------------------------------
@@ -1982,7 +2098,7 @@ CALL ICE4_NUCLEATION_WRAPPER(KIT, KJT, KKT, GDNOTMICRO, &
PTHT, PPABST, PRHODREF, PEXN, ZLSFACT3D, ZT, &
PRVT, &
PCIT, ZZ_RVHENI_MR)
-#if 0
+#if 1
!$acc kernels
!$acc loop independent collapse(3)
DO JK = 1, KKT
@@ -2014,9 +2130,30 @@ END DO
!
if ( lbu_enable ) then
!Note: there is an other contribution for HENU later
+#ifndef MNH_OPENACC
if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'HENU', pths(:, :, :) * prhodj(:, :, :) )
if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'HENU', prvs(:, :, :) * prhodj(:, :, :) )
if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'HENU', zz_rvheni(:, :, :) * prhodj(:, :, :) )
+#else
+ if ( lbudget_th ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = pths(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_TH), 'HENU', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_rv ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = prvs(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_end( tbudgets(NBUDGET_RV), 'HENU', ZTEMP_BUD(:,:,:) )
+ end if
+ if ( lbudget_ri ) then
+ !$acc kernels present_cr(ZTEMP_BUD)
+ ZTEMP_BUD(:,:,:) = zz_rvheni(:, :, :) * prhodj(:, :, :)
+ !$acc end kernels
+ call Budget_store_add( tbudgets(NBUDGET_RI), 'HENU', ZTEMP_BUD(:,:,:) )
+ end if
+#endif
end if
!-------------------------------------------------------------------------------
!
@@ -2174,7 +2311,7 @@ ELSE
END DO
!$acc end kernels
!
-!$acc kernels
+!$acc kernels present_cr( ZW_RHS )
ZW_RVS(:,:,:) = ( ZW_RVS(:,:,:) - PRVT(:,:,:) ) * ZINV_TSTEP
ZW_RCS(:,:,:) = ( ZW_RCS(:,:,:) - PRCT(:,:,:) ) * ZINV_TSTEP
ZW_RRS(:,:,:) = ( ZW_RRS(:,:,:) - PRRT(:,:,:) ) * ZINV_TSTEP
diff --git a/src/MNH/turb.f90 b/src/MNH/turb.f90
index abfde1c07..ab7389a2d 100644
--- a/src/MNH/turb.f90
+++ b/src/MNH/turb.f90
@@ -14,7 +14,7 @@ module mode_turb
#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
use modi_bitrep
#endif
-#ifdef MNH_COMPILER_CCE
+#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
!$mnh_undef(LOOP)
!$mnh_undef(OPENACC)
#endif
@@ -712,8 +712,6 @@ GTURBLEN_BL89_TURBLEN_RM17_TURBLEN_ADAP_ORMC01 = &
HTURBLEN=='BL89' .OR. HTURBLEN=='RM17' .OR. HTURBLEN == 'ADAP' .OR. ORMC01
!
!$acc update device(PTHLT,PRT)
-!PASCAL
-!!$acc kernels present_cr(ZCOEF_DISS,ZTHLM,ZRM,zcp)
!Copy data into ZTHLM and ZRM only if needed
IF (HTURBLEN=='BL89' .OR. HTURBLEN=='RM17' .OR. HTURBLEN=='ADAP' .OR. ORMC01) THEN
!$acc kernels present_cr(ZTHLM,ZRM)
@@ -761,9 +759,9 @@ ELSE
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
ZEXN(:,:,:) = (PPABST(:,:,:)/XP00) ** (XRD/XCPD)
#else
-DO CONCURRENT(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
ZEXN(JI,JJ,JK) = BR_POW(PPABST(JI,JJ,JK)/XP00,XRD/XCPD)
-END DO
+!$mnh_end_do()
#endif
END IF
!
@@ -812,18 +810,20 @@ IF (KRRL >=1) THEN
ZLSOCPEXNM,ZAMOIST_ICE,ZATHETA_ICE)
!
!$acc kernels present_cr( zamoist, zatheta, zlocpexnm, zlvocpexnm, zlsocpexnm, zamoist_ice, zatheta_ice )
- DO CONCURRENT(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
IF (PRT(JI,JJ,JK,2)+PRT(JI,JJ,JK,4)>0.0) THEN
ZFRAC_ICE(JI,JJ,JK) = PRT(JI,JJ,JK,4) / ( PRT(JI,JJ,JK,2)+PRT(JI,JJ,JK,4) )
END IF
- END DO
+ !$mnh_end_do()
!
+ !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
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(:,:,:)
+ !$mnh_end_expand_array()
!$acc end kernels
!$acc end data
@@ -878,7 +878,7 @@ END IF ! loop end on KRRL >= 1
IF ( KRRL >= 1 ) THEN
!$acc kernels present_cr( zlocpexnm )
IF ( KRRI >= 1 ) THEN
- DO CONCURRENT (JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
! Rnp at t
PRT(JI,JJ,JK,1) = PRT(JI,JJ,JK,1) + PRT(JI,JJ,JK,2) + PRT(JI,JJ,JK,4)
PRRS(JI,JJ,JK,1) = PRRS(JI,JJ,JK,1) + PRRS(JI,JJ,JK,2) + PRRS(JI,JJ,JK,4)
@@ -887,16 +887,16 @@ IF ( KRRL >= 1 ) THEN
- ZLSOCPEXNM(JI,JJ,JK) * PRT(JI,JJ,JK,4)
PRTHLS(JI,JJ,JK) = PRTHLS(JI,JJ,JK) - ZLVOCPEXNM(JI,JJ,JK) * PRRS(JI,JJ,JK,2) &
- ZLSOCPEXNM(JI,JJ,JK) * PRRS(JI,JJ,JK,4)
- ENDDO
+ !$mnh_end_do()
ELSE
- DO CONCURRENT (JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
! Rnp at t
PRT(JI,JJ,JK,1) = PRT(JI,JJ,JK,1) + PRT(JI,JJ,JK,2)
PRRS(JI,JJ,JK,1) = PRRS(JI,JJ,JK,1) + PRRS(JI,JJ,JK,2)
! Theta_l at t
PTHLT(JI,JJ,JK) = PTHLT(JI,JJ,JK) - ZLOCPEXNM(JI,JJ,JK) * PRT(JI,JJ,JK,2)
PRTHLS(JI,JJ,JK) = PRTHLS(JI,JJ,JK) - ZLOCPEXNM(JI,JJ,JK) * PRRS(JI,JJ,JK,2)
- ENDDO
+ !$mnh_end_do()
END IF
!$acc end kernels
END IF
@@ -1084,11 +1084,10 @@ ENDIF
ZCDUEFF(:,:) =-SQRT ( (PSFU(:,:)**2 + PSFV(:,:)**2) / &
(XMNH_TINY + ZUSLOPE(:,:)**2 + ZVSLOPE(:,:)**2 ) )
#else
- !$acc_nv loop independent collapse(2)
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ !$mnh_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
+ !$mnh_end_do()
#endif
!$acc end kernels
!
@@ -1515,7 +1514,6 @@ IF ( KRRL >= 1 ) THEN
END IF
END IF
-
! Remove non-physical negative values (unnecessary in a perfect world) + corresponding budgets
call Sources_neg_correct( hcloud, 'NETUR', krr, ptstep, ppabst, pthlt, prt, prthls, prrs, prsvs )
!$acc update self( PTHLT ) !PTHLT not modified in Sources_neg_correct
@@ -1763,7 +1761,7 @@ geast = HLBCX(2) /= "CYCL" .AND. LEAST_ll()
gsouth = HLBCY(1) /= "CYCL" .AND. LSOUTH_ll()
gnorth = HLBCY(2) /= "CYCL" .AND. LNORTH_ll()
-!$acc kernels present_cr(PUSLOPE)
+!$acc kernels present_cr(PUSLOPE,PVSLOPE)
IF ( gwest ) THEN
PUSLOPE(IIB-1,:)=PUSLOPE(IIB,:)
PVSLOPE(IIB-1,:)=PVSLOPE(IIB,:)
@@ -1859,7 +1857,7 @@ CALL MNH_MEM_GET( zdrvsatdt, size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
!
!* 1.1 Lv/Cph at t
!
-!$acc kernels present_cr(PLOCPEXN) ! present(ZRVSAT,ZDRVSATDT) ! present(PLOCPEXN) ! present ZDRVSATDT)
+!$acc kernels present_cr(PLOCPEXN) ! present(ZRVSAT,ZDRVSATDT) ! present(PLOCPEXN) ! present ZDRVSATDT)
PLOCPEXN(:,:,:) = ( PLTT + (XCPV-PC) * (PT(:,:,:)-XTT) ) / PCP(:,:,:)
!
!* 1.2 Saturation vapor pressure at t
@@ -1870,11 +1868,11 @@ CALL MNH_MEM_GET( zdrvsatdt, size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
ZRVSAT(:,:,:) = EXP( PALP - PBETA/PT(:,:,:) - PGAM*ALOG( PT(:,:,:) ) )
#else
- DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ !$mnh_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
+ !$mnh_end_do()
#endif
-!$acc end kernels
+!$acc end kernels
!$acc kernels present_cr(ZRVSAT,ZDRVSATDT)
!
!* 1.3 saturation mixing ratio at t
@@ -1891,9 +1889,9 @@ CALL MNH_MEM_GET( zdrvsatdt, size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
PAMOIST(:,:,:)= 0.5 / ( 1.0 + ZDRVSATDT(:,:,:) * PLOCPEXN(:,:,:) )
!
!$acc end kernels
+!$acc kernels
!* 1.6 compute Atheta
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-!$acc kernels present_cr(PATHETA)
PATHETA(:,:,:)= PAMOIST(:,:,:) * PEXN(:,:,:) * &
( ( ZRVSAT(:,:,:) - PRT(:,:,:,1) ) * PLOCPEXN(:,:,:) / &
( 1. + ZDRVSATDT(:,:,:) * PLOCPEXN(:,:,:) ) * &
@@ -1905,11 +1903,8 @@ CALL MNH_MEM_GET( zdrvsatdt, size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
) &
- ZDRVSATDT(:,:,:) &
)
-!$acc end kernels
#else
-!$acc kernels
-!$acc_nv loop independent collapse(3)
-DO CONCURRENT(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
PATHETA(JI,JJ,JK)= PAMOIST(JI,JJ,JK) * PEXN(JI,JJ,JK) * &
( ( ZRVSAT(JI,JJ,JK) - PRT(JI,JJ,JK,1) ) * PLOCPEXN(JI,JJ,JK) / &
( 1. + ZDRVSATDT(JI,JJ,JK) * PLOCPEXN(JI,JJ,JK) ) * &
@@ -1921,17 +1916,15 @@ DO CONCURRENT(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
) &
- ZDRVSATDT(JI,JJ,JK) &
)
-ENDDO
-!$acc end kernels
+!$mnh_end_do()
#endif
+!$acc end kernels
!* 1.7 Lv/Cph/Exner at t-1
!
-!!$acc kernels present(PLOCPEXN)
-!$acc kernels
-!$acc_nv loop independent collapse(3)
-DO CONCURRENT(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+!$acc kernels present_cr(PLOCPEXN)
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
PLOCPEXN(JI,JJ,JK) = PLOCPEXN(JI,JJ,JK) / PEXN(JI,JJ,JK)
-END DO
+!$mnh_end_do()
!$acc end kernels
if ( mppdb_initialized ) then
@@ -1943,7 +1936,7 @@ END DO
!$acc end data
-#ifndef MNH_OPENACC
+#ifndef MNH_OPENACC
deallocate( zrvsat, zdrvsatdt )
#else
!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
@@ -2026,7 +2019,7 @@ allocate( zlm_cloud (size( put, 1 ), size( put, 2 ), size( put, 3) ) )
!* 1. INITIALISATION
! --------------
!
-ZPENTE = ( PCOEF_AMPL_SAT - 1. ) / ( PCEI_MAX - PCEI_MIN )
+ZPENTE = ( PCOEF_AMPL_SAT - 1. ) / ( PCEI_MAX - PCEI_MIN )
ZCOEF_AMPL_CEI_NUL = 1. - ZPENTE * PCEI_MIN
!
ZCOEF_AMPL(:,:,:) = 1.
@@ -2043,7 +2036,7 @@ WHERE ( PCEI(:,:,:)>=PCEI_MAX ) ZCOEF_AMPL(:,:,:)=PCOEF_AMPL_SAT
!
WHERE ( PCEI(:,:,:) < PCEI_MAX .AND. &
PCEI(:,:,:) > PCEI_MIN ) &
- ZCOEF_AMPL(:,:,:) = ZPENTE * PCEI(:,:,:) + ZCOEF_AMPL_CEI_NUL
+ ZCOEF_AMPL(:,:,:) = ZPENTE * PCEI(:,:,:) + ZCOEF_AMPL_CEI_NUL
!
!
!* 3. CALCULATION OF THE MIXING LENGTH IN CLOUDS
@@ -2265,17 +2258,15 @@ IF (ODZ) THEN
#else
CALL MXF_DEVICE( PDXX, ZTMP1_DEVICE )
CALL MYF_DEVICE( PDYY, ZTMP2_DEVICE )
+!$acc kernels
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-!$acc kernels present_cr(PLM)
PLM(:,:,:) = ( PLM(:,:,:) * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:) ) ** (1./3.)
-!$acc end kernels
#else
-!$acc kernels
-DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
PLM(JI,JJ,JK) = BR_POW( PLM(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK), 1./3. )
-ENDDO
-!$acc end kernels
+!$mnh_end_do()
#endif
+!$acc end kernels
#endif
END IF
END IF
@@ -2305,9 +2296,9 @@ ELSE
#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
PLM(:,:,:) = ( ZTMP1_DEVICE * ZTMP2_DEVICE ) ** (1./2.)
#else
- DO CONCURRENT( JI=1:JIU, JJ=1:JJU, JK=1:JKU )
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
PLM(JI,JJ,JK) = BR_POW( ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK), 1. / 2. )
- END DO
+ !$mnh_end_do()
#endif
!$acc end kernels
#endif
@@ -2356,12 +2347,12 @@ IF (.NOT. ORMC01) THEN
END IF
!
!$acc kernels
-DO CONCURRENT(JI=1:JIU , JJ=1:JJU )
- PLM(JI,JJ,KKA) = PLM(JI,JJ,KKB )
-END DO
-DO CONCURRENT(JI=1:JIU , JJ=1:JJU )
- PLM(JI,JJ,KKU ) = PLM(JI,JJ,KKE)
-END DO
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU)
+ PLM(JI,JJ,KKA) = PLM(JI,JJ,KKB)
+! mnh_end_do()
+! mnh_do_concurrent(JI=1:JIU,JJ=1:JJU)
+ PLM(JI,JJ,KKU) = PLM(JI,JJ,KKE)
+!$mnh_end_do()
!$acc end kernels
!$acc end data
@@ -2372,8 +2363,8 @@ if ( mppdb_initialized ) then
end if
#ifdef MNH_OPENACC
- !Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
- CALL MNH_MEM_RELEASE()
+!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
+CALL MNH_MEM_RELEASE()
#endif
END SUBROUTINE DELT
@@ -2576,9 +2567,9 @@ IF ( HTURBDIM /= '1DIM' ) THEN ! 3D turbulence scheme
call Mppdb_check( plm, "Dear mid1:plm" )
end if
!$acc kernels
-DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
PLM(JI,JJ,JK) = BR_POW( PLM(JI,JJ,JK)*ZTMP1_DEVICE(JI,JJ,JK) *ZTMP2_DEVICE(JI,JJ,JK) , 1./3. )
-ENDDO
+!$mnh_end_do()
!$acc end kernels
if ( mppdb_initialized ) then
call Mppdb_check( plm, "Dear mid2:plm" )
@@ -2599,8 +2590,8 @@ CALL EMOIST(KRR,KRRI,PTHLT,PRT,PLOCPEXNM,PAMOIST,PSRCT,ZEMOIST)
!
!$acc kernels present(ZWORK2D,PLM)
IF (KRR>0) THEN
- !$acc_nv loop independent collapse(3) private(ZVAR)
- DO CONCURRENT( JI=1:JIU, JJ=1:JJU, JK = KKTB+1:KKTE-1)
+ ! acc loop private(ZVAR)
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=KKTB+1:KKTE-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)+ &
@@ -2616,10 +2607,10 @@ IF (KRR>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
+ !$mnh_end_do()
ELSE! For dry atmos or unsalted ocean runs
- !$acc_nv loop independent collapse(3) private(ZVAR)
- DO CONCURRENT( JI=1:JIU, JJ=1:JJU, JK = KKTB+1:KKTE-1)
+ ! acc loop private(ZVAR)
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=KKTB+1:KKTE-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 ))
IF (GOCEAN) THEN
@@ -2632,7 +2623,7 @@ ELSE! For dry atmos or unsalted ocean runs
PLM(JI,JJ,JK)=MAX(XMNH_EPSILON,MIN(PLM(JI,JJ,JK), &
0.76* SQRT(PTKET(JI,JJ,JK)/ZVAR)))
END IF
- END DO
+ !$mnh_end_do()
END IF
! special case near the surface
ZDTHLDZ(:,:,KKB)=(PTHLT(:,:,KKB+KKL)-PTHLT(:,:,KKB))/PDZZ(:,:,KKB+KKL)
@@ -2649,12 +2640,9 @@ IF (GOCEAN) THEN
ZWORK2D(:,:)=XG*(XALPHAOC*ZDTHLDZ(:,:,KKB)-XBETAOC*ZDRTDZ(:,:,KKB))
#else
!PW: bug: nvhpc 21.11 does not parallelize this loop even with loop independent directive!
-#ifdef MNH_COMPILER_NVHPC
-!$acc loop independent collapse(2)
-#endif
- DO CONCURRENT( JI = 1 : JIU, JJ = 1 : JJU )
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU)
ZWORK2D(JI,JJ)=XG*(XALPHAOC*ZDTHLDZ(JI,JJ,KKB)-XBETAOC*ZDRTDZ(JI,JJ,KKB))
- END DO
+ !$mnh_end_do()
#endif
ELSE
#if 0
@@ -2663,21 +2651,18 @@ ELSE
(ZETHETA(:,:,KKB)*ZDTHLDZ(:,:,KKB)+ZEMOIST(:,:,KKB)*ZDRTDZ(:,:,KKB))
#else
!PW: bug: nvhpc 21.11 does not parallelize this loop even with loop independent directive!
-#ifdef MNH_COMPILER_NVHPC
-!$acc loop independent collapse(2)
-#endif
- DO CONCURRENT( JI = 1 : JIU, JJ = 1 : JJU )
+ !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU)
ZWORK2D(JI,JJ)=XG/PTHVREF(JI,JJ,KKB)* &
(ZETHETA(JI,JJ,KKB)*ZDTHLDZ(JI,JJ,KKB)+ZEMOIST(JI,JJ,KKB)*ZDRTDZ(JI,JJ,KKB))
- END DO
+ !$mnh_end_do()
#endif
END IF
-DO CONCURRENT(JI=1:JIU,JJ=1:JJU)
+!$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU)
IF (ZWORK2D(JI,JJ)>0.) THEN
PLM(JI,JJ,KKB)=MAX(XMNH_EPSILON,MIN( PLM(JI,JJ,KKB), &
0.76* SQRT(PTKET(JI,JJ,KKB)/ZWORK2D(JI,JJ))))
END IF
-END DO
+!$mnh_end_do()
!
! mixing length limited by the distance normal to the surface (with the same factor as for BL89)
!
diff --git a/src/MNH/turb_hor_dyn_corr.f90 b/src/MNH/turb_hor_dyn_corr.f90
index d504591e9..d66d1f983 100644
--- a/src/MNH/turb_hor_dyn_corr.f90
+++ b/src/MNH/turb_hor_dyn_corr.f90
@@ -140,7 +140,9 @@ END MODULE MODI_TURB_HOR_DYN_CORR
!* 0. DECLARATIONS
! ------------
!
+#ifndef MNH_OPENACC
USE MODD_ARGSLIST_ll, ONLY: LIST_ll
+#endif
USE MODD_CST
USE MODD_CONF
USE MODD_CTURB
@@ -157,20 +159,23 @@ USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEAS
#endif
use mode_mppdb
!
+USE MODI_COEFJ
+#ifdef MNH_OPENACC
+USE MODI_GET_HALO
+#endif
USE MODI_GRADIENT_M
USE MODI_GRADIENT_U
USE MODI_GRADIENT_V
USE MODI_GRADIENT_W
+USE MODI_LES_MEAN_SUBGRID
+USE MODI_SECOND_MNH
#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
#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
USE MODI_BITREP
@@ -259,7 +264,9 @@ REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDV_DY ! dv/dy sur
REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDW_DZ ! dw/dz surf
!
INTEGER :: IINFO_ll ! return code of parallel routine
+#ifndef MNH_OPENACC
TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+#endif
REAL :: ZTIME1, ZTIME2
@@ -387,7 +394,9 @@ CALL MNH_MEM_GET( ztmp4_device, JIU, JJU, JKU )
!
!* 1. PRELIMINARY COMPUTATIONS
! ------------------------
+#ifndef MNH_OPENACC
NULLIFY(TZFIELDS_ll)
+#endif
!
IKB = 1+JPVEXT
IKE = SIZE(PUM,3)-JPVEXT
@@ -423,8 +432,9 @@ CALL GZ_W_M_DEVICE(PWM,PDZZ,GZ_W_M_PWM)
CALL MZF_DEVICE( PDZZ, ZMZF_DZZ )
#endif
!
+#ifndef MNH_OPENACC
CALL ADD3DFIELD_ll( TZFIELDS_ll, ZFLX, 'TURB_HOR_DYN_CORR::ZFLX' )
-
+#endif
! compute the coefficients for the uncentred gradient computation near the
! ground
@@ -619,7 +629,8 @@ CALL MYF_DEVICE(PDYY(:,:,IKB:IKB),ZTMP4_DEVICE(:,:,1:1))
!!! wait for the computation of ZDIRSINZW
!$acc wait(1)
!
-!$acc kernels async(4) present_cr(ZFLX,ZDIRSINZW)
+!$acc kernels async(4) present_cr(ZFLX,ZDIRSINZW)
+!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
#if !defined(MNH_BITREP)
ZFLX(:,:,IKB-1) = &
@@ -632,7 +643,6 @@ ZFLX(:,:,IKB-1) = &
- PUSLOPEM(:,:) * PCOSSLOPE(:,:)**2 * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) )
#else
!PW: BUG: commented 'acc loop independent collapse(2)' to workaround compiler bug (NVHPC 21.1)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
ZFLX(:,:,IKB-1) = &
PTAU11M(:,:) * BR_P2(PCOSSLOPE(:,:)) * BR_P2(PDIRCOSZW(:,:)) &
-2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
@@ -641,8 +651,8 @@ ZFLX(:,:,IKB-1) = &
+2. * PCDUEFF(:,:) * ( &
PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) &
- PUSLOPEM(:,:) * BR_P2(PCOSSLOPE(:,:)) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) )
-!$mnh_end_expand_array()
#endif
+!$mnh_end_expand_array()
!$acc end kernels
!
!!! wait for the computation of ZFLX(:,:,IKB) and ZFLX(:,:,IKB-1)
@@ -675,9 +685,11 @@ ZFLX(:,:,IKB-1) = &
!!! to be absolutely sure, we do a wait
!$acc wait
!
-!$acc update self(ZFLX)
+#ifndef MNH_OPENACC
CALL UPDATE_HALO_ll(TZFIELDS_ll, IINFO_ll)
-!$acc update device(ZFLX) async(10)
+#else
+CALL GET_HALO_D(ZFLX,HNAME='TURB_HOR_DYN_CORR::ZFLX')
+#endif
!
IF ( tpfile%lopened .AND. OTURB_FLX ) THEN
! stores <U U>
@@ -884,9 +896,11 @@ ZFLX(:,:,IKB-1) = 2. * ZFLX(:,:,IKB-1) - ZFLX(:,:,IKB)
! ! !$acc wait(3)
!
!$acc wait(3)
-!$acc update self(ZFLX)
+#ifndef MNH_OPENACC
CALL UPDATE_HALO_ll(TZFIELDS_ll, IINFO_ll)
-!$acc update device(ZFLX) async(10)
+#else
+CALL GET_HALO_D(ZFLX,HNAME='TURB_HOR_DYN_CORR::ZFLX')
+#endif
!
IF ( tpfile%lopened .AND. OTURB_FLX ) THEN
! stores <V V>
@@ -1070,7 +1084,7 @@ ZFLX(:,:,IKE+1)= ZFLX(:,:,IKE)
! - 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) present_cr(ZFLX)
+!$acc kernels async(3) present_cr(ZFLX)
!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
#if !defined(MNH_BITREP)
ZFLX(:,:,IKB-1) = &
@@ -1087,7 +1101,7 @@ ZFLX(:,:,IKB-1) = &
!$mnh_end_expand_array()
#endif
!$acc end kernels
- !
+!
!
!!! wait for the computation of ZFLX(:,:,IKB-1) and ZFLX(:,:,IKB)
!$acc wait(2) async(3)
@@ -1297,7 +1311,9 @@ END IF
!!! et un dernier wait pour etre sur
!$acc wait
!
+#ifndef MNH_OPENACC
CALL CLEANLIST_ll(TZFIELDS_ll)
+#endif
if ( mppdb_initialized ) then
!Check all inout arrays
diff --git a/src/MNH/update_lm.f90 b/src/MNH/update_lm.f90
index 2c06c9cc5..09c3fbb00 100644
--- a/src/MNH/update_lm.f90
+++ b/src/MNH/update_lm.f90
@@ -130,28 +130,36 @@ GNORTH = ( HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() )
!* 3. UPDATE EXTERNAL POINTS OF GLOBAL DOMAIN:
! ---------------------------------------
!
-!$acc kernels
+
IF ( GWEST ) THEN
+ !$acc kernels async
PLM (IIB-1,:,:) = PLM (IIB,:,:)
PLEPS(IIB-1,:,:) = PLEPS(IIB,:,:)
+ !$acc end kernels
END IF
IF ( GEAST ) THEN
+ !$acc kernels async
PLM (IIE+1,:,:) = PLM (IIE,:,:)
PLEPS(IIE+1,:,:) = PLEPS(IIE,:,:)
+ !$acc end kernels
END IF
IF ( GSOUTH ) 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 ( GNORTH ) 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
+ END DO
+ !$acc end kernels
END IF
-!$acc end kernels
+!$acc wait
if ( mppdb_initialized ) then
!Check all inout arrays
diff --git a/src/ZSOLVER/advection_metsv.f90 b/src/ZSOLVER/advection_metsv.f90
deleted file mode 100644
index 410aece0a..000000000
--- a/src/ZSOLVER/advection_metsv.f90
+++ /dev/null
@@ -1,1142 +0,0 @@
-!MNH_LIC Copyright 1994-2022 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_METSV
-! ###########################
-!
-INTERFACE
- SUBROUTINE ADVECTION_METSV (TPFILE, HUVW_ADV_SCHEME, &
- HMET_ADV_SCHEME,HSV_ADV_SCHEME, HCLOUD, KSPLIT, &
- OSPLIT_CFL, PSPLIT_CFL, OCFL_WRIT, &
- HLBCX, HLBCY, KRR, KSV, TPDTCUR, PTSTEP, &
- PUT, PVT, PWT, PTHT, PRT, PTKET, PSVT, PPABST, &
- PTHVREF, PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, &
- PRTHS, PRRS, PRTKES, PRSVS, &
- PRTHS_CLD, PRRS_CLD, PRSVS_CLD, PRTKES_ADV )
-!
-USE MODD_IO, ONLY: TFILEDATA
-USE MODD_TYPE_DATE, ONLY: DATE_TIME
-!
-TYPE(TFILEDATA), INTENT(INOUT):: TPFILE ! Output file
-CHARACTER(LEN=6), INTENT(IN) :: HMET_ADV_SCHEME, & ! Control of the
- HSV_ADV_SCHEME, & ! scheme applied
- HUVW_ADV_SCHEME
-CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of cloud parameterization
-!
-INTEGER, INTENT(INOUT):: KSPLIT ! Number of time splitting
- ! for PPM advection
-LOGICAL, INTENT(IN) :: OSPLIT_CFL ! flag to automatically chose number of iterations
-REAL, INTENT(IN) :: PSPLIT_CFL ! maximum CFL to automatically chose number of iterations
-LOGICAL, INTENT(IN) :: OCFL_WRIT ! flag to write CFL fields in output files
-!
-CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
-!
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-INTEGER, INTENT(IN) :: KSV ! Number of Scalar Variables
-!
-TYPE (DATE_TIME), INTENT(IN) :: TPDTCUR ! current date and time
-REAL, INTENT(IN) :: PTSTEP
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT , PVT , PWT
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT, PTKET, PRHODJ
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT , PSVT
- ! Variables at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
- ! of the reference state
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZX,PDZY
- ! metric coefficients
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRTHS, PRTKES
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRRS , PRSVS
- ! Sources terms
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRTHS_CLD
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRRS_CLD,PRSVS_CLD
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRTKES_ADV ! Advection TKE source term
-!
-END SUBROUTINE ADVECTION_METSV
-!
-END INTERFACE
-!
-END MODULE MODI_ADVECTION_METSV
-! ##########################################################################
- SUBROUTINE ADVECTION_METSV (TPFILE, HUVW_ADV_SCHEME, &
- HMET_ADV_SCHEME,HSV_ADV_SCHEME, HCLOUD, KSPLIT, &
- OSPLIT_CFL, PSPLIT_CFL, OCFL_WRIT, &
- HLBCX, HLBCY, KRR, KSV, TPDTCUR, PTSTEP, &
- PUT, PVT, PWT, PTHT, PRT, PTKET, PSVT, PPABST, &
- PTHVREF, PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, &
- PRTHS, PRRS, PRTKES, PRSVS, &
- PRTHS_CLD, PRRS_CLD, PRSVS_CLD, PRTKES_ADV )
-! ##########################################################################
-!
-!!**** *ADVECTION_METSV * - routine to call the specialized advection routines
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to control the advection routines.
-!! For that, it is first necessary to compute the metric coefficients
-!! and the contravariant components of the momentum.
-!!
-!!** METHOD
-!! ------
-!! Once the scheme is selected, it is applied to the following group of
-!! variables: METeorologicals (temperature, water substances, TKE,
-!! dissipation TKE) and Scalar Variables. It is possible to select different
-!! advection schemes for each group of variables.
-!!
-!! EXTERNAL
-!! --------
-!! CONTRAV : computes the contravariant components.
-!! ADVECUVW : computes the advection terms for momentum.
-!! ADVECSCALAR : computes the advection terms for scalar fields.
-!! ADD3DFIELD_ll : add a field to 3D-list
-!! ADVEC_4TH_ORDER : 4th order advection scheme
-!!
-!! 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 add time splitting
-!! 04/2014 (C.Lac) adaptation of time
-!! splitting for L1D and L2D
-!! 09/2014 (G.Delautier) close OUTPUT_LISTING before STOP
-!! 04/2015 (J.Escobar) remove/commente some NHALO=1 test
-!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
-!! J.Escobar : 01/10/2015 : add computation of CFL for L1D case
-!! 04/2016 (C.Lac) : correction of negativity for KHKO
-!! 10/2016 (C.Lac) Correction on the flag for Strang splitting
-!! to insure reproducibility between START and RESTA
-! V. Vionnet 07/2017: add advection of 2D variables at the surface for the blowing snow scheme
-! P. Wautelet 05/2016-04/2018: new data structures and calls for I/O
-! P. Wautelet 02/2020: use the new data structures and subroutines for budgets
-! B. Vie 03/2020: LIMA negativity checks after turbulence, advection and microphysics budgets
-! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
-! P. Wautelet 11/06/2020: bugfix: correct PRSVS array indices
-! P. Wautelet + Benoît Vié 06/2020: improve removal of negative scalar variables + adapt the corresponding budgets
-! P. Wautelet 30/06/2020: move removal of negative scalar variables to Sources_neg_correct
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-#ifdef MNH_OPENACC
-USE MODD_MPIF
-use modd_precision, only: MNHREAL_MPI
-USE MODD_VAR_ll, ONLY: NMNH_COMM_WORLD
-#endif
-USE MODD_BLOWSNOW
-USE MODD_BLOWSNOW_n
-use modd_budget, only: lbudget_th, lbudget_tke, lbudget_rv, lbudget_rc, &
- lbudget_rr, lbudget_ri, lbudget_rs, lbudget_rg, lbudget_rh, lbudget_sv, &
- NBUDGET_TH, NBUDGET_TKE, NBUDGET_RV, NBUDGET_RC, &
- NBUDGET_RR, NBUDGET_RI, NBUDGET_RS, NBUDGET_RG, NBUDGET_RH, NBUDGET_SV1, &
- tbudgets
-USE MODD_CONF, ONLY: LNEUTRAL,NHALO,L1D, L2D
-USE MODD_CST
-USE MODD_CTURB, ONLY: XTKEMIN
-use modd_field, only: tfielddata, TYPEREAL
-USE MODD_IBM_PARAM_n, ONLY: LIBM,XIBM_LS,XIBM_EPSI
-USE MODD_IO, ONLY: TFILEDATA
-USE MODD_LUNIT_n, ONLY: TLUOUT
-USE MODD_NSV
-USE MODD_PARAMETERS
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_n
-USE MODD_REF_n, ONLY: XRHODJ,XRHODREF
-USE MODD_TYPE_DATE, ONLY: DATE_TIME
-!
-use mode_argslist_ll, only: ADD3DFIELD_ll, ADD4DFIELD_ll, CLEANLIST_ll, LIST_ll
-use mode_budget, only: Budget_store_init, Budget_store_end
-#ifdef MNH_OPENACC
-USE MODE_DEVICE
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-use mode_exchange_ll, only: UPDATE_HALO_ll
-USE MODE_IO_FIELD_WRITE, only: IO_Field_write
-use mode_mppdb
-USE MODE_MSG
-use mode_sources_neg_correct, only: Sources_neg_correct
-#ifndef MNH_OPENACC
-use mode_sum_ll, only: MAX_ll
-#endif
-use mode_tools_ll, only: GET_INDICE_ll, lnorth_ll, lsouth_ll, least_ll, lwest_ll
-!
-USE MODI_ADV_BOUNDARIES
-#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
-USE MODI_BITREP
-#endif
-#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
-! mnh_undef(LOOP)
-! mnh_undef(OPENACC)
-#endif
-
-USE MODI_CONTRAV
-USE MODI_GET_HALO
-USE MODI_PPM_RHODJ
-USE MODI_PPM_MET
-USE MODI_PPM_SCALAR
-!
-!-------------------------------------------------------------------------------
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-TYPE(TFILEDATA), INTENT(INOUT):: TPFILE ! Output file
-CHARACTER(LEN=6), INTENT(IN) :: HMET_ADV_SCHEME, & ! Control of the
- HSV_ADV_SCHEME, & ! scheme applied
- HUVW_ADV_SCHEME
-CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of cloud parameterization
-!
-INTEGER, INTENT(INOUT):: KSPLIT ! Number of time splitting
- ! for PPM advection
-LOGICAL, INTENT(IN) :: OSPLIT_CFL ! flag to automatically chose number of iterations
-REAL, INTENT(IN) :: PSPLIT_CFL ! maximum CFL to automatically chose number of iterations
-LOGICAL, INTENT(IN) :: OCFL_WRIT ! flag to write CFL fields in output files
-!
-CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC
-!
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-INTEGER, INTENT(IN) :: KSV ! Number of Scalar Variables
-!
-TYPE (DATE_TIME), INTENT(IN) :: TPDTCUR ! current date and time
-REAL, INTENT(IN) :: PTSTEP
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT , PVT , PWT
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT, PTKET, PRHODJ
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT , PSVT
- ! Variables at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
- ! of the reference state
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZX,PDZY
- ! metric coefficients
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRTHS, PRTKES
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRRS , PRSVS
- ! Sources terms
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRTHS_CLD
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRRS_CLD, PRSVS_CLD
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRTKES_ADV ! Advection TKE source term
-!
-!
-!* 0.2 declarations of local variables
-!
-!
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRUCPPM
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRVCPPM
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRWCPPM
- ! contravariant
- ! components
- ! of momentum
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFLU
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFLV
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFLW
-! ! CFL numbers on each direction
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFL
-! ! CFL number
-REAL :: ZCFLU_MAX, ZCFLV_MAX, ZCFLW_MAX, ZCFL_MAX ! maximum CFL numbers
-!
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZTH
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZTKE
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTHS_OTHER
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTKES_OTHER
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTHS_PPM
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTKES_PPM
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZR
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZSV
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZSNWC
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZSNWC_INIT
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSNWCS
-! Guess at the sub time step
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRRS_OTHER
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSVS_OTHER
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSNWCS_OTHER
-! Tendencies since the beginning of the time step
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRRS_PPM
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSVS_PPM
-REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSNWCS_PPM
-! Guess at the end of the sub time step
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRHOX1,ZRHOX2
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRHOY1,ZRHOY2
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRHOZ1,ZRHOZ2
-REAL, DIMENSION(:,:,:),pointer , contiguous :: ZT,ZEXN,ZLV,ZLS,ZCPH
-
-! Temporary advected rhodj for PPM routines
-!
-INTEGER :: JS,JR,JSV,JSPL, JI, JJ ! Loop index
-REAL :: ZTSTEP_PPM ! Sub Time step
-LOGICAL :: GTKE
-!
-INTEGER :: IINFO_ll ! return code of parallel routine
-TYPE(LIST_ll), POINTER :: TZFIELDS0_ll ! list of fields to exchange
-TYPE(LIST_ll), POINTER :: TZFIELDS1_ll ! list of fields to exchange
-!
-!
-INTEGER :: IRESP ! Return code of FM routines
-INTEGER :: ILUOUT ! logical unit
-INTEGER :: ISPLIT_PPM ! temporal time splitting
-INTEGER :: IIB, IIE, IJB, IJE,IKB,IKE
-#ifdef MNH_OPENACC
-CHARACTER(LEN=3) :: YNUM
-#endif
-TYPE(TFIELDDATA) :: TZFIELD
-!
-INTEGER :: JIU,JJU,JKU
-INTEGER :: JK
-REAL :: ZIBM_EPSI !Intermediate variable used to work around a Cray compiler bug (CCE 13.0.0)
-!-------------------------------------------------------------------------------
-!$acc data present( PUT, PVT, PWT, PTHT, PTKET, PRHODJ, PPABST, PRT, PSVT, PTHVREF, &
-!$acc & PDXX, PDYY, PDZZ, PDZX, PDZY, PRTHS, PRTKES, PRRS, PRSVS, PRTHS_CLD, PRRS_CLD, PRSVS_CLD, PRTKES_ADV )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PUT,"ADVECTION_METSV beg:PUT")
- CALL MPPDB_CHECK(PVT,"ADVECTION_METSV beg:PVT")
- CALL MPPDB_CHECK(PWT,"ADVECTION_METSV beg:PWT")
- CALL MPPDB_CHECK(PTHT,"ADVECTION_METSV beg:PTHT")
- CALL MPPDB_CHECK(PTKET,"ADVECTION_METSV beg:PTKET")
- CALL MPPDB_CHECK(PRHODJ,"ADVECTION_METSV beg:PRHODJ")
- CALL MPPDB_CHECK(PPABST,"ADVECTION_METSV beg:PPABST")
- CALL MPPDB_CHECK(PRT,"ADVECTION_METSV beg:PRT")
- CALL MPPDB_CHECK(PSVT,"ADVECTION_METSV beg:PSVT")
- CALL MPPDB_CHECK(PTHVREF,"ADVECTION_METSV beg:PTHVREF")
- CALL MPPDB_CHECK(PDXX,"ADVECTION_METSV beg:PDXX")
- CALL MPPDB_CHECK(PDYY,"ADVECTION_METSV beg:PDYY")
- CALL MPPDB_CHECK(PDZZ,"ADVECTION_METSV beg:PDZZ")
- CALL MPPDB_CHECK(PDZX,"ADVECTION_METSV beg:PDZX")
- CALL MPPDB_CHECK(PDZY,"ADVECTION_METSV beg:PDZY")
- CALL MPPDB_CHECK(PRTHS_CLD,"ADVECTION_METSV beg:PRTHS_CLD")
- CALL MPPDB_CHECK(PRRS_CLD,"ADVECTION_METSV beg:PRRS_CLD")
- CALL MPPDB_CHECK(PRSVS_CLD,"ADVECTION_METSV beg:PRSVS_CLD")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PRTHS,"ADVECTION_METSV beg:PRTHS")
- CALL MPPDB_CHECK(PRTKES,"ADVECTION_METSV beg:PRTKES")
- CALL MPPDB_CHECK(PRRS,"ADVECTION_METSV beg:PRRS")
- CALL MPPDB_CHECK(PRSVS,"ADVECTION_METSV beg:PRSVS")
-END IF
-
-JIU = size(PUT, 1 )
-JJU = size(PUT, 2 )
-JKU = size(PUT, 3 )
-
-
-#ifndef MNH_OPENACC
-allocate( ZRUCPPM ( JIU,JJU,JKU ) )
-allocate( ZRVCPPM ( JIU,JJU,JKU ) )
-allocate( ZRWCPPM ( JIU,JJU,JKU ) )
-allocate( ZCFLU ( JIU,JJU,JKU ) )
-allocate( ZCFLV ( JIU,JJU,JKU ) )
-allocate( ZCFLW ( JIU,JJU,JKU ) )
-allocate( ZCFL ( JIU,JJU,JKU ) )
-allocate( ZTH ( JIU,JJU,JKU ) )
-allocate( ZTKE ( JIU,JJU,SIZE(PTKET,3)) )
-allocate( ZRTHS_OTHER ( JIU,JJU,JKU ) )
-allocate( ZRTKES_OTHER ( JIU,JJU,SIZE(PTKET,3)) )
-allocate( ZRTHS_PPM ( JIU,JJU,JKU ) )
-allocate( ZRTKES_PPM ( JIU,JJU,SIZE(PTKET,3)) )
-allocate( ZR ( JIU,JJU,JKU, SIZE(PRT, 4) ) )
-allocate( ZSV ( JIU,JJU,JKU, SIZE(PSVT,4) ) )
-allocate( ZSNWC ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
-allocate( ZSNWC_INIT ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
-allocate( ZRSNWCS ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
-allocate( ZRRS_OTHER ( JIU,JJU,JKU, SIZE(PRT, 4) ) )
-allocate( ZRSVS_OTHER ( JIU,JJU,JKU, SIZE(PSVT,4) ) )
-allocate( ZRSNWCS_OTHER( JIU,JJU,JKU, NBLOWSNOW_2D ) )
-allocate( ZRRS_PPM ( JIU,JJU,JKU, SIZE(PRT, 4) ) )
-allocate( ZRSVS_PPM ( JIU,JJU,JKU, SIZE(PSVT,4) ) )
-allocate( ZRSNWCS_PPM ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
-allocate( ZRHOX1 ( JIU,JJU,JKU ) )
-allocate( ZRHOX2 ( JIU,JJU,JKU ) )
-allocate( ZRHOY1 ( JIU,JJU,JKU ) )
-allocate( ZRHOY2 ( JIU,JJU,JKU ) )
-allocate( ZRHOZ1 ( JIU,JJU,JKU ) )
-allocate( ZRHOZ2 ( JIU,JJU,JKU ) )
-allocate( ZT ( JIU,JJU,JKU ) )
-allocate( ZEXN ( JIU,JJU,JKU ) )
-allocate( ZLV ( JIU,JJU,JKU ) )
-allocate( ZLS ( JIU,JJU,JKU ) )
-allocate( ZCPH ( JIU,JJU,JKU ) )
-#else
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN()
-
-CALL MNH_MEM_GET( ZRUCPPM , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRVCPPM , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRWCPPM , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZCFLU , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZCFLV , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZCFLW , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZCFL , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZTH , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZTKE , JIU, JJU, SIZE(PTKET,3) )
-CALL MNH_MEM_GET( ZRTHS_OTHER , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRTKES_OTHER , JIU, JJU, SIZE(PTKET,3) )
-CALL MNH_MEM_GET( ZRTHS_PPM , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRTKES_PPM , JIU, JJU, SIZE(PTKET,3) )
-CALL MNH_MEM_GET( ZR , JIU, JJU, JKU, SIZE(PRT, 4) )
-CALL MNH_MEM_GET( ZSV , JIU, JJU, JKU, SIZE(PSVT,4) )
-CALL MNH_MEM_GET( ZSNWC , JIU, JJU, JKU, NBLOWSNOW_2D )
-CALL MNH_MEM_GET( ZSNWC_INIT , JIU, JJU, JKU, NBLOWSNOW_2D )
-CALL MNH_MEM_GET( ZRSNWCS , JIU, JJU, JKU, NBLOWSNOW_2D )
-CALL MNH_MEM_GET( ZRRS_OTHER , JIU, JJU, JKU, SIZE(PRT, 4) )
-CALL MNH_MEM_GET( ZRSVS_OTHER , JIU, JJU, JKU, SIZE(PSVT,4) )
-CALL MNH_MEM_GET( ZRSNWCS_OTHER, JIU, JJU, JKU, NBLOWSNOW_2D )
-CALL MNH_MEM_GET( ZRRS_PPM , JIU, JJU, JKU, SIZE(PRT, 4) )
-CALL MNH_MEM_GET( ZRSVS_PPM , JIU, JJU, JKU, SIZE(PSVT,4) )
-CALL MNH_MEM_GET( ZRSNWCS_PPM , JIU, JJU, JKU, NBLOWSNOW_2D )
-CALL MNH_MEM_GET( ZRHOX1 , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRHOX2 , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRHOY1 , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRHOY2 , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRHOZ1 , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZRHOZ2 , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZT , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZEXN , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZLV , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZLS , JIU, JJU, JKU )
-CALL MNH_MEM_GET( ZCPH , JIU, JJU, JKU )
-#endif
-
-!$acc data present( ZRUCPPM, ZRVCPPM, ZRWCPPM, ZCFLU, ZCFLV, ZCFLW, ZCFL, ZTH, &
-!$acc & ZTKE, ZRTHS_OTHER, ZRTKES_OTHER, ZRTHS_PPM, ZRTKES_PPM, &
-!$acc & ZR, ZSV, ZSNWC, ZSNWC_INIT, ZRSNWCS, ZRRS_OTHER, ZRSVS_OTHER, ZRSNWCS_OTHER, &
-!$acc & ZRRS_PPM, ZRSVS_PPM, ZRSNWCS_PPM, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
-!$acc & ZT, ZEXN, ZLV, ZLS, ZCPH )
-
-!
-!* 0. INITIALIZATION
-! --------------
-
-GTKE=(SIZE(PTKET)/=0)
-
-if ( lbudget_th ) call Budget_store_init( tbudgets(NBUDGET_TH ), 'ADV', prths (:, :, :) )
-if ( lbudget_tke ) call Budget_store_init( tbudgets(NBUDGET_TKE), 'ADV', prtkes(:, :, :) )
-if ( lbudget_rv ) call Budget_store_init( tbudgets(NBUDGET_RV ), 'ADV', prrs (:, :, :, 1) )
-if ( lbudget_rc ) call Budget_store_init( tbudgets(NBUDGET_RC ), 'ADV', prrs (:, :, :, 2) )
-if ( lbudget_rr ) call Budget_store_init( tbudgets(NBUDGET_RR ), 'ADV', prrs (:, :, :, 3) )
-if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI ), 'ADV', prrs (:, :, :, 4) )
-if ( lbudget_rs ) call Budget_store_init( tbudgets(NBUDGET_RS ), 'ADV', prrs (:, :, :, 5) )
-if ( lbudget_rg ) call Budget_store_init( tbudgets(NBUDGET_RG ), 'ADV', prrs (:, :, :, 6) )
-if ( lbudget_rh ) call Budget_store_init( tbudgets(NBUDGET_RH ), 'ADV', prrs (:, :, :, 7) )
-if ( lbudget_sv) then
- do jsv = 1, ksv
- call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + jsv ), 'ADV', prsvs(:, :, :, jsv) )
- end do
-end if
-
-ILUOUT = TLUOUT%NLU
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKB=1+JPVEXT
-IKE=SIZE(PSVT,3) - JPVEXT
-
-ZIBM_EPSI = XIBM_EPSI
-
-#ifdef MNH_OPENACC
-CALL INIT_ON_HOST_AND_DEVICE(PRTKES_ADV,PVALUE=-1e99,HNAME='ADVECTION_METSV::PRTKES_ADV')
-CALL INIT_ON_HOST_AND_DEVICE(ZRUCPPM,PVALUE=-1e90,HNAME='ADVECTION_METSV::ZRUCPPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZRVCPPM,PVALUE=-1e91,HNAME='ADVECTION_METSV::ZRVCPPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZRWCPPM,PVALUE=-1e92,HNAME='ADVECTION_METSV::ZRWCPPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZCFLU,PVALUE=-1e99,HNAME='ADVECTION_METSV::ZCFLU')
-CALL INIT_ON_HOST_AND_DEVICE(ZCFLV,PVALUE=-1e99,HNAME='ADVECTION_METSV::ZCFLV')
-CALL INIT_ON_HOST_AND_DEVICE(ZCFLW,PVALUE=-1e99,HNAME='ADVECTION_METSV::ZCFLW')
-CALL INIT_ON_HOST_AND_DEVICE(ZCFL, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZCFL')
-CALL INIT_ON_HOST_AND_DEVICE(ZTH, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZTH')
-CALL INIT_ON_HOST_AND_DEVICE(ZTKE, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZTKE')
-CALL INIT_ON_HOST_AND_DEVICE(ZRTHS_OTHER, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRTHS_OTHER')
-CALL INIT_ON_HOST_AND_DEVICE(ZRTKES_OTHER,PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRTKES_OTHER')
-CALL INIT_ON_HOST_AND_DEVICE(ZRTHS_PPM, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRTHS_PPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZRTKES_PPM, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRTKES_PPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZR, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZR')
-CALL INIT_ON_HOST_AND_DEVICE(ZSV, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZSV')
-CALL INIT_ON_HOST_AND_DEVICE(ZRRS_OTHER, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRRS_OTHER')
-CALL INIT_ON_HOST_AND_DEVICE(ZRSVS_OTHER, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRSVS_OTHER')
-CALL INIT_ON_HOST_AND_DEVICE(ZRRS_PPM, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRRS_PPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZRSVS_PPM, PVALUE=-1e99,HNAME='ADVECTION_METSV::ZRSVS_PPM')
-CALL INIT_ON_HOST_AND_DEVICE(ZRHOX1,PVALUE=-1e93,HNAME='ADVECTION_METSV::ZRHOX1')
-CALL INIT_ON_HOST_AND_DEVICE(ZRHOX2,PVALUE=-1e94,HNAME='ADVECTION_METSV::ZRHOX2')
-CALL INIT_ON_HOST_AND_DEVICE(ZRHOY1,PVALUE=-1e95,HNAME='ADVECTION_METSV::ZRHOY1')
-CALL INIT_ON_HOST_AND_DEVICE(ZRHOY2,PVALUE=-1e96,HNAME='ADVECTION_METSV::ZRHOY2')
-CALL INIT_ON_HOST_AND_DEVICE(ZRHOZ1,PVALUE=-1e97,HNAME='ADVECTION_METSV::ZRHOZ1')
-CALL INIT_ON_HOST_AND_DEVICE(ZRHOZ2,PVALUE=-1e98,HNAME='ADVECTION_METSV::ZRHOZ2')
-#endif
-!
-IF(LBLOWSNOW) THEN ! Put 2D Canopy blowing snow variables into a 3D array for advection
-#ifdef MNH_OPENACC
- call Print_msg( NVERB_ERROR, 'GEN', 'ADVECTION_METSV', 'OpenACC: LBLOWSNOW not yet implemented' )
-#endif
- ZSNWC_INIT(:,:,:,:) = 0.
- ZRSNWCS(:,:,:,:) = 0.
- !dir$ concurrent
- DO JSV=1,(NBLOWSNOW_2D)
- ZSNWC_INIT(:,:,IKB,JSV) = XSNWCANO(:,:,JSV)
- ZRSNWCS(:,:,IKB,JSV) = XRSNWCANOS(:,:,JSV)
- END DO
-ENDIF
-!
-!-------------------------------------------------------------------------------
-!
-!* 2. COMPUTES THE CONTRAVARIANT COMPONENTS (FOR PPM ONLY)
-! --------------------------------------
-!
-!* 2.1 computes contravariant components
-!
-!Update on host of ZRUCPPM,ZRVCPPM,ZRWCPPM is done in CONTRAV_DEVICE
-#ifndef MNH_OPENACC
-IF (HUVW_ADV_SCHEME=='CEN2ND' ) THEN
- CALL CONTRAV (HLBCX,HLBCY,PUT,PVT,PWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCPPM,ZRVCPPM,ZRWCPPM,2)
-ELSE
- CALL CONTRAV (HLBCX,HLBCY,PUT,PVT,PWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCPPM,ZRVCPPM,ZRWCPPM,4)
-END IF
-#else
-IF (HUVW_ADV_SCHEME=='CEN2ND' ) THEN
- CALL CONTRAV_DEVICE (HLBCX,HLBCY,PUT,PVT,PWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCPPM,ZRVCPPM,ZRWCPPM,2, &
- ODATA_ON_DEVICE=.TRUE.)
-ELSE
- CALL CONTRAV_DEVICE (HLBCX,HLBCY,PUT,PVT,PWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCPPM,ZRVCPPM,ZRWCPPM,4, &
- ODATA_ON_DEVICE=.TRUE.)
-END IF
-#endif
-!
-!
-!* 2.2 computes CFL numbers
-!
-!PW: not necessary: data already on device due to contrav_device !$acc update device(ZRUCPPM,ZRVCPPM,ZRWCPPM)
-! acc kernels
-IF (.NOT. L1D) THEN
- !$acc kernels present_cr(ZCFLU,ZCFLV,ZCFLW)
- ZCFLU(:,:,:) = 0.0 ; ZCFLV(:,:,:) = 0.0 ; ZCFLW(:,:,:) = 0.0
- ZCFLU(IIB:IIE,IJB:IJE,:) = ABS(ZRUCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
- ZCFLV(IIB:IIE,IJB:IJE,:) = ABS(ZRVCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
- ZCFLW(IIB:IIE,IJB:IJE,:) = ABS(ZRWCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
- !$acc end kernels
- IF (LIBM) THEN
- !$acc kernels
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-!$mnh_expand_array(JI=IIB:IIE,JJ=IJB:IJE,JK=1:JKU)
- ZCFLU(IIB:IIE,IJB:IJE,:) = ZCFLU(IIB:IIE,IJB:IJE,:)*(1.-exp(-(XIBM_LS(IIB:IIE,IJB:IJE,:,2)/&
- (XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:))**(1./3.))**2.))
- ZCFLV(IIB:IIE,IJB:IJE,:) = ZCFLV(IIB:IIE,IJB:IJE,:)*(1.-exp(-(XIBM_LS(IIB:IIE,IJB:IJE,:,3)/&
- (XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:))**(1./3.))**2.))
- ZCFLW(IIB:IIE,IJB:IJE,:) = ZCFLW(IIB:IIE,IJB:IJE,:)*(1.-exp(-(XIBM_LS(IIB:IIE,IJB:IJE,:,4)/&
- (XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:))**(1./3.))**2.))
-!$mnh_end_expand_array()
-#else
-#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
-DO CONCURRENT (JK=1:JKU,JJ=IJB:IJE,JI=IIB:IIE)
-#else
-!$mnh_expand_array(JI=IIB:IIE,JJ=IJB:IJE,JK=1:JKU)
-#endif
- ZCFLU(IIB:IIE,IJB:IJE,:) = ZCFLU(IIB:IIE,IJB:IJE,:)*(1.-Br_exp(-Br_pow(XIBM_LS(IIB:IIE,IJB:IJE,:,2)/&
- Br_pow(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:),1./3.),2.)))
- ZCFLV(IIB:IIE,IJB:IJE,:) = ZCFLV(IIB:IIE,IJB:IJE,:)*(1.-Br_exp(-Br_pow(XIBM_LS(IIB:IIE,IJB:IJE,:,3)/&
- Br_pow(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:),1./3.),2.)))
- ZCFLW(IIB:IIE,IJB:IJE,:) = ZCFLW(IIB:IIE,IJB:IJE,:)*(1.-Br_exp(-Br_pow(XIBM_LS(IIB:IIE,IJB:IJE,:,4)/&
- Br_pow(XRHODJ(IIB:IIE,IJB:IJE,:)/XRHODREF(IIB:IIE,IJB:IJE,:),1./3.),2.)))
-#if defined(MNH_COMPILER_CCE) && defined(MNH_BITREP_OMP)
-END DO ! CONCURRENT
-#else
-!$mnh_end_expand_array()
-#endif
-#endif
- WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,2).GT.(-ZIBM_EPSI)) ZCFLU(IIB:IIE,IJB:IJE,:)=0.
- WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,3).GT.(-ZIBM_EPSI)) ZCFLV(IIB:IIE,IJB:IJE,:)=0.
- WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,4).GT.(-ZIBM_EPSI)) ZCFLW(IIB:IIE,IJB:IJE,:)=0.
- !$acc end kernels
- ENDIF
-!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-#if !defined(MNH_BITREP)
- IF (.NOT. L2D) THEN
- !$acc kernels present_cr(ZCFL)
- ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLV(:,:,:)**2+ZCFLW(:,:,:)**2)
- !$acc end kernels
- ELSE
- !$acc kernels
- ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLW(:,:,:)**2)
- !$acc end kernels
- END IF
-#else
- IF (.NOT. L2D) THEN
- !$acc kernels
- !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLU(JI,JJ,JK))+BR_P2(ZCFLV(JI,JJ,JK))+BR_P2(ZCFLW(JI,JJ,JK)))
- !$mnh_end_do()
- !$acc end kernels
- ELSE
- !$acc kernels
- !$mnh_do_concurrent( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
- ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLU(JI,JJ,JK))+BR_P2(ZCFLW(JI,JJ,JK)))
- !$mnh_end_do()
- !$acc end kernels
- END IF
-#endif
-ELSE
- !$acc kernels
- ZCFLU(:,:,:) = 0.0 ; ZCFLV(:,:,:) = 0.0 ; ZCFLW(:,:,:) = 0.0
- ZCFLW(IIB:IIE,IJB:IJE,:) = ABS(ZRWCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
-!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-#if !defined(MNH_BITREP)
- ZCFL(:,:,:) = SQRT(ZCFLW(:,:,:)**2)
-#else
- !$mnh_do_concurrent(JI=1:JIU,JJ=1:JJU,JK=1:JKU )
- ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLW(JI,JJ,JK)))
- !$mnh_end_do()
-#endif
- !$acc end kernels
-END IF
-! acc end kernels
-!
-!* prints in the file the 3D Courant numbers (one should flag this)
-!
-IF ( tpfile%lopened .AND. OCFL_WRIT .AND. (.NOT. L1D) ) THEN
-!$acc update host(ZCFLU,ZCFLV,ZCFLW,ZCFL)
- TZFIELD%CMNHNAME = 'CFLU'
- TZFIELD%CSTDNAME = ''
- TZFIELD%CLONGNAME = 'CFLU'
- TZFIELD%CUNITS = '1'
- TZFIELD%CDIR = 'XY'
- TZFIELD%CCOMMENT = 'X_Y_Z_CFLU'
- TZFIELD%NGRID = 1
- TZFIELD%NTYPE = TYPEREAL
- TZFIELD%NDIMS = 3
- TZFIELD%LTIMEDEP = .TRUE.
- CALL IO_Field_write(TPFILE,TZFIELD,ZCFLU)
-!
- IF (.NOT. L2D) THEN
- TZFIELD%CMNHNAME = 'CFLV'
- TZFIELD%CSTDNAME = ''
- TZFIELD%CLONGNAME = 'CFLV'
- TZFIELD%CUNITS = '1'
- TZFIELD%CDIR = 'XY'
- TZFIELD%CCOMMENT = 'X_Y_Z_CFLV'
- TZFIELD%NGRID = 1
- TZFIELD%NTYPE = TYPEREAL
- TZFIELD%NDIMS = 3
- TZFIELD%LTIMEDEP = .TRUE.
- CALL IO_Field_write(TPFILE,TZFIELD,ZCFLV)
- END IF
-!
- TZFIELD%CMNHNAME = 'CFLW'
- TZFIELD%CSTDNAME = ''
- TZFIELD%CLONGNAME = 'CFLW'
- TZFIELD%CUNITS = '1'
- TZFIELD%CDIR = 'XY'
- TZFIELD%CCOMMENT = 'X_Y_Z_CFLW'
- TZFIELD%NGRID = 1
- TZFIELD%NTYPE = TYPEREAL
- TZFIELD%NDIMS = 3
- TZFIELD%LTIMEDEP = .TRUE.
- CALL IO_Field_write(TPFILE,TZFIELD,ZCFLW)
-!
- TZFIELD%CMNHNAME = 'CFL'
- TZFIELD%CSTDNAME = ''
- TZFIELD%CLONGNAME = 'CFL'
- TZFIELD%CUNITS = '1'
- TZFIELD%CDIR = 'XY'
- TZFIELD%CCOMMENT = 'X_Y_Z_CFL'
- TZFIELD%NGRID = 1
- TZFIELD%NTYPE = TYPEREAL
- TZFIELD%NDIMS = 3
- TZFIELD%LTIMEDEP = .TRUE.
- CALL IO_Field_write(TPFILE,TZFIELD,ZCFL)
-END IF
-!
-!* prints in the output file the maximum CFL
-!
-#ifndef MNH_OPENACC
-ZCFLU_MAX = MAX_ll(ZCFLU,IINFO_ll)
-ZCFLV_MAX = MAX_ll(ZCFLV,IINFO_ll)
-ZCFLW_MAX = MAX_ll(ZCFLW,IINFO_ll)
-ZCFL_MAX = MAX_ll(ZCFL,IINFO_ll)
-#else
-!
-#ifndef MNH_COMPILER_NVHPC
-!$acc kernels
-ZCFLU_MAX = MAXVAL(ZCFLU(IIB:IIE,IJB:IJE,IKB:IKE))
-ZCFLV_MAX = MAXVAL(ZCFLV(IIB:IIE,IJB:IJE,IKB:IKE))
-ZCFLW_MAX = MAXVAL(ZCFLW(IIB:IIE,IJB:IJE,IKB:IKE))
-ZCFL_MAX = MAXVAL(ZCFL (IIB:IIE,IJB:IJE,IKB:IKE))
-!$acc end kernels
-#else
-ZCFLU_MAX = 0.0 ; ZCFLV_MAX = 0.0 ; ZCFLW_MAX = 0.0 ; ZCFL_MAX = 0.0
-!$acc parallel reduction(max:ZCFLU_MAX,ZCFLV_MAX,ZCFLW_MAX,ZCFL_MAX)
-!$mnh_do_concurrent(JI=IIB:IIE,JJ=IJB:IJE,JK=IKB:IKE)
- ZCFLU_MAX = MAX(ZCFLU_MAX,ZCFLU(JI,JJ,JK))
- ZCFLV_MAX = MAX(ZCFLV_MAX,ZCFLV(JI,JJ,JK))
- ZCFLW_MAX = MAX(ZCFLW_MAX,ZCFLW(JI,JJ,JK))
- ZCFL_MAX = MAX(ZCFL_MAX,ZCFL (JI,JJ,JK))
-!$mnh_end_do()
-!$acc end parallel
-#endif
-!
-CALL MPI_ALLREDUCE(MPI_IN_PLACE,ZCFLU_MAX,1,MNHREAL_MPI,MPI_MAX,NMNH_COMM_WORLD,IINFO_ll)
-CALL MPI_ALLREDUCE(MPI_IN_PLACE,ZCFLV_MAX,1,MNHREAL_MPI,MPI_MAX,NMNH_COMM_WORLD,IINFO_ll)
-CALL MPI_ALLREDUCE(MPI_IN_PLACE,ZCFLW_MAX,1,MNHREAL_MPI,MPI_MAX,NMNH_COMM_WORLD,IINFO_ll)
-CALL MPI_ALLREDUCE(MPI_IN_PLACE,ZCFL_MAX,1,MNHREAL_MPI,MPI_MAX,NMNH_COMM_WORLD,IINFO_ll)
-#endif
-!
-WRITE(ILUOUT,FMT='(A24,F10.2,A5,F10.2,A5,F10.2,A9,F10.2)') &
- 'Max. CFL number for U : ',ZCFLU_MAX, &
- ' V : ',ZCFLV_MAX,' W : ', ZCFLW_MAX,&
- 'global : ',ZCFL_MAX
-!
-!
-!* 2.3 updates time step splitting loop
-!
-IF (OSPLIT_CFL .AND. (.NOT.L1D) ) THEN
-!
- ISPLIT_PPM = INT(ZCFL_MAX/PSPLIT_CFL)+1
- IF ( KSPLIT /= ISPLIT_PPM ) &
- WRITE(ILUOUT,FMT='(A37,I2,A4,I2,A11)') &
- 'PPM time spliting loop changed from ', &
- KSPLIT,' to ',ISPLIT_PPM, ' iterations'
-!
- KSPLIT = ISPLIT_PPM
-!
-END IF
-! ---------------------------------------------------------------
-IF (( (ZCFLU_MAX>=3.) .AND. (.NOT.L1D) ) .OR. &
- ( (ZCFLV_MAX>=3.) .AND. (.NOT.L1D) .AND. (.NOT.L2D) ) .OR. &
- ( (ZCFLW_MAX>=8.) .AND. (.NOT.L1D) ) ) THEN
- WRITE(ILUOUT,*) ' '
- WRITE(ILUOUT,*) ' +---------------------------------------------------+'
- WRITE(ILUOUT,*) ' | MODEL ERROR |'
- WRITE(ILUOUT,*) ' +---------------------------------------------------+'
- WRITE(ILUOUT,*) ' | |'
- WRITE(ILUOUT,*) ' | The model wind speed becomes too high |'
- WRITE(ILUOUT,*) ' | |'
- IF ( ZCFLU_MAX>=3. .OR. ZCFLV_MAX>=3. ) &
- WRITE(ILUOUT,*) ' | The horizontal CFL value reaches 3. or more |'
- IF ( ZCFLW_MAX>=8. ) &
- WRITE(ILUOUT,*) ' | The vertical CFL value reaches 8. or more |'
- WRITE(ILUOUT,*) ' | |'
- WRITE(ILUOUT,*) ' | This can be due either to : |'
- WRITE(ILUOUT,*) ' | - a numerical explosion of the model |'
- WRITE(ILUOUT,*) ' | - or a too high wind speed for an |'
- WRITE(ILUOUT,*) ' | acceptable accuracy of the advection |'
- WRITE(ILUOUT,*) ' | |'
- WRITE(ILUOUT,*) ' | Please decrease your time-step |'
- WRITE(ILUOUT,*) ' | |'
- WRITE(ILUOUT,*) ' +---------------------------------------------------+'
- WRITE(ILUOUT,*) ' '
- WRITE(ILUOUT,*) ' +---------------------------------------------------+'
- WRITE(ILUOUT,*) ' | MODEL STOPS |'
- WRITE(ILUOUT,*) ' +---------------------------------------------------+'
- CALL PRINT_MSG(NVERB_FATAL,'GEN','ADVECTION_METSV','')
-END IF
-!
-!
-ZTSTEP_PPM = PTSTEP / REAL(KSPLIT)
-!
-!
-!* 2.4 normalized contravariant components for split PPM time-step
-!
-!$acc kernels
-ZRUCPPM(:,:,:) = ZRUCPPM(:,:,:)*ZTSTEP_PPM
-ZRVCPPM(:,:,:) = ZRVCPPM(:,:,:)*ZTSTEP_PPM
-ZRWCPPM(:,:,:) = ZRWCPPM(:,:,:)*ZTSTEP_PPM
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3. COMPUTES THE TENDENCIES SINCE THE BEGINNING OF THE TIME STEP
-! ------------------------------------------------------------
-!
-!* This represent the effects of all OTHER processes
-! Clouds related processes from previous time-step are taken into account in PRTHS_CLD
-! Advection related processes from previous time-step will be taken into account in ZRTHS_PPM
-!
-!dir$ concurrent
-ZRTHS_OTHER(:,:,:) = PRTHS(:,:,:) - PTHT(:,:,:) * PRHODJ(:,:,:) / PTSTEP
-!dir$ concurrent
-IF (GTKE) THEN
- ZRTKES_OTHER(:,:,:) = PRTKES(:,:,:) - PTKET(:,:,:) * PRHODJ(:,:,:) / PTSTEP
-END IF
-DO JR = 1, KRR
- !dir$ concurrent
- ZRRS_OTHER(:,:,:,JR) = PRRS(:,:,:,JR) - PRT(:,:,:,JR) * PRHODJ(:,:,:) / PTSTEP
-END DO
-DO JSV = 1, KSV
- !dir$ concurrent
- ZRSVS_OTHER(:,:,:,JSV) = PRSVS(:,:,:,JSV) - PSVT(:,:,:,JSV) * PRHODJ / PTSTEP
-END DO
-!$acc end kernels
-IF(LBLOWSNOW) THEN
- DO JSV = 1, (NBLOWSNOW_2D)
- !dir$ concurrent
- ZRSNWCS_OTHER(:,:,:,JSV) = ZRSNWCS(:,:,:,JSV) - ZSNWC_INIT(:,:,:,JSV) * PRHODJ / PTSTEP
- END DO
-ENDIF
-!
-! Top and bottom Boundaries
-!
-#ifdef MNH_OPENACC
-CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRTHS_OTHER)
-IF (GTKE) CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRTKES_OTHER)
-DO JR = 1, KRR
- CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRRS_OTHER(:,:,:,JR))
-END DO
-DO JSV = 1, KSV
- CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRSVS_OTHER(:,:,:,JSV))
-END DO
-!Already done in ADV_BOUNDARIES_DEVICE !$acc update self(ZRTHS_OTHER,ZRTKES_OTHER,ZRRS_OTHER(:,:,:,1:KRR),ZRSVS_OTHER(:,:,:,1:KSV))
-#else
-CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRTHS_OTHER)
-IF (GTKE) CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRTKES_OTHER)
-DO JR = 1, KRR
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRRS_OTHER(:,:,:,JR))
-END DO
-DO JSV = 1, KSV
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRSVS_OTHER(:,:,:,JSV))
-END DO
-#endif
-IF(LBLOWSNOW) THEN
- DO JSV = 1, (NBLOWSNOW_2D)
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZRSNWCS_OTHER(:,:,:,JSV))
- END DO
-END IF
-!
-! Exchanges on processors
-!
-#ifndef MNH_OPENACC
-NULLIFY(TZFIELDS0_ll)
-!!$IF(NHALO == 1) THEN
- CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRTHS_OTHER, 'ADVECTION_METSV::ZRTHS_OTHER' )
- IF (GTKE) CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRTKES_OTHER, 'ADVECTION_METSV::ZRTKES_OTHER' )
- IF ( KRR>0 ) CALL ADD4DFIELD_ll( TZFIELDS0_ll, ZRRS_OTHER(:,:,:,1:KRR), 'ADVECTION_METSV::ZRRS_OTHER' )
- IF ( KSV>0 ) CALL ADD4DFIELD_ll( TZFIELDS0_ll, ZRSVS_OTHER(:,:,:,1:KSV), 'ADVECTION_METSV::ZRSVS_OTHER' )
- IF(LBLOWSNOW) CALL ADD4DFIELD_ll( TZFIELDS0_ll, ZRSNWCS_OTHER(:,:,:,1:NBLOWSNOW_2D), 'ADVECTION_METSV::ZRSNWCS_OTHER' )
- CALL UPDATE_HALO_ll(TZFIELDS0_ll,IINFO_ll)
- CALL CLEANLIST_ll(TZFIELDS0_ll)
-!!$END IF
-#else
- CALL GET_HALO_D(ZRTHS_OTHER, HNAME='ADVECTION_METSV::ZRTHS_OTHER')
- IF (GTKE) CALL GET_HALO_D(ZRTKES_OTHER,HNAME='ADVECTION_METSV::ZRTKES_OTHER')
- DO JR=1,KRR
- WRITE(YNUM, '( I3.3 )' ) JR
- CALL GET_HALO_D(ZRRS_OTHER(:,:,:,JR),HNAME='ADVECTION_METSV::ZRRS_OTHER:'//YNUM)
- END DO
- DO JSV = 1, KSV
- WRITE(YNUM, '( I3.3 )' ) JSV
- CALL GET_HALO_D(ZRSVS_OTHER(:,:,:,JSV),HNAME='ADVECTION_METSV::ZRSVS_OTHER:'//YNUM)
- END DO
- IF ( LBLOWSNOW ) THEN
- DO JSV = 1,NBLOWSNOW_2D
- WRITE(YNUM, '( I3.3 )' ) JSV
- CALL GET_HALO_D(ZRSNWCS_OTHER(:,:,:,JSV),HNAME='ADVECTION_METSV::ZRSNWCS_OTHER:'//YNUM)
- END DO
- END IF
- !PW: TODO: update only what is needed...
- ! acc update device(ZRTHS_OTHER,ZRTKES_OTHER,ZRRS_OTHER,ZRSVS_OTHER)
-#endif
-
-
-!
-!
-
-!-------------------------------------------------------------------------------
-!
-!* 4. CALLS THE PPM ADVECTION INSIDE A TIME SPLITTING
-! --------------------------------------
-!
-CALL PPM_RHODJ(HLBCX,HLBCY, ZRUCPPM, ZRVCPPM, ZRWCPPM, &
- ZTSTEP_PPM, PRHODJ, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, &
- ZRHOZ1, ZRHOZ2 )
-!
-!* values of the fields at the beginning of the time splitting loop
-!$acc kernels
-!dir$ concurrent
-ZTH(:,:,:) = PTHT(:,:,:)
-!dir concurrent
-IF (KRR /=0 ) THEN
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JR=1:KRR )
- ZR(:,:,:,:) = PRT(:,:,:,:)
- !$mnh_end_expand_array()
-END IF
-!dir concurrent
-IF (KSV /=0 ) THEN
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JSV=1:KSV)
- ZSV(:,:,:,:) = PSVT(:,:,:,:)
- !$mnh_end_expand_array()
-END IF
-!
-IF (GTKE) THEN
- PRTKES_ADV(:,:,:) = 0.
- ZTKE(:,:,:) = PTKET(:,:,:)
-END IF
-!$acc end kernels
-!
-IF(LBLOWSNOW) THEN
- DO JSV = 1, (NBLOWSNOW_2D)
- ZSNWC(:,:,:,JSV) = ZRSNWCS(:,:,:,JSV)* PTSTEP/ PRHODJ
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZSNWC(:,:,:,JSV))
- END DO
- ZSNWC_INIT(:,:,:,:)=ZSNWC(:,:,:,:)
-ENDIF
-!
-!* time splitting loop
-DO JSPL=1,KSPLIT
-!
- !ZRTHS_PPM(:,:,:) = 0.
- !ZRTKES_PPM(:,:,:) = 0.
- !IF (KRR /=0) ZRRS_PPM(:,:,:,:) = 0.
- !IF (KSV /=0) ZRSVS_PPM(:,:,:,:) = 0.
-!
- IF (LNEUTRAL) THEN
- !Must be done in a kernels region
-!$acc kernels
- ZTH(:,:,:)=ZTH(:,:,:)-PTHVREF(:,:,:) !* To be removed with the new PPM scheme ?
-!$acc end kernels
- END IF
- CALL PPM_MET (HLBCX,HLBCY, KRR, TPDTCUR, ZRUCPPM, ZRVCPPM, ZRWCPPM, PTSTEP,ZTSTEP_PPM, &
- PRHODJ, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
- ZTH, ZTKE, ZR, ZRTHS_PPM, ZRTKES_PPM, ZRRS_PPM, HMET_ADV_SCHEME)
- IF (LNEUTRAL) THEN
- !Must be done in a kernels region
-!$acc kernels
- ZTH(:,:,:) = ZTH(:,:,:) + PTHVREF(:,:,:) !* To be removed with the new PPM scheme ?
-!$acc end kernels
- END IF
-!
- CALL PPM_SCALAR (HLBCX,HLBCY, KSV, TPDTCUR, ZRUCPPM, ZRVCPPM, ZRWCPPM, PTSTEP, &
- ZTSTEP_PPM, PRHODJ, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
- ZSV, ZRSVS_PPM, HSV_ADV_SCHEME )
-!
-! Tendencies of PPM
-!
-! acc kernels
- !$acc kernels present_cr(PRTHS,ZRTHS_PPM)
- PRTHS(:,:,:) = PRTHS (:,:,:) + ZRTHS_PPM (:,:,:) / KSPLIT
- IF (GTKE) THEN
- PRTKES_ADV(:,:,:) = PRTKES_ADV(:,:,:) + ZRTKES_PPM(:,:,:) / KSPLIT
- END IF
- IF (KRR /=0) THEN
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JR=1:KRR)
- PRRS (:,:,:,:) = PRRS (:,:,:,:) + ZRRS_PPM (:,:,:,:) / KSPLIT
- !$mnh_end_expand_array()
- END IF
- IF (KSV /=0 ) THEN
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU,JSV=1:KSV)
- PRSVS (:,:,:,:) = PRSVS (:,:,:,:) + ZRSVS_PPM (:,:,:,:) / KSPLIT
- !$mnh_end_expand_array()
- END IF
- !$acc end kernels
-!
- IF (JSPL<KSPLIT) THEN
-!
-! Guesses of the field inside the time splitting loop
-!
- !$acc kernels present_cr(ZTH)
- ZTH(:,:,:) = ZTH(:,:,:) + ( ZRTHS_PPM(:,:,:) + ZRTHS_OTHER(:,:,:) + PRTHS_CLD(:,:,:)) * &
- ZTSTEP_PPM / PRHODJ(:,:,:)
- !$acc end kernels
- IF (GTKE) THEN
- !$acc kernels present_cr(ZTKE)
- ZTKE(:,:,:) = ZTKE(:,:,:) + ( ZRTKES_PPM(:,:,:) + ZRTKES_OTHER(:,:,:) ) * ZTSTEP_PPM / PRHODJ(:,:,:)
- !$acc end kernels
- END IF
- !$acc kernels
- !$mnh_do_concurrent( JI=1:JIU,JJ=1:JJU,JK=1:JKU, JR=1:KRR )
- ZR(JI,JJ,JK,JR) = ZR(JI,JJ,JK,JR) + ( ZRRS_PPM(JI,JJ,JK,JR) + ZRRS_OTHER(JI,JJ,JK,JR) + PRRS_CLD(JI,JJ,JK,JR) ) &
- * ZTSTEP_PPM / PRHODJ(JI,JJ,JK)
- !$mnh_end_do() !CONCURRENT
- !$acc loop seq
- DO JSV = 1, KSV
- !$mnh_do_concurrent ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZSV(JI,JJ,JK,JSV) = ZSV(JI,JJ,JK,JSV) + ( ZRSVS_PPM(JI,JJ,JK,JSV) + ZRSVS_OTHER(JI,JJ,JK,JSV) + &
- PRSVS_CLD(JI,JJ,JK,JSV) ) * ZTSTEP_PPM / PRHODJ(JI,JJ,JK)
- !$mnh_end_do() !CONCURRENT
- END DO
- !$acc end kernels
- END IF
-! acc end kernels
-!
-! Top and bottom Boundaries and LBC for the guesses
-!
- IF (JSPL<KSPLIT) THEN
-#ifndef MNH_OPENACC
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZTH, PTHT )
- IF (GTKE) CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZTKE, PTKET)
- DO JR = 1, KRR
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZR(:,:,:,JR), PRT(:,:,:,JR))
- END DO
- DO JSV = 1, KSV
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZSV(:,:,:,JSV), PSVT(:,:,:,JSV))
- END DO
-#else
- CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZTH, PTHT )
- IF (GTKE) CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZTKE, PTKET)
- DO JR = 1, KRR
- CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZR(:,:,:,JR), PRT(:,:,:,JR))
- END DO
- DO JSV = 1, KSV
- CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZSV(:,:,:,JSV), PSVT(:,:,:,JSV))
- END DO
-!Already done in ADV_BOUNDARIES_DEVICE !$acc update self(ZTH,ZTKE,ZR,ZSV)
-#endif
-
- IF(LBLOWSNOW) THEN ! Advection of Canopy mass at the 1st atmospheric level
- ZRSNWCS_PPM(:,:,:,:) = 0.
- !
-
- CALL PPM_SCALAR (HLBCX,HLBCY, NBLOWSNOW_2D, TPDTCUR, ZRUCPPM, ZRVCPPM, ZRWCPPM,PTSTEP, &
- ZTSTEP_PPM, PRHODJ, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
- ZSNWC, ZRSNWCS_PPM, HSV_ADV_SCHEME)
-
-
-! Tendencies of PPM
- ZRSNWCS(:,:,:,:) = ZRSNWCS(:,:,:,:) + ZRSNWCS_PPM (:,:,:,:) / KSPLIT
-! Guesses of the field inside the time splitting loop
- DO JSV = 1, ( NBLOWSNOW_2D)
- ZSNWC(:,:,:,JSV) = ZSNWC(:,:,:,JSV) + ZRSNWCS_PPM(:,:,:,JSV)*ZTSTEP_PPM/ PRHODJ(:,:,:)
- END DO
-
-! Top and bottom Boundaries and LBC for the guesses
- DO JSV = 1, (NBLOWSNOW_2D)
- CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZSNWC(:,:,:,JSV), ZSNWC_INIT(:,:,:,JSV))
- END DO
- END IF
-!
-! Exchanges fields between processors
-!
-#ifndef MNH_OPENACC
- NULLIFY(TZFIELDS1_ll)
-!!$ IF(NHALO == 1) THEN
- CALL ADD3DFIELD_ll( TZFIELDS1_ll, ZTH, 'ZTH' )
- IF (GTKE) CALL ADD3DFIELD_ll( TZFIELDS1_ll, ZTKE, 'ADVECTION_METSV::ZTKE' )
- IF ( KRR>0 ) CALL ADD4DFIELD_ll( TZFIELDS1_ll, ZR (:,:,:,1:KRR), 'ADVECTION_METSV::ZR' )
- IF ( KSV>0 ) CALL ADD4DFIELD_ll( TZFIELDS1_ll, ZSV(:,:,:,1:KSV), 'ADVECTION_METSV::ZSV' )
- IF ( LBLOWSNOW ) CALL ADD4DFIELD_ll( TZFIELDS1_ll, ZSNWC(:,:,:,1:NBLOWSNOW_2D), 'ADVECTION_METSV::ZSNWC' )
- CALL UPDATE_HALO_ll(TZFIELDS1_ll,IINFO_ll)
- CALL CLEANLIST_ll(TZFIELDS1_ll)
-!!$ END IF
-#else
- CALL GET_HALO_D(ZTH,HNAME='ZTH')
- IF (GTKE) CALL GET_HALO_D(ZTKE,HNAME='ADVECTION_METSV::ZTKE')
- DO JR=1,KRR
- CALL GET_HALO_D(ZR(:,:,:,JR),HNAME='ADVECTION_METSV::ZR')
- END DO
- DO JSV = 1, KSV
- CALL GET_HALO_D(ZSV(:,:,:,JSV),HNAME='ADVECTION_METSV::ZSV')
- END DO
- IF ( LBLOWSNOW ) THEN
- DO JSV = 1,NBLOWSNOW_2D
- CALL GET_HALO_D(ZSNWC(:,:,:,JSV),HNAME='ADVECTION_METSV::ZSNWC')
- END DO
- END IF
-#endif
-
- END IF
-!
-END DO
-!
-!-------------------------------------------------------------------------------
-!
-! TKE special case: advection is the last process for TKE
-!
-! TKE must be greater than its minimum value
-! (previously done in tke_eps_sources)
-!
-IF (GTKE) THEN
-!$acc kernels
- PRTKES(:,:,:) = PRTKES(:,:,:) + PRTKES_ADV(:,:,:)
- PRTKES(:,:,:) = MAX (PRTKES(:,:,:) , XTKEMIN * PRHODJ(:,:,:) / PTSTEP )
-!$acc end kernels
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-! Update tendency for cano variables : from 3D to 2D
-!
-IF(LBLOWSNOW) THEN
-
- DO JSV=1,(NBLOWSNOW_2D)
- DO JI=1,SIZE(PSVT,1)
- DO JJ=1,SIZE(PSVT,2)
- XRSNWCANOS(JI,JJ,JSV) = SUM(ZRSNWCS(JI,JJ,IKB:IKE,JSV))
- END DO
- END DO
- END DO
-IF(LWEST_ll()) XRSNWCANOS(IIB,:,:) = ZRSNWCS(IIB,:,IKB,:)
-IF(LEAST_ll()) XRSNWCANOS(IIE,:,:) = ZRSNWCS(IIE,:,IKB,:)
-IF(LSOUTH_ll()) XRSNWCANOS(:,IJB,:) = ZRSNWCS(:,IJB,IKB,:)
-IF(LNORTH_ll()) XRSNWCANOS(:,IJE,:) = ZRSNWCS(:,IJE,IKB,:)
-
-END IF
-!-------------------------------------------------------------------------------
-!
-!* 5. BUDGETS
-! -------
-!
-if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH ), 'ADV', prths (:, :, :) )
-if ( lbudget_tke ) call Budget_store_end( tbudgets(NBUDGET_TKE), 'ADV', prtkes(:, :, :) )
-if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV ), 'ADV', prrs (:, :, :, 1) )
-if ( lbudget_rc ) call Budget_store_end( tbudgets(NBUDGET_RC ), 'ADV', prrs (:, :, :, 2) )
-if ( lbudget_rr ) call Budget_store_end( tbudgets(NBUDGET_RR ), 'ADV', prrs (:, :, :, 3) )
-if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI ), 'ADV', prrs (:, :, :, 4) )
-if ( lbudget_rs ) call Budget_store_end( tbudgets(NBUDGET_RS ), 'ADV', prrs (:, :, :, 5) )
-if ( lbudget_rg ) call Budget_store_end( tbudgets(NBUDGET_RG ), 'ADV', prrs (:, :, :, 6) )
-if ( lbudget_rh ) call Budget_store_end( tbudgets(NBUDGET_RH ), 'ADV', prrs (:, :, :, 7) )
-if ( lbudget_sv) then
- do jsv = 1, ksv
- call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + jsv ), 'ADV', prsvs(:, :, :, jsv) )
- end do
-end if
-
-! Remove non-physical negative values (unnecessary in a perfect world) + corresponding budgets
-call Sources_neg_correct( hcloud, 'NEADV', krr, ptstep, ppabst, ptht, prt, prths, prrs, prsvs )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PRTHS,"ADVECTION_METSV end:PRTHS")
- CALL MPPDB_CHECK(PRTKES,"ADVECTION_METSV end:PRTKES")
- CALL MPPDB_CHECK(PRRS,"ADVECTION_METSV end:PRRS")
- CALL MPPDB_CHECK(PRSVS,"ADVECTION_METSV end:PRSVS")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PRTKES_ADV,"ADVECTION_METSV end:PRTKES_ADV")
-END IF
-
-!$acc end data
-
-#ifndef MNH_OPENACC
-deallocate ( ZRUCPPM, ZRVCPPM, ZRWCPPM, ZCFLU, ZCFLV, ZCFLW, ZCFL, ZTH, &
- ZTKE, ZRTHS_OTHER, ZRTKES_OTHER, ZRTHS_PPM, ZRTKES_PPM, &
- ZR, ZSV, ZSNWC, ZSNWC_INIT, ZRSNWCS, ZRRS_OTHER, ZRSVS_OTHER, ZRSNWCS_OTHER, &
- ZRRS_PPM, ZRSVS_PPM, ZRSNWCS_PPM, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
- ZT, ZEXN, ZLV, ZLS, ZCPH )
-#else
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE()
-#endif
-
-!$acc end data
-
-END SUBROUTINE ADVECTION_METSV
diff --git a/src/ZSOLVER/advection_uvw.f90 b/src/ZSOLVER/advection_uvw.f90
deleted file mode 100644
index 58ba42fe5..000000000
--- a/src/ZSOLVER/advection_uvw.f90
+++ /dev/null
@@ -1,513 +0,0 @@
-!MNH_LIC Copyright 1994-2022 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
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: 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
-! P. Wautelet 02/2020: use the new data structures and subroutines for budgets
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
-use modd_budget, only: lbudget_u, lbudget_v, lbudget_w, NBUDGET_U, NBUDGET_V, NBUDGET_W, tbudgets
-USE MODD_CONF, ONLY : NHALO
-USE MODD_PARAMETERS, ONLY : JPVEXT
-
-use mode_budget, only: Budget_store_init, Budget_store_end
-USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_DEVICE
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-use mode_mppdb
-
-USE MODI_ADV_BOUNDARIES
-USE MODI_ADVECUVW_RK
-USE MODI_CONTRAV
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_GET_HALO, ONLY: GET_HALO_D
-USE MODI_SHUMAN_DEVICE
-#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)
-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
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: 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
- ! cartesian
- ! components of
- ! momentum
-!
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRUCT
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRVCT
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRWCT
- ! contravariant
- ! components
- ! of momentum
-!
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZU, ZV, ZW
-! 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
-! 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
-!
-! 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
-!
-INTEGER :: IIU,IJU,IKU
-!
-INTEGER :: JI,JJ,JK
-!
-!-------------------------------------------------------------------------------
-!
-!* 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
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN()
-
-CALL MNH_MEM_GET( ZRUT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRVT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRWT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRUCT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRVCT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRWCT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZU, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZV, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZW, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRUS_OTHER, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRVS_OTHER, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRWS_OTHER, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRUS_ADV, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRVS_ADV, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRWS_ADV, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZMXM_RHODJ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZMYM_RHODJ, IIU, IJU, IKU )
-CALL MNH_MEM_GET( 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 )
-
-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
-
-if ( lbudget_u ) call Budget_store_init( tbudgets(NBUDGET_U), 'ADV', prus(:, :, :) )
-if ( lbudget_v ) call Budget_store_init( tbudgets(NBUDGET_V), 'ADV', prvs(:, :, :) )
-if ( lbudget_w ) call Budget_store_init( tbudgets(NBUDGET_W), 'ADV', prws(:, :, :) )
-
-!-------------------------------------------------------------------------------
-!
-!* 1. COMPUTES THE CONTRAVARIANT COMPONENTS
-! -------------------------------------
-!
-!$acc kernels present_cr(ZRUT,ZRVT,ZRWT)
-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,&
- 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 present_cr(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
-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 )
-!
-! Tendencies on wind
-! acc update device(ZRUS_ADV,ZRVS_ADV,ZRWS_ADV)
-!$acc kernels
-!$mnh_do_concurrent(JI=1:IIU,JJ=1:IJU,JK=1:IKU )
- PRUS(JI,JJ,JK) = PRUS(JI,JJ,JK) + ZRUS_ADV(JI,JJ,JK) / ISPLIT
- PRVS(JI,JJ,JK) = PRVS(JI,JJ,JK) + ZRVS_ADV(JI,JJ,JK) / ISPLIT
- PRWS(JI,JJ,JK) = PRWS(JI,JJ,JK) + ZRWS_ADV(JI,JJ,JK) / ISPLIT
-!$mnh_end_do()
- IF (JSPL<ISPLIT) THEN
-!
-! Guesses for next time splitting loop
-!
-!
-!$mnh_do_concurrent(JI=1:IIU,JJ=1:IJU,JK=1:IKU)
- ZU(JI,JJ,JK) = ZU(JI,JJ,JK) + ZTSTEP / ZMXM_RHODJ(JI,JJ,JK) * &
- (ZRUS_OTHER(JI,JJ,JK) + ZRUS_ADV(JI,JJ,JK))
- ZV(JI,JJ,JK) = ZV(JI,JJ,JK) + ZTSTEP / ZMYM_RHODJ(JI,JJ,JK) * &
- (ZRVS_OTHER(JI,JJ,JK) + ZRVS_ADV(JI,JJ,JK))
- ZW(JI,JJ,JK) = ZW(JI,JJ,JK) + ZTSTEP / ZMZM_RHODJ(JI,JJ,JK) * &
- (ZRWS_OTHER(JI,JJ,JK) + ZRWS_ADV(JI,JJ,JK))
-!$mnh_end_do()
-END IF
-!$acc end kernels
-!
-! 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 ) call Budget_store_end( tbudgets(NBUDGET_U), 'ADV', prus(:, :, :) )
-if ( lbudget_v ) call Budget_store_end( tbudgets(NBUDGET_V), 'ADV', prvs(:, :, :) )
-if ( lbudget_w ) call Budget_store_end( tbudgets(NBUDGET_W), 'ADV', prws(:, :, :) )
-
-!-------------------------------------------------------------------------------
-!
-
-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
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE()
-#endif
-
-!$acc end data
-
-END SUBROUTINE ADVECTION_UVW
diff --git a/src/ZSOLVER/dotprod.f90 b/src/ZSOLVER/dotprod.f90
deleted file mode 100644
index 89fa14392..000000000
--- a/src/ZSOLVER/dotprod.f90
+++ /dev/null
@@ -1,209 +0,0 @@
-!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_DOTPROD
-! ###################
-!
-INTERFACE
-!
- FUNCTION DOTPROD(PA,PB,HLBCX,HLBCY) RESULT(PDOTPROD)
-!
-IMPLICIT NONE
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PA, PB ! input vectors
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
-!
-REAL :: PDOTPROD ! dot product
-!
-END FUNCTION DOTPROD
-!
-END INTERFACE
-!
-END MODULE MODI_DOTPROD
-!
-!
-!
-! #####################################################
- FUNCTION DOTPROD(PA,PB,HLBCX,HLBCY) RESULT(PDOTPROD)
-! #####################################################
-!
-!!**** *DOTPROD* - compute the dot product of two vectors
-!!
-!! PURPOSE
-!! -------
-! The purpose of this function is to compute dot product of the vectors
-! stored in the arrays PA, PB. The elements of PA and PB are localized at
-! mass points.
-!
-!!** METHOD
-!! ------
-!! The scalar product DOTPROD of 2 vectors A and B is defined by :
-!! DOTPROD = SUM( A(i,j,k)* B(i,j,k) )
-!! The bounds for the summation depend on the l.b.c.
-!!
-!! EXTERNAL
-!! --------
-!! NONE
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!! Module MODD_PARAMETERS: declaration of parameter variables
-!! JPHEXT, JPVEXT: define the number of marginal points out of the
-!! physical domain along horizontal and vertical directions respectively
-!! Module MODD_CONF: model configurations
-!! L2D: logical switch for 2D model version
-!!
-!! REFERENCE
-!! ---------
-!! Book2 of documentation of Meso-NH (function DOTPROD)
-!!
-!! AUTHOR
-!! ------
-!! P. Hereil and J. Stein * Meteo France *
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 25/07/94
-!! J.-P. Pinty 12/11/99 Parallelization
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS
-USE MODD_CONF
-!
-USE MODE_ll
-!JUAN
-USE MODE_REPRO_SUM
-!JUAN
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-!
-USE MODE_MPPDB
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of arguments and result
-! ------------------------------------
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PA, PB ! input vectors
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
-!
-REAL :: PDOTPROD ! dot product
-!
-!* 0.2 Declarations of local variables
-! -------------------------------
-!
-INTEGER :: JK,JI,JJ ! loop indexes
-!
-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
-INTEGER :: IJE ! indice J for the last inner mass point along y
-INTEGER :: IKB ! indice K for the first inner mass point along z
-INTEGER :: IKE ! indice K for the last inner mass point along z
-!
-INTEGER :: ILBXB,ILBYB,ILBXE,ILBYE ! loop indices depending on the
- ! lateral boundary conditions
-!
-INTEGER :: IINFO_ll
-!JUAN16
-REAL, POINTER, CONTIGUOUS, DIMENSION(:,:) :: ZDOTPROD
-!JUAN16
-!
-!-------------------------------------------------------------------------------
-!
-!* 1. COMPUTE LOOP BOUNDS
-!-------------------
-if ( mppdb_initialized ) then
- !Check all in arrays
- call Mppdb_check( PA, "Dotprod beg:PA" )
- call Mppdb_check( PB, "Dotprod beg:PB" )
-end if
-!
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-!
-IKB=1+JPVEXT
-IKE=SIZE(PA,3) - JPVEXT
-!
-IF(HLBCX(1)/='CYCL' .AND. LWEST_ll()) THEN
- ILBXB = IIB-1 ! non cyclic condition at the physical boundary
-ELSE
- ILBXB = IIB
-ENDIF
-!
-IF(HLBCX(2)/='CYCL' .AND. LEAST_ll()) THEN
- ILBXE = IIE+1 ! non cyclic condition at the physical boundary
-ELSE
- ILBXE = IIE
-ENDIF
-!
-ILBYB = IJB
-ILBYE = IJE
-!
-IF (.NOT.L2D) THEN ! 3d version
- IF(HLBCY(1)/='CYCL' .AND. LSOUTH_ll()) THEN
- ILBYB = IJB-1 ! non cyclic condition at the physical boundary
- ELSE
- ILBYB = IJB
- ENDIF
-!
- IF(HLBCY(2)/='CYCL' .AND. LNORTH_ll()) THEN
- ILBYE = IJE+1 ! non cyclic condition at the physical boundary
- ELSE
- ILBYE = IJE
- ENDIF
-ELSE ! 2d version
- ILBYB = IJB
- ILBYE = IJB
-ENDIF
-!
-!* 2. COMPUTE THE DOT PRODUCT
-! -----------------------
-!
-!JUAN16
-#ifndef MNH_OPENACC
-ALLOCATE(ZDOTPROD(ILBXB:ILBXE,ILBYB:ILBYE))
-#else
-CALL MNH_MEM_POSITION_PIN()
-CALL MNH_MEM_GET(ZDOTPROD, ILBXB,ILBXE ,ILBYB,ILBYE )
-#endif
-!$acc kernels present(ZDOTPROD)
-ZDOTPROD(:,:) = 0.
-!$acc end kernels
-!$acc parallel
-!$mnh_do_concurrent(JI=ILBXB:ILBXE,JJ=ILBYB:ILBYE)
- !dir$ nextscalar
- !$acc loop seq
- DO JK = IKB-1,IKE+1
- ZDOTPROD(JI,JJ) = ZDOTPROD(JI,JJ) + PA(JI,JJ,JK) * PB(JI,JJ,JK)
- END DO
-!$mnh_end_do()
-!$acc end parallel
-! acc update host(ZDOTPROD)
-PDOTPROD = SUM_DD_R2_ll_DEVICE(ZDOTPROD)
-!JUAN16
-#ifndef MNH_OPENACC
-DEALLOCATE(ZDOTPROD)
-#else
-CALL MNH_MEM_RELEASE()
-#endif
-!
-!-------------------------------------------------------------------------------
-!
-END FUNCTION DOTPROD
diff --git a/src/ZSOLVER/flat_inv.f90 b/src/ZSOLVER/flat_inv.f90
deleted file mode 100644
index 38fd8718d..000000000
--- a/src/ZSOLVER/flat_inv.f90
+++ /dev/null
@@ -1,702 +0,0 @@
-!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_FLAT_INV
-! ####################
-!
-INTERFACE
-!
- SUBROUTINE FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
- PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y)
-!
-!
-IMPLICIT NONE
-!
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
-CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
-!
-REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
- ! direction
-REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
- ! direction
-!
-REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
- ! localized at a mass level
-!
-REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
- ! matrix in the pressure eq.
-!
- ! arrays of sin or cos values
- ! for the FFT :
-REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
-REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
-!
- ! decomposition in prime
- ! numbers for the FFT:
-INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
-INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
-!
-REAL, DIMENSION(:,:,:), INTENT(OUT):: PF_1_Y ! solution of the equation
-!
-END SUBROUTINE FLAT_INV
-!
-END INTERFACE
-!
-END MODULE MODI_FLAT_INV
-! ######################################################################
- SUBROUTINE FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
- PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y)
-! ######################################################################
-!
-!!**** *FLAT_INV * - Invert the flat quasi-laplacian operator
-!!
-!! PURPOSE
-!! -------
-! This routine solves the following equation:
-! F ( F_1_Y ) = Y
-! where F represents the quasi-laplacian without orography. The solution is
-! F_1_Y.
-!
-!!** METHOD
-!! ------
-!! The horizontal part of F is inverted with a FFT transform. For each
-!! horizontal direction, the FFT form depends on the lateral boundary
-!! conditions :
-!! - CRAY intrinsic function RFFTMLT in the cyclic case
-!! - fast cosine transform called FFT55 for all other boundary condtions.
-!! Then, in the wavenumber space, we invert for each
-!! horizontal mode i,j a tridiagonal matrix by a classical double sweep
-!! method. The singular mean mode (i,j)=(0,0) corresponds to the
-!! undetermination of the pressure to within a constant and is treated apart.
-!! To fix this degree of freedom, we set the horizontal mean value of the
-!! pressure perturbation to 0 at the upper level of the model.
-!!
-!! EXTERNAL
-!! --------
-!! Subroutine FFT55 : aplly multiple fast real staggered (shifted)
-!! cosine transform
-!! Subroutine RFFTMLT : apply real-to-complex or complex-to-real Fast
-!! Fourier Transform (FFT) on multiple input vectors.
-!! Subroutine FFT991 : equivalent to RFFTMLT
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!! Module MODD_PARAMETERS: declaration of parameter variables
-!! JPHEXT, JPVEXT: define the number of marginal points out of the
-!! physical domain along horizontal and vertical directions respectively
-!! Module MODD_CONF: model configurations
-!! L2D: logical for 2D model version
-!!
-!! REFERENCE
-!! ---------
-!! Book2 of documentation (subroutine FLAT_INV)
-!!
-!! AUTHOR
-!! ------
-!! P. Hereil and J. Stein * Meteo France *
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 20/07/94
-!! Revision Jabouille (juillet 96) replace the CRAY intrinsic function
-!! RFFTMLT by the arpege routine FFT991
-!! 17/07/97 ( J. Stein and V. Masson) initialize the corner
-!! verticals
-!! 17/07/97 ( J. Stein and V. Masson) initialize the corner
-!! verticals
-!! Revision Jabouille (septembre 97) suppress the particular case for
-!! tridiagonal inversion
-!! Stein ( January 98 ) faster computation for the unused
-!! points under the ground and out of the domain
-!! Modification Lugato, Guivarch (June 1998) Parallelisation
-!! Escobar, Stein (July 2000) optimisation
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS
-USE MODD_CONF
-!
-USE MODE_ll
-USE MODD_ARGSLIST_ll, ONLY : LIST_ll
-!
-USE MODI_FFT55
-!
-IMPLICIT NONE
-!
-!* 0.1 declarations of 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
-!
-REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
- ! direction
-REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
- ! direction
-!
-REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
- ! localized at a mass level
-!
-REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
- ! matrix in the pressure eq.
-!
- ! arrays of sin or cos values
- ! for the FFT :
-REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
-REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
-!
- ! decomposition in prime
- ! numbers for the FFT:
-INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
-INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
-!
-REAL, DIMENSION(:,:,:), INTENT(OUT):: PF_1_Y ! solution of the equation
-!
-!* 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
-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 :: IIMAX ! number of inner mass points along the x direction
-INTEGER :: IJB ! indice J for the first inner mass point along y
-INTEGER :: IJE ! indice J for the last inner mass point along y
-INTEGER :: IJMAX ! number of inner mass points along the y direction
-INTEGER :: IKB ! indice K for the first inner mass point along z
-INTEGER :: IKE ! indice K for the last inner mass point along z
-INTEGER :: IKU ! size of the arrays along z
-INTEGER :: IKMAX ! number of inner mass points along the z direction
-!
-REAL :: ZDXM2,ZDYM2 ! respectively equal to PDXHATM*PDXHATM
- ! and PDYHATM*PDYHATM
-INTEGER :: JI,JJ,JK ! loop indexes along x, y, z respectively
-!
-!
-INTEGER :: IIE_INT,IJE_INT ! highest indice I and J values for the x y modes.
- ! They depend on the l.b.c. !
-!
-INTEGER :: ILOTX,ILOTY ! number of data vectors along x, y resp. computed
- ! in parallel during the FFT process
-!
-INTEGER :: INC1X,INC1Y ! increment within each data vector for the FFT along
- ! x, y resp.
-!
-INTEGER :: INC2X,INC2Y ! increment between the start of one data vector and
- ! the next for the FFT along x,y resp.
-!
-!
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWORKX ! work array used by
-! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWORKY ! work array used by
-! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
-!
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZGAM
- ! intermediate arrays
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZBETX ! for the tridiag.
- ! matrix inversion
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_X ! array in X slices distribution
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_Y ! array in Y slices distribution
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_YR ! array in Y slices distribution
-!
-INTEGER :: IINFO_ll ! return code of parallel routine
-!
-INTEGER :: IIX,IJX,IIY,IJY ! dimensions of the extended x or y slices subdomain
-!
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_YT ! array in Y slices distribution transpose
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_YRT ! array in Y slices distribution transpose
-!-------------------------------------------------------------------------------
-!
-!* 1. COMPUTE LOOP BOUNDS
-! -------------------
-!
-CALL GET_PHYSICAL_ll(IIB,IJB,IIE,IJE)
-CALL GET_DIM_EXT_ll('X',IIX,IJX)
-CALL GET_DIM_EXT_ll('Y',IIY,IJY)
-IIMAX = IIX-2*JPHEXT
-IJMAX = IJY-2*JPHEXT
-!
-IKU=SIZE(PY,3)
-IKB=1+JPVEXT
-IKE=IKU - JPVEXT
-IKMAX=IKE-IKB+1
-!
-!!
-ALLOCATE(ZBAND_X(IIX,IJX,IKU))
-ALLOCATE(ZBAND_Y(IIY,IJY,IKU))
-ALLOCATE(ZBAND_YR(IIY,IJY,IKU))
-ALLOCATE(ZWORKX(IIX,IJX,IKU))
-ALLOCATE(ZWORKY(IIY,IJY,IKU))
-ALLOCATE(ZBETX(IIY,IJY))
-ALLOCATE(ZGAM(IIY,IJY,IKU))
-IF (.NOT. L2D) THEN
- ALLOCATE(ZBAND_YT(IJY,IIY,IKU))
- ALLOCATE(ZBAND_YRT(IJY,IIY,IKU))
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!* 2. COMPUTE THE ARRAY INCREMENTS FOR THE FFT
-! ----------------------------------------
-!
-IF(.NOT. L2D) THEN
-!
- ILOTX = IJX*IKU
- INC1X = 1
- INC2X = IIX
-!
- ILOTY = IIY*IKU
- INC1Y = 1
- INC2Y = IJY
-!
-ELSE
-!
- ILOTX = IKU
- INC1X = 1
- INC2X = IIX*IJX
-ENDIF
-!
-!-------------------------------------------------------------------------------
-!
-!* 3. FORM HOMOGENEOUS BOUNDARY CONDITIONS FOR A NONCYCLIC CASE
-! ---------------------------------------------------------
-!
-!
-!* 3.1 copy the RHS in a local array REMAP functions will shift the indices for the FFT
-!
-PF_1_Y = 0.
-ZY = PY
-!
-!* 3.2 form homogeneous boundary condition used by the FFT for non-periodic
-! cases
-!
-! modify the RHS in the x direction
-!
-IF (HLBCX(1) /= 'CYCL') THEN
-!
- IF (LWEST_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JJ = IJB, IJE
- ZY(IIB,JJ,JK) = ZY(IIB,JJ,JK) + PY(IIB-1,JJ,JK)
- END DO
- END DO
- END IF
-!
- IF (LEAST_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JJ = IJB, IJE
- ZY(IIE,JJ,JK) = ZY(IIE,JJ,JK) - PY(IIE+1,JJ,JK)
- END DO
- END DO
- END IF
-END IF
-!
-! modify the RHS in the same way along y
-!
-IF (HLBCY(1) /= 'CYCL'.AND. (.NOT. L2D)) THEN
- IF (LSOUTH_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JI = IIB, IIE
- ZY(JI,IJB,JK) = ZY(JI,IJB,JK) + PY(JI,IJB-1,JK)
- END DO
- END DO
- END IF
-!
- IF (LNORTH_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JI = IIB, IIE
- ZY(JI,IJE,JK) = ZY(JI,IJE,JK) - PY(JI,IJE+1,JK)
- END DO
- END DO
- END IF
-END IF
-!
-!
-!* 3.3 2way structure -> xslice structure, + data shift
-!
-ZBAND_X=0.
-CALL REMAP_2WAY_X_ll(ZY,ZBAND_X,IINFO_ll)
-!
-!
-!-------------------------------------------------------------------------------
-!
-!* 4. APPLY A REAL TO COMPLEX FFT
-! ---------------------------
-!
-!
-IF (HLBCX(1) == 'CYCL') THEN
- CALL FFT991(ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
- IIMAX,ILOTX,-1 )
-ELSE
- CALL FFT55(ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
- IIMAX,ILOTX,-1 )
-END IF
-!
-!
-ZBAND_Y=0.
-CALL REMAP_X_Y_ll(ZBAND_X,ZBAND_Y,IINFO_ll)
-!
-IF (.NOT. L2D) THEN
-!
-! array transposition I --> J
-!
- CALL FAST_TRANSPOSE(ZBAND_Y,ZBAND_YT,IIY,IJY,IKU)
-!
- IF (HLBCY(1) == 'CYCL') THEN
- CALL FFT991(ZBAND_YT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
- IJMAX,ILOTY,-1 )
- ELSE
- CALL FFT55(ZBAND_YT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
- IJMAX,ILOTY,-1 )
- END IF
-!
-END IF
-!
-! singular matrix case : the last term is computed by setting the
-! average of the pressure field equal to zero.
-IF (LWEST_ll(HSPLITTING='Y')) THEN
- IF (L2D) THEN
- ZBAND_Y(1,1,IKE+1)=0
- ELSE
- ZBAND_YT(1,1,IKE+1)=0.
- END IF
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!* 5. MATRIX INVERSION FOR THE FLAT OPERATOR
-! --------------------------------------
-!
-CALL FAST_SPREAD(PAF,ZAF,IIY,IJY,IKU)
-!
-IF (LWEST_ll(HSPLITTING='Y')) THEN
- ZAF(1,1,IKE+1)=0. !singular matrix corresponding to the horizontal average
-END IF
-!
-IF (L2D) THEN
- CALL FAST_SUBSTITUTION_2D(ZBAND_YR,ZBETX,PBF,ZGAM,PCF,ZAF &
- ,ZBAND_Y,IIY,IJY,IKU)
-ELSE
- CALL FAST_SUBSTITUTION_3D(ZBAND_YRT,ZBETX,PBF,ZGAM,PCF,ZAF &
- ,ZBAND_YT,IIY,IJY,IKU)
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!* 6. APPLY A COMPLEX TO REAL FFT
-! ---------------------------
-!
-!
-IF (.NOT. L2D) THEN
- IF (HLBCY(1) == 'CYCL') THEN
- CALL FFT991( ZBAND_YRT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
- IJMAX,ILOTY,+1 )
- ELSE
- CALL FFT55( ZBAND_YRT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
- IJMAX,ILOTY,+1 )
- END IF
- ! array transposition J --> I
- CALL FAST_TRANSPOSE(ZBAND_YRT,ZBAND_YR,IJY,IIY,IKU)
-ENDIF
-!
-! Transposition Y-> X
-!
-ZBAND_X=0.
-CALL REMAP_Y_X_ll(ZBAND_YR,ZBAND_X,IINFO_ll)
-!
-!
-IF (HLBCX(1) == 'CYCL') THEN
- CALL FFT991( ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
- IIMAX,ILOTX,+1 )
-ELSE
- CALL FFT55( ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
- IIMAX,ILOTX,+1 )
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!* 7. RETURN TO A NON HOMOGENEOUS NEUMAN CONDITION FOR NON-CYCLIC CASES
-! -----------------------------------------------------------------
-!
-!* 7.1 Transposition + shift X -> 2way
-!
-CALL REMAP_X_2WAY_ll(ZBAND_X,PF_1_Y,IINFO_ll)
-!
-!* 7.2 complete the lateral boundaries
-!
-IF (HLBCX(1) /= 'CYCL') THEN
-!
-!* 7.2.1 return to a non-homogeneous case in the x direction
-!
- ZDXM2 = PDXHATM*PDXHATM
-!
- IF (LWEST_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JJ = IJB,IJE
- PF_1_Y(IIB-1,JJ,JK) = PF_1_Y(IIB,JJ,JK) - PY(IIB-1,JJ,JK)*ZDXM2/PRHOM(JK)
- END DO
- END DO
- END IF
-!
- IF (LEAST_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JJ = IJB,IJE
- PF_1_Y(IIE+1,JJ,JK) = PF_1_Y(IIE,JJ,JK) + PY(IIE+1,JJ,JK)*ZDXM2/PRHOM(JK)
- END DO
- END DO
- END IF
-!
-! we set the solution at the corner point by the condition:
-! dxm ( P ) = 0
- IF (LWEST_ll(HSPLITTING='B')) THEN
- DO JJ = IJB,IJE
- PF_1_Y(IIB-1,JJ,IKB-1) = PF_1_Y(IIB,JJ,IKB-1)
- PF_1_Y(IIB-1,JJ,IKE+1) = PF_1_Y(IIB,JJ,IKE+1)
- END DO
- END IF
- IF (LEAST_ll(HSPLITTING='B')) THEN
- DO JJ = IJB,IJE
- PF_1_Y(IIE+1,JJ,IKB-1) = PF_1_Y(IIE,JJ,IKB-1)
- PF_1_Y(IIE+1,JJ,IKE+1) = PF_1_Y(IIE,JJ,IKE+1)
- END DO
- END IF
-!
-ELSE
-!
-!* 7.2.2 periodize the pressure function field along the x direction
-!
-! in fact this part is useless because it is done in the routine
-! REMAP_X_2WAY.
-!
-END IF
-!
-IF (.NOT.L2D) THEN
- IF (HLBCY(1) /= 'CYCL') THEN
-!
-!* 7.2.3 return to a non-homogeneous case in the y direction
-!
- ZDYM2 = PDYHATM*PDYHATM
-!
- IF (LSOUTH_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JI = IIB,IIE
- PF_1_Y(JI,IJB-1,JK) = PF_1_Y(JI,IJB,JK) - PY(JI,IJB-1,JK)*ZDYM2/PRHOM(JK)
- END DO
- END DO
- END IF
-!
- IF (LNORTH_ll(HSPLITTING='B')) THEN
- DO JK=IKB,IKE
- DO JI = IIB,IIE
- PF_1_Y(JI,IJE+1,JK) = PF_1_Y(JI,IJE,JK) + PY(JI,IJE+1,JK)*ZDYM2/PRHOM(JK)
- END DO
- END DO
- END IF
-! we set the solution at the corner point by the condition:
-! dym ( P ) = 0
-!
- IF (LSOUTH_ll(HSPLITTING='B')) THEN
- DO JI = IIB,IIE
- PF_1_Y(JI,IJB-1,IKB-1) = PF_1_Y(JI,IJB,IKB-1)
- PF_1_Y(JI,IJB-1,IKE+1) = PF_1_Y(JI,IJB,IKE+1)
- END DO
- END IF
-!
- IF (LNORTH_ll(HSPLITTING='B')) THEN
- DO JI = IIB,IIE
- PF_1_Y(JI,IJE+1,IKB-1) = PF_1_Y(JI,IJE,IKB-1)
- PF_1_Y(JI,IJE+1,IKE+1) = PF_1_Y(JI,IJE,IKE+1)
- END DO
- END IF
- ELSE
-!
-!* 7.2.4 periodize the pressure function field along the y direction
-!
-!
-! in fact this part is useless because it is done in the routine
-! REMAP_X_2WAY.
-!
- END IF
-!
-END IF
-!
-IF (.NOT. L2D .AND. HLBCX(1)/='CYCL' .AND. HLBCY(1)/='CYCL') THEN
-! the following verticals are not used
- IF ( (LWEST_ll(HSPLITTING='B')).AND.(LSOUTH_ll(HSPLITTING='B')) ) THEN
- PF_1_Y(IIB-1,IJB-1,:)=PF_1_Y(IIB,IJB,:)
- END IF
-!
- IF ( (LWEST_ll(HSPLITTING='B')).AND.(LNORTH_ll(HSPLITTING='B')) ) THEN
- PF_1_Y(IIB-1,IJE+1,:)=PF_1_Y(IIB,IJE,:)
- END IF
-!
- IF ( (LEAST_ll(HSPLITTING='B')).AND.(LSOUTH_ll(HSPLITTING='B')) ) THEN
- PF_1_Y(IIE+1,IJB-1,:)=PF_1_Y(IIE,IJB,:)
- END IF
-!
- IF ( (LEAST_ll(HSPLITTING='B')).AND.(LNORTH_ll(HSPLITTING='B')) ) THEN
- PF_1_Y(IIE+1,IJE+1,:)=PF_1_Y(IIE,IJE,:)
- END IF
-END IF
-!
-DEALLOCATE(ZBAND_X)
-DEALLOCATE(ZBAND_Y)
-IF (.NOT. L2D) THEN
- DEALLOCATE(ZBAND_YT)
- DEALLOCATE(ZBAND_YRT)
-END IF
-DEALLOCATE(ZBAND_YR)
-DEALLOCATE(ZWORKX)
-DEALLOCATE(ZWORKY)
-DEALLOCATE(ZBETX)
-DEALLOCATE(ZGAM)
-!
-!-------------------------------------------------------------------------------
-!
-CONTAINS
- SUBROUTINE FAST_TRANSPOSE(PX,PXT,KNI,KNJ,KNK)
- INTEGER :: KNI,KNJ,KNK ! 3D dimension of X and XT
- REAL, DIMENSION(KNI*KNJ,KNK) :: PX
- REAL, DIMENSION(KNJ*KNI,KNK) :: PXT
- !
- INTEGER :: IJI,II,IJ,IIJ ! index in array X and XT
- INTEGER :: JK
-!
- DO JK=1,KNK
- ! PERMUTATION(PX,PXT)
- !CDIR NODEP
- !OCL NOVREC
- DO IJI = 1, KNJ*KNI
- ! I,J Indice in XT array from linearised index IJI
- II = 1 + (IJI-1)/KNJ
- IJ = IJI - (II-1)*KNJ
- ! linearised index in X
- IIJ = II + (IJ-1)*KNI
- ! transposition
- PXT(IJI,JK) = PX(IIJ,JK)
-
- END DO
- END DO
-!
-END SUBROUTINE FAST_TRANSPOSE
-
-SUBROUTINE FAST_SUBSTITUTION_3D(PBAND_YR,PBETX,PPBF,PGAM,PPCF,PAF &
- ,PBAND_Y,KIY,KJY,KKU)
-INTEGER :: KIY,KJY,KKU
-REAL, DIMENSION (KIY*KJY,KKU) :: PBAND_YR,PBAND_Y,PPBF,PGAM,PAF
-REAL, DIMENSION (KIY*KJY) :: PBETX
-REAL, DIMENSION (KKU) :: PPCF
-INTEGER :: JK
-!
-!
-! initialization
-!
-!
-PBAND_YR = 0.0
-PBETX(:) = PPBF(:,IKB-1)
-PBAND_YR(:,IKB-1) = PBAND_Y(:,IKB-1) &
- / PBETX(:)
-!
-! decomposition and forward substitution
-!
-DO JK = IKB,IKE+1
- PGAM(:,JK) = PPCF(JK-1) / PBETX(:)
-!
- PBETX(:) = PPBF(:,JK) - &
- PAF(:,JK)*PGAM(:,JK)
-!
- PBAND_YR(:,JK) = ( PBAND_Y(:,JK) - &
- PAF(:,JK)*PBAND_YR(:,JK- 1) ) &
- /PBETX(:)
-!
-END DO
-!
-! backsubstitution
-!
-DO JK = IKE,IKB-1,-1
- PBAND_YR(:,JK) = PBAND_YR(:,JK) - &
- PGAM(:,JK+1)*PBAND_YR(:,JK+1)
-END DO
-!
-!
-END SUBROUTINE FAST_SUBSTITUTION_3D
-!
-SUBROUTINE FAST_SUBSTITUTION_2D(PBAND_YR,PBETX,PPBF,PGAM,PPCF,PAF &
- ,PBAND_Y,KIY,KJY,KKU)
-INTEGER :: KIY,KJY,KKU
-REAL, DIMENSION (KIY,KJY,KKU) :: PBAND_YR,PBAND_Y,PPBF,PGAM,PAF
-REAL, DIMENSION (KIY,KJY) :: PBETX
-REAL, DIMENSION (KKU) :: PPCF
-INTEGER :: JK
-!
-!
-! initialization
-!
-!
-PBAND_YR = 0.0
-PBETX(:,1) = PPBF(:,1,IKB-1)
-PBAND_YR(:,1,IKB-1) = PBAND_Y(:,1,IKB-1) &
- / PBETX(:,1)
-!
-! decomposition and forward substitution
-!
-DO JK = IKB,IKE+1
- PGAM(:,1,JK) = PPCF(JK-1) / PBETX(:,1)
-!
- PBETX(:,1) = PPBF(:,1,JK) - &
- PAF(:,1,JK)*PGAM(:,1,JK)
-!
- PBAND_YR(:,1,JK) = ( PBAND_Y(:,1,JK) - &
- PAF(:,1,JK)*PBAND_YR(:,1,JK- 1) ) &
- /PBETX(:,1)
-!
-END DO
-!
-! backsubstitution
-!
-DO JK = IKE,IKB-1,-1
- PBAND_YR(:,1,JK) = PBAND_YR(:,1,JK) - &
- PGAM(:,1,JK+1)*PBAND_YR(:,1,JK+1)
-END DO
-!
-!
-END SUBROUTINE FAST_SUBSTITUTION_2D
-
-SUBROUTINE FAST_SPREAD(PTAB1D,PTAB3D,KIY,KJY,KKU)
-INTEGER :: KIY,KJY,KKU
-REAL, DIMENSION (KKU) :: PTAB1D
-REAL, DIMENSION (KIY*KJY,KKU) :: PTAB3D
-
-INTEGER :: JIJ,JK
-!
-DO JK=1,KKU
- DO JIJ=1,KIY*KJY
- PTAB3D(JIJ,JK) = PTAB1D(JK)
- ENDDO
-ENDDO
-!
-END SUBROUTINE FAST_SPREAD
-!
-!------------------------------------------------------------------------------
-END SUBROUTINE FLAT_INV
diff --git a/src/ZSOLVER/p_abs.f90 b/src/ZSOLVER/p_abs.f90
deleted file mode 100644
index 962230cde..000000000
--- a/src/ZSOLVER/p_abs.f90
+++ /dev/null
@@ -1,519 +0,0 @@
-!MNH_LIC Copyright 1994-2022 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_P_ABS
-! #################
-!
-INTERFACE
-!
- SUBROUTINE P_ABS (KRR, KRRL, KRRI, PDRYMASST, PREFMASS, PMASS_O_PHI0, &
- PTHT, PRT, PRHODJ, PRHODREF, PTHETAV, PTHVREF, &
- PRVREF, PEXNREF, PPHIT, PPHI0)
-!
-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
-REAL, INTENT(INOUT) :: PPHI0 ! Phi0 at time t !
-!
-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, PPHI0 )
-! #######################################################################
-!
-!!**** *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
-!! J.L Redelsperger 03/2021 Change of one step to pressure computation
-!! in order to perform Ocean runs (equivalent to LHE shallow convection)
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_CST
-USE MODD_CONF
-USE MODD_DYN_n, ONLY: LOCEAN
-USE MODD_IBM_PARAM_n, ONLY: XIBM_LS, LIBM, XIBM_EPSI
-USE MODD_PARAMETERS
-USE MODD_REF, ONLY: LBOUSS
-!
-USE MODE_ll
-USE MODE_REPRO_SUM
-!
-#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
-USE MODI_BITREP
-#endif
-#ifdef MNH_COMPILER_CCE
-!$mnh_undef(LOOP)
-!$mnh_undef(OPENACC)
-#endif
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-!
-USE MODE_MPPDB
-!
-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
-#ifdef MNH_COMPILER_CCE_1403
-REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: PEXNREF_BR
-#endif
-!
-REAL, INTENT(INOUT) :: PPHI0 ! PHI0 at t
-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, DIMENSION(:,:) , POINTER , CONTIGUOUS :: 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
-#ifdef MNH_OPENACC
-INTEGER :: IZRTOT, IZRHOREF, IZWORK
-#endif
-REAL :: ZPHI0
-!
-INTEGER :: IINFO_ll
-!
-LOGICAL :: GPRVREF0
-!
-INTEGER :: IIU,IJU
-!
-LOGICAL, SAVE :: GFIRST_CALL_P_ABS = .TRUE.
-!
-!-------------------------------------------------------------------------------
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PTHT,"P_ABS beg:PTHT")
- CALL MPPDB_CHECK(PRT,"P_ABS beg:PRT")
- CALL MPPDB_CHECK(PRHODJ,"P_ABS beg:PRHODJ")
- CALL MPPDB_CHECK(PTHETAV,"P_ABS beg:PTHETAV")
- CALL MPPDB_CHECK(PRHODREF,"P_ABS beg:PRHODREF")
- CALL MPPDB_CHECK(PTHVREF,"P_ABS beg:PTHVREF")
- CALL MPPDB_CHECK(PRVREF,"P_ABS beg:PRVREF")
- CALL MPPDB_CHECK(PEXNREF,"P_ABS beg:PEXNREF")
- CALL MPPDB_CHECK(PPHIT,"P_ABS beg:PPHIT")
-END IF
-!
-!* 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 )
-!
-!
-ZP00_O_RD = XP00 / XRD
-ZCVD_O_RD = (XCPD - XRD) / XRD
-!
-#ifndef MNH_OPENACC
-ALLOCATE(ZMASS_O_PI_2D(IIB:IIE,IJB:IJE))
-ALLOCATE(ZMASSGUESS_2D(IIB:IIE,IJB:IJE))
-ALLOCATE(ZWATERMASST_2D(IIB:IIE,IJB:IJE))
-ALLOCATE (ZRTOT(IIU,IJU,IKU), ZRHOREF(IIU,IJU,IKU), ZWORK(IIU,IJU,IKU))
-#else
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN()
-
-#ifdef MNH_COMPILER_CCE_1403
-CALL MNH_MEM_GET(PEXNREF_BR , IIB,IIE , IJB,IJE, IKB,IKE)
-#endif
-CALL MNH_MEM_GET(ZMASS_O_PI_2D , IIB,IIE , IJB,IJE)
-CALL MNH_MEM_GET(ZMASSGUESS_2D , IIB,IIE , IJB,IJE)
-CALL MNH_MEM_GET(ZWATERMASST_2D , IIB,IIE , IJB,IJE)
-CALL MNH_MEM_GET( ZRTOT, IIU, IJU, IKU )
-CALL MNH_MEM_GET( ZRHOREF, IIU, IJU, IKU )
-CALL MNH_MEM_GET( 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
-#if defined(MNH_COMPILER_CCE_1403) && defined(MNH_BITREP_OMP)
- !$acc loop
- !$mnh_do_concurrent(JI=IIB:IIE,JJ=IJB:IJE,JK=IKB:IKE )
- PEXNREF_BR(JI,JJ,JK)=BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD)
- !$mnh_end_do()
-#endif
- !$acc end kernels
- !$acc parallel
- !$acc loop seq
- DO JK = IKB,IKE
- !$acc loop independent
- DO CONCURRENT ( JJ = IJB:IJE , JI = IIB:IIE )
- ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- (PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
-#else
-#ifndef MNH_COMPILER_CCE_1403
- BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD) &
-#else
- PEXNREF_BR(JI,JJ,JK) &
-#endif
-#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
- !$acc end parallel
- !
- ELSE
- DO JK = IKB,IKE
- DO JJ = IJB,IJE
- DO JI = IIB,IIE
- ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- (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
- * 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
-!
- !
- ! acc update host(ZMASSGUESS_2D,ZMASS_O_PI_2D,ZWATERMASST_2D)
- ZMASSGUESS = SUM_DD_R2_ll_DEVICE(ZMASSGUESS_2D)
- ZMASS_O_PI = SUM_DD_R2_ll_DEVICE(ZMASS_O_PI_2D)
- ZWATERMASST = SUM_DD_R2_ll_DEVICE(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
- #if defined(MNH_COMPILER_CCE_1403) && defined(MNH_BITREP_OMP)
- !$acc kernels
- !$acc loop
- !$mnh_do_concurrent(JI=IIB:IIE,JJ=IJB:IJE,JK=IKB:IKE )
- PEXNREF_BR(JI,JJ,JK)=BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD)
- !$mnh_end_do()
- !$acc end kernels
-#endif
- !$acc parallel
- !$acc loop seq
- DO JK = IKB,IKE
- !$acc loop independent
- DO CONCURRENT ( JJ = IJB:IJE , JI = IIB:IIE )
- ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- (PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK))**ZCVD_O_RD &
-#else
-#ifndef MNH_COMPILER_CCE_1403
- BR_POW((PEXNREF(JI,JJ,JK)+PPHIT(JI,JJ,JK)),ZCVD_O_RD) &
-#else
- PEXNREF_BR(JI,JJ,JK) &
-#endif
-#endif
- * ZWORK(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
- END DO
- END DO
- !$acc end parallel
- ELSE
- DO JK = IKB,IKE
- DO JJ = IJB,IJE
- DO JI = IIB,IIE
- ZMASSGUESS_2D(JI,JJ) = ZMASSGUESS_2D(JI,JJ) + &
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- (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
- * PRHODJ(JI,JJ,JK) / PRHODREF(JI,JJ,JK) / PTHETAV(JI,JJ,JK)
- END DO
- END DO
- END DO
- END IF
-!
- ! acc update host(ZMASSGUESS_2D)
- ZMASSGUESS = SUM_DD_R2_ll_DEVICE(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
-#if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
- ZRHOREF(:,:,:) = PEXNREF(:,:,:) ** ZCVD_O_RD &
-#else
- ZRHOREF(:,:,:) = BR_POW( PEXNREF(:,:,:), ZCVD_O_RD )&
-#endif
- * 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)
- 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
- !
- IF (LIBM) THEN
- WHERE (XIBM_LS(:,:,:,1).GT.-XIBM_EPSI)
- ZWORK(:,:,:) = PTHVREF(:,:,:)
- ENDWHERE
- ENDIF
- !
- ! compute the absolute pressure function (LHE equation system case)
- !
- !
- !
- 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)
- !
- ! case shallow bouss : to get the real pressure fluctuation
- ! Eq 2.40 p15 : constant not resolved in poisson equation
- IF (.NOT. LOCEAN) THEN
- PPHI0 = (PDRYMASST + ZWATERMASST - 2. * PREFMASS + ZMASSGUESS ) / PMASS_O_PHI0
- ELSE
- ! PPHI0 = 0. => to be possibly modified for ocean LES case
- PPHI0=0.
- END IF
- ! following computation moved in PRESSURE routine (Eq 2.40 bis p15: Phi_total)
- ! PPHIT(:,:,:) = PPHIT(:,:,:) + ZPHI0
- !
-END IF
-!
-#ifndef MNH_OPENACC
-DEALLOCATE(ZMASS_O_PI_2D,ZMASSGUESS_2D,ZWATERMASST_2D)
-DEALLOCATE (ZRTOT, ZRHOREF, ZWORK)
-#else
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE()
-#endif
-IF (MPPDB_INITIALIZED) THEN
- CALL MPPDB_CHECK(PPHIT,"P_ABS end:PPHIT")
-END IF
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE P_ABS
diff --git a/src/ZSOLVER/rain_ice_red.f90 b/src/ZSOLVER/rain_ice_red.f90
deleted file mode 100644
index 3aeb5a133..000000000
--- a/src/ZSOLVER/rain_ice_red.f90
+++ /dev/null
@@ -1,2977 +0,0 @@
-!MNH_LIC Copyright 1995-2021 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.
-!-----------------------------------------------------------------
-! ######spl
- MODULE MODI_RAIN_ICE_RED
-! ########################
-!
-INTERFACE
- SUBROUTINE RAIN_ICE_RED ( KIT, KJT, KKT, KSIZE, &
- OSEDIC, HSEDIM, HSUBG_AUCV_RC, HSUBG_AUCV_RI, &
- OWARM, KKA, KKU, KKL, &
- PTSTEP, KRR, ODMICRO, PEXN, &
- PDZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, PCIT, PCLDFR,&
- PHLC_HRC, PHLC_HCF, PHLI_HRI, PHLI_HCF,&
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, &
- PRGT, PTHS, PRVS, PRCS, PRRS, PRIS, PRSS, PRGS, &
- PINPRC,PINPRR, PEVAP3D, &
- PINPRS, PINPRG, PINDEP, PRAINFR, PSIGS, PSEA, PTOWN, &
- PRHT, PRHS, PINPRH, PFPR )
-!
-!
-INTEGER, INTENT(IN) :: KIT, KJT, KKT ! arrays size
-INTEGER, INTENT(IN) :: KSIZE
-LOGICAL, INTENT(IN) :: OSEDIC ! Switch for droplet sedim.
-CHARACTER(LEN=4), INTENT(IN) :: HSEDIM ! Sedimentation scheme
-CHARACTER(LEN=4), INTENT(IN) :: HSUBG_AUCV_RC ! Switch for rc->rr Subgrid autoconversion
- ! Kind of Subgrid autoconversion method
-CHARACTER(LEN=80), INTENT(IN) :: HSUBG_AUCV_RI ! Switch for ri->rs Subgrid autoconversion
- ! Kind of Subgrid autoconversion method
-LOGICAL, INTENT(IN) :: OWARM ! .TRUE. allows raindrops to
- ! form by warm processes
- ! (Kessler scheme)
-!
-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, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KRR ! Number of moist variable
-LOGICAL, DIMENSION(:,:,:), INTENT(IN) :: ODMICRO ! mask to limit computation
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXN ! Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Layer thikness (m)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! absolute pressure at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIT ! Pristine ice n.c. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCLDFR ! Cloud fraction
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLC_HRC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLC_HCF
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLI_HRI
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLI_HCF
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel/hail m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
-
-!
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRC! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRR! Rain instant precip
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEVAP3D! Rain evap profile
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRS! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRG! Graupel instant precip
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRAINFR! Rain fraction
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at t
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN! Fraction that is town
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PINPRH! Hail instant precip
-REAL, DIMENSION(:,:,:,:), OPTIONAL, INTENT(OUT) :: PFPR ! upper-air precipitation fluxes
-!
-END SUBROUTINE RAIN_ICE_RED
-END INTERFACE
-END MODULE MODI_RAIN_ICE_RED
-! ######spl
- SUBROUTINE RAIN_ICE_RED ( KIT, KJT, KKT, KSIZE, &
- OSEDIC, HSEDIM, HSUBG_AUCV_RC, HSUBG_AUCV_RI, &
- OWARM,KKA,KKU,KKL,&
- PTSTEP, KRR, ODMICRO, PEXN, &
- PDZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, PCIT, PCLDFR,&
- PHLC_HRC, PHLC_HCF, PHLI_HRI, PHLI_HCF, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, &
- PRGT, PTHS, PRVS, PRCS, PRRS, PRIS, PRSS, PRGS, &
- PINPRC,PINPRR, PEVAP3D, &
- PINPRS, PINPRG, PINDEP, PRAINFR, PSIGS, PSEA, PTOWN, &
- PRHT, PRHS, PINPRH, PFPR )
-! ######################################################################
-!
-!!**** * - compute the explicit microphysical sources
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the slow microphysical sources
-!! which can be computed explicitly
-!!
-!!
-!!** METHOD
-!! ------
-!! The autoconversion computation follows Kessler (1969).
-!! The sedimentation rate is computed with a time spliting technique and
-!! an upstream scheme, written as a difference of non-advective fluxes. This
-!! source term is added to the future instant ( split-implicit process ).
-!! The others microphysical processes are evaluated at the central instant
-!! (split-explicit process ): autoconversion, accretion and rain evaporation.
-!! These last 3 terms are bounded in order not to create negative values
-!! for the water species at the future instant.
-!!
-!! EXTERNAL
-!! --------
-!! None
-!!
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!! Module MODD_PARAMETERS
-!! JPHEXT : Horizontal external points number
-!! JPVEXT : Vertical external points number
-!! Module MODD_CONF :
-!! CCONF configuration of the model for the first time step
-!! Module MODD_CST
-!! XP00 ! Reference pressure
-!! XRD,XRV ! Gaz constant for dry air, vapor
-!! XMD,XMV ! Molecular weight for dry air, vapor
-!! XCPD ! Cpd (dry air)
-!! XCL ! Cl (liquid)
-!! XCI ! Ci (solid)
-!! XTT ! Triple point temperature
-!! XLVTT ! Vaporization heat constant
-!! XALPW,XBETAW,XGAMW ! Constants for saturation vapor pressure
-!! function over liquid water
-!! XALPI,XBETAI,XGAMI ! Constants for saturation vapor pressure
-!! function over solid ice
-!! Module MODD_BUDGET:
-!! NBUMOD : model in which budget is calculated
-!! CBUTYPE : type of desired budget
-!! 'CART' for cartesian box configuration
-!! 'MASK' for budget zone defined by a mask
-!! 'NONE' ' for no budget
-!! LBU_RTH : logical for budget of RTH (potential temperature)
-!! .TRUE. = budget of RTH
-!! .FALSE. = no budget of RTH
-!! LBU_RRV : logical for budget of RRV (water vapor)
-!! .TRUE. = budget of RRV
-!! .FALSE. = no budget of RRV
-!! LBU_RRC : logical for budget of RRC (cloud water)
-!! .TRUE. = budget of RRC
-!! .FALSE. = no budget of RRC
-!! LBU_RRI : logical for budget of RRI (cloud ice)
-!! .TRUE. = budget of RRI
-!! .FALSE. = no budget of RRI
-!! LBU_RRR : logical for budget of RRR (rain water)
-!! .TRUE. = budget of RRR
-!! .FALSE. = no budget of RRR
-!! LBU_RRS : logical for budget of RRS (aggregates)
-!! .TRUE. = budget of RRS
-!! .FALSE. = no budget of RRS
-!! LBU_RRG : logical for budget of RRG (graupeln)
-!! .TRUE. = budget of RRG
-!! .FALSE. = no budget of RRG
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Book1 and Book2 of documentation ( routine RAIN_ICE )
-!!
-!! AUTHOR
-!! ------
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 02/11/95
-!! (J.Viviand) 04/02/97 debug accumulated prcipitation & convert
-!! precipitation rate in m/s
-!! (J.-P. Pinty) 17/02/97 add budget calls
-!! (J.-P. Pinty) 17/11/97 set ice sedim. for cirrus ice, reset RCHONI
-!! and RRHONG, reverse order for DEALLOCATE
-!! (J.-P. Pinty) 11/02/98 correction of the air dynamical viscosity and
-!! add advance of the budget calls
-!! (J.-P. Pinty) 18/05/98 correction of the air density in the RIAUTS
-!! process
-!! (J.-P. Pinty) 18/11/98 split the main routine
-!! (V. Masson) 18/11/98 bug in IVEC1 and IVEC2 upper limits
-!! (J. Escobar & J.-P. Pinty)
-!! 11/12/98 contains and rewrite count+pack
-!! (J. Stein & J.-P. Pinty)
-!! 14/10/99 correction for very small RIT
-!! (J. Escobar & J.-P. Pinty)
-!! 24/07/00 correction for very samll m.r. in
-!! the sedimentation subroutine
-!! (M. Tomasini) 11/05/01 Autoconversion of rc into rr modification to take
-!! into account the subgrid variance
-!! (cf Redelsperger & Sommeria JAS 86)
-!! (G. Molinie) 21/05/99 bug in RRCFRIG process, RHODREF**(-1) missing
-!! in RSRIMCG
-!! (G. Molinie & J.-P. Pinty)
-!! 21/06/99 bug in RACCS process
-!! (P. Jabouille) 27/05/04 safety test for case where esw/i(T)> pabs (~Z>40km)
-!! (J-.P. Chaboureau) 12/02/05 temperature depending ice-to-snow autocon-
-! version threshold (Chaboureau and Pinty GRL 2006)
-!! (J.-P. Pinty) 01/01/O1 add the hail category and correction of the
-!! wet growth rate of the graupeln
-!! (S.Remy & C.Lac) 06/06 Add the cloud sedimentation
-!! (S.Remy & C.Lac) 06/06 Sedimentation becoming the last process
-!! to settle the precipitating species created during the current time step
-!! (S.Remy & C.Lac) 06/06 Modification of the algorithm of sedimentation
-!! to settle n times the precipitating species created during Dt/n instead
-!! of Dt
-!! (C.Lac) 11/06 Optimization of the sedimentation loop for NEC
-!! (J.Escobar) 18/01/2008 Parallel Bug in Budget when IMICRO >= 1
-!! --> Path inhibit this test by IMICRO >= 0 allway true
-!! (Y.Seity) 03/2008 Add Statistic sedimentation
-!! (Y.Seity) 10/2009 Added condition for the raindrop accretion of the aggregates
-!! into graupeln process (5.2.6) to avoid negative graupel mixing ratio
-!! (V.Masson, C.Lac) 09/2010 Correction in split sedimentation for
-!! reproducibility
-!! (S. Riette) Oct 2010 Better vectorisation of RAIN_ICE_SEDIMENTATION_STAT
-!! (Y. Seity), 02-2012 add possibility to run with reversed vertical levels
-!! (L. Bengtsson), 02-2013 Passing in land/sea mask and town fraction in
-!! order to use different cloud droplet number conc. over
-!! land, sea and urban areas in the cloud sedimentation.
-!! (D. Degrauwe), 2013-11: Export upper-air precipitation fluxes PFPR.
-!! (S. Riette) Nov 2013 Protection against null sigma
-!! (C. Lac) FIT temporal scheme : instant M removed
-!! (JP Pinty), 01-2014 : ICE4 : partial reconversion of hail to graupel
-!! July, 2015 (O.Nuissier/F.Duffourg) Add microphysics diagnostic for
-!! aircraft, ballon and profiler
-!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
-!! C.Lac : 10/2016 : add droplet deposition
-!! C.Lac : 01/2017 : correction on droplet deposition
-!! J.Escobar : 10/2017 : for real*4 , limit exp() in RAIN_ICE_SLOW with XMNH_HUGE_12_LOG
-!! (C. Abiven, Y. Léauté, V. Seigner, S. Riette) Phasing of Turner rain subgrid param
-!! (S. Riette) Source code split into several files
-!! 02/2019 C.Lac add rain fraction as an output field
-! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
-! P. Wautelet 28/05/2019: move COUNTJV function to tools.f90
-! P. Wautelet 29/05/2019: remove PACK/UNPACK intrinsics (to get more performance and better OpenACC support)
-! P. Wautelet 17/01/2020: move Quicksort to tools.f90
-! P. Wautelet 02/2020: use the new data structures and subroutines for budgets
-! P. Wautelet 25/02/2020: bugfix: add missing budget: WETH_BU_RRG
-!-----------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE PARKIND1, ONLY : JPRB
-USE YOMHOOK , ONLY : LHOOK, DR_HOOK
-
-use modd_budget, only: lbu_enable, &
- lbudget_th, lbudget_rv, lbudget_rc, lbudget_rr, lbudget_ri, lbudget_rs, lbudget_rg, lbudget_rh, &
- NBUDGET_TH, NBUDGET_RV, NBUDGET_RC, NBUDGET_RR, NBUDGET_RI, NBUDGET_RS, NBUDGET_RG, NBUDGET_RH, &
- tbudgets
-USE MODD_CST, ONLY: XCI,XCL,XCPD,XCPV,XLSTT,XLVTT,XTT
-USE MODD_PARAMETERS, ONLY: JPVEXT,XUNDEF
-USE MODD_PARAM_ICE, ONLY: CSUBG_PR_PDF,CSUBG_RC_RR_ACCR,CSUBG_RR_EVAP,LDEPOSC,LFEEDBACKT,LSEDIM_AFTER, &
- NMAXITER,XMRSTEP,XTSTEP_TS,XVDEPOSC
-USE MODD_RAIN_ICE_DESCR, ONLY: XRTMIN
-USE MODD_VAR_ll, ONLY: IP
-
-use mode_budget, only: Budget_store_add, Budget_store_init, Budget_store_end
-USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-USE MODE_MPPDB
-USE MODE_MSG
-use mode_tools, only: Countjv
-#ifdef MNH_OPENACC
-use mode_tools, only: Countjv_device
-#endif
-
-USE MODI_ICE4_NUCLEATION_WRAPPER
-USE MODI_ICE4_RAINFR_VERT
-USE MODI_ICE4_SEDIMENTATION_SPLIT
-USE MODI_ICE4_SEDIMENTATION_STAT
-USE MODI_ICE4_TENDENCIES
-
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-!
-!
-INTEGER, INTENT(IN) :: KIT, KJT, KKT ! arrays size
-INTEGER, INTENT(IN) :: KSIZE
-LOGICAL, INTENT(IN) :: OSEDIC ! Switch for droplet sedim.
-CHARACTER(LEN=4), INTENT(IN) :: HSEDIM ! Sedimentation scheme
-CHARACTER(LEN=4), INTENT(IN) :: HSUBG_AUCV_RC ! Kind of Subgrid autoconversion method
-CHARACTER(LEN=80), INTENT(IN) :: HSUBG_AUCV_RI ! Kind of Subgrid autoconversion method
-LOGICAL, INTENT(IN) :: OWARM ! .TRUE. allows raindrops to
- ! form by warm processes
- ! (Kessler scheme)
-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, INTENT(IN) :: PTSTEP ! Double Time step (single if cold start)
-INTEGER, INTENT(IN) :: KRR ! Number of moist variable
-LOGICAL, DIMENSION(:,:,:), INTENT(IN) :: ODMICRO ! mask to limit computation
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXN ! Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Layer thikness (m)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! absolute pressure at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIT ! Pristine ice n.c. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCLDFR ! Convective Mass Flux Cloud fraction
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLC_HRC
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLC_HCF
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLI_HRI
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PHLI_HCF
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel/hail m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
-!
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRC! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRR! Rain instant precip
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEVAP3D! Rain evap profile
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRS! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRG! Graupel instant precip
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRAINFR! Rain fraction
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at t
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN! Fraction that is town
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PINPRH! Hail instant precip
-REAL, DIMENSION(:,:,:,:), OPTIONAL, INTENT(OUT) :: PFPR ! upper-air precipitation fluxes
-!
-#ifdef MNH_COMPILER_CCE
-STOP "RAIN_ICE_RED TROP LENT A COMPILER AVEC CRAY/CCE >> 30 Minutes "
-STOP "ENLEVE LE ifdefMNH_COMPILER_CCE , SI VOUS EN AVEZ BESOIN sur GPU AMD "
-#else
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: IIB ! Define the domain where is
-INTEGER :: IIE ! the microphysical sources have to be computed
-INTEGER :: IJB !
-INTEGER :: IJE !
-INTEGER :: IKB, IKTB !
-INTEGER :: IKE, IKTE !
-!
-INTEGER :: IDX, JI, JJ, JK
-INTEGER :: IMICRO ! Case r_x>0 locations
-INTEGER :: JIU,JJU,JKU
-#ifndef MNH_OPENACC
-INTEGER, DIMENSION(:), allocatable :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-!Arrays for nucleation call outisde of ODMICRO points
-REAL, DIMENSION(:,:,:), allocatable :: ZW ! work array
-REAL, DIMENSION(:,:,:), allocatable :: ZT ! Temperature
-REAL, DIMENSION(:,:,:), allocatable :: &
- & ZZ_RVHENI_MR, & ! heterogeneous nucleation mixing ratio change
- & ZZ_RVHENI ! heterogeneous nucleation
-real, dimension(:,:,:), allocatable :: zw1, zw2, zw3, zw4, zw5, zw6 !Work arrays
-real, dimension(:,:,:), allocatable :: zz_diff
-REAL, DIMENSION(:,:,:), allocatable :: ZZ_LVFACT, ZZ_LSFACT, ZLSFACT3D
-!
-!Diagnostics
-REAL, DIMENSION(:,:,:), allocatable :: &
- & ZHLC_HCF3D,& ! HLCLOUDS cloud fraction in high water content part
- & ZHLC_LCF3D,& ! HLCLOUDS cloud fraction in low water content part
- & ZHLC_HRC3D,& ! HLCLOUDS cloud water content in high water content
- & ZHLC_LRC3D,& ! HLCLOUDS cloud water content in low water content
- & ZHLI_HCF3D,& ! HLCLOUDS cloud fraction in high ice content part
- & ZHLI_LCF3D,& ! HLCLOUDS cloud fraction in low ice content part
- & ZHLI_HRI3D,& ! HLCLOUDS cloud water content in high ice content
- & ZHLI_LRI3D ! HLCLOUDS cloud water content in high ice content
-
-REAL, DIMENSION(:,:), allocatable :: ZINPRI ! Pristine ice instant precip
-!
-!Packed variables
-REAL, DIMENSION(:), allocatable :: ZRVT, & ! Water vapor m.r. at t
- & ZRCT, & ! Cloud water m.r. at t
- & ZRRT, & ! Rain water m.r. at t
- & ZRIT, & ! Pristine ice m.r. at t
- & ZRST, & ! Snow/aggregate m.r. at t
- & ZRGT, & ! Graupel m.r. at t
- & ZRHT, & ! Hail m.r. at t
- & ZCIT, & ! Pristine ice conc. at t
- & ZTHT, & ! Potential temperature
- & ZRHODREF, & ! RHO Dry REFerence
- & ZZT, & ! Temperature
- & ZPRES, & ! Pressure
- & ZEXN, & ! EXNer Pressure
- & ZLSFACT, & ! L_s/(Pi*C_ph)
- & ZLVFACT, & ! L_v/(Pi*C_ph)
- & ZSIGMA_RC,& ! Standard deviation of rc at time t
- & ZCF, & ! Cloud fraction
- & ZHLC_HCF, & ! HLCLOUDS : fraction of High Cloud Fraction in grid
- & ZHLC_LCF, & ! HLCLOUDS : fraction of Low Cloud Fraction in grid
- ! note that ZCF = ZHLC_HCF + ZHLC_LCF
- & ZHLC_HRC, & ! HLCLOUDS : LWC that is High LWC in grid
- & ZHLC_LRC, & ! HLCLOUDS : LWC that is Low LWC in grid
- ! note that ZRC = ZHLC_HRC + ZHLC_LRC
- & ZHLI_HCF, &
- & ZHLI_LCF, &
- & ZHLI_HRI, &
- & ZHLI_LRI
-!
-!Output packed tendencies (for budgets only)
-REAL, DIMENSION(:), allocatable :: ZRVHENI_MR, & ! heterogeneous nucleation mixing ratio change
- & ZRCHONI, & ! Homogeneous nucleation
- & ZRRHONG_MR, & ! Spontaneous freezing mixing ratio change
- & ZRVDEPS, & ! Deposition on r_s,
- & ZRIAGGS, & ! Aggregation on r_s
- & ZRIAUTS, & ! Autoconversion of r_i for r_s production
- & ZRVDEPG, & ! Deposition on r_g
- & ZRCAUTR, & ! Autoconversion of r_c for r_r production
- & ZRCACCR, & ! Accretion of r_c for r_r production
- & ZRREVAV, & ! Evaporation of r_r
- & ZRIMLTC_MR, & ! Cloud ice melting mixing ratio change
- & ZRCBERI, & ! Bergeron-Findeisen effect
- & ZRHMLTR, & ! Melting of the hailstones
- & ZRSMLTG, & ! Conversion-Melting of the aggregates
- & ZRCMLTSR, & ! Cloud droplet collection onto aggregates by positive temperature
- & ZRRACCSS, ZRRACCSG, ZRSACCRG, & ! Rain accretion onto the aggregates
- & ZRCRIMSS, ZRCRIMSG, ZRSRIMCG, ZRSRIMCG_MR, & ! Cloud droplet riming of the aggregates
- & ZRICFRRG, ZRRCFRIG, ZRICFRR, & ! Rain contact freezing
- & ZRCWETG, ZRIWETG, ZRRWETG, ZRSWETG, & ! Graupel wet growth
- & ZRCDRYG, ZRIDRYG, ZRRDRYG, ZRSDRYG, & ! Graupel dry growth
- & ZRWETGH, & ! Conversion of graupel into hail
- & ZRWETGH_MR, & ! Conversion of graupel into hail, mr change
- & ZRGMLTR, & ! Melting of the graupel
- & ZRCWETH, ZRIWETH, ZRSWETH, ZRGWETH, ZRRWETH, & ! Dry growth of hailstone
- & ZRCDRYH, ZRIDRYH, ZRSDRYH, ZRRDRYH, ZRGDRYH, & ! Wet growth of hailstone
- & ZRDRYHG ! Conversion of hailstone into graupel
-!
-!Output packed total mixing ratio change (for budgets only)
-REAL, DIMENSION(:), allocatable :: ZTOT_RVHENI, & ! heterogeneous nucleation mixing ratio change
- & ZTOT_RCHONI, & ! Homogeneous nucleation
- & ZTOT_RRHONG, & ! Spontaneous freezing mixing ratio change
- & ZTOT_RVDEPS, & ! Deposition on r_s,
- & ZTOT_RIAGGS, & ! Aggregation on r_s
- & ZTOT_RIAUTS, & ! Autoconversion of r_i for r_s production
- & ZTOT_RVDEPG, & ! Deposition on r_g
- & ZTOT_RCAUTR, & ! Autoconversion of r_c for r_r production
- & ZTOT_RCACCR, & ! Accretion of r_c for r_r production
- & ZTOT_RREVAV, & ! Evaporation of r_r
- & ZTOT_RCRIMSS, ZTOT_RCRIMSG, ZTOT_RSRIMCG, & ! Cloud droplet riming of the aggregates
- & ZTOT_RIMLTC, & ! Cloud ice melting mixing ratio change
- & ZTOT_RCBERI, & ! Bergeron-Findeisen effect
- & ZTOT_RHMLTR, & ! Melting of the hailstones
- & ZTOT_RSMLTG, & ! Conversion-Melting of the aggregates
- & ZTOT_RCMLTSR, & ! Cloud droplet collection onto aggregates by positive temperature
- & ZTOT_RRACCSS, ZTOT_RRACCSG, ZTOT_RSACCRG, & ! Rain accretion onto the aggregates
- & ZTOT_RICFRRG, ZTOT_RRCFRIG, ZTOT_RICFRR, & ! Rain contact freezing
- & ZTOT_RCWETG, ZTOT_RIWETG, ZTOT_RRWETG, ZTOT_RSWETG, & ! Graupel wet growth
- & ZTOT_RCDRYG, ZTOT_RIDRYG, ZTOT_RRDRYG, ZTOT_RSDRYG, & ! Graupel dry growth
- & ZTOT_RWETGH, & ! Conversion of graupel into hail
- & ZTOT_RGMLTR, & ! Melting of the graupel
- & ZTOT_RCWETH, ZTOT_RIWETH, ZTOT_RSWETH, ZTOT_RGWETH, ZTOT_RRWETH, & ! Dry growth of hailstone
- & ZTOT_RCDRYH, ZTOT_RIDRYH, ZTOT_RSDRYH, ZTOT_RRDRYH, ZTOT_RGDRYH, & ! Wet growth of hailstone
- & ZTOT_RDRYHG ! Conversion of hailstone into graupel
-!
-!For time- or mixing-ratio- splitting
-REAL, DIMENSION(:), allocatable :: Z0RVT, & ! Water vapor m.r. at the beginig of the current loop
- & Z0RCT, & ! Cloud water m.r. at the beginig of the current loop
- & Z0RRT, & ! Rain water m.r. at the beginig of the current loop
- & Z0RIT, & ! Pristine ice m.r. at the beginig of the current loop
- & Z0RST, & ! Snow/aggregate m.r. at the beginig of the current loop
- & Z0RGT, & ! Graupel m.r. at the beginig of the current loop
- & Z0RHT, & ! Hail m.r. at the beginig of the current loop
- & ZA_TH, ZA_RV, ZA_RC, ZA_RR, ZA_RI, ZA_RS, ZA_RG, ZA_RH, &
- & ZB_TH, ZB_RV, ZB_RC, ZB_RR, ZB_RI, ZB_RS, ZB_RG, ZB_RH
-!
-!To take into acount external tendencies inside the splitting
-REAL, DIMENSION(:), allocatable :: ZEXT_RV, & ! External tendencie for rv
- ZEXT_RC, & ! External tendencie for rc
- ZEXT_RR, & ! External tendencie for rr
- ZEXT_RI, & ! External tendencie for ri
- ZEXT_RS, & ! External tendencie for rs
- ZEXT_RG, & ! External tendencie for rg
- ZEXT_RH, & ! External tendencie for rh
- ZEXT_TH ! External tendencie for th
-LOGICAL :: GEXT_TEND
-!
-INTEGER, DIMENSION(:), allocatable :: IITER ! Number of iterations done (with real tendencies computation)
-INTEGER :: INB_ITER_MAX ! Maximum number of iterations (with real tendencies computation)
-REAL, DIMENSION(:), allocatable :: ZTIME, & ! Current integration time (starts with 0 and ends with PTSTEP)
- & ZMAXTIME, & ! Time on which we can apply the current tendencies
- & ZTIME_THRESHOLD, & ! Time to reach threshold
- & ZTIME_LASTCALL ! Integration time when last tendecies call has been done
-REAL, DIMENSION(:), allocatable :: ZW1D
-REAL, DIMENSION(:), allocatable :: ZCOMPUTE ! Points where we must compute tendenceis
-LOGICAL :: GSOFT ! Must we really compute tendencies or only adjust them to new T variables
-LOGICAL, DIMENSION(:,:,:), allocatable :: GDNOTMICRO ! = .NOT.ODMICRO
-REAL :: ZTSTEP ! length of sub-timestep in case of time splitting
-REAL :: ZINV_TSTEP ! Inverse ov PTSTEP
-REAL, DIMENSION(:,:), allocatable :: ZRS_TEND
-REAL, DIMENSION(:,:), allocatable :: ZRG_TEND
-REAL, DIMENSION(:,:), allocatable :: ZRH_TEND
-REAL, DIMENSION(:), allocatable :: ZSSI
-!
-!For total tendencies computation
-REAL, DIMENSION(:,:,:), allocatable :: &
- &ZW_RVS, ZW_RCS, ZW_RRS, ZW_RIS, ZW_RSS, ZW_RGS, ZW_RHS, ZW_THS
-!
-REAL, DIMENSION(:,:,:), allocatable :: ZTEMP_BUD
-#else
-INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-!Arrays for nucleation call outisde of ODMICRO points
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZW ! work array
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZT ! Temperature
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: &
- & ZZ_RVHENI_MR, & ! heterogeneous nucleation mixing ratio change
- & ZZ_RVHENI ! heterogeneous nucleation
-real, dimension(:,:,:), POINTER, CONTIGUOUS :: zw1, zw2, zw3, zw4, zw5, zw6 !Work arrays
-real, dimension(:,:,:), POINTER, CONTIGUOUS :: zz_diff
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZZ_LVFACT, ZZ_LSFACT, ZLSFACT3D
-!
-!Diagnostics
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: &
- & ZHLC_HCF3D,& ! HLCLOUDS cloud fraction in high water content part
- & ZHLC_LCF3D,& ! HLCLOUDS cloud fraction in low water content part
- & ZHLC_HRC3D,& ! HLCLOUDS cloud water content in high water content
- & ZHLC_LRC3D,& ! HLCLOUDS cloud water content in low water content
- & ZHLI_HCF3D,& ! HLCLOUDS cloud fraction in high ice content part
- & ZHLI_LCF3D,& ! HLCLOUDS cloud fraction in low ice content part
- & ZHLI_HRI3D,& ! HLCLOUDS cloud water content in high ice content
- & ZHLI_LRI3D ! HLCLOUDS cloud water content in high ice content
-
-REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZINPRI ! Pristine ice instant precip
-!
-!Packed variables
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRVT, & ! Water vapor m.r. at t
- ZRCT, & ! Cloud water m.r. at t
- ZRRT, & ! Rain water m.r. at t
- ZRIT, & ! Pristine ice m.r. at t
- ZRST, & ! Snow/aggregate m.r. at t
- ZRGT, & ! Graupel m.r. at t
- ZRHT, & ! Hail m.r. at t
- ZCIT, & ! Pristine ice conc. at t
- ZTHT, & ! Potential temperature
- ZRHODREF, & ! RHO Dry REFerence
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXN, & ! EXNer Pressure
- ZLSFACT, & ! L_s/(Pi*C_ph)
- ZLVFACT, & ! L_v/(Pi*C_ph)
- ZSIGMA_RC,& ! Standard deviation of rc at time t
- ZCF, & ! Cloud fraction
- ZHLC_HCF, & ! HLCLOUDS : fraction of High Cloud Fraction in grid
- ZHLC_LCF, & ! HLCLOUDS : fraction of Low Cloud Fraction in grid
- ! note that ZCF = ZHLC_HCF + ZHLC_LCF
- ZHLC_HRC, & ! HLCLOUDS : LWC that is High LWC in grid
- ZHLC_LRC, & ! HLCLOUDS : LWC that is Low LWC in grid
- ! note that ZRC = ZHLC_HRC + ZHLC_LRC
- ZHLI_HCF, &
- ZHLI_LCF, &
- ZHLI_HRI, &
- ZHLI_LRI
-!
-!Output packed tendencies (for budgets only)
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRVHENI_MR, & ! heterogeneous nucleation mixing ratio change
- ZRCHONI, & ! Homogeneous nucleation
- ZRRHONG_MR, & ! Spontaneous freezing mixing ratio change
- ZRVDEPS, & ! Deposition on r_s,
- ZRIAGGS, & ! Aggregation on r_s
- ZRIAUTS, & ! Autoconversion of r_i for r_s production
- ZRVDEPG, & ! Deposition on r_g
- ZRCAUTR, & ! Autoconversion of r_c for r_r production
- ZRCACCR, & ! Accretion of r_c for r_r production
- ZRREVAV, & ! Evaporation of r_r
- ZRIMLTC_MR, & ! Cloud ice melting mixing ratio change
- ZRCBERI, & ! Bergeron-Findeisen effect
- ZRHMLTR, & ! Melting of the hailstones
- ZRSMLTG, & ! Conversion-Melting of the aggregates
- ZRCMLTSR, & ! Cloud droplet collection onto aggregates by positive temperature
- ZRRACCSS, ZRRACCSG, ZRSACCRG, & ! Rain accretion onto the aggregates
- ZRCRIMSS, ZRCRIMSG, ZRSRIMCG, ZRSRIMCG_MR, & ! Cloud droplet riming of the aggregates
- ZRICFRRG, ZRRCFRIG, ZRICFRR, & ! Rain contact freezing
- ZRCWETG, ZRIWETG, ZRRWETG, ZRSWETG, & ! Graupel wet growth
- ZRCDRYG, ZRIDRYG, ZRRDRYG, ZRSDRYG, & ! Graupel dry growth
- ZRWETGH, & ! Conversion of graupel into hail
- ZRWETGH_MR, & ! Conversion of graupel into hail, mr change
- ZRGMLTR, & ! Melting of the graupel
- ZRCWETH, ZRIWETH, ZRSWETH, ZRGWETH, ZRRWETH, & ! Dry growth of hailstone
- ZRCDRYH, ZRIDRYH, ZRSDRYH, ZRRDRYH, ZRGDRYH, & ! Wet growth of hailstone
- ZRDRYHG ! Conversion of hailstone into graupel
-!
-!Output packed total mixing ratio change (for budgets only)
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZTOT_RVHENI, & ! heterogeneous nucleation mixing ratio change
- ZTOT_RCHONI, & ! Homogeneous nucleation
- ZTOT_RRHONG, & ! Spontaneous freezing mixing ratio change
- ZTOT_RVDEPS, & ! Deposition on r_s,
- ZTOT_RIAGGS, & ! Aggregation on r_s
- ZTOT_RIAUTS, & ! Autoconversion of r_i for r_s production
- ZTOT_RVDEPG, & ! Deposition on r_g
- ZTOT_RCAUTR, & ! Autoconversion of r_c for r_r production
- ZTOT_RCACCR, & ! Accretion of r_c for r_r production
- ZTOT_RREVAV, & ! Evaporation of r_r
- ZTOT_RCRIMSS, ZTOT_RCRIMSG, ZTOT_RSRIMCG, & ! Cloud droplet riming of the aggregates
- ZTOT_RIMLTC, & ! Cloud ice melting mixing ratio change
- ZTOT_RCBERI, & ! Bergeron-Findeisen effect
- ZTOT_RHMLTR, & ! Melting of the hailstones
- ZTOT_RSMLTG, & ! Conversion-Melting of the aggregates
- ZTOT_RCMLTSR, & ! Cloud droplet collection onto aggregates by positive temperature
- ZTOT_RRACCSS, ZTOT_RRACCSG, ZTOT_RSACCRG, & ! Rain accretion onto the aggregates
- ZTOT_RICFRRG, ZTOT_RRCFRIG, ZTOT_RICFRR, & ! Rain contact freezing
- ZTOT_RCWETG, ZTOT_RIWETG, ZTOT_RRWETG, ZTOT_RSWETG, & ! Graupel wet growth
- ZTOT_RCDRYG, ZTOT_RIDRYG, ZTOT_RRDRYG, ZTOT_RSDRYG, & ! Graupel dry growth
- ZTOT_RWETGH, & ! Conversion of graupel into hail
- ZTOT_RGMLTR, & ! Melting of the graupel
- ZTOT_RCWETH, ZTOT_RIWETH, ZTOT_RSWETH, ZTOT_RGWETH, ZTOT_RRWETH, & ! Dry growth of hailstone
- ZTOT_RCDRYH, ZTOT_RIDRYH, ZTOT_RSDRYH, ZTOT_RRDRYH, ZTOT_RGDRYH, & ! Wet growth of hailstone
- ZTOT_RDRYHG ! Conversion of hailstone into graupel
-!
-!For time- or mixing-ratio- splitting
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: Z0RVT, & ! Water vapor m.r. at the beginig of the current loop
- Z0RCT, & ! Cloud water m.r. at the beginig of the current loop
- Z0RRT, & ! Rain water m.r. at the beginig of the current loop
- Z0RIT, & ! Pristine ice m.r. at the beginig of the current loop
- Z0RST, & ! Snow/aggregate m.r. at the beginig of the current loop
- Z0RGT, & ! Graupel m.r. at the beginig of the current loop
- Z0RHT, & ! Hail m.r. at the beginig of the current loop
- ZA_TH, ZA_RV, ZA_RC, ZA_RR, ZA_RI, ZA_RS, ZA_RG, ZA_RH, &
- ZB_TH, ZB_RV, ZB_RC, ZB_RR, ZB_RI, ZB_RS, ZB_RG, ZB_RH
-!
-!To take into acount external tendencies inside the splitting
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZEXT_RV, & ! External tendencie for rv
- ZEXT_RC, & ! External tendencie for rc
- ZEXT_RR, & ! External tendencie for rr
- ZEXT_RI, & ! External tendencie for ri
- ZEXT_RS, & ! External tendencie for rs
- ZEXT_RG, & ! External tendencie for rg
- ZEXT_RH, & ! External tendencie for rh
- ZEXT_TH ! External tendencie for th
-LOGICAL :: GEXT_TEND
-!
-INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: IITER ! Number of iterations done (with real tendencies computation)
-INTEGER :: INB_ITER_MAX ! Maximum number of iterations (with real tendencies computation)
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZTIME, & ! Current integration time (starts with 0 and ends with PTSTEP)
- ZMAXTIME, & ! Time on which we can apply the current tendencies
- ZTIME_THRESHOLD, & ! Time to reach threshold
- ZTIME_LASTCALL ! Integration time when last tendecies call has been done
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZW1D
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZCOMPUTE ! Points where we must compute tendenceis
-LOGICAL :: GSOFT ! Must we really compute tendencies or only adjust them to new T variables
-LOGICAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: GDNOTMICRO ! = .NOT.ODMICRO
-REAL :: ZTSTEP ! length of sub-timestep in case of time splitting
-REAL :: ZINV_TSTEP ! Inverse ov PTSTEP
-REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZRS_TEND
-REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZRG_TEND
-REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZRH_TEND
-REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZSSI
-!
-!For total tendencies computation
-REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: &
- &ZW_RVS, ZW_RCS, ZW_RRS, ZW_RIS, ZW_RSS, ZW_RGS, ZW_RHS, ZW_THS
-!
-REAL, DIMENSION(:,:,:), pointer, contiguous :: ZTEMP_BUD
-#endif
-!
-LOGICAL :: GTEST ! temporary variable for OpenACC character limitation (Cray CCE)
-
-!$acc data present( ODMICRO, PEXN, PDZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, PCIT, PCLDFR, &
-!$acc & PHLC_HRC, PTHT, PRVT, &
-!$acc & PRCT, PHLC_HCF, PHLI_HRI, PHLI_HCF, PRRT, PRIT, PRST, PRGT, PSIGS, &
-!$acc & PTHS, PRVS, PRCS, PRRS, PRIS, PRSS, PRGS, &
-!$acc & PINPRC, PINDEP, PINPRR, PEVAP3D, PINPRS, PINPRG, PRAINFR, &
-!$acc & PSEA, PTOWN, PRHT, PRHS, PINPRH, PFPR )
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(ODMICRO,"RAIN_ICE_RED beg:ODMICRO")
- CALL MPPDB_CHECK(PEXN,"RAIN_ICE_RED beg:PEXN")
- CALL MPPDB_CHECK(PDZZ,"RAIN_ICE_RED beg:PDZZ")
- CALL MPPDB_CHECK(PRHODJ,"RAIN_ICE_RED beg:PRHODJ")
- CALL MPPDB_CHECK(PRHODREF,"RAIN_ICE_RED beg:PRHODREF")
- CALL MPPDB_CHECK(PEXNREF,"RAIN_ICE_RED beg:PEXNREF")
- CALL MPPDB_CHECK(PPABST,"RAIN_ICE_RED beg:PPABST")
- CALL MPPDB_CHECK(PCLDFR,"RAIN_ICE_RED beg:PCLDFR")
- CALL MPPDB_CHECK(PHLC_HRC,"RAIN_ICE_RED beg:PHLC_HRC")
- CALL MPPDB_CHECK(PHLC_HCF,"RAIN_ICE_RED beg:PHLC_HCF")
- CALL MPPDB_CHECK(PHLI_HRI,"RAIN_ICE_RED beg:PHLI_HRI")
- CALL MPPDB_CHECK(PHLI_HCF,"RAIN_ICE_RED beg:PHLI_HCF")
- CALL MPPDB_CHECK(PTHT,"RAIN_ICE_RED beg:PTHT")
- CALL MPPDB_CHECK(PRVT,"RAIN_ICE_RED beg:PRVT")
- CALL MPPDB_CHECK(PRCT,"RAIN_ICE_RED beg:PRCT")
- CALL MPPDB_CHECK(PRRT,"RAIN_ICE_RED beg:PRRT")
- CALL MPPDB_CHECK(PRIT,"RAIN_ICE_RED beg:PRIT")
- CALL MPPDB_CHECK(PRST,"RAIN_ICE_RED beg:PRST")
- CALL MPPDB_CHECK(PRGT,"RAIN_ICE_RED beg:PRGT")
- CALL MPPDB_CHECK(PSIGS,"RAIN_ICE_RED beg:PSIGS")
- IF (PRESENT(PSEA)) CALL MPPDB_CHECK(PSEA,"RAIN_ICE_RED beg:PSEA")
- IF (PRESENT(PTOWN)) CALL MPPDB_CHECK(PTOWN,"RAIN_ICE_RED beg:PTOWN")
- IF (PRESENT(PRHT)) CALL MPPDB_CHECK(PRHT,"RAIN_ICE_RED beg:PRHT")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PCIT,"RAIN_ICE_RED beg:PCIT")
- CALL MPPDB_CHECK(PTHS,"RAIN_ICE_RED beg:PTHS")
- CALL MPPDB_CHECK(PRVS,"RAIN_ICE_RED beg:PRVS")
- CALL MPPDB_CHECK(PRCS,"RAIN_ICE_RED beg:PRCS")
- CALL MPPDB_CHECK(PRRS,"RAIN_ICE_RED beg:PRRS")
- CALL MPPDB_CHECK(PRIS,"RAIN_ICE_RED beg:PRIS")
- CALL MPPDB_CHECK(PRSS,"RAIN_ICE_RED beg:PRSS")
- CALL MPPDB_CHECK(PRGS,"RAIN_ICE_RED beg:PRGS")
- CALL MPPDB_CHECK(PINDEP,"RAIN_ICE_RED beg:PINDEP")
- IF (PRESENT(PRHS)) CALL MPPDB_CHECK(PRHS,"RAIN_ICE_RED beg:PRHS")
-END IF
-
-!$acc kernels
-imicro = count(odmicro)
-!$acc end kernels
-
-JIU = SIZE( ptht, 1 )
-JJU = SIZE( ptht, 2 )
-JKU = SIZE( ptht, 3 )
-
-#ifndef MNH_OPENACC
-allocate( i1(imicro ) )
-allocate( i2(imicro ) )
-allocate( i3(imicro ) )
-
-allocate( zw(size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
-allocate( zt(size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
-
-allocate( zz_rvheni_mr(jiu, jju, jku ) )
-allocate( zz_rvheni (jiu, jju, jku ) )
-allocate( zz_lvfact (jiu, jju, jku ) )
-allocate( zz_lsfact (jiu, jju, jku ) )
-allocate( zlsfact3d (jiu, jju, jku ) )
-
-allocate( ZHLC_HCF3D(jiu, jju, jku ) )
-allocate( ZHLC_LCF3D(jiu, jju, jku ) )
-allocate( ZHLC_HRC3D(jiu, jju, jku ) )
-allocate( ZHLC_LRC3D(jiu, jju, jku ) )
-allocate( ZHLI_HCF3D(jiu, jju, jku ) )
-allocate( ZHLI_LCF3D(jiu, jju, jku ) )
-allocate( ZHLI_HRI3D(jiu, jju, jku ) )
-allocate( ZHLI_LRI3D(jiu, jju, jku ) )
-
-allocate( zinpri(jiu, jju ) )
-
-allocate( zrvt (imicro ) )
-allocate( zrct (imicro ) )
-allocate( zrrt (imicro ) )
-allocate( zrit (imicro ) )
-allocate( zrst (imicro ) )
-allocate( zrgt (imicro ) )
-allocate( zrht (imicro ) )
-allocate( zcit (imicro ) )
-allocate( ztht (imicro ) )
-allocate( zrhodref (imicro ) )
-allocate( zzt (imicro ) )
-allocate( zpres (imicro ) )
-allocate( zexn (imicro ) )
-allocate( zlsfact (imicro ) )
-allocate( zlvfact (imicro ) )
-allocate( zsigma_rc(imicro ) )
-allocate( zcf (imicro ) )
-allocate( zhlc_hcf (imicro ) )
-allocate( zhlc_lcf (imicro ) )
-allocate( zhlc_hrc (imicro ) )
-allocate( zhlc_lrc (imicro ) )
-allocate( ZHLI_HCF (imicro ) )
-allocate( ZHLI_LCF (imicro ) )
-allocate( ZHLI_HRI (imicro ) )
-allocate( ZHLI_LRI (imicro ) )
-
-allocate( zrvheni_mr (imicro ) )
-allocate( zrchoni (imicro ) )
-allocate( zrrhong_mr (imicro ) )
-allocate( zrvdeps (imicro ) )
-allocate( zriaggs (imicro ) )
-allocate( zriauts (imicro ) )
-allocate( zrvdepg (imicro ) )
-allocate( zrcautr (imicro ) )
-allocate( zrcaccr (imicro ) )
-allocate( zrrevav (imicro ) )
-allocate( zrimltc_mr (imicro ) )
-allocate( zrcberi (imicro ) )
-allocate( zrhmltr (imicro ) )
-allocate( zrsmltg (imicro ) )
-allocate( zrcmltsr (imicro ) )
-allocate( zrraccss (imicro ) )
-allocate( zrraccsg (imicro ) )
-allocate( zrsaccrg (imicro ) )
-allocate( zrcrimss (imicro ) )
-allocate( zrcrimsg (imicro ) )
-allocate( zrsrimcg (imicro ) )
-allocate( zrsrimcg_mr(imicro ) )
-allocate( zricfrrg (imicro ) )
-allocate( zrrcfrig (imicro ) )
-allocate( zricfrr (imicro ) )
-allocate( zrcwetg (imicro ) )
-allocate( zriwetg (imicro ) )
-allocate( zrrwetg (imicro ) )
-allocate( zrswetg (imicro ) )
-allocate( zrcdryg (imicro ) )
-allocate( zridryg (imicro ) )
-allocate( zrrdryg (imicro ) )
-allocate( zrsdryg (imicro ) )
-allocate( zrwetgh (imicro ) )
-allocate( zrwetgh_mr (imicro ) )
-allocate( zrgmltr (imicro ) )
-allocate( zrcweth (imicro ) )
-allocate( zriweth (imicro ) )
-allocate( zrsweth (imicro ) )
-allocate( zrgweth (imicro ) )
-allocate( zrrweth (imicro ) )
-allocate( zrcdryh (imicro ) )
-allocate( zridryh (imicro ) )
-allocate( zrsdryh (imicro ) )
-allocate( zrrdryh (imicro ) )
-allocate( zrgdryh (imicro ) )
-allocate( zrdryhg (imicro ) )
-
-allocate( ztot_rvheni (imicro ) )
-allocate( ztot_rchoni (imicro ) )
-allocate( ztot_rrhong (imicro ) )
-allocate( ztot_rvdeps (imicro ) )
-allocate( ztot_riaggs (imicro ) )
-allocate( ztot_riauts (imicro ) )
-allocate( ztot_rvdepg (imicro ) )
-allocate( ztot_rcautr (imicro ) )
-allocate( ztot_rcaccr (imicro ) )
-allocate( ztot_rrevav (imicro ) )
-allocate( ztot_rcrimss(imicro ) )
-allocate( ztot_rcrimsg(imicro ) )
-allocate( ztot_rsrimcg(imicro ) )
-allocate( ztot_rimltc (imicro ) )
-allocate( ztot_rcberi (imicro ) )
-allocate( ztot_rhmltr (imicro ) )
-allocate( ztot_rsmltg (imicro ) )
-allocate( ztot_rcmltsr(imicro ) )
-allocate( ztot_rraccss(imicro ) )
-allocate( ztot_rraccsg(imicro ) )
-allocate( ztot_rsaccrg(imicro ) )
-allocate( ztot_ricfrrg(imicro ) )
-allocate( ztot_rrcfrig(imicro ) )
-allocate( ztot_ricfrr (imicro ) )
-allocate( ztot_rcwetg (imicro ) )
-allocate( ztot_riwetg (imicro ) )
-allocate( ztot_rrwetg (imicro ) )
-allocate( ztot_rswetg (imicro ) )
-allocate( ztot_rcdryg (imicro ) )
-allocate( ztot_ridryg (imicro ) )
-allocate( ztot_rrdryg (imicro ) )
-allocate( ztot_rsdryg (imicro ) )
-allocate( ztot_rwetgh (imicro ) )
-allocate( ztot_rgmltr (imicro ) )
-allocate( ztot_rcweth (imicro ) )
-allocate( ztot_riweth (imicro ) )
-allocate( ztot_rsweth (imicro ) )
-allocate( ztot_rgweth (imicro ) )
-allocate( ztot_rrweth (imicro ) )
-allocate( ztot_rcdryh (imicro ) )
-allocate( ztot_rdryhg (imicro ) )
-allocate( ztot_ridryh (imicro ) )
-allocate( ztot_rsdryh (imicro ) )
-allocate( ztot_rrdryh (imicro ) )
-allocate( ztot_rgdryh (imicro ) )
-
-allocate( z0rvt(imicro ) )
-allocate( z0rct(imicro ) )
-allocate( z0rrt(imicro ) )
-allocate( z0rit(imicro ) )
-allocate( z0rst(imicro ) )
-allocate( z0rgt(imicro ) )
-allocate( z0rht(imicro ) )
-allocate( za_th(imicro ) )
-allocate( za_rv(imicro ) )
-allocate( za_rc(imicro ) )
-allocate( za_rr(imicro ) )
-allocate( za_ri(imicro ) )
-allocate( za_rs(imicro ) )
-allocate( za_rg(imicro ) )
-allocate( za_rh(imicro ) )
-allocate( zb_th(imicro ) )
-allocate( zb_rv(imicro ) )
-allocate( zb_rc(imicro ) )
-allocate( zb_rr(imicro ) )
-allocate( zb_ri(imicro ) )
-allocate( zb_rs(imicro ) )
-allocate( zb_rg(imicro ) )
-allocate( zb_rh(imicro ) )
-
-allocate( zext_rv(imicro ) )
-allocate( zext_rc(imicro ) )
-allocate( zext_rr(imicro ) )
-allocate( zext_ri(imicro ) )
-allocate( zext_rs(imicro ) )
-allocate( zext_rg(imicro ) )
-allocate( zext_rh(imicro ) )
-allocate( zext_th(imicro ) )
-
-allocate( iiter(imicro ) )
-
-allocate( ztime(imicro ) )
-allocate( zmaxtime(imicro ) )
-allocate( ztime_threshold(imicro ) )
-allocate( ztime_lastcall(imicro ) )
-
-allocate( zw1d (imicro ) )
-allocate( zcompute(imicro ) )
-
-allocate( gdnotmicro(size( odmicro, 1 ), size( odmicro, 2 ), size( odmicro, 3 ) ) )
-
-allocate( zrs_tend(imicro, 8 ) )
-allocate( zrg_tend(imicro, 8 ) )
-allocate( zrh_tend(imicro, 10 ) )
-
-allocate( zssi(imicro ) )
-
-allocate( zw_rvs(jiu, jju, jku ) )
-allocate( zw_rcs(jiu, jju, jku ) )
-allocate( zw_rrs(jiu, jju, jku ) )
-allocate( zw_ris(jiu, jju, jku ) )
-allocate( zw_rss(jiu, jju, jku ) )
-allocate( zw_rgs(jiu, jju, jku ) )
-allocate( zw_rhs(jiu, jju, jku ) )
-allocate( zw_ths(jiu, jju, jku ) )
-allocate( ZTEMP_BUD(JIU,JJU,JKU) )
-#else
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN()
-
-CALL MNH_MEM_GET( i1, imicro )
-CALL MNH_MEM_GET( i2, imicro )
-CALL MNH_MEM_GET( i3, imicro )
-
-CALL MNH_MEM_GET( zw, size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) )
-CALL MNH_MEM_GET( zt, size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) )
-
-CALL MNH_MEM_GET( zz_rvheni_mr, jiu, jju, jku )
-CALL MNH_MEM_GET( zz_rvheni, jiu, jju, jku )
-CALL MNH_MEM_GET( zz_lvfact, jiu, jju, jku )
-CALL MNH_MEM_GET( zz_lsfact, jiu, jju, jku )
-CALL MNH_MEM_GET( zlsfact3d, jiu, jju, jku )
-
-CALL MNH_MEM_GET( ZHLC_HCF3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLC_LCF3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLC_HRC3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLC_LRC3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLI_HCF3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLI_LCF3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLI_HRI3D, jiu, jju, jku )
-CALL MNH_MEM_GET( ZHLI_LRI3D, jiu, jju, jku )
-
-CALL MNH_MEM_GET( zinpri, jiu, jju )
-
-CALL MNH_MEM_GET( zrvt , imicro )
-CALL MNH_MEM_GET( zrct , imicro )
-CALL MNH_MEM_GET( zrrt , imicro )
-CALL MNH_MEM_GET( zrit , imicro )
-CALL MNH_MEM_GET( zrst , imicro )
-CALL MNH_MEM_GET( zrgt , imicro )
-CALL MNH_MEM_GET( zrht , imicro )
-CALL MNH_MEM_GET( zcit , imicro )
-CALL MNH_MEM_GET( ztht , imicro )
-CALL MNH_MEM_GET( zrhodref , imicro )
-CALL MNH_MEM_GET( zzt , imicro )
-CALL MNH_MEM_GET( zpres , imicro )
-CALL MNH_MEM_GET( zexn , imicro )
-CALL MNH_MEM_GET( zlsfact , imicro )
-CALL MNH_MEM_GET( zlvfact , imicro )
-CALL MNH_MEM_GET( zsigma_rc, imicro )
-CALL MNH_MEM_GET( zcf , imicro )
-CALL MNH_MEM_GET( zhlc_hcf , imicro )
-CALL MNH_MEM_GET( zhlc_lcf , imicro )
-CALL MNH_MEM_GET( zhlc_hrc , imicro )
-CALL MNH_MEM_GET( zhlc_lrc , imicro )
-CALL MNH_MEM_GET( ZHLI_HCF , imicro )
-CALL MNH_MEM_GET( ZHLI_LCF , imicro )
-CALL MNH_MEM_GET( ZHLI_HRI , imicro )
-CALL MNH_MEM_GET( ZHLI_LRI , imicro )
-
-CALL MNH_MEM_GET( zrvheni_mr , imicro )
-CALL MNH_MEM_GET( zrchoni , imicro )
-CALL MNH_MEM_GET( zrrhong_mr , imicro )
-CALL MNH_MEM_GET( zrvdeps , imicro )
-CALL MNH_MEM_GET( zriaggs , imicro )
-CALL MNH_MEM_GET( zriauts , imicro )
-CALL MNH_MEM_GET( zrvdepg , imicro )
-CALL MNH_MEM_GET( zrcautr , imicro )
-CALL MNH_MEM_GET( zrcaccr , imicro )
-CALL MNH_MEM_GET( zrrevav , imicro )
-CALL MNH_MEM_GET( zrimltc_mr , imicro )
-CALL MNH_MEM_GET( zrcberi , imicro )
-CALL MNH_MEM_GET( zrhmltr , imicro )
-CALL MNH_MEM_GET( zrsmltg , imicro )
-CALL MNH_MEM_GET( zrcmltsr , imicro )
-CALL MNH_MEM_GET( zrraccss , imicro )
-CALL MNH_MEM_GET( zrraccsg , imicro )
-CALL MNH_MEM_GET( zrsaccrg , imicro )
-CALL MNH_MEM_GET( zrcrimss , imicro )
-CALL MNH_MEM_GET( zrcrimsg , imicro )
-CALL MNH_MEM_GET( zrsrimcg , imicro )
-CALL MNH_MEM_GET( zrsrimcg_mr, imicro )
-CALL MNH_MEM_GET( zricfrrg , imicro )
-CALL MNH_MEM_GET( zrrcfrig , imicro )
-CALL MNH_MEM_GET( zricfrr , imicro )
-CALL MNH_MEM_GET( zrcwetg , imicro )
-CALL MNH_MEM_GET( zriwetg , imicro )
-CALL MNH_MEM_GET( zrrwetg , imicro )
-CALL MNH_MEM_GET( zrswetg , imicro )
-CALL MNH_MEM_GET( zrcdryg , imicro )
-CALL MNH_MEM_GET( zridryg , imicro )
-CALL MNH_MEM_GET( zrrdryg , imicro )
-CALL MNH_MEM_GET( zrsdryg , imicro )
-CALL MNH_MEM_GET( zrwetgh , imicro )
-CALL MNH_MEM_GET( zrwetgh_mr , imicro )
-CALL MNH_MEM_GET( zrgmltr , imicro )
-CALL MNH_MEM_GET( zrcweth , imicro )
-CALL MNH_MEM_GET( zriweth , imicro )
-CALL MNH_MEM_GET( zrsweth , imicro )
-CALL MNH_MEM_GET( zrgweth , imicro )
-CALL MNH_MEM_GET( zrrweth , imicro )
-CALL MNH_MEM_GET( zrcdryh , imicro )
-CALL MNH_MEM_GET( zridryh , imicro )
-CALL MNH_MEM_GET( zrsdryh , imicro )
-CALL MNH_MEM_GET( zrrdryh , imicro )
-CALL MNH_MEM_GET( zrgdryh , imicro )
-CALL MNH_MEM_GET( zrdryhg , imicro )
-
-CALL MNH_MEM_GET( ztot_rvheni , imicro )
-CALL MNH_MEM_GET( ztot_rchoni , imicro )
-CALL MNH_MEM_GET( ztot_rrhong , imicro )
-CALL MNH_MEM_GET( ztot_rvdeps , imicro )
-CALL MNH_MEM_GET( ztot_riaggs , imicro )
-CALL MNH_MEM_GET( ztot_riauts , imicro )
-CALL MNH_MEM_GET( ztot_rvdepg , imicro )
-CALL MNH_MEM_GET( ztot_rcautr , imicro )
-CALL MNH_MEM_GET( ztot_rcaccr , imicro )
-CALL MNH_MEM_GET( ztot_rrevav , imicro )
-CALL MNH_MEM_GET( ztot_rcrimss, imicro )
-CALL MNH_MEM_GET( ztot_rcrimsg, imicro )
-CALL MNH_MEM_GET( ztot_rsrimcg, imicro )
-CALL MNH_MEM_GET( ztot_rimltc , imicro )
-CALL MNH_MEM_GET( ztot_rcberi , imicro )
-CALL MNH_MEM_GET( ztot_rhmltr , imicro )
-CALL MNH_MEM_GET( ztot_rsmltg , imicro )
-CALL MNH_MEM_GET( ztot_rcmltsr, imicro )
-CALL MNH_MEM_GET( ztot_rraccss, imicro )
-CALL MNH_MEM_GET( ztot_rraccsg, imicro )
-CALL MNH_MEM_GET( ztot_rsaccrg, imicro )
-CALL MNH_MEM_GET( ztot_ricfrrg, imicro )
-CALL MNH_MEM_GET( ztot_rrcfrig, imicro )
-CALL MNH_MEM_GET( ztot_ricfrr , imicro )
-CALL MNH_MEM_GET( ztot_rcwetg , imicro )
-CALL MNH_MEM_GET( ztot_riwetg , imicro )
-CALL MNH_MEM_GET( ztot_rrwetg , imicro )
-CALL MNH_MEM_GET( ztot_rswetg , imicro )
-CALL MNH_MEM_GET( ztot_rcdryg , imicro )
-CALL MNH_MEM_GET( ztot_ridryg , imicro )
-CALL MNH_MEM_GET( ztot_rrdryg , imicro )
-CALL MNH_MEM_GET( ztot_rsdryg , imicro )
-CALL MNH_MEM_GET( ztot_rwetgh , imicro )
-CALL MNH_MEM_GET( ztot_rgmltr , imicro )
-CALL MNH_MEM_GET( ztot_rcweth , imicro )
-CALL MNH_MEM_GET( ztot_riweth , imicro )
-CALL MNH_MEM_GET( ztot_rsweth , imicro )
-CALL MNH_MEM_GET( ztot_rgweth , imicro )
-CALL MNH_MEM_GET( ztot_rrweth , imicro )
-CALL MNH_MEM_GET( ztot_rcdryh , imicro )
-CALL MNH_MEM_GET( ztot_rdryhg , imicro )
-CALL MNH_MEM_GET( ztot_ridryh , imicro )
-CALL MNH_MEM_GET( ztot_rsdryh , imicro )
-CALL MNH_MEM_GET( ztot_rrdryh , imicro )
-CALL MNH_MEM_GET( ztot_rgdryh , imicro )
-
-CALL MNH_MEM_GET( z0rvt, imicro )
-CALL MNH_MEM_GET( z0rct, imicro )
-CALL MNH_MEM_GET( z0rrt, imicro )
-CALL MNH_MEM_GET( z0rit, imicro )
-CALL MNH_MEM_GET( z0rst, imicro )
-CALL MNH_MEM_GET( z0rgt, imicro )
-CALL MNH_MEM_GET( z0rht, imicro )
-CALL MNH_MEM_GET( za_th, imicro )
-CALL MNH_MEM_GET( za_rv, imicro )
-CALL MNH_MEM_GET( za_rc, imicro )
-CALL MNH_MEM_GET( za_rr, imicro )
-CALL MNH_MEM_GET( za_ri, imicro )
-CALL MNH_MEM_GET( za_rs, imicro )
-CALL MNH_MEM_GET( za_rg, imicro )
-CALL MNH_MEM_GET( za_rh, imicro )
-CALL MNH_MEM_GET( zb_th, imicro )
-CALL MNH_MEM_GET( zb_rv, imicro )
-CALL MNH_MEM_GET( zb_rc, imicro )
-CALL MNH_MEM_GET( zb_rr, imicro )
-CALL MNH_MEM_GET( zb_ri, imicro )
-CALL MNH_MEM_GET( zb_rs, imicro )
-CALL MNH_MEM_GET( zb_rg, imicro )
-CALL MNH_MEM_GET( zb_rh, imicro )
-
-CALL MNH_MEM_GET( zext_rv, imicro )
-CALL MNH_MEM_GET( zext_rc, imicro )
-CALL MNH_MEM_GET( zext_rr, imicro )
-CALL MNH_MEM_GET( zext_ri, imicro )
-CALL MNH_MEM_GET( zext_rs, imicro )
-CALL MNH_MEM_GET( zext_rg, imicro )
-CALL MNH_MEM_GET( zext_rh, imicro )
-CALL MNH_MEM_GET( zext_th, imicro )
-
-CALL MNH_MEM_GET( iiter, imicro )
-
-CALL MNH_MEM_GET( ztime, imicro )
-CALL MNH_MEM_GET( zmaxtime, imicro )
-CALL MNH_MEM_GET( ztime_threshold, imicro )
-CALL MNH_MEM_GET( ztime_lastcall, imicro )
-
-CALL MNH_MEM_GET( zw1d, imicro )
-CALL MNH_MEM_GET( zcompute, imicro )
-
-CALL MNH_MEM_GET( gdnotmicro, size( odmicro, 1 ), size( odmicro, 2 ), size( odmicro, 3 ) )
-
-CALL MNH_MEM_GET( zrs_tend, imicro, 8 )
-CALL MNH_MEM_GET( zrg_tend, imicro, 8 )
-CALL MNH_MEM_GET( zrh_tend, imicro, 10 )
-
-CALL MNH_MEM_GET( zssi, imicro )
-
-CALL MNH_MEM_GET( zw_rvs, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_rcs, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_rrs, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_ris, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_rss, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_rgs, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_rhs, jiu, jju, jku )
-CALL MNH_MEM_GET( zw_ths, jiu, jju, jku )
-CALL MNH_MEM_GET( ZTEMP_BUD, JIU, JJU, JKU )
-!$acc data present( I1, I2, I3, &
-!$acc & ZW, ZT, ZZ_RVHENI_MR, ZZ_RVHENI, ZZ_LVFACT, ZZ_LSFACT, ZLSFACT3D, ZINPRI, &
-!$acc & ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZRHT, ZCIT, ZTHT, ZRHODREF, ZZT, ZPRES, ZEXN, &
-!$acc & ZLSFACT, ZLVFACT, &
-!$acc & ZHLC_HCF3D, ZHLC_LCF3D, ZHLC_HRC3D, ZHLC_LRC3D, ZHLI_HCF3D, ZHLI_LCF3D, ZHLI_HRI3D, ZHLI_LRI3D, &
-!$acc & ZSIGMA_RC, ZCF, ZHLC_HCF, ZHLC_LCF, ZHLC_HRC, ZHLC_LRC, ZHLI_HCF, ZHLI_LCF, ZHLI_HRI, ZHLI_LRI, &
-!$acc & ZRVHENI_MR, ZRCHONI, ZRRHONG_MR, ZRVDEPS, ZRIAGGS, ZRIAUTS, ZRVDEPG, ZRCAUTR, ZRCACCR, ZRREVAV, ZRIMLTC_MR, &
-!$acc & ZRCBERI, ZRHMLTR, ZRSMLTG, ZRCMLTSR, ZRRACCSS, ZRRACCSG, ZRSACCRG, &
-!$acc & ZRCRIMSS, ZRCRIMSG, ZRSRIMCG, ZRSRIMCG_MR, &
-!$acc & ZRICFRRG, ZRRCFRIG, ZRICFRR, ZRCWETG, ZRIWETG, ZRRWETG, ZRSWETG, ZRCDRYG, ZRIDRYG, ZRRDRYG, ZRSDRYG, &
-!$acc & ZRWETGH, ZRWETGH_MR, ZRGMLTR, ZRCWETH, ZRIWETH, ZRSWETH, ZRGWETH, ZRRWETH, &
-!$acc & ZRCDRYH, ZRIDRYH, ZRSDRYH, ZRRDRYH, ZRGDRYH, ZRDRYHG, &
-!$acc & ZTOT_RVHENI, ZTOT_RCHONI, ZTOT_RRHONG, ZTOT_RVDEPS, ZTOT_RIAGGS, ZTOT_RIAUTS, ZTOT_RVDEPG, ZTOT_RCAUTR, &
-!$acc & ZTOT_RCACCR, ZTOT_RREVAV, ZTOT_RCRIMSS, ZTOT_RCRIMSG, ZTOT_RSRIMCG, ZTOT_RIMLTC, ZTOT_RCBERI, ZTOT_RHMLTR, &
-!$acc & ZTOT_RSMLTG, ZTOT_RCMLTSR, ZTOT_RRACCSS, ZTOT_RRACCSG, ZTOT_RSACCRG, ZTOT_RICFRRG, ZTOT_RRCFRIG, &
-!$acc & ZTOT_RICFRR, ZTOT_RCWETG, ZTOT_RIWETG, ZTOT_RRWETG, ZTOT_RSWETG, ZTOT_RCDRYG, ZTOT_RIDRYG, ZTOT_RRDRYG, &
-!$acc & ZTOT_RSDRYG, ZTOT_RWETGH, ZTOT_RGMLTR, ZTOT_RCWETH, ZTOT_RIWETH, ZTOT_RSWETH, ZTOT_RGWETH, ZTOT_RRWETH, &
-!$acc & ZTOT_RCDRYH, ZTOT_RIDRYH, ZTOT_RSDRYH, ZTOT_RRDRYH, ZTOT_RGDRYH, ZTOT_RDRYHG, &
-!$acc & Z0RVT, Z0RCT, Z0RRT, Z0RIT, Z0RST, Z0RGT, Z0RHT, &
-!$acc & ZA_TH, ZA_RV, ZA_RC, ZA_RR, ZA_RI, ZA_RS, ZA_RG, ZA_RH, &
-!$acc & ZB_TH, ZB_RV, ZB_RC, ZB_RR, ZB_RI, ZB_RS, ZB_RG, ZB_RH, &
-!$acc & ZEXT_RV, ZEXT_RC, ZEXT_RR, ZEXT_RI, ZEXT_RS, ZEXT_RG, ZEXT_RH, ZEXT_TH, &
-!$acc & IITER, ZTIME, ZMAXTIME, ZTIME_THRESHOLD, ZTIME_LASTCALL, ZW1D, ZCOMPUTE, GDNOTMICRO, &
-!$acc & ZRS_TEND, ZRG_TEND, ZRH_TEND, ZSSI, ZW_RVS, ZW_RCS, ZW_RRS, ZW_RIS, ZW_RSS, ZW_RGS, ZW_RHS, ZW_THS, &
-!$acc & ZTEMP_BUD )
-#endif
-
-!-------------------------------------------------------------------------------
-if ( lbu_enable ) then
- if ( lbudget_th ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = pths(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_TH), 'HENU', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rv ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prvs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RV), 'HENU', ZTEMP_BUD(:,:,:) )
- end if
-end if
-!-------------------------------------------------------------------------------
-!
-!* 1. COMPUTE THE LOOP BOUNDS
-! -----------------------
-!
-CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
-#ifdef MNH_COMPILER_CCE
-!$acc kernels present(ZRS_TEND,ZRG_TEND,ZRH_TEND,ZRCHONI,ZRVDEPS,ZRIAGGS,ZRIAUTS, &
-!$acc & ZRVDEPG,ZRCAUTR,ZRCACCR,ZRREVAV,ZRSMLTG,ZRCMLTSR,ZRICFRRG, &
-!$acc & ZRRCFRIG,ZRICFRR,ZRGMLTR,ZRHMLTR,ZRCBERI)
-#else
-!$acc kernels
-#endif
-IKB=KKA+JPVEXT*KKL
-IKE=KKU-JPVEXT*KKL
-IKTB=1+JPVEXT
-IKTE=KKT-JPVEXT
-!
-ZINV_TSTEP=1./PTSTEP
-GEXT_TEND=.TRUE.
-!
-!Not necessary (done in ICE4_TENDENCIES when GSOFT=.FALSE.)
-!but useful for calls to MPPDB_CHECK
-ZRS_TEND(:,:) = 0.
-ZRG_TEND(:,:) = 0.
-ZRH_TEND(:,:) = 0.
-ZRCHONI(:) = 0.
-ZRVDEPS(:) = 0.
-ZRIAGGS(:) = 0.
-ZRIAUTS(:) = 0.
-ZRVDEPG(:) = 0.
-ZRCAUTR(:) = 0.
-ZRCACCR(:) = 0.
-ZRREVAV(:) = 0.
-ZRSMLTG(:) = 0.
-ZRCMLTSR(:)= 0.
-ZRICFRRG(:) = 0.
-ZRRCFRIG(:) = 0.
-ZRICFRR(:) = 0.
-ZRGMLTR(:) = 0.
-ZRHMLTR(:) = 0.
-ZRCBERI(:) = 0.
-!
-! LSFACT and LVFACT without exner
-IF(KRR==7) THEN
-!$acc loop independent collapse(3)
- DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ZT(JI,JJ,JK) = PTHT(JI,JJ,JK) * PEXN(JI,JJ,JK)
- ZZ_LSFACT(JI,JJ,JK)=(XLSTT+(XCPV-XCI)*(ZT(JI,JJ,JK)-XTT)) &
- /( XCPD + XCPV*PRVT(JI,JJ,JK) + XCL*(PRCT(JI,JJ,JK)+PRRT(JI,JJ,JK)) &
- + XCI*(PRIT(JI,JJ,JK)+PRST(JI,JJ,JK)+PRGT(JI,JJ,JK)+PRHT(JI,JJ,JK)))
- ZZ_LVFACT(JI,JJ,JK)=(XLVTT+(XCPV-XCL)*(ZT(JI,JJ,JK)-XTT)) &
- /( XCPD + XCPV*PRVT(JI,JJ,JK) + XCL*(PRCT(JI,JJ,JK)+PRRT(JI,JJ,JK)) &
- + XCI*(PRIT(JI,JJ,JK)+PRST(JI,JJ,JK)+PRGT(JI,JJ,JK)+PRHT(JI,JJ,JK)))
- ENDDO
- ENDDO
- ENDDO
-ELSE
-!$acc loop independent collapse(3)
- DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ZT(JI,JJ,JK) = PTHT(JI,JJ,JK) * PEXN(JI,JJ,JK)
- ZZ_LSFACT(JI,JJ,JK)=(XLSTT+(XCPV-XCI)*(ZT(JI,JJ,JK)-XTT)) &
- /( XCPD + XCPV*PRVT(JI,JJ,JK) + XCL*(PRCT(JI,JJ,JK)+PRRT(JI,JJ,JK)) &
- + XCI*(PRIT(JI,JJ,JK)+PRST(JI,JJ,JK)+PRGT(JI,JJ,JK)))
- ZZ_LVFACT(JI,JJ,JK)=(XLVTT+(XCPV-XCL)*(ZT(JI,JJ,JK)-XTT)) &
- /( XCPD + XCPV*PRVT(JI,JJ,JK) + XCL*(PRCT(JI,JJ,JK)+PRRT(JI,JJ,JK)) &
- + XCI*(PRIT(JI,JJ,JK)+PRST(JI,JJ,JK)+PRGT(JI,JJ,JK)))
- ENDDO
- ENDDO
- ENDDO
-ENDIF
-!$acc end kernels
-!
-!-------------------------------------------------------------------------------
-!
-!* 2. COMPUTE THE SEDIMENTATION (RS) SOURCE
-! -------------------------------------
-!
-IF(.NOT. LSEDIM_AFTER) THEN
- !
- !* 2.1 sedimentation
- !
- if ( lbudget_rc .and. osedic ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RC), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rr ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prrs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RR), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_ri ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = pris(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RI), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rs ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prss(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RS), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rg ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prgs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RG), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rh ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prhs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RH), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
-
- !Init only if not osedic (to prevent crash with double init)
- !Remark: the 2 source terms SEDI and DEPO could be mixed and stored in the same source term (SEDI)
- ! if osedic=T and ldeposc=T (a warning is printed in ini_budget in that case)
- if ( lbudget_rc .and. ldeposc .and. .not.osedic ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_init( tbudgets(NBUDGET_RC), 'DEPO', ZTEMP_BUD(:,:,:) )
- end if
-
- IF(HSEDIM=='STAT') THEN
-#ifdef MNH_OPENACC
- CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_RED','OpenACC: HSEDIM=STAT not yet implemented')
-#endif
- !SR: It *seems* that we must have two separate calls for ifort
- IF(KRR==7) THEN
- CALL ICE4_SEDIMENTATION_STAT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCS*PTSTEP, PRRS, PRRS*PTSTEP, PRIS, PRIS*PTSTEP,&
- &PRSS, PRSS*PTSTEP, PRGS, PRGS*PTSTEP,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PINPRH=PINPRH, PRHT=PRHS*PTSTEP, PRHS=PRHS, PFPR=PFPR)
- ELSE
- CALL ICE4_SEDIMENTATION_STAT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCS*PTSTEP, PRRS, PRRS*PTSTEP, PRIS, PRIS*PTSTEP,&
- &PRSS, PRSS*PTSTEP, PRGS, PRGS*PTSTEP,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PFPR=PFPR)
- ENDIF
-!$acc kernels
- PINPRS(:,:) = PINPRS(:,:) + ZINPRI(:,:)
-!$acc end kernels
- !No negativity correction here as we apply sedimentation on PR.S*PTSTEP variables
- ELSEIF(HSEDIM=='SPLI') THEN
- !SR: It *seems* that we must have two separate calls for ifort
- IF(KRR==7) THEN
- CALL ICE4_SEDIMENTATION_SPLIT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCT, PRRS, PRRT, PRIS, PRIT, PRSS, PRST, PRGS, PRGT,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PINPRH=PINPRH, PRHT=PRHT, PRHS=PRHS, PFPR=PFPR)
- ELSE
- CALL ICE4_SEDIMENTATION_SPLIT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCT, PRRS, PRRT, PRIS, PRIT, PRSS, PRST, PRGS, PRGT,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PFPR=PFPR)
- ENDIF
-!$acc kernels
- PINPRS(:,:) = PINPRS(:,:) + ZINPRI(:,:)
-!$acc end kernels
- !We correct negativities with conservation
- !SPLI algorith uses a time-splitting. Inside the loop a temporary m.r. is used.
- ! It is initialized with the m.r. at T and is modified by two tendencies:
- ! sedimentation tendency and an external tendency which represents all other
- ! processes (mainly advection and microphysical processes). If both tendencies
- ! are negative, sedimentation can remove a specie at a given sub-timestep. From
- ! this point sedimentation stops for the remaining sub-timesteps but the other tendency
- ! will be still active and will lead to negative values.
- ! We could prevent the algorithm to not consume too much a specie, instead we apply
- ! a correction here.
- CALL CORRECT_NEGATIVITIES(KIT, KJT, KKT, KRR, PRVS, PRCS, PRRS, &
- &PRIS, PRSS, PRGS, &
- &PTHS, ZZ_LVFACT, ZZ_LSFACT, PRHS)
- ELSEIF(HSEDIM=='NONE') THEN
- ELSE
- call Print_msg( NVERB_FATAL, 'GEN', 'RAIN_ICE_RED', 'no sedimentation scheme for HSEDIM='//HSEDIM )
- END IF
- !
- !* 2.2 budget storage
- !
- if ( lbudget_rc .and. osedic ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RC), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rr ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prrs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RR), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_ri ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = pris(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RI), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rs ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prss(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RS), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rg ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prgs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RG), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rh ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prhs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RH), 'SEDI', ZTEMP_BUD(:,:,:) )
- end if
-
- !If osedic=T and ldeposc=T, DEPO is in fact mixed and stored with the SEDI source term
- !(a warning is printed in ini_budget in that case)
- if ( lbudget_rc .and. ldeposc .and. .not.osedic) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prcs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RC), 'DEPO', ZTEMP_BUD(:,:,:) )
- end if
-ENDIF
-!
-!-------------------------------------------------------------------------------
-!
-!* 3. PACKING
-! --------
-! optimization by looking for locations where
-! the microphysical fields are larger than a minimal value only !!!
-!
-#ifndef MNH_OPENACC
-IMICRO=COUNTJV(ODMICRO(:,:,:), I1(:), I2(:), I3(:))
-#else
-CALL COUNTJV_DEVICE(ODMICRO(:,:,:),I1(:),I2(:),I3(:),IMICRO)
-#endif
-!Packing
-GTEST=.false.
-IF(HSUBG_AUCV_RC=='PDF ' .AND. CSUBG_PR_PDF=='SIGM') GTEST=.true.
-#ifdef MNH_COMPILER_CCE
-!$acc kernels present(ZSIGMA_RC,ZRHT,ZEXT_RH, &
-!$acc & ZTOT_RVHENI, ZTOT_RCHONI, ZTOT_RRHONG, ZTOT_RVDEPS, ZTOT_RIAGGS, ZTOT_RIAUTS, ZTOT_RVDEPG, ZTOT_RCAUTR, &
-!$acc & ZTOT_RCACCR, ZTOT_RREVAV, ZTOT_RCRIMSS, ZTOT_RCRIMSG, ZTOT_RSRIMCG, ZTOT_RIMLTC, ZTOT_RCBERI, ZTOT_RHMLTR, &
-!$acc & ZTOT_RSMLTG, ZTOT_RCMLTSR, ZTOT_RRACCSS, ZTOT_RRACCSG, ZTOT_RSACCRG, ZTOT_RICFRRG, ZTOT_RRCFRIG, &
-!$acc & ZTOT_RICFRR, ZTOT_RCWETG, ZTOT_RIWETG, ZTOT_RRWETG, ZTOT_RSWETG, ZTOT_RCDRYG, ZTOT_RIDRYG, ZTOT_RRDRYG, &
-!$acc & ZTOT_RSDRYG, ZTOT_RWETGH, ZTOT_RGMLTR, ZTOT_RCWETH, ZTOT_RIWETH, ZTOT_RSWETH, ZTOT_RGWETH, ZTOT_RRWETH, &
-!$acc & ZTOT_RCDRYH, ZTOT_RIDRYH, ZTOT_RSDRYH, ZTOT_RRDRYH, ZTOT_RGDRYH, ZTOT_RDRYHG)
-#else
-!$acc kernels
-#endif
-
-IF(IMICRO>0) THEN
-!acc loop independent
- !$mnh_do_concurrent(JL=1:IMICRO)
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZRST(JL) = PRST(I1(JL),I2(JL),I3(JL))
- ZRGT(JL) = PRGT(I1(JL),I2(JL),I3(JL))
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
- ZCF(JL) = PCLDFR(I1(JL),I2(JL),I3(JL))
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- ZTHT(JL) = PTHT(I1(JL),I2(JL),I3(JL))
- ZPRES(JL) = PPABST(I1(JL),I2(JL),I3(JL))
- ZEXN(JL) = PEXN(I1(JL),I2(JL),I3(JL))
- ZHLC_HCF(JL) = PHLC_HCF(I1(JL),I2(JL),I3(JL))
- ZHLC_HRC(JL) = PHLC_HRC(I1(JL),I2(JL),I3(JL))
- ZHLC_LRC(JL) = ZRCT(JL) - ZHLC_HRC(JL)
- ZHLI_HCF(JL) = PHLI_HCF(I1(JL),I2(JL),I3(JL))
- ZHLI_HRI(JL) = PHLI_HRI(I1(JL),I2(JL),I3(JL))
- ZHLI_LRI(JL) = ZRIT(JL) - ZHLI_HRI(JL)
- IF(ZRCT(JL)>0.) THEN
- ZHLC_LCF(JL) = ZCF(JL)- ZHLC_HCF(JL)
- ELSE
- ZHLC_LCF(JL)=0.
- ENDIF
- IF(ZRIT(JL)>0.) THEN
- ZHLI_LCF(JL) = ZCF(JL)- ZHLI_HCF(JL)
- ELSE
- ZHLI_LCF(JL)=0.
- ENDIF
- !$mnh_end_do()
- IF(GEXT_TEND) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZEXT_RV(JL) = PRVS(I1(JL),I2(JL),I3(JL)) - ZRVT(JL)*ZINV_TSTEP
- ZEXT_RC(JL) = PRCS(I1(JL),I2(JL),I3(JL)) - ZRCT(JL)*ZINV_TSTEP
- ZEXT_RR(JL) = PRRS(I1(JL),I2(JL),I3(JL)) - ZRRT(JL)*ZINV_TSTEP
- ZEXT_RI(JL) = PRIS(I1(JL),I2(JL),I3(JL)) - ZRIT(JL)*ZINV_TSTEP
- ZEXT_RS(JL) = PRSS(I1(JL),I2(JL),I3(JL)) - ZRST(JL)*ZINV_TSTEP
- ZEXT_RG(JL) = PRGS(I1(JL),I2(JL),I3(JL)) - ZRGT(JL)*ZINV_TSTEP
- ZEXT_TH(JL) = PTHS(I1(JL),I2(JL),I3(JL)) - ZTHT(JL)*ZINV_TSTEP
- !The th tendency is not related to a mixing ratio change, there is no exn/exnref issue here
- ENDDO
- ENDIF
- !IF(HSUBG_AUCV_RC=='PDF ' .AND. CSUBG_PR_PDF=='SIGM') THEN
- IF (GTEST) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZSIGMA_RC(JL) = PSIGS(I1(JL),I2(JL),I3(JL))*2.
- ENDDO
- ELSE !useful when doing calls to MPPDB_CHECK
- ZSIGMA_RC(:) = XUNDEF
- ENDIF
- IF(KRR==7) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZRHT(JL) = PRHT(I1(JL),I2(JL),I3(JL))
- ENDDO
- IF(GEXT_TEND) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZEXT_RH(JL) = PRHS(I1(JL),I2(JL),I3(JL)) - ZRHT(JL)*ZINV_TSTEP
- ENDDO
- ENDIF
- ELSE
- ZRHT(:)=0.
- IF(GEXT_TEND) ZEXT_RH(:)=0.
- ENDIF
- IF(LBU_ENABLE) THEN
- ZTOT_RVHENI(:)=0.
- ZTOT_RCHONI(:)=0.
- ZTOT_RRHONG(:)=0.
- ZTOT_RVDEPS(:)=0.
- ZTOT_RIAGGS(:)=0.
- ZTOT_RIAUTS(:)=0.
- ZTOT_RVDEPG(:)=0.
- ZTOT_RCAUTR(:)=0.
- ZTOT_RCACCR(:)=0.
- ZTOT_RREVAV(:)=0.
- ZTOT_RCRIMSS(:)=0.
- ZTOT_RCRIMSG(:)=0.
- ZTOT_RSRIMCG(:)=0.
- ZTOT_RIMLTC(:)=0.
- ZTOT_RCBERI(:)=0.
- ZTOT_RHMLTR(:)=0.
- ZTOT_RSMLTG(:)=0.
- ZTOT_RCMLTSR(:)=0.
- ZTOT_RRACCSS(:)=0.
- ZTOT_RRACCSG(:)=0.
- ZTOT_RSACCRG(:)=0.
- ZTOT_RICFRRG(:)=0.
- ZTOT_RRCFRIG(:)=0.
- ZTOT_RICFRR(:)=0.
- ZTOT_RCWETG(:)=0.
- ZTOT_RIWETG(:)=0.
- ZTOT_RRWETG(:)=0.
- ZTOT_RSWETG(:)=0.
- ZTOT_RCDRYG(:)=0.
- ZTOT_RIDRYG(:)=0.
- ZTOT_RRDRYG(:)=0.
- ZTOT_RSDRYG(:)=0.
- ZTOT_RWETGH(:)=0.
- ZTOT_RGMLTR(:)=0.
- ZTOT_RCWETH(:)=0.
- ZTOT_RIWETH(:)=0.
- ZTOT_RSWETH(:)=0.
- ZTOT_RGWETH(:)=0.
- ZTOT_RRWETH(:)=0.
- ZTOT_RCDRYH(:)=0.
- ZTOT_RIDRYH(:)=0.
- ZTOT_RSDRYH(:)=0.
- ZTOT_RRDRYH(:)=0.
- ZTOT_RGDRYH(:)=0.
- ZTOT_RDRYHG(:)=0.
- ENDIF
-ENDIF
-!$acc end kernels
-!-------------------------------------------------------------------------------
-!
-!* 4. LOOP
-! ----
-!
-!Maximum number of iterations
-!We only count real iterations (those for which we *compute* tendencies)
-!acc kernels
-INB_ITER_MAX=NMAXITER
-IF(XTSTEP_TS/=0.)THEN
- INB_ITER_MAX=MAX(1, INT(PTSTEP/XTSTEP_TS)) !At least the number of iterations needed for the time-splitting
- ZTSTEP=PTSTEP/INB_ITER_MAX
- INB_ITER_MAX=MAX(NMAXITER, INB_ITER_MAX) !For the case XMRSTEP/=0. at the same time
-ENDIF
-!acc end kernels
-!$acc kernels present_cr(IITER,ZTIME)
-IITER(:)=0
-ZTIME(:)=0. ! Current integration time (all points may have a different integration time)
-!$acc end kernels
-!$acc update self(ZTIME)
-DO WHILE(ANY(ZTIME(:)<PTSTEP)) ! Loop to *really* compute tendencies
- IF(XMRSTEP/=0.) THEN
-!$acc kernels
- ! In this case we need to remember the mixing ratios used to compute the tendencies
- ! because when mixing ratio has evolved more than a threshold, we must re-compute tendecies
- Z0RVT(:)=ZRVT(:)
- Z0RCT(:)=ZRCT(:)
- Z0RRT(:)=ZRRT(:)
- Z0RIT(:)=ZRIT(:)
- Z0RST(:)=ZRST(:)
- Z0RGT(:)=ZRGT(:)
- Z0RHT(:)=ZRHT(:)
-!$acc end kernels
- ENDIF
- IF(XTSTEP_TS/=0.) THEN
-!$acc kernels
- ! In this case we need to remember the time when tendencies were computed
- ! because when time has evolved more than a limit, we must re-compute tendecies
- ZTIME_LASTCALL(:)=ZTIME(:)
-!$acc end kernels
- ENDIF
-!$acc kernels
- ZCOMPUTE(:)=MAX(0., -SIGN(1., ZTIME(:)-PTSTEP)) ! Compuation (1.) only for points for which integration time has not reached the timestep
- GSOFT=.FALSE. ! We *really* compute the tendencies
-!$acc loop independent
- DO JL = 1, IMICRO
- IITER(JL) = IITER(JL) + INT( ZCOMPUTE(JL) )
- END DO
-!$acc end kernels
-!$acc update self(ZCOMPUTE)
- DO WHILE(SUM(ZCOMPUTE(:))>0.) ! Loop to adjust tendencies when we cross the 0°C or when a specie disappears
-!$acc kernels
- IF(KRR==7) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZZT(JL) = ZTHT(JL) * ZEXN(JL)
- ZLSFACT(JL)=(XLSTT+(XCPV-XCI)*(ZZT(JL)-XTT)) &
- &/( (XCPD + XCPV*ZRVT(JL) + XCL*(ZRCT(JL)+ZRRT(JL)) &
- &+ XCI*(ZRIT(JL)+ZRST(JL)+ZRGT(JL)+ZRHT(JL)))*ZEXN(JL) )
- ZLVFACT(JL)=(XLVTT+(XCPV-XCL)*(ZZT(JL)-XTT)) &
- &/( (XCPD + XCPV*ZRVT(JL) + XCL*(ZRCT(JL)+ZRRT(JL)) &
- &+ XCI*(ZRIT(JL)+ZRST(JL)+ZRGT(JL)+ZRHT(JL)))*ZEXN(JL) )
- ENDDO
- ELSE
-!$acc loop independent
- DO JL=1, IMICRO
- ZZT(JL) = ZTHT(JL) * ZEXN(JL)
- ZLSFACT(JL)=(XLSTT+(XCPV-XCI)*(ZZT(JL)-XTT)) &
- &/( (XCPD + XCPV*ZRVT(JL) + XCL*(ZRCT(JL)+ZRRT(JL)) &
- &+ XCI*(ZRIT(JL)+ZRST(JL)+ZRGT(JL)))*ZEXN(JL) )
- ZLVFACT(JL)=(XLVTT+(XCPV-XCL)*(ZZT(JL)-XTT)) &
- &/( (XCPD + XCPV*ZRVT(JL) + XCL*(ZRCT(JL)+ZRRT(JL)) &
- &+ XCI*(ZRIT(JL)+ZRST(JL)+ZRGT(JL)))*ZEXN(JL) )
- ENDDO
- ENDIF
-!$acc end kernels
- !
- !*** 4.1 Tendecies computation
- !
- ! Tendencies are *really* computed when GSOFT==.FALSE. and only adjusted otherwise
- CALL ICE4_TENDENCIES(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, KKT, KKL, &
- &KRR, GSOFT, ZCOMPUTE, &
- &OWARM, CSUBG_RC_RR_ACCR, CSUBG_RR_EVAP, &
- &HSUBG_AUCV_RC, HSUBG_AUCV_RI, CSUBG_PR_PDF, &
- &ZEXN, ZRHODREF, ZLVFACT, ZLSFACT, I1, I2, I3, &
- &ZPRES, ZCF, ZSIGMA_RC,&
- &ZCIT, &
- &ZZT, ZTHT, &
- &ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZRHT, &
- &ZRVHENI_MR, ZRRHONG_MR, ZRIMLTC_MR, ZRSRIMCG_MR, &
- &ZRCHONI, ZRVDEPS, ZRIAGGS, ZRIAUTS, ZRVDEPG, &
- &ZRCAUTR, ZRCACCR, ZRREVAV, &
- &ZRCRIMSS, ZRCRIMSG, ZRSRIMCG, ZRRACCSS, ZRRACCSG, ZRSACCRG, ZRSMLTG, ZRCMLTSR, &
- &ZRICFRRG, ZRRCFRIG, ZRICFRR, ZRCWETG, ZRIWETG, ZRRWETG, ZRSWETG, &
- &ZRCDRYG, ZRIDRYG, ZRRDRYG, ZRSDRYG, ZRWETGH, ZRWETGH_MR, ZRGMLTR, &
- &ZRCWETH, ZRIWETH, ZRSWETH, ZRGWETH, ZRRWETH, &
- &ZRCDRYH, ZRIDRYH, ZRSDRYH, ZRRDRYH, ZRGDRYH, ZRDRYHG, ZRHMLTR, &
- &ZRCBERI, &
- &ZRS_TEND, ZRG_TEND, ZRH_TEND, ZSSI, &
- &ZA_TH, ZA_RV, ZA_RC, ZA_RR, ZA_RI, ZA_RS, ZA_RG, ZA_RH, &
- &ZB_TH, ZB_RV, ZB_RC, ZB_RR, ZB_RI, ZB_RS, ZB_RG, ZB_RH, &
- &ZHLC_HCF, ZHLC_LCF, ZHLC_HRC, ZHLC_LRC, &
- &ZHLI_HCF, ZHLI_LCF, ZHLI_HRI, ZHLI_LRI, PRAINFR)
- ! External tendencies
-!$acc kernels
- IF(GEXT_TEND) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZA_TH(JL) = ZA_TH(JL) + ZEXT_TH(JL)
- ZA_RV(JL) = ZA_RV(JL) + ZEXT_RV(JL)
- ZA_RC(JL) = ZA_RC(JL) + ZEXT_RC(JL)
- ZA_RR(JL) = ZA_RR(JL) + ZEXT_RR(JL)
- ZA_RI(JL) = ZA_RI(JL) + ZEXT_RI(JL)
- ZA_RS(JL) = ZA_RS(JL) + ZEXT_RS(JL)
- ZA_RG(JL) = ZA_RG(JL) + ZEXT_RG(JL)
- ZA_RH(JL) = ZA_RH(JL) + ZEXT_RH(JL)
- ENDDO
- ENDIF
- !
- !*** 4.2 Integration time
- !
- ! If we can, we will use these tendencies until the end of the timestep
- ZMAXTIME(:)=ZCOMPUTE(:) * (PTSTEP-ZTIME(:)) ! Remaining time until the end of the timestep
-
- !We need to adjust tendencies when temperature reaches 0
- IF(LFEEDBACKT) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- !Is ZB_TH enough to change temperature sign?
- ZW1D(JL)=(ZTHT(JL) - XTT/ZEXN(JL)) * (ZTHT(JL) + ZB_TH(JL) - XTT/ZEXN(JL))
- ZMAXTIME(JL)=ZMAXTIME(JL)*MAX(0., SIGN(1., ZW1D(JL)))
- !Can ZA_TH make temperature change of sign?
- ZW1D(JL)=MAX(0., -SIGN(1., 1.E-20 - ABS(ZA_TH(JL)))) ! WHERE(ABS(ZA_TH(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1. - ZW1D(JL))*(-1.) + &
- ZW1D(JL) * &
- (XTT/ZEXN(JL) - ZB_TH(JL) - ZTHT(JL))/ &
- SIGN(MAX(ABS(ZA_TH(JL)), 1.E-20), ZA_TH(JL))
- ZW1D(JL)=MAX(0., -SIGN(1., 1.E-20 - ZTIME_THRESHOLD(JL))) ! WHERE(ZTIME_THRESHOLD(:)>1.E-20)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- ZW1D(JL) * MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ENDDO
- ENDIF
- !We need to adjust tendencies when a specy disappears
- !When a species is missing, only the external tendencies can be negative (and we must keep track of it)
-!$acc loop independent
- DO JL=1, IMICRO
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RV(JL)+1.E-20)) * & ! WHERE(ZA_RV(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(1)-ZRVT(JL))) ! WHERE(ZRVT(:)>XRTMIN(1))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RV(JL)+ZRVT(JL))/MIN(ZA_RV(JL), -1.E-20))
-
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RC(JL)+1.E-20)) * & ! WHERE(ZA_RC(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(2)-ZRCT(JL))) ! WHERE(ZRCT(:)>XRTMIN(2))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RC(JL)+ZRCT(JL))/MIN(ZA_RC(JL), -1.E-20))
-
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RR(JL)+1.E-20)) * & ! WHERE(ZA_RR(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(3)-ZRRT(JL))) ! WHERE(ZRRT(:)>XRTMIN(3))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RR(JL)+ZRRT(JL))/MIN(ZA_RR(JL), -1.E-20))
-
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RI(JL)+1.E-20)) * & ! WHERE(ZI_RV(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(4)-ZRIT(JL))) ! WHERE(ZRIT(:)>XRTMIN(4))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RI(JL)+ZRIT(JL))/MIN(ZA_RI(JL), -1.E-20))
-
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RS(JL)+1.E-20)) * & ! WHERE(ZA_RS(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(5)-ZRST(JL))) ! WHERE(ZRST(:)>XRTMIN(5))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RS(JL)+ZRST(JL))/MIN(ZA_RS(JL), -1.E-20))
-
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RG(JL)+1.E-20)) * & ! WHERE(ZA_RG(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(6)-ZRGT(JL))) ! WHERE(ZRGT(:)>XRTMIN(6))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RG(JL)+ZRGT(JL))/MIN(ZA_RG(JL), -1.E-20))
- ENDDO
-
- IF(KRR==7) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZW1D(JL)=MAX(0., -SIGN(1., ZA_RH(JL)+1.E-20)) * & ! WHERE(ZA_RH(:)<-1.E-20)
- &MAX(0., -SIGN(1., XRTMIN(7)-ZRHT(JL))) ! WHERE(ZRHT(:)>XRTMIN(7))
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * MIN(ZMAXTIME(JL), -(ZB_RH(JL)+ZRHT(JL))/MIN(ZA_RH(JL), -1.E-20))
- ENDDO
- ENDIF
- !We stop when the end of the timestep is reached
- ZCOMPUTE(:)=ZCOMPUTE(:) * MAX(0., -SIGN(1., ZTIME(:)+ZMAXTIME(:)-PTSTEP))
-
- !We must recompute tendencies when the end of the sub-timestep is reached
- IF(XTSTEP_TS/=0.) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., ZTIME_LASTCALL(JL)+ZTSTEP-ZTIME(JL)-ZMAXTIME(JL))) ! WHERE(ZTIME(:)+ZMAXTIME(:)>ZTIME_LASTCALL(:)+ZTSTEP)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL) * (ZTIME_LASTCALL(JL)-ZTIME(JL)+ZTSTEP)
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
- ENDDO
- ENDIF
- !We must recompute tendencies when the maximum allowed change is reached
- !When a specy is missing, only the external tendencies can be active and we do not want to recompute
- !the microphysical tendencies when external tendencies are negative (results won't change because specy was already missing)
- IF(XMRSTEP/=0.) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RV(JL)))) ! WHERE(ABS(ZA_RV(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RV(JL))*XMRSTEP+Z0RVT(JL)-ZRVT(JL)-ZB_RV(JL))/ &
- &SIGN(MAX(ABS(ZA_RV(JL)), 1.E-20), ZA_RV(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRVT(JL))) + & !WHERE(ZRVT(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RV(JL)))) !WHERE(ZA_RV(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
-
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RC(JL)))) ! WHERE(ABS(ZA_RC(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RC(JL))*XMRSTEP+Z0RCT(JL)-ZRCT(JL)-ZB_RC(JL))/ &
- &SIGN(MAX(ABS(ZA_RC(JL)), 1.E-20), ZA_RC(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRCT(JL))) + & !WHERE(ZRCT(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RC(JL)))) !WHERE(ZA_RC(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
-
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RR(JL)))) ! WHERE(ABS(ZA_RR(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RR(JL))*XMRSTEP+Z0RRT(JL)-ZRRT(JL)-ZB_RR(JL))/ &
- &SIGN(MAX(ABS(ZA_RR(JL)), 1.E-20), ZA_RR(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRRT(JL))) + & !WHERE(ZRRT(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RR(JL)))) !WHERE(ZA_RR(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
-
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RI(JL)))) ! WHERE(ABS(ZA_RI(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RI(JL))*XMRSTEP+Z0RIT(JL)-ZRIT(JL)-ZB_RI(JL))/ &
- &SIGN(MAX(ABS(ZA_RI(JL)), 1.E-20), ZA_RI(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRIT(JL))) + & !WHERE(ZRIT(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RI(JL)))) !WHERE(ZA_RI(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
-
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RS(JL)))) ! WHERE(ABS(ZA_RS(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RS(JL))*XMRSTEP+Z0RST(JL)-ZRST(JL)-ZB_RS(JL))/ &
- &SIGN(MAX(ABS(ZA_RS(JL)), 1.E-20), ZA_RS(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRST(JL))) + & !WHERE(ZRST(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RS(JL)))) !WHERE(ZA_RS(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
-
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RG(JL)))) ! WHERE(ABS(ZA_RG(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RG(JL))*XMRSTEP+Z0RGT(JL)-ZRGT(JL)-ZB_RG(JL))/ &
- &SIGN(MAX(ABS(ZA_RG(JL)), 1.E-20), ZA_RG(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRGT(JL))) + & !WHERE(ZRGT(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RG(JL)))) !WHERE(ZA_RG(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
- ENDDO
-
- IF(KRR==7) THEN
-!$acc loop independent
- DO JL=1, IMICRO
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & ! WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., 1.E-20-ABS(ZA_RH(JL)))) ! WHERE(ABS(ZA_RH(:))>1.E-20)
- ZTIME_THRESHOLD(JL)=(1.-ZW1D(JL))*(-1.) + &
- &ZW1D(JL)*(SIGN(1., ZA_RH(JL))*XMRSTEP+Z0RHT(JL)-ZRHT(JL)-ZB_RH(JL))/ &
- &SIGN(MAX(ABS(ZA_RH(JL)), 1.E-20), ZA_RH(JL))
- ZW1D(JL)=MAX(0., SIGN(1., ZTIME_THRESHOLD(JL))) * & !WHERE(ZTIME_THRESHOLD(:)>=0.)
- &MAX(0., -SIGN(1., ZTIME_THRESHOLD(JL)-ZMAXTIME(JL))) * & !WHERE(ZTIME_THRESHOLD(:)<ZMAXTIME(:))
- &MIN(1., MAX(0., -SIGN(1., XRTMIN(6)-ZRHT(JL))) + & !WHERE(ZRHT(:)>XRTMIN(6)) .OR.
- &MAX(0., -SIGN(1., -ZA_RH(JL)))) !WHERE(ZA_RH(:)>0.)
- ZMAXTIME(JL)=(1.-ZW1D(JL)) * ZMAXTIME(JL) + &
- &ZW1D(JL)*MIN(ZMAXTIME(JL), ZTIME_THRESHOLD(JL))
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
- ENDDO
- ENDIF
-
-!$acc loop independent
- DO JL=1, IMICRO
- ZW1D(JL)=MAX(ABS(ZB_RV(JL)), ABS(ZB_RC(JL)), ABS(ZB_RR(JL)), ABS(ZB_RI(JL)), &
- &ABS(ZB_RS(JL)), ABS(ZB_RG(JL)), ABS(ZB_RH(JL)))
- ZW1D(JL)=MAX(0., -SIGN(1., IITER(JL)-INB_ITER_MAX+0.)) * & !WHERE(IITER(:)<INB_ITER_MAX)
- &MAX(0., -SIGN(1., XMRSTEP-ZW1D(JL))) !WHERE(ZW1D(:)>XMRSTEP)
- ZMAXTIME(JL)=(1.-ZW1D(JL))*ZMAXTIME(JL)
- ZCOMPUTE(JL)=ZCOMPUTE(JL) * (1. - ZW1D(JL))
- ENDDO
- ENDIF
- !
- !*** 4.3 New values of variables for next iteration
- !
-!$acc loop independent
- DO JL=1, IMICRO
- ZTHT(JL)=ZTHT(JL)+ZA_TH(JL)*ZMAXTIME(JL)+ZB_TH(JL)
- ZRVT(JL)=ZRVT(JL)+ZA_RV(JL)*ZMAXTIME(JL)+ZB_RV(JL)
- ZRCT(JL)=ZRCT(JL)+ZA_RC(JL)*ZMAXTIME(JL)+ZB_RC(JL)
- ZRRT(JL)=ZRRT(JL)+ZA_RR(JL)*ZMAXTIME(JL)+ZB_RR(JL)
- ZRIT(JL)=ZRIT(JL)+ZA_RI(JL)*ZMAXTIME(JL)+ZB_RI(JL)
- ZRST(JL)=ZRST(JL)+ZA_RS(JL)*ZMAXTIME(JL)+ZB_RS(JL)
- ZRGT(JL)=ZRGT(JL)+ZA_RG(JL)*ZMAXTIME(JL)+ZB_RG(JL)
- ZCIT(JL)=ZCIT(JL) * MAX(0., -SIGN(1., -ZRIT(JL))) ! WHERE(ZRIT(:)==0.) ZCIT(:) = 0.
- ENDDO
-!$acc end kernels
- IF(KRR==7) THEN
-!$acc kernels
- ZRHT(:)=ZRHT(:)+ZA_RH(:)*ZMAXTIME(:)+ZB_RH(:)
-!$acc end kernels
- END IF
- !
- !*** 4.4 Mixing ratio change due to each process
- !
- IF(LBU_ENABLE) THEN
-!$acc kernels
- ZTOT_RVHENI(:)= ZTOT_RVHENI(:) +ZRVHENI_MR(:)
- ZTOT_RCHONI(:)= ZTOT_RCHONI(:) +ZRCHONI(:) *ZMAXTIME(:)
- ZTOT_RRHONG(:)= ZTOT_RRHONG(:) +ZRRHONG_MR(:)
- ZTOT_RVDEPS(:)= ZTOT_RVDEPS(:) +ZRVDEPS(:) *ZMAXTIME(:)
- ZTOT_RIAGGS(:)= ZTOT_RIAGGS(:) +ZRIAGGS(:) *ZMAXTIME(:)
- ZTOT_RIAUTS(:)= ZTOT_RIAUTS(:) +ZRIAUTS(:) *ZMAXTIME(:)
- ZTOT_RVDEPG(:)= ZTOT_RVDEPG(:) +ZRVDEPG(:) *ZMAXTIME(:)
- ZTOT_RCAUTR(:)= ZTOT_RCAUTR(:) +ZRCAUTR(:) *ZMAXTIME(:)
- ZTOT_RCACCR(:)= ZTOT_RCACCR(:) +ZRCACCR(:) *ZMAXTIME(:)
- ZTOT_RREVAV(:)= ZTOT_RREVAV(:) +ZRREVAV(:) *ZMAXTIME(:)
- ZTOT_RCRIMSS(:)=ZTOT_RCRIMSS(:)+ZRCRIMSS(:)*ZMAXTIME(:)
- ZTOT_RCRIMSG(:)=ZTOT_RCRIMSG(:)+ZRCRIMSG(:)*ZMAXTIME(:)
- ZTOT_RSRIMCG(:)=ZTOT_RSRIMCG(:)+ZRSRIMCG(:)*ZMAXTIME(:)+ZRSRIMCG_MR(:)
- ZTOT_RRACCSS(:)=ZTOT_RRACCSS(:)+ZRRACCSS(:)*ZMAXTIME(:)
- ZTOT_RRACCSG(:)=ZTOT_RRACCSG(:)+ZRRACCSG(:)*ZMAXTIME(:)
- ZTOT_RSACCRG(:)=ZTOT_RSACCRG(:)+ZRSACCRG(:)*ZMAXTIME(:)
- ZTOT_RSMLTG(:)= ZTOT_RSMLTG(:) +ZRSMLTG(:) *ZMAXTIME(:)
- ZTOT_RCMLTSR(:)=ZTOT_RCMLTSR(:)+ZRCMLTSR(:) *ZMAXTIME(:)
- ZTOT_RICFRRG(:)=ZTOT_RICFRRG(:)+ZRICFRRG(:)*ZMAXTIME(:)
- ZTOT_RRCFRIG(:)=ZTOT_RRCFRIG(:)+ZRRCFRIG(:)*ZMAXTIME(:)
- ZTOT_RICFRR(:)= ZTOT_RICFRR(:) +ZRICFRR(:) *ZMAXTIME(:)
- ZTOT_RCWETG(:)= ZTOT_RCWETG(:) +ZRCWETG(:) *ZMAXTIME(:)
- ZTOT_RIWETG(:)= ZTOT_RIWETG(:) +ZRIWETG(:) *ZMAXTIME(:)
- ZTOT_RRWETG(:)= ZTOT_RRWETG(:) +ZRRWETG(:) *ZMAXTIME(:)
- ZTOT_RSWETG(:)= ZTOT_RSWETG(:) +ZRSWETG(:) *ZMAXTIME(:)
- ZTOT_RWETGH(:)= ZTOT_RWETGH(:) +ZRWETGH(:) *ZMAXTIME(:)+ZRWETGH_MR(:)
- ZTOT_RCDRYG(:)= ZTOT_RCDRYG(:) +ZRCDRYG(:) *ZMAXTIME(:)
- ZTOT_RIDRYG(:)= ZTOT_RIDRYG(:) +ZRIDRYG(:) *ZMAXTIME(:)
- ZTOT_RRDRYG(:)= ZTOT_RRDRYG(:) +ZRRDRYG(:) *ZMAXTIME(:)
- ZTOT_RSDRYG(:)= ZTOT_RSDRYG(:) +ZRSDRYG(:) *ZMAXTIME(:)
- ZTOT_RGMLTR(:)= ZTOT_RGMLTR(:) +ZRGMLTR(:) *ZMAXTIME(:)
- ZTOT_RCWETH(:)= ZTOT_RCWETH(:) +ZRCWETH(:) *ZMAXTIME(:)
- ZTOT_RIWETH(:)= ZTOT_RIWETH(:) +ZRIWETH(:) *ZMAXTIME(:)
- ZTOT_RSWETH(:)= ZTOT_RSWETH(:) +ZRSWETH(:) *ZMAXTIME(:)
- ZTOT_RGWETH(:)= ZTOT_RGWETH(:) +ZRGWETH(:) *ZMAXTIME(:)
- ZTOT_RRWETH(:)= ZTOT_RRWETH(:) +ZRRWETH(:) *ZMAXTIME(:)
- ZTOT_RCDRYH(:)= ZTOT_RCDRYH(:) +ZRCDRYH(:) *ZMAXTIME(:)
- ZTOT_RIDRYH(:)= ZTOT_RIDRYH(:) +ZRIDRYH(:) *ZMAXTIME(:)
- ZTOT_RSDRYH(:)= ZTOT_RSDRYH(:) +ZRSDRYH(:) *ZMAXTIME(:)
- ZTOT_RRDRYH(:)= ZTOT_RRDRYH(:) +ZRRDRYH(:) *ZMAXTIME(:)
- ZTOT_RGDRYH(:)= ZTOT_RGDRYH(:) +ZRGDRYH(:) *ZMAXTIME(:)
- ZTOT_RDRYHG(:)= ZTOT_RDRYHG(:) +ZRDRYHG(:) *ZMAXTIME(:)
- ZTOT_RHMLTR(:)= ZTOT_RHMLTR(:) +ZRHMLTR(:) *ZMAXTIME(:)
- ZTOT_RIMLTC(:)= ZTOT_RIMLTC(:) +ZRIMLTC_MR(:)
- ZTOT_RCBERI(:)= ZTOT_RCBERI(:) +ZRCBERI(:) *ZMAXTIME(:)
-!$acc end kernels
- ENDIF
- !
- !*** 4.5 Next loop
- !
- GSOFT=.TRUE. ! We try to adjust tendencies (inner while loop)
-!$acc kernels
- ZTIME(:)=ZTIME(:)+ZMAXTIME(:)
-!$acc end kernels
-!$acc update self(ZCOMPUTE)
- ENDDO
-!$acc update self(ZTIME)
-ENDDO
-!-------------------------------------------------------------------------------
-!
-!* 5. UNPACKING DIAGNOSTICS
-! ---------------------
-!
-! !$acc kernels
-IF(IMICRO>0) THEN
-!$acc kernels present_cr(ZHLC_HCF3D,ZHLC_LCF3D,ZHLC_HRC3D,ZHLC_LRC3D,ZHLI_HCF3D,ZHLI_LCF3D,ZHLI_HRI3D,ZHLI_LRI3D)
- ZHLC_HCF3D(:,:,:)=0.
- ZHLC_LCF3D(:,:,:)=0.
- ZHLC_HRC3D(:,:,:)=0.
- ZHLC_LRC3D(:,:,:)=0.
- ZHLI_HCF3D(:,:,:)=0.
- ZHLI_LCF3D(:,:,:)=0.
- ZHLI_HRI3D(:,:,:)=0.
- ZHLI_LRI3D(:,:,:)=0.
-!$acc loop independent
- DO JL=1,IMICRO
- ZHLC_HCF3D(I1(JL), I2(JL), I3(JL)) = ZHLC_HCF(JL)
- ZHLC_LCF3D(I1(JL), I2(JL), I3(JL)) = ZHLC_LCF(JL)
- ZHLC_HRC3D(I1(JL), I2(JL), I3(JL)) = ZHLC_HRC(JL)
- ZHLC_LRC3D(I1(JL), I2(JL), I3(JL)) = ZHLC_LRC(JL)
- ZHLI_LCF3D(I1(JL), I2(JL), I3(JL)) = ZHLI_LCF(JL)
- ZHLI_HCF3D(I1(JL), I2(JL), I3(JL)) = ZHLI_HCF(JL)
- ZHLI_HRI3D(I1(JL), I2(JL), I3(JL)) = ZHLI_HRI(JL)
- ZHLI_LRI3D(I1(JL), I2(JL), I3(JL)) = ZHLI_LRI(JL)
- PCIT(I1(JL), I2(JL), I3(JL)) = ZCIT(JL)
- END DO
-!$acc end kernels
-ELSE
-!$acc kernels present_cr(PRAINFR,ZHLC_HCF3D,ZHLC_LCF3D,ZHLC_HRC3D,ZHLC_LRC3D,ZHLI_HCF3D,ZHLI_LCF3D,ZHLI_HRI3D,ZHLI_LRI3D,PCIT)
- PRAINFR(:,:,:)=0.
- ZHLC_HCF3D(:,:,:)=0.
- ZHLC_LCF3D(:,:,:)=0.
- ZHLC_HRC3D(:,:,:)=0.
- ZHLC_LRC3D(:,:,:)=0.
- ZHLI_HCF3D(:,:,:)=0.
- ZHLI_LCF3D(:,:,:)=0.
- ZHLI_HRI3D(:,:,:)=0.
- ZHLI_LRI3D(:,:,:)=0.
- PCIT(:,:,:) = 0.
-!$acc end kernels
-ENDIF
-!$acc kernels present_cr(PEVAP3D)
-IF(OWARM) THEN
- PEVAP3D(:,:,:) = 0.
-!$acc loop independent
- DO JL=1,IMICRO
- PEVAP3D(I1(JL), I2(JL), I3(JL)) = ZRREVAV(JL)
- END DO
-ENDIF
-!
-!
-!* 6. COMPUTES THE SLOW COLD PROCESS SOURCES OUTSIDE OF ODMICRO POINTS
-! ----------------------------------------------------------------
-!
-GDNOTMICRO = .NOT.ODMICRO
-ZLSFACT3D(:,:,:) = ZZ_LSFACT(:,:,:)/PEXN(:,:,:)
-!$acc end kernels
-CALL ICE4_NUCLEATION_WRAPPER(KIT, KJT, KKT, GDNOTMICRO, &
- PTHT, PPABST, PRHODREF, PEXN, ZLSFACT3D, ZT, &
- PRVT, &
- PCIT, ZZ_RVHENI_MR)
-!$acc kernels
-!$acc loop independent collapse(3)
-DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ZZ_LSFACT(JI,JJ,JK)=ZZ_LSFACT(JI,JJ,JK)/PEXNREF(JI,JJ,JK)
- ZZ_LVFACT(JI,JJ,JK)=ZZ_LVFACT(JI,JJ,JK)/PEXNREF(JI,JJ,JK)
- ZZ_RVHENI(JI,JJ,JK) = MIN(PRVS(JI,JJ,JK), ZZ_RVHENI_MR(JI,JJ,JK)/PTSTEP)
- PRIS(JI,JJ,JK)=PRIS(JI,JJ,JK)+ZZ_RVHENI(JI,JJ,JK)
- PRVS(JI,JJ,JK)=PRVS(JI,JJ,JK)-ZZ_RVHENI(JI,JJ,JK)
- PTHS(JI,JJ,JK)=PTHS(JI,JJ,JK) + ZZ_RVHENI(JI,JJ,JK)*ZZ_LSFACT(JI,JJ,JK)
- ENDDO
- ENDDO
-ENDDO
-!$acc end kernels
-!$acc update self(PRIS,PRVS,PTHS)
-!
-if ( lbu_enable ) then
- !Note: there is an other contribution for HENU later
- if ( lbudget_th ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = pths(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_TH), 'HENU', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_rv ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = prvs(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_end( tbudgets(NBUDGET_RV), 'HENU', ZTEMP_BUD(:,:,:) )
- end if
- if ( lbudget_ri ) then
- !$acc kernels present_cr(ZTEMP_BUD)
- ZTEMP_BUD(:,:,:) = zz_rvheni(:, :, :) * prhodj(:, :, :)
- !$acc end kernels
- call Budget_store_add( tbudgets(NBUDGET_RI), 'HENU', ZTEMP_BUD(:,:,:) )
- end if
-end if
-!-------------------------------------------------------------------------------
-!
-!* 7. UNPACKING AND TOTAL TENDENCIES
-! ------------------------------
-!
-!
-!*** 7.1 total tendencies limited by available species
-!
-! ZW_??S variables will contain the new S variables values
-!
-IF(GEXT_TEND) THEN
-!$acc kernels
- !Z..T variables contain the exeternal tendency, we substract it
-!$acc loop independent
- DO CONCURRENT ( JL = 1 : IMICRO )
- ZRVT(JL) = ZRVT(JL) - ZEXT_RV(JL) * PTSTEP
- ZRCT(JL) = ZRCT(JL) - ZEXT_RC(JL) * PTSTEP
- ZRRT(JL) = ZRRT(JL) - ZEXT_RR(JL) * PTSTEP
- ZRIT(JL) = ZRIT(JL) - ZEXT_RI(JL) * PTSTEP
- ZRST(JL) = ZRST(JL) - ZEXT_RS(JL) * PTSTEP
- ZRGT(JL) = ZRGT(JL) - ZEXT_RG(JL) * PTSTEP
- ZTHT(JL) = ZTHT(JL) - ZEXT_TH(JL) * PTSTEP
- END DO
-!$acc end kernels
- IF (KRR==7) THEN
-!$acc kernels
-!$acc loop independent
- DO CONCURRENT ( JL = 1 : IMICRO )
- ZRHT(JL) = ZRHT(JL) - ZEXT_RH(JL) * PTSTEP
- END DO
-!$acc end kernels
- END IF
-END IF
-!$acc update self(ZRVT)
-!Tendencies computed from difference between old state and new state (can be negative)
-#ifndef MNH_OPENACC
- ZW_RVS(:,:,:) = 0.
- ZW_RCS(:,:,:) = 0.
- ZW_RRS(:,:,:) = 0.
- ZW_RIS(:,:,:) = 0.
- ZW_RSS(:,:,:) = 0.
- ZW_RGS(:,:,:) = 0.
- ZW_RHS(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW_RVS(I1(JL), I2(JL), I3(JL)) = ( ZRVT(JL) - PRVT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- ZW_RCS(I1(JL), I2(JL), I3(JL)) = ( ZRCT(JL) - PRCT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- ZW_RRS(I1(JL), I2(JL), I3(JL)) = ( ZRRT(JL) - PRRT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- ZW_RIS(I1(JL), I2(JL), I3(JL)) = ( ZRIT(JL) - PRIT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- ZW_RSS(I1(JL), I2(JL), I3(JL)) = ( ZRST(JL) - PRST(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- ZW_RGS(I1(JL), I2(JL), I3(JL)) = ( ZRGT(JL) - PRGT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- END DO
- IF(KRR==7) THEN
- DO JL=1,IMICRO
- ZW_RHS(I1(JL), I2(JL), I3(JL)) = ( ZRHT(JL) - PRHT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
- END DO
-END IF
-#else
-IF (KRR==7) THEN
-!PW: probably not working (see ELSE branch)
- CALL PRINT_MSG(NVERB_WARNING,'GEN','RAIN_ICE_RED','OpenACC: KRR=7 not yet tested')
-!PW:BUG: CCE 13.0.0 crash if kernels region is enabled here
-!acc kernels
- IDX = 0
- DO JK=1,SIZE(ODMICRO,3)
- DO JJ=1,SIZE(ODMICRO,2)
- DO JI=1,SIZE(ODMICRO,1)
- IF (ODMICRO(JI,JJ,JK)) THEN
- IDX = IDX+1
- ZW_RVS(JI,JJ,JK) = ( ZRVT(IDX) - PRVT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RCS(JI,JJ,JK) = ( ZRCT(IDX) - PRCT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RRS(JI,JJ,JK) = ( ZRRT(IDX) - PRRT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RIS(JI,JJ,JK) = ( ZRIT(IDX) - PRIT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RSS(JI,JJ,JK) = ( ZRST(IDX) - PRST(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RGS(JI,JJ,JK) = ( ZRGT(IDX) - PRGT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RHS(JI,JJ,JK) = ( ZRHT(IDX) - PRHT(JI,JJ,JK) ) * ZINV_TSTEP
- ELSE
- ZW_RVS(JI,JJ,JK) = 0.
- ZW_RCS(JI,JJ,JK) = 0.
- ZW_RRS(JI,JJ,JK) = 0.
- ZW_RIS(JI,JJ,JK) = 0.
- ZW_RSS(JI,JJ,JK) = 0.
- ZW_RGS(JI,JJ,JK) = 0.
- ZW_RHS(JI,JJ,JK) = 0.
- END IF
- END DO
- END DO
- END DO
-!acc end kernels
-ELSE
-
-!PW: BUG: this should work...
-! !$acc kernels
-! ZW_RVS(JI,JJ,JK) = 0.
-! ZW_RCS(JI,JJ,JK) = 0.
-! ZW_RRS(JI,JJ,JK) = 0.
-! ZW_RIS(JI,JJ,JK) = 0.
-! ZW_RSS(JI,JJ,JK) = 0.
-! ZW_RGS(JI,JJ,JK) = 0.
-! !$acc loop independent
-! DO JL=1,IMICRO
-! ZW_RVS(I1(JL), I2(JL), I3(JL)) = ( ZRVT(JL) - PRVT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
-! ZW_RCS(I1(JL), I2(JL), I3(JL)) = ( ZRCT(JL) - PRCT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
-! ZW_RRS(I1(JL), I2(JL), I3(JL)) = ( ZRRT(JL) - PRRT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
-! ZW_RIS(I1(JL), I2(JL), I3(JL)) = ( ZRIT(JL) - PRIT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
-! ZW_RSS(I1(JL), I2(JL), I3(JL)) = ( ZRST(JL) - PRST(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
-! ZW_RGS(I1(JL), I2(JL), I3(JL)) = ( ZRGT(JL) - PRGT(I1(JL), I2(JL), I3(JL)) ) * ZINV_TSTEP
-! END DO
-! !$acc end kernels
-
-#if 0
-!$acc kernels
- IDX = 0
- DO JK=1,SIZE(ODMICRO,3)
- DO JJ=1,SIZE(ODMICRO,2)
- DO JI=1,SIZE(ODMICRO,1)
- IF (ODMICRO(JI,JJ,JK)) THEN
- IDX = IDX+1
- ZW_RVS(JI,JJ,JK) = ( ZRVT(IDX) - PRVT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RCS(JI,JJ,JK) = ( ZRCT(IDX) - PRCT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RRS(JI,JJ,JK) = ( ZRRT(IDX) - PRRT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RIS(JI,JJ,JK) = ( ZRIT(IDX) - PRIT(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RSS(JI,JJ,JK) = ( ZRST(IDX) - PRST(JI,JJ,JK) ) * ZINV_TSTEP
- ZW_RGS(JI,JJ,JK) = ( ZRGT(IDX) - PRGT(JI,JJ,JK) ) * ZINV_TSTEP
- ELSE
- ZW_RVS(JI,JJ,JK) = 0.
- ZW_RCS(JI,JJ,JK) = 0.
- ZW_RRS(JI,JJ,JK) = 0.
- ZW_RIS(JI,JJ,JK) = 0.
- ZW_RSS(JI,JJ,JK) = 0.
- ZW_RGS(JI,JJ,JK) = 0.
- END IF
- END DO
- END DO
- END DO
- !
- ZW_RHS(:,:,:) = 0.
-!$acc end kernels
-#else
-!$acc kernels
- ZW_RVS(:,:,:) = PRVT(:,:,:)
- ZW_RCS(:,:,:) = PRCT(:,:,:)
- ZW_RRS(:,:,:) = PRRT(:,:,:)
- ZW_RIS(:,:,:) = PRIT(:,:,:)
- ZW_RSS(:,:,:) = PRST(:,:,:)
- ZW_RGS(:,:,:) = PRGT(:,:,:)
-!$acc loop independent
- DO JL=1,IMICRO
- ZW_RVS(I1(JL), I2(JL), I3(JL)) = ZRVT(JL)
- ZW_RCS(I1(JL), I2(JL), I3(JL)) = ZRCT(JL)
- ZW_RRS(I1(JL), I2(JL), I3(JL)) = ZRRT(JL)
- ZW_RIS(I1(JL), I2(JL), I3(JL)) = ZRIT(JL)
- ZW_RSS(I1(JL), I2(JL), I3(JL)) = ZRST(JL)
- ZW_RGS(I1(JL), I2(JL), I3(JL)) = ZRGT(JL)
- END DO
-!$acc end kernels
-!
-!$acc kernels present_cr(ZW_RHS)
- ZW_RVS(:,:,:) = ( ZW_RVS(:,:,:) - PRVT(:,:,:) ) * ZINV_TSTEP
- ZW_RCS(:,:,:) = ( ZW_RCS(:,:,:) - PRCT(:,:,:) ) * ZINV_TSTEP
- ZW_RRS(:,:,:) = ( ZW_RRS(:,:,:) - PRRT(:,:,:) ) * ZINV_TSTEP
- ZW_RIS(:,:,:) = ( ZW_RIS(:,:,:) - PRIT(:,:,:) ) * ZINV_TSTEP
- ZW_RSS(:,:,:) = ( ZW_RSS(:,:,:) - PRST(:,:,:) ) * ZINV_TSTEP
- ZW_RGS(:,:,:) = ( ZW_RGS(:,:,:) - PRGT(:,:,:) ) * ZINV_TSTEP
- !
- ZW_RHS(:,:,:) = 0.
-!$acc end kernels
-#endif
-ENDIF
-#endif
-!$acc kernels
-ZW_THS(:,:,:) = (ZW_RCS(:,:,:)+ZW_RRS(:,:,:) )*ZZ_LVFACT(:,:,:) + &
- & (ZW_RIS(:,:,:)+ZW_RSS(:,:,:)+ZW_RGS(:,:,:)+ZW_RHS(:,:,:))*ZZ_LSFACT(:,:,:)
-!We apply these tendencies to the S variables
-ZW_RVS(:,:,:) = PRVS(:,:,:) + ZW_RVS(:,:,:)
-ZW_RCS(:,:,:) = PRCS(:,:,:) + ZW_RCS(:,:,:)
-ZW_RRS(:,:,:) = PRRS(:,:,:) + ZW_RRS(:,:,:)
-ZW_RIS(:,:,:) = PRIS(:,:,:) + ZW_RIS(:,:,:)
-ZW_RSS(:,:,:) = PRSS(:,:,:) + ZW_RSS(:,:,:)
-ZW_RGS(:,:,:) = PRGS(:,:,:) + ZW_RGS(:,:,:)
-IF(KRR==7) ZW_RHS(:,:,:) = PRHS(:,:,:) + ZW_RHS(:,:,:)
-ZW_THS(:,:,:) = PTHS(:,:,:) + ZW_THS(:,:,:)
-!$acc end kernels
-
-if ( lbu_enable ) then
- if ( lbudget_th ) call Budget_store_init( tbudgets(NBUDGET_TH), 'CORR', zw_ths(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rv ) call Budget_store_init( tbudgets(NBUDGET_RV), 'CORR', zw_rvs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_init( tbudgets(NBUDGET_RC), 'CORR', zw_rcs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_init( tbudgets(NBUDGET_RR), 'CORR', zw_rrs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'CORR', zw_ris(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_init( tbudgets(NBUDGET_RS), 'CORR', zw_rss(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_init( tbudgets(NBUDGET_RG), 'CORR', zw_rgs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_init( tbudgets(NBUDGET_RH), 'CORR', zw_rhs(:, :, :) * prhodj(:, :, :) )
-end if
-
-!We correct negativities with conservation
-CALL CORRECT_NEGATIVITIES(KIT, KJT, KKT, KRR, ZW_RVS, ZW_RCS, ZW_RRS, &
- &ZW_RIS, ZW_RSS, ZW_RGS, &
- &ZW_THS, ZZ_LVFACT, ZZ_LSFACT, ZW_RHS)
-
-if ( lbu_enable ) then
- if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'CORR', zw_ths(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'CORR', zw_rvs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_end( tbudgets(NBUDGET_RC), 'CORR', zw_rcs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_end( tbudgets(NBUDGET_RR), 'CORR', zw_rrs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI), 'CORR', zw_ris(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_end( tbudgets(NBUDGET_RS), 'CORR', zw_rss(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_end( tbudgets(NBUDGET_RG), 'CORR', zw_rgs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_end( tbudgets(NBUDGET_RH), 'CORR', zw_rhs(:, :, :) * prhodj(:, :, :) )
-end if
-!
-!*** 7.2 LBU_ENABLE case
-!
-IF(LBU_ENABLE) THEN
-#ifdef MNH_OPENACC
- CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_RED','OpenACC: LBU_ENABLE=.true. not yet implemented')
-#endif
-!$acc update self(ZINV_TSTEP)
-
- allocate( zw1( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
- allocate( zw2( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
- allocate( zw3( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
- allocate( zw4( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
- if ( krr == 7 ) then
- allocate( zw5( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
- allocate( zw6( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
- end if
-
- if ( lbudget_th ) then
- allocate( zz_diff( size( zz_lsfact, 1 ), size( zz_lsfact, 2 ), size( zz_lsfact, 3 ) ) )
- zz_diff(:, :, :) = zz_lsfact(:, :, :) - zz_lvfact(:, :, :)
- end if
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RVHENI(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'HENU', zw(:, :, :) * zz_lsfact(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rv ) call Budget_store_add( tbudgets(NBUDGET_RV), 'HENU', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'HENU', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RCHONI(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'HON', zw(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'HON', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'HON', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RRHONG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'SFR', zw(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'SFR', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'SFR', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RVDEPS(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPS', zw(:, :, :) * zz_lsfact(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rv ) call Budget_store_add( tbudgets(NBUDGET_RV), 'DEPS', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'DEPS', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RIAGGS(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'AGGS', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'AGGS', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RIAUTS(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'AUTS', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'AUTS', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RVDEPG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPG', zw(:, :, :) * zz_lsfact(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rv ) call Budget_store_add( tbudgets(NBUDGET_RV), 'DEPG', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'DEPG', zw(:, :, :) * prhodj(:, :, :) )
-
- IF(OWARM) THEN
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RCAUTR(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'AUTO', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'AUTO', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RCACCR(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'ACCR', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'ACCR', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RREVAV(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'REVA', -zw(:, :, :) * zz_lvfact(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rv ) call Budget_store_add( tbudgets(NBUDGET_RV), 'REVA', zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'REVA', -zw(:, :, :) * prhodj(:, :, :) )
- ENDIF
-
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RCRIMSS(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RCRIMSG(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RSRIMCG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'RIM', ( zw1(:, :, :) + zw2(:, :, :) ) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'RIM', ( -zw1(:, :, :) - zw2(:, :, :) ) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'RIM', ( zw1(:, :, :) - zw3(:, :, :) ) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'RIM', ( zw2(:, :, :) + zw3(:, :, :) ) * prhodj(:, :, :) )
-
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RRACCSS(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RRACCSG(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RSACCRG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'ACC', ( zw1(:, :, :) + zw2(:, :, :) ) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'ACC', ( -zw1(:, :, :) - zw2(:, :, :) ) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'ACC', ( zw1(:, :, :) - zw3(:, :, :) ) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'ACC', ( zw2(:, :, :) + zw3(:, :, :) ) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RSMLTG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'CMEL', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'CMEL', zw(:, :, :) * prhodj(:, :, :) )
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RCMLTSR(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'CMEL', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'CMEL', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RICFRRG(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RRCFRIG(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RICFRR(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'CFRZ', zw2(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'CFRZ', ( -zw2(:, :, :) + zw3(:, :, :) ) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'CFRZ', ( -zw1(:, :, :) - zw3(:, :, :) ) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'CFRZ', ( zw1(:, :, :) + zw2(:, :, :) ) * prhodj(:, :, :) )
-
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RCWETG(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RRWETG(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RIWETG(JL) * ZINV_TSTEP
- END DO
- ZW4(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW4(I1(JL), I2(JL), I3(JL)) = ZTOT_RSWETG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'WETG', ( zw1(:, :, :) + zw2(:, :, :) ) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'WETG', -zw1(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'WETG', -zw2(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'WETG', -zw3(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'WETG', -zw4(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'WETG', ( zw1(:, :, :) + zw2(:, :, :) &
- + zw3(:, :, :) + zw4(:, :, :) ) &
- * prhodj(:, :, :) )
-
- IF(KRR==7) THEN
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RWETGH(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'GHCV', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_add( tbudgets(NBUDGET_RH), 'GHCV', zw(:, :, :) * prhodj(:, :, :) )
- END IF
-
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RCDRYG(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RRDRYG(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RIDRYG(JL) * ZINV_TSTEP
- END DO
- ZW4(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW4(I1(JL), I2(JL), I3(JL)) = ZTOT_RSDRYG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'DRYG', ( zw1(:, :, :) + zw2(:, :, :) ) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'DRYG', -zw1(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'DRYG', -zw2(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'DRYG', -zw3(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'DRYG', -zw4(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'DRYG', ( zw1(:, :, :) + zw2(:, :, :) &
- + zw3(:, :, :) + zw4(:, :, :) ) &
- * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RGMLTR(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'GMLT', -zw(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'GMLT', zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'GMLT', -zw(:, :, :) * prhodj(:, :, :) )
-
- IF(KRR==7) THEN
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RCWETH(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RRWETH(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RIWETH(JL) * ZINV_TSTEP
- END DO
- ZW4(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW4(I1(JL), I2(JL), I3(JL)) = ZTOT_RSWETH(JL) * ZINV_TSTEP
- END DO
- ZW5(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW5(I1(JL), I2(JL), I3(JL)) = ZTOT_RGWETH(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'WETH', ( zw1(:, :, :) + zw2(:, :, :) ) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'WETH', -zw1(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'WETH', -zw2(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'WETH', -zw3(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'WETH', -zw4(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'WETH', -zw5(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_add( tbudgets(NBUDGET_RH), 'WETH', ( zw1(:, :, :) + zw2(:, :, :) + zw3(:, :, :) &
- + zw4(:, :, :) + zw5(:, :, : ) ) &
- * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RGWETH(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'HGCV', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_add( tbudgets(NBUDGET_RH), 'HGCV', zw(:, :, :) * prhodj(:, :, :) )
-
- ZW1(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW1(I1(JL), I2(JL), I3(JL)) = ZTOT_RCDRYH(JL) * ZINV_TSTEP
- END DO
- ZW2(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW2(I1(JL), I2(JL), I3(JL)) = ZTOT_RRDRYH(JL) * ZINV_TSTEP
- END DO
- ZW3(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW3(I1(JL), I2(JL), I3(JL)) = ZTOT_RIDRYH(JL) * ZINV_TSTEP
- END DO
- ZW4(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW4(I1(JL), I2(JL), I3(JL)) = ZTOT_RSDRYH(JL) * ZINV_TSTEP
- END DO
- ZW5(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW5(I1(JL), I2(JL), I3(JL)) = ZTOT_RGDRYH(JL) * ZINV_TSTEP
- END DO
- ZW6(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW6(I1(JL), I2(JL), I3(JL)) = ZTOT_RDRYHG(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) &
- call Budget_store_add( tbudgets(NBUDGET_TH), 'DRYH', ( zw1(:, :, :) + zw2(:, :, :) ) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'DRYH', -zw1(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'DRYH', -zw2(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'DRYH', -zw3(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'DRYH', -zw4(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_add( tbudgets(NBUDGET_RG), 'DRYH', ( -zw5(:, :, :) + zw6(:, :, : ) ) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_add( tbudgets(NBUDGET_RH), 'DRYH', ( zw1(:, :, :) + zw2(:, :, :) + zw3(:, :, :) &
- + zw4(:, :, :) + zw5(:, :, : )- zw6(:, :, :) ) &
- * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RHMLTR(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'HMLT', -zw(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'HMLT', zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_add( tbudgets(NBUDGET_RH), 'HMLT', -zw(:, :, :) * prhodj(:, :, :) )
- ENDIF
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RIMLTC(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'IMLT', -zw(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'IMLT', zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'IMLT', -zw(:, :, :) * prhodj(:, :, :) )
-
- ZW(:,:,:) = 0.
- DO JL=1,IMICRO
- ZW(I1(JL), I2(JL), I3(JL)) = ZTOT_RCBERI(JL) * ZINV_TSTEP
- END DO
- if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'BERFI', zw(:, :, :) * zz_diff(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rc ) call Budget_store_add( tbudgets(NBUDGET_RC), 'BERFI', -zw(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'BERFI', zw(:, :, :) * prhodj(:, :, :) )
-
- deallocate( zw1, zw2, zw3, zw4 )
- if ( krr == 7 ) deallocate( zw5, zw6 )
- if ( lbudget_th ) deallocate( zz_diff )
-ENDIF
-!
-!*** 7.3 Final tendencies
-!
-!$acc kernels
-PRVS(:,:,:) = ZW_RVS(:,:,:)
-PRCS(:,:,:) = ZW_RCS(:,:,:)
-PRRS(:,:,:) = ZW_RRS(:,:,:)
-PRIS(:,:,:) = ZW_RIS(:,:,:)
-PRSS(:,:,:) = ZW_RSS(:,:,:)
-PRGS(:,:,:) = ZW_RGS(:,:,:)
-IF (KRR==7) THEN
- PRHS(:,:,:) = ZW_RHS(:,:,:)
-ENDIF
-PTHS(:,:,:) = ZW_THS(:,:,:)
-!$acc end kernels
-!
-!-------------------------------------------------------------------------------
-!
-!* 8. COMPUTE THE SEDIMENTATION (RS) SOURCE
-! -------------------------------------
-!
-IF(LSEDIM_AFTER) THEN
- !
- !* 8.1 sedimentation
- !
- if ( lbudget_rc .and. osedic ) call Budget_store_init( tbudgets(NBUDGET_RC), 'SEDI', prcs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_init( tbudgets(NBUDGET_RR), 'SEDI', prrs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'SEDI', pris(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_init( tbudgets(NBUDGET_RS), 'SEDI', prss(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_init( tbudgets(NBUDGET_RG), 'SEDI', prgs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_init( tbudgets(NBUDGET_RH), 'SEDI', prhs(:, :, :) * prhodj(:, :, :) )
-
- !Init only if not osedic (to prevent crash with double init)
- !Remark: the 2 source terms SEDI and DEPO could be mixed and stored in the same source term (SEDI)
- ! if osedic=T and ldeposc=T (a warning is printed in ini_budget in that case)
- if ( lbudget_rc .and. ldeposc .and. .not.osedic ) &
- call Budget_store_init( tbudgets(NBUDGET_RC), 'DEPO', prcs(:, :, :) * prhodj(:, :, :) )
-
- IF(HSEDIM=='STAT') THEN
- !SR: It *seems* that we must have two separate calls for ifort
- IF(KRR==7) THEN
- CALL ICE4_SEDIMENTATION_STAT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCS*PTSTEP, PRRS, PRRS*PTSTEP, PRIS, PRIS*PTSTEP,&
- &PRSS, PRSS*PTSTEP, PRGS, PRGS*PTSTEP,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PINPRH=PINPRH, PRHT=PRHS*PTSTEP, PRHS=PRHS, PFPR=PFPR)
- ELSE
- CALL ICE4_SEDIMENTATION_STAT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ,&
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCS*PTSTEP, PRRS, PRRS*PTSTEP, PRIS, PRIS*PTSTEP,&
- &PRSS, PRSS*PTSTEP, PRGS, PRGS*PTSTEP,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PFPR=PFPR)
- ENDIF
-!$acc kernels
- PINPRS(:,:) = PINPRS(:,:) + ZINPRI(:,:)
-!$acc end kernels
- !No negativity correction here as we apply sedimentation on PR.S*PTSTEP variables
- ELSEIF(HSEDIM=='SPLI') THEN
- !SR: It *seems* that we must have two separate calls for ifort
- IF(KRR==7) THEN
- CALL ICE4_SEDIMENTATION_SPLIT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCT, PRRS, PRRT, PRIS, PRIT, PRSS, PRST, PRGS, PRGT,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PINPRH=PINPRH, PRHT=PRHT, PRHS=PRHS, PFPR=PFPR)
- ELSE
- CALL ICE4_SEDIMENTATION_SPLIT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, IKTB, IKTE, KKT, KKL, &
- &PTSTEP, KRR, OSEDIC, LDEPOSC, XVDEPOSC, PDZZ, &
- &PRHODREF, PPABST, PTHT, PRHODJ, &
- &PRCS, PRCT, PRRS, PRRT, PRIS, PRIT, PRSS, PRST, PRGS, PRGT,&
- &PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, &
- &PSEA=PSEA, PTOWN=PTOWN, &
- &PFPR=PFPR)
- ENDIF
-!$acc kernels
- PINPRS(:,:) = PINPRS(:,:) + ZINPRI(:,:)
-!$acc end kernels
- !We correct negativities with conservation
- !SPLI algorith uses a time-splitting. Inside the loop a temporary m.r. is used.
- ! It is initialized with the m.r. at T and is modified by two tendencies:
- ! sedimentation tendency and an external tendency which represents all other
- ! processes (mainly advection and microphysical processes). If both tendencies
- ! are negative, sedimentation can remove a specie at a given sub-timestep. From
- ! this point sedimentation stops for the remaining sub-timesteps but the other tendency
- ! will be still active and will lead to negative values.
- ! We could prevent the algorithm to not consume too much a specie, instead we apply
- ! a correction here.
- CALL CORRECT_NEGATIVITIES(KIT, KJT, KKT, KRR, PRVS, PRCS, PRRS, &
- &PRIS, PRSS, PRGS, &
- &PTHS, ZZ_LVFACT, ZZ_LSFACT, PRHS)
- ELSE
- call Print_msg( NVERB_FATAL, 'GEN', 'RAIN_ICE_RED', 'no sedimentation scheme for HSEDIM='//HSEDIM )
- END IF
- !
- !* 8.2 budget storage
- !
- if ( lbudget_rc .and. osedic ) call Budget_store_end( tbudgets(NBUDGET_RC), 'SEDI', prcs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rr ) call Budget_store_end( tbudgets(NBUDGET_RR), 'SEDI', prrs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI), 'SEDI', pris(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rs ) call Budget_store_end( tbudgets(NBUDGET_RS), 'SEDI', prss(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rg ) call Budget_store_end( tbudgets(NBUDGET_RG), 'SEDI', prgs(:, :, :) * prhodj(:, :, :) )
- if ( lbudget_rh ) call Budget_store_end( tbudgets(NBUDGET_RH), 'SEDI', prhs(:, :, :) * prhodj(:, :, :) )
-
- !If osedic=T and ldeposc=T, DEPO is in fact mixed and stored with the SEDI source term
- !(a warning is printed in ini_budget in that case)
- if ( lbudget_rc .and. ldeposc .and. .not.osedic) &
- call Budget_store_end( tbudgets(NBUDGET_RC), 'DEPO', prcs(:, :, :) * prhodj(:, :, :) )
-
- !sedimentation of rain fraction
- IF (PRESENT(PRHS)) THEN
- CALL ICE4_RAINFR_VERT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, KKT, KKL, PRAINFR, PRRS(:,:,:)*PTSTEP, &
- &PRSS(:,:,:)*PTSTEP, PRGS(:,:,:)*PTSTEP, PRHS(:,:,:)*PTSTEP)
- ELSE
- CALL ICE4_RAINFR_VERT(IIB, IIE, KIT, IJB, IJE, KJT, IKB, IKE, KKT, KKL, PRAINFR, PRRS(:,:,:)*PTSTEP, &
- &PRSS(:,:,:)*PTSTEP, PRGS(:,:,:)*PTSTEP)
- ENDIF
-ENDIF
-
-!$acc end data
-
-#ifdef MNH_OPENACC
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE()
-#endif
-
-IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PCIT,"RAIN_ICE_RED end:PCIT")
- CALL MPPDB_CHECK(PTHS,"RAIN_ICE_RED end:PTHS")
- CALL MPPDB_CHECK(PRVS,"RAIN_ICE_RED end:PRVS")
- CALL MPPDB_CHECK(PRCS,"RAIN_ICE_RED end:PRCS")
- CALL MPPDB_CHECK(PRRS,"RAIN_ICE_RED end:PRRS")
- CALL MPPDB_CHECK(PRIS,"RAIN_ICE_RED end:PRIS")
- CALL MPPDB_CHECK(PRSS,"RAIN_ICE_RED end:PRSS")
- CALL MPPDB_CHECK(PRGS,"RAIN_ICE_RED end:PRGS")
- CALL MPPDB_CHECK(PINDEP,"RAIN_ICE_RED end:PINDEP")
- !Check all OUT arrays
- CALL MPPDB_CHECK(PINPRC,"RAIN_ICE_RED end:PINPRC")
- CALL MPPDB_CHECK(PINPRR,"RAIN_ICE_RED end:PINPRR")
- CALL MPPDB_CHECK(PEVAP3D,"RAIN_ICE_RED end:PEVAP3D")
- CALL MPPDB_CHECK(PINPRS,"RAIN_ICE_RED end:PINPRS")
- CALL MPPDB_CHECK(PINPRG,"RAIN_ICE_RED end:PINPRG")
- CALL MPPDB_CHECK(PRAINFR,"RAIN_ICE_RED end:PRAINFR")
- IF (PRESENT(PINPRH)) CALL MPPDB_CHECK(PINPRH,"RAIN_ICE_RED end:PINPRH")
- IF (PRESENT(PFPR)) CALL MPPDB_CHECK(PFPR, "RAIN_ICE_RED end:PFPR")
-END IF
-
-!$acc end data
-
-CONTAINS
- !
- SUBROUTINE CORRECT_NEGATIVITIES(KIT, KJT, KKT, KRR, PRV, PRC, PRR, &
- &PRI, PRS, PRG, &
- &PTH, PLVFACT, PLSFACT, PRH)
- !
- IMPLICIT NONE
- !
- INTEGER, INTENT(IN) :: KIT, KJT, KKT, KRR
- REAL, DIMENSION(KIT, KJT, KKT), INTENT(INOUT) :: PRV, PRC, PRR, PRI, PRS, PRG, PTH
- REAL, DIMENSION(KIT, KJT, KKT), INTENT(IN) :: PLVFACT, PLSFACT
- REAL, DIMENSION(KIT, KJT, KKT), OPTIONAL, INTENT(INOUT) :: PRH
- !
- INTEGER :: JI, JJ, JK
- !
- !
-#ifndef MNH_OPENACC
- LOGICAL, DIMENSION(:,:,:), allocatable :: GW
- REAL, DIMENSION(:,:,:), allocatable :: ZW
-#else
- LOGICAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: GW
- REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZW
-#endif
- !
- !
- IF (MPPDB_INITIALIZED) THEN
- !Check all IN arrays
- CALL MPPDB_CHECK(PLVFACT,"CORRECT_NEGATIVITIES beg:PLVFACT")
- CALL MPPDB_CHECK(PLSFACT,"CORRECT_NEGATIVITIES beg:PLSFACT")
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PRV,"CORRECT_NEGATIVITIES beg:PRV")
- CALL MPPDB_CHECK(PRC,"CORRECT_NEGATIVITIES beg:PRC")
- CALL MPPDB_CHECK(PRR,"CORRECT_NEGATIVITIES beg:PRR")
- CALL MPPDB_CHECK(PRI,"CORRECT_NEGATIVITIES beg:PRI")
- CALL MPPDB_CHECK(PRS,"CORRECT_NEGATIVITIES beg:PRS")
- CALL MPPDB_CHECK(PRG,"CORRECT_NEGATIVITIES beg:PRG")
- IF(PRESENT(PRH)) CALL MPPDB_CHECK(PRH,"CORRECT_NEGATIVITIES beg:PRH")
- CALL MPPDB_CHECK(PTH,"CORRECT_NEGATIVITIES beg:PTH")
- END IF
-
-!$acc data present( PRV, PRC, PRR, PRI, PRS, PRG, PTH, PLVFACT, PLSFACT )
-
-#ifndef MNH_OPENACC
- allocate( gw(size( prv, 1 ), size( prv, 2 ), size( prv, 3 ) ) )
- allocate( zw(size( prv, 1 ), size( prv, 2 ), size( prv, 3 ) ) )
-#else
- !Pin positions in the pools of MNH memory
- CALL MNH_MEM_POSITION_PIN()
-
- CALL MNH_MEM_GET( gw, size( prv, 1 ), size( prv, 2 ), size( prv, 3 ) )
- CALL MNH_MEM_GET( zw, size( prv, 1 ), size( prv, 2 ), size( prv, 3 ) )
-
-!$acc data present( GW, ZW )
-#endif
-
-!$acc data present( PRH ) if ( present( PRH ) )
-!$acc kernels
- !We correct negativities with conservation
- ! 1) deal with negative values for mixing ratio, except for vapor
- DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ZW(JI,JJ,JK) =PRC(JI,JJ,JK)-MAX(PRC(JI,JJ,JK), 0.)
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLVFACT(JI,JJ,JK)
- PRC(JI,JJ,JK)=PRC(JI,JJ,JK)-ZW(JI,JJ,JK)
-
- ZW(JI,JJ,JK) =PRR(JI,JJ,JK)-MAX(PRR(JI,JJ,JK), 0.)
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLVFACT(JI,JJ,JK)
- PRR(JI,JJ,JK)=PRR(JI,JJ,JK)-ZW(JI,JJ,JK)
-
- ZW(JI,JJ,JK) =PRI(JI,JJ,JK)-MAX(PRI(JI,JJ,JK), 0.)
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
- PRI(JI,JJ,JK)=PRI(JI,JJ,JK)-ZW(JI,JJ,JK)
-
- ZW(JI,JJ,JK) =PRS(JI,JJ,JK)-MAX(PRS(JI,JJ,JK), 0.)
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
- PRS(JI,JJ,JK)=PRS(JI,JJ,JK)-ZW(JI,JJ,JK)
-
- ZW(JI,JJ,JK) =PRG(JI,JJ,JK)-MAX(PRG(JI,JJ,JK), 0.)
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
- PRG(JI,JJ,JK)=PRG(JI,JJ,JK)-ZW(JI,JJ,JK)
- ENDDO
- ENDDO
- ENDDO
-
- IF(KRR==7) THEN
- DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ZW(JI,JJ,JK) =PRH(JI,JJ,JK)-MAX(PRH(JI,JJ,JK), 0.)
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
- PRH(JI,JJ,JK)=PRH(JI,JJ,JK)-ZW(JI,JJ,JK)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ! 2) deal with negative vapor mixing ratio
- DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ! for rc and ri, we keep ice fraction constant
- ZW(JI,JJ,JK)=MIN(1., MAX(XRTMIN(1)-PRV(JI,JJ,JK), 0.) / &
- &MAX(PRC(JI,JJ,JK)+PRI(JI,JJ,JK), 1.E-20)) ! Proportion of rc+ri to convert into rv
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)* &
- &(PRC(JI,JJ,JK)*PLVFACT(JI,JJ,JK)+PRI(JI,JJ,JK)*PLSFACT(JI,JJ,JK))
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)*(PRC(JI,JJ,JK)+PRI(JI,JJ,JK))
- PRC(JI,JJ,JK)=(1.-ZW(JI,JJ,JK))*PRC(JI,JJ,JK)
- PRI(JI,JJ,JK)=(1.-ZW(JI,JJ,JK))*PRI(JI,JJ,JK)
-
- ZW(JI,JJ,JK)=MIN(MAX(PRR(JI,JJ,JK), 0.), &
- &MAX(XRTMIN(1)-PRV(JI,JJ,JK), 0.)) ! Quantity of rr to convert into rv
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PRR(JI,JJ,JK)=PRR(JI,JJ,JK)-ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLVFACT(JI,JJ,JK)
-
- ZW(JI,JJ,JK)=MIN(MAX(PRS(JI,JJ,JK), 0.), &
- &MAX(XRTMIN(1)-PRV(JI,JJ,JK), 0.)) ! Quantity of rs to convert into rv
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PRS(JI,JJ,JK)=PRS(JI,JJ,JK)-ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
-
- ZW(JI,JJ,JK)=MIN(MAX(PRG(JI,JJ,JK), 0.), &
- &MAX(XRTMIN(1)-PRV(JI,JJ,JK), 0.)) ! Quantity of rg to convert into rv
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PRG(JI,JJ,JK)=PRG(JI,JJ,JK)-ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
- ENDDO
- ENDDO
- ENDDO
-
- IF(KRR==7) THEN
- DO JK = 1, KKT
- DO JJ = 1, KJT
- DO JI = 1, KIT
- ZW(JI,JJ,JK)=MIN(MAX(PRH(JI,JJ,JK), 0.), &
- &MAX(XRTMIN(1)-PRV(JI,JJ,JK), 0.)) ! Quantity of rh to convert into rv
- PRV(JI,JJ,JK)=PRV(JI,JJ,JK)+ZW(JI,JJ,JK)
- PRH(JI,JJ,JK)=PRH(JI,JJ,JK)-ZW(JI,JJ,JK)
- PTH(JI,JJ,JK)=PTH(JI,JJ,JK)-ZW(JI,JJ,JK)*PLSFACT(JI,JJ,JK)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-!$acc end kernels
-!$acc end data
-
-!$acc end data
-
-#ifdef MNH_OPENACC
- !Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
- CALL MNH_MEM_RELEASE()
-#endif
-
-!$acc end data
-
- IF (MPPDB_INITIALIZED) THEN
- !Check all INOUT arrays
- CALL MPPDB_CHECK(PRV,"CORRECT_NEGATIVITIES end:PRV")
- CALL MPPDB_CHECK(PRC,"CORRECT_NEGATIVITIES end:PRC")
- CALL MPPDB_CHECK(PRR,"CORRECT_NEGATIVITIES end:PRR")
- CALL MPPDB_CHECK(PRI,"CORRECT_NEGATIVITIES end:PRI")
- CALL MPPDB_CHECK(PRS,"CORRECT_NEGATIVITIES end:PRS")
- CALL MPPDB_CHECK(PRG,"CORRECT_NEGATIVITIES end:PRG")
- IF(PRESENT(PRH)) CALL MPPDB_CHECK(PRH,"CORRECT_NEGATIVITIES end:PRH")
- CALL MPPDB_CHECK(PTH,"CORRECT_NEGATIVITIES end:PTH")
- END IF
-
- END SUBROUTINE CORRECT_NEGATIVITIES
-!
-#endif
-END SUBROUTINE RAIN_ICE_RED
-
diff --git a/src/ZSOLVER/set_ref.f90 b/src/ZSOLVER/set_ref.f90
deleted file mode 100644
index a5e8b7532..000000000
--- a/src/ZSOLVER/set_ref.f90
+++ /dev/null
@@ -1,603 +0,0 @@
-!MNH_LIC Copyright 1994-2021 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_SET_REF
-!###################
-!
-INTERFACE
-!
- SUBROUTINE SET_REF(KMI,TPINIFILE, &
- PZZ,PZHAT,PJ,PDXX,PDYY,HLBCX,HLBCY, &
- PREFMASS,PMASS_O_PHI0,PLINMASS, &
- PRHODREF,PTHVREF,PRVREF,PEXNREF,PRHODJ )
-!
-USE MODD_IO, ONLY : TFILEDATA
-!
-INTEGER, INTENT(IN) :: KMI ! Model index
-TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height of the w levels
- ! with orography
-REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Height of the w levels
- ! in the transformed space (GCS transf.) or without orography
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PJ ! Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
-CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! type of lateral boundary
-! ! condition (i=IB, i=IE+1)
-CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! type of lateral boundary
- ! condition (j=JB, j=JE+1)
-REAL, INTENT(OUT) :: PREFMASS ! Mass of the ref. atmosphere
- ! contained in the simulation domain
-REAL, INTENT(OUT) :: PMASS_O_PHI0 ! normalization constant
- ! used in the PHI0 computation
-REAL, INTENT(OUT) :: PLINMASS ! lineic mass through open
- ! boundaries
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHODREF ! rhod for reference state
- ! with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHVREF ! Thetav for reference state
- ! with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVREF ! mixing ratio for the reference
- ! state with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEXNREF ! Exner function for reference
- ! state with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHODJ ! rhod J
-!
-END SUBROUTINE SET_REF
-!
-END INTERFACE
-!
-END MODULE MODI_SET_REF
-!
-!
-! #########################################################################
- SUBROUTINE SET_REF(KMI,TPINIFILE, &
- PZZ,PZHAT,PJ,PDXX,PDYY,HLBCX,HLBCY, &
- PREFMASS,PMASS_O_PHI0,PLINMASS, &
- PRHODREF,PTHVREF,PRVREF,PEXNREF,PRHODJ )
-! #########################################################################
-!
-!!**** *SET_REF* - routine to set reference state for anelastic approximation
-!!
-!! PURPOSE
-!! -------
-! The purpose of this routine is to set reference state for anelastic
-! approximation
-!
-!!** METHOD
-!! ------
-!! The vertical profiles of thetav, rho (dry) for anelastic reference
-!! state and the Exner function at model top are read in LFIFM file
-!! (TPINIFILE). These vertical profiles do not take
-!! into account the orography. Since these vertical profiles are the same for
-!! all nested models, they are only read at the first call by INI_MODEL1
-!! (i.e. KMI=1). Variables in module MODD_REF are therefore initialized during
-!! the initialization of model 1.
-!! Then, the 3D reference state which takes into account the orography is
-!! deduced from these vertical profiles by a linear interpolation in height
-!! for virtual potential temperature and density.
-!! The Exner function is computed by integration of hydrostatic relation
-!! from model top.
-!! Then, rho J is computed and the total mass of reference atmosphere is
-!! diagnozed.
-!!
-!! The lineic mass is computed on the faces with open lateral boundary.
-!!
-!! EXTERNAL
-!! --------
-!! FMREAD : to read data in LFIFM file
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!! Module MODD_PARAMETERS : contains declaration of parameter variables
-!!
-!! JPHEXT : Horizontal external points number
-!! JPVEXT : Vertical external points number
-!!
-!! Module MODD_REF : contains declaration of reference state variables
-!! without orography
-!!
-!! XRHODREFZ: rhod for reference state without orography
-!! XTHVREFZ : thetav for reference state without orography
-!! XEXNTOP : Exner function at model top
-!!
-!! Module MODD_CST : contains physical constants
-!!
-!! XRD : Gaz constant for dry air Rd
-!! XCPD : Specific heat at constant pressure for dry air Cp
-!! XP00 : Reference pressure
-!! XG : gravity constant
-!! XCPD : specific heat for dry air
-!!
-!! Module MODD_CONF : contains configuration variables
-!!
-!! NVERB : verbosity level
-!!
-!! REFERENCE
-!! ---------
-!! Book2 of documentation (routine SET_REF)
-!!
-!!
-!! AUTHOR
-!! ------
-!! V. Ducrocq * Meteo France *
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 30/06/94
-!! Modification 02/11/94 (J.Stein) change the extrapolation for thvref
-!! Modification 02/02/95 (J.P.Lafore) Total mass computation to
-!! diagnoze the absolute pressure function Phi0
-!! Modification 01/02/95 (J.Stein) change the extrapolation for
-!! rhodref
-!! Modification 09/02/95 (V.Masson) computation of lineic mass for
-!! open boundaries
-!! Modification 30/10/96 (V.Masson) add prints
-!! Modification 02/02/95 (J.P.Lafore) Introduction of 2 anelastic systems:
-!! Modified Anelastic Equation and one derived
-!! from Durran (1989), ANE and DUR respectively
-!! Modification 20/10/97 (J.P.Lafore) introduction of 'DAVI' type of lbc
-!! Modification 14/08/98 (V. Ducrocq) //
-!! Modification 14/07/01 (V. MASSON) LNEUTRAL case
-!! 13/09/01 (J. Stein) change the option for the
-!! point under the ground
-!! Modification 03/12/02 (P. Jabouille) add no thinshell condition
-!! Modification 05/06 Remove the 'DAVI' type of lbc
-!! Modification 07/13 (J.Colin) Special case for LBOUSS=T
-!! Modification 07/13 (M.Moge) calling UPDATE_HALO_ll on PRHODJ, PRVREF,
-!! PRHODREF, PEXNREF, PTHVREF after computation
-!! 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
-!! Jean-Luc Redelsperger 03/2021 : OCEAN LES case
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-USE MODD_CONF
-USE MODD_CST
-USE MODD_DYN_n, ONLY: LOCEAN
-USE MODD_IO, ONLY: TFILEDATA
-USE MODD_LUNIT_n, ONLY: TLUOUT
-USE MODD_PARAMETERS
-USE MODD_REF
-!
-USE MODE_IO_FIELD_READ, only: IO_Field_read
-USE MODE_ll
-USE MODE_MPPDB
-USE MODE_REPRO_SUM
-#ifdef MNH_BITREP
-USE MODI_BITREP
-#endif
-!
-IMPLICIT NONE
-!
-!* 0.1 declarations of arguments
-!
-INTEGER, INTENT(IN) :: KMI ! Model index
-TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height of the w levels
- ! with orography
-REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Height of the w levels
- ! in the transformed space (GCS transf.) or without orography
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PJ ! Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
-CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! type of lateral boundary
-! ! condition (i=IB, i=IE+1)
-CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! type of lateral boundary
- ! condition (j=JB, j=JE+1)
-
-REAL, INTENT(OUT) :: PREFMASS ! Mass of the ref. atmosphere
- ! contained in the simulation domain
-REAL, INTENT(OUT) :: PMASS_O_PHI0 ! normalization constant
- ! used in the PHI0 computation
-REAL, INTENT(OUT) :: PLINMASS ! lineic mass through open
- ! boundaries
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHODREF ! rhod for reference state
- ! with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHVREF ! Thetav for reference state
- ! with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVREF ! mixing ratio for the reference
- ! state with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEXNREF ! Exner function for reference
- ! state with orography
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHODJ ! rhod J
-!
-!* 0.2 declarations of local variables
-!
-INTEGER :: ILUOUT ! Unit number for prints
-REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)) :: ZZM
- ! height of the mass levels
- ! with orography
-REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)) :: ZRHOREF
- ! Reference density
-REAL, DIMENSION(SIZE(PZZ,3)) :: ZZHATM ! height of the mass levels
- ! in the transformed space (GCS transf.) or without orography
-REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)) :: ZDENSOC,ZPFLUX,ZPMASS
-!
-INTEGER :: IIU ! Upper dimension in x direction
-INTEGER :: IJU ! Upper dimension in y direction
-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
-INTEGER :: JKS ! Loop index
-INTEGER :: IKS ! index of 1D level just above 3d level at I,J
-INTEGER :: JKLOOP ! Loop index
-INTEGER :: IINFO_ll ! return status of the // routines
-REAL :: ZGSCPD ! = g/Cpd
-REAL :: ZCVD_O_RD ! = Cvd / Rd
-REAL :: ZCVD_O_RDCPD ! = Cvd / (Rd*Cpd)
-REAL :: ZDZ1SDZ,ZDZ2SDZ ! working arrays
-REAL :: ZD1 ! DELTA1 (switch 0/1) for thinshell approximation
-!JUAN16
-REAL, ALLOCATABLE, DIMENSION (:,:) :: ZREFMASS_2D , ZMASS_O_PHI0_2D
-REAL, ALLOCATABLE, DIMENSION (:,:) :: ZLINMASS_W_2D , ZLINMASS_E_2D , ZLINMASS_S_2D , ZLINMASS_N_2D
-!REAL :: ZREFMASS , ZMASS_O_PHI0 , ZLINMASS ! total leak of mass
-!JUAN16
-TYPE(LIST_ll), POINTER :: TZFIELDS_ll=>NULL() ! list of fields to exchange
-!
-!
-!-------------------------------------------------------------------------------
-!
-!* 1. COMPUTE DIMENSIONS OF ARRAYS AND OTHER INDICES:
-! ----------------------------------------------
-CALL GET_DIM_EXT_ll('B',IIU,IJU)
-CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
-IKU = SIZE(PEXNREF,3)
-IKB = 1 + JPVEXT
-IKE = IKU - JPVEXT
-!
-ILUOUT = TLUOUT%NLU
-!
-!* 2. READ REFERENCE STATE WITHOUT OROGRAPHY IN LFIFM FILE
-! ----------------------------------------------------
-!
-IF (KMI == 1) THEN
- CALL IO_Field_read(TPINIFILE,'RHOREFZ',XRHODREFZ)
- CALL IO_Field_read(TPINIFILE,'THVREFZ',XTHVREFZ)
- CALL IO_Field_read(TPINIFILE,'EXNTOP', XEXNTOP)
-!
- LNEUTRAL=.FALSE.
- IF (MAXVAL(XTHVREFZ(IKB:IKE))-MINVAL(XTHVREFZ(IKB:IKE)) < 1.E-10) LNEUTRAL=.TRUE.
-END IF
-!* Ref state diff for O & A in LES coupled mode
-IF (LCOUPLES .AND. LOCEAN) THEN
- CALL IO_Field_read(TPINIFILE,'RHOREFZ',XRHODREFZO)
- CALL IO_Field_read(TPINIFILE,'THVREFZ',XTHVREFZO)
- CALL IO_Field_read(TPINIFILE,'EXNTOP', XEXNTOPO)
-END IF
-!-------------------------------------------------------------------------------
-!
-!* 3. SET REFERENCE STATE WITH OROGRAPHY
-! ----------------------------------
-!
-!
-!* 3.1 Compute level and height of mass position
-!
-DO JK = 1,IKU-1
- ZZM(:,:,JK) = 0.5*(PZZ(:,:,JK) + PZZ(:,:,JK+1))
- ZZHATM(JK) = 0.5*(PZHAT(JK)+PZHAT(JK+1))
-END DO
-ZZHATM(IKU) = 2.* PZHAT(IKU) -ZZHATM(IKU-1)
-ZZM(:,:,IKU) = 2.* PZZ(:,:,IKU) -ZZM(:,:,IKU-1)
-! ZZM(:,:,IKU) is always smaller than or equal ZZHATM(IKU)
-!
-!
-CALL MPPDB_CHECK3D(ZZM,"SET_REF::ZZM",PRECISION)
-!
-!* 3.2 Interpolation
-!
-IF (LCOUPLES .AND. LOCEAN) THEN
- DO JK = 1,IKU
- PTHVREF(:,:,JK) = XTHVREFZO(JK)
- PRHODREF(:,:,JK)= XRHODREFZO(JK)
- END DO
-ELSE
- DO JI = 1,SIZE(PZZ,1)
- DO JJ = 1,SIZE(PZZ,2)
-!
- DO JK = 1,IKU
-!
- IF (ZZM(JI,JJ,JK) >= ZZHATM(IKU)) THEN ! copy out when
- PTHVREF(JI,JJ,JK) = XTHVREFZ(IKU) ! ZZM(IKU)= ZZHATM(IKU)
- PRHODREF(JI,JJ,JK) = XRHODREFZ(IKU) ! (in case zs=0.)
-!
- ELSE ! search levels on the mass grid without orography
- IF (ZZM(JI,JJ,JK) < ZZHATM(2)) THEN
- IKS=3
- ELSE
- SEARCH : DO JKS = 3,IKU
- IF((ZZM(JI,JJ,JK) >= ZZHATM(JKS-1)).AND.(ZZM(JI,JJ,JK) < ZZHATM(JKS))) &
- THEN ! interpolation with the values on the grid without
- ! orography
- IKS=JKS
- EXIT SEARCH
- END IF
- END DO SEARCH
- END IF
- ZDZ1SDZ = (ZZM(JI,JJ,JK)-ZZHATM(IKS-1)) / (ZZHATM(IKS)-ZZHATM(IKS-1))
- ZDZ2SDZ = 1. - ZDZ1SDZ
- PTHVREF(JI,JJ,JK) = ( ZDZ1SDZ* XTHVREFZ(IKS) ) &
- + (ZDZ2SDZ* XTHVREFZ(IKS-1) )
- PRHODREF(JI,JJ,JK)= ( ZDZ1SDZ* XRHODREFZ(IKS) ) &
- + (ZDZ2SDZ* XRHODREFZ(IKS-1) )
- END IF
- END DO
- END DO
- END DO
-END IF
-!
-! change the extrapolation option for the thvref field to be consistent with
-! the extrapolation option for the flottability at the ground and for rhodref
-! to be consistent with the extrapolation to compute a divergence
-PTHVREF(:,:,IKB-1) = PTHVREF(:,:,IKB)
-PRHODREF(:,:,IKB-1) = PRHODREF(:,:,IKB)
-CALL MPPDB_CHECK3D(PTHVREF,"SET_REF::PTHVREF",PRECISION)
-CALL MPPDB_CHECK3D(PRHODREF,"SET_REF::PRHODREF",PRECISION)
-!
-!-------------------------------------------------------------------------------
-!
-!* 4. COMPUTE EXNER FUNCTION AT MASS GRID POINT
-! ----------------------------------------
-IF (LCARTESIAN .OR. LTHINSHELL) THEN
- ZD1=0.
-ELSE
- ZD1=1.
-ENDIF
-!
-ZGSCPD = XG/XCPD
-!
-IF (LOCEAN) THEN
-!--------------------------------
-! Pressure at domain top (Flux point !!!) saved in Press_mass above the ocen sfc
- IF (LCOUPLES) THEN
- ZPMASS(:,:,IKE+1)= XP00 *XEXNTOPO**(XCPD/XRD)
- ELSE
- ZPMASS(:,:,IKE+1)= XP00 *XEXNTOP**(XCPD/XRD)
- ENDIF
- ZPMASS(:,:,IKE) = ZPMASS(:,:,IKE+1) +XG*PRHODREF(:,:,IKE)*(PZZ(:,:,IKE+1)-ZZM(:,:,IKE))
- DO JK = IKE-1,1,-1
- ZPMASS(:,:,JK) = ZPMASS(:,:,JK+1) + XG * &
- .5*(PRHODREF(:,:,JK)+ PRHODREF(:,:,JK+1)) * (ZZM(:,:,JK+1) -ZZM(:,:,JK))
- END DO
-!
- IF (LCOUPLES) THEN
- DO JK = IKE+1, IKU
-! Pressure above domain top (i.e. ocean sfc), i.e. in atmosphere (should be not used)
- ZPMASS(:,:,JK) = XP00 *XEXNTOPO**(XCPD/XRD)
- END DO
- ELSE
- DO JK = IKE+1, IKU
-! Pressure above domain top (i.e. ocean sfc), i.e. in atmosphere (should be not used)
- ZPMASS(:,:,JK) = XP00 *XEXNTOP**(XCPD/XRD)
- END DO
- ENDIF
- PEXNREF(:,:,:)= (ZPMASS(:,:,:)/XP00)**(XRD/XCPD)
- ! OCEAN end
-ELSE
- ! ATMOSPHERE
- PEXNREF(:,:,IKE)=(XEXNTOP*(1.+ZD1*2./7.*(PZZ(:,:,IKE+1)-ZZM(:,:,IKE))/ &
- (XRADIUS+(PZZ(:,:,IKE+1)+ZZM(:,:,IKE))/2.)) &
- + ZGSCPD/PTHVREF(:,:,IKE)*(PZZ(:,:,IKE+1)-ZZM(:,:,IKE)))/ &
- (1.-ZD1*2./7.*(PZZ(:,:,IKE+1)-ZZM(:,:,IKE))/(XRADIUS+(PZZ(:,:,IKE+1)+ZZM(:,:,IKE))/2.))
-!
- DO JK = IKE-1, 1, -1
- PEXNREF(:,:,JK)=(PEXNREF(:,:,JK+1)*(1.+ZD1*2./7.*(ZZM(:,:,JK+1) -ZZM(:,:,JK))/ &
- (XRADIUS+PZZ(:,:,JK+1)))+ &
- 2.*ZGSCPD/(PTHVREF(:,:,JK+1)+PTHVREF(:,:,JK))*(ZZM(:,:,JK+1) -ZZM(:,:,JK)))/&
- (1.-ZD1*2./7.*(ZZM(:,:,JK+1) -ZZM(:,:,JK))/(XRADIUS+PZZ(:,:,JK+1)))
- END DO
-!
- DO JK = IKE+1, IKU
- PEXNREF(:,:,JK)=(PEXNREF(:,:,JK-1)*(1.+ZD1*2./7.*(ZZM(:,:,JK-1) -ZZM(:,:,JK))/ &
- (XRADIUS+PZZ(:,:,JK)))+ &
- 2.*ZGSCPD/(PTHVREF(:,:,JK-1)+PTHVREF(:,:,JK))*(ZZM(:,:,JK-1) -ZZM(:,:,JK)))/&
- (1.-ZD1*2./7.*(ZZM(:,:,JK-1) -ZZM(:,:,JK))/ (XRADIUS+PZZ(:,:,JK)))
- END DO
-!
-END IF
-!
-!
-CALL MPPDB_CHECK3D(PEXNREF,"SET_REF::PEXNREF",PRECISION)
-!-------------------------------------------------------------------------------
-!
-!* 5. SET RHODJ AND REFERENCE DENSITY
-! ---------------------------------
-!
-!
-ZCVD_O_RD = (XCPD / XRD) - 1.
-IF (LBOUSS) THEN
- ZRHOREF(:,:,:) = PRHODREF(:,:,:)
-ELSE
-#ifndef MNH_BITREP
- ZRHOREF(:,:,:) = PEXNREF(:,:,:) ** ZCVD_O_RD * XP00 / ( XRD * PTHVREF(:,:,:) )
-#else
- ZRHOREF(:,:,:) = BR_POW ( PEXNREF(:,:,:) , ZCVD_O_RD ) * XP00 / ( XRD * PTHVREF(:,:,:) )
-#endif
- ZRHOREF(:,:,1)=ZRHOREF(:,:,2) ! this avoids to obtain erroneous values for
- ! rv at this last point
-END IF
-!
-IF ( CEQNSYS == 'DUR' ) THEN
- IF ( SIZE(PRVREF,1) == 0 ) THEN
- PRHODJ(:,:,:) = PRHODREF(:,:,:)* PJ(:,:,:) * PTHVREF(:,:,:) &
- / XTH00
- ELSE
- PRVREF(:,:,:) = ( ZRHOREF(:,:,:)/PRHODREF(:,:,:) ) - 1.
- PRHODJ(:,:,:) = PRHODREF(:,:,:)* PJ(:,:,:) * PTHVREF(:,:,:) &
- * (1. + PRVREF(:,:,:)) / XTH00
- END IF
-ELSEIF ( CEQNSYS == 'MAE' .OR. CEQNSYS == 'LHE' ) THEN
- PRHODJ(:,:,:) = PRHODREF(:,:,:)* PJ(:,:,:)
-END IF
-!
-! update halo of PRHODJ and PRVREF for future use ( notably in anel_balance_n )
-!
-NULLIFY( TZFIELDS_ll )
-CALL ADD3DFIELD_ll( TZFIELDS_ll, PRHODJ, 'SET_REF::PRHODJ' )
-IF ( SIZE(PRVREF,1) /= 0 ) CALL ADD3DFIELD_ll( TZFIELDS_ll, PRVREF, 'SET_REF::PRVREF' )
-CALL ADD3DFIELD_ll( TZFIELDS_ll, PRHODREF, 'SET_REF::PRHODREF')
-CALL ADD3DFIELD_ll( TZFIELDS_ll, PEXNREF, 'SET_REF::PEXNREF')
-CALL ADD3DFIELD_ll( TZFIELDS_ll, PTHVREF, 'SET_REF::PTHVREF')
-CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
-CALL CLEANLIST_ll(TZFIELDS_ll)
-!
-CALL MPPDB_CHECK3D(ZRHOREF,"SET_REF::ZRHOREF",PRECISION)
-IF ( SIZE(PRVREF,1) /= 0 ) CALL MPPDB_CHECK3D(PRVREF,"SET_REF::PRVREF",PRECISION)
-CALL MPPDB_CHECK3D(PRHODJ,"SET_REF::PRHODJ",PRECISION)
-!
-!* 6. COMPUTES THE TOTAL MASS OF REFERENCE ATMOSPHERE
-! -----------------------------------------------
-!
-IF (CEQNSYS == "LHE" ) THEN
- ZCVD_O_RDCPD = ZCVD_O_RD / XCPD
- !
- ALLOCATE(ZREFMASS_2D(IIB:IIE,IJB:IJE))
- ALLOCATE(ZMASS_O_PHI0_2D(IIB:IIE,IJB:IJE))
- ZREFMASS_2D = 0.
- ZMASS_O_PHI0_2D = 0.
- DO JK = IKB,IKE
- DO JJ = IJB,IJE
- DO JI = IIB,IIE
- ZREFMASS_2D(JI,JJ) = ZREFMASS_2D(JI,JJ) + ZRHOREF (JI,JJ,JK) * PJ(JI,JJ,JK) ! Reference density
- ZMASS_O_PHI0_2D(JI,JJ) = ZMASS_O_PHI0_2D(JI,JJ) + ZRHOREF(JI,JJ,JK) / PTHVREF(JI,JJ,JK) &
- * ZCVD_O_RDCPD * PJ(JI,JJ,JK) / PEXNREF(JI,JJ,JK)
- END DO
- END DO
- END DO
-!
-!JUAN16
-!!$ CALL REDUCESUM_ll(ZREFMASS,IINFO_ll)
-!!$ CALL REDUCESUM_ll(ZMASS_O_PHI0,IINFO_ll)
- PREFMASS = SUM_DD_R2_ll(ZREFMASS_2D)
- PMASS_O_PHI0 = SUM_DD_R2_ll(ZMASS_O_PHI0_2D)
-!JUAN16
-!
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!* 6. COMPUTATION OF LINEIC MASS
-! --------------------------
-!
-PLINMASS=0.
-!
-IF ( HLBCX(1)=='OPEN' ) THEN
- ALLOCATE(ZLINMASS_W_2D(IIB:IIB,IJB:IJE))
- ZLINMASS_W_2D = 0.0
- IF (LWEST_ll(HSPLITTING='B')) THEN
- DO JJ=IJB,IJE
- DO JK=IKB,IKE
- ZLINMASS_W_2D(IIB,JJ)=ZLINMASS_W_2D(IIB,JJ)+1./PDXX(IIB,JJ,JK) &
- *0.5*(PRHODJ(IIB,JJ,JK)+PRHODJ(IIB-1,JJ,JK))
- ENDDO
- ENDDO
- ENDIF
- PLINMASS = SUM_DD_R2_ll(ZLINMASS_W_2D)
-!
- ALLOCATE(ZLINMASS_E_2D(IIE+1:IIE+1,IJB:IJE))
- ZLINMASS_E_2D = 0.0
- IF (LEAST_ll(HSPLITTING='B')) THEN
- DO JJ=IJB,IJE
- DO JK=IKB,IKE
- ZLINMASS_E_2D(IIE+1,JJ)=ZLINMASS_E_2D(IIE+1,JJ)+1./PDXX(IIE+1,JJ,JK) &
- *0.5*(PRHODJ(IIE+1,JJ,JK)+PRHODJ(IIE,JJ,JK))
- ENDDO
- ENDDO
- ENDIF
- PLINMASS = PLINMASS + SUM_DD_R2_ll(ZLINMASS_E_2D)
-!
-ENDIF
-IF ( HLBCY(1)=='OPEN' ) THEN
- ALLOCATE( ZLINMASS_S_2D(IIB:IIE,IJB:IJB))
- ZLINMASS_S_2D = 0.0
- IF (LSOUTH_ll(HSPLITTING='B')) THEN
- DO JI=IIB,IIE
- DO JK=IKB,IKE
- ZLINMASS_S_2D(JI,IJB)=ZLINMASS_S_2D(JI,IJB)+1./PDYY(JI,IJB,JK) &
- *0.5*(PRHODJ(JI,IJB,JK)+PRHODJ(JI,IJB-1,JK))
- ENDDO
- ENDDO
- ENDIF
- PLINMASS = PLINMASS + SUM_DD_R2_ll(ZLINMASS_S_2D)
- !
- ALLOCATE( ZLINMASS_N_2D(IIB:IIE,IJE+1:IJE+1))
- ZLINMASS_N_2D = 0.0
- IF (LNORTH_ll(HSPLITTING='B')) THEN
- DO JI=IIB,IIE
- DO JK=IKB,IKE
- ZLINMASS_N_2D(JI,IJE+1)=ZLINMASS_N_2D(JI,IJE+1)+1./PDYY(JI,IJE+1,JK) &
- *0.5*(PRHODJ(JI,IJE+1,JK)+PRHODJ(JI,IJE,JK))
- ENDDO
- ENDDO
- ENDIF
- PLINMASS = PLINMASS + SUM_DD_R2_ll(ZLINMASS_N_2D)
-!
-END IF
-!
-CALL MPPDB_CHECK3D(PRHODREF,"SET_REF::PRHODREF",PRECISION)
-CALL MPPDB_CHECK3D(PTHVREF,"SET_REF::PTHVREF",PRECISION)
-CALL MPPDB_CHECK3D(PRVREF,"SET_REF::PRVREF",PRECISION)
-CALL MPPDB_CHECK3D(PEXNREF,"SET_REF::PEXNREF",PRECISION)
-CALL MPPDB_CHECK3D(PRHODJ,"SET_REF::PRHODJ",PRECISION)
-!
-!-------------------------------------------------------------------------------
-!
-!* 7. PRINT ON OUTPUT-LISTING
-! -----------------------
-!
-IF(NVERB >= 5 ) THEN !Value control
- WRITE(ILUOUT,*) 'SET_REF : PLINMASS = ',PLINMASS
-END IF
-!
-IF(NVERB >= 10) THEN !Value control
-!
- WRITE(ILUOUT,*) 'SET_REF: XTHVREFZ values:'
- WRITE(ILUOUT,*) XTHVREFZ
-!
- WRITE(ILUOUT,*) 'SET_REF: XRHODREFZ values:'
- WRITE(ILUOUT,*) XRHODREFZ
-!
- WRITE(ILUOUT,*) 'SET_REF: XEXNTOP'
- WRITE(ILUOUT,*) XEXNTOP
-!
- WRITE(ILUOUT,*) 'SET_REF: Some PTHVREF values:'
- DO JKLOOP=1,IKU,5
- WRITE(ILUOUT,*) PTHVREF(1,1,JKLOOP),PTHVREF(IIU/2,IJU/2,JKLOOP), &
- PTHVREF(IIU,IJU,JKLOOP)
- END DO
-!
- WRITE(ILUOUT,*) 'SET_REF: Some PRHODREF values:'
- DO JKLOOP=1,IKU,5
- WRITE(ILUOUT,*) PRHODREF(1,1,JKLOOP),PRHODREF(IIU/2,IJU/2,JKLOOP), &
- PRHODREF(IIU,IJU,JKLOOP)
- END DO
- WRITE(ILUOUT,*) 'SET_REF: Some PEXNREF values:'
- DO JKLOOP=1,IKU,5
- WRITE(ILUOUT,*) PEXNREF(1,1,JKLOOP),PEXNREF(IIU/2,IJU/2,JKLOOP), &
- PEXNREF(IIU,IJU,JKLOOP)
- END DO
- WRITE(ILUOUT,*) 'SET_REF: Some PRHODJ values:'
- DO JKLOOP=1,IKU,5
- WRITE(ILUOUT,*) PRHODJ(1,1,JKLOOP),PRHODJ(IIU/2,IJU/2,JKLOOP), &
- PRHODJ(IIU,IJU,JKLOOP)
- END DO
-END IF
-!
-!$acc update device(PEXNREF,PRHODREF,PTHVREF)
-IF ( SIZE(PRVREF,1) /= 0 ) THEN
- !$acc update device(PRVREF)
-END IF
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE SET_REF
diff --git a/src/ZSOLVER/turb_hor_dyn_corr.f90 b/src/ZSOLVER/turb_hor_dyn_corr.f90
deleted file mode 100644
index 17291f66c..000000000
--- a/src/ZSOLVER/turb_hor_dyn_corr.f90
+++ /dev/null
@@ -1,1336 +0,0 @@
-!MNH_LIC Copyright 1994-2022 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, &
- 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) :: OTURB_FLX ! switch to write the
- ! turbulent fluxes in the syncronous FM-file
-INTEGER, INTENT(IN) :: KRR ! number of moist var.
-TYPE(TFILEDATA), INTENT(INOUT) :: 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, &
- 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_field, only: tfielddata, TYPEREAL
-USE MODD_IO, ONLY: TFILEDATA
-USE MODD_PARAMETERS
-USE MODD_LES
-USE MODD_NSV
-!
-USE MODE_IO_FIELD_WRITE, only: IO_Field_write
-USE MODE_ll
-#ifdef MNH_OPENACC
-USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE
-#endif
-use mode_mppdb
-!
-USE MODI_COEFJ
-#ifdef MNH_OPENACC
-USE MODI_GET_HALO
-#endif
-USE MODI_GRADIENT_M
-USE MODI_GRADIENT_U
-USE MODI_GRADIENT_V
-USE MODI_GRADIENT_W
-USE MODI_LES_MEAN_SUBGRID
-USE MODI_SECOND_MNH
-#ifndef MNH_OPENACC
-USE MODI_SHUMAN
-#else
-USE MODI_SHUMAN_DEVICE
-#endif
-USE MODI_TRIDIAG_W
-!
-#if defined(MNH_BITREP) || defined(MNH_BITREP_OMP)
-USE MODI_BITREP
-#endif
-#ifdef MNH_COMPILER_CCE
-!$mnh_undef(LOOP)
-!$mnh_undef(OPENACC)
-#endif
-!
-IMPLICIT NONE
-!
-!
-!* 0.1 declaration of arguments
-!
-!
-!
-INTEGER, INTENT(IN) :: KSPLT ! split process index
-REAL, INTENT(IN) :: PTSTEP ! timestep
-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(INOUT) :: 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
- ! 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
-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 :: 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
-!
-#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_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
-!Pin positions in the pools of MNH memory
-CALL MNH_MEM_POSITION_PIN()
-
-CALL MNH_MEM_GET( zflx, JIU, JJU, JKU )
-CALL MNH_MEM_GET( zwork, JIU, JJU, JKU )
-
-CALL MNH_MEM_GET( zdirsinzw,JIU,JJU )
-
-CALL MNH_MEM_GET( gx_u_m_pum, JIU, JJU, JKU )
-CALL MNH_MEM_GET( gy_v_m_pvm, JIU, JJU, JKU )
-CALL MNH_MEM_GET( gz_w_m_pwm, JIU, JJU, JKU )
-CALL MNH_MEM_GET( gz_w_m_zwp, JIU, JJU, JKU )
-CALL MNH_MEM_GET( zmzf_dzz, JIU, JJU, JKU )
-CALL MNH_MEM_GET( zdfddwdz, JIU, JJU, JKU )
-CALL MNH_MEM_GET( zwp, JIU, JJU, JKU )
-
-CALL MNH_MEM_GET( zdu_dz_dzs_dx,1, JIU, 1, JJU, 1 , 1 )
-CALL MNH_MEM_GET( zdv_dz_dzs_dy,1, JIU, 1, JJU, 1 , 1 )
-CALL MNH_MEM_GET( zdu_dx, 1, JIU, 1, JJU, 1 , 1 )
-CALL MNH_MEM_GET( zdv_dy, 1, JIU, 1, JJU, 1 , 1 )
-CALL MNH_MEM_GET( zdw_dz, 1, JIU, 1, JJU, 1 , 1 )
-
-CALL MNH_MEM_GET( zcoeff,1, JIU, 1, JJU, 1 + jpvext, 3 + jpvext )
-CALL MNH_MEM_GET( zdzz, 1, JIU, 1, JJU, 1 + jpvext, 3 + jpvext )
-
-CALL MNH_MEM_GET( ztmp1_device, JIU, JJU, JKU )
-CALL MNH_MEM_GET( ztmp2_device, JIU, JJU, JKU )
-CALL MNH_MEM_GET( ztmp3_device, JIU, JJU, JKU )
-CALL MNH_MEM_GET( 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
-! ------------------------
-#ifndef MNH_OPENACC
-NULLIFY(TZFIELDS_ll)
-#endif
-!
-IKB = 1+JPVEXT
-IKE = SIZE(PUM,3)-JPVEXT
-IKU = SIZE(PUM,3)
-!
-!
-!$acc kernels async(1)
-!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-#if !defined(MNH_BITREP)
-ZDIRSINZW(:,:) = SQRT( 1. - PDIRCOSZW(:,:)**2 )
-#else
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU )
- ZDIRSINZW(:,:) = SQRT( 1. - BR_P2(PDIRCOSZW(:,:)) )
-!$mnh_end_expand_array()
-#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(PUM,PDXX,PDZZ,PDZX,GX_U_M_PUM)
-IF (.NOT. L2D) THEN
- CALL GY_V_M_DEVICE(PVM,PDYY,PDZZ,PDZY,GY_V_M_PVM)
-END IF
-CALL GZ_W_M_DEVICE(PWM,PDZZ,GZ_W_M_PWM)
-!
-CALL MZF_DEVICE( PDZZ, ZMZF_DZZ )
-#endif
-!
-#ifndef MNH_OPENACC
-CALL ADD3DFIELD_ll( TZFIELDS_ll, ZFLX, 'TURB_HOR_DYN_CORR::ZFLX' )
-#endif
-
-! 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) present_cr(zflx,gz_w_m_pwm)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZFLX(:,:,:)= (2./3.) * PTKEM(:,:,:) &
- - XCMFS * PK(:,:,:) *( (4./3.) * GX_U_M_PUM(:,:,:) &
- -(2./3.) * ( GY_V_M_PVM(:,:,:) &
- +GZ_W_M_PWM(:,:,:) ) )
- !$mnh_end_expand_array()
- !$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)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
-!$mnh_end_expand_array()
-!$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) present_cr(zdzz,zcoeff)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- 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) )
-!$mnh_end_expand_array()
-!$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) present_cr(pum,ztmp1_device)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- 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))
-!$mnh_end_expand_array()
-!$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) present_cr(ztmp1_device,zdu_dz_dzs_dx)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZDU_DZ_DZS_DX(:,:,1) = ZTMP2_DEVICE(:,:,1) / ZTMP1_DEVICE(:,:,1)
-!$mnh_end_expand_array()
-!$acc end kernels
-!
-CALL MYM_DEVICE(PDZZ(:,:,IKB:IKB+2),ZDZZ(:,:,:))
-#endif
-!$acc kernels async(4) present_cr(zdzz,zcoeff)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- 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) )
-!$mnh_end_expand_array()
-!$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) present_cr(pvm,ztmp3_device)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- 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))
-!$mnh_end_expand_array()
-!$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) present_cr(ZDV_DZ_DZS_DY)
-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) present_cr(zdu_dz_dzs_dx,zdu_dx)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZDU_DX(:,:,1)= ZTMP1_DEVICE(:,:,1) / ZTMP2_DEVICE(:,:,1) - ZDU_DZ_DZS_DX(:,:,1)
-!$mnh_end_expand_array()
-!$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) present_cr(zdv_dz_dzs_dy,zdv_dy)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZDV_DY(:,:,1)= ZTMP3_DEVICE(:,:,1) / ZTMP4_DEVICE(:,:,1) - ZDV_DZ_DZS_DY(:,:,1)
-!$mnh_end_expand_array()
-!$acc end kernels
-!
-!
-!!! wait for the computation of ZDU_DX and ZDV_DY
-!$acc wait(3) async(4)
-#endif
-!
-!$acc kernels async(4) present_cr(zdv_dy,zdw_dz)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZDW_DZ(:,:,1)=-ZDU_DX(:,:,1)-ZDV_DY(:,:,1)
-!$mnh_end_expand_array()
-!$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) present_cr(zdu_dx,zflx)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
- - XCMFS * PK(:,:,IKB) * 2. * ZDU_DX(:,:,1)
-!$mnh_end_expand_array()
-!$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) present_cr(ZFLX,ZDIRSINZW)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
-!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-#if !defined(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
-!PW: BUG: commented 'acc loop independent collapse(2)' to workaround compiler bug (NVHPC 21.1)
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * BR_P2(PCOSSLOPE(:,:)) * BR_P2(PDIRCOSZW(:,:)) &
- -2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
- + PTAU22M(:,:) * BR_P2(PSINSLOPE(:,:)) &
- + PTAU33M(:,:) * BR_P2(PCOSSLOPE(:,:)) * BR_P2(ZDIRSINZW(:,:)) &
- +2. * PCDUEFF(:,:) * ( &
- PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) &
- - PUSLOPEM(:,:) * BR_P2(PCOSSLOPE(:,:)) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) )
-#endif
-!$mnh_end_expand_array()
-!$acc end kernels
-!
-!!! wait for the computation of ZFLX(:,:,IKB) and ZFLX(:,:,IKB-1)
-!$acc wait(3) async(4)
-!
-!$acc kernels async(4)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZFLX(:,:,IKB-1) = 2. * ZFLX(:,:,IKB-1) - ZFLX(:,:,IKB)
-!$mnh_end_expand_array()
-!$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
-!
-#ifndef MNH_OPENACC
-CALL UPDATE_HALO_ll(TZFIELDS_ll, IINFO_ll)
-#else
-CALL GET_HALO_D(ZFLX)
-#endif
-!
-IF ( tpfile%lopened .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) present_cr(ztmp1_device,ztmp2_device)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = PRHODJ(:,:,:) * ZFLX(:,:,:) / ZTMP1_DEVICE(:,:,:)
-!$mnh_end_expand_array()
-!$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 present_cr(zflx,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = PRHODJ(:,:,:) * ZFLX(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
- !$acc kernels present_cr(ztmp4_device,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:) * PINV_PDZZ(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL MXM_DEVICE( ZTMP2_DEVICE, ZTMP4_DEVICE )
- !$acc kernels present_cr(ztmp4_device,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = PDZX(:,:,:) / ZTMP1_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL DZF_DEVICE( 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) present_cr(gx_u_m_pum,zwork)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZWORK(:,:,:) = - ZFLX(:,:,:) * GX_U_M_PUM(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- !
- ! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
- !
- !$acc kernels async(2) present_cr(zdu_dx,zwork)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZWORK(:,:,IKB) = 0.5* ( -ZFLX(:,:,IKB)*ZDU_DX(:,:,1) + ZWORK(:,:,IKB+1) )
- !$mnh_end_expand_array()
- !$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 present_cr(ZTMP1_DEVICE)
- 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) present_cr(gz_w_m_pwm,zflx)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZFLX(:,:,:)= (2./3.) * PTKEM(:,:,:) &
- - XCMFS * PK(:,:,:) *( (4./3.) * GY_V_M_PVM(:,:,:) &
- -(2./3.) * ( GX_U_M_PUM(:,:,:) &
- +GZ_W_M_PWM(:,:,:) ) )
- !$mnh_end_expand_array()
- !$acc end kernels
- !! & to be tested
- !! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
- !
-ELSE
- !$acc kernels async(3) present_cr(gz_w_m_pwm,zflx)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZFLX(:,:,:)= (2./3.) * PTKEM(:,:,:) &
- - XCMFS * PK(:,:,:) *(-(2./3.) * ( GX_U_M_PUM(:,:,:) &
- +GZ_W_M_PWM(:,:,:) ) )
- !$mnh_end_expand_array()
- !$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) present_cr(zdv_dy,zflx)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
- - XCMFS * PK(:,:,IKB) * 2. * ZDV_DY(:,:,1)
-!$mnh_end_expand_array()
-!$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) present_cr(ZFLX)
-!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-#if !defined(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
-!PW: BUG: commented 'acc loop independent collapse(2)' to workaround compiler bug (NVHPC 21.1)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU )
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * BR_P2(PSINSLOPE(:,:)) * BR_P2(PDIRCOSZW(:,:)) &
- +2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
- + PTAU22M(:,:) * BR_P2(PCOSSLOPE(:,:)) &
- + PTAU33M(:,:) * BR_P2(PSINSLOPE(:,:)) * BR_P2(ZDIRSINZW(:,:)) &
- -2. * PCDUEFF(:,:)* ( &
- PUSLOPEM(:,:) * BR_P2(PSINSLOPE(:,:)) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) &
- + PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) )
-!$mnh_end_expand_array()
-#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)
-#ifndef MNH_OPENACC
-CALL UPDATE_HALO_ll(TZFIELDS_ll, IINFO_ll)
-#else
-CALL GET_HALO_D(ZFLX)
-#endif
-!
-IF ( tpfile%lopened .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) present_cr(ztmp1_device,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = PRHODJ(:,:,:) * ZFLX(:,:,:) / ZTMP1_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$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 present_cr(zflx,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = PRHODJ(:,:,:) * ZFLX(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
- !$acc kernels present_cr(ztmp4_device,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:) * PINV_PDZZ(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL MYM_DEVICE( ZTMP2_DEVICE,ZTMP4_DEVICE )
- !$acc kernels present_cr(ztmp4_device,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = PDZY(:,:,:) / ZTMP1_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL DZF_DEVICE( ZTMP2_DEVICE, ZTMP4_DEVICE )
- !$acc kernels async(1)
- PRVS(:,:,:)=PRVS(:,:,:) &
- -ZTMP3_DEVICE(:,:,:) &
- +ZTMP4_DEVICE(:,:,:)
- !$acc end kernels
- ELSE
- !$acc kernels async(1)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- PRVS(:,:,:)=PRVS(:,:,:) - ZTMP3_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- END IF
-! Contribution to the dynamic production of TKE:
- IF (KSPLT==1) THEN
- !$acc kernels async(2) present_cr(gy_v_m_pvm,zwork)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZWORK(:,:,:) = - ZFLX(:,:,:) * GY_V_M_PVM(:,:,:)
- !$mnh_end_expand_array()
- !$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) present_cr(zdv_dy,zwork)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZWORK(:,:,IKB) = 0.5* ( -ZFLX(:,:,IKB)*ZDV_DY(:,:,1) + ZWORK(:,:,IKB+1) )
- !$mnh_end_expand_array()
- !$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 present_cr(zwork,ztmp1_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP1_DEVICE(:,:,:) = -ZWORK(:,:,:)
- !$mnh_end_expand_array()
- !$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) present_cr(gy_v_m_pvm,zflx)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZFLX(:,:,:) = (2./3.) * PTKEM(:,:,:) &
- - XCMFS * PK(:,:,:) *( (4./3.) * GZ_W_M_PWM(:,:,:) &
- -(2./3.) * ( GX_U_M_PUM(:,:,:) &
- +GY_V_M_PVM(:,:,:) ) )
- !$mnh_end_expand_array()
- !$acc end kernels
- !! & to be tested
- !! -2.* XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
-ELSE
- !$acc kernels async(2) present_cr(gx_u_m_pum,zflx)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZFLX(:,:,:)= (2./3.) * PTKEM(:,:,:) &
- - XCMFS * PK(:,:,:) *( (4./3.) * GZ_W_M_PWM(:,:,:) &
- -(2./3.) * ( GX_U_M_PUM(:,:,:) ) )
- !$mnh_end_expand_array()
- !$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) present_cr(zdw_dz,zflx)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
- - XCMFS * PK(:,:,IKB) * 2. * ZDW_DZ(:,:,1)
-!$mnh_end_expand_array()
-
-!$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) present_cr(ZFLX)
-!if !defined(MNH_BITREP) && !defined(MNH_BITREP_OMP)
-#if !defined(MNH_BITREP)
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * ZDIRSINZW(:,:)**2 &
- + PTAU33M(:,:) * PDIRCOSZW(:,:)**2 &
- +2. * PCDUEFF(:,:)* PUSLOPEM(:,:) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:)
-#else
-!PW: BUG: commented 'acc loop independent collapse(2)' to workaround compiler bug (NVHPC 21.1)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU )
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * BR_P2(ZDIRSINZW(:,:)) &
- + PTAU33M(:,:) * BR_P2(PDIRCOSZW(:,:)) &
- +2. * PCDUEFF(:,:)* PUSLOPEM(:,:) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:)
-!$mnh_end_expand_array()
-#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 ( tpfile%lopened .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(ZWP,PDZZ,GZ_W_M_ZWP)
-#endif
-!$acc kernels async(2) present_cr(gz_w_m_pwm,zflx)
-!$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=IKB+1:JKU)
- ZFLX(:,:,:)=ZFLX(:,:,:) &
- - XCMFS * PK(:,:,:) * (4./3.) * (GZ_W_M_ZWP(:,:,:) - GZ_W_M_PWM(:,:,:))
-!$mnh_end_expand_array()
-!$acc end kernels
-!
-IF (KSPLT==1) THEN
- !Contribution to the dynamic production of TKE:
- !$acc kernels async(2) present_cr(gz_w_m_zwp,zwork)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZWORK(:,:,:) = - ZFLX(:,:,:) * GZ_W_M_ZWP(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- !
- ! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
- !
- !$acc kernels async(2) present_cr(zdw_dz,zwork)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU)
- ZWORK(:,:,IKB) = 0.5* ( -ZFLX(:,:,IKB)*ZDW_DZ(:,:,1) + ZWORK(:,:,IKB+1) )
- !$mnh_end_expand_array()
- !$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 present_cr(zwork,ztmp1_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP1_DEVICE(:,:,:) = -ZWORK(:,:,:)
- !$mnh_end_expand_array()
- !$acc end kernels
- CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_RES_ddxa_W_SBG_UaW , .TRUE.)
- !
- CALL GZ_M_M_DEVICE(PTHLM,PDZZ,ZTMP1_DEVICE)
- !$acc kernels present_cr(zflx,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:)
- !$mnh_end_expand_array()
- !$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( ZTMP1_DEVICE, ZTMP2_DEVICE )
- !$acc kernels present_cr(ztmp2_device,ztmp3_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP3_DEVICE(:,:,:) = ZFLX(:,:,:)*ZTMP2_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$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(PRM(:,:,:,1),PDZZ,ZTMP1_DEVICE)
- !$acc kernels present_cr(zflx,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZFLX(:,:,:)
- !$mnh_end_expand_array()
- !$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( ZTMP1_DEVICE, ZTMP2_DEVICE )
- !$acc kernels present_cr(ztmp2_device,ztmp3_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP3_DEVICE(:,:,:) = ZFLX(:,:,:)*ZTMP2_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$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(PSVM(:,:,:,JSV),PDZZ,ZTMP1_DEVICE)
- !$acc kernels present_cr(zflx,ztmp2_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZFLX(:,:,:)
- !$mnh_end_expand_array()
- !$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(ZTMP1_DEVICE,ZTMP2_DEVICE)
- !$acc kernels present_cr(ztmp2_device,ztmp3_device)
- !$mnh_expand_array(JI=1:JIU,JJ=1:JJU,JK=1:JKU)
- ZTMP3_DEVICE(:,:,:) = ZFLX(:,:,:)*ZTMP2_DEVICE(:,:,:)
- !$mnh_end_expand_array()
- !$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
-!
-#ifndef MNH_OPENACC
-CALL CLEANLIST_ll(TZFIELDS_ll)
-#endif
-
-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
-!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN
-CALL MNH_MEM_RELEASE()
-#endif
-
-!$acc end data
-
-END SUBROUTINE TURB_HOR_DYN_CORR
--
GitLab