diff --git a/src/ZSOLVER/anel_balancen.f90 b/src/ZSOLVER/anel_balancen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c1659356c3616b260ddda416eb328e07ddb3faca
--- /dev/null
+++ b/src/ZSOLVER/anel_balancen.f90
@@ -0,0 +1,334 @@
+!MNH_LIC Copyright 1994-2020 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! ##########################
+ MODULE MODI_ANEL_BALANCE_n
+! ##########################
+!
+INTERFACE
+!
+SUBROUTINE ANEL_BALANCE_n(PRESIDUAL)
+!
+REAL, OPTIONAL :: PRESIDUAL
+END SUBROUTINE ANEL_BALANCE_n
+!
+END INTERFACE
+!
+END MODULE MODI_ANEL_BALANCE_n
+!
+!
+!
+! ################################
+ SUBROUTINE ANEL_BALANCE_n(PRESIDUAL)
+!
+! ################################
+!
+!
+!!**** *ANEL_BALANCE_n* - routine to apply an anelastic correction
+!!
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to fulfill the anelastic balance
+! in case of non-vanishing orography
+!
+!
+!
+!!** METHOD
+!! ------
+!! The coefficients for the flat operator are first computed. Then the
+!! pressure equation is solved and the pressure gradient is added to the wind
+!! components in order to render this wind field non-divergent.
+!!
+!! EXTERNAL
+!! --------
+!! TRID : to compute coefficients for the flat operator
+!! PRESSURE : to solve the pressure equation and add the pressure term to
+!! wind
+!! MXM,MYM,MZM : to average a field at mass point in the x,y,z directions
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONF : contains configuration variables for all models.
+!! NVERB : verbosity level for output-listing
+!!
+!! Module MODD_GRID_n : contains grid variables
+!! XMAP,XXHAT,XYHAT,XZZ
+!!
+!! Module MODD_REF_n : contains reference state variables
+!! XRHODJ,XTHVREF,XEXNREF,XRHODREF,XRVREF
+!!
+!! Module MODD_REF_n : contains reference state variables
+!! XLINMASS : lineic mass along the lateral boundaries
+!!
+!! Module MODD_FIELD_n : contains prognostic variables
+!! XUT,XVT,XWT,XTHT,XRT
+!!
+!! Module MODD_DYN_n : contains parameters for the dynamics
+!! CPRESOPT : option for the pressure solver
+!! NITR : number of iterations for the solver
+!! XRELAX : relaxation coefficient used in the Richardson method
+!!
+!! Module MODD_LBC_n : contains parameters relative to the boundaries
+!! CLBCX : choice of lateral boundary condition along x
+!! CLBCY : choice of lateral boundary condition along y
+!!
+!! REFERENCE
+!! ---------
+!! NONE
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 6/09/94
+!! J. Stein 4/11/94 put the pressure solver parameters in namelist
+!! J. Stein 2/12/94 source cleaning
+!! J.P. Lafore 03/01/95 call to PRESSURE to account for absolute pressure
+!! J. Stein 17/01/95 bug in the pressure call
+!! J. Stein 15/03/95 remove R from the historical variables
+!! J.Stein and J.P. lafore 17/04/96 new version including the way to choose
+!! the model number and the instant where the projection is performed
+!! Stein,Lafore 14/01/97 new anelastic equations
+!! M.Faivre 2014
+!! M.Moge 08/2015 removing UPDATE_HALO_ll(XRHODJ) + EXTRAPOL on ZRU and ZRV in part 3.1
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! 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
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+USE MODE_ll
+USE MODE_MODELN_HANDLER
+!
+USE MODD_CONF ! declarative modules
+USE MODD_PARAMETERS
+USE MODD_GRID_n
+USE MODD_DIM_n
+USE MODD_METRICS_n
+USE MODD_REF_n
+USE MODD_FIELD_n
+USE MODD_DYN_n
+USE MODD_LBC_n
+!
+USE MODI_TRIDZ ! interface modules
+USE MODI_PRESSUREZ
+USE MODE_SPLITTINGZ_ll
+USE MODI_SHUMAN
+!
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODE_MPPDB
+USE MODE_EXTRAPOL
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments :
+!
+REAL, OPTIONAL :: PRESIDUAL
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IRESP ! return code
+INTEGER :: IIY,IJY ! same variable for Y decomposition
+INTEGER :: ITCOUNT ! counter value of temporal loop set to 1 ( this
+ ! means that no guess of the pressure is available for
+ ! the pressure solver
+REAL :: ZDXHATM ! mean grid increment in the x direction
+REAL :: ZDYHATM ! mean grid increment in the y direction
+REAL, DIMENSION (SIZE(XRHODJ,3)) :: ZRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(SIZE(XRHODJ,3)) :: ZAF,ZCF ! vector giving the nonvanishing
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBFY ! elements of the tri-diag matrix
+ ! in the pressure equation
+REAL, DIMENSION(:), ALLOCATABLE :: ZTRIGSX ! arrays of sin or cos values for
+REAL, DIMENSION(:), ALLOCATABLE :: ZTRIGSY ! the FFT in x and y directions
+INTEGER, DIMENSION(19) :: IIFAXX ! decomposition in prime numbers
+INTEGER, DIMENSION(19) :: IIFAXY ! for the FFT in x and y
+ ! directions
+REAL, DIMENSION(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3)) :: ZPABST
+ ! Potential at time t
+REAL, DIMENSION(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3)) :: ZRU,ZRV,ZRW
+ ! Rhod * (U,V,W)
+REAL, DIMENSION(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3)) :: ZTH
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZRR
+!
+INTEGER :: IRR ! Total number of water variables
+INTEGER :: IRRL ! Number of liquid water variables
+INTEGER :: IRRI ! Number of solid water variables
+REAL :: ZDRYMASST ! Mass of dry air Md
+REAL :: ZREFMASS ! Total mass of the ref. atmosphere
+REAL :: ZMASS_O_PHI0 ! Mass / Phi0
+LOGICAL :: GCLOSE_OUT ! switch for the LFI writing
+CHARACTER (LEN= 28) :: YFMFILE ! virtual FM file
+INTEGER :: IMI ! model index
+!JUAN
+INTEGER :: IIU_B,IJU_B,IKU
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBFB,ZBF_SXP2_YP1_Z
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZAF_ZS,ZBF_ZS,ZCF_ZS
+REAL, DIMENSION(:,:) , ALLOCATABLE :: ZDXATH_ZS,ZDYATH_ZS
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRHO_ZS
+REAL, DIMENSION(:), ALLOCATABLE :: ZA_K,ZB_K,ZC_K,ZD_K
+!JUAN
+!
+INTEGER :: IINFO_ll
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll=>NULL() ! list of fields to exchange
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PROLOGUE :
+! --------
+!
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IF (L2D) THEN
+ ALLOCATE(ZBFY(IIY,IJY,SIZE(XRHODJ,3)))
+ELSE
+ ALLOCATE(ZBFY(IJY,IIY,SIZE(XRHODJ,3)))
+ENDIF
+ALLOCATE(ZTRIGSX(3*(NIMAX_ll+2*JPHEXT)))
+ALLOCATE(ZTRIGSY(3*(NJMAX_ll+2*JPHEXT)))
+!JUAN Z_SPLITING
+IKU=SIZE(XRHODJ,3)
+CALL GET_DIM_EXT_ll('B',IIU_B,IJU_B)
+ALLOCATE(ZBFB(IIU_B,IJU_B,IKU))
+!
+ALLOCATE(ZAF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZBF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZCF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZDXATH_ZS(IIU_B,IJU_B))
+ALLOCATE(ZDYATH_ZS(IIU_B,IJU_B))
+ALLOCATE(ZRHO_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZA_K(IKU))
+ALLOCATE(ZB_K(IKU))
+ALLOCATE(ZC_K(IKU))
+ALLOCATE(ZD_K(IKU))
+!
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+ALLOCATE(ZBF_SXP2_YP1_Z(IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll))
+!
+!JUAN Z_SPLITING
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen1-::XRHODJ",PRECISION)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen1-::XUT",PRECISION)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. PRESSURE SOLVER INITIALIZATION :
+! -------------------------------
+!
+!
+CALL TRIDZ(CLBCX,CLBCY,XMAP,XDXHAT,XDYHAT,CPRESOPT, &
+ ZDXHATM,ZDYHATM,ZRHOM, &
+ ZAF,ZCF,ZTRIGSX,ZTRIGSY,IIFAXX,IIFAXY,XRHODJ,XTHVREF,XZZ,ZBFY,&
+ ZBFB,ZBF_SXP2_YP1_Z, &
+ ZAF_ZS,ZBF_ZS,ZCF_ZS, &
+ ZDXATH_ZS,ZDYATH_ZS,ZRHO_ZS, &
+ ZA_K,ZB_K,ZC_K,ZD_K) !JUAN FULL ZSOLVER
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen1-after TRIDZ::XRHODJ",PRECISION)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ANELASTIC CORRECTION :
+! ---------------------
+!
+!
+!* 3.1 multiplication by RHODJ
+!
+!$20140710 UPHALO on XRHODJ
+!CALL ADD3DFIELD_ll( TZFIELDS_ll, XRHODJ, 'ANEL_BALANCE_n::XRHODJ' )
+!CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+!CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen3.1-after update halo::XRHODJ",PRECISION)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen3.1-after update halo::XUT",PRECISION)
+CALL MPPDB_CHECK3D(XWT,"anel_balancen3.1-after update halo::XWT",PRECISION)
+!
+ZRU(:,:,:) = MXM(XRHODJ) * XUT(:,:,:)
+ZRV(:,:,:) = MYM(XRHODJ) * XVT(:,:,:)
+ZRW(:,:,:) = MZM(XRHODJ) * XWT(:,:,:)
+ZTH(:,:,:) = XTHT(:,:,:)
+ALLOCATE(ZRR(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3),SIZE(XRT,4)))
+ZRR(:,:,:,:) = XRT(:,:,:,:)
+!20131112 appli update_halo_ll
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRU, 'ANEL_BALANCE_n::ZRU' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRV, 'ANEL_BALANCE_n::ZRV' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRW, 'ANEL_BALANCE_n::ZRW' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZTH, 'ANEL_BALANCE_n::ZTH' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(ZRU,"anel_balancen3.1-after1stupdhalo::ZRU",PRECISION)
+!$20131125 add extrapol on ZRU to have correct boundaries
+!CALL EXTRAPOL('W',ZRU) ! ZRU boundaries now correct
+CALL MPPDB_CHECK3D(ZRU,"anel_balancen3.1-afterextrapol W::ZRU",PRECISION)
+!20131126 add extrapol on ZRV to have correct boundaries
+!CALL EXTRAPOL('S',ZRV) ! ZRV boundaries now correct
+CALL MPPDB_CHECK3D(ZRV,"anel_balancen3.1-afterextrapol S::ZRV",PRECISION)
+CALL MPPDB_CHECK3D(ZRW,"anel_balancen3.1-afterextrapol S::ZRW",PRECISION)
+!
+!
+!
+!
+!* 3.2 satisfy the anelastic constraint
+!
+ITCOUNT =-1 ! no first guess of the pressure is available
+ZPABST(:,:,:)= 0. ! ==================CAUTION=====================
+ZDRYMASST = 0. ! | Initialization necessary for the |
+ZREFMASS = 0. ! | computation of the absolute pressure, |
+ZMASS_O_PHI0 = 1. ! | which is here not needed |
+IRR = 0 ! | |
+IRRL = 0 ! | |
+IRRI = 0 ! ==============================================
+GCLOSE_OUT=.FALSE.
+YFMFILE='UNUSED'
+!
+IMI = GET_CURRENT_MODEL_INDEX()
+CALL PRESSUREZ(CLBCX,CLBCY,CPRESOPT,NITR,LITRADJ,ITCOUNT,XRELAX,IMI, &
+ XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY,ZDXHATM,ZDYHATM,ZRHOM, &
+ ZAF,ZBFY,ZCF,ZTRIGSX,ZTRIGSY,IIFAXX,IIFAXY, &
+ IRR,IRRL,IRRI,ZDRYMASST,ZREFMASS,ZMASS_O_PHI0, &
+ ZTH,ZRR,XRHODREF,XTHVREF,XRVREF,XEXNREF, XLINMASS, &
+ ZRU,ZRV,ZRW,ZPABST, &
+ ZBFB,ZBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K, &
+ PRESIDUAL )
+!
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen3.2-after pressurez halo::XRHODJ",PRECISION)
+CALL MPPDB_CHECK3D(ZRU,"anel_balancen3.2-after pressurez::ZRU",PRECISION)
+CALL MPPDB_CHECK3D(ZRV,"anel_balancen3.2-after pressurez::ZRV",PRECISION)
+!
+DEALLOCATE(ZBFY,ZTRIGSX,ZTRIGSY,ZRR,ZBF_SXP2_YP1_Z)
+!* 3.2 return to the historical variables
+!
+!20131112 appli update_halo_ll and associated operations
+XUT(:,:,:) = ZRU(:,:,:) / MXM(XRHODJ)
+XVT(:,:,:) = ZRV(:,:,:) / MYM(XRHODJ)
+XWT(:,:,:) = ZRW(:,:,:) / MZM(XRHODJ)
+!20131112 appli update_halo_ll to XUT,XVT,XWT
+CALL ADD3DFIELD_ll( TZFIELDS_ll, XUT, 'ANEL_BALANCE_n::XUT' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, XVT, 'ANEL_BALANCE_n::XVT' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, XWT, 'ANEL_BALANCE_n::XWT' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen3.2-afterupdhalo::XUT",PRECISION)
+CALL MPPDB_CHECK3D(XVT,"anel_balancen3.2-afterupdhalo::XVT",PRECISION)
+!20131125 apply extrapol to fix boundary issue in //
+CALL EXTRAPOL('W',XUT)
+CALL EXTRAPOL('S',XVT)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen3.2-after extrapolW::XUT",PRECISION)
+CALL MPPDB_CHECK3D(XVT,"anel_balancen3.2-after extrapolS::XVT",PRECISION)
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE ANEL_BALANCE_n
diff --git a/src/ZSOLVER/flat_inv.f90 b/src/ZSOLVER/flat_inv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..38fd8718dff9fbfb46dee6c8b59de4b1b6d8d94a
--- /dev/null
+++ b/src/ZSOLVER/flat_inv.f90
@@ -0,0 +1,702 @@
+!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/ini_dynamics.f90 b/src/ZSOLVER/ini_dynamics.f90
new file mode 100644
index 0000000000000000000000000000000000000000..40aa0eb77eb2b9006ff0fba76d8f24366581a555
--- /dev/null
+++ b/src/ZSOLVER/ini_dynamics.f90
@@ -0,0 +1,640 @@
+!MNH_LIC Copyright 1994-2018 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_INI_DYNAMICS
+! ########################
+INTERFACE
+SUBROUTINE INI_DYNAMICS(PLON,PLAT,PRHODJ,PTHVREF,PMAP,PZZ, &
+ PDXHAT,PDYHAT,PZHAT,HLBCX,HLBCY,PTSTEP,HPRESOPT, &
+ OVE_RELAX,OVE_RELAX_GRD,OHORELAX_UVWTH,OHORELAX_RV, &
+ OHORELAX_RC,OHORELAX_RR,OHORELAX_RI,OHORELAX_RS,OHORELAX_RG, &
+ OHORELAX_RH,OHORELAX_TKE,OHORELAX_SV, &
+ OHORELAX_SVC2R2,OHORELAX_SVC1R3,OHORELAX_SVELEC,OHORELAX_SVLG,&
+ OHORELAX_SVCHEM,OHORELAX_SVAER,OHORELAX_SVDST,OHORELAX_SVSLT, &
+ OHORELAX_SVPP,OHORELAX_SVCS, OHORELAX_SVCHIC,OHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ OHORELAX_SVFF, &
+#endif
+ PRIMKMAX,KRIMX,KRIMY,PALKTOP,PALKGRD,PALZBOT,PALZBAS, &
+ PT4DIFU,PT4DIFTH,PT4DIFSV, &
+ PCORIOX,PCORIOY,PCORIOZ,PCURVX,PCURVY, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBFY,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PALK,PALKW,KALBOT,PALKBAS,PALKWBAS,KALBAS, &
+ OMASK_RELAX,PKURELAX, PKVRELAX, PKWRELAX, &
+ PDK2U,PDK4U,PDK2TH,PDK4TH,PDK2SV,PDK4SV,OZDIFFU,PZDIFFU_HALO2,&
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+! intent in arguments
+!
+USE MODE_TYPE_ZDIFFU
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PLON,PLAT !Longitude and latitude
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! rho J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! virtual potential
+ ! temperature of the reference state
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! Map factor
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Gal-Chen Height
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+LOGICAL, INTENT(IN) :: OVE_RELAX ! logical
+ ! switch to activate the VErtical RELAXation
+LOGICAL, INTENT(IN) :: OVE_RELAX_GRD ! logical
+ ! switch to activate the VErtical RELAXation (ground layer)
+LOGICAL, INTENT(IN) :: OHORELAX_UVWTH ! switch for the
+ ! horizontal relaxation for U,V,W,TH
+LOGICAL, INTENT(IN) :: OHORELAX_RV ! switch for the
+ ! horizontal relaxation for Rv
+LOGICAL, INTENT(IN) :: OHORELAX_RC ! switch for the
+ ! horizontal relaxation for Rc
+LOGICAL, INTENT(IN) :: OHORELAX_RR ! switch for the
+ ! horizontal relaxation for Rr
+LOGICAL, INTENT(IN) :: OHORELAX_RI ! switch for the
+ ! horizontal relaxation for Ri
+LOGICAL, INTENT(IN) :: OHORELAX_RS ! switch for the
+ ! horizontal relaxation for Rs
+LOGICAL, INTENT(IN) :: OHORELAX_RG ! switch for the
+ ! horizontal relaxation for Rg
+LOGICAL, INTENT(IN) :: OHORELAX_RH ! switch for the
+ ! horizontal relaxation for Rh
+LOGICAL, INTENT(IN) :: OHORELAX_TKE ! switch for the
+ ! horizontal relaxation for tke
+LOGICAL,DIMENSION(:),INTENT(IN):: OHORELAX_SV ! switch for the
+ ! horizontal relaxation for sv variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC2R2 ! switch for the
+ ! horizontal relaxation for c2r2 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC1R3 ! switch for the
+ ! horizontal relaxation for c1r3 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVELEC ! switch for the
+ ! horizontal relaxation for elec variables
+LOGICAL, INTENT(IN):: OHORELAX_SVLG ! switch for the
+ ! horizontal relaxation for lg variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHEM ! switch for the
+ ! horizontal relaxation for chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHIC ! switch for the
+ ! horizontal relaxation for ice chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVAER ! switch for the
+ ! horizontal relaxation for aer variables
+LOGICAL, INTENT(IN):: OHORELAX_SVDST ! switch for the
+ ! horizontal relaxation for dst variables
+LOGICAL, INTENT(IN):: OHORELAX_SVSLT ! switch for the
+ ! horizontal relaxation for slt variables
+LOGICAL, INTENT(IN):: OHORELAX_SVPP ! switch for the
+ ! horizontal relaxation for passive pollutants
+LOGICAL, INTENT(IN):: OHORELAX_SVSNW ! switch for the
+ ! horizontal relaxation for blowing snow variables
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN):: OHORELAX_SVFF ! switch for the
+ ! horizontal relaxation for ForeFire variables
+#endif
+LOGICAL, INTENT(IN):: OHORELAX_SVCS ! switch for the
+ ! horizontal relaxation for conditional sampling
+REAL, INTENT(IN) :: PRIMKMAX !Max. value of the horiz.
+ ! relaxation coefficients
+INTEGER, INTENT(IN) :: KRIMX,KRIMY ! Number of points in
+ ! the rim zone in the x and y directions
+REAL, INTENT(IN) :: PALKTOP ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALKGRD ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALZBOT ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PALZBAS ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PT4DIFU ! Damping time scale for 2*dx wavelength
+ ! specified for the 4nd order num. diffusion
+ ! for momentum
+REAL, INTENT(IN) :: PT4DIFTH ! for meteorological scalar variables
+REAL, INTENT(IN) :: PT4DIFSV ! for tracer scalar variables
+
+REAL, INTENT(IN) :: PTSTEP ! Time step
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+! intent out arguments
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOX,PCORIOY ! Hor. Coriolis parameters
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOZ ! Vert. Coriolis parameter
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCURVX,PCURVY ! Curvature coefficients
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF ! vectors giving the non-vanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements of the tri-diag matrix
+ ! on an y-slice of global physical domain
+REAL, DIMENSION(:), INTENT(OUT) :: PCF ! in the pressure equation
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! Arrays for sinus or cosinus
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! values for the FFT in x and
+ ! y directions
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXX ! Decomposition in prime numbers
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXY ! for the FFT in x and y
+ ! direction
+INTEGER , INTENT(OUT) :: KALBOT ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALK ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKW ! Idem but defined for w
+INTEGER , INTENT(OUT) :: KALBAS ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALKBAS ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKWBAS ! Idem but defined for w
+LOGICAL, DIMENSION(:,:), INTENT(OUT) :: OMASK_RELAX ! True where the
+ ! lateral relax. has to be performed
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKURELAX ! Horizontal relaxation
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKVRELAX ! coefficients for the
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKWRELAX ! u, v and mass locations
+REAL, INTENT(OUT) :: PDK2U ! 2nd order num. diffusion coef. /dx2
+REAL, INTENT(OUT) :: PDK4U ! 4nd order num. diffusion coef. /dx4
+ ! for momentum
+REAL, INTENT(OUT) :: PDK2TH! for meteorological scalar variables
+REAL, INTENT(OUT) :: PDK4TH!
+REAL, INTENT(OUT) :: PDK2SV! for tracer scalar variables
+REAL, INTENT(OUT) :: PDK4SV!
+!
+LOGICAL, INTENT(IN) :: OZDIFFU
+TYPE(TYPE_ZDIFFU_HALO2) :: PZDIFFU_HALO2
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements of the tri-diag matrix
+ ! on an b-slice of global physical domain
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+
+END SUBROUTINE INI_DYNAMICS
+!
+END INTERFACE
+!
+END MODULE MODI_INI_DYNAMICS
+! ######################################################################
+SUBROUTINE INI_DYNAMICS(PLON,PLAT,PRHODJ,PTHVREF,PMAP,PZZ, &
+ PDXHAT,PDYHAT,PZHAT,HLBCX,HLBCY,PTSTEP,HPRESOPT, &
+ OVE_RELAX,OVE_RELAX_GRD,OHORELAX_UVWTH,OHORELAX_RV, &
+ OHORELAX_RC,OHORELAX_RR,OHORELAX_RI,OHORELAX_RS,OHORELAX_RG, &
+ OHORELAX_RH,OHORELAX_TKE,OHORELAX_SV, &
+ OHORELAX_SVC2R2,OHORELAX_SVC1R3,OHORELAX_SVELEC,OHORELAX_SVLG,&
+ OHORELAX_SVCHEM,OHORELAX_SVAER,OHORELAX_SVDST,OHORELAX_SVSLT, &
+ OHORELAX_SVPP,OHORELAX_SVCS, OHORELAX_SVCHIC,OHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ OHORELAX_SVFF, &
+#endif
+ PRIMKMAX,KRIMX,KRIMY,PALKTOP,PALKGRD,PALZBOT,PALZBAS, &
+ PT4DIFU,PT4DIFTH,PT4DIFSV, &
+ PCORIOX,PCORIOY,PCORIOZ,PCURVX,PCURVY, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBFY,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PALK,PALKW,KALBOT,PALKBAS,PALKWBAS,KALBAS, &
+ OMASK_RELAX,PKURELAX, PKVRELAX, PKWRELAX, &
+ PDK2U,PDK4U,PDK2TH,PDK4TH,PDK2SV,PDK4SV,OZDIFFU,PZDIFFU_HALO2,&
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+! ######################################################################
+!
+!!**** *INI_DYNAMICS* - routine to initialize the parameters for the dynamics
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to set or compute the parameters used
+! by the MESONH dynamics :
+! * Coriolis parameters
+! * Curvature coefficients
+! * Pressure solver coefficients
+! * Absorbing layer coefficients
+! * Numerical difussion coefficients
+!
+!!** METHOD
+!! ------
+!! - Coriolis parameters and curvature terms :
+!! Horizontal Coriolis parameters are not initialized if thinshell
+!! approximation is made (LTHINSHELL=.TRUE.).
+!! Curvature coefficients are not initialized if Cartesian geometry
+!! (LCARTESIAN=.TRUE.)
+!! - Coefficients and variables for pressure solver :
+!! This is done by TRID
+!! - Coefficients and variables for the absorbing layer
+!! ( upper and lateral) : This is done by RELAXDEF
+!! - Coefficients for the numerical diffusion
+!!
+!! EXTERNAL
+!! --------
+!! TRID : to initialize pressure solver
+!! RELAXDEF: to compute the relaxation coefficients
+!! GET_DIM_EXT_ll : get extended sub-domain sizes
+!!
+!! Module MODI_TRID : interface for routine TRID
+!! Module MODI_RELAXDEF : interface for routine RELAXDEF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONF : contains declaration of configuration variables
+!!
+!! LTHINSHELL : Logical for THINSHELL approximation
+!! .TRUE. = thinshell approximation
+!! LCARTESIAN : Logical for cartesian geometry :
+!! .TRUE. = cartesian geometry
+!! L1D : Logical for 1D configuration :
+!! .TRUE. = 1D model
+!!
+!! Module MODD_CST : contains physical constants
+!!
+!! XPI : Pi
+!! XOMEGA : Earth rotation
+!!
+!! Module MODD_GRID : contains grid variables
+!!
+!! XLON0 : Reference longitude for the conformal projection
+!! XLAT0 : Reference latitude for the conformal projection
+!! XBETA : Rotation angle for the conformal projection
+!! XRPK : Projection parameter for the conformal projection
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine INI_DYNAMICS)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/07/94
+!! Modification 18/10/94 (J. Stein) to add the abs. layer
+!! Modification 16/11/94 (Lafore+Pinty) to add the num. diffusion
+!! Modification 06/12/94 (J.Stein) add the switch LABSLAYER
+!! Modification 12/12/94 (J.Stein) add the lateral relaxation
+!! Modification 16/01/95 (J.Stein) conditional CALL to trid for 1D case
+!! Modification 13/08/98 (N.Asencio) add parallel code
+!! Modification 20/05/06 Remove KEPS
+!! Modification 07/2013 (Bosseur & Filippi) Adds Forefire
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Vionnet 07/2017 : blow snow
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_CONF
+USE MODD_CST
+USE MODD_GRID
+USE MODD_LUNIT_n, ONLY: TLUOUT
+!
+USE MODI_RELAXDEF
+! USE MODI_TRID
+USE MODI_TRIDZ
+USE MODI_ZDIFFUSETUP
+!
+USE MODE_ll
+USE MODE_TYPE_ZDIFFU
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#define SIN BR_SIN
+#define COS BR_COS
+#endif
+!
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of argument
+!
+! intent in arguments
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PLON,PLAT !Longitude and latitude
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! rho J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! virtual potential
+ ! temperature of the reference state
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! Map factor
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Gal-Chen Height
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+LOGICAL, INTENT(IN) :: OVE_RELAX ! logical
+ ! switch to activate the VErtical RELAXation
+LOGICAL, INTENT(IN) :: OVE_RELAX_GRD ! logical
+ ! switch to activate the VErtical RELAXation (ground layer)
+LOGICAL, INTENT(IN) :: OHORELAX_UVWTH ! switch for the
+ ! horizontal relaxation for U,V,W,TH
+LOGICAL, INTENT(IN) :: OHORELAX_RV ! switch for the
+ ! horizontal relaxation for Rv
+LOGICAL, INTENT(IN) :: OHORELAX_RC ! switch for the
+ ! horizontal relaxation for Rc
+LOGICAL, INTENT(IN) :: OHORELAX_RR ! switch for the
+ ! horizontal relaxation for Rr
+LOGICAL, INTENT(IN) :: OHORELAX_RI ! switch for the
+ ! horizontal relaxation for Ri
+LOGICAL, INTENT(IN) :: OHORELAX_RS ! switch for the
+ ! horizontal relaxation for Rs
+LOGICAL, INTENT(IN) :: OHORELAX_RG ! switch for the
+ ! horizontal relaxation for Rg
+LOGICAL, INTENT(IN) :: OHORELAX_RH ! switch for the
+ ! horizontal relaxation for Rh
+LOGICAL, INTENT(IN) :: OHORELAX_TKE ! switch for the
+ ! horizontal relaxation for tke
+LOGICAL,DIMENSION(:),INTENT(IN):: OHORELAX_SV ! switch for the
+ ! horizontal relaxation for sv variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC2R2 ! switch for the
+ ! horizontal relaxation for c2r2 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC1R3 ! switch for the
+ ! horizontal relaxation for c1r3 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVELEC ! switch for the
+ ! horizontal relaxation for elec variables
+LOGICAL, INTENT(IN):: OHORELAX_SVLG ! switch for the
+ ! horizontal relaxation for lg variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHEM ! switch for the
+ ! horizontal relaxation for chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHIC ! switch for the
+ ! horizontal relaxation for ice chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVAER ! switch for the
+ ! horizontal relaxation for aer variables
+LOGICAL, INTENT(IN):: OHORELAX_SVDST ! switch for the
+ ! horizontal relaxation for dst variables
+LOGICAL, INTENT(IN):: OHORELAX_SVSLT ! switch for the
+ ! horizontal relaxation for slt variables
+LOGICAL, INTENT(IN):: OHORELAX_SVPP ! switch for the
+ ! horizontal relaxation for passive pollutants
+LOGICAL, INTENT(IN):: OHORELAX_SVSNW ! switch for the
+ ! horizontal relaxation for blowing snow variables
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN):: OHORELAX_SVFF ! switch for the
+ ! horizontal relaxation for ForeFire variables
+#endif
+LOGICAL, INTENT(IN):: OHORELAX_SVCS ! switch for the
+ ! horizontal relaxation for conditional sampling
+REAL, INTENT(IN) :: PRIMKMAX !Max. value of the horiz.
+ ! relaxation coefficients
+INTEGER, INTENT(IN) :: KRIMX,KRIMY ! Number of points in
+ ! the rim zone in the x and y directions
+REAL, INTENT(IN) :: PALKTOP ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALZBOT ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PALKGRD ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALZBAS ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PT4DIFU ! Damping time scale for 2*dx wavelength
+ ! specified for the 4nd order num. diffusion
+ ! for momentum
+REAL, INTENT(IN) :: PT4DIFTH ! for meteorological scalar variables
+REAL, INTENT(IN) :: PT4DIFSV ! for tracer scalar variables
+
+REAL, INTENT(IN) :: PTSTEP ! Time step
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+! intent out arguments
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOX,PCORIOY ! Hor. Coriolis parameters
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOZ ! Vert. Coriolis parameter
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCURVX,PCURVY ! Curvature coefficients
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF ! vectors giving the non-vanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements of the tri-diag matrix
+ ! on an y-slice of global physical domain
+REAL, DIMENSION(:), INTENT(OUT) :: PCF ! in the pressure equation
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! Arrays for sinus or cosinus
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! values for the FFT in x and
+ ! y directions
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXX ! Decomposition in prime numbers
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXY ! for the FFT in x and y
+ ! direction
+INTEGER , INTENT(OUT) :: KALBOT ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALK ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKW ! Idem but defined for w
+INTEGER , INTENT(OUT) :: KALBAS ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALKBAS ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKWBAS ! Idem but defined for w
+LOGICAL, DIMENSION(:,:), INTENT(OUT) :: OMASK_RELAX ! True where the
+ ! lateral relax. has to be performed
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKURELAX ! Horizontal relaxation
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKVRELAX ! coefficients for the
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKWRELAX ! u, v and mass locations
+REAL, INTENT(OUT) :: PDK2U ! 2nd order num. diffusion coef. /dx2
+REAL, INTENT(OUT) :: PDK4U ! 4nd order num. diffusion coef. /dx4
+ ! for momentum
+REAL, INTENT(OUT) :: PDK2TH! for meteorological scalar variables
+REAL, INTENT(OUT) :: PDK4TH!
+REAL, INTENT(OUT) :: PDK2SV! for tracer scalar variables
+REAL, INTENT(OUT) :: PDK4SV!
+LOGICAL, INTENT(IN) :: OZDIFFU
+TYPE(TYPE_ZDIFFU_HALO2) :: PZDIFFU_HALO2
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements of the tri-diag matrix
+ ! on an b-slice of global physical domain
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2)) :: ZGAMMA ! Gamma =K(lambda-lambda0) - beta
+REAL :: ZMBETA ! -beta
+REAL :: ZCDR ! to convert degrees in
+ ! radians
+INTEGER :: ILUOUT ! Logical unit number for output_listing file
+INTEGER :: IIU,IJU ! Upper bounds in x,y directions
+LOGICAL :: GHORELAX
+LOGICAL, DIMENSION(7) :: GHORELAXR ! local array of logical
+#ifdef MNH_FOREFIRE
+LOGICAL, DIMENSION(13):: GHORELAXSV! local array of logical
+#else
+LOGICAL, DIMENSION(12):: GHORELAXSV! local array of logical
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTES CORIOLIS PARAMETERS AND CURVATURE COEFFICIENTS
+! -------------------------------------------------------
+!
+ZCDR = XPI/180.
+IF (.NOT.LCARTESIAN) THEN
+ ZGAMMA(:,:) = XRPK * ((PLON(:,:) - XLON0)*ZCDR) - (XBETA*ZCDR)
+ IF (.NOT.LTHINSHELL) THEN
+ PCORIOX(:,:) = - 2. * XOMEGA * COS(PLAT(:,:)*ZCDR) * SIN(ZGAMMA(:,:))
+ PCORIOY(:,:) = 2. * XOMEGA * COS(PLAT(:,:)*ZCDR) * COS(ZGAMMA(:,:))
+ END IF
+ PCORIOZ(:,:) = 2. * XOMEGA * SIN(PLAT(:,:)*ZCDR)
+ PCURVX (:,:) = COS(ZGAMMA(:,:)) * (SIN(PLAT(:,:)*ZCDR) -XRPK) &
+ / COS(PLAT(:,:)*ZCDR)
+ PCURVY (:,:) = SIN(ZGAMMA(:,:)) * (SIN(PLAT(:,:)*ZCDR) -XRPK) &
+ / COS(PLAT(:,:)*ZCDR)
+ !
+ CALL MPPDB_CHECK2D(PCORIOX,"ini_dynamics:PCORIOX",PRECISION)
+ CALL MPPDB_CHECK2D(PCORIOY,"ini_dynamics:PCORIOY",PRECISION)
+ CALL MPPDB_CHECK2D(PCORIOZ,"ini_dynamics:PCORIOZ",PRECISION)
+ !
+ELSE
+ ZMBETA = - (XBETA*ZCDR)
+ PCORIOX(:,:) = - 2. * XOMEGA * COS(XLAT0*ZCDR) * SIN(ZMBETA)
+ PCORIOY(:,:) = 2. * XOMEGA * COS(XLAT0*ZCDR) * COS(ZMBETA)
+ PCORIOZ(:,:) = 2. * XOMEGA * SIN(XLAT0*ZCDR)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. INITIALIZATION OF PRESSURE SOLVER
+! ---------------------------------
+!
+IF (.NOT.L1D) THEN
+! CALL TRID(HLBCX,HLBCY, &
+! PMAP,PDXHAT,PDYHAT,PDXHATM,PDYHATM,PRHOM,PAF, &
+! PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+! PRHODJ,PTHVREF,PZZ,PBFY)
+ CALL TRIDZ(HLBCX,HLBCY, &
+ PMAP,PDXHAT,PDYHAT,HPRESOPT, &
+ PDXHATM,PDYHATM,PRHOM,PAF, &
+ PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PRHODJ,PTHVREF,PZZ,PBFY,PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+END IF
+!
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE ABSORBING LAYER COEFFICIENTS
+! ----------------------------------------
+!
+GHORELAXR(1) = OHORELAX_RV
+GHORELAXR(2) = OHORELAX_RC
+GHORELAXR(3) = OHORELAX_RR
+GHORELAXR(4) = OHORELAX_RI
+GHORELAXR(5) = OHORELAX_RS
+GHORELAXR(6) = OHORELAX_RG
+GHORELAXR(7) = OHORELAX_RH
+!
+GHORELAXSV(1) = OHORELAX_SVC2R2
+GHORELAXSV(2) = OHORELAX_SVC1R3
+GHORELAXSV(3) = OHORELAX_SVELEC
+GHORELAXSV(4) = OHORELAX_SVLG
+GHORELAXSV(5) = OHORELAX_SVCHEM
+GHORELAXSV(6) = OHORELAX_SVAER
+GHORELAXSV(7) = OHORELAX_SVDST
+GHORELAXSV(8) = OHORELAX_SVSLT
+GHORELAXSV(9) = OHORELAX_SVPP
+GHORELAXSV(10)= OHORELAX_SVCS
+GHORELAXSV(11) = OHORELAX_SVCHIC
+GHORELAXSV(12) = OHORELAX_SVSNW
+#ifdef MNH_FOREFIRE
+GHORELAXSV(13) = OHORELAX_SVFF
+#endif
+!
+GHORELAX=ANY(GHORELAXR) .OR. ANY(GHORELAXSV) .OR. ANY(OHORELAX_SV) &
+ .OR. OHORELAX_UVWTH .OR. OHORELAX_TKE
+!
+IF (GHORELAX .OR. OVE_RELAX.OR.OVE_RELAX_GRD) THEN
+ CALL RELAXDEF( OVE_RELAX,OVE_RELAX_GRD,OHORELAX_UVWTH,OHORELAX_RV, &
+ OHORELAX_RC,OHORELAX_RR,OHORELAX_RI,OHORELAX_RS,OHORELAX_RG, &
+ OHORELAX_RH,OHORELAX_TKE,OHORELAX_SV, &
+ OHORELAX_SVC2R2,OHORELAX_SVC1R3,OHORELAX_SVELEC,OHORELAX_SVLG, &
+ OHORELAX_SVCHEM, OHORELAX_SVAER, OHORELAX_SVDST, OHORELAX_SVSLT, &
+ OHORELAX_SVPP, OHORELAX_SVCS, OHORELAX_SVCHIC,OHORELAX_SVSNW, &
+ PALKTOP,PALKGRD, PALZBOT,PALZBAS, &
+ PZZ, PZHAT, PTSTEP, &
+ PRIMKMAX,KRIMX,KRIMY, &
+ PALK, PALKW, KALBOT, &
+ PALKBAS, PALKWBAS, KALBAS, &
+ OMASK_RELAX,PKURELAX, PKVRELAX, PKWRELAX )
+END IF
+!
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. COMPUTE THE NUMERICAL DIFFUSION COEFFICIENTS
+! --------------------------------------------
+!
+PDK4U = 1.0/(16.0*PT4DIFU) ! The damping rate for the 2*dx wavelength is the same
+PDK2U = 2.0*PDK4U ! for the 2nd and the 4th order diffusion schemes
+ ! for momentum
+PDK4TH= 1.0/(16.0*PT4DIFTH) ! for meteorological scalar variables
+PDK2TH= 2.0*PDK4TH
+PDK4SV= 1.0/(16.0*PT4DIFSV) ! for tracer scalar variables
+PDK2SV= 2.0*PDK4SV
+!
+! Call ZDIFFUSETUP if OZDIFFU is true (parameters for truly horizontal diffusion)
+!
+IF (OZDIFFU) THEN
+ CALL ZDIFFUSETUP (PZZ,&
+ PZDIFFU_HALO2)
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. PRINT ON OUTPUT_LISTING
+! -----------------------
+!
+IF (NVERB >= 10) THEN
+ CALL GET_DIM_EXT_ll ('B',IIU,IJU)
+ ILUOUT = TLUOUT%NLU
+!
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCORIOZ values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCORIOZ(1,1),PCORIOZ(IIU/2,IJU/2),PCORIOZ(IIU,IJU)
+!
+ IF (.NOT.LTHINSHELL) THEN
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCORIOX values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCORIOX(1,1),PCORIOX(IIU/2,IJU/2),PCORIOX(IIU,IJU)
+!
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCORIOY values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCORIOY(1,1),PCORIOY(IIU/2,IJU/2),PCORIOY(IIU,IJU)
+ END IF
+!
+ IF ( .NOT. LCARTESIAN ) THEN
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCURVX values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCURVX(1,1),PCURVX(IIU/2,IJU/2),PCURVX(IIU,IJU)
+!
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCURVY values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCURVY(1,1),PCURVY(IIU/2,IJU/2),PCURVY(IIU,IJU)
+ END IF
+END IF
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE INI_DYNAMICS
diff --git a/src/ZSOLVER/ini_modeln.f90 b/src/ZSOLVER/ini_modeln.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8203f0ada7d3d47b9a065697b8587553b551aa77
--- /dev/null
+++ b/src/ZSOLVER/ini_modeln.f90
@@ -0,0 +1,2525 @@
+!MNH_LIC Copyright 1994-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! #######################
+ MODULE MODI_INI_MODEL_n
+! #######################
+!
+INTERFACE
+!
+ SUBROUTINE INI_MODEL_n(KMI,TPINIFILE)
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KMI ! Model Index
+TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+END SUBROUTINE INI_MODEL_n
+!
+END INTERFACE
+!
+END MODULE MODI_INI_MODEL_n
+! ############################################
+ SUBROUTINE INI_MODEL_n(KMI,TPINIFILE)
+! ############################################
+!
+!!**** *INI_MODEL_n* - routine to initialize the nested model _n
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to initialize the variables
+! of the nested model _n.
+!
+!!** METHOD
+!! ------
+!! The initialization of the model _n is performed as follows :
+!! - Memory for arrays are then allocated :
+!! * If turbulence kinetic energy variable is not needed
+!! (CTURB='NONE'), XTKET, XTKEM and XTKES are zero-size arrays.
+!! * If dissipation of TKE variable is not needed
+!! (CTURBLEN /='KEPS'), XEPST, XEPSM and XREPSS are zero-size arrays.
+!! * Memory for mixing ratio arrays is allocated according to the
+!! value of logicals LUSERn (the number NRR of moist variables is deduced).
+!! * The latitude (XLAT), longitude (XLON) and map factor (XMAP)
+!! arrays are zero-size arrays if Cartesian geometry (LCARTESIAN=.TRUE.)
+!! * Memory for reference state without orography ( XRHODREFZ and
+!! XTHVREFZ) is only allocated in INI_MODEL1
+!! * The horizontal Coriolis parameters (XCORIOX and XCORIOY) arrays
+!! are zero-size arrays if thinshell approximation (LTHINSHELL=.TRUE.)
+!! * The Curvature coefficients (XCURVX and XCURVY) arrays
+!! are zero-size arrays if Cartesian geometry (LCARTESIAN=.TRUE.)
+!! * Memory for the Jacobian (ZJ) local array is allocated
+!! (This variable is computed in SET_GRID and used in SET_REF).
+!! - The spatial and temporal grid variables are initialized by SET_GRID.
+!! - The metric coefficients are computed by METRICS (they are using in
+!! the SET-REF call).
+!! - The prognostic variables and are read in initial
+!! LFIFM file (in READ_FIELD)
+!! - The reference state variables are initialized by SET_REF.
+!! - The temporal indexes of the outputs are computed by SET_OUTPUT_TIMES
+!! - The large scale sources are computed in case of coupling case by
+!! INI_CPL.
+!! - The initialization of the parameters needed for the dynamics
+!! of the model n is realized in INI_DYNAMICS.
+!! - Then the initial file (DESFM+LFIFM files) is closed by IO_File_close.
+!! - The initialization of the parameters needed for the ECMWF radiation
+!! code is realized in INI_RADIATIONS.
+!! - The contents of the scalar variables are overwritten by
+!! the chemistry initialization subroutine CH_INIT_FIELDn when
+!! the flags LUSECHEM and LCH_INIT_FIELD are set to TRUE.
+!! This allows easy initialization of the chemical fields at a
+!! restart of the model.
+!!
+!! EXTERNAL
+!! --------
+!! SET_DIM : to initialize dimensions
+!! SET_GRID : to initialize grid
+!! METRICS : to compute metric coefficients
+!! READ_FIELD : to initialize field
+!! FMCLOS : to close a FM-file
+!! SET_REF : to initialize reference state for anelastic approximation
+!! INI_DYNAMICS: to initialize parameters for the dynamics
+!! INI_TKE_EPS : to initialize the TKE
+!! SET_DIRCOS : to compute the director cosinus of the orography
+!! INI_RADIATIONS : to initialize radiation computations
+!! CH_INIT_CCS: to initialize the chemical core system
+!! CH_INIT_FIELDn: to (re)initialize the scalar variables
+!! INI_DEEP_CONVECTION : to initialize the deep convection scheme
+!! CLEANLIST_ll : deaalocate a list
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_PARAMETERS : contains declaration of parameter variables
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_MODD_DYN : contains declaration of parameters
+!! for the dynamics
+!! Module MODD_CONF : contains declaration of configuration variables
+!! for all models
+!! NMODEL : Number of nested models
+!! NVERB : Level of informations on output-listing
+!! 0 for minimum prints
+!! 5 for intermediate level of prints
+!! 10 for maximum prints
+!!
+!! Module MODD_REF : contains declaration of reference state
+!! variables for all models
+!! Module MODD_FIELD_n : contains declaration of prognostic fields
+!! Module MODD_LSFIELD_n : contains declaration of Larger Scale fields
+!! Module MODD_GRID_n : contains declaration of spatial grid variables
+!! Module MODD_TIME_n : contains declaration of temporal grid variables
+!! Module MODD_REF_n : contains declaration of reference state
+!! variables
+!! Module MODD_CURVCOR_n : contains declaration of curvature and Coriolis
+!! variables
+!! Module MODD_BUDGET : contains declarations of the budget parameters
+!! Module MODD_RADIATIONS_n:contains declaration of the variables of the
+!! radiation interface scheme
+!! Module MODD_STAND_ATM : contains declaration of the 5 standard
+!! atmospheres used for the ECMWF-radiation code
+!! Module MODD_FRC : contains declaration of the control variables
+!! and of the forcing fields
+!! Module MODD_CH_MNHC_n : contains the control parameters for chemistry
+!! Module MODD_DEEP_CONVECTION_n: contains declaration of the variables of
+!! the deep convection scheme
+!!
+!!
+!!
+!!
+!! Module MODN_CONF_n : contains declaration of namelist NAM_CONFn and
+!! uses module MODD_CONF_n (configuration variables)
+!! Module MODN_LUNIT_n : contains declaration of namelist NAM_LUNITn and
+!! uses module MODD_LUNIT_n (Logical units)
+!! Module MODN_DYN_n : contains declaration of namelist NAM_DYNn and
+!! uses module MODD_DYN_n (control of dynamics)
+!! Module MODN_PARAM_n : contains declaration of namelist NAM_PARAMn and
+!! uses module MODD_PARAM_n (control of physical
+!! parameterization)
+!! Module MODN_LBC_n : contains declaration of namelist NAM_LBCn and
+!! uses module MODD_LBC_n (lateral boundaries)
+!! Module MODN_TURB_n : contains declaration of namelist NAM_TURBn and
+!! uses module MODD_TURB_n (turbulence scheme)
+!! Module MODN_PARAM_RAD_n: contains declaration of namelist NAM_PARAM_RADn
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine INI_MODEL_n)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 10/06/94
+!! Modification 17/10/94 (Stein) For LCORIO
+!! Modification 20/10/94 (Stein) For SET_GRID and NAMOUTN
+!! Modification 26/10/94 (Stein) Modifications of the namelist names
+!! Modification 10/11/94 (Lafore) allocatation of tke fields
+!! Modification 22/11/94 (Stein) change the READ_FIELDS call ( add
+!! pressure function
+!! Modification 06/12/94 (Stein) add the LS fields
+!! 12/12/94 (Stein) rename END_INI in INI_DYNAMICS
+!! Modification 09/01/95 (Stein) add the turbulence scheme
+!! Modification Jan 19, 1995 (J. Cuxart) add the TKE initialization
+!! Jan 23, 1995 (J. Stein ) remove the condition
+!! LTHINSHELL=T LCARTESIAN=T => stop
+!! Modification Feb 16, 1995 (I.Mallet) add the METRICS call and
+!! change the SET_REF call (add
+!! the lineic mass)
+!! Modification Mar 10, 1995 (I. Mallet) add the COUPLING initialization
+!! June 29,1995 (Ph. Hereil, J. Stein) add the budget init.
+!! Modification Sept. 1, 1995 (S. Belair) Reading of the surface variables
+!! and parameters for ISBA (i.e., add a
+!! CALL READ_GR_FIELD)
+!! Modification 18/08/95 (J.P.Lafore) time step change case
+!! 25/09/95 (J. Cuxart and J.Stein) add LES variables
+!! and the diachronic file initialization
+!! Modification Sept 20,1995 (Lafore) coupling for the dry mass Md
+!! Modification Sept. 12, 1995 (J.-P. Pinty) add the initialization of
+!! the ECMWF radiation code
+!! Modification Sept. 13, 1995 (J.-P. Pinty) control the allocation of the
+!! arrays of MODD_GR_FIELD_n
+!! Modification Nove. 17, 1995 (J.Stein) control of the control !!
+!! March 01, 1996 (J. Stein) add the cloud fraction
+!! April 03, 1996 (J. Stein) unify the ISBA and TSZ0 cases
+!! Modification 13/12/95 (M. Georgelin) add the forcing variables in
+!! the call read_field, and their
+!! allocation.
+!! Mai 23, 1996 (J. Stein) allocate XSEA in the TSZ0 case
+!! June 11, 1996 (V. Masson) add XSILT and XLAKE of
+!! MODD_GR_FIELD_n
+!! August 7, 1996 (K. Suhre) add (re)initialization of
+!! chemistry
+!! Octo. 11, 1996 (J. Stein ) add XSRCT and XSRCM
+!! October 8, 1996 (J. Cuxart, E. Sanchez) Moist LES diagnostics
+!! and control on TKE initialization.
+!! Modification 19/12/96 (J.-P. Pinty) add the ice parameterization and
+!! the precipitation fields
+!! Modification 11/01/97 (J.-P. Pinty) add the deep convection
+!! Nov. 1, 1996 (V. Masson) Read the vertical grid kind
+!! Nov. 20, 1996 (V. Masson) control of convection calling time
+!! July 16, 1996 (J.P.Lafore) update of EXSEG file reading
+!! Oct. 08, 1996 (J.P.Lafore, V.Masson)
+!! MY_NAME and DAD_NAME reading and check
+!! Oct. 30, 1996 (J.P.Lafore) resolution ratio reading for nesting
+!! and Bikhardt interpolation coef. initialization
+!! Nov. 22, 1996 (J.P.Lafore) allocation of LS sources for nesting
+!! Feb. 26, 1997 (J.P.Lafore) allocation of "surfacic" LS fields
+!! March 10, 1997 (J.P.Lafore) forcing only for model 1
+!! June 22, 1997 (J. Stein) add the absolute pressure
+!! July 09, 1997 (V. Masson) add directional z0 and SSO
+!! Aug. 18, 1997 (V. Masson) consistency between storage
+!! type and CCONF
+!! Dec. 22, 1997 (J. Stein) add the LS field spawning
+!! Jan. 24, 1998 (P.Bechtold) change MODD_FRC and MODD_DEEP_CONVECTION
+!! Dec. 24, 1997 (V.Masson) directional z0 parameters
+!! Aug. 13, 1998 (V. Ducrocq P Jabouille) //
+!! Mai. 26, 1998 (J. Stein) remove NXEND,NYEND
+!! Feb. 1, 1999 (J. Stein) compute the Bikhardt
+!! interpolation coeff. before the call to set_grid
+!! April 5, 1999 (V. Ducrocq) change the DXRATIO_ALL init.
+!! April 12, 1999 (J. Stein) cleaning + INI_SPAWN_LS
+!! Apr. 7, 1999 (P Jabouille) store the metric coefficients
+!! in modd_metrics_n
+!! Jui. 15,1999 (P Jabouille) split the routines in two parts
+!! Jan. 04,2000 (V. Masson) removes the TSZ0 case
+!! Apr. 15,2000 (P Jabouille) parallelization of grid nesting
+!! Aug. 20,2000 (J Stein ) tranpose XBFY
+!! Jui 01,2000 (F.solmon ) adapatation for patch approach
+!! Jun. 15,2000 (J.-P. Pinty) add C2R2 initialization
+!! Nov. 15,2000 (V.Masson) use of ini_modeln in prep_real_case
+!! Nov. 15,2000 (V.Masson) call of LES routines
+!! Nov. 15,2000 (V.Masson) aircraft and balloon initialization routines
+!! Jan. 22,2001 (D.Gazen) update_nsv set NSV_* var. for current model
+!! Mar. 04,2002 (V.Ducrocq) initialization to temporal series
+!! Mar. 15,2002 (F.Solmon) modification of ini_radiation interface
+!! Nov. 29,2002 (JP Pinty) add C3R5, ICE2, ICE4, ELEC
+!! Jan. 2004 (V.Masson) externalization of surface
+!! May 2006 Remove KEPS
+!! Apr. 2010 (M. Leriche) add pH for aqueous phase chemistry
+!! Jul. 2010 (M. Leriche) add Ice phase chemistry
+!! Oct. 2010 (J.Escobar) check if local domain not to small for NRIMX NRIMY
+!! Nov. 2010 (J.Escobar) PGI BUG , add SIZE(CSV) to init_ground routine
+!! Nov. 2009 (C. Barthe) add call to INI_ELEC_n
+!! Mar. 2010 (M. Chong) add small ions
+!! Apr. 2011 (M. Chong) correction of RESTART (ELEC)
+!! June 2011 (B.Aouizerats) Prognostic aerosols
+!! June 2011 (P.Aumond) Drag of the vegetation
+!! + Mean fields
+!! July 2013 (Bosseur & Filippi) Adds Forefire
+!! P. Tulet Nov 2014 accumulated moles of aqueous species that fall at the surface
+!! JAn. 2015 (F. Brosse) bug in allocate XACPRAQ
+!! Dec 2014 (C.Lac) : For reproducibility START/RESTA
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! V. Masson Feb 2015 replaces, for aerosols, cover fractions by sea, town, bare soil fractions
+!! J.Escobar : 19/04/2016 : Pb IOZ/NETCDF , missing OPARALLELIO=.FALSE. for PGD files
+!! J.Escobar : 01/06/2016 : correct check limit of NRIM versus local subdomain size IDIM
+!! 06/2016 (G.Delautier) phasage surfex 8
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Aug. 2016 (J.Pianezze) Add SFX_OASIS_READ_NAM function from SurfEx
+!! M.Leriche 2016 Chemistry
+!! 10/2016 M.Mazoyer New KHKO output fields
+!! 10/2016 (C.Lac) Add max values
+!! F. Brosse Oct. 2016 add prod/loss terms computation for chemistry
+!! M.Leriche 2016 Chemistry
+!! M.Leriche 10/02/17 prevent negative values in LBX(Y)SVS
+!! M.Leriche 01/07/2017 Add DIAG chimical surface fluxes
+!! 09/2017 Q.Rodier add LTEND_UV_FRC
+!! 02/2018 Q.Libois ECRAD
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! V. Vionnet : 18/07/2017 : add blowing snow scheme
+!! 01/18 J.Colin Add DRAG
+! P. Wautelet 29/01/2019: bug: add missing zero-size allocations
+! P. Wautelet 07/02/2019: force TYPE to a known value for IO_File_add2list
+! P. Wautelet 13/02/2019: initialize XALBUV even if no radiation (needed in CH_INTERP_JVALUES)
+! P. Wautelet 13/02/2019: removed PPABSM and PTSTEP dummy arguments of READ_FIELD
+! P. Wautelet 14/02/2019: remove CLUOUT/CLUOUT0 and associated variables
+! P. Wautelet 14/02/2019: remove HINIFILE dummy argument from INI_RADIATIONS_ECMWF/ECRAD
+!! 02/2019 C.Lac add rain fraction as an output field
+!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 14/03/2019: correct ZWS when variable not present in file (set to XZWS_DEFAULT)
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 19/04/2019: removed unused dummy arguments and variables
+! P. Wautelet 07/06/2019: allocate lookup tables for optical properties only when needed
+!---------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef MNH_ECRAD
+USE YOERDI, only: RCCO2
+#endif
+
+USE MODD_2D_FRC
+USE MODD_ADVFRC_n
+USE MODD_ADV_n
+use MODD_AEROSET, only: POLYTAU, POLYSSA, POLYG
+USE MODD_ARGSLIST_ll, only: LIST_ll
+USE MODD_BIKHARDT_n
+USE MODD_BLOWSNOW
+USE MODD_BLOWSNOW_n
+USE MODD_BUDGET
+USE MODD_CH_AERO_n, only: XSOLORG,XMI
+USE MODD_CH_AEROSOL, only: LORILAM
+USE MODD_CH_BUDGET_n
+USE MODD_CH_FLX_n, only: XCHFLX
+USE MODD_CH_M9_n, only:NNONZEROTERMS
+USE MODD_CH_MNHC_n, only: LUSECHEM, LUSECHAQ, LUSECHIC, LCH_INIT_FIELD, &
+ LCH_CONV_LINOX, XCH_TUV_DOBNEW, LCH_PH
+USE MODD_CH_PH_n
+USE MODD_CH_PRODLOSSTOT_n
+USE MODD_CLOUD_MF_n
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CST
+USE MODD_CTURB
+USE MODD_CURVCOR_n
+USE MODD_DEEP_CONVECTION_n
+USE MODD_DEF_EDDY_FLUX_n ! for VT and WT fluxes
+USE MODD_DEF_EDDYUV_FLUX_n ! FOR UV
+USE MODD_DIAG_FLAG, only: LCHEMDIAG, CSPEC_BU_DIAG
+USE MODD_DIM_n
+USE MODD_DRAG_n
+USE MODD_DRAGTREE
+USE MODD_DUST
+use MODD_DUST_OPT_LKT, only: NMAX_RADIUS_LKT_DUST=>NMAX_RADIUS_LKT, NMAX_SIGMA_LKT_DUST=>NMAX_SIGMA_LKT, &
+ NMAX_WVL_SW_DUST=>NMAX_WVL_SW, &
+ XEXT_COEFF_WVL_LKT_DUST=>XEXT_COEFF_WVL_LKT, XEXT_COEFF_550_LKT_DUST=>XEXT_COEFF_550_LKT, &
+ XPIZA_LKT_DUST=>XPIZA_LKT, XCGA_LKT_DUST=>XCGA_LKT
+USE MODD_DYN
+USE MODD_DYN_n
+USE MODD_DYNZD
+USE MODD_DYNZD_n
+USE MODD_ELEC_n, only: XCION_POS_FW, XCION_NEG_FW
+USE MODD_FIELD_n
+#ifdef MNH_FOREFIRE
+USE MODD_FOREFIRE
+USE MODD_FOREFIRE_n
+#endif
+USE MODD_FRC
+USE MODD_FRC_n
+USE MODD_GET_n
+USE MODD_GRID_n
+USE MODD_GRID, only: XLONORI,XLATORI
+USE MODD_IO, only: CIO_DIR, TFILEDATA, TFILE_DUMMY
+USE MODD_IO_SURF_MNH, only: IO_SURF_MNH_MODEL
+USE MODD_LATZ_EDFLX
+USE MODD_LBC_n, only: CLBCX, CLBCY
+USE MODD_LSFIELD_n
+USE MODD_LUNIT_n
+USE MODD_MEAN_FIELD
+USE MODD_MEAN_FIELD_n
+USE MODD_METRICS_n
+USE MODD_MNH_SURFEX_n
+USE MODD_NESTING, only: CDAD_NAME, NDAD, NDT_2_WAY, NDTRATIO, NDXRATIO_ALL, NDYRATIO_ALL
+USE MODD_NSV
+USE MODD_NSV
+USE MODD_NUDGING_n, only: LNUDGING
+USE MODD_OUT_n
+USE MODD_PARAMETERS
+USE MODD_PARAM_KAFR_n
+USE MODD_PARAM_MFSHALL_n
+USE MODD_PARAM_n
+USE MODD_PARAM_RAD_n, only: CAER, CAOP, CLW
+USE MODD_PASPOL
+USE MODD_PASPOL_n
+USE MODD_PAST_FIELD_n
+use modd_precision, only: LFIINT
+USE MODD_RADIATIONS_n
+USE MODD_REF
+USE MODD_REF_n
+USE MODD_RELFRC_n
+use MODD_SALT, only: LSALT
+use MODD_SALT_OPT_LKT, only: NMAX_RADIUS_LKT_SALT=>NMAX_RADIUS_LKT, NMAX_SIGMA_LKT_SALT=>NMAX_SIGMA_LKT, &
+ NMAX_WVL_SW_SALT=>NMAX_WVL_SW, &
+ XEXT_COEFF_WVL_LKT_SALT=>XEXT_COEFF_WVL_LKT, XEXT_COEFF_550_LKT_SALT=>XEXT_COEFF_550_LKT, &
+ XPIZA_LKT_SALT=>XPIZA_LKT, XCGA_LKT_SALT=>XCGA_LKT
+USE MODD_SERIES, only: LSERIES
+USE MODD_SHADOWS_n
+USE MODD_STAND_ATM, only: XSTROATM, XSMLSATM, XSMLWATM, XSPOSATM, XSPOWATM
+USE MODD_TIME
+USE MODD_TIME_n
+USE MODD_TURB_CLOUD, only: NMODEL_CLOUD, CTURBLEN_CLOUD,XCEI
+USE MODD_TURB_n
+USE MODD_VAR_ll, only: IP
+
+USE MODE_GATHER_ll
+USE MODE_INI_ONE_WAY_n
+USE MODE_IO
+USE MODE_IO_FIELD_READ, only: IO_Field_read
+USE MODE_IO_FILE, only: IO_File_open
+USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list
+USE MODE_ll
+USE MODE_MODELN_HANDLER
+USE MODE_MPPDB
+USE MODE_MSG
+USE MODE_SPLITTINGZ_ll, only: GET_DIM_EXTZ_ll
+USE MODE_TYPE_ZDIFFU
+
+USE MODI_CH_AER_MOD_INIT
+USE MODI_CH_INIT_BUDGET_n
+USE MODI_CH_INIT_FIELD_n
+USE MODI_CH_INIT_JVALUES
+USE MODI_CH_INIT_PRODLOSSTOT_n
+USE MODI_GET_SIZEX_LB
+USE MODI_GET_SIZEY_LB
+USE MODI_INI_AEROSET1
+USE MODI_INI_AEROSET2
+USE MODI_INI_AEROSET3
+USE MODI_INI_AEROSET4
+USE MODI_INI_AEROSET5
+USE MODI_INI_AEROSET6
+USE MODI_INI_AIRCRAFT_BALLOON
+USE MODI_INI_AIRCRAFT_BALLOON
+USE MODI_INI_BIKHARDT_n
+USE MODI_INI_BUDGET
+USE MODI_INI_CPL
+USE MODI_INI_DEEP_CONVECTION
+USE MODI_INI_DRAG
+USE MODI_INI_DYNAMICS
+USE MODI_INI_ELEC_n
+USE MODI_INI_LES_N
+USE MODI_INI_LG
+USE MODI_INI_LW_SETUP
+USE MODI_INI_MICRO_n
+USE MODI_INI_POSPROFILER_n
+USE MODI_INI_RADIATIONS
+USE MODI_INI_RADIATIONS_ECMWF
+USE MODI_INI_RADIATIONS_ECRAD
+USE MODI_INI_SERIES_N
+USE MODI_INI_SPAWN_LS_n
+USE MODI_INI_SURF_RAD
+USE MODI_INI_SURFSTATION_n
+USE MODI_INI_SW_SETUP
+USE MODI_INIT_AEROSOL_PROPERTIES
+#ifdef MNH_FOREFIRE
+USE MODI_INIT_FOREFIRE_n
+#endif
+USE MODI_INIT_GROUND_PARAM_n
+USE MODI_INI_TKE_EPS
+USE MODI_METRICS
+USE MODI_MNHGET_SURF_PARAM_n
+USE MODI_MNHREAD_ZS_DUMMY_n
+USE MODI_READ_FIELD
+USE MODI_SET_DIRCOS
+USE MODI_SET_GRID
+USE MODI_SET_REF
+#ifdef CPLOASIS
+USE MODI_SFX_OASIS_READ_NAM
+#endif
+USE MODI_SUNPOS_n
+USE MODI_SURF_SOLAR_GEOM
+USE MODI_UPDATE_METRICS
+USE MODI_UPDATE_NSV
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+INTEGER, INTENT(IN) :: KMI ! Model Index
+TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+!* 0.2 declarations of local variables
+!
+REAL, PARAMETER :: NALBUV_DEFAULT = 0.01 ! Arbitrary low value for XALBUV
+!
+INTEGER :: JSV ! Loop index
+INTEGER :: IRESP ! Return code of FM routines
+INTEGER :: ILUOUT ! Logical unit number of output-listing
+CHARACTER(LEN=28) :: YNAME
+INTEGER :: IIU ! Upper dimension in x direction (local)
+INTEGER :: IJU ! Upper dimension in y direction (local)
+INTEGER :: IIU_ll ! Upper dimension in x direction (global)
+INTEGER :: IJU_ll ! Upper dimension in y direction (global)
+INTEGER :: IKU ! Upper dimension in z direction
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ ! Jacobian
+LOGICAL :: GINIDCONV ! logical switch for the deep convection
+ ! initialization
+LOGICAL :: GINIRAD ! logical switch for the radiation
+ ! initialization
+!
+!
+TYPE(LIST_ll), POINTER :: TZINITHALO2D_ll ! pointer for the list of 2D fields
+ ! which must be communicated in INIT
+TYPE(LIST_ll), POINTER :: TZINITHALO3D_ll ! pointer for the list of 3D fields
+ ! which must be communicated in INIT
+!
+INTEGER :: IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU ! dimensions of the
+INTEGER :: IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2 ! West-east LB arrays
+INTEGER :: IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV ! dimensions of the
+INTEGER :: IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2 ! North-south LB arrays
+INTEGER :: IINFO_ll ! Return code of //routines
+INTEGER :: IIY,IJY
+INTEGER :: IIU_B,IJU_B
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll
+!
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZCO2 ! CO2 concentration near the surface
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZSEA ! sea fraction
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZTOWN ! town fraction
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZBARE ! bare soil fraction
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZDIR_ALB ! direct albedo
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZSCA_ALB ! diffuse albedo
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZEMIS ! emissivity
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZTSRAD ! surface temperature
+!
+!
+INTEGER, DIMENSION(:,:),ALLOCATABLE :: IINDEX ! indices of non-zero terms
+INTEGER, DIMENSION(:),ALLOCATABLE :: IIND
+INTEGER :: JM
+!
+!------------------------------------------
+! Dummy pointers needed to correct an ifort Bug
+REAL, DIMENSION(:), POINTER :: DPTR_XZHAT
+REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSM,DPTR_XLSZWSS
+!
+INTEGER :: IIB,IJB,IIE,IJE,IDIMX,IDIMY,IMI
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. PROLOGUE
+! --------
+! Compute relaxation coefficients without changing INI_DYNAMICS nor RELAXDEF
+!
+IF (CCLOUD == 'LIMA') THEN
+ LHORELAX_SVC1R3=LHORELAX_SVLIMA
+END IF
+!
+!
+NULLIFY(TZINITHALO2D_ll)
+NULLIFY(TZINITHALO3D_ll)
+!
+!* 1. RETRIEVE LOGICAL UNIT NUMBER
+! ----------------------------
+!
+ILUOUT = TLUOUT%NLU
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. END OF READING
+! --------------
+!* 2.1 Read number of forcing fields
+!
+IF (LFORCING) THEN ! Retrieve the number of time-dependent forcings.
+ CALL IO_Field_read(TPINIFILE,'FRC',NFRC,IRESP)
+ IF ( (IRESP /= 0) .OR. (NFRC <=0) ) THEN
+ WRITE(ILUOUT,'(A/A)') &
+ "INI_MODEL_n ERROR: you want to read forcing variables from FMfile", &
+ " but no fields have been found by IO_Field_read"
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+END IF
+!
+! Modif PP for time evolving adv forcing
+ IF ( L2D_ADV_FRC ) THEN ! Retrieve the number of time-dependent forcings.
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ENTER ADV_FORCING"
+ CALL IO_Field_read(TPINIFILE,'NADVFRC1',NADVFRC,IRESP)
+ IF ( (IRESP /= 0) .OR. (NADVFRC <=0) ) THEN
+ WRITE(ILUOUT,'(A/A)') &
+ "INI_MODELn ERROR: you want to read forcing ADV variables from FMfile", &
+ " but no fields have been found by IO_Field_read"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ WRITE(ILUOUT,*) 'NADVFRC = ', NADVFRC
+END IF
+!
+IF ( L2D_REL_FRC ) THEN ! Retrieve the number of time-dependent forcings.
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ENTER REL_FORCING"
+ CALL IO_Field_read(TPINIFILE,'NRELFRC1',NRELFRC,IRESP)
+ IF ( (IRESP /= 0) .OR. (NRELFRC <=0) ) THEN
+ WRITE(ILUOUT,'(A/A)') &
+ "INI_MODELn ERROR: you want to read forcing REL variables from FMfile", &
+ " but no fields have been found by IO_Field_read"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ WRITE(ILUOUT,*) 'NRELFRC = ', NRELFRC
+END IF
+!* 2.2 Checks the position of vertical absorbing layer
+!
+IKU=NKMAX+2*JPVEXT
+!
+ALLOCATE(XZHAT(IKU))
+CALL IO_Field_read(TPINIFILE,'ZHAT',XZHAT)
+CALL IO_Field_read(TPINIFILE,'ZTOP',XZTOP)
+IF (XALZBOT>=XZHAT(IKU) .AND. LVE_RELAX) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ERROR: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but bottom of layer XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " is upper than model top (",XZHAT(IKU),")"
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+END IF
+IF (LVE_RELAX) THEN
+ IF (XALZBOT>=XZHAT(IKU-4) ) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n WARNING: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but the layer defined by XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " contains less than 5 model levels"
+ END IF
+END IF
+DEALLOCATE(XZHAT)
+!
+!* 2.3 Compute sizes of arrays of the extended sub-domain
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+IIU_ll=NIMAX_ll + 2 * JPHEXT
+IJU_ll=NJMAX_ll + 2 * JPHEXT
+! initialize NIMAX and NJMAX for not updated versions regarding the parallelism
+! spawning,...
+CALL GET_DIM_PHYS_ll('B',NIMAX,NJMAX)
+!
+CALL GET_INDICE_ll( IIB,IJB,IIE,IJE)
+IDIMX = IIE - IIB + 1
+IDIMY = IJE - IJB + 1
+!
+NRR=0
+NRRL=0
+NRRI=0
+IF (CGETRVT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ IDX_RVT = NRR
+END IF
+IF (CGETRCT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRL = NRRL+1
+ IDX_RCT = NRR
+END IF
+IF (CGETRRT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRL = NRRL+1
+ IDX_RRT = NRR
+END IF
+IF (CGETRIT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RIT = NRR
+END IF
+IF (CGETRST /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RST = NRR
+END IF
+IF (CGETRGT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RGT = NRR
+END IF
+IF (CGETRHT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RHT = NRR
+END IF
+IF (NVERB >= 5) THEN
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," WATER VARIABLES")') NRR
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," LIQUID VARIABLES")') NRRL
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," SOLID VARIABLES")') NRRI
+END IF
+!
+!* 2.4 Update NSV and floating indices for the current model
+!
+!
+CALL UPDATE_NSV(KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ALLOCATE MEMORY
+! -----------------
+!
+!* 3.1 Module MODD_FIELD_n
+!
+IF (LMEAN_FIELD) THEN
+!
+ MEAN_COUNT = 0
+!
+ ALLOCATE(XUM_MEAN(IIU,IJU,IKU)) ; XUM_MEAN = 0.0
+ ALLOCATE(XVM_MEAN(IIU,IJU,IKU)) ; XVM_MEAN = 0.0
+ ALLOCATE(XWM_MEAN(IIU,IJU,IKU)) ; XWM_MEAN = 0.0
+ ALLOCATE(XTHM_MEAN(IIU,IJU,IKU)) ; XTHM_MEAN = 0.0
+ ALLOCATE(XTEMPM_MEAN(IIU,IJU,IKU)) ; XTEMPM_MEAN = 0.0
+ IF (CTURB/='NONE') THEN
+ ALLOCATE(XTKEM_MEAN(IIU,IJU,IKU))
+ XTKEM_MEAN = 0.0
+ ELSE
+ ALLOCATE(XTKEM_MEAN(0,0,0))
+ END IF
+ ALLOCATE(XPABSM_MEAN(IIU,IJU,IKU)) ; XPABSM_MEAN = 0.0
+!
+ ALLOCATE(XU2_MEAN(IIU,IJU,IKU)) ; XU2_MEAN = 0.0
+ ALLOCATE(XV2_MEAN(IIU,IJU,IKU)) ; XV2_MEAN = 0.0
+ ALLOCATE(XW2_MEAN(IIU,IJU,IKU)) ; XW2_MEAN = 0.0
+ ALLOCATE(XTH2_MEAN(IIU,IJU,IKU)) ; XTH2_MEAN = 0.0
+ ALLOCATE(XTEMP2_MEAN(IIU,IJU,IKU)) ; XTEMP2_MEAN = 0.0
+ ALLOCATE(XPABS2_MEAN(IIU,IJU,IKU)) ; XPABS2_MEAN = 0.0
+!
+ ALLOCATE(XUM_MAX(IIU,IJU,IKU)) ; XUM_MAX = -1.E20
+ ALLOCATE(XVM_MAX(IIU,IJU,IKU)) ; XVM_MAX = -1.E20
+ ALLOCATE(XWM_MAX(IIU,IJU,IKU)) ; XWM_MAX = -1.E20
+ ALLOCATE(XTHM_MAX(IIU,IJU,IKU)) ; XTHM_MAX = 0.0
+ ALLOCATE(XTEMPM_MAX(IIU,IJU,IKU)) ; XTEMPM_MAX = 0.0
+ IF (CTURB/='NONE') THEN
+ ALLOCATE(XTKEM_MAX(IIU,IJU,IKU))
+ XTKEM_MAX = 0.0
+ ELSE
+ ALLOCATE(XTKEM_MAX(0,0,0))
+ END IF
+ ALLOCATE(XPABSM_MAX(IIU,IJU,IKU)) ; XPABSM_MAX = 0.0
+ELSE
+ ALLOCATE(XUM_MEAN(0,0,0))
+ ALLOCATE(XVM_MEAN(0,0,0))
+ ALLOCATE(XWM_MEAN(0,0,0))
+ ALLOCATE(XTHM_MEAN(0,0,0))
+ ALLOCATE(XTEMPM_MEAN(0,0,0))
+ ALLOCATE(XTKEM_MEAN(0,0,0))
+ ALLOCATE(XPABSM_MEAN(0,0,0))
+!
+ ALLOCATE(XU2_MEAN(0,0,0))
+ ALLOCATE(XV2_MEAN(0,0,0))
+ ALLOCATE(XW2_MEAN(0,0,0))
+ ALLOCATE(XTH2_MEAN(0,0,0))
+ ALLOCATE(XTEMP2_MEAN(0,0,0))
+ ALLOCATE(XPABS2_MEAN(0,0,0))
+!
+ ALLOCATE(XUM_MAX(0,0,0))
+ ALLOCATE(XVM_MAX(0,0,0))
+ ALLOCATE(XWM_MAX(0,0,0))
+ ALLOCATE(XTHM_MAX(0,0,0))
+ ALLOCATE(XTEMPM_MAX(0,0,0))
+ ALLOCATE(XTKEM_MAX(0,0,0))
+ ALLOCATE(XPABSM_MAX(0,0,0))
+END IF
+!
+IF ((CUVW_ADV_SCHEME(1:3)=='CEN') .AND. (CTEMP_SCHEME == 'LEFR') ) THEN
+ ALLOCATE(XUM(IIU,IJU,IKU))
+ ALLOCATE(XVM(IIU,IJU,IKU))
+ ALLOCATE(XWM(IIU,IJU,IKU))
+ ALLOCATE(XDUM(IIU,IJU,IKU))
+ ALLOCATE(XDVM(IIU,IJU,IKU))
+ ALLOCATE(XDWM(IIU,IJU,IKU))
+ IF (CCONF == 'START') THEN
+ XUM = 0.0
+ XVM = 0.0
+ XWM = 0.0
+ XDUM = 0.0
+ XDVM = 0.0
+ XDWM = 0.0
+ END IF
+ELSE
+ ALLOCATE(XUM(0,0,0))
+ ALLOCATE(XVM(0,0,0))
+ ALLOCATE(XWM(0,0,0))
+ ALLOCATE(XDUM(0,0,0))
+ ALLOCATE(XDVM(0,0,0))
+ ALLOCATE(XDWM(0,0,0))
+END IF
+!
+ALLOCATE(XUT(IIU,IJU,IKU)) ; XUT = 0.0
+ALLOCATE(XVT(IIU,IJU,IKU)) ; XVT = 0.0
+ALLOCATE(XWT(IIU,IJU,IKU)) ; XWT = 0.0
+ALLOCATE(XTHT(IIU,IJU,IKU)) ; XTHT = 0.0
+ALLOCATE(XRUS(IIU,IJU,IKU)) ; XRUS = 0.0
+ALLOCATE(XRVS(IIU,IJU,IKU)) ; XRVS = 0.0
+ALLOCATE(XRWS(IIU,IJU,IKU)) ; XRWS = 0.0
+ALLOCATE(XRUS_PRES(IIU,IJU,IKU)); XRUS_PRES = 0.0
+ALLOCATE(XRVS_PRES(IIU,IJU,IKU)); XRVS_PRES = 0.0
+ALLOCATE(XRWS_PRES(IIU,IJU,IKU)); XRWS_PRES = 0.0
+ALLOCATE(XRTHS(IIU,IJU,IKU)) ; XRTHS = 0.0
+!$acc enter data copyin(XRTHS)
+ALLOCATE(XRTHS_CLD(IIU,IJU,IKU)); XRTHS_CLD = 0.0
+IF (CTURB /= 'NONE') THEN
+ ALLOCATE(XTKET(IIU,IJU,IKU))
+ ALLOCATE(XRTKES(IIU,IJU,IKU))
+ ALLOCATE(XRTKEMS(IIU,IJU,IKU)); XRTKEMS = 0.0
+ ALLOCATE(XWTHVMF(IIU,IJU,IKU))
+ ALLOCATE(XDYP(IIU,IJU,IKU))
+ ALLOCATE(XTHP(IIU,IJU,IKU))
+ ALLOCATE(XTR(IIU,IJU,IKU))
+ ALLOCATE(XDISS(IIU,IJU,IKU))
+ ALLOCATE(XLEM(IIU,IJU,IKU))
+ XTKEMIN=XKEMIN
+ XCED =XCEDIS
+ELSE
+ ALLOCATE(XTKET(0,0,0))
+ ALLOCATE(XRTKES(0,0,0))
+ ALLOCATE(XRTKEMS(0,0,0))
+ ALLOCATE(XWTHVMF(0,0,0))
+ ALLOCATE(XDYP(0,0,0))
+ ALLOCATE(XTHP(0,0,0))
+ ALLOCATE(XTR(0,0,0))
+ ALLOCATE(XDISS(0,0,0))
+ ALLOCATE(XLEM(0,0,0))
+END IF
+IF (CTOM == 'TM06') THEN
+ ALLOCATE(XBL_DEPTH(IIU,IJU))
+ELSE
+ ALLOCATE(XBL_DEPTH(0,0))
+END IF
+IF (LRMC01) THEN
+ ALLOCATE(XSBL_DEPTH(IIU,IJU))
+ELSE
+ ALLOCATE(XSBL_DEPTH(0,0))
+END IF
+!
+ALLOCATE(XPABSM(IIU,IJU,IKU)) ; XPABSM = 0.0
+ALLOCATE(XPABST(IIU,IJU,IKU)) ; XPABST = 0.0
+!
+ALLOCATE(XRT(IIU,IJU,IKU,NRR)) ; XRT = 0.0
+ALLOCATE(XRRS(IIU,IJU,IKU,NRR)) ; XRRS = 0.0
+ALLOCATE(XRRS_CLD(IIU,IJU,IKU,NRR)); XRRS_CLD = 0.0
+!
+IF (CTURB /= 'NONE' .AND. NRR>1) THEN
+ ALLOCATE(XSRCT(IIU,IJU,IKU))
+ ALLOCATE(XSIGS(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XSRCT(0,0,0))
+ ALLOCATE(XSIGS(0,0,0))
+END IF
+!
+IF (NRR>1) THEN
+ ALLOCATE(XCLDFR(IIU,IJU,IKU))
+ ALLOCATE(XRAINFR(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XCLDFR(0,0,0))
+ ALLOCATE(XRAINFR(0,0,0))
+END IF
+!
+ALLOCATE(XSVT(IIU,IJU,IKU,NSV)) ; XSVT = 0.
+ALLOCATE(XRSVS(IIU,IJU,IKU,NSV)); XRSVS = 0.
+ALLOCATE(XRSVS_CLD(IIU,IJU,IKU,NSV)); XRSVS_CLD = 0.0
+ALLOCATE(XZWS(IIU,IJU)) ; XZWS(:,:) = XZWS_DEFAULT
+!
+IF (LPASPOL) THEN
+ ALLOCATE( XATC(IIU,IJU,IKU,NSV_PP) )
+ XATC = 0.
+ELSE
+ ALLOCATE( XATC(0,0,0,0))
+END IF
+!
+IF(LBLOWSNOW) THEN
+ ALLOCATE(XSNWCANO(IIU,IJU,NBLOWSNOW_2D))
+ ALLOCATE(XRSNWCANOS(IIU,IJU,NBLOWSNOW_2D))
+ XSNWCANO(:,:,:) = 0.0
+ XRSNWCANOS(:,:,:) = 0.0
+ELSE
+ ALLOCATE(XSNWCANO(0,0,0))
+ ALLOCATE(XRSNWCANOS(0,0,0))
+END IF
+!
+!* 3.2 Module MODD_GRID_n and MODD_METRICS_n
+!
+IF (LCARTESIAN) THEN
+ ALLOCATE(XLON(0,0))
+ ALLOCATE(XLAT(0,0))
+ ALLOCATE(XMAP(0,0))
+ELSE
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XMAP(IIU,IJU))
+END IF
+ALLOCATE(XXHAT(IIU))
+ALLOCATE(XDXHAT(IIU))
+ALLOCATE(XYHAT(IJU))
+ALLOCATE(XDYHAT(IJU))
+ALLOCATE(XZS(IIU,IJU))
+ALLOCATE(XZSMT(IIU,IJU))
+ALLOCATE(XZZ(IIU,IJU,IKU))
+ALLOCATE(XZHAT(IKU))
+ALLOCATE(XDIRCOSZW(IIU,IJU))
+ALLOCATE(XDIRCOSXW(IIU,IJU))
+ALLOCATE(XDIRCOSYW(IIU,IJU))
+ALLOCATE(XCOSSLOPE(IIU,IJU))
+ALLOCATE(XSINSLOPE(IIU,IJU))
+!
+ALLOCATE(XDXX(IIU,IJU,IKU))
+ALLOCATE(XDYY(IIU,IJU,IKU))
+ALLOCATE(XDZX(IIU,IJU,IKU))
+ALLOCATE(XDZY(IIU,IJU,IKU))
+ALLOCATE(XDZZ(IIU,IJU,IKU))
+!$acc enter data create(XDXX,XDYY,XDZZ,XDZX,XDZY)
+!
+!* 3.3 Modules MODD_REF and MODD_REF_n
+!
+IF (KMI == 1) THEN
+ ALLOCATE(XRHODREFZ(IKU),XTHVREFZ(IKU))
+ELSE
+ !Do not allocate XRHODREFZ and XTHVREFZ because they are the same on all grids (not 'n' variables)
+END IF
+ALLOCATE(XRHODREF(IIU,IJU,IKU))
+ALLOCATE(XTHVREF(IIU,IJU,IKU))
+ALLOCATE(XEXNREF(IIU,IJU,IKU))
+ALLOCATE(XRHODJ(IIU,IJU,IKU))
+!$acc enter data create(XRHODJ)
+IF (CEQNSYS=='DUR' .AND. LUSERV) THEN
+ ALLOCATE(XRVREF(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XRVREF(0,0,0))
+END IF
+!
+!* 3.4 Module MODD_CURVCOR_n
+!
+IF (LTHINSHELL) THEN
+ ALLOCATE(XCORIOX(0,0))
+ ALLOCATE(XCORIOY(0,0))
+ELSE
+ ALLOCATE(XCORIOX(IIU,IJU))
+ ALLOCATE(XCORIOY(IIU,IJU))
+END IF
+ ALLOCATE(XCORIOZ(IIU,IJU))
+IF (LCARTESIAN) THEN
+ ALLOCATE(XCURVX(0,0))
+ ALLOCATE(XCURVY(0,0))
+ELSE
+ ALLOCATE(XCURVX(IIU,IJU))
+ ALLOCATE(XCURVY(IIU,IJU))
+END IF
+!
+!* 3.5 Module MODD_DYN_n
+!
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IF (L2D) THEN
+ ALLOCATE(XBFY(IIY,IJY,IKU))
+ELSE
+ ALLOCATE(XBFY(IJY,IIY,IKU)) ! transposition needed by the optimisation of the
+ ! FFT solver
+END IF
+CALL GET_DIM_EXT_ll('B',IIU_B,IJU_B)
+ALLOCATE(XBFB(IIU_B,IJU_B,IKU))
+ALLOCATE(XAF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XBF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XCF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XDXATH_ZS(IIU_B,IJU_B))
+ALLOCATE(XDYATH_ZS(IIU_B,IJU_B))
+ALLOCATE(XRHO_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XA_K(IKU))
+ALLOCATE(XB_K(IKU))
+ALLOCATE(XC_K(IKU))
+ALLOCATE(XD_K(IKU))
+
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+ALLOCATE(XBF_SXP2_YP1_Z(IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll))
+ALLOCATE(XAF(IKU),XCF(IKU))
+ALLOCATE(XTRIGSX(3*IIU_ll))
+ALLOCATE(XTRIGSY(3*IJU_ll))
+ALLOCATE(XRHOM(IKU))
+ALLOCATE(XALK(IKU))
+ALLOCATE(XALKW(IKU))
+ALLOCATE(XALKBAS(IKU))
+ALLOCATE(XALKWBAS(IKU))
+!
+IF ( LHORELAX_UVWTH .OR. LHORELAX_RV .OR. &
+ LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. &
+ LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. &
+ ANY(LHORELAX_SV) ) THEN
+ ALLOCATE(XKURELAX(IIU,IJU))
+ ALLOCATE(XKVRELAX(IIU,IJU))
+ ALLOCATE(XKWRELAX(IIU,IJU))
+ ALLOCATE(LMASK_RELAX(IIU,IJU))
+ELSE
+ ALLOCATE(XKURELAX(0,0))
+ ALLOCATE(XKVRELAX(0,0))
+ ALLOCATE(XKWRELAX(0,0))
+ ALLOCATE(LMASK_RELAX(0,0))
+END IF
+!
+! Additional fields for truly horizontal diffusion (Module MODD_DYNZD$n)
+IF (LZDIFFU) THEN
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2)
+ELSE
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2,0)
+ENDIF
+!
+!* 3.6 Larger Scale variables (Module MODD_LSFIELD$n)
+!
+!
+! upper relaxation part
+!
+ALLOCATE(XLSUM(IIU,IJU,IKU)) ; XLSUM = 0.0
+ALLOCATE(XLSVM(IIU,IJU,IKU)) ; XLSVM = 0.0
+ALLOCATE(XLSWM(IIU,IJU,IKU)) ; XLSWM = 0.0
+ALLOCATE(XLSTHM(IIU,IJU,IKU)) ; XLSTHM = 0.0
+IF ( NRR > 0 ) THEN
+ ALLOCATE(XLSRVM(IIU,IJU,IKU)) ; XLSRVM = 0.0
+ELSE
+ ALLOCATE(XLSRVM(0,0,0))
+END IF
+ALLOCATE(XLSZWSM(IIU,IJU)) ; XLSZWSM = -1.
+!
+! lbc part
+!
+IF ( L1D) THEN ! 1D case
+!
+ NSIZELBX_ll=0
+ NSIZELBXU_ll=0
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBXTKE_ll=0
+ NSIZELBXR_ll=0
+ NSIZELBXSV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXUM(0,0,0))
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBXVM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBXWM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBXTHM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ELSEIF( L2D ) THEN ! 2D case
+!
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+!
+ IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2*JPHEXT
+ NSIZELBXU_ll=2*NRIMX+2*JPHEXT
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBX_ll=2*JPHEXT ! 2
+ NSIZELBXU_ll=2*(JPHEXT+1) ! 4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+!
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2* NRIMX+2*JPHEXT
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2* NRIMX+2*JPHEXT
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2* NRIMX+2*JPHEXT
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ END IF
+!
+ELSE ! 3D case
+!
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+ CALL GET_SIZEY_LB(NIMAX_ll,NJMAX_ll,NRIMY, &
+ IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV, &
+ IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2)
+!
+! check if local domain not to small for NRIMX NRIMY
+!
+ IF ( CLBCX(1) /= 'CYCL' ) THEN
+ IF ( NRIMX .GT. IDIMX ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_MODEL_n ERROR: ( NRIMX > IDIMX ) ", &
+ " Local domain to small for relaxation NRIMX,IDIMX ", &
+ NRIMX,IDIMX ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ END IF
+ IF ( CLBCY(1) /= 'CYCL' ) THEN
+ IF ( NRIMY .GT. IDIMY ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_MODEL_n ERROR: ( NRIMY > IDIMY ) ", &
+ " Local domain to small for relaxation NRIMY,IDIMY ", &
+ NRIMY,IDIMY ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ END IF
+IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2*JPHEXT
+ NSIZELBXU_ll=2*NRIMX+2*JPHEXT
+ NSIZELBY_ll=2*NRIMY+2*JPHEXT
+ NSIZELBYV_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBYUM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYVM(IISIZEYFV,IJSIZEYFV,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYWM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTHM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBX_ll=2*JPHEXT ! 2
+ NSIZELBXU_ll=2*(JPHEXT+1) ! 4
+ NSIZELBY_ll=2*JPHEXT ! 2
+ NSIZELBYV_ll=2*(JPHEXT+1) ! 4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBYUM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYVM(IISIZEY4,IJSIZEY4,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYWM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTHM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ !
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2*NRIMX+2*JPHEXT
+ NSIZELBYTKE_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2*JPHEXT ! 2
+ NSIZELBYTKE_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ NSIZELBYTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2*NRIMX+2*JPHEXT
+ NSIZELBYR_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEYF,IJSIZEYF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2*JPHEXT ! 2
+ NSIZELBYR_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEY2,IJSIZEY2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ NSIZELBYR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2*NRIMX+2*JPHEXT
+ NSIZELBYSV_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEYF,IJSIZEYF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2*JPHEXT ! 2
+ NSIZELBYSV_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEY2,IJSIZEY2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+ END IF
+END IF ! END OF THE IF STRUCTURE ON THE MODEL DIMENSION
+!
+!
+IF ( KMI > 1 ) THEN
+ ! it has been assumed that the THeta field used the largest rim area compared
+ ! to the others prognostic variables, if it is not the case, you must change
+ ! these lines
+ ALLOCATE(XCOEFLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE( NKLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XCOEFLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE( NKLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XCOEFLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE( NKLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XCOEFLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE( NKLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XCOEFLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE( NKLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XCOEFLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE( NKLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XCOEFLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE( NKLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XCOEFLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE( NKLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ELSE
+ ALLOCATE(XCOEFLIN_LBXM(0,0,0))
+ ALLOCATE( NKLIN_LBXM(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYM(0,0,0))
+ ALLOCATE( NKLIN_LBYM(0,0,0))
+ ALLOCATE(XCOEFLIN_LBXU(0,0,0))
+ ALLOCATE( NKLIN_LBXU(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYU(0,0,0))
+ ALLOCATE( NKLIN_LBYU(0,0,0))
+ ALLOCATE(XCOEFLIN_LBXV(0,0,0))
+ ALLOCATE( NKLIN_LBXV(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYV(0,0,0))
+ ALLOCATE( NKLIN_LBYV(0,0,0))
+ ALLOCATE(XCOEFLIN_LBXW(0,0,0))
+ ALLOCATE( NKLIN_LBXW(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYW(0,0,0))
+ ALLOCATE( NKLIN_LBYW(0,0,0))
+END IF
+!
+! allocation of the LS fields for vertical relaxation and numerical diffusion
+IF( .NOT. LSTEADYLS ) THEN
+!
+ ALLOCATE(XLSUS(SIZE(XLSUM,1),SIZE(XLSUM,2),SIZE(XLSUM,3)))
+ ALLOCATE(XLSVS(SIZE(XLSVM,1),SIZE(XLSVM,2),SIZE(XLSVM,3)))
+ ALLOCATE(XLSWS(SIZE(XLSWM,1),SIZE(XLSWM,2),SIZE(XLSWM,3)))
+ ALLOCATE(XLSTHS(SIZE(XLSTHM,1),SIZE(XLSTHM,2),SIZE(XLSTHM,3)))
+ ALLOCATE(XLSRVS(SIZE(XLSRVM,1),SIZE(XLSRVM,2),SIZE(XLSRVM,3)))
+ ALLOCATE(XLSZWSS(SIZE(XLSZWSM,1),SIZE(XLSZWSM,2)))
+!
+ELSE
+!
+ ALLOCATE(XLSUS(0,0,0))
+ ALLOCATE(XLSVS(0,0,0))
+ ALLOCATE(XLSWS(0,0,0))
+ ALLOCATE(XLSTHS(0,0,0))
+ ALLOCATE(XLSRVS(0,0,0))
+ ALLOCATE(XLSZWSS(0,0))
+!
+END IF
+! allocation of the LB fields for horizontal relaxation and Lateral Boundaries
+IF( .NOT. ( LSTEADYLS .AND. KMI==1 ) ) THEN
+!
+ ALLOCATE(XLBXTKES(SIZE(XLBXTKEM,1),SIZE(XLBXTKEM,2),SIZE(XLBXTKEM,3)))
+ ALLOCATE(XLBYTKES(SIZE(XLBYTKEM,1),SIZE(XLBYTKEM,2),SIZE(XLBYTKEM,3)))
+ ALLOCATE(XLBXUS(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XLBYUS(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XLBXVS(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XLBYVS(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XLBXWS(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XLBYWS(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE(XLBXTHS(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XLBYTHS(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XLBXRS(SIZE(XLBXRM,1),SIZE(XLBXRM,2),SIZE(XLBXRM,3),SIZE(XLBXRM,4)))
+ ALLOCATE(XLBYRS(SIZE(XLBYRM,1),SIZE(XLBYRM,2),SIZE(XLBYRM,3),SIZE(XLBYRM,4)))
+ ALLOCATE(XLBXSVS(SIZE(XLBXSVM,1),SIZE(XLBXSVM,2),SIZE(XLBXSVM,3),SIZE(XLBXSVM,4)))
+ ALLOCATE(XLBYSVS(SIZE(XLBYSVM,1),SIZE(XLBYSVM,2),SIZE(XLBYSVM,3),SIZE(XLBYSVM,4)))
+!
+ELSE
+!
+ ALLOCATE(XLBXTKES(0,0,0))
+ ALLOCATE(XLBYTKES(0,0,0))
+ ALLOCATE(XLBXUS(0,0,0))
+ ALLOCATE(XLBYUS(0,0,0))
+ ALLOCATE(XLBXVS(0,0,0))
+ ALLOCATE(XLBYVS(0,0,0))
+ ALLOCATE(XLBXWS(0,0,0))
+ ALLOCATE(XLBYWS(0,0,0))
+ ALLOCATE(XLBXTHS(0,0,0))
+ ALLOCATE(XLBYTHS(0,0,0))
+ ALLOCATE(XLBXRS(0,0,0,0))
+ ALLOCATE(XLBYRS(0,0,0,0))
+ ALLOCATE(XLBXSVS(0,0,0,0))
+ ALLOCATE(XLBYSVS(0,0,0,0))
+!
+END IF
+!
+!
+!* 3.7 Module MODD_RADIATIONS_n (except XOZON and XAER)
+!
+! Initialization of SW bands
+NSWB_OLD = 6 ! Number of bands in ECMWF original scheme (from Fouquart et Bonnel (1980))
+ ! then modified through INI_RADIATIONS_ECMWF but remains equal to 6 practically
+IF (CRAD == 'ECRA') THEN
+ NSWB_MNH = 14
+ELSE
+ NSWB_MNH = NSWB_OLD
+END IF
+
+NLWB_MNH = 16 ! For XEMIS initialization (should be spectral in the future)
+
+
+ALLOCATE(XSW_BANDS (NSWB_MNH))
+ALLOCATE(XLW_BANDS (NLWB_MNH))
+ALLOCATE(XZENITH (IIU,IJU))
+ALLOCATE(XAZIM (IIU,IJU))
+ALLOCATE(XALBUV (IIU,IJU))
+XALBUV(:,:) = NALBUV_DEFAULT !Set to an arbitrary low value (XALBUV is needed in CH_INTERP_JVALUES even if no radiation)
+ALLOCATE(XDIRSRFSWD(IIU,IJU,NSWB_MNH))
+ALLOCATE(XSCAFLASWD(IIU,IJU,NSWB_MNH))
+ALLOCATE(XFLALWD (IIU,IJU))
+!
+IF (CRAD /= 'NONE') THEN
+ ALLOCATE(XSLOPANG(IIU,IJU))
+ ALLOCATE(XSLOPAZI(IIU,IJU))
+ ALLOCATE(XDTHRAD(IIU,IJU,IKU))
+ ALLOCATE(XDIRFLASWD(IIU,IJU,NSWB_MNH))
+ ALLOCATE(XDIR_ALB(IIU,IJU,NSWB_MNH))
+ ALLOCATE(XSCA_ALB(IIU,IJU,NSWB_MNH))
+ ALLOCATE(XEMIS (IIU,IJU,NLWB_MNH))
+ ALLOCATE(XTSRAD (IIU,IJU)) ; XTSRAD = 0.0
+ ALLOCATE(XSEA (IIU,IJU))
+ ALLOCATE(XZS_XY (IIU,IJU))
+ ALLOCATE(NCLEARCOL_TM1(IIU,IJU))
+ ALLOCATE(XSWU(IIU,IJU,IKU))
+ ALLOCATE(XSWD(IIU,IJU,IKU))
+ ALLOCATE(XLWU(IIU,IJU,IKU))
+ ALLOCATE(XLWD(IIU,IJU,IKU))
+ ALLOCATE(XDTHRADSW(IIU,IJU,IKU))
+ ALLOCATE(XDTHRADLW(IIU,IJU,IKU))
+ ALLOCATE(XRADEFF(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XSLOPANG(0,0))
+ ALLOCATE(XSLOPAZI(0,0))
+ ALLOCATE(XDTHRAD(0,0,0))
+ ALLOCATE(XDIRFLASWD(0,0,0))
+ ALLOCATE(XDIR_ALB(0,0,0))
+ ALLOCATE(XSCA_ALB(0,0,0))
+ ALLOCATE(XEMIS (0,0,0))
+ ALLOCATE(XTSRAD (0,0))
+ ALLOCATE(XSEA (0,0))
+ ALLOCATE(XZS_XY (0,0))
+ ALLOCATE(NCLEARCOL_TM1(0,0))
+ ALLOCATE(XSWU(0,0,0))
+ ALLOCATE(XSWD(0,0,0))
+ ALLOCATE(XLWU(0,0,0))
+ ALLOCATE(XLWD(0,0,0))
+ ALLOCATE(XDTHRADSW(0,0,0))
+ ALLOCATE(XDTHRADLW(0,0,0))
+ ALLOCATE(XRADEFF(0,0,0))
+END IF
+
+IF (CRAD == 'ECMW' .OR. CRAD == 'ECRA') THEN
+ ALLOCATE(XSTROATM(31,6))
+ ALLOCATE(XSMLSATM(31,6))
+ ALLOCATE(XSMLWATM(31,6))
+ ALLOCATE(XSPOSATM(31,6))
+ ALLOCATE(XSPOWATM(31,6))
+ ALLOCATE(XSTATM(31,6))
+ELSE
+ ALLOCATE(XSTROATM(0,0))
+ ALLOCATE(XSMLSATM(0,0))
+ ALLOCATE(XSMLWATM(0,0))
+ ALLOCATE(XSPOSATM(0,0))
+ ALLOCATE(XSPOWATM(0,0))
+ ALLOCATE(XSTATM(0,0))
+END IF
+!
+!* 3.8 Module MODD_DEEP_CONVECTION_n
+!
+IF (CDCONV /= 'NONE' .OR. CSCONV == 'KAFR') THEN
+ ALLOCATE(NCOUNTCONV(IIU,IJU))
+ ALLOCATE(XDTHCONV(IIU,IJU,IKU))
+ ALLOCATE(XDRVCONV(IIU,IJU,IKU))
+ ALLOCATE(XDRCCONV(IIU,IJU,IKU))
+ ALLOCATE(XDRICONV(IIU,IJU,IKU))
+ ALLOCATE(XPRCONV(IIU,IJU))
+ ALLOCATE(XPACCONV(IIU,IJU))
+ ALLOCATE(XPRSCONV(IIU,IJU))
+ ! diagnostics
+ IF (LCH_CONV_LINOX) THEN
+ ALLOCATE(XIC_RATE(IIU,IJU))
+ ALLOCATE(XCG_RATE(IIU,IJU))
+ ALLOCATE(XIC_TOTAL_NUMBER(IIU,IJU))
+ ALLOCATE(XCG_TOTAL_NUMBER(IIU,IJU))
+ ELSE
+ ALLOCATE(XIC_RATE(0,0))
+ ALLOCATE(XCG_RATE(0,0))
+ ALLOCATE(XIC_TOTAL_NUMBER(0,0))
+ ALLOCATE(XCG_TOTAL_NUMBER(0,0))
+ END IF
+ IF ( LDIAGCONV ) THEN
+ ALLOCATE(XUMFCONV(IIU,IJU,IKU))
+ ALLOCATE(XDMFCONV(IIU,IJU,IKU))
+ ALLOCATE(XPRLFLXCONV(IIU,IJU,IKU))
+ ALLOCATE(XPRSFLXCONV(IIU,IJU,IKU))
+ ALLOCATE(XCAPE(IIU,IJU))
+ ALLOCATE(NCLTOPCONV(IIU,IJU))
+ ALLOCATE(NCLBASCONV(IIU,IJU))
+ ELSE
+ ALLOCATE(XUMFCONV(0,0,0))
+ ALLOCATE(XDMFCONV(0,0,0))
+ ALLOCATE(XPRLFLXCONV(0,0,0))
+ ALLOCATE(XPRSFLXCONV(0,0,0))
+ ALLOCATE(XCAPE(0,0))
+ ALLOCATE(NCLTOPCONV(0,0))
+ ALLOCATE(NCLBASCONV(0,0))
+ END IF
+ELSE
+ ALLOCATE(NCOUNTCONV(0,0))
+ ALLOCATE(XDTHCONV(0,0,0))
+ ALLOCATE(XDRVCONV(0,0,0))
+ ALLOCATE(XDRCCONV(0,0,0))
+ ALLOCATE(XDRICONV(0,0,0))
+ ALLOCATE(XPRCONV(0,0))
+ ALLOCATE(XPACCONV(0,0))
+ ALLOCATE(XPRSCONV(0,0))
+ ALLOCATE(XIC_RATE(0,0))
+ ALLOCATE(XCG_RATE(0,0))
+ ALLOCATE(XIC_TOTAL_NUMBER(0,0))
+ ALLOCATE(XCG_TOTAL_NUMBER(0,0))
+ ALLOCATE(XUMFCONV(0,0,0))
+ ALLOCATE(XDMFCONV(0,0,0))
+ ALLOCATE(XPRLFLXCONV(0,0,0))
+ ALLOCATE(XPRSFLXCONV(0,0,0))
+ ALLOCATE(XCAPE(0,0))
+ ALLOCATE(NCLTOPCONV(0,0))
+ ALLOCATE(NCLBASCONV(0,0))
+END IF
+!
+IF ((CDCONV == 'KAFR' .OR. CSCONV == 'KAFR') &
+ .AND. LSUBG_COND .AND. LSIG_CONV) THEN
+ ALLOCATE(XMFCONV(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XMFCONV(0,0,0))
+ENDIF
+!
+IF ((CDCONV == 'KAFR' .OR. CSCONV == 'KAFR') &
+ .AND. LCHTRANS .AND. NSV > 0 ) THEN
+ ALLOCATE(XDSVCONV(IIU,IJU,IKU,NSV))
+ELSE
+ ALLOCATE(XDSVCONV(0,0,0,0))
+END IF
+!
+ALLOCATE(XCF_MF(IIU,IJU,IKU)) ; XCF_MF=0.0
+ALLOCATE(XRC_MF(IIU,IJU,IKU)) ; XRC_MF=0.0
+ALLOCATE(XRI_MF(IIU,IJU,IKU)) ; XRI_MF=0.0
+!
+!* 3.9 Local variables
+!
+ALLOCATE(ZJ(IIU,IJU,IKU))
+!
+!* 3.10 Forcing variables (Module MODD_FRC)
+!
+IF (KMI == 1) THEN
+ IF ( LFORCING ) THEN
+ ALLOCATE(TDTFRC(NFRC))
+ ALLOCATE(XUFRC(IKU,NFRC))
+ ALLOCATE(XVFRC(IKU,NFRC))
+ ALLOCATE(XWFRC(IKU,NFRC))
+ ALLOCATE(XTHFRC(IKU,NFRC))
+ ALLOCATE(XRVFRC(IKU,NFRC))
+ ALLOCATE(XTENDTHFRC(IKU,NFRC))
+ ALLOCATE(XTENDRVFRC(IKU,NFRC))
+ ALLOCATE(XGXTHFRC(IKU,NFRC))
+ ALLOCATE(XGYTHFRC(IKU,NFRC))
+ ALLOCATE(XPGROUNDFRC(NFRC))
+ ALLOCATE(XTENDUFRC(IKU,NFRC))
+ ALLOCATE(XTENDVFRC(IKU,NFRC))
+ ELSE
+ ALLOCATE(TDTFRC(0))
+ ALLOCATE(XUFRC(0,0))
+ ALLOCATE(XVFRC(0,0))
+ ALLOCATE(XWFRC(0,0))
+ ALLOCATE(XTHFRC(0,0))
+ ALLOCATE(XRVFRC(0,0))
+ ALLOCATE(XTENDTHFRC(0,0))
+ ALLOCATE(XTENDRVFRC(0,0))
+ ALLOCATE(XGXTHFRC(0,0))
+ ALLOCATE(XGYTHFRC(0,0))
+ ALLOCATE(XPGROUNDFRC(0))
+ ALLOCATE(XTENDUFRC(0,0))
+ ALLOCATE(XTENDVFRC(0,0))
+ END IF
+ IF ( LFORCING ) THEN
+ ALLOCATE(XWTFRC(IIU,IJU,IKU))
+ ALLOCATE(XUFRC_PAST(IIU,IJU,IKU)) ; XUFRC_PAST = XUNDEF
+ ALLOCATE(XVFRC_PAST(IIU,IJU,IKU)) ; XVFRC_PAST = XUNDEF
+ ELSE
+ ALLOCATE(XWTFRC(0,0,0))
+ ALLOCATE(XUFRC_PAST(0,0,0))
+ ALLOCATE(XVFRC_PAST(0,0,0))
+ END IF
+ELSE
+ !Do not allocate because they are the same on all grids (not 'n' variables)
+END IF
+! ----------------------------------------------------------------------
+!
+IF (L2D_ADV_FRC) THEN
+ WRITE(ILUOUT,*) 'L2D_ADV_FRC IS SET TO', L2D_ADV_FRC
+ WRITE(ILUOUT,*) 'ADV FRC WILL BE SET'
+ ALLOCATE(TDTADVFRC(NADVFRC))
+ ALLOCATE(XDTHFRC(IIU,IJU,IKU,NADVFRC)) ; XDTHFRC=0.
+ ALLOCATE(XDRVFRC(IIU,IJU,IKU,NADVFRC)) ; XDRVFRC=0.
+ELSE
+ ALLOCATE(TDTADVFRC(0))
+ ALLOCATE(XDTHFRC(0,0,0,0))
+ ALLOCATE(XDRVFRC(0,0,0,0))
+ENDIF
+
+IF (L2D_REL_FRC) THEN
+ WRITE(ILUOUT,*) 'L2D_REL_FRC IS SET TO', L2D_REL_FRC
+ WRITE(ILUOUT,*) 'REL FRC WILL BE SET'
+ ALLOCATE(TDTRELFRC(NRELFRC))
+ ALLOCATE(XTHREL(IIU,IJU,IKU,NRELFRC)) ; XTHREL=0.
+ ALLOCATE(XRVREL(IIU,IJU,IKU,NRELFRC)) ; XRVREL=0.
+ELSE
+ ALLOCATE(TDTRELFRC(0))
+ ALLOCATE(XTHREL(0,0,0,0))
+ ALLOCATE(XRVREL(0,0,0,0))
+ENDIF
+!
+!* 4.11 BIS: Eddy fluxes allocation
+!
+IF ( LTH_FLX ) THEN
+ ALLOCATE(XVTH_FLUX_M(IIU,IJU,IKU)) ; XVTH_FLUX_M = 0.
+ ALLOCATE(XWTH_FLUX_M(IIU,IJU,IKU)) ; XWTH_FLUX_M = 0.
+ IF (KMI /= 1) THEN
+ ALLOCATE(XRTHS_EDDY_FLUX(IIU,IJU,IKU))
+ XRTHS_EDDY_FLUX = 0.
+ ELSE
+ ALLOCATE(XRTHS_EDDY_FLUX(0,0,0))
+ ENDIF
+ELSE
+ ALLOCATE(XVTH_FLUX_M(0,0,0))
+ ALLOCATE(XWTH_FLUX_M(0,0,0))
+ ALLOCATE(XRTHS_EDDY_FLUX(0,0,0))
+END IF
+!
+IF ( LUV_FLX) THEN
+ ALLOCATE(XVU_FLUX_M(IIU,IJU,IKU)) ; XVU_FLUX_M = 0.
+ IF (KMI /= 1) THEN
+ ALLOCATE(XRVS_EDDY_FLUX(IIU,IJU,IKU))
+ XRVS_EDDY_FLUX = 0.
+ ELSE
+ ALLOCATE(XRVS_EDDY_FLUX(0,0,0))
+ ENDIF
+ELSE
+ ALLOCATE(XVU_FLUX_M(0,0,0))
+ ALLOCATE(XRVS_EDDY_FLUX(0,0,0))
+END IF
+!
+!* 3.11 Module MODD_ICE_CONC_n
+!
+IF ( (CCLOUD == 'ICE3'.OR.CCLOUD == 'ICE4') .AND. &
+ (CPROGRAM == 'DIAG '.OR.CPROGRAM == 'MESONH')) THEN
+ ALLOCATE(XCIT(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XCIT(0,0,0))
+END IF
+!
+IF ( CCLOUD == 'KHKO' .OR. CCLOUD == 'C2R2') THEN
+ ALLOCATE(XSUPSAT(IIU,IJU,IKU))
+ ALLOCATE(XNACT(IIU,IJU,IKU))
+ ALLOCATE(XNPRO(IIU,IJU,IKU))
+ ALLOCATE(XSSPRO(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XSUPSAT(0,0,0))
+ ALLOCATE(XNACT(0,0,0))
+ ALLOCATE(XNPRO(0,0,0))
+ ALLOCATE(XSSPRO(0,0,0))
+END IF
+!
+!* 3.12 Module MODD_TURB_CLOUD
+!
+IF (.NOT.(ALLOCATED(XCEI))) ALLOCATE(XCEI(0,0,0))
+IF (KMI == NMODEL_CLOUD .AND. CTURBLEN_CLOUD/='NONE' ) THEN
+ DEALLOCATE(XCEI)
+ ALLOCATE(XCEI(IIU,IJU,IKU))
+ENDIF
+!
+!* 3.13 Module MODD_CH_PH_n
+!
+IF (LUSECHAQ.AND.(CPROGRAM == 'DIAG '.OR.CPROGRAM == 'MESONH')) THEN
+ IF (LCH_PH) THEN
+ ALLOCATE(XPHC(IIU,IJU,IKU))
+ IF (NRRL==2) THEN
+ ALLOCATE(XPHR(IIU,IJU,IKU))
+ ALLOCATE(XACPHR(IIU,IJU))
+ XACPHR(:,:) = 0.
+ ENDIF
+ ENDIF
+ IF (NRRL==2) THEN
+ ALLOCATE(XACPRAQ(IIU,IJU,NSV_CHAC/2))
+ XACPRAQ(:,:,:) = 0.
+ ENDIF
+ENDIF
+IF (.NOT.(ASSOCIATED(XPHC))) ALLOCATE(XPHC(0,0,0))
+IF (.NOT.(ASSOCIATED(XPHR))) ALLOCATE(XPHR(0,0,0))
+IF (.NOT.(ASSOCIATED(XACPHR))) ALLOCATE(XACPHR(0,0))
+IF (.NOT.(ASSOCIATED(XACPRAQ))) ALLOCATE(XACPRAQ(0,0,0))
+IF ((LUSECHEM).AND.(CPROGRAM == 'DIAG ')) THEN
+ ALLOCATE(XCHFLX(IIU,IJU,NSV_CHEM))
+ XCHFLX(:,:,:) = 0.
+ELSE
+ ALLOCATE(XCHFLX(0,0,0))
+END IF
+!
+!* 3.14 Module MODD_DRAG
+!
+IF (LDRAG) THEN
+ ALLOCATE(XDRAG(IIU,IJU))
+ELSE
+ ALLOCATE(XDRAG(0,0))
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. INITIALIZE BUDGET VARIABLES
+! ---------------------------
+!
+IF ( CBUTYPE /= "NONE" .AND. NBUMOD == KMI ) THEN
+ CALL INI_BUDGET(ILUOUT,XTSTEP,NSV,NRR, &
+ LNUMDIFU,LNUMDIFTH,LNUMDIFSV, &
+ LHORELAX_UVWTH,LHORELAX_RV, LHORELAX_RC,LHORELAX_RR, &
+ LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, LHORELAX_RH,LHORELAX_TKE, &
+ LHORELAX_SV,LVE_RELAX,LCHTRANS,LNUDGING,LDRAGTREE,LDEPOTREE, &
+ CRAD,CDCONV,CSCONV,CTURB,CTURBDIM,CCLOUD )
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 5. INITIALIZE INTERPOLATION COEFFICIENTS
+!
+CALL INI_BIKHARDT_n (NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI),KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. BUILT THE GENERIC OUTPUT NAME
+! ----------------------------
+!
+IF (KMI == 1) THEN
+ DO IMI = 1 , NMODEL
+ WRITE(IO_SURF_MNH_MODEL(IMI)%COUTFILE,'(A,".",I1,".",A)') CEXP,IMI,TRIM(ADJUSTL(CSEG))
+ WRITE(YNAME, '(A,".",I1,".",A)') CEXP,IMI,TRIM(ADJUSTL(CSEG))//'.000'
+ CALL IO_File_add2list(LUNIT_MODEL(IMI)%TDIAFILE,YNAME,'MNHDIACHRONIC','WRITE', &
+ HDIRNAME=CIO_DIR, &
+ KLFINPRAR=INT(50,KIND=LFIINT),KLFITYPE=1,KLFIVERB=NVERB, &
+ TPDADFILE=LUNIT_MODEL(NDAD(IMI))%TDIAFILE )
+ END DO
+ !
+ TDIAFILE => LUNIT_MODEL(KMI)%TDIAFILE !Necessary because no call to GOTO_MODEL before needing it
+ !
+ IF (CPROGRAM=='MESONH') THEN
+ IF ( NDAD(KMI) == 1) CDAD_NAME(KMI) = CEXP//'.1.'//CSEG
+ IF ( NDAD(KMI) == 2) CDAD_NAME(KMI) = CEXP//'.2.'//CSEG
+ IF ( NDAD(KMI) == 3) CDAD_NAME(KMI) = CEXP//'.3.'//CSEG
+ IF ( NDAD(KMI) == 4) CDAD_NAME(KMI) = CEXP//'.4.'//CSEG
+ IF ( NDAD(KMI) == 5) CDAD_NAME(KMI) = CEXP//'.5.'//CSEG
+ IF ( NDAD(KMI) == 6) CDAD_NAME(KMI) = CEXP//'.6.'//CSEG
+ IF ( NDAD(KMI) == 7) CDAD_NAME(KMI) = CEXP//'.7.'//CSEG
+ IF ( NDAD(KMI) == 8) CDAD_NAME(KMI) = CEXP//'.8.'//CSEG
+ END IF
+ELSE
+ ALLOCATE(XUM(0,0,0))
+ ALLOCATE(XVM(0,0,0))
+ ALLOCATE(XWM(0,0,0))
+ ALLOCATE(XDUM(0,0,0))
+ ALLOCATE(XDVM(0,0,0))
+ ALLOCATE(XDWM(0,0,0))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. INITIALIZE GRIDS AND METRIC COEFFICIENTS
+! ----------------------------------------
+!
+CALL SET_GRID(KMI,TPINIFILE,IKU,NIMAX_ll,NJMAX_ll, &
+ XTSTEP,XSEGLEN, &
+ XLONORI,XLATORI,XLON,XLAT, &
+ XXHAT,XYHAT,XDXHAT,XDYHAT, XMAP, &
+ XZS,XZZ,XZHAT,XZTOP,LSLEVE,XLEN1,XLEN2,XZSMT, &
+ ZJ, &
+ TDTMOD,TDTCUR,NSTOP,NBAK_NUMB,NOUT_NUMB,TBACKUPN,TOUTPUTN)
+!
+CALL METRICS(XMAP,XDXHAT,XDYHAT,XZZ,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!* update halos of metric coefficients
+!
+!
+CALL UPDATE_METRICS(CLBCX,CLBCY,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!
+CALL SET_DIRCOS(CLBCX,CLBCY,XDXX,XDYY,XDZX,XDZY,TZINITHALO2D_ll, &
+ XDIRCOSXW,XDIRCOSYW,XDIRCOSZW,XCOSSLOPE,XSINSLOPE )
+!
+! grid nesting initializations
+IF ( KMI == 1 ) THEN
+ XTSTEP_MODEL1=XTSTEP
+END IF
+!
+NDT_2_WAY(KMI)=4
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. INITIALIZE DATA FOR JVALUES AND AEROSOLS
+!
+IF ( LUSECHEM .OR. LCHEMDIAG ) THEN
+ IF ((KMI==1).AND.(CPROGRAM == "MESONH".OR.CPROGRAM == "DIAG ")) &
+ CALL CH_INIT_JVALUES(TDTCUR%TDATE%DAY, TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%YEAR, ILUOUT, XCH_TUV_DOBNEW)
+!
+ IF (LORILAM) THEN
+ CALL CH_AER_MOD_INIT
+ ENDIF
+END IF
+IF (.NOT.(ASSOCIATED(XMI))) ALLOCATE(XMI(0,0,0,0))
+IF (.NOT.(ASSOCIATED(XSOLORG))) ALLOCATE(XSOLORG(0,0,0,0))
+!
+IF (CCLOUD=='LIMA') CALL INIT_AEROSOL_PROPERTIES
+!
+!-------------------------------------------------------------------------------
+!
+!* 9. INITIALIZE THE PROGNOSTIC FIELDS
+! --------------------------------
+!
+CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-before read_field::XUT",PRECISION)
+CALL READ_FIELD(TPINIFILE,IIU,IJU,IKU, &
+ CGETTKET,CGETRVT,CGETRCT,CGETRRT,CGETRIT,CGETCIT,CGETZWS, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,CGETSRCT,CGETSIGS,CGETCLDFR, &
+ CGETBL_DEPTH,CGETSBL_DEPTH,CGETPHC,CGETPHR,CUVW_ADV_SCHEME, &
+ CTEMP_SCHEME,NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll,&
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XUM,XVM,XWM,XDUM,XDVM,XDWM, &
+ XUT,XVT,XWT,XTHT,XPABST,XTKET,XRTKEMS, &
+ XRT,XSVT,XZWS,XCIT,XDRYMASST, &
+ XSIGS,XSRCT,XCLDFR,XBL_DEPTH,XSBL_DEPTH,XWTHVMF,XPHC,XPHR, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM, &
+ XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM, &
+ XLBYRM,XLBYSVM, &
+ NFRC,TDTFRC,XUFRC,XVFRC,XWFRC,XTHFRC,XRVFRC, &
+ XTENDTHFRC,XTENDRVFRC,XGXTHFRC,XGYTHFRC, &
+ XPGROUNDFRC, XATC, &
+ XTENDUFRC, XTENDVFRC, &
+ NADVFRC,TDTADVFRC,XDTHFRC,XDRVFRC, &
+ NRELFRC,TDTRELFRC,XTHREL,XRVREL, &
+ XVTH_FLUX_M,XWTH_FLUX_M,XVU_FLUX_M, &
+ XRUS_PRES,XRVS_PRES,XRWS_PRES,XRTHS_CLD,XRRS_CLD,XRSVS_CLD )
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 10. INITIALIZE REFERENCE STATE
+! ---------------------------
+!
+!
+CALL SET_REF(KMI,TPINIFILE, &
+ XZZ,XZHAT,ZJ,XDXX,XDYY,CLBCX,CLBCY, &
+ XREFMASS,XMASS_O_PHI0,XLINMASS, &
+ XRHODREF,XTHVREF,XRVREF,XEXNREF,XRHODJ )
+!
+!-------------------------------------------------------------------------------
+!
+!* 10.1 INITIALIZE THE TURBULENCE VARIABLES
+! -----------------------------------
+!
+IF ((CTURB == 'TKEL').AND.(CCONF=='START')) THEN
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-before ini_tke_eps::XUT",PRECISION)
+ CALL INI_TKE_EPS(CGETTKET,XTHVREF,XZZ, &
+ XUT,XVT,XTHT, &
+ XTKET,TZINITHALO3D_ll )
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-after ini_tke_eps::XUT",PRECISION)
+END IF
+!
+!
+!* 10.2 INITIALIZE THE LES VARIABLES
+! ----------------------------
+!
+CALL INI_LES_n
+!
+!-------------------------------------------------------------------------------
+!
+!* 11. INITIALIZE THE SOURCE OF TOTAL DRY MASS Md
+! ------------------------------------------
+!
+IF((KMI==1).AND.LSTEADYLS) THEN
+ XDRYMASSS = 0.
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 12. INITIALIZE THE MICROPHYSICS
+! ----------------------------
+!
+IF (CELEC == 'NONE') THEN
+ CALL INI_MICRO_n(TPINIFILE,ILUOUT)
+!
+!-------------------------------------------------------------------------------
+!
+!* 13. INITIALIZE THE ATMOSPHERIC ELECTRICITY
+! --------------------------------------
+!
+ELSE
+ CALL INI_ELEC_n(ILUOUT, CELEC, CCLOUD, TPINIFILE, &
+ XTSTEP, XZZ, &
+ XDXX, XDYY, XDZZ, XDZX, XDZY )
+!
+ WRITE (UNIT=ILUOUT,&
+ FMT='(/,"ELECTRIC VARIABLES ARE BETWEEN INDEX",I2," AND ",I2)')&
+ NSV_ELECBEG, NSV_ELECEND
+!
+ IF( CGETSVT(NSV_ELECBEG)=='INIT' ) THEN
+ XSVT(:,:,:,NSV_ELECBEG) = XCION_POS_FW(:,:,:) ! Nb/kg
+ XSVT(:,:,:,NSV_ELECEND) = XCION_NEG_FW(:,:,:)
+!
+ XSVT(:,:,:,NSV_ELECBEG+1:NSV_ELECEND-1) = 0.0
+ ELSE ! Convert elec_variables per m3 into elec_variables per kg of air
+ DO JSV = NSV_ELECBEG, NSV_ELECEND
+ XSVT(:,:,:,JSV) = XSVT(:,:,:,JSV) / XRHODREF(:,:,:)
+ ENDDO
+ END IF
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 14. INITIALIZE THE LARGE SCALE SOURCES
+! ----------------------------------
+!
+IF ((KMI==1).AND.(.NOT. LSTEADYLS)) THEN
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-before ini_cpl::XUT",PRECISION)
+ CALL INI_CPL(NSTOP,XTSTEP,LSTEADYLS,CCONF, &
+ CGETTKET, &
+ CGETRVT,CGETRCT,CGETRRT,CGETRIT, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, &
+ NSV,NIMAX_ll,NJMAX_ll, &
+ NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, &
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS )
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-after ini_cpl::XUT",PRECISION)
+!
+ DO JSV=NSV_CHEMBEG,NSV_CHEMEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_LNOXBEG,NSV_LNOXEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_AERBEG,NSV_AEREND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTBEG,NSV_DSTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTDEPBEG,NSV_DSTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTBEG,NSV_SLTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTDEPBEG,NSV_SLTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_PPBEG,NSV_PPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#ifdef MNH_FOREFIRE
+ DO JSV=NSV_FFBEG,NSV_FFEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#endif
+ DO JSV=NSV_CSBEG,NSV_CSEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+!
+END IF
+ALLOCATE(XLSZWSM(IIU,IJU)) ; XLSZWSM = -1.
+!
+IF ( KMI > 1) THEN
+ ! Use dummy pointers to correct an ifort BUG
+ DPTR_XBMX1=>XBMX1
+ DPTR_XBMX2=>XBMX2
+ DPTR_XBMX3=>XBMX3
+ DPTR_XBMX4=>XBMX4
+ DPTR_XBMY1=>XBMY1
+ DPTR_XBMY2=>XBMY2
+ DPTR_XBMY3=>XBMY3
+ DPTR_XBMY4=>XBMY4
+ DPTR_XBFX1=>XBFX1
+ DPTR_XBFX2=>XBFX2
+ DPTR_XBFX3=>XBFX3
+ DPTR_XBFX4=>XBFX4
+ DPTR_XBFY1=>XBFY1
+ DPTR_XBFY2=>XBFY2
+ DPTR_XBFY3=>XBFY3
+ DPTR_XBFY4=>XBFY4
+ DPTR_CLBCX=>CLBCX
+ DPTR_CLBCY=>CLBCY
+ !
+ DPTR_XZZ=>XZZ
+ DPTR_XZHAT=>XZHAT
+ DPTR_XLSUM=>XLSUM
+ DPTR_XLSVM=>XLSVM
+ DPTR_XLSWM=>XLSWM
+ DPTR_XLSTHM=>XLSTHM
+ DPTR_XLSRVM=>XLSRVM
+ DPTR_XLSZWSM=>XLSZWSM
+ DPTR_XLSUS=>XLSUS
+ DPTR_XLSVS=>XLSVS
+ DPTR_XLSWS=>XLSWS
+ DPTR_XLSTHS=>XLSTHS
+ DPTR_XLSRVS=>XLSRVS
+ DPTR_XLSZWSS=>XLSZWSS
+ !
+ DPTR_NKLIN_LBXU=>NKLIN_LBXU
+ DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU
+ DPTR_NKLIN_LBYU=>NKLIN_LBYU
+ DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU
+ DPTR_NKLIN_LBXV=>NKLIN_LBXV
+ DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV
+ DPTR_NKLIN_LBYV=>NKLIN_LBYV
+ DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV
+ DPTR_NKLIN_LBXW=>NKLIN_LBXW
+ DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW
+ DPTR_NKLIN_LBYW=>NKLIN_LBYW
+ DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW
+ DPTR_NKLIN_LBXM=>NKLIN_LBXM
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_NKLIN_LBYM=>NKLIN_LBYM
+ DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM
+ !
+ CALL INI_SPAWN_LS_n(NDAD(KMI),XTSTEP,KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT, &
+ LSLEVE,XLEN1,XLEN2, &
+ DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSZWSM, &
+ DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSZWSS, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM )
+ !
+ DPTR_XLBXUM=>XLBXUM
+ DPTR_XLBYUM=>XLBYUM
+ DPTR_XLBXVM=>XLBXVM
+ DPTR_XLBYVM=>XLBYVM
+ DPTR_XLBXWM=>XLBXWM
+ DPTR_XLBYWM=>XLBYWM
+ DPTR_XLBXTHM=>XLBXTHM
+ DPTR_XLBYTHM=>XLBYTHM
+ DPTR_XLBXTKEM=>XLBXTKEM
+ DPTR_XLBYTKEM=>XLBYTKEM
+ DPTR_XLBXRM=>XLBXRM
+ DPTR_XLBYRM=>XLBYRM
+ DPTR_XLBXSVM=>XLBXSVM
+ DPTR_XLBYSVM=>XLBYSVM
+ CALL INI_ONE_WAY_n(NDAD(KMI),KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, &
+ CCLOUD, LUSECHAQ, LUSECHIC, &
+ DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, &
+ DPTR_XLBXTHM,DPTR_XLBYTHM, &
+ DPTR_XLBXTKEM,DPTR_XLBYTKEM, &
+ DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM )
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 15. INITIALIZE THE SCALAR VARIABLES
+! -------------------------------
+!
+IF (LLG .AND. LINIT_LG .AND. CPROGRAM=='MESONH') &
+ CALL INI_LG(XXHAT,XYHAT,XZZ,XSVT,XLBXSVM,XLBYSVM)
+
+!
+!-------------------------------------------------------------------------------
+!
+!* 16. INITIALIZE THE PARAMETERS FOR THE DYNAMICS
+! ------------------------------------------
+!
+CALL INI_DYNAMICS(XLON,XLAT,XRHODJ,XTHVREF,XMAP,XZZ,XDXHAT,XDYHAT, &
+ XZHAT,CLBCX,CLBCY,XTSTEP,CPRESOPT, &
+ LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV, &
+ LHORELAX_RC,LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, &
+ LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, &
+ LHORELAX_SVC2R2,LHORELAX_SVC1R3,LHORELAX_SVELEC,LHORELAX_SVLG, &
+ LHORELAX_SVCHEM,LHORELAX_SVAER,LHORELAX_SVDST,LHORELAX_SVSLT, &
+ LHORELAX_SVPP,LHORELAX_SVCS,LHORELAX_SVCHIC,LHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF, &
+#endif
+ XRIMKMAX,NRIMX,NRIMY, &
+ XALKTOP,XALKGRD,XALZBOT,XALZBAS, &
+ XT4DIFU,XT4DIFTH,XT4DIFSV, &
+ XCORIOX,XCORIOY,XCORIOZ,XCURVX,XCURVY, &
+ XDXHATM,XDYHATM,XRHOM,XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY,&
+ XALK,XALKW,NALBOT,XALKBAS,XALKWBAS,NALBAS, &
+ LMASK_RELAX,XKURELAX,XKVRELAX,XKWRELAX, &
+ XDK2U,XDK4U,XDK2TH,XDK4TH,XDK2SV,XDK4SV, &
+ LZDIFFU,XZDIFFU_HALO2, &
+ XBFB,XBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K )
+!
+!
+!* 16.1 Initialize the XDRAG array
+! -------------
+IF (LDRAG) THEN
+ CALL INI_DRAG(LMOUNT,XZS,XHSTART,NSTART,XDRAG)
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 17. SURFACE FIELDS
+! --------------
+!
+!* 17.1 Radiative setup
+! ---------------
+!
+IF (CRAD /= 'NONE') THEN
+ IF (CGETRAD =='INIT') THEN
+ GINIRAD =.TRUE.
+ ELSE
+ GINIRAD =.FALSE.
+ END IF
+ CALL INI_RADIATIONS(TPINIFILE,GINIRAD,TDTCUR,TDTEXP,XZZ, &
+ XDXX, XDYY, &
+ XSINDEL,XCOSDEL,XTSIDER,XCORSOL, &
+ XSLOPANG,XSLOPAZI, &
+ XDTHRAD,XDIRFLASWD,XSCAFLASWD, &
+ XFLALWD,XDIRSRFSWD,NCLEARCOL_TM1, &
+ XZENITH,XAZIM, &
+ TDTRAD_FULL,TDTRAD_CLONLY, &
+ TZINITHALO2D_ll, &
+ XRADEFF,XSWU,XSWD,XLWU, &
+ XLWD,XDTHRADSW,XDTHRADLW )
+ !
+ IF (GINIRAD) CALL SUNPOS_n(XZENITH,PAZIMSOL=XAZIM)
+ CALL SURF_SOLAR_GEOM (XZS, XZS_XY)
+ !
+ ALLOCATE(XXHAT_ll (IIU_ll))
+ ALLOCATE(XYHAT_ll (IJU_ll))
+ ALLOCATE(XZS_ll (IIU_ll,IJU_ll))
+ ALLOCATE(XZS_XY_ll (IIU_ll,IJU_ll))
+ !
+ CALL GATHERALL_FIELD_ll('XY',XZS,XZS_ll,IRESP)
+ CALL GATHERALL_FIELD_ll('XY',XZS_XY,XZS_XY_ll,IRESP)
+ CALL GATHERALL_FIELD_ll('XX',XXHAT,XXHAT_ll,IRESP)
+ CALL GATHERALL_FIELD_ll('YY',XYHAT,XYHAT_ll,IRESP)
+ XZS_MAX_ll=MAXVAL(XZS_ll)
+ELSE
+ XAZIM = XPI
+ XZENITH = XPI/2.
+ XDIRSRFSWD = 0.
+ XSCAFLASWD = 0.
+ XFLALWD = 300. ! W/m2
+ XTSIDER = 0.
+END IF
+!
+!
+CALL INI_SW_SETUP (CRAD,NSWB_MNH,XSW_BANDS)
+CALL INI_LW_SETUP (CRAD,NLWB_MNH,XLW_BANDS)
+!
+!
+! 17.1.1 Special initialisation for CO2 content
+! CO2 (molar mass=44) horizontally and vertically homogeneous at 360 ppm
+!
+XCCO2 = 360.0E-06 * 44.0E-03 / XMD
+#ifdef MNH_ECRAD
+RCCO2 = 360.0E-06 * 44.0E-03 / XMD
+#endif
+!
+!
+!* 17.2 Externalized surface fields
+! ---------------------------
+!
+ALLOCATE(ZCO2(IIU,IJU))
+ZCO2(:,:) = XCCO2
+!
+
+ALLOCATE(ZDIR_ALB(IIU,IJU,NSWB_MNH))
+ALLOCATE(ZSCA_ALB(IIU,IJU,NSWB_MNH))
+ALLOCATE(ZEMIS (IIU,IJU,NLWB_MNH))
+ALLOCATE(ZTSRAD (IIU,IJU))
+!
+IF ((TPINIFILE%NMNHVERSION(1)==4 .AND. TPINIFILE%NMNHVERSION(2)>=6) .OR. TPINIFILE%NMNHVERSION(1)>4) THEN
+ CALL IO_Field_read(TPINIFILE,'SURF',CSURF)
+ELSE
+ CSURF = "EXTE"
+END IF
+!
+!
+IF (CSURF=='EXTE' .AND. (CPROGRAM=='MESONH' .OR. CPROGRAM=='DIAG ')) THEN
+ ! ouverture du fichier PGD
+ IF ( LEN_TRIM(CINIFILEPGD) > 0 ) THEN
+ CALL IO_File_add2list(TINIFILEPGD,TRIM(CINIFILEPGD),'PGD','READ',KLFITYPE=2,KLFIVERB=NVERB)
+ CALL IO_File_open(TINIFILEPGD,KRESP=IRESP)
+ LUNIT_MODEL(KMI)%TINIFILEPGD => TINIFILEPGD
+ IF (IRESP/=0) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ERROR TO OPEN THE FILE CINIFILEPGD=",CINIFILEPGD
+ WRITE(ILUOUT,FMT=*) "CHECK YOUR NAMELIST NAM_LUNITn"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ ENDIF
+ ELSE
+ ! case after a spawning
+ CINIFILEPGD = TPINIFILE%CNAME
+ END IF
+ !
+ CALL GOTO_SURFEX(KMI)
+#ifdef CPLOASIS
+ CALL SFX_OASIS_READ_NAM(CPROGRAM,XTSTEP)
+ WRITE(*,*) 'SFX-OASIS: READ NAM_SFX_SEA_CPL OK'
+#endif
+ !* initialization of surface
+ CALL INIT_GROUND_PARAM_n ('ALL',SIZE(CSV),CSV,ZCO2, &
+ XZENITH,XAZIM,XSW_BANDS,XLW_BANDS,ZDIR_ALB,ZSCA_ALB, &
+ ZEMIS,ZTSRAD )
+ !
+ IF (SIZE(XEMIS)>0) THEN
+ XDIR_ALB = ZDIR_ALB
+ XSCA_ALB = ZSCA_ALB
+ XEMIS = ZEMIS
+ XTSRAD = ZTSRAD
+ CALL MNHGET_SURF_PARAM_n (PSEA=XSEA)
+ END IF
+ELSE
+ !* fields not physically necessary, but must be initialized
+ IF (SIZE(XEMIS)>0) THEN
+ XDIR_ALB = 0.
+ XSCA_ALB = 0.
+ XEMIS = 1.
+ XTSRAD = XTT
+ XSEA = 1.
+ END IF
+
+END IF
+IF (CSURF=='EXTE' .AND. (CPROGRAM=='SPAWN ')) THEN
+ ! ouverture du fichier PGD
+ CALL IO_File_add2list(TINIFILEPGD,TRIM(CINIFILEPGD),'PGD','READ',KLFITYPE=2,KLFIVERB=NVERB)
+ CALL IO_File_open(TINIFILEPGD,KRESP=IRESP)
+ LUNIT_MODEL(KMI)%TINIFILEPGD => TINIFILEPGD
+ IF (IRESP/=0) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ERROR TO OPEN THE FILE CINIFILEPGD=",CINIFILEPGD
+ WRITE(ILUOUT,FMT=*) "CHECK YOUR NAMELIST NAM_LUNIT2_SPA"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ ENDIF
+ENDIF
+!
+IF (.NOT.ASSOCIATED(TINIFILEPGD)) TINIFILEPGD => TFILE_DUMMY
+!
+ !* special case after spawning in prep_real_case
+IF (CSURF=='EXRM' .AND. CPROGRAM=='REAL ') CSURF = 'EXTE'
+!
+DEALLOCATE(ZDIR_ALB)
+DEALLOCATE(ZSCA_ALB)
+DEALLOCATE(ZEMIS )
+DEALLOCATE(ZTSRAD )
+!
+DEALLOCATE(ZCO2)
+!
+!
+!* in a RESTART case, reads surface radiative quantities in the MESONH file
+!
+IF ((CRAD == 'ECMW' .OR. CRAD == 'ECRA') .AND. CGETRAD=='READ') THEN
+ CALL INI_SURF_RAD(TPINIFILE, XDIR_ALB, XSCA_ALB, XEMIS, XTSRAD)
+END IF
+!
+!
+!* 17.3 Mesonh fields
+! -------------
+!
+IF (CPROGRAM/='REAL ') CALL MNHREAD_ZS_DUMMY_n(TINIFILEPGD)
+!
+!-------------------------------------------------------------------------------
+!
+!* 18. INITIALIZE THE PARAMETERS FOR THE PHYSICS
+! -----------------------------------------
+!
+IF (CRAD == 'ECMW') THEN
+!
+!* get cover mask for aerosols
+!
+ IF (CPROGRAM=='MESONH' .OR. CPROGRAM=='DIAG ') THEN
+ ALLOCATE(ZSEA(IIU,IJU))
+ ALLOCATE(ZTOWN(IIU,IJU))
+ ALLOCATE(ZBARE(IIU,IJU))
+ IF (CSURF=='EXTE') THEN
+ CALL GOTO_SURFEX(KMI)
+ CALL MNHGET_SURF_PARAM_n(PSEA=ZSEA,PTOWN=ZTOWN,PBARE=ZBARE)
+ ELSE
+ ZSEA (:,:) = 1.
+ ZTOWN(:,:) = 0.
+ ZBARE(:,:) = 0.
+ END IF
+!
+ IF ( CAOP=='EXPL' .AND. LDUST ) THEN
+ ALLOCATE( XEXT_COEFF_WVL_LKT_DUST( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST, NMAX_WVL_SW_DUST ) )
+ ALLOCATE( XEXT_COEFF_550_LKT_DUST( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST ) )
+ ALLOCATE( XPIZA_LKT_DUST ( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST, NMAX_WVL_SW_DUST ) )
+ ALLOCATE( XCGA_LKT_DUST ( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST, NMAX_WVL_SW_DUST ) )
+ END IF
+!
+ IF ( CAOP=='EXPL' .AND. LSALT ) THEN
+ ALLOCATE( XEXT_COEFF_WVL_LKT_SALT( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT, NMAX_WVL_SW_SALT ) )
+ ALLOCATE( XEXT_COEFF_550_LKT_SALT( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT ) )
+ ALLOCATE( XPIZA_LKT_SALT ( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT, NMAX_WVL_SW_SALT ) )
+ ALLOCATE( XCGA_LKT_SALT ( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT, NMAX_WVL_SW_SALT ) )
+ END IF
+!
+ CALL INI_RADIATIONS_ECMWF (XZHAT,XPABST,XTHT,XTSRAD,XLAT,XLON,TDTCUR,TDTEXP, &
+ CLW,NDLON,NFLEV,NFLUX,NRAD,NSWB_OLD,CAER,NAER,NSTATM, &
+ XSTATM,ZSEA,ZTOWN,ZBARE,XOZON, XAER,XDST_WL, LSUBG_COND )
+!
+ DEALLOCATE(ZSEA,ZTOWN,ZBARE)
+ ALLOCATE (XAER_CLIM(SIZE(XAER,1),SIZE(XAER,2),SIZE(XAER,3),SIZE(XAER,4)))
+ XAER_CLIM(:,:,:,:) =XAER(:,:,:,:)
+!
+ END IF
+
+ELSE IF (CRAD == 'ECRA') THEN
+#ifdef MNH_ECRAD
+!* get cover mask for aerosols
+!
+ IF (CPROGRAM=='MESONH' .OR. CPROGRAM=='DIAG ') THEN
+ ALLOCATE(ZSEA(IIU,IJU))
+ ALLOCATE(ZTOWN(IIU,IJU))
+ ALLOCATE(ZBARE(IIU,IJU))
+ IF (CSURF=='EXTE') THEN
+ CALL GOTO_SURFEX(KMI)
+ CALL MNHGET_SURF_PARAM_n(PSEA=ZSEA,PTOWN=ZTOWN,PBARE=ZBARE)
+ ELSE
+ ZSEA (:,:) = 1.
+ ZTOWN(:,:) = 0.
+ ZBARE(:,:) = 0.
+ END IF
+!
+ CALL INI_RADIATIONS_ECRAD (XZHAT,XPABST,XTHT,XTSRAD,XLAT,XLON,TDTCUR,TDTEXP, &
+ CLW,NDLON,NFLEV,NFLUX,NRAD,NSWB_OLD,CAER,NAER,NSTATM, &
+ XSTATM,ZSEA,ZTOWN,ZBARE,XOZON, XAER,XDST_WL, LSUBG_COND )
+
+ DEALLOCATE(ZSEA,ZTOWN,ZBARE)
+ ALLOCATE (XAER_CLIM(SIZE(XAER,1),SIZE(XAER,2),SIZE(XAER,3),SIZE(XAER,4)))
+ XAER_CLIM(:,:,:,:) = XAER(:,:,:,:)
+!
+ END IF
+#endif
+ELSE
+ ALLOCATE (XOZON(0,0,0))
+ ALLOCATE (XAER(0,0,0,0))
+ ALLOCATE (XDST_WL(0,0,0,0))
+ ALLOCATE (XAER_CLIM(0,0,0,0))
+END IF
+!
+!
+!
+IF (CDCONV /= 'NONE' .OR. CSCONV == 'KAFR') THEN
+ IF (CGETCONV=='INIT') THEN
+ GINIDCONV=.TRUE.
+ ELSE
+ GINIDCONV=.FALSE.
+ END IF
+!
+! commensurability between convection calling time and time step
+!
+ XDTCONV=XTSTEP*REAL( INT( (MIN(XDTCONV,1800.)+1.E-10)/XTSTEP ) )
+ XDTCONV=MAX( XDTCONV, XTSTEP )
+ IF (NVERB>=10) THEN
+ WRITE(ILUOUT,*) 'XDTCONV has been set to : ',XDTCONV
+ END IF
+ CALL INI_DEEP_CONVECTION (TPINIFILE,GINIDCONV,TDTCUR, &
+ NCOUNTCONV,XDTHCONV,XDRVCONV,XDRCCONV, &
+ XDRICONV,XPRCONV,XPRSCONV,XPACCONV, &
+ XUMFCONV,XDMFCONV,XMFCONV,XPRLFLXCONV,XPRSFLXCONV,&
+ XCAPE,NCLTOPCONV,NCLBASCONV, &
+ TDTDCONV, CGETSVCONV, XDSVCONV, &
+ LCH_CONV_LINOX, XIC_RATE, XCG_RATE, &
+ XIC_TOTAL_NUMBER, XCG_TOTAL_NUMBER )
+
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 19. ALLOCATION OF THE TEMPORAL SERIES
+! ---------------------------------
+!
+IF (LSERIES .AND. CPROGRAM/='DIAG ') CALL INI_SERIES_n
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 20. (re)initialize scalar variables
+! -------------------------------
+!
+!
+IF ( LUSECHEM .OR. LCHEMDIAG ) THEN
+ IF (CPROGRAM=='MESONH'.AND.CCONF=='RESTA') LCH_INIT_FIELD =.FALSE.
+ IF (CPROGRAM=='MESONH'.OR. CPROGRAM=='DIAG ' .OR. CPROGRAM=='IDEAL ') &
+ CALL CH_INIT_FIELD_n(KMI, ILUOUT, NVERB)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. UPDATE HALO
+! -----------
+!
+!
+CALL UPDATE_HALO_ll(TZINITHALO3D_ll,IINFO_ll)
+CALL UPDATE_HALO_ll(TZINITHALO2D_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZINITHALO3D_ll)
+CALL CLEANLIST_ll(TZINITHALO2D_ll)
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 22. DEALLOCATION
+! -------------
+!
+DEALLOCATE(ZJ)
+!
+DEALLOCATE(XSTROATM)
+DEALLOCATE(XSMLSATM)
+DEALLOCATE(XSMLWATM)
+DEALLOCATE(XSPOSATM)
+DEALLOCATE(XSPOWATM)
+!
+!-------------------------------------------------------------------------------
+!
+!* 23. BALLOON and AIRCRAFT initializations
+! ------------------------------------
+!
+CALL INI_AIRCRAFT_BALLOON(TPINIFILE,XTSTEP, TDTSEG, XSEGLEN, NRR, NSV, &
+ IKU,CTURB=="TKEL" , &
+ XLATORI, XLONORI )
+!
+!-------------------------------------------------------------------------------
+!
+!* 24. STATION initializations
+! -----------------------
+!
+CALL INI_SURFSTATION_n(XTSTEP, TDTSEG, XSEGLEN, NRR, NSV, &
+ CTURB=="TKEL" , &
+ XLATORI, XLONORI )
+!
+!-------------------------------------------------------------------------------
+!
+!* 25. PROFILER initializations
+! ------------------------
+!
+CALL INI_POSPROFILER_n(XTSTEP, TDTSEG, XSEGLEN, NRR, NSV, &
+ CTURB=="TKEL", &
+ XLATORI, XLONORI )
+!
+!-------------------------------------------------------------------------------
+!
+!* 26. Prognostic aerosols
+! ------------------------
+!
+IF ( ( CRAD=='ECMW' .OR. CRAD=='ECRA' ) .AND. CAOP=='EXPL' .AND. LORILAM ) THEN
+ ALLOCATE(POLYTAU(6,10,8,6,13))
+ ALLOCATE(POLYSSA(6,10,8,6,13))
+ ALLOCATE(POLYG (6,10,8,6,13))
+ CALL INI_AEROSET1
+ CALL INI_AEROSET2
+ CALL INI_AEROSET3
+ CALL INI_AEROSET4
+ CALL INI_AEROSET5
+ CALL INI_AEROSET6
+END IF
+#ifdef MNH_FOREFIRE
+!
+!-------------------------------------------------------------------------------
+!
+!* 27. FOREFIRE initializations
+! ------------------------
+!
+
+! Coupling with ForeFire if resolution is low enough
+!---------------------------------------------------
+IF ( LFOREFIRE .AND. 0.5*(XXHAT(2)-XXHAT(1)+XYHAT(2)-XYHAT(1)) < COUPLINGRES ) THEN
+ FFCOUPLING = .TRUE.
+ELSE
+ FFCOUPLING = .FALSE.
+ENDIF
+
+! Initializing the ForeFire variables
+!------------------------------------
+IF ( LFOREFIRE ) THEN
+ CALL INIT_FOREFIRE_n(KMI, ILUOUT, IP &
+ , TDTCUR%TDATE%YEAR, TDTCUR%TDATE%MONTH, TDTCUR%TDATE%DAY, TDTCUR%TIME, XTSTEP)
+END IF
+#endif
+
+!-------------------------------------------------------------------------------
+!
+!* 30. Total production/Loss for chemical species
+!
+IF (LCHEMDIAG) THEN
+ CALL CH_INIT_PRODLOSSTOT_n(ILUOUT)
+ IF (NEQ_PLT>0) THEN
+ ALLOCATE(XPROD(IIU,IJU,IKU,NEQ_PLT))
+ ALLOCATE(XLOSS(IIU,IJU,IKU,NEQ_PLT))
+ XPROD=0.0
+ XLOSS=0.0
+ ELSE
+ ALLOCATE(XPROD(0,0,0,0))
+ ALLOCATE(XLOSS(0,0,0,0))
+ END IF
+ELSE
+ ALLOCATE(XPROD(0,0,0,0))
+ ALLOCATE(XLOSS(0,0,0,0))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 31. Extended production/loss terms for chemical species
+!
+IF (LCHEMDIAG) THEN
+ CALL CH_INIT_BUDGET_n(ILUOUT)
+ IF (NEQ_BUDGET>0) THEN
+ ALLOCATE(IINDEX(2,NNONZEROTERMS))
+ ALLOCATE(IIND(NEQ_BUDGET))
+ CALL CH_NONZEROTERMS(KMI,IINDEX,NNONZEROTERMS)
+ ALLOCATE(XTCHEM(NEQ_BUDGET))
+ DO JM=1,NEQ_BUDGET
+ IIND(JM)=COUNT((IINDEX(1,:))==NSPEC_BUDGET(JM))
+ ALLOCATE(XTCHEM(JM)%NB_REAC(IIND(JM)))
+ ALLOCATE(XTCHEM(JM)%XB_REAC(IIU,IJU,IKU,IIND(JM)))
+ END DO
+ DEALLOCATE(IIND)
+ DEALLOCATE(IINDEX)
+ ELSE
+ ALLOCATE(XTCHEM(0))
+ END IF
+ELSE
+ ALLOCATE(XTCHEM(0))
+END IF
+
+END SUBROUTINE INI_MODEL_n
+
diff --git a/src/ZSOLVER/ini_spectren.f90 b/src/ZSOLVER/ini_spectren.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4783443207ecf52aa183b97da09c2f4014f94b58
--- /dev/null
+++ b/src/ZSOLVER/ini_spectren.f90
@@ -0,0 +1,941 @@
+!MNH_LIC Copyright 2015-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! #######################
+ MODULE MODI_INI_SPECTRE_n
+! #######################
+!
+INTERFACE
+!
+ SUBROUTINE INI_SPECTRE_n(KMI,TPINIFILE)
+!
+ USE MODD_IO, ONLY: TFILEDATA
+!
+ INTEGER, INTENT(IN) :: KMI ! Model index
+ TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+END SUBROUTINE INI_SPECTRE_n
+!
+END INTERFACE
+!
+END MODULE MODI_INI_SPECTRE_n
+! #######################################
+ SUBROUTINE INI_SPECTRE_n(KMI,TPINIFILE)
+! #######################################
+!
+!!**** *INI_SPECTRE_n* - routine to initialize SPECTRE (based on ini_modeln.f90)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.P Chaboureau * L.A*
+!! 10/2016 (C.Lac) Cleaning of the modules
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+! P. Wautelet 08/02/2019: allocate to zero-size non associated pointers
+! P. Wautelet 14/02/2019: remove CLUOUT/CLUOUT0 and associated variables
+! S. Bielli 02/2019: sea salt: significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 19/04/2019: removed unused dummy arguments and variables
+!
+!---------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ADV_n
+USE MODD_ARGSLIST_ll, ONLY: LIST_ll
+USE MODD_BIKHARDT_n
+USE MODD_BUDGET
+USE MODD_CH_MNHC_n, ONLY: LUSECHAQ, LUSECHIC, LCH_INIT_FIELD
+USE MODD_CH_PH_n
+USE MODD_CLOUD_MF_n
+USE MODD_CST
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CTURB
+USE MODD_CURVCOR_n
+USE MODD_DEEP_CONVECTION_n
+USE MODD_DIM_n
+USE MODD_DRAGTREE
+USE MODD_DUST
+USE MODD_DYN
+USE MODD_DYN_n
+USE MODD_DYNZD
+USE MODD_DYNZD_n
+USE MODD_FIELD_n
+USE MODD_FRC
+USE MODD_FRC_n
+USE MODD_GET_n
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_GRID_n
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LBC_n, only: CLBCX, CLBCY
+USE MODD_LSFIELD_n
+USE MODD_LUNIT_n, ONLY: COUTFILE, TLUOUT
+USE MODD_MEAN_FIELD
+USE MODD_MEAN_FIELD_n
+USE MODD_METRICS_n
+USE MODD_NESTING, only: NDAD, NDT_2_WAY, NDXRATIO_ALL, NDYRATIO_ALL
+USE MODD_NSV
+USE MODD_OUT_n
+USE MODD_PARAMETERS
+USE MODD_PARAM_KAFR_n
+USE MODD_PARAM_MFSHALL_n
+USE MODD_PARAM_n
+USE MODD_PASPOL
+USE MODD_PASPOL_n
+USE MODD_BLOWSNOW
+USE MODD_BLOWSNOW_n
+USE MODD_PAST_FIELD_n
+USE MODD_RADIATIONS_n
+USE MODD_REF
+USE MODD_REF_n
+USE MODD_SHADOWS_n
+USE MODD_SPECTRE
+USE MODD_TIME
+USE MODD_TIME_n
+USE MODD_TURB_n
+USE MODD_VAR_ll, ONLY: IP
+!
+USE MODE_GATHER_ll
+USE MODE_INI_ONE_WAY_n
+USE MODE_IO_FIELD_READ, only: IO_Field_read
+USE MODE_ll
+USE MODE_MODELN_HANDLER
+USE MODE_MSG
+USE MODE_SPLITTINGZ_ll, ONLY: GET_DIM_EXTZ_ll
+USE MODE_TYPE_ZDIFFU
+!
+USE MODI_INI_BIKHARDT_n
+USE MODI_INI_CPL
+USE MODI_INI_DYNAMICS
+USE MODI_INI_SPAWN_LS_n
+USE MODI_GET_SIZEX_LB
+USE MODI_GET_SIZEY_LB
+USE MODI_SET_GRID
+USE MODI_METRICS
+USE MODI_SET_REF
+USE MODI_UPDATE_METRICS
+USE MODI_UPDATE_NSV
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILUOUT ! Logical unit number of output-listing
+INTEGER :: IIU ! Upper dimension in x direction (local)
+INTEGER :: IJU ! Upper dimension in y direction (local)
+INTEGER :: IIU_ll ! Upper dimension in x direction (global)
+INTEGER :: IJU_ll ! Upper dimension in y direction (global)
+INTEGER :: IKU ! Upper dimension in z direction
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ ! Jacobian
+!
+!
+TYPE(LIST_ll), POINTER :: TZINITHALO2D_ll ! pointer for the list of 2D fields
+ ! which must be communicated in INIT
+TYPE(LIST_ll), POINTER :: TZINITHALO3D_ll ! pointer for the list of 3D fields
+ ! which must be communicated in INIT
+!
+INTEGER :: IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU ! dimensions of the
+INTEGER :: IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2 ! West-east LB arrays
+INTEGER :: IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV ! dimensions of the
+INTEGER :: IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2 ! North-south LB arrays
+INTEGER :: IINFO_ll ! Return code of //routines
+INTEGER :: IIY,IJY
+INTEGER :: IIU_B,IJU_B
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll
+!
+!------------------------------------------
+! Dummy pointers needed to correct an ifort Bug
+REAL, DIMENSION(:), POINTER :: DPTR_XZHAT
+REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSS,DPTR_XLSZWSM
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. PROLOGUE
+! --------
+!
+NULLIFY(TZINITHALO2D_ll)
+NULLIFY(TZINITHALO3D_ll)
+!
+!* 1. RETRIEVE LOGICAL UNIT NUMBER
+! ----------------------------
+!
+ILUOUT = TLUOUT%NLU
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. END OF READING
+! --------------
+!* 2.1 Read number of forcing fields
+!
+!* 2.2 Checks the position of vertical absorbing layer
+!
+IKU=NKMAX+2*JPVEXT
+!
+ALLOCATE(XZHAT(IKU))
+CALL IO_Field_read(TPINIFILE,'ZHAT',XZHAT)
+CALL IO_Field_read(TPINIFILE,'ZTOP',XZTOP)
+IF (XALZBOT>=XZHAT(IKU) .AND. LVE_RELAX) THEN
+ WRITE(ILUOUT,FMT=*) "INI_SPECTRE_n ERROR: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but bottom of layer XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " is upper than model top (",XZHAT(IKU),")"
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_SPECTRE_n','')
+END IF
+IF (LVE_RELAX) THEN
+ IF (XALZBOT>=XZHAT(IKU-4) ) THEN
+ WRITE(ILUOUT,FMT=*) "INI_SPECTRE_n WARNING: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but the layer defined by XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " contains less than 5 model levels"
+ END IF
+END IF
+DEALLOCATE(XZHAT)
+!
+!* 2.3 Compute sizes of arrays of the extended sub-domain
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+IIU_ll=NIMAX_ll + 2 * JPHEXT
+IJU_ll=NJMAX_ll + 2 * JPHEXT
+! initialize NIMAX and NJMAX for not updated versions regarding the parallelism
+! spawning,...
+CALL GET_DIM_PHYS_ll('B',NIMAX,NJMAX)
+!
+NRR=1
+NRRL=0
+NRRI=0
+IF (NVERB >= 5) THEN
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," WATER VARIABLES")') NRR
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," LIQUID VARIABLES")') NRRL
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," SOLID VARIABLES")') NRRI
+END IF
+!
+!* 2.3 Update NSV and floating indices for the current model
+!
+!
+CALL UPDATE_NSV(KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ALLOCATE MEMORY
+! -----------------
+!
+!* 3.2 Module MODD_GRID_n and MODD_METRICS_n
+!
+IF (LCARTESIAN) THEN
+ ALLOCATE(XLON(0,0))
+ ALLOCATE(XLAT(0,0))
+ ALLOCATE(XMAP(0,0))
+ELSE
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XMAP(IIU,IJU))
+END IF
+ALLOCATE(XXHAT(IIU))
+ALLOCATE(XDXHAT(IIU))
+ALLOCATE(XYHAT(IJU))
+ALLOCATE(XDYHAT(IJU))
+ALLOCATE(XZS(IIU,IJU))
+ALLOCATE(XZSMT(IIU,IJU))
+ALLOCATE(XZZ(IIU,IJU,IKU))
+ALLOCATE(XZHAT(IKU))
+!
+ALLOCATE(XDXX(IIU,IJU,IKU))
+ALLOCATE(XDYY(IIU,IJU,IKU))
+ALLOCATE(XDZX(IIU,IJU,IKU))
+ALLOCATE(XDZY(IIU,IJU,IKU))
+ALLOCATE(XDZZ(IIU,IJU,IKU))
+!
+!* 3.3 Modules MODD_REF and MODD_REF_n
+!
+IF (KMI == 1) THEN
+ ALLOCATE(XRHODREFZ(IKU),XTHVREFZ(IKU))
+END IF
+ALLOCATE(XRHODREF(IIU,IJU,IKU))
+ALLOCATE(XTHVREF(IIU,IJU,IKU))
+ALLOCATE(XEXNREF(IIU,IJU,IKU))
+ALLOCATE(XRHODJ(IIU,IJU,IKU))
+IF (CEQNSYS=='DUR' .AND. LUSERV) THEN
+ ALLOCATE(XRVREF(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XRVREF(0,0,0))
+END IF
+!
+!* 3.4 Module MODD_CURVCOR_n
+!
+IF (LTHINSHELL) THEN
+ ALLOCATE(XCORIOX(0,0))
+ ALLOCATE(XCORIOY(0,0))
+ELSE
+ ALLOCATE(XCORIOX(IIU,IJU))
+ ALLOCATE(XCORIOY(IIU,IJU))
+END IF
+ ALLOCATE(XCORIOZ(IIU,IJU))
+IF (LCARTESIAN) THEN
+ ALLOCATE(XCURVX(0,0))
+ ALLOCATE(XCURVY(0,0))
+ELSE
+ ALLOCATE(XCURVX(IIU,IJU))
+ ALLOCATE(XCURVY(IIU,IJU))
+END IF
+!
+!* 3.5 Module MODD_DYN_n
+!
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IF (L2D) THEN
+ ALLOCATE(XBFY(IIY,IJY,IKU))
+ELSE
+ ALLOCATE(XBFY(IJY,IIY,IKU)) ! transposition needed by the optimisition of the
+ ! FFT solver
+END IF
+CALL GET_DIM_EXT_ll('B',IIU_B,IJU_B)
+ALLOCATE(XBFB(IIU_B,IJU_B,IKU))
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+ALLOCATE(XBF_SXP2_YP1_Z(IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll))
+ALLOCATE(XAF(IKU),XCF(IKU))
+ALLOCATE(XTRIGSX(3*IIU_ll))
+ALLOCATE(XTRIGSY(3*IJU_ll))
+ALLOCATE(XRHOM(IKU))
+ALLOCATE(XALK(IKU))
+ALLOCATE(XALKW(IKU))
+!
+IF ( LHORELAX_UVWTH .OR. LHORELAX_RV .OR. &
+ LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. &
+ LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. &
+ ANY(LHORELAX_SV) ) THEN
+ ALLOCATE(XKURELAX(IIU,IJU))
+ ALLOCATE(XKVRELAX(IIU,IJU))
+ ALLOCATE(XKWRELAX(IIU,IJU))
+ ALLOCATE(LMASK_RELAX(IIU,IJU))
+ELSE
+ ALLOCATE(XKURELAX(0,0))
+ ALLOCATE(XKVRELAX(0,0))
+ ALLOCATE(XKWRELAX(0,0))
+ ALLOCATE(LMASK_RELAX(0,0))
+END IF
+!
+! Additional fields for truly horizontal diffusion (Module MODD_DYNZD$n)
+IF (LZDIFFU) THEN
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2)
+ELSE
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2,0)
+ENDIF
+!
+!* 3.6 Larger Scale variables (Module MODD_LSFIELD$n)
+!
+!
+! upper relaxation part
+!
+ALLOCATE(XLSUM(IIU,IJU,IKU)) ; XLSUM = 0.0
+ALLOCATE(XLSVM(IIU,IJU,IKU)) ; XLSVM = 0.0
+ALLOCATE(XLSWM(IIU,IJU,IKU)) ; XLSWM = 0.0
+ALLOCATE(XLSTHM(IIU,IJU,IKU)) ; XLSTHM = 0.0
+IF ( NRR > 0 ) THEN
+ ALLOCATE(XLSRVM(IIU,IJU,IKU)) ; XLSRVM = 0.0
+ELSE
+ ALLOCATE(XLSRVM(0,0,0))
+END IF
+!
+! lbc part
+!
+IF ( L1D) THEN ! 1D case
+!
+ NSIZELBX_ll=0
+ NSIZELBXU_ll=0
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBXTKE_ll=0
+ NSIZELBXR_ll=0
+ NSIZELBXSV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXUM(0,0,0))
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBXVM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBXWM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBXTHM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ELSEIF( L2D ) THEN ! 2D case
+!
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+!
+ IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2
+ NSIZELBXU_ll=2*NRIMX+2
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBX_ll=2
+ NSIZELBXU_ll=4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+!
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2* NRIMX+2
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2* NRIMX+2
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2* NRIMX+2
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ END IF
+!
+ELSE ! 3D case
+!
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+ CALL GET_SIZEY_LB(NIMAX_ll,NJMAX_ll,NRIMY, &
+ IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV, &
+ IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2)
+!
+! check if local domain not to small for NRIMX NRIMY
+!
+ IF ( CLBCX(1) /= 'CYCL' ) THEN
+ IF ( NRIMX+2*JPHEXT .GE. IIU ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_SPECTRE_n ERROR: ( NRIMX+2*JPHEXT >= IIU ) ", &
+ " Local domain to small for relaxation NRIMX+2*JPHEXT,IIU ", &
+ NRIMX+2*JPHEXT,IIU ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_SPECTRE_n','')
+ END IF
+ END IF
+ IF ( CLBCY(1) /= 'CYCL' ) THEN
+ IF ( NRIMY+2*JPHEXT .GE. IJU ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_SPECTRE_n ERROR: ( NRIMY+2*JPHEXT >= IJU ) ", &
+ " Local domain to small for relaxation NRIMY+2*JPHEXT,IJU ", &
+ NRIMY+2*JPHEXT,IJU ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_SPECTRE_n','')
+ END IF
+ END IF
+IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2
+ NSIZELBXU_ll=2*NRIMX+2
+ NSIZELBY_ll=2*NRIMY+2
+ NSIZELBYV_ll=2*NRIMY+2
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBYUM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYVM(IISIZEYFV,IJSIZEYFV,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYWM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTHM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBX_ll=2
+ NSIZELBXU_ll=4
+ NSIZELBY_ll=2
+ NSIZELBYV_ll=4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBYUM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYVM(IISIZEY4,IJSIZEY4,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYWM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTHM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ !
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2*NRIMX+2
+ NSIZELBYTKE_ll=2*NRIMY+2
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2
+ NSIZELBYTKE_ll=2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ NSIZELBYTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2*NRIMX+2
+ NSIZELBYR_ll=2*NRIMY+2
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEYF,IJSIZEYF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2
+ NSIZELBYR_ll=2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEY2,IJSIZEY2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ NSIZELBYR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2*NRIMX+2
+ NSIZELBYSV_ll=2*NRIMY+2
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEYF,IJSIZEYF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2
+ NSIZELBYSV_ll=2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEY2,IJSIZEY2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+ END IF
+END IF ! END OF THE IF STRUCTURE ON THE MODEL DIMENSION
+!
+!
+IF ( KMI > 1 ) THEN
+ ! it has been assumed that the THeta field used the largest rim area compared
+ ! to the others prognostic variables, if it is not the case, you must change
+ ! these lines
+ ALLOCATE(XCOEFLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE( NKLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XCOEFLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE( NKLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XCOEFLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE( NKLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XCOEFLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE( NKLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XCOEFLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE( NKLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XCOEFLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE( NKLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XCOEFLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE( NKLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XCOEFLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE( NKLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+END IF
+!
+! allocation of the LS fields for vertical relaxation and numerical diffusion
+IF( .NOT. LSTEADYLS ) THEN
+!
+ ALLOCATE(XLSUS(SIZE(XLSUM,1),SIZE(XLSUM,2),SIZE(XLSUM,3)))
+ ALLOCATE(XLSVS(SIZE(XLSVM,1),SIZE(XLSVM,2),SIZE(XLSVM,3)))
+ ALLOCATE(XLSWS(SIZE(XLSWM,1),SIZE(XLSWM,2),SIZE(XLSWM,3)))
+ ALLOCATE(XLSTHS(SIZE(XLSTHM,1),SIZE(XLSTHM,2),SIZE(XLSTHM,3)))
+ ALLOCATE(XLSRVS(SIZE(XLSRVM,1),SIZE(XLSRVM,2),SIZE(XLSRVM,3)))
+!
+ELSE
+!
+ ALLOCATE(XLSUS(0,0,0))
+ ALLOCATE(XLSVS(0,0,0))
+ ALLOCATE(XLSWS(0,0,0))
+ ALLOCATE(XLSTHS(0,0,0))
+ ALLOCATE(XLSRVS(0,0,0))
+!
+END IF
+! allocation of the LB fields for horizontal relaxation and Lateral Boundaries
+IF( .NOT. ( LSTEADYLS .AND. KMI==1 ) ) THEN
+!
+ ALLOCATE(XLBXTKES(SIZE(XLBXTKEM,1),SIZE(XLBXTKEM,2),SIZE(XLBXTKEM,3)))
+ ALLOCATE(XLBYTKES(SIZE(XLBYTKEM,1),SIZE(XLBYTKEM,2),SIZE(XLBYTKEM,3)))
+ ALLOCATE(XLBXUS(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XLBYUS(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XLBXVS(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XLBYVS(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XLBXWS(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XLBYWS(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE(XLBXTHS(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XLBYTHS(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XLBXRS(SIZE(XLBXRM,1),SIZE(XLBXRM,2),SIZE(XLBXRM,3),SIZE(XLBXRM,4)))
+ ALLOCATE(XLBYRS(SIZE(XLBYRM,1),SIZE(XLBYRM,2),SIZE(XLBYRM,3),SIZE(XLBYRM,4)))
+ ALLOCATE(XLBXSVS(SIZE(XLBXSVM,1),SIZE(XLBXSVM,2),SIZE(XLBXSVM,3),SIZE(XLBXSVM,4)))
+ ALLOCATE(XLBYSVS(SIZE(XLBYSVM,1),SIZE(XLBYSVM,2),SIZE(XLBYSVM,3),SIZE(XLBYSVM,4)))
+!
+ELSE
+!
+ ALLOCATE(XLBXTKES(0,0,0))
+ ALLOCATE(XLBYTKES(0,0,0))
+ ALLOCATE(XLBXUS(0,0,0))
+ ALLOCATE(XLBYUS(0,0,0))
+ ALLOCATE(XLBXVS(0,0,0))
+ ALLOCATE(XLBYVS(0,0,0))
+ ALLOCATE(XLBXWS(0,0,0))
+ ALLOCATE(XLBYWS(0,0,0))
+ ALLOCATE(XLBXTHS(0,0,0))
+ ALLOCATE(XLBYTHS(0,0,0))
+ ALLOCATE(XLBXRS(0,0,0,0))
+ ALLOCATE(XLBYRS(0,0,0,0))
+ ALLOCATE(XLBXSVS(0,0,0,0))
+ ALLOCATE(XLBYSVS(0,0,0,0))
+!
+END IF
+!
+!* 3.9 Local variables
+!
+ALLOCATE(ZJ(IIU,IJU,IKU))
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 5. INITIALIZE INTERPOLATION COEFFICIENTS
+!
+CALL INI_BIKHARDT_n (NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI),KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. INITIALIZE GRIDS AND METRIC COEFFICIENTS
+! ----------------------------------------
+!
+CALL SET_GRID(KMI,TPINIFILE,IKU,NIMAX_ll,NJMAX_ll, &
+ XTSTEP,XSEGLEN, &
+ XLONORI,XLATORI,XLON,XLAT, &
+ XXHAT,XYHAT,XDXHAT,XDYHAT, XMAP, &
+ XZS,XZZ,XZHAT,XZTOP,LSLEVE,XLEN1,XLEN2,XZSMT, &
+ ZJ, &
+ TDTMOD,TDTCUR,NSTOP,NBAK_NUMB,NOUT_NUMB,TBACKUPN,TOUTPUTN)
+!
+CALL METRICS(XMAP,XDXHAT,XDYHAT,XZZ,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!* update halos of metric coefficients
+!
+!
+CALL UPDATE_METRICS(CLBCX,CLBCY,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!
+! grid nesting initializations
+IF ( KMI == 1 ) THEN
+ XTSTEP_MODEL1=XTSTEP
+END IF
+!
+NDT_2_WAY(KMI)=4
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. INITIALIZE THE PROGNOSTIC FIELDS
+! --------------------------------
+!
+
+IF (LSPECTRE_U) THEN
+ ALLOCATE(XUT(IIU,IJU,IKU)) ; XUT = 0.0
+ CALL IO_Field_read(TPINIFILE,'UT',XUT)
+END IF
+!
+IF (LSPECTRE_V) THEN
+ ALLOCATE(XVT(IIU,IJU,IKU)) ; XVT = 0.0
+ CALL IO_Field_read(TPINIFILE,'VT',XVT)
+END IF
+!
+IF (LSPECTRE_W) THEN
+ ALLOCATE(XWT(IIU,IJU,IKU)) ; XWT = 0.0
+ CALL IO_Field_read(TPINIFILE,'WT',XWT)
+END IF
+!
+IF (LSPECTRE_TH) THEN
+ ALLOCATE(XTHT(IIU,IJU,IKU)) ; XTHT = 0.0
+ CALL IO_Field_read(TPINIFILE,'THT',XTHT)
+END IF
+!
+IF (LSPECTRE_RV) THEN
+ ALLOCATE(XRT(IIU,IJU,IKU,NRR))
+ CALL IO_Field_read(TPINIFILE,'RVT',XRT(:,:,:,1))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 9. INITIALIZE REFERENCE STATE
+! ---------------------------
+!
+!
+CALL SET_REF(KMI,TPINIFILE, &
+ XZZ,XZHAT,ZJ,XDXX,XDYY,CLBCX,CLBCY, &
+ XREFMASS,XMASS_O_PHI0,XLINMASS, &
+ XRHODREF,XTHVREF,XRVREF,XEXNREF,XRHODJ)
+!-------------------------------------------------------------------------------
+!
+!* 11. INITIALIZE THE SOURCE OF TOTAL DRY MASS Md
+! ------------------------------------------
+!
+IF((KMI==1).AND.LSTEADYLS) THEN
+ XDRYMASSS = 0.
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 14. INITIALIZE THE LARGE SCALE SOURCES
+! ----------------------------------
+!
+IF ((KMI==1).AND.(.NOT. LSTEADYLS)) THEN
+ IF (LSPECTRE_LSU.OR.LSPECTRE_LSV.OR.LSPECTRE_LSW.OR. &
+ LSPECTRE_LSRV.OR.LSPECTRE_LSTH) THEN
+ CALL INI_CPL(NSTOP,XTSTEP,LSTEADYLS,CCONF, &
+ CGETTKET, &
+ CGETRVT,CGETRCT,CGETRRT,CGETRIT, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, &
+ NSV,NIMAX_ll,NJMAX_ll, &
+ NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, &
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS )
+ END IF
+END IF
+!
+IF ( KMI > 1) THEN
+ ! Use dummy pointers to correct an ifort BUG
+ DPTR_XBMX1=>XBMX1
+ DPTR_XBMX2=>XBMX2
+ DPTR_XBMX3=>XBMX3
+ DPTR_XBMX4=>XBMX4
+ DPTR_XBMY1=>XBMY1
+ DPTR_XBMY2=>XBMY2
+ DPTR_XBMY3=>XBMY3
+ DPTR_XBMY4=>XBMY4
+ DPTR_XBFX1=>XBFX1
+ DPTR_XBFX2=>XBFX2
+ DPTR_XBFX3=>XBFX3
+ DPTR_XBFX4=>XBFX4
+ DPTR_XBFY1=>XBFY1
+ DPTR_XBFY2=>XBFY2
+ DPTR_XBFY3=>XBFY3
+ DPTR_XBFY4=>XBFY4
+ DPTR_CLBCX=>CLBCX
+ DPTR_CLBCY=>CLBCY
+ !
+ DPTR_XZZ=>XZZ
+ DPTR_XZHAT=>XZHAT
+ DPTR_XLSUM=>XLSUM
+ DPTR_XLSVM=>XLSVM
+ DPTR_XLSWM=>XLSWM
+ DPTR_XLSTHM=>XLSTHM
+ DPTR_XLSRVM=>XLSRVM
+ DPTR_XLSZWSM=>XLSZWSM
+ DPTR_XLSUS=>XLSUS
+ DPTR_XLSVS=>XLSVS
+ DPTR_XLSWS=>XLSWS
+ DPTR_XLSTHS=>XLSTHS
+ DPTR_XLSRVS=>XLSRVS
+ DPTR_XLSZWSS=>XLSZWSS
+ !
+ DPTR_NKLIN_LBXU=>NKLIN_LBXU
+ DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU
+ DPTR_NKLIN_LBYU=>NKLIN_LBYU
+ DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU
+ DPTR_NKLIN_LBXV=>NKLIN_LBXV
+ DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV
+ DPTR_NKLIN_LBYV=>NKLIN_LBYV
+ DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV
+ DPTR_NKLIN_LBXW=>NKLIN_LBXW
+ DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW
+ DPTR_NKLIN_LBYW=>NKLIN_LBYW
+ DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW
+ DPTR_NKLIN_LBXM=>NKLIN_LBXM
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_NKLIN_LBYM=>NKLIN_LBYM
+ DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM
+ !
+ CALL INI_SPAWN_LS_n(NDAD(KMI),XTSTEP,KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT, &
+ LSLEVE,XLEN1,XLEN2, &
+ DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSZWSM, &
+ DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSZWSS, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM )
+ !
+ DPTR_XLBXUM=>XLBXUM
+ DPTR_XLBYUM=>XLBYUM
+ DPTR_XLBXVM=>XLBXVM
+ DPTR_XLBYVM=>XLBYVM
+ DPTR_XLBXWM=>XLBXWM
+ DPTR_XLBYWM=>XLBYWM
+ DPTR_XLBXTHM=>XLBXTHM
+ DPTR_XLBYTHM=>XLBYTHM
+ DPTR_XLBXTKEM=>XLBXTKEM
+ DPTR_XLBYTKEM=>XLBYTKEM
+ DPTR_XLBXRM=>XLBXRM
+ DPTR_XLBYRM=>XLBYRM
+ DPTR_XLBXSVM=>XLBXSVM
+ DPTR_XLBYSVM=>XLBYSVM
+ CALL INI_ONE_WAY_n(NDAD(KMI),KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, &
+ CCLOUD, LUSECHAQ, LUSECHIC, &
+ DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, &
+ DPTR_XLBXTHM,DPTR_XLBYTHM, &
+ DPTR_XLBXTKEM,DPTR_XLBYTKEM, &
+ DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM )
+END IF
+!
+!
+!* 16. BUILT THE GENERIC OUTPUT NAME
+! ----------------------------
+!
+WRITE(COUTFILE,'(A,".",I1,".",A)') CEXP,KMI,TRIM(ADJUSTL(CSEG))
+
+!-------------------------------------------------------------------------------
+!
+!* 17. INITIALIZE THE PARAMETERS FOR THE DYNAMICS
+! ------------------------------------------
+!
+!Allocate to zero size to not pass unallocated pointers
+ALLOCATE(XALKBAS(0))
+ALLOCATE(XALKWBAS(0))
+!
+CALL INI_DYNAMICS(XLON,XLAT,XRHODJ,XTHVREF,XMAP,XZZ,XDXHAT,XDYHAT, &
+ XZHAT,CLBCX,CLBCY,XTSTEP,CPRESOPT, &
+ LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV, &
+ LHORELAX_RC,LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, &
+ LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, &
+ LHORELAX_SVC2R2,LHORELAX_SVC1R3,LHORELAX_SVELEC,LHORELAX_SVLG, &
+ LHORELAX_SVCHEM,LHORELAX_SVAER,LHORELAX_SVDST,LHORELAX_SVSLT, &
+ LHORELAX_SVPP,LHORELAX_SVCS,LHORELAX_SVCHIC,LHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF, &
+#endif
+ XRIMKMAX,NRIMX,NRIMY, &
+ XALKTOP,XALKGRD,XALZBOT,XALZBAS, &
+ XT4DIFU,XT4DIFTH,XT4DIFSV, &
+ XCORIOX,XCORIOY,XCORIOZ,XCURVX,XCURVY, &
+ XDXHATM,XDYHATM,XRHOM,XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY,&
+ XALK,XALKW,NALBOT,XALKBAS,XALKWBAS,NALBAS, &
+ LMASK_RELAX,XKURELAX,XKVRELAX,XKWRELAX, &
+ XDK2U,XDK4U,XDK2TH,XDK4TH,XDK2SV,XDK4SV, &
+ LZDIFFU,XZDIFFU_HALO2, &
+ XBFB,XBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K)
+!
+!-------------------------------------------------------------------------------
+!
+!* 22. UPDATE HALO
+! -----------
+!
+!
+CALL UPDATE_HALO_ll(TZINITHALO3D_ll,IINFO_ll)
+CALL UPDATE_HALO_ll(TZINITHALO2D_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZINITHALO3D_ll)
+CALL CLEANLIST_ll(TZINITHALO2D_ll)
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 23. DEALLOCATION
+! -------------
+!
+DEALLOCATE(ZJ)
+!
+
+END SUBROUTINE INI_SPECTRE_n
diff --git a/src/ZSOLVER/modd_dynn.f90 b/src/ZSOLVER/modd_dynn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..445105291501c6f96285c0eb1654124d801036a5
--- /dev/null
+++ b/src/ZSOLVER/modd_dynn.f90
@@ -0,0 +1,402 @@
+!MNH_LIC Copyright 1994-2018 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 MODD_DYN_n
+! #################
+!
+!!**** *MODD_DYN$n* - declaration of dynamic control variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the dynamic
+! control variables.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_DYNn)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 18/05/94
+!! Modifications 16/11/94 (Lafore+Pinty) For NUM_DIFF
+!! Modifications 06/01/95 (Lafore) For LSTEADY_DMASS
+!! Modifications 28/07/96 (Masson) Supress LSTEADY_DMASS
+!! Modifications 15/03/98 (Stein) Add LHO_RELAX for each variables
+!! Modifications 22/01/01 (Gazen) Add LHORELAX_SVC2R2, _SVCHEM, _SVLG
+!! Modifications 29/11/02 (Pinty) Add LHORELAX_SVC1R3, _SVELEC
+!! Modifications 07/05 (P.Tulet) Add relaxation for dust and aerosol
+!! Modifications 05/07 (C.Lac) Separation of num diffusion
+!! Modifications 07/10 (M.Leriche) Add relaxation for ice phase chemical
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Modification 07/2017 (V. Vionnet) Add blowing snow variable
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS, ONLY: JPMODELMAX, JPSVMAX
+IMPLICIT NONE
+
+TYPE DYN_t
+!
+ INTEGER :: NSTOP ! Number of time step
+ REAL :: XTSTEP ! Time step
+!
+!++++++++++++++++++++++++++++++++++
+!PART USED BY THE PRESSURE SOLVER
+!++++++++++++++++++++++++++++++++++
+!
+ REAL, DIMENSION(:,:,:), POINTER :: XBFY=>NULL() ! Vectors giving the non
+ REAL, DIMENSION(:,:,:), POINTER :: XBFB=>NULL() ! Vectors giving the non
+ REAL, DIMENSION(:,:,:), POINTER :: XBF_SXP2_YP1_Z=>NULL() ! Vectors giving the non
+ REAL, DIMENSION(:,:,:), POINTER :: XBF=>NULL() ! vanishing elements of the
+ REAL, DIMENSION(:), POINTER :: XAF=>NULL(),XCF=>NULL() ! tri-diag matrix in the pressure equation
+ REAL, DIMENSION(:,:,:), POINTER :: XAF_ZS=>NULL(),XBF_ZS=>NULL(),XCF_ZS=>NULL() ! coef for Zsolver
+ REAL, DIMENSION(:,:) , POINTER :: XDXATH_ZS=>NULL(),XDYATH_ZS=>NULL()
+ REAL, DIMENSION(:,:,:), POINTER :: XRHO_ZS=>NULL()
+ REAL, DIMENSION(:), POINTER :: XA_K=>NULL(),XB_K=>NULL(),XC_K=>NULL(),XD_K=>NULL()
+!
+ ! Arrays of sinus or cosinus
+ ! values for the FFT
+ REAL, DIMENSION(:), POINTER :: XTRIGSX=>NULL() ! in x-direction
+ REAL, DIMENSION(:), POINTER :: XTRIGSY=>NULL() ! in y-direction
+ INTEGER, DIMENSION(:),POINTER :: NIFAXX =>NULL() ! Decomposition in prime numbers
+ INTEGER, DIMENSION(:),POINTER :: NIFAXY =>NULL() ! for the FFT in x and y directions
+ CHARACTER(LEN=5) :: CPRESOPT ! Choice of the pressure solver
+ INTEGER :: NITR ! Number of iterations for the
+ ! pressure solver
+ LOGICAL :: LITRADJ ! Choice to adjust the number of
+ !solver iterations during
+ !the simulation
+ LOGICAL :: LRES ! Choice of a different residual
+ ! divergence limit
+ REAL :: XRES ! Value of residual divergence limit
+ REAL :: XRELAX ! relaxation coefficient for the
+ ! Richardson's method
+!
+ REAL :: XDXHATM ! mean grid increment in the
+ REAL :: XDYHATM ! x and y directions
+
+ REAL, DIMENSION (:), POINTER :: XRHOM=>NULL() ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+!++++++++++++++++++++++++++++++++++
+!PART USED BY THE ABSORBING LAYERS
+!++++++++++++++++++++++++++++++++++
+!
+ INTEGER :: NALBOT ! Vertical index corresponding to the
+ ! absorbing layer base
+!
+ INTEGER :: NALBAS ! Vertical index corresponding to the
+ ! absorbing layer base
+!
+ REAL, DIMENSION(:), POINTER :: XALK=>NULL() ! Function of the absorbing
+ ! layer damping coefficient defined for
+ ! u,v,and theta
+ REAL, DIMENSION(:), POINTER :: XALKW=>NULL() ! Idem but defined for w
+!
+ REAL, DIMENSION(:), POINTER :: XALKBAS=>NULL() ! Function of the absorbing
+ ! layer damping coefficient defined for
+ ! u,v,and theta
+ REAL, DIMENSION(:), POINTER :: XALKWBAS=>NULL() ! Idem but defined for w
+!
+ LOGICAL :: LVE_RELAX ! switch to activate the VErtical RELAXation
+ LOGICAL :: LVE_RELAX_GRD ! switch to activate the VErtical RELAXation
+!
+! switch to activate the HOrizontal RELAXation
+! LOGICAL :: LHORELAX_UVWTH
+!
+ LOGICAL :: LHORELAX_RV, LHORELAX_RC, LHORELAX_RR, LHORELAX_RI
+ LOGICAL :: LHORELAX_RS, LHORELAX_RG, LHORELAX_RH
+!
+! LOGICAL :: LHORELAX_TKE
+!
+ LOGICAL :: LHORELAX_SVC2R2
+ LOGICAL :: LHORELAX_SVC1R3
+ LOGICAL :: LHORELAX_SVLIMA
+ LOGICAL :: LHORELAX_SVELEC
+ LOGICAL :: LHORELAX_SVCHEM
+ LOGICAL :: LHORELAX_SVCHIC
+ LOGICAL :: LHORELAX_SVLG
+ LOGICAL :: LHORELAX_SVDST
+ LOGICAL :: LHORELAX_SVSLT
+ LOGICAL :: LHORELAX_SVAER
+ LOGICAL :: LHORELAX_SVPP
+#ifdef MNH_FOREFIRE
+ LOGICAL :: LHORELAX_SVFF
+#endif
+ LOGICAL :: LHORELAX_SVCS
+ LOGICAL :: LHORELAX_SVSNW
+ LOGICAL, DIMENSION(:),POINTER :: LHORELAX_SV =>NULL()
+!
+ REAL :: XRIMKMAX ! Max. value of the horiz. relaxation coeff.
+! INTEGER :: NRIMX,NRIMY! Number of points in the lateral absorbing
+ ! layer in the x and y directions
+! sizes of the West-east total LB area
+ INTEGER :: NSIZELBX_ll,NSIZELBXU_ll ! for T,V,W and u
+ INTEGER :: NSIZELBXTKE_ll ! for TKE
+ INTEGER :: NSIZELBXR_ll,NSIZELBXSV_ll ! for Rx and SV
+! sizes of the North-south total LB area
+ INTEGER :: NSIZELBY_ll,NSIZELBYV_ll ! for T,U,W and v
+ INTEGER :: NSIZELBYTKE_ll ! for TKE
+ INTEGER :: NSIZELBYR_ll,NSIZELBYSV_ll ! for Rx and SV
+ LOGICAL, DIMENSION(:,:), POINTER :: LMASK_RELAX=>NULL() ! Mask for lateral
+ ! relaxation: True where it has to be performed
+ REAL, DIMENSION(:,:), POINTER :: XKURELAX=>NULL() ! Horizontal relaxation
+ REAL, DIMENSION(:,:), POINTER :: XKVRELAX=>NULL() ! coefficients for the
+ REAL, DIMENSION(:,:), POINTER :: XKWRELAX=>NULL() ! u, v and mass locations
+!
+!++++++++++++++++++++++++++++++++++++
+!PART USED BY THE NUMERICAL DIFFUSION
+!++++++++++++++++++++++++++++++++++++
+!
+ REAL :: XT4DIFU ! Damping time scale for 2*dx wavelength
+ ! specified for the 4nd order num. diffusion
+ ! for momentum
+ REAL :: XT4DIFTH! for theta and mixing ratios
+ REAL :: XT4DIFSV! for scalar variables
+ REAL :: XDK2U ! 2nd order num. diffusion coef. /dx2
+ ! for momentum
+ REAL :: XDK4U ! 4nd order num. diffusion coef. /dx4
+ ! for momentum
+ REAL :: XDK2TH ! for theta and mixing ratios
+ REAL :: XDK4TH ! for theta and mixing ratios
+ REAL :: XDK2SV ! for scalar variables
+ REAL :: XDK4SV ! for scalar variables
+!
+END TYPE DYN_t
+
+TYPE(DYN_t), DIMENSION(JPMODELMAX), TARGET, SAVE :: DYN_MODEL
+LOGICAL , DIMENSION(JPMODELMAX), SAVE :: DYN_FIRST_CALL = .TRUE.
+
+INTEGER, POINTER :: NSTOP=>NULL()
+REAL, POINTER :: XTSTEP=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBFY=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBFB=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBF_SXP2_YP1_Z=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBF=>NULL()
+REAL, DIMENSION(:), POINTER :: XAF=>NULL(),XCF=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XAF_ZS=>NULL(),XBF_ZS=>NULL(),XCF_ZS=>NULL()
+REAL, DIMENSION(:,:) , POINTER :: XDXATH_ZS=>NULL(),XDYATH_ZS=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XRHO_ZS=>NULL()
+REAL, DIMENSION(:), POINTER :: XA_K=>NULL(),XB_K=>NULL(),XC_K=>NULL(),XD_K=>NULL()
+REAL, DIMENSION(:), POINTER :: XTRIGSX=>NULL()
+REAL, DIMENSION(:), POINTER :: XTRIGSY=>NULL()
+INTEGER, DIMENSION(:), POINTER :: NIFAXX=>NULL()
+INTEGER, DIMENSION(:), POINTER :: NIFAXY=>NULL()
+CHARACTER(LEN=5), POINTER :: CPRESOPT=>NULL()
+INTEGER, POINTER :: NITR=>NULL()
+LOGICAL, POINTER :: LITRADJ=>NULL()
+LOGICAL, POINTER :: LRES=>NULL()
+REAL, POINTER :: XRES=>NULL()
+REAL, POINTER :: XRELAX=>NULL()
+REAL, POINTER :: XDXHATM=>NULL()
+REAL, POINTER :: XDYHATM=>NULL()
+REAL, DIMENSION (:), POINTER :: XRHOM=>NULL()
+INTEGER, POINTER :: NALBOT=>NULL()
+REAL, DIMENSION(:), POINTER :: XALK=>NULL()
+REAL, DIMENSION(:), POINTER :: XALKW=>NULL()
+INTEGER, POINTER :: NALBAS=>NULL()
+REAL, DIMENSION(:), POINTER :: XALKBAS=>NULL()
+REAL, DIMENSION(:), POINTER :: XALKWBAS=>NULL()
+LOGICAL, POINTER :: LVE_RELAX=>NULL()
+LOGICAL, POINTER :: LVE_RELAX_GRD=>NULL()
+LOGICAL, POINTER :: LHORELAX_UVWTH=>NULL()
+LOGICAL, POINTER :: LHORELAX_RV=>NULL(), LHORELAX_RC=>NULL(), LHORELAX_RR=>NULL(), LHORELAX_RI=>NULL()
+LOGICAL, POINTER :: LHORELAX_RS=>NULL(), LHORELAX_RG=>NULL(), LHORELAX_RH=>NULL()
+LOGICAL, POINTER :: LHORELAX_TKE=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVC2R2=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVC1R3=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVLIMA=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVELEC=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVCHEM=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVCHIC=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVLG=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVDST=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVSLT=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVAER=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVPP=>NULL()
+#ifdef MNH_FOREFIRE
+LOGICAL, POINTER :: LHORELAX_SVFF=>NULL()
+#endif
+LOGICAL, POINTER :: LHORELAX_SVCS=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVSNW=>NULL()
+LOGICAL, DIMENSION(:), POINTER :: LHORELAX_SV=>NULL()
+REAL, POINTER :: XRIMKMAX=>NULL()
+INTEGER, POINTER :: NRIMX=>NULL(),NRIMY=>NULL()
+INTEGER, POINTER :: NSIZELBX_ll=>NULL(),NSIZELBXU_ll=>NULL()
+INTEGER, POINTER :: NSIZELBXTKE_ll=>NULL()
+INTEGER, POINTER :: NSIZELBXR_ll=>NULL(),NSIZELBXSV_ll=>NULL()
+INTEGER, POINTER :: NSIZELBY_ll=>NULL(),NSIZELBYV_ll=>NULL()
+INTEGER, POINTER :: NSIZELBYTKE_ll=>NULL()
+INTEGER, POINTER :: NSIZELBYR_ll=>NULL(),NSIZELBYSV_ll=>NULL()
+LOGICAL, DIMENSION(:,:), POINTER :: LMASK_RELAX=>NULL()
+REAL, DIMENSION(:,:), POINTER :: XKURELAX=>NULL()
+REAL, DIMENSION(:,:), POINTER :: XKVRELAX=>NULL()
+REAL, DIMENSION(:,:), POINTER :: XKWRELAX=>NULL()
+REAL, POINTER :: XT4DIFU=>NULL()
+REAL, POINTER :: XDK2U=>NULL()
+REAL, POINTER :: XDK4U=>NULL()
+REAL, POINTER :: XT4DIFTH=>NULL()
+REAL, POINTER :: XDK2TH=>NULL()
+REAL, POINTER :: XDK4TH=>NULL()
+REAL, POINTER :: XT4DIFSV=>NULL()
+REAL, POINTER :: XDK2SV=>NULL()
+REAL, POINTER :: XDK4SV=>NULL()
+
+CONTAINS
+
+SUBROUTINE DYN_GOTO_MODEL(KFROM, KTO)
+INTEGER, INTENT(IN) :: KFROM, KTO
+!
+IF (DYN_FIRST_CALL(KTO)) THEN
+ALLOCATE (DYN_MODEL(KTO)%NIFAXX(19))
+ALLOCATE (DYN_MODEL(KTO)%NIFAXY(19))
+ALLOCATE (DYN_MODEL(KTO)%LHORELAX_SV(JPSVMAX))
+DYN_FIRST_CALL(KTO) = .FALSE.
+ENDIF
+! Save current state for allocated arrays
+DYN_MODEL(KFROM)%XBFY=>XBFY
+DYN_MODEL(KFROM)%XBFB=>XBFB
+DYN_MODEL(KFROM)%XBF_SXP2_YP1_Z=>XBF_SXP2_YP1_Z
+DYN_MODEL(KFROM)%XBF=>XBF
+DYN_MODEL(KFROM)%XAF=>XAF
+DYN_MODEL(KFROM)%XCF=>XCF
+
+DYN_MODEL(KFROM)%XAF_ZS=>XAF_ZS
+DYN_MODEL(KFROM)%XBF_ZS=>XBF_ZS
+DYN_MODEL(KFROM)%XCF_ZS=>XCF_ZS
+
+DYN_MODEL(KFROM)%XDXATH_ZS=>XDXATH_ZS
+DYN_MODEL(KFROM)%XDYATH_ZS=>XDYATH_ZS
+DYN_MODEL(KFROM)%XRHO_ZS=>XRHO_ZS
+DYN_MODEL(KFROM)%XA_K=>XA_K
+DYN_MODEL(KFROM)%XB_K=>XB_K
+DYN_MODEL(KFROM)%XC_K=>XC_K
+DYN_MODEL(KFROM)%XD_K=>XD_K
+
+DYN_MODEL(KFROM)%XTRIGSX=>XTRIGSX
+DYN_MODEL(KFROM)%XTRIGSY=>XTRIGSY
+DYN_MODEL(KFROM)%XRHOM=>XRHOM
+DYN_MODEL(KFROM)%XALK=>XALK
+DYN_MODEL(KFROM)%XALKW=>XALKW
+DYN_MODEL(KFROM)%XALKBAS=>XALKBAS
+DYN_MODEL(KFROM)%XALKWBAS=>XALKWBAS
+DYN_MODEL(KFROM)%LMASK_RELAX=>LMASK_RELAX
+DYN_MODEL(KFROM)%XKURELAX=>XKURELAX
+DYN_MODEL(KFROM)%XKVRELAX=>XKVRELAX
+DYN_MODEL(KFROM)%XKWRELAX=>XKWRELAX
+!
+! Current model is set to model KTO
+NSTOP=>DYN_MODEL(KTO)%NSTOP
+XTSTEP=>DYN_MODEL(KTO)%XTSTEP
+XBFY=>DYN_MODEL(KTO)%XBFY
+XBFB=>DYN_MODEL(KTO)%XBFB
+XBF_SXP2_YP1_Z=>DYN_MODEL(KTO)%XBF_SXP2_YP1_Z
+XBF=>DYN_MODEL(KTO)%XBF
+XAF=>DYN_MODEL(KTO)%XAF
+XCF=>DYN_MODEL(KTO)%XCF
+
+XAF_ZS=>DYN_MODEL(KTO)%XAF_ZS
+XBF_ZS=>DYN_MODEL(KTO)%XBF_ZS
+XCF_ZS=>DYN_MODEL(KTO)%XCF_ZS
+
+XDXATH_ZS=>DYN_MODEL(KFROM)%XDXATH_ZS
+XDYATH_ZS=>DYN_MODEL(KFROM)%XDYATH_ZS
+XRHO_ZS=>DYN_MODEL(KFROM)%XRHO_ZS
+XA_K=>DYN_MODEL(KFROM)%XA_K
+XB_K=>DYN_MODEL(KFROM)%XB_K
+XC_K=>DYN_MODEL(KFROM)%XC_K
+XD_K=>DYN_MODEL(KFROM)%XD_K
+
+XTRIGSX=>DYN_MODEL(KTO)%XTRIGSX
+XTRIGSY=>DYN_MODEL(KTO)%XTRIGSY
+NIFAXX=>DYN_MODEL(KTO)%NIFAXX
+NIFAXY=>DYN_MODEL(KTO)%NIFAXY
+CPRESOPT=>DYN_MODEL(KTO)%CPRESOPT
+NITR=>DYN_MODEL(KTO)%NITR
+LITRADJ=>DYN_MODEL(KTO)%LITRADJ
+LRES=>DYN_MODEL(KTO)%LRES
+XRES=>DYN_MODEL(KTO)%XRES
+XRELAX=>DYN_MODEL(KTO)%XRELAX
+XDXHATM=>DYN_MODEL(KTO)%XDXHATM
+XDYHATM=>DYN_MODEL(KTO)%XDYHATM
+XRHOM=>DYN_MODEL(KTO)%XRHOM
+NALBOT=>DYN_MODEL(KTO)%NALBOT
+XALK=>DYN_MODEL(KTO)%XALK
+XALKW=>DYN_MODEL(KTO)%XALKW
+NALBAS=>DYN_MODEL(KTO)%NALBAS
+XALKBAS=>DYN_MODEL(KTO)%XALKBAS
+XALKWBAS=>DYN_MODEL(KTO)%XALKWBAS
+LVE_RELAX=>DYN_MODEL(KTO)%LVE_RELAX
+LVE_RELAX_GRD=>DYN_MODEL(KTO)%LVE_RELAX_GRD
+!LHORELAX_UVWTH=>DYN_MODEL(KTO)%LHORELAX_UVWTH !Done in FIELDLIST_GOTO_MODEL
+LHORELAX_RV=>DYN_MODEL(KTO)%LHORELAX_RV
+LHORELAX_RC=>DYN_MODEL(KTO)%LHORELAX_RC
+LHORELAX_RR=>DYN_MODEL(KTO)%LHORELAX_RR
+LHORELAX_RI=>DYN_MODEL(KTO)%LHORELAX_RI
+LHORELAX_RS=>DYN_MODEL(KTO)%LHORELAX_RS
+LHORELAX_RG=>DYN_MODEL(KTO)%LHORELAX_RG
+LHORELAX_RH=>DYN_MODEL(KTO)%LHORELAX_RH
+!LHORELAX_TKE=>DYN_MODEL(KTO)%LHORELAX_TKE !Done in FIELDLIST_GOTO_MODEL
+LHORELAX_SVC2R2=>DYN_MODEL(KTO)%LHORELAX_SVC2R2
+LHORELAX_SVC1R3=>DYN_MODEL(KTO)%LHORELAX_SVC1R3
+LHORELAX_SVLIMA=>DYN_MODEL(KTO)%LHORELAX_SVLIMA
+LHORELAX_SVELEC=>DYN_MODEL(KTO)%LHORELAX_SVELEC
+LHORELAX_SVCHEM=>DYN_MODEL(KTO)%LHORELAX_SVCHEM
+LHORELAX_SVCHIC=>DYN_MODEL(KTO)%LHORELAX_SVCHIC
+LHORELAX_SVLG=>DYN_MODEL(KTO)%LHORELAX_SVLG
+LHORELAX_SVDST=>DYN_MODEL(KTO)%LHORELAX_SVDST
+LHORELAX_SVSLT=>DYN_MODEL(KTO)%LHORELAX_SVSLT
+LHORELAX_SVAER=>DYN_MODEL(KTO)%LHORELAX_SVAER
+LHORELAX_SVPP=>DYN_MODEL(KTO)%LHORELAX_SVPP
+#ifdef MNH_FOREFIRE
+LHORELAX_SVFF=>DYN_MODEL(KTO)%LHORELAX_SVFF
+#endif
+LHORELAX_SVCS=>DYN_MODEL(KTO)%LHORELAX_SVCS
+LHORELAX_SVSNW=>DYN_MODEL(KTO)%LHORELAX_SVSNW
+LHORELAX_SV=>DYN_MODEL(KTO)%LHORELAX_SV
+XRIMKMAX=>DYN_MODEL(KTO)%XRIMKMAX
+!NRIMX=>DYN_MODEL(KTO)%NRIMX !Done in FIELDLIST_GOTO_MODEL
+!NRIMY=>DYN_MODEL(KTO)%NRIMY !Done in FIELDLIST_GOTO_MODEL
+NSIZELBX_ll=>DYN_MODEL(KTO)%NSIZELBX_ll
+NSIZELBXU_ll=>DYN_MODEL(KTO)%NSIZELBXU_ll
+NSIZELBXTKE_ll=>DYN_MODEL(KTO)%NSIZELBXTKE_ll
+NSIZELBXR_ll=>DYN_MODEL(KTO)%NSIZELBXR_ll
+NSIZELBXSV_ll=>DYN_MODEL(KTO)%NSIZELBXSV_ll
+NSIZELBY_ll=>DYN_MODEL(KTO)%NSIZELBY_ll
+NSIZELBYV_ll=>DYN_MODEL(KTO)%NSIZELBYV_ll
+NSIZELBYTKE_ll=>DYN_MODEL(KTO)%NSIZELBYTKE_ll
+NSIZELBYR_ll=>DYN_MODEL(KTO)%NSIZELBYR_ll
+NSIZELBYSV_ll=>DYN_MODEL(KTO)%NSIZELBYSV_ll
+LMASK_RELAX=>DYN_MODEL(KTO)%LMASK_RELAX
+XKURELAX=>DYN_MODEL(KTO)%XKURELAX
+XKVRELAX=>DYN_MODEL(KTO)%XKVRELAX
+XKWRELAX=>DYN_MODEL(KTO)%XKWRELAX
+XT4DIFU=>DYN_MODEL(KTO)%XT4DIFU
+XDK2U=>DYN_MODEL(KTO)%XDK2U
+XDK4U=>DYN_MODEL(KTO)%XDK4U
+XT4DIFTH=>DYN_MODEL(KTO)%XT4DIFTH
+XDK2TH=>DYN_MODEL(KTO)%XDK2TH
+XDK4TH=>DYN_MODEL(KTO)%XDK4TH
+XT4DIFSV=>DYN_MODEL(KTO)%XT4DIFSV
+XDK2SV=>DYN_MODEL(KTO)%XDK2SV
+XDK4SV=>DYN_MODEL(KTO)%XDK4SV
+
+END SUBROUTINE DYN_GOTO_MODEL
+
+END MODULE MODD_DYN_n
diff --git a/src/ZSOLVER/modeln.f90 b/src/ZSOLVER/modeln.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a65e4e58abd7369dc942b9d7956f844df1cfa6dc
--- /dev/null
+++ b/src/ZSOLVER/modeln.f90
@@ -0,0 +1,2257 @@
+!MNH_LIC Copyright 1994-2020 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_MODEL_n
+! ###################
+!
+INTERFACE
+!
+ SUBROUTINE MODEL_n(KTCOUNT,OEXIT)
+!
+INTEGER, INTENT(IN) :: KTCOUNT ! temporal loop index of model KMODEL
+LOGICAL, INTENT(INOUT):: OEXIT ! switch for the end of the temporal loop
+!
+END SUBROUTINE MODEL_n
+!
+END INTERFACE
+!
+END MODULE MODI_MODEL_n
+
+! ###################################
+ SUBROUTINE MODEL_n(KTCOUNT, OEXIT)
+! ###################################
+!
+!!**** *MODEL_n * -monitor of the model version _n
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to build up a typical model version
+! by sequentially calling the specialized routines.
+!
+!!** METHOD
+!! ------
+!! Some preliminary initializations are performed in the first section.
+!! Then, specialized routines are called to update the guess of the future
+!! instant XRxxS of the variable xx by adding the effects of all the
+!! different sources of evolution.
+!!
+!! (guess of xx at t+dt) * Rhod_ref * Jacobian
+!! XRxxS = -------------------------------------------
+!! 2 dt
+!!
+!! At this level, the informations are transferred with a USE association
+!! from the INIT step, where the modules have been previously filled. The
+!! transfer to the subroutines computing each source term is performed by
+!! argument in order to avoid repeated compilations of these subroutines.
+!! This monitor model_n, must therefore be duplicated for each model,
+!! model1 corresponds in this case to the outermost model, model2 is used
+!! for the first level of gridnesting,....
+!! The effect of all parameterizations is computed in PHYS_PARAM_n, which
+!! is itself a monitor. This is due to a possible large number of
+!! parameterizations, which can be activated and therefore, will require a
+!! very large list of arguments. To circumvent this problem, we transfer by
+!! a USE association, the necessary informations in this monitor, which will
+!! dispatch the pertinent information to every parametrization.
+!! Some elaborated diagnostics, LES tools, budget storages are also called
+!! at this level because they require informations about the fields at every
+!! timestep.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine IO_File_open: to open a file
+!! Subroutine WRITE_DESFM: to write the descriptive part of a FMfile
+!! Subroutine WRITE_LFIFM: to write the binary part of a FMfile
+!! Subroutine SET_MASK : to compute all the masks selected for budget
+!! computations
+!! Subroutine BOUNDARIES : set the fields at the marginal points in every
+!! directions according the selected boundary conditions
+!! Subroutine INITIAL_GUESS: initializes the guess of the future instant
+!! Subroutine LES_FLX_SPECTRA: computes the resolved fluxes and the
+!! spectra of some quantities when running in LES mode.
+!! Subroutine ADVECTION: computes the advection terms.
+!! Subroutine DYN_SOURCES: computes the curvature, Coriolis, gravity terms.
+!! Subroutine NUM_DIFF: applies the fourth order numerical diffusion.
+!! Subroutine RELAXATION: performs the relaxation to Larger Scale fields
+!! in the upper levels and outermost vertical planes
+!! Subroutine PHYS_PARAM_n : computes the parameterized physical terms
+!! Subroutine RAD_BOUND: prepares the velocity normal components for the bc.
+!! Subroutine RESOLVED_CLOUD : computes the sources terms for water in any
+!! form
+!! Subroutine PRESSURE : computes the pressure gradient term and the
+!! absolute pressure
+!! Subroutine EXCHANGE : updates the halo of each subdomains
+!! Subroutine ENDSTEP : advances in time the fields.
+!! Subroutines UVW_LS_COUPLING and SCALAR_LS_COUPLING:
+!! compute the large scale fields, used to
+!! couple Model_n with outer informations.
+!! Subroutine ENDSTEP_BUDGET: writes the budget informations.
+!! Subroutine IO_File_close: closes a file
+!! Subroutine DATETIME_CORRECTDATE: transform the current time in GMT
+!! Subroutine FORCING : computes forcing terms
+!! Subroutine ADD3DFIELD_ll : add a field to 3D-list
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! MODD_DYN
+!! MODD_CONF
+!! MODD_NESTING
+!! MODD_BUDGET
+!! MODD_PARAMETERS
+!! MODD_CONF_n
+!! MODD_CURVCOR_n
+!! MODD_DYN_n
+!! MODD_DIM_n
+!! MODD_ADV_n
+!! MODD_FIELD_n
+!! MODD_LSFIELD_n
+!! MODD_GRID_n
+!! MODD_METRICS_n
+!! MODD_LBC_n
+!! MODD_PARAM_n
+!! MODD_REF_n
+!! MODD_LUNIT_n
+!! MODD_OUT_n
+!! MODD_TIME_n
+!! MODD_TURB_n
+!! MODD_CLOUDPAR_n
+!! MODD_TIME
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 15/09/94
+!! Modification 20/10/94 (J.Stein) for the outputs and abs_layers routines
+!! Modification 10/11/94 (J.Stein) change ABS_LAYER_FIELDS call
+!! Modification 16/11/94 (J.Stein) add call to the renormalization
+!! Modification 17/11/94 (J.-P. Lafore and J.-P. Pinty) call NUM_DIFF
+!! Modification 08/12/94 (J.Stein) cleaning + remove (RENORM + ABS_LAYER..
+!! ..) + add RELAXATION + LS fiels in the arguments
+!! Modification 19/12/94 (J.Stein) switch for the num diff
+!! Modification 22/12/94 (J.Stein) update tdtcur + change dyn_source call
+!! Modification 05/01/95 (J.Stein) add the parameterization monitor
+!! Modification 09/01/95 (J.Stein) add the 1D switch
+!! Modification 10/01/95 (J.Stein) displace the TDTCUR computation
+!! Modification 03/01/95 (J.-P. Lafore) Absolute pressure diagnosis
+!! Modification Jan 19, 1995 (J. Cuxart) Shunt the DYN_SOURCES in 1D cases.
+!! Modification Jan 24, 1995 (J. Stein) Interchange Boundaries and
+!! Initial_guess to correct a bug in 2D configuration
+!! Modification Feb 02, 1995 (I.Mallet) update BOUNDARIES and RAD_BOUND
+!! calls
+!! Modification Mar 10, 1995 (I.Mallet) add call to SET_COUPLING
+!! March,21, 1995 (J. Stein) remove R from the historical var.
+!! March,26, 1995 (J. Stein) add the EPS variable
+!! April 18, 1995 (J. Cuxart) add the LES call
+!! Sept 20,1995 (Lafore) coupling for the dry mass Md
+!! Nov 2,1995 (Stein) displace the temporal counter increase
+!! Jan 2,1996 (Stein) rm the test on the temporal counter
+!! Modification Feb 5,1996 (J. Vila) implementation new advection
+!! schemes for scalars
+!! Modification Feb 20,1996 (J.Stein) doctor norm
+!! Dec95 - Jul96 (Georgelin, Pinty, Mari, Suhre) FORCING
+!! June 17,1996 (Vincent, Lafore, Jabouille)
+!! statistics of computing time
+!! Aug 8, 1996 (K. Suhre) add chemistry
+!! October 12, 1996 (J. Stein) save the PSRC value
+!! Sept 05,1996 (V.Masson) print of loop index for debugging
+!! purposes
+!! July 22,1996 (Lafore) improve write of computing time statistics
+!! July 29,1996 (Lafore) nesting introduction
+!! Aug. 1,1996 (Lafore) synchronization between models
+!! Sept. 4,1996 (Lafore) modification of call to routine SET_COUPLING
+!! now splitted in 2 routines
+!! (UVW_LS_COUPLING and SCALAR_LS_COUPLING)
+!! Sept 5,1996 (V.Masson) print of loop index for debugging
+!! purposes
+!! Sept 25,1996 (V.Masson) test for coupling performed here
+!! Oct. 29,1996 (Lafore) one-way nesting implementation
+!! Oct. 12,1996 (J. Stein) save the PSRC value
+!! Dec. 12,1996 (Lafore) change call to RAD_BOUND
+!! Dec. 21,1996 (Lafore) two-way nesting implementation
+!! Mar. 12,1997 (Lafore) introduction of "surfacic" LS fields
+!! Nov 18, 1996 (J.-P. Pinty) FORCING revisited (translation)
+!! Dec 04, 1996 (J.-P. Pinty) include mixed-phase clouds
+!! Dec 20, 1996 (J.-P. Pinty) update the budgets
+!! Dec 23, 1996 (J.-P. Pinty) add the diachronic file control
+!! Jan 11, 1997 (J.-P. Pinty) add the deep convection control
+!! Dec 20,1996 (V.Masson) call boundaries before the writing
+!! Fev 25, 1997 (P.Jabouille) modify the LES tools
+!! April 3,1997 (Lafore) merging of the nesting
+!! developments on MASTER3
+!! Jul. 8,1997 (Lafore) print control for nesting (NVERB>=7)
+!! Jul. 28,1997 (Masson) supress LSTEADY_DMASS
+!! Aug. 19,1997 (Lafore) full Clark's formulation introduction
+!! Sept 26,1997 (Lafore) LS source calculation at restart
+!! (temporarily test to have LS at instant t)
+!! Jan. 28,1998 (Bechtold) add SST forcing
+!! fev. 10,1998 (Lafore) RHODJ computation and storage for budget
+!! Jul. 10,1998 (Stein ) sequentiel loop for nesting
+!! Apr. 07,1999 (Stein ) cleaning of the nesting subroutines
+!! oct. 20,1998 (Jabouille) //
+!! oct. 20,2000 (J.-P. Pinty) add the C2R2 scheme
+!! fev. 01,2001 (D.Gazen) add module MODD_NSV for NSV variables
+!! mar, 4,2002 (V.Ducrocq) call to temporal series
+!! mar, 8, 2001 (V. Masson) advection of perturbation of theta in neutral cases.
+!! Nov, 6, 2002 (V. Masson) time counters for budgets & LES
+!! mars 20,2001 (Pinty) add ICE4 and C3R5 options
+!! jan. 2004 (Masson) surface externalization
+!! sept 2004 (M. Tomasini) Cloud mixing length modification
+!! june 2005 (P. Tulet) add aerosols / dusts
+!! Jul. 2005 (N. Asencio) two_way and phys_param calls:
+!! Add the surface parameters : precipitating
+!! hydrometeors, Short and Long Wave , MASKkids array
+!! Fev. 2006 (M. Leriche) add aqueous phase chemistry
+!! april 2006 (T.Maric) Add halo related to 4th order advection scheme
+!! May 2006 Remove KEPS
+!! Oct 2008 (C.Lac) FIT for variables advected with PPM
+!! July 2009 : Displacement of surface diagnostics call to be
+!! coherent with surface diagnostics obtained with DIAG
+!! 10/11/2009 (P. Aumond) Add mean moments
+!! Nov, 12, 2009 (C. Barthe) add cloud electrification and lightning flashes
+!! July 2010 (M. Leriche) add ice phase chemical species
+!! April 2011 (C.Lac) : Remove instant M
+!! April 2011 (C.Lac, V.Masson) : Time splitting for advection
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+!! P. Tulet Nov 2014 accumulated moles of aqueous species that fall at the surface
+!! Dec 2014 (C.Lac) : For reproducibility START/RESTA
+!! J.Escobar 20/04/2015: missing UPDATE_HALO before UPDATE_HALO2
+!! July, 2015 (O.Nuissier/F.Duffourg) Add microphysics diagnostic for
+!! aircraft, ballon and profiler
+!! C.Lac 11/09/2015: correction of the budget due to FIT temporal scheme
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! Sep 2015 (S. Bielli) : Remove YDADFILE from argument call
+! of write_phys_param
+!! J.Escobar : 19/04/2016 : Pb IOZ/NETCDF , missing OPARALLELIO=.FALSE. for PGD files
+!! M.Mazoyer : 04/2016 DTHRAD used for radiative cooling when LACTIT
+!!! Modification 01/2016 (JP Pinty) Add LIMA
+!! 06/2016 (G.Delautier) phasage surfex 8
+!! M.Leriche : 03/2016 Move computation of accumulated chem. in rain to ch_monitor
+!! 09/2016 Add filter on negative values on AERDEP SV before relaxation
+!! 10/2016 (C.Lac) _ Correction on the flag for Strang splitting
+!! to insure reproducibility between START and RESTA
+!! _ Add OSPLIT_WENO
+!! _ Add droplet deposition
+!! 10/2016 (M.Mazoyer) New KHKO output fields
+!! P.Wautelet : 11/07/2016 : removed MNH_NCWRIT define
+!! 09/2017 Q.Rodier add LTEND_UV_FRC
+!! 10/2017 (C.Lac) Necessity to have chemistry processes as
+!! the las process modifying XRSVS
+!! 01/2018 (G.Delautier) SURFEX 8.1
+!! 03/2018 (P.Wautelet) replace ADD_FORECAST_TO_DATE by DATETIME_CORRECTDATE
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! 07/2017 (V. Vionnet) : Add blowing snow scheme
+!! S. Riette : 11/2016 Add ZPABST to keep pressure constant during timestep
+!! 01/2018 (C.Lac) Add VISCOSITY
+!! Philippe Wautelet: 21/01/2019: add LIO_ALLOW_NO_BACKUP and LIO_NO_WRITE to modd_io_ll
+! to allow to disable writes (for bench purposes)
+! P. Wautelet 07/02/2019: remove OPARALLELIO argument from open and close files subroutines
+! (nsubfiles_ioz is now determined in IO_File_add2list)
+!! 02/2019 C.Lac add rain fraction as an output field
+!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 28/03/2019: use MNHTIME for time measurement variables
+! P. Wautelet 28/03/2019: use TFILE instead of unit number for set_iluout_timing
+! P. Wautelet 19/04/2019: removed unused dummy arguments and variables
+! P. Wautelet 26/04/2019: replace non-standard FLOAT function by REAL function
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+! J. Escobar 09/07/2019: norme Doctor -> Rename Module Type variable TZ -> T
+! J. Escobar 09/07/2019: for bug in management of XLSZWSM variable, add/use specific 2D TLSFIELD2D_ll pointer
+! P. Wautelet 23/07/2019: OpenACC: move data creations from resolved_cloud to modeln and optimize updates
+! J. Escobar 27/09/2019: add missing report timing of RESOLVED_ELEC
+!!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_2D_FRC
+USE MODD_ADV_n
+USE MODD_AIRCRAFT_BALLOON
+USE MODD_BAKOUT
+USE MODD_BIKHARDT_n
+USE MODD_BLANK
+USE MODD_BUDGET
+USE MODD_CH_AERO_n, ONLY: XSOLORG, XMI
+USE MODD_CH_MNHC_n, ONLY: LUSECHEM,LCH_CONV_LINOX,LUSECHAQ,LUSECHIC, &
+ LCH_INIT_FIELD
+USE MODD_CLOUD_MF_n
+USE MODD_VISCOSITY
+USE MODD_DRAG_n
+USE MODD_CLOUDPAR_n
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CURVCOR_n
+USE MODD_DEEP_CONVECTION_n
+USE MODD_DIM_n
+USE MODD_DUST, ONLY: LDUST
+USE MODD_DYN
+USE MODD_DYN_n
+USE MODD_DYNZD
+USE MODD_DYNZD_n
+USE MODD_ELEC_DESCR
+USE MODD_FIELD_n
+USE MODD_FRC
+USE MODD_FRC_n
+USE MODD_GET_n
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_GRID_n
+USE MODD_ICE_C1R3_DESCR, ONLY: XRTMIN_C1R3=>XRTMIN
+USE MODD_IO, ONLY: LIO_NO_WRITE, TFILEDATA, TFILE_SURFEX, TFILE_DUMMY
+USE MODD_LBC_n
+USE MODD_LES
+USE MODD_LES_BUDGET
+USE MODD_LIMA_PRECIP_SCAVENGING_n
+USE MODD_LSFIELD_n
+USE MODD_LUNIT, ONLY: TLUOUT0,TOUTDATAFILE
+USE MODD_LUNIT_n, ONLY: TDIAFILE,TINIFILE,TINIFILEPGD,TLUOUT
+USE MODD_MEAN_FIELD
+USE MODD_MEAN_FIELD_n
+USE MODD_METRICS_n
+USE MODD_MNH_SURFEX_n
+USE MODD_NESTING
+USE MODD_NSV
+USE MODD_NUDGING_n
+USE MODD_OUT_n
+USE MODD_PARAM_C1R3, ONLY: NSEDI => LSEDI, NHHONI => LHHONI
+USE MODD_PARAM_C2R2, ONLY: NSEDC => LSEDC, NRAIN => LRAIN, NACTIT => LACTIT,LACTTKE,LDEPOC
+USE MODD_PARAMETERS
+USE MODD_PARAM_ICE, ONLY: LWARM,LSEDIC,LCONVHG,LDEPOSC
+USE MODD_PARAM_LIMA, ONLY: MSEDC => LSEDC, MWARM => LWARM, MRAIN => LRAIN, &
+ MACTIT => LACTIT, LSCAV, LCOLD, &
+ MSEDI => LSEDI, MHHONI => LHHONI, LHAIL, &
+ XRTMIN_LIMA=>XRTMIN, MACTTKE=>LACTTKE
+USE MODD_BLOWSNOW_n
+USE MODD_BLOWSNOW
+USE MODD_PARAM_MFSHALL_n
+USE MODD_PARAM_n
+USE MODD_PAST_FIELD_n
+USE MODD_PRECIP_n
+use modd_precision, only: MNHTIME
+USE MODD_PROFILER_n
+USE MODD_RADIATIONS_n, ONLY: XTSRAD,XSCAFLASWD,XDIRFLASWD,XDIRSRFSWD, XAER, XDTHRAD
+USE MODD_RAIN_ICE_DESCR, ONLY: XRTMIN
+USE MODD_REF_n
+USE MODD_SALT, ONLY: LSALT
+USE MODD_SERIES, ONLY: LSERIES
+USE MODD_SERIES_n, ONLY: NFREQSERIES
+USE MODD_STATION_n
+USE MODD_SUB_MODEL_n
+USE MODD_TIME
+USE MODD_TIME_n
+USE MODD_TIMEZ
+USE MODD_TURB_CLOUD, ONLY: NMODEL_CLOUD,CTURBLEN_CLOUD,XCEI
+USE MODD_TURB_n
+!
+USE MODE_DATETIME
+USE MODE_ELEC_ll
+USE MODE_GRIDCART
+USE MODE_GRIDPROJ
+USE MODE_IO_FIELD_WRITE, only: IO_Field_user_write, IO_Fieldlist_write, IO_Header_write
+USE MODE_IO_FILE, only: IO_File_close, IO_File_open
+USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list
+USE MODE_ll
+USE MODE_MNH_TIMING
+USE MODE_MODELN_HANDLER
+USE MODE_MPPDB
+USE MODE_ONE_WAY_n
+!
+USE MODI_ADVECTION_METSV
+USE MODI_ADVECTION_UVW
+USE MODI_ADVECTION_UVW_CEN
+USE MODI_ADV_FORCING_n
+USE MODI_AER_MONITOR_n
+USE MODI_AIRCRAFT_BALLOON
+USE MODI_BLOWSNOW
+USE MODI_BOUNDARIES
+USE MODI_BUDGET_FLAGS
+USE MODI_CART_COMPRESS
+USE MODI_CH_MONITOR_n
+USE MODI_DIAG_SURF_ATM_N
+USE MODI_DYN_SOURCES
+USE MODI_END_DIAG_IN_RUN
+USE MODI_ENDSTEP
+USE MODI_ENDSTEP_BUDGET
+USE MODI_EXCHANGE
+USE MODI_FORCING
+USE MODI_FORC_SQUALL_LINE
+USE MODI_FORC_WIND
+USE MODI_GET_HALO
+USE MODI_GRAVITY_IMPL
+USE MODI_INI_DIAG_IN_RUN
+USE MODI_INI_LG
+USE MODI_INI_MEAN_FIELD
+USE MODI_INITIAL_GUESS
+USE MODI_LES_INI_TIMESTEP_n
+USE MODI_LES_N
+USE MODI_VISCOSITY
+USE MODI_LIMA_PRECIP_SCAVENGING
+USE MODI_LS_COUPLING
+USE MODI_MASK_COMPRESS
+USE MODI_MEAN_FIELD
+USE MODI_MENU_DIACHRO
+USE MODI_MNHGET_SURF_PARAM_n
+USE MODI_MNHWRITE_ZS_DUMMY_n
+USE MODI_NUDGING
+USE MODI_NUM_DIFF
+USE MODI_PHYS_PARAM_n
+USE MODI_PRESSUREZ
+USE MODI_PROFILER_n
+USE MODI_RAD_BOUND
+USE MODI_RELAX2FW_ION
+USE MODI_RELAXATION
+USE MODI_REL_FORCING_n
+USE MODI_RESOLVED_CLOUD
+USE MODI_RESOLVED_ELEC_n
+USE MODI_SERIES_N
+USE MODI_SETLB_LG
+USE MODI_SET_MASK
+USE MODI_SHUMAN
+USE MODI_SPAWN_LS_n
+USE MODI_STATION_n
+USE MODI_TURB_CLOUD_INDEX
+USE MODI_TWO_WAY
+USE MODI_UPDATE_NSV
+USE MODI_WRITE_AIRCRAFT_BALLOON
+USE MODI_WRITE_DESFM_n
+USE MODI_WRITE_DIAG_SURF_ATM_N
+USE MODI_WRITE_LES_n
+USE MODI_WRITE_LFIFM_n
+USE MODI_WRITE_LFIFMN_FORDIACHRO_n
+USE MODI_WRITE_PROFILER_n
+USE MODI_WRITE_SERIES_n
+USE MODI_WRITE_STATION_n
+USE MODI_WRITE_SURF_ATM_N
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KTCOUNT
+LOGICAL, INTENT(INOUT):: OEXIT
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILUOUT ! Logical unit number for the output listing
+INTEGER :: IIU,IJU,IKU ! array size in first, second and third dimensions
+INTEGER :: IIB,IIE,IJB,IJE ! index values for the physical subdomain
+INTEGER :: JSV,JRR ! Loop index for scalar and moist variables
+INTEGER :: INBVAR ! number of HALO2_lls to allocate
+INTEGER :: IINFO_ll ! return code of parallel routine
+INTEGER :: IVERB ! LFI verbosity level
+LOGICAL :: GSTEADY_DMASS ! conditional call to mass computation
+!
+ ! for computing time analysis
+REAL(kind=MNHTIME), DIMENSION(2) :: ZTIME, ZTIME1, ZTIME2, ZEND, ZTOT, ZALL, ZTOT_PT
+REAL(kind=MNHTIME), DIMENSION(2) :: ZTIME_STEP,ZTIME_STEP_PTS
+CHARACTER :: YMI
+INTEGER :: IPOINTS
+CHARACTER(len=16) :: YTCOUNT,YPOINTS
+!
+INTEGER :: ISYNCHRO ! model synchronic index relative to its father
+ ! = 1 for the first time step in phase with DAD
+ ! = 0 for the last time step (out of phase)
+INTEGER :: IMI ! Current model index
+REAL, DIMENSION(:,:),ALLOCATABLE :: ZSEA
+REAL, DIMENSION(:,:),ALLOCATABLE :: ZTOWN
+! Dummy pointers needed to correct an ifort Bug
+REAL, DIMENSION(:), POINTER :: DPTR_XZHAT
+REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSM,DPTR_XLSZWSS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUS,DPTR_XLBYUS,DPTR_XLBXVS,DPTR_XLBYVS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWS,DPTR_XLBYWS,DPTR_XLBXTHS,DPTR_XLBYTHS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKES,DPTR_XLBYTKES
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRS,DPTR_XLBYRS,DPTR_XLBXSVS,DPTR_XLBYSVS
+!
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XRHODJ,DPTR_XUM,DPTR_XVM,DPTR_XWM,DPTR_XTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XTKEM,DPTR_XRUS,DPTR_XRVS,DPTR_XRWS,DPTR_XRTHS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XRTKES,DPTR_XDIRFLASWD,DPTR_XSCAFLASWD,DPTR_XDIRSRFSWD
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XRM,DPTR_XSVM,DPTR_XRRS,DPTR_XRSVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XINPRC,DPTR_XINPRR,DPTR_XINPRS,DPTR_XINPRG
+REAL, DIMENSION(:,:), POINTER :: DPTR_XINPRH,DPTR_XPRCONV,DPTR_XPRSCONV
+LOGICAL, DIMENSION(:,:),POINTER :: DPTR_GMASKkids
+!
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDC
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDR
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDS
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDG
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDH
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRC3D
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRS3D
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRG3D
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRH3D
+!
+LOGICAL :: KWARM
+LOGICAL :: KRAIN
+LOGICAL :: KSEDC
+LOGICAL :: KACTIT
+LOGICAL :: KSEDI
+LOGICAL :: KHHONI
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRUS,ZRVS,ZRWS
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZPABST !To give pressure at t
+ ! (and not t+1) to resolved_cloud
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ
+!
+TYPE(LIST_ll), POINTER :: TZFIELDC_ll ! list of fields to exchange
+TYPE(HALO2LIST_ll), POINTER :: TZHALO2C_ll ! list of fields to exchange
+LOGICAL :: GCLD ! conditionnal call for dust wet deposition
+LOGICAL :: GCLOUD_ONLY ! conditionnal radiation computations for
+ ! the only cloudy columns
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZWETDEPAER
+
+
+!
+TYPE(TFILEDATA),POINTER :: TZBAKFILE, TZOUTFILE
+! TYPE(TFILEDATA),SAVE :: TZDIACFILE
+!-------------------------------------------------------------------------------
+!
+TZBAKFILE=> NULL()
+TZOUTFILE=> NULL()
+
+allocate( ZRUS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZRVS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZRWS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZPABST(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZJ (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZWETDEPAER(SIZE(XRSVS,1), SIZE(XRSVS,2), SIZE(XRSVS,3), NSV_AER) )
+
+!$acc data create( zrws )
+
+!
+!* 0. MICROPHYSICAL SCHEME
+! -------------------
+SELECT CASE(CCLOUD)
+CASE('C2R2','KHKO','C3R5')
+ KWARM = .TRUE.
+ KRAIN = NRAIN
+ KSEDC = NSEDC
+ KACTIT = NACTIT
+!
+ KSEDI = NSEDI
+ KHHONI = NHHONI
+CASE('LIMA')
+ KWARM = MWARM
+ KRAIN = MRAIN
+ KSEDC = MSEDC
+ KACTIT = MACTIT
+!
+ KSEDI = MSEDI
+ KHHONI = MHHONI
+CASE('ICE3','ICE4') !default values
+ KWARM = LWARM
+ KRAIN = .TRUE.
+ KSEDC = .TRUE.
+ KACTIT = .FALSE.
+!
+ KSEDI = .TRUE.
+ KHHONI = .FALSE.
+END SELECT
+!
+!
+!* 1 PRELIMINARY
+! ------------
+IMI = GET_CURRENT_MODEL_INDEX()
+!
+!* 1.0 update NSV_* variables for current model
+! ----------------------------------------
+!
+CALL UPDATE_NSV(IMI)
+!
+!* 1.1 RECOVER THE LOGICAL UNIT NUMBER FOR THE OUTPUT PRINTS
+!
+ILUOUT = TLUOUT%NLU
+!
+!* 1.2 SET ARRAY SIZE
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+IKU=NKMAX+2*JPVEXT
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+!
+IF (IMI==1) THEN
+ GSTEADY_DMASS=LSTEADYLS
+ELSE
+ GSTEADY_DMASS=.FALSE.
+END IF
+!
+!* 1.3 OPEN THE DIACHRONIC FILE
+!
+IF (KTCOUNT == 1) THEN
+!
+ NULLIFY(TFIELDS_ll,TLSFIELD_ll,TFIELDT_ll)
+ NULLIFY(TLSFIELD2D_ll)
+ NULLIFY(THALO2T_ll)
+ NULLIFY(TLSHALO2_ll)
+ NULLIFY(TFIELDSC_ll)
+!
+ ALLOCATE(XWT_ACT_NUC(SIZE(XWT,1),SIZE(XWT,2),SIZE(XWT,3)))
+ ALLOCATE(GMASKkids(SIZE(XWT,1),SIZE(XWT,2)))
+!
+! initialization of the FM file backup/output number
+ IBAK=0
+ IOUT=0
+!
+ IF ( .NOT. LIO_NO_WRITE ) THEN
+ CALL IO_File_open(TDIAFILE)
+!
+ CALL IO_Header_write(TDIAFILE)
+ CALL WRITE_DESFM_n(IMI,TDIAFILE)
+ CALL WRITE_LFIFMN_FORDIACHRO_n(TDIAFILE)
+ END IF
+!
+!* 1.4 Initialization of the list of fields for the halo updates
+!
+! a) Sources terms
+!
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRUS, 'MODEL_n::XRUS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRVS, 'MODEL_n::XRVS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRWS, 'MODEL_n::XRWS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRTHS, 'MODEL_n::XRTHS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRUS_PRES, 'MODEL_n::XRUS_PRES' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRVS_PRES, 'MODEL_n::XRVS_PRES' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRWS_PRES, 'MODEL_n::XRWS_PRES' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRTHS_CLD, 'MODEL_n::XRTHS_CLD' )
+ IF (SIZE(XRTKES,1) /= 0) CALL ADD3DFIELD_ll( TFIELDS_ll, XRTKES, 'MODEL_n::XRTKES' )
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRRS (:,:,:,1:NRR), 'MODEL_n::XRRS' )
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRRS_CLD (:,:,:,1:NRR), 'MODEL_n::XRRS_CLD' )
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRSVS (:,:,:,1:NSV), 'MODEL_n::XRSVS')
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRSVS_CLD(:,:,:,1:NSV), 'MODEL_n::XRSVS_CLD')
+ IF (SIZE(XSRCT,1) /= 0) CALL ADD3DFIELD_ll( TFIELDS_ll, XSRCT, 'MODEL_n::XSRCT' )
+ !
+ IF ((LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV) ) THEN
+ !
+ ! b) LS fields
+ !
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSUM, 'MODEL_n::XLSUM' )
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSVM, 'MODEL_n::XLSVM' )
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSWM, 'MODEL_n::XLSWM' )
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSTHM, 'MODEL_n::XLSTHM' )
+ CALL ADD2DFIELD_ll( TLSFIELD2D_ll, XLSZWSM, 'MODEL_n::XLSZWSM' )
+ IF (NRR >= 1) THEN
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSRVM, 'MODEL_n::XLSRVM' )
+ ENDIF
+ !
+ ! c) Fields at t
+ !
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XUT, 'MODEL_n::XUT' )
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XVT, 'MODEL_n::XVT' )
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XWT, 'MODEL_n::XWT' )
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XTHT, 'MODEL_n::XTHT' )
+ IF (SIZE(XRTKES,1) /= 0) CALL ADD3DFIELD_ll( TFIELDT_ll, XTKET, 'MODEL_n::XTKET' )
+ CALL ADD4DFIELD_ll(TFIELDT_ll, XRT (:,:,:,1:NRR), 'MODEL_n::XSV' )
+ CALL ADD4DFIELD_ll(TFIELDT_ll, XSVT(:,:,:,1:NSV), 'MODEL_n::XSVT' )
+ !
+ !* 1.5 Initialize the list of fields for the halo updates (2nd layer)
+ !
+ INBVAR = 4+NRR+NSV
+ IF (SIZE(XRTKES,1) /= 0) INBVAR=INBVAR+1
+ CALL INIT_HALO2_ll(THALO2T_ll,INBVAR,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TLSHALO2_ll,4+MIN(1,NRR),IIU,IJU,IKU)
+ !
+ !* 1.6 Initialise the 2nd layer of the halo of the LS fields
+ !
+ IF ( LSTEADYLS ) THEN
+ CALL UPDATE_HALO_ll(TLSFIELD_ll, IINFO_ll)
+ CALL UPDATE_HALO_ll(TLSFIELD2D_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TLSFIELD_ll, TLSHALO2_ll, IINFO_ll)
+ END IF
+ END IF
+ !
+!
+ !
+ XT_START = 0.0_MNHTIME
+ !
+ XT_STORE = 0.0_MNHTIME
+ XT_BOUND = 0.0_MNHTIME
+ XT_GUESS = 0.0_MNHTIME
+ XT_FORCING = 0.0_MNHTIME
+ XT_NUDGING = 0.0_MNHTIME
+ XT_ADV = 0.0_MNHTIME
+ XT_ADVUVW = 0.0_MNHTIME
+ XT_GRAV = 0.0_MNHTIME
+ XT_SOURCES = 0.0_MNHTIME
+ !
+ XT_DIFF = 0.0_MNHTIME
+ XT_RELAX = 0.0_MNHTIME
+ XT_PARAM = 0.0_MNHTIME
+ XT_SPECTRA = 0.0_MNHTIME
+ XT_HALO = 0.0_MNHTIME
+ XT_VISC = 0.0_MNHTIME
+ XT_RAD_BOUND = 0.0_MNHTIME
+ XT_PRESS = 0.0_MNHTIME
+ !
+ XT_CLOUD = 0.0_MNHTIME
+ XT_STEP_SWA = 0.0_MNHTIME
+ XT_STEP_MISC = 0.0_MNHTIME
+ XT_COUPL = 0.0_MNHTIME
+ XT_1WAY = 0.0_MNHTIME
+ XT_STEP_BUD = 0.0_MNHTIME
+ !
+ XT_RAD = 0.0_MNHTIME
+ XT_DCONV = 0.0_MNHTIME
+ XT_GROUND = 0.0_MNHTIME
+ XT_TURB = 0.0_MNHTIME
+ XT_MAFL = 0.0_MNHTIME
+ XT_DRAG = 0.0_MNHTIME
+ XT_TRACER = 0.0_MNHTIME
+ XT_SHADOWS = 0.0_MNHTIME
+ XT_ELEC = 0.0_MNHTIME
+ XT_CHEM = 0.0_MNHTIME
+ XT_2WAY = 0.0_MNHTIME
+ !
+END IF
+!
+!* 1.7 Allocation of arrays for observation diagnostics
+!
+CALL INI_DIAG_IN_RUN(IIU,IJU,IKU,LFLYER,LSTATION,LPROFILER)
+!
+!
+CALL SECOND_MNH2(ZEND)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ONE-WAY NESTING AND LARGE SCALE FIELD REFRESH
+! ---------------------------------------------
+!
+!
+CALL SECOND_MNH2(ZTIME1)
+!
+ISYNCHRO = MODULO (KTCOUNT, NDTRATIO(IMI) ) ! test of synchronisation
+!
+
+
+IF (IMI/=1 .AND. NDAD(IMI)/=IMI .AND. (ISYNCHRO==1 .OR. NDTRATIO(IMI) == 1) ) THEN
+!
+ ! Use dummy pointers to correct an ifort BUG
+ DPTR_XBMX1=>XBMX1
+ DPTR_XBMX2=>XBMX2
+ DPTR_XBMX3=>XBMX3
+ DPTR_XBMX4=>XBMX4
+ DPTR_XBMY1=>XBMY1
+ DPTR_XBMY2=>XBMY2
+ DPTR_XBMY3=>XBMY3
+ DPTR_XBMY4=>XBMY4
+ DPTR_XBFX1=>XBFX1
+ DPTR_XBFX2=>XBFX2
+ DPTR_XBFX3=>XBFX3
+ DPTR_XBFX4=>XBFX4
+ DPTR_XBFY1=>XBFY1
+ DPTR_XBFY2=>XBFY2
+ DPTR_XBFY3=>XBFY3
+ DPTR_XBFY4=>XBFY4
+ DPTR_CLBCX=>CLBCX
+ DPTR_CLBCY=>CLBCY
+ !
+ DPTR_XZZ=>XZZ
+ DPTR_XZHAT=>XZHAT
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_XLSTHM=>XLSTHM
+ DPTR_XLSRVM=>XLSRVM
+ DPTR_XLSUM=>XLSUM
+ DPTR_XLSVM=>XLSVM
+ DPTR_XLSWM=>XLSWM
+ DPTR_XLSZWSM=>XLSZWSM
+ DPTR_XLSTHS=>XLSTHS
+ DPTR_XLSRVS=>XLSRVS
+ DPTR_XLSUS=>XLSUS
+ DPTR_XLSVS=>XLSVS
+ DPTR_XLSWS=>XLSWS
+ DPTR_XLSZWSS=>XLSZWSS
+ !
+ IF ( LSTEADYLS ) THEN
+ NCPL_CUR=0
+ ELSE
+ IF (NCPL_CUR/=1) THEN
+ IF ( KTCOUNT+1 == NCPL_TIMES(NCPL_CUR-1,IMI) ) THEN
+ !
+ ! LS sources are interpolated from the LS field
+ ! values of model DAD(IMI)
+ CALL SPAWN_LS_n(NDAD(IMI),XTSTEP,IMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(IMI),NDYRATIO_ALL(IMI), &
+ DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT,LSLEVE,XLEN1,XLEN2,DPTR_XCOEFLIN_LBXM, &
+ DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSZWSM, &
+ DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS, DPTR_XLSZWSS )
+ END IF
+ END IF
+ !
+ END IF
+ !
+ DPTR_NKLIN_LBXU=>NKLIN_LBXU
+ DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU
+ DPTR_NKLIN_LBYU=>NKLIN_LBYU
+ DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU
+ DPTR_NKLIN_LBXV=>NKLIN_LBXV
+ DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV
+ DPTR_NKLIN_LBYV=>NKLIN_LBYV
+ DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV
+ DPTR_NKLIN_LBXW=>NKLIN_LBXW
+ DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW
+ DPTR_NKLIN_LBYW=>NKLIN_LBYW
+ DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW
+ !
+ DPTR_NKLIN_LBXM=>NKLIN_LBXM
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_NKLIN_LBYM=>NKLIN_LBYM
+ DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM
+ !
+ DPTR_XLBXUM=>XLBXUM
+ DPTR_XLBYUM=>XLBYUM
+ DPTR_XLBXVM=>XLBXVM
+ DPTR_XLBYVM=>XLBYVM
+ DPTR_XLBXWM=>XLBXWM
+ DPTR_XLBYWM=>XLBYWM
+ DPTR_XLBXTHM=>XLBXTHM
+ DPTR_XLBYTHM=>XLBYTHM
+ DPTR_XLBXTKEM=>XLBXTKEM
+ DPTR_XLBYTKEM=>XLBYTKEM
+ DPTR_XLBXRM=>XLBXRM
+ DPTR_XLBYRM=>XLBYRM
+ DPTR_XLBXSVM=>XLBXSVM
+ DPTR_XLBYSVM=>XLBYSVM
+ !
+ DPTR_XLBXUS=>XLBXUS
+ DPTR_XLBYUS=>XLBYUS
+ DPTR_XLBXVS=>XLBXVS
+ DPTR_XLBYVS=>XLBYVS
+ DPTR_XLBXWS=>XLBXWS
+ DPTR_XLBYWS=>XLBYWS
+ DPTR_XLBXTHS=>XLBXTHS
+ DPTR_XLBYTHS=>XLBYTHS
+ DPTR_XLBXTKES=>XLBXTKES
+ DPTR_XLBYTKES=>XLBYTKES
+ DPTR_XLBXRS=>XLBXRS
+ DPTR_XLBYRS=>XLBYRS
+ DPTR_XLBXSVS=>XLBXSVS
+ DPTR_XLBYSVS=>XLBYSVS
+ !
+ CALL ONE_WAY_n(NDAD(IMI),XTSTEP,IMI,KTCOUNT, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(IMI),NDYRATIO_ALL(IMI),NDTRATIO(IMI), &
+ DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, &
+ GSTEADY_DMASS,CCLOUD,LUSECHAQ,LUSECHIC, &
+ DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, &
+ DPTR_XLBXTHM,DPTR_XLBYTHM, &
+ DPTR_XLBXTKEM,DPTR_XLBYTKEM, &
+ DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM, &
+ XDRYMASST,XDRYMASSS, &
+ DPTR_XLBXUS,DPTR_XLBYUS,DPTR_XLBXVS,DPTR_XLBYVS,DPTR_XLBXWS,DPTR_XLBYWS, &
+ DPTR_XLBXTHS,DPTR_XLBYTHS, &
+ DPTR_XLBXTKES,DPTR_XLBYTKES, &
+ DPTR_XLBXRS,DPTR_XLBYRS,DPTR_XLBXSVS,DPTR_XLBYSVS )
+ !
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+XT_1WAY = XT_1WAY + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. LATERAL BOUNDARY CONDITIONS EXCEPT FOR NORMAL VELOCITY
+! ------------------------------------------------------
+!
+ZTIME1=ZTIME2
+!
+!* 3.1 Set the lagragian variables values at the LB
+!
+IF( LLG .AND. IMI==1 ) CALL SETLB_LG
+!
+IF (CCONF == "START" .OR. (CCONF == "RESTA" .AND. KTCOUNT /= 1 )) THEN
+CALL BOUNDARIES ( &
+ XTSTEP,CLBCX,CLBCY,NRR,NSV,KTCOUNT, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS, &
+ XRHODJ, &
+ XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, XSRCT )
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_BOUND = XT_BOUND + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!* initializes surface number
+IF (CSURF=='EXTE') CALL GOTO_SURFEX(IMI)
+!-------------------------------------------------------------------------------
+!
+!* 4. STORAGE IN A SYNCHRONOUS FILE
+! -----------------------------
+!
+ZTIME1 = ZTIME2
+!
+IF (IBAK < NBAK_NUMB ) THEN
+ IF (KTCOUNT == TBACKUPN(IBAK+1)%NSTEP) THEN
+ IBAK=IBAK+1
+ GCLOSE_OUT=.TRUE.
+ !
+ TZBAKFILE => TBACKUPN(IBAK)%TFILE
+ IVERB = TZBAKFILE%NLFIVERB
+ !
+ CALL IO_File_open(TZBAKFILE)
+ !
+ CALL WRITE_DESFM_n(IMI,TZBAKFILE)
+ CALL IO_Header_write(TBACKUPN(IBAK)%TFILE)
+ CALL WRITE_LFIFM_n(TBACKUPN(IBAK)%TFILE,TBACKUPN(IBAK)%TFILE%TDADFILE%CNAME)
+ TOUTDATAFILE => TZBAKFILE
+ CALL MNHWRITE_ZS_DUMMY_n(TZBAKFILE)
+ IF (CSURF=='EXTE') THEN
+ TFILE_SURFEX => TZBAKFILE
+ CALL GOTO_SURFEX(IMI)
+ CALL WRITE_SURF_ATM_n(YSURF_CUR,'MESONH','ALL',.FALSE.)
+ NULLIFY(TFILE_SURFEX)
+ END IF
+ !
+ ! Reinitialize Lagragian variables at every model backup
+ IF (LLG .AND. LINIT_LG .AND. CINIT_LG=='FMOUT') THEN
+ CALL INI_LG(XXHAT,XYHAT,XZZ,XSVT,XLBXSVM,XLBYSVM)
+ IF (IVERB>=5) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) '************************************'
+ WRITE(UNIT=ILUOUT,FMT=*) '*** Lagrangian variables refreshed after ',TRIM(TZBAKFILE%CNAME),' backup'
+ WRITE(UNIT=ILUOUT,FMT=*) '************************************'
+ END IF
+ END IF
+ ! Reinitialise mean variables
+ IF (LMEAN_FIELD) THEN
+ CALL INI_MEAN_FIELD
+ END IF
+!
+ ELSE
+ !Necessary to have a 'valid' CNAME when calling some subroutines
+ TZBAKFILE => TFILE_DUMMY
+ END IF
+ELSE
+ !Necessary to have a 'valid' CNAME when calling some subroutines
+ TZBAKFILE => TFILE_DUMMY
+END IF
+!
+IF (IOUT < NOUT_NUMB ) THEN
+ IF (KTCOUNT == TOUTPUTN(IOUT+1)%NSTEP) THEN
+ IOUT=IOUT+1
+ !
+ TZOUTFILE => TOUTPUTN(IOUT)%TFILE
+ !
+ CALL IO_File_open(TZOUTFILE)
+ !
+ CALL IO_Header_write(TZOUTFILE)
+ CALL IO_Fieldlist_write(TOUTPUTN(IOUT))
+ CALL IO_Field_user_write(TOUTPUTN(IOUT))
+ !
+ CALL IO_File_close(TZOUTFILE)
+ !
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STORE = XT_STORE + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. INITIALIZATION OF THE BUDGET VARIABLES
+! --------------------------------------
+!
+IF (NBUMOD==IMI) THEN
+ LBU_ENABLE = CBUTYPE /='NONE'.AND. CBUTYPE /='SKIP'
+ELSE
+ LBU_ENABLE = .FALSE.
+END IF
+!
+IF (NBUMOD==IMI .AND. CBUTYPE=='MASK' ) THEN
+ CALL SET_MASK
+ IF (LBU_RU) XBURHODJU(:,NBUTIME,:) = XBURHODJU(:,NBUTIME,:) &
+ + MASK_COMPRESS(MXM(XRHODJ))
+ IF (LBU_RV) XBURHODJV(:,NBUTIME,:) = XBURHODJV(:,NBUTIME,:) &
+ + MASK_COMPRESS(MYM(XRHODJ))
+ IF (LBU_RW) XBURHODJW(:,NBUTIME,:) = XBURHODJW(:,NBUTIME,:) &
+ + MASK_COMPRESS(MZM(XRHODJ))
+ IF (ALLOCATED(XBURHODJ)) &
+ XBURHODJ (:,NBUTIME,:) = XBURHODJ (:,NBUTIME,:) &
+ + MASK_COMPRESS(XRHODJ)
+END IF
+!
+IF (NBUMOD==IMI .AND. CBUTYPE=='CART' ) THEN
+ IF (LBU_RU) XBURHODJU(:,:,:) = XBURHODJU(:,:,:) &
+ + CART_COMPRESS(MXM(XRHODJ))
+ IF (LBU_RV) XBURHODJV(:,:,:) = XBURHODJV(:,:,:) &
+ + CART_COMPRESS(MYM(XRHODJ))
+ IF (LBU_RW) XBURHODJW(:,:,:) = XBURHODJW(:,:,:) &
+ + CART_COMPRESS(MZM(XRHODJ))
+ IF (ALLOCATED(XBURHODJ)) &
+ XBURHODJ (:,:,:) = XBURHODJ (:,:,:) &
+ + CART_COMPRESS(XRHODJ)
+END IF
+!
+CALL BUDGET_FLAGS(LUSERV, LUSERC, LUSERR, &
+ LUSERI, LUSERS, LUSERG, LUSERH )
+!
+XTIME_BU = 0.0
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. INITIALIZATION OF THE FIELD TENDENCIES
+! --------------------------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+!
+CALL INITIAL_GUESS ( NRR, NSV, KTCOUNT, XRHODJ,IMI, XTSTEP, &
+ XRUS, XRVS, XRWS, XRTHS, XRRS, XRTKES, XRSVS, &
+ XUT, XVT, XWT, XTHT, XRT, XTKET, XSVT )
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_GUESS = XT_GUESS + ZTIME2 - ZTIME1 - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. INITIALIZATION OF THE LES FOR CURRENT TIME-STEP
+! -----------------------------------------------
+!
+XTIME_LES_BU = 0.0
+XTIME_LES = 0.0
+IF (LLES) CALL LES_INI_TIMESTEP_n(KTCOUNT)
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. TWO-WAY INTERACTIVE GRID-NESTING
+! --------------------------------
+!
+!
+CALL SECOND_MNH2(ZTIME1)
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+GMASKkids(:,:)=.FALSE.
+!
+IF (NMODEL>1) THEN
+ ! correct an ifort bug
+ DPTR_XRHODJ=>XRHODJ
+ DPTR_XUM=>XUT
+ DPTR_XVM=>XVT
+ DPTR_XWM=>XWT
+ DPTR_XTHM=>XTHT
+ DPTR_XRM=>XRT
+ DPTR_XTKEM=>XTKET
+ DPTR_XSVM=>XSVT
+ DPTR_XRUS=>XRUS
+ DPTR_XRVS=>XRVS
+ DPTR_XRWS=>XRWS
+ DPTR_XRTHS=>XRTHS
+ DPTR_XRRS=>XRRS
+ DPTR_XRTKES=>XRTKES
+ DPTR_XRSVS=>XRSVS
+ DPTR_XINPRC=>XINPRC
+ DPTR_XINPRR=>XINPRR
+ DPTR_XINPRS=>XINPRS
+ DPTR_XINPRG=>XINPRG
+ DPTR_XINPRH=>XINPRH
+ DPTR_XPRCONV=>XPRCONV
+ DPTR_XPRSCONV=>XPRSCONV
+ DPTR_XDIRFLASWD=>XDIRFLASWD
+ DPTR_XSCAFLASWD=>XSCAFLASWD
+ DPTR_XDIRSRFSWD=>XDIRSRFSWD
+ DPTR_GMASKkids=>GMASKkids
+ !
+ CALL TWO_WAY( NRR,NSV,KTCOUNT,DPTR_XRHODJ,IMI,XTSTEP, &
+ DPTR_XUM ,DPTR_XVM ,DPTR_XWM , DPTR_XTHM, DPTR_XRM,DPTR_XSVM, &
+ DPTR_XRUS,DPTR_XRVS,DPTR_XRWS,DPTR_XRTHS,DPTR_XRRS,DPTR_XRSVS, &
+ DPTR_XINPRC,DPTR_XINPRR,DPTR_XINPRS,DPTR_XINPRG,DPTR_XINPRH,DPTR_XPRCONV,DPTR_XPRSCONV, &
+ DPTR_XDIRFLASWD,DPTR_XSCAFLASWD,DPTR_XDIRSRFSWD,DPTR_GMASKkids )
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+XT_2WAY = XT_2WAY + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 10. FORCING
+! -------
+!
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+IF (LCARTESIAN) THEN
+ CALL SM_GRIDCART(XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XDXHAT,XDYHAT,XZZ,ZJ)
+ XMAP=1.
+ELSE
+ CALL SM_GRIDPROJ(XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XLATORI,XLONORI, &
+ XMAP,XLAT,XLON,XDXHAT,XDYHAT,XZZ,ZJ)
+END IF
+!
+IF ( LFORCING ) THEN
+ CALL FORCING(XTSTEP,LUSERV,XRHODJ,XCORIOZ,XZHAT,XZZ,TDTCUR,&
+ XUFRC_PAST, XVFRC_PAST, &
+ XUT,XVT,XWT,XTHT,XTKET,XRT,XSVT, &
+ XRUS,XRVS,XRWS,XRTHS,XRTKES,XRRS,XRSVS,IMI,ZJ)
+END IF
+!
+IF ( L2D_ADV_FRC ) THEN
+ CALL ADV_FORCING_n(XRHODJ,TDTCUR,XTHT,XRT,XZZ,XRTHS,XRRS)
+END IF
+IF ( L2D_REL_FRC ) THEN
+ CALL REL_FORCING_n(XRHODJ,TDTCUR,XTHT,XRT,XZZ,XRTHS,XRRS)
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_FORCING = XT_FORCING + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 11. NUDGING
+! -------
+!
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF ( LNUDGING ) THEN
+ CALL NUDGING(LUSERV,XRHODJ,XTNUDGING, &
+ XUT,XVT,XWT,XTHT,XRT, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM, &
+ XRUS,XRVS,XRWS,XRTHS,XRRS)
+
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_NUDGING = XT_NUDGING + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 12. DYNAMICAL SOURCES
+! -----------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF( LTRANS ) THEN
+ XUT(:,:,:) = XUT(:,:,:) + XUTRANS
+ XVT(:,:,:) = XVT(:,:,:) + XVTRANS
+END IF
+!
+CALL DYN_SOURCES( NRR,NRRL, NRRI, &
+ XUT, XVT, XWT, XTHT, XRT, &
+ XCORIOX, XCORIOY, XCORIOZ, XCURVX, XCURVY, &
+ XRHODJ, XZZ, XTHVREF, XEXNREF, &
+ XRUS, XRVS, XRWS, XRTHS )
+!
+IF( LTRANS ) THEN
+ XUT(:,:,:) = XUT(:,:,:) - XUTRANS
+ XVT(:,:,:) = XVT(:,:,:) - XVTRANS
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_SOURCES = XT_SOURCES + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 13. NUMERICAL DIFFUSION
+! -------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF ( LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV ) THEN
+!
+ CALL UPDATE_HALO_ll(TFIELDT_ll, IINFO_ll)
+ CALL UPDATE_HALO2_ll(TFIELDT_ll, THALO2T_ll, IINFO_ll)
+ IF ( .NOT. LSTEADYLS ) THEN
+ CALL UPDATE_HALO_ll(TLSFIELD_ll, IINFO_ll)
+ CALL UPDATE_HALO_ll(TLSFIELD2D_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TLSFIELD_ll, TLSHALO2_ll, IINFO_ll)
+ END IF
+ CALL NUM_DIFF ( CLBCX, CLBCY, NRR, NSV, &
+ XDK2U, XDK4U, XDK2TH, XDK4TH, XDK2SV, XDK4SV, IMI, &
+ XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XRHODJ, &
+ XRUS, XRVS, XRWS, XRTHS, XRTKES, XRRS, XRSVS, &
+ LZDIFFU,LNUMDIFU, LNUMDIFTH, LNUMDIFSV, &
+ THALO2T_ll, TLSHALO2_ll,XZDIFFU_HALO2 )
+END IF
+!
+DO JSV = NSV_CHEMBEG,NSV_CHEMEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_CHICBEG,NSV_CHICEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_AERBEG,NSV_AEREND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_LNOXBEG,NSV_LNOXEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_DSTBEG,NSV_DSTEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_SLTBEG,NSV_SLTEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_PPBEG,NSV_PPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+#ifdef MNH_FOREFIRE
+DO JSV = NSV_FFBEG,NSV_FFEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+#endif
+DO JSV = NSV_CSBEG,NSV_CSEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_DSTDEPBEG,NSV_DSTDEPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_SLTDEPBEG,NSV_SLTDEPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_AERDEPBEG,NSV_AERDEPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_SNWBEG,NSV_SNWEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+IF (CELEC .NE. 'NONE') THEN
+ XRSVS(:,:,:,NSV_ELECBEG) = MAX(XRSVS(:,:,:,NSV_ELECBEG),0.)
+ XRSVS(:,:,:,NSV_ELECEND) = MAX(XRSVS(:,:,:,NSV_ELECEND),0.)
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_DIFF = XT_DIFF + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 14. UPPER AND LATERAL RELAXATION
+! ----------------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF(LVE_RELAX .OR. LVE_RELAX_GRD .OR. LHORELAX_UVWTH .OR. LHORELAX_RV .OR.&
+ LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. &
+ LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. &
+ ANY(LHORELAX_SV)) THEN
+ CALL RELAXATION (LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV,LHORELAX_RC, &
+ LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, &
+ LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, &
+ LHORELAX_SVC2R2,LHORELAX_SVC1R3, &
+ LHORELAX_SVELEC,LHORELAX_SVLG, &
+ LHORELAX_SVCHEM,LHORELAX_SVCHIC,LHORELAX_SVAER, &
+ LHORELAX_SVDST,LHORELAX_SVSLT,LHORELAX_SVPP, &
+ LHORELAX_SVCS,LHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF, &
+#endif
+ KTCOUNT,NRR,NSV,XTSTEP,XRHODJ, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, &
+ XLSUM, XLSVM, XLSWM, XLSTHM, &
+ XLBXUM, XLBXVM, XLBXWM, XLBXTHM, &
+ XLBXRM, XLBXSVM, XLBXTKEM, &
+ XLBYUM, XLBYVM, XLBYWM, XLBYTHM, &
+ XLBYRM, XLBYSVM, XLBYTKEM, &
+ NALBOT, XALK, XALKW, &
+ NALBAS, XALKBAS, XALKWBAS, &
+ LMASK_RELAX,XKURELAX, XKVRELAX, XKWRELAX, &
+ NRIMX,NRIMY, &
+ XRUS, XRVS, XRWS, XRTHS, XRRS, XRSVS, XRTKES )
+END IF
+
+IF (CELEC.NE.'NONE' .AND. LRELAX2FW_ION) THEN
+ CALL RELAX2FW_ION (KTCOUNT, IMI, XTSTEP, XRHODJ, XSVT, NALBOT, &
+ XALK, LMASK_RELAX, XKWRELAX, XRSVS )
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_RELAX = XT_RELAX + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 15. PARAMETRIZATIONS' MONITOR
+! -------------------------
+!
+ZTIME1 = ZTIME2
+!
+CALL PHYS_PARAM_n(KTCOUNT,TZBAKFILE, GCLOSE_OUT, &
+ XT_RAD,XT_SHADOWS,XT_DCONV,XT_GROUND,XT_MAFL, &
+ XT_DRAG,XT_TURB,XT_TRACER, &
+ ZTIME,ZWETDEPAER,GMASKkids,GCLOUD_ONLY)
+!
+IF (CDCONV/='NONE') THEN
+ XPACCONV = XPACCONV + XPRCONV * XTSTEP
+ IF (LCH_CONV_LINOX) THEN
+ XIC_TOTAL_NUMBER = XIC_TOTAL_NUMBER + XIC_RATE * XTSTEP
+ XCG_TOTAL_NUMBER = XCG_TOTAL_NUMBER + XCG_RATE * XTSTEP
+ END IF
+END IF
+!
+IF (IBAK>0 .AND. IBAK <= NBAK_NUMB ) THEN
+ IF (KTCOUNT == TBACKUPN(IBAK)%NSTEP) THEN
+ IF (CSURF=='EXTE') THEN
+ CALL GOTO_SURFEX(IMI)
+ CALL DIAG_SURF_ATM_n(YSURF_CUR,'MESONH')
+ TFILE_SURFEX => TZBAKFILE
+ CALL WRITE_DIAG_SURF_ATM_n(YSURF_CUR,'MESONH','ALL')
+ NULLIFY(TFILE_SURFEX)
+ END IF
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_PARAM = XT_PARAM + ZTIME2 - ZTIME1 - XTIME_LES - ZTIME
+!
+!-------------------------------------------------------------------------------
+!
+!* 16. TEMPORAL SERIES
+! ---------------
+!
+ZTIME1 = ZTIME2
+!
+IF (LSERIES) THEN
+ IF ( MOD (KTCOUNT-1,NFREQSERIES) == 0 ) CALL SERIES_n
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_MISC = XT_STEP_MISC + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 17. LARGE SCALE FIELD REFRESH
+! -------------------------
+!
+ZTIME1 = ZTIME2
+!
+IF (.NOT. LSTEADYLS) THEN
+ IF ( IMI==1 .AND. &
+ NCPL_CUR < NCPL_NBR ) THEN
+ IF (KTCOUNT+1 == NCPL_TIMES(NCPL_CUR,1) ) THEN
+ ! The next current time reachs a
+ NCPL_CUR=NCPL_CUR+1 ! coupling one, LS sources are refreshed
+ !
+ CALL LS_COUPLING(XTSTEP,GSTEADY_DMASS,CCONF, &
+ CGETTKET, &
+ CGETRVT,CGETRCT,CGETRRT,CGETRIT, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, NSV, &
+ NIMAX_ll,NJMAX_ll, &
+ NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, &
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS )
+ !
+ DO JSV=NSV_CHEMBEG,NSV_CHEMEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_LNOXBEG,NSV_LNOXEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_AERBEG,NSV_AEREND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTBEG,NSV_DSTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTDEPBEG,NSV_DSTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTBEG,NSV_SLTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTDEPBEG,NSV_SLTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_PPBEG,NSV_PPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#ifdef MNH_FOREFIRE
+ DO JSV=NSV_FFBEG,NSV_FFEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#endif
+ DO JSV=NSV_CSBEG,NSV_CSEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SNWBEG,NSV_SNWEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ END IF
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_COUPL = XT_COUPL + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!
+!
+!* 8 Bis . Blowing snow scheme
+! ---------
+!
+IF(LBLOWSNOW) THEN
+ CALL BLOWSNOW(CLBCX,CLBCY,XTSTEP,NRR,XPABST,XTHT,XRT,XZZ,XRHODREF, &
+ XRHODJ,XEXNREF,XRRS,XRTHS,XSVT,XRSVS,XSNWSUBL3D )
+ENDIF
+!
+!-----------------------------------------------------------------------
+!
+!* 8 Ter VISCOSITY (no-slip condition inside)
+! ---------
+!
+!
+IF ( LVISC ) THEN
+!
+ZTIME1 = ZTIME2
+!
+ CALL VISCOSITY(CLBCX, CLBCY, NRR, NSV, XMU_V,XPRANDTL, &
+ LVISC_UVW,LVISC_TH,LVISC_SV,LVISC_R, &
+ LDRAG, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, &
+ XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRUS, XRVS, XRWS, XRTHS, XRRS, XRSVS,XDRAG )
+!
+ENDIF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_VISC = XT_VISC + ZTIME2 - ZTIME1
+!!
+!-------------------------------------------------------------------------------
+!
+!* 9. ADVECTION
+! ---------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+!$acc update device(XRTHS)
+!
+!$acc data create (XUT, XVT, XWT) &
+!$acc & copyin (XTHT, XPABST, XRT, XSVT, XRTHS_CLD, XRRS_CLD, XTHVREF) &
+!$acc & copy (XRRS, XRUS, XRVS, XRWS) &
+!$acc & copy (XRWS_PRES) & !XRWS_PRES copy and not copyout (hidden in UPDATE_HALO)
+!$acc & present(XDXX, XDYY, XDZZ, XDZX, XDZY, XRHODJ)
+!
+!$acc update device(XUT, XVT, XWT, XRHODJ)
+
+!
+!
+!$acc data copyin (XTKET, XRSVS_CLD) &
+!$acc & copy (XRTKES, XRSVS) &
+!$acc & copyout(XRTKEMS)
+CALL ADVECTION_METSV ( TZBAKFILE, GCLOSE_OUT,CUVW_ADV_SCHEME, &
+ CMET_ADV_SCHEME, CSV_ADV_SCHEME, CCLOUD, NSPLIT, &
+ LSPLIT_CFL, XSPLIT_CFL, LCFL_WRIT, &
+ CLBCX, CLBCY, NRR, NSV, TDTCUR, XTSTEP, &
+ XUT, XVT, XWT, XTHT, XRT, XTKET, XSVT, XPABST, &
+ XTHVREF, XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRTHS, XRRS, XRTKES, XRSVS, &
+ XRTHS_CLD, XRRS_CLD, XRSVS_CLD, XRTKEMS )
+!$acc end data
+!
+!$acc update host(XRTHS)
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_ADV = XT_ADV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+!$acc kernels
+ZRWS(:,:,:) = XRWS(:,:,:)
+!$acc end kernels
+!
+CALL GRAVITY_IMPL ( CLBCX, CLBCY, NRR, NRRL, NRRI,XTSTEP, &
+ XTHT, XRT, XTHVREF, XRHODJ, XRWS, XRTHS, XRRS, &
+ XRTHS_CLD, XRRS_CLD )
+!
+! At the initial instant the difference with the ref state creates a
+! vertical velocity production that must not be advected as it is
+! compensated by the pressure gradient
+!
+IF (KTCOUNT == 1 .AND. CCONF=='START') THEN
+!$acc kernels
+ XRWS_PRES(:,:,:) = ZRWS(:,:,:) - XRWS(:,:,:)
+!$acc end kernels
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_GRAV = XT_GRAV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF ((CUVW_ADV_SCHEME(1:3)=='CEN') .AND. (CTEMP_SCHEME == 'LEFR')) THEN
+ IF (CUVW_ADV_SCHEME=='CEN4TH') THEN
+ NULLIFY(TZFIELDC_ll)
+ NULLIFY(TZHALO2C_ll)
+ CALL ADD3DFIELD_ll( TZFIELDC_ll, XUT, 'MODEL_n::XUT' )
+ CALL ADD3DFIELD_ll( TZFIELDC_ll, XVT, 'MODEL_n::XVT' )
+ CALL ADD3DFIELD_ll( TZFIELDC_ll, XWT, 'MODEL_n::XWT' )
+ CALL INIT_HALO2_ll(TZHALO2C_ll,3,IIU,IJU,IKU)
+ CALL UPDATE_HALO_ll(TZFIELDC_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TZFIELDC_ll, TZHALO2C_ll, IINFO_ll)
+!$acc update device(XUT, XVT, XWT)
+ END IF
+!$acc data copyin(XUM, XVM, XWM) &
+!$acc & copy (XDUM, XDVM, XDWM)
+ CALL ADVECTION_UVW_CEN(CUVW_ADV_SCHEME, &
+ CLBCX, CLBCY, &
+ XTSTEP, KTCOUNT, &
+ XUM, XVM, XWM, XDUM, XDVM, XDWM, &
+ XUT, XVT, XWT, &
+ XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRUS,XRVS, XRWS, &
+ TZHALO2C_ll )
+!$acc end data
+ IF (CUVW_ADV_SCHEME=='CEN4TH') THEN
+ CALL CLEANLIST_ll(TZFIELDC_ll)
+ NULLIFY(TZFIELDC_ll)
+ CALL DEL_HALO2_ll(TZHALO2C_ll)
+ NULLIFY(TZHALO2C_ll)
+ END IF
+ELSE
+
+!$acc data copyin(XRUS_PRES, XRVS_PRES)
+ CALL ADVECTION_UVW(CUVW_ADV_SCHEME, CTEMP_SCHEME, &
+ NWENO_ORDER, LSPLIT_WENO, &
+ CLBCX, CLBCY, XTSTEP, &
+ XUT, XVT, XWT, &
+ XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRUS, XRVS, XRWS, &
+ XRUS_PRES, XRVS_PRES, XRWS_PRES )
+!$acc end data
+END IF
+!
+!$acc end data
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_ADVUVW = XT_ADVUVW + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+IF (NMODEL_CLOUD==IMI .AND. CTURBLEN_CLOUD/='NONE') THEN
+ CALL TURB_CLOUD_INDEX(XTSTEP,TZBAKFILE, &
+ LTURB_DIAG,GCLOSE_OUT,NRRI, &
+ XRRS,XRT,XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY, &
+ XCEI )
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 18. LATERAL BOUNDARY CONDITION FOR THE NORMAL VELOCITY
+! --------------------------------------------------
+!
+ZTIME1 = ZTIME2
+!
+ZRUS=XRUS
+ZRVS=XRVS
+ZRWS=XRWS
+!
+ CALL RAD_BOUND (CLBCX,CLBCY,CTURB,XCARPKMAX, &
+ XTSTEP, &
+ XDXHAT, XDYHAT, XZHAT, &
+ XUT, XVT, &
+ XLBXUM, XLBYVM, XLBXUS, XLBYVS, &
+ XCPHASE, XCPHASE_PBL, XRHODJ, &
+ XTKET,XRUS, XRVS, XRWS )
+ZRUS=XRUS-ZRUS
+ZRVS=XRVS-ZRVS
+ZRWS=XRWS-ZRWS
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_RAD_BOUND = XT_RAD_BOUND + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 19. PRESSURE COMPUTATION
+! --------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+ZPABST = XPABST
+!
+IF(.NOT. L1D) THEN
+!
+ XRUS_PRES = XRUS
+ XRVS_PRES = XRVS
+ XRWS_PRES = XRWS
+!
+ CALL PRESSUREZ( CLBCX,CLBCY,CPRESOPT,NITR,LITRADJ,KTCOUNT, XRELAX,IMI, &
+ XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY,XDXHATM,XDYHATM,XRHOM, &
+ XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY, &
+ NRR,NRRL,NRRI,XDRYMASST,XREFMASS,XMASS_O_PHI0, &
+ XTHT,XRT,XRHODREF,XTHVREF,XRVREF,XEXNREF, XLINMASS, &
+ XRUS, XRVS, XRWS, XPABST, &
+ XBFB, &
+ XBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K) !JUAN FULL ZSOLVER
+!
+ XRUS_PRES = XRUS - XRUS_PRES + ZRUS
+ XRVS_PRES = XRVS - XRVS_PRES + ZRVS
+ XRWS_PRES = XRWS - XRWS_PRES + ZRWS
+!
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_PRESS = XT_PRESS + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 20. CHEMISTRY/AEROSOLS
+! ------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF (LUSECHEM) THEN
+ CALL CH_MONITOR_n(ZWETDEPAER,KTCOUNT,XTSTEP, ILUOUT, NVERB)
+END IF
+!
+! For inert aerosol (dust and sea salt) => aer_monitor_n
+IF ((LDUST).OR.(LSALT)) THEN
+!
+! tests to see if any cloud exists
+!
+ GCLD=.TRUE.
+ IF (GCLD .AND. NRR.LE.3 ) THEN
+ IF( MAXVAL(XCLDFR(:,:,:)).LE. 1.E-10 .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no clouds
+ END IF
+ END IF
+!
+ IF (GCLD .AND. NRR.GE.4 ) THEN
+ IF( CCLOUD(1:3)=='ICE' )THEN
+ IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN(2) .AND. &
+ MAXVAL(XRT(:,:,:,4)).LE.XRTMIN(4) .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no cloudwater and ice
+ END IF
+ END IF
+ IF( CCLOUD=='C3R5' )THEN
+ IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN_C1R3(2) .AND. &
+ MAXVAL(XRT(:,:,:,4)).LE.XRTMIN_C1R3(4) .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no cloudwater and ice
+ END IF
+ END IF
+ IF( CCLOUD=='LIMA' )THEN
+ IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN_LIMA(2) .AND. &
+ MAXVAL(XRT(:,:,:,4)).LE.XRTMIN_LIMA(4) .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no cloudwater and ice
+ END IF
+ END IF
+ END IF
+
+!
+ CALL AER_MONITOR_n(KTCOUNT,XTSTEP, ILUOUT, NVERB, GCLD)
+END IF
+!
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_CHEM = XT_CHEM + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+ZTIME = ZTIME + XTIME_LES_BU_PROCESS + XTIME_BU_PROCESS
+
+!-------------------------------------------------------------------------------
+!
+!* 20. WATER MICROPHYSICS
+! ------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF (CCLOUD /= 'NONE' .AND. CELEC == 'NONE') THEN
+!
+ IF (CCLOUD == 'C2R2' .OR. CCLOUD == 'KHKO' .OR. CCLOUD == 'C3R5' &
+ .OR. CCLOUD == "LIMA" ) THEN
+ IF ( LFORCING ) THEN
+ XWT_ACT_NUC(:,:,:) = XWT(:,:,:) + XWTFRC(:,:,:)
+ ELSE
+ XWT_ACT_NUC(:,:,:) = XWT(:,:,:)
+ END IF
+ IF (CTURB /= 'NONE' ) THEN
+ IF ( ((CCLOUD=='C2R2'.OR.CCLOUD=='KHKO').AND.LACTTKE) .OR. (CCLOUD=='LIMA'.AND.MACTTKE) ) THEN
+ XWT_ACT_NUC(:,:,:) = XWT_ACT_NUC(:,:,:) + (2./3. * XTKET(:,:,:))**0.5
+ ELSE
+ XWT_ACT_NUC(:,:,:) = XWT_ACT_NUC(:,:,:)
+ ENDIF
+ ENDIF
+ ELSE
+ XWT_ACT_NUC(:,:,:) = 0.
+ END IF
+!
+ XRTHS_CLD(:, :, : ) = XRTHS(:, :, : )
+ XRRS_CLD (:, :, :, : ) = XRRS(:, :, :, : )
+ XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : )
+!$acc data present(XRHODJ) &
+!$acc & copyin (XZZ, XRHODREF, XEXNREF, ZPABST, XTHT, XSIGS, VSIGQSAT, XMFCONV, XTHM, XPABSM, &
+!$acc & XRCM, XWT_ACT_NUC, XDTHRAD, XCF_MF, XRC_MF, XRI_MF, &
+!$acc & XSOLORG, XMI) &
+!$acc & copy (XSUPSAT, XNACT, XNPRO, XSSPRO, &
+!$acc & XRT, XRRS, XSVT, XRSVS, XCLDFR, XCIT, XINPRR3D, XEVAP3D, &
+!$acc & XINPRC, XINPRR, XINPRS, XINPRG, XINPRH, XINDEP) &
+!$acc & copyout(XSRCT, XRAINFR)
+
+!$acc update device ( XRTHS )
+
+ IF (CSURF=='EXTE') THEN
+ ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ZSEA(:,:) = 0.
+ ZTOWN(:,:)= 0.
+ CALL MNHGET_SURF_PARAM_n (PSEA=ZSEA(:,:),PTOWN=ZTOWN(:,:))
+!$acc data copyin(ZSEA, ZTOWN )
+ CALL RESOLVED_CLOUD ( CCLOUD, CACTCCN, CSCONV, CMF_CLOUD, NRR, NSPLITR, &
+ NSPLITG, IMI, KTCOUNT, &
+ CLBCX,CLBCY,TZBAKFILE, CRAD, CTURBDIM, &
+ GCLOSE_OUT, LSUBG_COND,LSIGMAS,CSUBG_AUCV,XTSTEP, &
+ XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT,XRT,XSIGS,VSIGQSAT,XMFCONV,XTHM,XRCM, &
+ XPABSM, XWT_ACT_NUC,XDTHRAD, XRTHS, XRRS, &
+ XSVT, XRSVS, &
+ XSRCT, XCLDFR,XCIT, &
+ LSEDIC,KACTIT, KSEDC, KSEDI, KRAIN, KWARM, KHHONI, &
+ LCONVHG, XCF_MF,XRC_MF, XRI_MF, &
+! XINPRC,ZINPRC3D,XINPRR, XINPRR3D, XEVAP3D, &
+! XINPRS,ZINPRS3D, XINPRG,ZINPRG3D, XINPRH,ZINPRH3D, &
+ XINPRC,XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG,XINPRH, &
+! XSOLORG, XMI,ZSPEEDC, ZSPEEDR, ZSPEEDS, ZSPEEDG, ZSPEEDH, &
+ XSOLORG, XMI, &
+ XINDEP, XSUPSAT, XNACT, XNPRO,XSSPRO, XRAINFR, &
+ ZSEA, ZTOWN )
+!$acc end data
+ DEALLOCATE(ZTOWN)
+ ELSE
+ CALL RESOLVED_CLOUD ( CCLOUD, CACTCCN, CSCONV, CMF_CLOUD, NRR, NSPLITR, &
+ NSPLITG, IMI, KTCOUNT, &
+ CLBCX,CLBCY,TZBAKFILE, CRAD, CTURBDIM, &
+ GCLOSE_OUT, LSUBG_COND,LSIGMAS,CSUBG_AUCV, &
+ XTSTEP,XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT,XRT,XSIGS,VSIGQSAT,XMFCONV,XTHM,XRCM, &
+ XPABSM, XWT_ACT_NUC,XDTHRAD, XRTHS, XRRS, &
+ XSVT, XRSVS, &
+ XSRCT, XCLDFR,XCIT, &
+ LSEDIC,KACTIT, KSEDC, KSEDI, KRAIN, KWARM, KHHONI, &
+ LCONVHG, XCF_MF,XRC_MF, XRI_MF, &
+! XINPRC,ZINPRC3D,XINPRR, XINPRR3D, XEVAP3D, &
+! XINPRS,ZINPRS3D, XINPRG,ZINPRG3D, XINPRH,ZINPRH3D, &
+ XINPRC,XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG,XINPRH, &
+! XSOLORG, XMI,ZSPEEDC, ZSPEEDR, ZSPEEDS, ZSPEEDG, ZSPEEDH, &
+ XSOLORG, XMI, &
+ XINDEP, XSUPSAT, XNACT, XNPRO,XSSPRO, XRAINFR )
+ END IF
+!$acc end data
+
+!$acc update host(XRTHS)
+
+ XRTHS_CLD(:, :, : ) = XRTHS(:, :, : ) - XRTHS_CLD(:, :, : )
+ XRRS_CLD (:, :, :, : ) = XRRS (:, :, :, : ) - XRRS_CLD (:, :, :, : )
+ XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : ) - XRSVS_CLD(:, :, :, : )
+!
+ IF (CCLOUD /= 'REVE' ) THEN
+ XACPRR = XACPRR + XINPRR * XTSTEP
+ IF ( (CCLOUD(1:3) == 'ICE' .AND. LSEDIC ) .OR. &
+ ((CCLOUD == 'C2R2' .OR. CCLOUD == 'C3R5' .OR. CCLOUD == 'KHKO' &
+ .OR. CCLOUD == 'LIMA' ) .AND. KSEDC ) ) THEN
+ XACPRC = XACPRC + XINPRC * XTSTEP
+ IF (LDEPOSC .OR. LDEPOC) XACDEP = XACDEP + XINDEP * XTSTEP
+ END IF
+ IF (CCLOUD(1:3) == 'ICE' .OR. CCLOUD == 'C3R5' .OR. &
+ (CCLOUD == 'LIMA' .AND. LCOLD ) ) THEN
+ XACPRS = XACPRS + XINPRS * XTSTEP
+ XACPRG = XACPRG + XINPRG * XTSTEP
+ IF (CCLOUD == 'ICE4' .OR. (CCLOUD == 'LIMA' .AND. LHAIL)) XACPRH = XACPRH + XINPRH * XTSTEP
+ END IF
+!
+! Lessivage des CCN et IFN nucléables par Slinn
+!
+ IF (LSCAV .AND. (CCLOUD == 'LIMA')) THEN
+ CALL LIMA_PRECIP_SCAVENGING(CCLOUD, ILUOUT, KTCOUNT,XTSTEP,XRT(:,:,:,3), &
+ XRHODREF, XRHODJ, XZZ, XPABST, XTHT, &
+ XSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ XRSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), XINPAP )
+!
+ XACPAP(:,:) = XACPAP(:,:) + XINPAP(:,:) * XTSTEP
+ END IF
+ END IF
+!
+! It is necessary that SV_C2R2 and SV_C1R3 are contiguous in the preceeding CALL
+!
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_CLOUD = XT_CLOUD + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. CLOUD ELECTRIFICATION AND LIGHTNING FLASHES
+! -------------------------------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF (CELEC /= 'NONE' .AND. (CCLOUD(1:3) == 'ICE')) THEN
+ XWT_ACT_NUC(:,:,:) = 0.
+!
+ XRTHS_CLD = XRTHS
+ XRRS_CLD = XRRS
+ XRSVS_CLD = XRSVS
+ IF (CSURF=='EXTE') THEN
+ ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ZSEA(:,:) = 0.
+ ZTOWN(:,:)= 0.
+ CALL MNHGET_SURF_PARAM_n (PSEA=ZSEA(:,:),PTOWN=ZTOWN(:,:))
+ CALL RESOLVED_ELEC_n (CCLOUD, CSCONV, CMF_CLOUD, &
+ NRR, NSPLITR, IMI, KTCOUNT, OEXIT, &
+ CLBCX, CLBCY, CRAD, CTURBDIM, &
+ LSUBG_COND, LSIGMAS,VSIGQSAT,CSUBG_AUCV, &
+ XTSTEP, XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT, XRTHS, XWT, XRT, XRRS, &
+ XSVT, XRSVS, XCIT, &
+ XSIGS, XSRCT, XCLDFR, XMFCONV, XCF_MF, XRC_MF, &
+ XRI_MF, LSEDIC, LWARM, &
+ XINPRC, XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG, XINPRH, &
+ ZSEA, ZTOWN )
+ DEALLOCATE(ZTOWN)
+ ELSE
+ CALL RESOLVED_ELEC_n (CCLOUD, CSCONV, CMF_CLOUD, &
+ NRR, NSPLITR, IMI, KTCOUNT, OEXIT, &
+ CLBCX, CLBCY, CRAD, CTURBDIM, &
+ LSUBG_COND, LSIGMAS,VSIGQSAT, CSUBG_AUCV, &
+ XTSTEP, XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT, XRTHS, XWT, &
+ XRT, XRRS, XSVT, XRSVS, XCIT, &
+ XSIGS, XSRCT, XCLDFR, XMFCONV, XCF_MF, XRC_MF, &
+ XRI_MF, LSEDIC, LWARM, &
+ XINPRC, XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG, XINPRH )
+ END IF
+ XRTHS_CLD = XRTHS - XRTHS_CLD
+ XRRS_CLD = XRRS - XRRS_CLD
+ XRSVS_CLD = XRSVS - XRSVS_CLD
+!
+ XACPRR = XACPRR + XINPRR * XTSTEP
+ IF ((CCLOUD(1:3) == 'ICE' .AND. LSEDIC)) &
+ XACPRC = XACPRC + XINPRC * XTSTEP
+ IF (CCLOUD(1:3) == 'ICE') THEN
+ XACPRS = XACPRS + XINPRS * XTSTEP
+ XACPRG = XACPRG + XINPRG * XTSTEP
+ IF (CCLOUD == 'ICE4') XACPRH = XACPRH + XINPRH * XTSTEP
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_ELEC = XT_ELEC + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. L.E.S. COMPUTATIONS
+! -------------------
+!
+ZTIME1 = ZTIME2
+!
+CALL LES_n
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_SPECTRA = XT_SPECTRA + ZTIME2 - ZTIME1 + XTIME_LES_BU + XTIME_LES
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. bis MEAN_UM
+! --------------------
+!
+IF (LMEAN_FIELD) THEN
+ CALL MEAN_FIELD(XUT, XVT, XWT, XTHT, XTKET, XPABST)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 22. UPDATE HALO OF EACH SUBDOMAINS FOR TIME T+DT
+! --------------------------------------------
+!
+ZTIME1 = ZTIME2
+!
+CALL EXCHANGE (XTSTEP,NRR,NSV,XRHODJ,TFIELDS_ll, &
+ XRUS, XRVS,XRWS,XRTHS,XRRS,XRTKES,XRSVS)
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_HALO = XT_HALO + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 23. TEMPORAL SWAPPING
+! -----------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+!
+CALL ENDSTEP ( XTSTEP,NRR,NSV,KTCOUNT,IMI, &
+ CUVW_ADV_SCHEME,CTEMP_SCHEME,XRHODJ, &
+ XRUS,XRVS,XRWS,XDRYMASSS, &
+ XRTHS,XRRS,XRTKES,XRSVS, &
+ XLSUS,XLSVS,XLSWS, &
+ XLSTHS,XLSRVS,XLSZWSS, &
+ XLBXUS,XLBXVS,XLBXWS, &
+ XLBXTHS,XLBXRS,XLBXTKES,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS, &
+ XLBYTHS,XLBYRS,XLBYTKES,XLBYSVS, &
+ XUM,XVM,XWM,XZWS, &
+ XUT,XVT,XWT,XPABST,XDRYMASST, &
+ XTHT, XRT, XTHM, XRCM, XPABSM,XTKET, XSVT,&
+ XLSUM,XLSVM,XLSWM, &
+ XLSTHM,XLSRVM,XLSZWSM, &
+ XLBXUM,XLBXVM,XLBXWM, &
+ XLBXTHM,XLBXRM,XLBXTKEM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM, &
+ XLBYTHM,XLBYRM,XLBYTKEM,XLBYSVM )
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_SWA = XT_STEP_SWA + ZTIME2 - ZTIME1 - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 24.1 BALLOON and AIRCRAFT
+! --------------------
+!
+ZTIME1 = ZTIME2
+!
+IF (LFLYER) &
+ CALL AIRCRAFT_BALLOON(XTSTEP, &
+ TDTEXP, TDTMOD, TDTSEG, TDTCUR, &
+ XXHAT, XYHAT, XZZ, XMAP, XLONORI, XLATORI, &
+ XUT, XVT, XWT, XPABST, XTHT, XRT, XSVT, XTKET, XTSRAD, &
+ XRHODREF,XCIT,PSEA=ZSEA(:,:))
+
+
+!-------------------------------------------------------------------------------
+!
+!* 24.2 STATION (observation diagnostic)
+! --------------------------------
+!
+IF (LSTATION) &
+ CALL STATION_n(XTSTEP, &
+ TDTEXP, TDTMOD, TDTSEG, TDTCUR, &
+ XXHAT, XYHAT, XZZ, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, XTSRAD, XPABST )
+!
+!---------------------------------------------------------
+!
+!* 24.3 PROFILER (observation diagnostic)
+! ---------------------------------
+!
+IF (LPROFILER) &
+ CALL PROFILER_n(XTSTEP, &
+ TDTEXP, TDTMOD, TDTSEG, TDTCUR, &
+ XXHAT, XYHAT, XZZ,XRHODREF, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, XTSRAD, XPABST, &
+ XAER, XCLDFR, XCIT)
+!
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_MISC = XT_STEP_MISC + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 24.4 deallocation of observation diagnostics
+! ---------------------------------------
+!
+CALL END_DIAG_IN_RUN
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 25. STORAGE OF BUDGET FIELDS
+! ------------------------
+!
+ZTIME1 = ZTIME2
+!
+IF ( .NOT. LIO_NO_WRITE ) THEN
+ IF (NBUMOD==IMI .AND. CBUTYPE/='NONE') THEN
+ CALL ENDSTEP_BUDGET(TDIAFILE,KTCOUNT,TDTCUR,TDTMOD,XTSTEP,NSV)
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_BUD = XT_STEP_BUD + ZTIME2 - ZTIME1 + XTIME_BU
+!
+!-------------------------------------------------------------------------------
+!
+!* 26. FM FILE CLOSURE
+! ---------------
+!
+IF (GCLOSE_OUT) THEN
+ GCLOSE_OUT=.FALSE.
+ CALL IO_File_close(TZBAKFILE)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 27. CURRENT TIME REFRESH
+! --------------------
+!
+TDTCUR%TIME=TDTCUR%TIME + XTSTEP
+CALL DATETIME_CORRECTDATE(TDTCUR)
+!
+!-------------------------------------------------------------------------------
+!
+!* 28. CPU ANALYSIS
+! ------------
+!
+CALL SECOND_MNH2(ZTIME2)
+XT_START=XT_START+ZTIME2-ZEND
+!
+!
+IF ( KTCOUNT == NSTOP .AND. IMI==1) THEN
+ OEXIT=.TRUE.
+END IF
+!
+IF (OEXIT) THEN
+!
+ IF ( .NOT. LIO_NO_WRITE ) THEN
+ IF (LSERIES) CALL WRITE_SERIES_n(TDIAFILE)
+ CALL WRITE_AIRCRAFT_BALLOON(TDIAFILE)
+ CALL WRITE_STATION_n(TDIAFILE)
+ CALL WRITE_PROFILER_n(TDIAFILE)
+ CALL WRITE_LES_n(TDIAFILE,' ')
+ CALL WRITE_LES_n(TDIAFILE,'A')
+ CALL WRITE_LES_n(TDIAFILE,'E')
+ CALL WRITE_LES_n(TDIAFILE,'H')
+ CALL MENU_DIACHRO(TDIAFILE,'END')
+ CALL IO_File_close(TDIAFILE)
+ END IF
+ !
+ CALL IO_File_close(TINIFILE)
+ IF (CSURF=="EXTE") CALL IO_File_close(TINIFILEPGD)
+!
+!* 28.1 print statistics!
+!
+ ! Set File Timing OUTPUT
+ !
+ CALL SET_ILUOUT_TIMING(TLUOUT)
+ !
+ ! Compute global time
+ !
+ CALL TIME_STAT_ll(XT_START,ZTOT)
+ !
+ CALL TIME_HEADER_ll(IMI)
+ !
+ CALL TIME_STAT_ll(XT_1WAY,ZTOT, ' ONE WAY','=')
+ CALL TIME_STAT_ll(XT_BOUND,ZTOT, ' BOUNDARIES','=')
+ CALL TIME_STAT_ll(XT_STORE,ZTOT, ' STORE-FIELDS','=')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_SEND,ZTOT, ' W3D_SEND ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_RECV,ZTOT, ' W3D_RECV ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_WRIT,ZTOT, ' W3D_WRIT ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_WAIT,ZTOT, ' W3D_WAIT ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_ALL ,ZTOT, ' W3D_ALL ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_GATH,ZTOT, ' W2D_GATH ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_WRIT,ZTOT, ' W2D_WRIT ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_ALL ,ZTOT, ' W2D_ALL ','-')
+ CALL TIME_STAT_ll(XT_GUESS,ZTOT, ' INITIAL_GUESS','=')
+ CALL TIME_STAT_ll(XT_2WAY,ZTOT, ' TWO WAY','=')
+ CALL TIME_STAT_ll(XT_ADV,ZTOT, ' ADVECTION MET','=')
+ CALL TIME_STAT_ll(XT_ADVUVW,ZTOT, ' ADVECTION UVW','=')
+ CALL TIME_STAT_ll(XT_GRAV,ZTOT, ' GRAVITY','=')
+ CALL TIME_STAT_ll(XT_FORCING,ZTOT, ' FORCING','=')
+ CALL TIME_STAT_ll(XT_NUDGING,ZTOT, ' NUDGING','=')
+ CALL TIME_STAT_ll(XT_SOURCES,ZTOT, ' DYN_SOURCES','=')
+ CALL TIME_STAT_ll(XT_DIFF,ZTOT, ' NUM_DIFF','=')
+ CALL TIME_STAT_ll(XT_RELAX,ZTOT, ' RELAXATION','=')
+ !
+ CALL TIMING_LEGEND()
+ !
+ CALL TIME_STAT_ll(XT_PARAM,ZTOT, ' PHYS_PARAM','=')
+ CALL TIME_STAT_ll(XT_RAD,ZTOT, ' RAD = '//CRAD ,'-')
+ CALL TIME_STAT_ll(XT_SHADOWS,ZTOT, ' SHADOWS' ,'-')
+ CALL TIME_STAT_ll(XT_DCONV,ZTOT, ' DEEP CONV = '//CDCONV,'-')
+ CALL TIME_STAT_ll(XT_GROUND,ZTOT, ' GROUND' ,'-')
+ CALL TIME_STAT_ll(XT_TURB,ZTOT, ' TURB = '//CTURB ,'-')
+ CALL TIME_STAT_ll(XT_MAFL,ZTOT, ' MAFL = '//CSCONV,'-')
+ CALL TIME_STAT_ll(XT_CHEM,ZTOT, ' CHIMIE' ,'-')
+ CALL TIMING_LEGEND()
+ CALL TIME_STAT_ll(XT_COUPL,ZTOT, ' SET_COUPLING','=')
+ CALL TIME_STAT_ll(XT_RAD_BOUND,ZTOT, ' RAD_BOUND','=')
+ !
+ CALL TIMING_LEGEND()
+ !
+ CALL TIME_STAT_ll(XT_PRESS,ZTOT, ' PRESSURE ','=','F')
+ !JUAN Z_SPLITTING
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_B_SX_YP2_ZP1,ZTOT, ' REMAP B=>FFTXZ' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SX_YP2_ZP1_SXP2_Y_ZP1,ZTOT, ' REMAP FFTXZ=>FFTYZ' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_B,ZTOT, ' REMAP FTTYZ=>B' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_SXP2_YP1_Z,ZTOT, ' REMAP FFTYZ=>SUBZ' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_B_SXP2_Y_ZP1,ZTOT, ' REMAP B=>FFTYZ-1','-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_YP1_Z_SXP2_Y_ZP1,ZTOT, ' REMAP SUBZ=>FFTYZ-1','-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_SX_YP2_ZP1,ZTOT, ' REMAP FFTYZ-1=>FFTXZ-1','-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SX_YP2_ZP1_B,ZTOT, ' REMAP FFTXZ-1=>B ' ,'-','F')
+ ! JUAN P1/P2
+ CALL TIME_STAT_ll(XT_CLOUD,ZTOT, ' RESOLVED_CLOUD','=')
+ CALL TIME_STAT_ll(XT_ELEC,ZTOT, ' RESOLVED_ELEC','=')
+ CALL TIME_STAT_ll(XT_HALO,ZTOT, ' EXCHANGE_HALO','=')
+ CALL TIME_STAT_ll(XT_STEP_SWA,ZTOT, ' ENDSTEP','=')
+ CALL TIME_STAT_ll(XT_STEP_BUD,ZTOT, ' BUDGETS','=')
+ CALL TIME_STAT_ll(XT_SPECTRA,ZTOT, ' LES','=')
+ CALL TIME_STAT_ll(XT_STEP_MISC,ZTOT, ' MISCELLANEOUS','=')
+ !
+ ! sum of call subroutine
+ !
+ ZALL = XT_1WAY + XT_BOUND + XT_STORE + XT_GUESS + XT_2WAY + &
+ XT_ADV + XT_FORCING + XT_NUDGING + XT_SOURCES + XT_DIFF + &
+ XT_ADVUVW + XT_GRAV + &
+ XT_RELAX+ XT_PARAM + XT_COUPL + XT_RAD_BOUND+XT_PRESS + &
+ XT_CLOUD+ XT_ELEC + XT_HALO + XT_SPECTRA + XT_STEP_SWA + &
+ XT_STEP_MISC+ XT_STEP_BUD
+ CALL TIME_STAT_ll(ZALL,ZTOT, ' SUM(CALL)','=')
+ CALL TIMING_SEPARATOR('=')
+ !
+ ! Gobale Stat
+ !
+ WRITE(ILUOUT,FMT=*)
+ WRITE(ILUOUT,FMT=*)
+ CALL TIMING_LEGEND()
+ !
+ ! MODELN all included
+ !
+ CALL TIMING_SEPARATOR('+')
+ CALL TIMING_SEPARATOR('+')
+ WRITE(YMI,FMT="(I0)") IMI
+ CALL TIME_STAT_ll(XT_START,ZTOT, ' MODEL'//YMI,'+')
+ CALL TIMING_SEPARATOR('+')
+ CALL TIMING_SEPARATOR('+')
+ CALL TIMING_SEPARATOR('+')
+ !
+ ! Timing/ Steps
+ !
+ ZTIME_STEP = XT_START / REAL(KTCOUNT)
+ WRITE(YTCOUNT,FMT="(I0)") KTCOUNT
+ CALL TIME_STAT_ll(ZTIME_STEP,ZTOT, ' SECOND/STEP='//YTCOUNT,'=')
+ !
+ ! Timing/Step/Points
+ !
+ IPOINTS = NIMAX_ll*NJMAX_ll*NKMAX
+ WRITE(YPOINTS,FMT="(I0)") IPOINTS
+ ZTIME_STEP_PTS = ZTIME_STEP / REAL(IPOINTS) * 1e6
+ CALL TIME_STAT_ll(ZTIME_STEP_PTS,ZTOT_PT)
+ CALL TIME_STAT_ll(ZTIME_STEP_PTS,ZTOT_PT, ' MICROSEC/STP/PT='//YPOINTS,'-')
+ !
+ CALL TIMING_SEPARATOR('=')
+ !
+ !
+ !
+ CALL IO_File_close(TLUOUT)
+ IF (IMI==NMODEL) CALL IO_File_close(TLUOUT0)
+END IF
+
+!$acc end data
+
+END SUBROUTINE MODEL_n
diff --git a/src/ZSOLVER/pressurez.f90 b/src/ZSOLVER/pressurez.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c9b2b9db971f01c05b40f5c809a24c8f18a47d18
--- /dev/null
+++ b/src/ZSOLVER/pressurez.f90
@@ -0,0 +1,789 @@
+!MNH_LIC Copyright 1994-2020 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!###################
+MODULE MODI_PRESSUREZ
+!###################
+!
+INTERFACE
+!
+ SUBROUTINE PRESSUREZ( &
+ HLBCX,HLBCY,HPRESOPT,KITR,OITRADJ,KTCOUNT,PRELAX,KMI, &
+ PRHODJ,PDXX,PDYY,PDZZ,PDZX,PDZY,PDXHATM,PDYHATM,PRHOT, &
+ PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KRR,KRRL,KRRI,PDRYMASST,PREFMASS,PMASS_O_PHI0, &
+ PTHT,PRT,PRHODREF,PTHVREF,PRVREF,PEXNREF,PLINMASS, &
+ PRUS,PRVS,PRWS,PPABST, &
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K, &
+ PRESIDUAL) !JUAN FULL ZSOLVER
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+INTEGER, INTENT(INOUT) :: KITR ! number of iterations for the
+ ! pressure solver
+LOGICAL, INTENT(IN) :: OITRADJ ! switch to adjust or not KITR
+INTEGER, INTENT(IN) :: KTCOUNT ! counter value of the
+ ! model temporal loop
+INTEGER, INTENT(IN) :: KMI ! Model index
+REAL, INTENT(IN) :: PRELAX ! relaxation coefficient for
+ ! the Richardson's method
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference state
+ ! * J
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY ! metric coefficients
+!
+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) :: PRHOT ! 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. y-slide
+ ! 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
+!
+!
+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
+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) :: PRHODREF ! dry Density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
+ ! of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! mixing ratio of the
+ ! reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Exner function
+ ! of the reference state
+REAL, INTENT(IN) :: PLINMASS ! lineic mass through
+ ! open boundaries
+!
+REAL, INTENT(INOUT) :: PRUS(:,:,:) ! source term along x
+REAL, INTENT(INOUT) :: PRVS(:,:,:) ! source term along y
+REAL, INTENT(INOUT) :: PRWS(:,:,:) ! source term along z
+!
+REAL, INTENT(INOUT) :: PPABST(:,:,:) ! pressure(t)
+!
+!JUAN Z_SPLITING
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBFB ! elements of the tri-diag b-slide .
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+
+REAL, OPTIONAL :: PRESIDUAL
+!JUAN Z_SPLITING
+END SUBROUTINE PRESSUREZ
+!
+END INTERFACE
+!
+END MODULE MODI_PRESSUREZ
+! ######################################################################
+ SUBROUTINE PRESSUREZ( &
+ HLBCX,HLBCY,HPRESOPT,KITR,OITRADJ,KTCOUNT,PRELAX,KMI, &
+ PRHODJ,PDXX,PDYY,PDZZ,PDZX,PDZY,PDXHATM,PDYHATM,PRHOT, &
+ PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KRR,KRRL,KRRI,PDRYMASST,PREFMASS,PMASS_O_PHI0, &
+ PTHT,PRT,PRHODREF,PTHVREF,PRVREF,PEXNREF,PLINMASS, &
+ PRUS,PRVS,PRWS,PPABST, &
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K, &
+ PRESIDUAL) !JUAN FULL ZSOLVER
+! ######################################################################
+!
+!!**** *PRESSUREZ * - solve the pressure equation and add the pressure term
+!! to the sources
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to solve the pressure equation:
+! with either the conjugate gradient method or the Richardson's method.
+! The pressure gradient is added to the sources in order
+! to nullify the divergence of the momentum* Thetavref*(1+Rvref)
+! at the time t+dt.
+!
+!!** METHOD
+!! ------
+!! The divergence of the sources ( RHS of the pressure equation ) is
+!! computed. The pressure equation is then solved by either CG method,
+!! either Richardson's method, or an exact method. Finally, the pressure
+!! gradient is added to the sources RUS, RVS, RWS.
+!! Finally, the absolute pressure is diagnozed from the total mass
+!! included in the simulation domain.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine MASS_LEAK : assures global non-divergence condition in the
+!! case of open boundaries
+!! Subroutine FLAT_INV : solve the pressure equation for the case
+!! without orography
+!! Subroutine RICHARDSON: solve the pressure equation with the
+!! Richardson's method
+!! Subroutine CONJGRAD : solve the pressure equation with the Conjugate
+!! Gradient algorithm
+!! Function GX_M_U : compute the gradient along x
+!! Function GY_M_V : compute the gradient along y
+!! Function GZ_M_W : compute the gradient along z
+!! Subroutine GDIV : compute J times the divergence of 1/J times a vector
+!! Function MXM: compute an average in the x direction for a variable
+!! at a mass localization
+!! Function MYM: compute an average in the y direction for a variable
+!! at a mass localization
+!! Function MZM: compute an average in the z direction for a variable
+!! at a mass localization
+!! Subroutine P_ABS : compute the constant for PABS and therefore, the
+!! absolute pressure function
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONF: model configuration
+!! LFLAT: logical switch for zero orography
+!! L2D : logical switch for two-dimensional configuration
+!! LCARTESIAN : logical switch for cartesian geometry
+!! 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_CST: physical constants
+!! XCPD
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (subroutine PRESSURE) + Book1 ( )
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! Modification 03/01/95 (Lafore) To add the absolute pressure diagnosis
+!! Modification 31/01/95 (Stein) Copy of the pressure function in the
+!! 2D case in the two outermost planes
+!! Modification 16/02/95 (Mallet) Add the call to MASS_LEAK
+!! Modification 16/03/95 (Stein) change the argument list of the
+!! gradient and remove R from the historical var.
+!! Modification 30/06/95 (Stein) Add a test not to compute the absolute
+!! pressure in the Boussinesq case
+!! 16/10/95 (J. Stein) change the budget calls
+!! 29/01/96 (J. Stein) call iterative resolution for
+!! non-cartessian geometry
+!! 19/12/96 (J.-P. Pinty) update the budget calls
+!! 14/01/97 (Stein,Lafore) New anelastic equations
+!! 17/12/97 ( Stein )include the case of non-vanishing
+!! orography at the lbc
+!! 26/03/98 (Stein,Jabouille) fix the value of the corner point
+!! 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! 25/08/99 (J.-P. Pinty) add CRESI option to CPRESOPT
+!! 06/11/02 (V. Masson) update the budget calls
+!! 24/08/2005 (J. escobar) BUG : remove IIE+1, IJE+1 out of bound
+!! references in parallel run
+!! 08/2010 (V.Masson, C.Lac) Add UPDATE_HALO
+!! 11/2010 (V.Masson, C.Lac) PPABST, must not be cyclic => add temp array
+!! to save it before UPDATE_HALO
+!! 07/2011 (J.escobar ) Bypass Bug with ifort11/12 on HLBCX,HLBCY
+!! 09/2001 (J.escobar ) reintroduce correctly the GMAXLOC_ll call
+!! 11/2010 (V.Masson, C.Lac) PPABST must not be cyclic => add temp array
+!! to save it before UPDATE_HALO
+!! 02/2013 (J.Escobar ) add a test on abs(err) > 100.O for BG without controle of NAN
+!! 2012 (V.Masson) Modif update_halo due to CONTRAV
+!! 2014 (C.Lac) correction for 3D run with LBOUSS=.TRUE.
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! J.escobar : check nb proc versus ZRESI & min(DIMX,DIMY)
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Philippe Wautelet: 22/01/2019: use standard FLUSH statement instead of non standard intrinsics
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ARGSLIST_ll, ONLY: LIST_ll
+USE MODD_BUDGET
+USE MODD_CST
+USE MODD_CONF
+USE MODD_DYN_n, ONLY: LRES, XRES
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_MPIF
+USE MODD_PARAMETERS
+use modd_precision, only: MNHREAL_MPI
+USE MODD_REF, ONLY: LBOUSS
+USE MODD_VAR_ll, ONLY: NMNH_COMM_WORLD , NPROC
+!
+USE MODE_ll
+USE MODE_MPPDB
+USE MODE_MSG
+USE MODE_SUM2_ll, ONLY: GMAXLOC_ll
+!
+USE MODI_BUDGET
+USE MODI_CONJGRAD
+USE MODI_ZCONJGRAD
+USE MODI_CONRESOL
+USE MODI_CONRESOLZ
+USE MODI_FLAT_INV
+USE MODI_ZSOLVER
+USE MODI_FLAT_INVZ
+USE MODI_GDIV
+USE MODI_GRADIENT_M
+USE MODI_MASS_LEAK
+USE MODI_P_ABS
+USE MODI_RICHARDSON
+USE MODI_SHUMAN
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+ CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+ CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+INTEGER, INTENT(INOUT) :: KITR ! number of iterations for the
+ ! pressure solver
+LOGICAL, INTENT(IN) :: OITRADJ ! switch to adjust or not KITR
+INTEGER, INTENT(IN) :: KTCOUNT ! counter value of the
+ ! model temporal loop
+INTEGER, INTENT(IN) :: KMI ! Model index
+REAL, INTENT(IN) :: PRELAX ! relaxation coefficient for
+ ! the Richardson's method
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference state
+ ! * J
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY ! metric coefficients
+!
+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) :: PRHOT ! 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 y-slide .
+ ! 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
+!
+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
+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) :: PRHODREF ! dry Density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
+ ! of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! mixing ratio of the
+ ! reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Exner function
+ ! of the reference state
+REAL, INTENT(IN) :: PLINMASS ! lineic mass through
+ ! open boundaries
+!
+REAL, INTENT(INOUT) :: PRUS(:,:,:) ! source term along x
+REAL, INTENT(INOUT) :: PRVS(:,:,:) ! source term along y
+REAL, INTENT(INOUT) :: PRWS(:,:,:) ! source term along z
+!
+REAL, INTENT(INOUT) :: PPABST(:,:,:) ! pressure(t)
+!
+!JUAN Z_SPLITING
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBFB ! elements of the tri-diag b-slide .
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+
+REAL, OPTIONAL :: PRESIDUAL
+!JUAN Z_SPLITING
+!
+!* 0.2 declarations of local variables
+!
+! Metric coefficients:
+!
+REAL, DIMENSION(SIZE(PPABST,1),SIZE(PPABST,2),SIZE(PPABST,3)) :: ZDV_SOURCE
+! ! divergence of the sources
+!
+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 :: ILUOUT ! Logical unit of output listing
+INTEGER :: IRESP ! Return code of FM routines
+!
+REAL, DIMENSION(SIZE(PPABST,1),SIZE(PPABST,2),SIZE(PPABST,3)) :: ZTHETAV, &
+ ! virtual potential temperature
+ ZPHIT
+ ! MAE + DUR => Exner function perturbation
+ ! LHE => Exner function perturbation * CPD * THVREF
+!
+REAL :: ZRV_OV_RD ! XRV / XRD
+REAL :: ZMAXVAL, ZMAXRES, ZMAX,ZMAX_ll ! for print
+INTEGER, DIMENSION(3) :: IMAXLOC ! purpose
+INTEGER :: JWATER ! loop index on water species
+INTEGER :: IIU,IJU,IKU ! array sizes in I,J,K
+INTEGER :: JK ! loop index on the vertical levels
+INTEGER :: JI,JJ
+!
+REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,3)) :: ZPABS_S ! local pressure on southern side
+REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,3)) :: ZPABS_N ! local pressure on northern side
+REAL, DIMENSION(SIZE(PDYY,2),SIZE(PDXX,3)) :: ZPABS_E ! local pressure on eastern side
+REAL, DIMENSION(SIZE(PDYY,2),SIZE(PDXX,3)) :: ZPABS_W ! local pressure on western side
+INTEGER :: IINFO_ll,KINFO
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll, TZFIELDS2_ll ! list of fields to exchange
+!
+INTEGER :: IIB_I,IIE_I,IJB_I,IJE_I
+INTEGER :: IIMAX_ll,IJMAX_ll
+!
+!
+!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARIES
+! -------------
+!
+ILUOUT = TLUOUT%NLU
+!
+CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
+IF ( ( MIN(IIMAX_ll,IJMAX_ll) < NPROC ) .AND. ( HPRESOPT /= 'ZRESI' ) .AND. ( HPRESOPT /= 'ZSOLV' )) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'ERROR IN PRESSUREZ:: YOU WANT TO USE TO MANY PROCESSOR WITHOUT CPRESOPT="ZRESI/ZSOLV" '
+ WRITE(UNIT=ILUOUT,FMT=*) 'MIN(IIMAX_ll,IJMAX_ll)=',MIN(IIMAX_ll,IJMAX_ll),' < NPROC =', NPROC
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU HAVE TO SET CPRESOPT="ZRESI => JOB ABORTED '
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','PRESSUREZ','')
+ENDIF
+CALL GET_PHYSICAL_ll(IIB,IJB,IIE,IJE)
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+!
+IKB= 1+JPVEXT
+IKU= SIZE(PPABST,3)
+IKE= IKU - JPVEXT
+!
+ZPABS_S(:,:) = 0.
+ZPABS_N(:,:) = 0.
+ZPABS_E(:,:) = 0.
+ZPABS_W(:,:) = 0.
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE LINEIC MASS
+! -----------------------
+!
+IF ( ANY(HLBCX(:)=='OPEN') .OR. ANY(HLBCY(:)=='OPEN') ) THEN
+ CALL MASS_LEAK(PDXX,PDYY,HLBCX,HLBCY,PLINMASS,PRHODJ,PRUS,PRVS)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. COMPUTE THE FORCING TERM FOR THE PRESSURE EQUATION
+! --------------------------------------------------
+!
+!
+CALL MPPDB_CHECK3D(PRUS,"pressurez 4-before update_halo_ll::PRUS",PRECISION)
+CALL MPPDB_CHECK3D(PRVS,"pressurez 4-before update_halo_ll::PRVS",PRECISION)
+CALL MPPDB_CHECK3D(PRWS,"pressurez 4-before update_halo_ll::PRWS",PRECISION)
+NULLIFY(TZFIELDS_ll)
+CALL ADD3DFIELD_ll( TZFIELDS_ll, PRUS, 'PRESSUREZ::PRUS' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, PRVS, 'PRESSUREZ::PRVS' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, PRWS, 'PRESSUREZ::PRWS' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(PRUS,"pressurez 4-after update_halo_ll::PRUS",PRECISION)
+CALL MPPDB_CHECK3D(PRVS,"pressurez 4-after update_halo_ll::PRVS",PRECISION)
+CALL MPPDB_CHECK3D(PRWS,"pressurez 4-after update_halo_ll::PRWS",PRECISION)
+!
+CALL GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRUS,PRVS,PRWS,ZDV_SOURCE)
+!
+! The non-homogenous Neuman problem is transformed in an homogenous Neuman
+! problem in the non-periodic cases
+IF (HLBCX(1) /= 'CYCL') THEN
+ IF (LWEST_ll()) ZDV_SOURCE(IIB-1,:,:) = 0.
+ IF (LEAST_ll()) ZDV_SOURCE(IIE+1,:,:) = 0.
+ENDIF
+!
+IF (.NOT. L2D .AND. HLBCY(1) /= 'CYCL') THEN
+ IF (LSOUTH_ll()) ZDV_SOURCE(:,IJB-1,:) = 0.
+ IF (LNORTH_ll()) ZDV_SOURCE(:,IJE+1,:) = 0.
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. SOLVE THE PRESSURE EQUATION
+! ---------------------------
+!
+!
+!* 5.1 Compute the virtual theta and the pressure perturbation
+! -------------------------------------------------------
+!
+IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+ IF(KRR > 0) THEN
+ !
+ ! compute the ratio : 1 + total water mass / dry air mass
+ ZRV_OV_RD = XRV / XRD
+ ZTHETAV(:,:,:) = 1. + PRT(:,:,:,1)
+ DO JWATER = 2 , 1+KRRL+KRRI
+ ZTHETAV(:,:,:) = ZTHETAV(:,:,:) + PRT(:,:,:,JWATER)
+ END DO
+ ! compute the virtual potential temperature when water is present in any
+ ! form
+ ZTHETAV(:,:,:) = PTHT(:,:,:) * (1. + PRT(:,:,:,1) * ZRV_OV_RD) / ZTHETAV(:,:,:)
+ ELSE
+ ! compute the virtual potential temperature when water is absent
+ ZTHETAV(:,:,:) = PTHT(:,:,:)
+ END IF
+ !
+ ZPHIT(:,:,:)=(PPABST(:,:,:)/XP00)**(XRD/XCPD)-PEXNREF(:,:,:)
+ !
+ELSEIF(CEQNSYS=='LHE') THEN
+ ZPHIT(:,:,:)= ((PPABST(:,:,:)/XP00)**(XRD/XCPD)-PEXNREF(:,:,:)) &
+ * XCPD * PTHVREF(:,:,:)
+ !
+END IF
+!
+IF(CEQNSYS=='LHE'.AND. LFLAT .AND. LCARTESIAN) THEN
+ ! flat cartesian LHE case -> exact solution
+ IF ( HPRESOPT /= "ZRESI" ) THEN
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZDV_SOURCE,ZPHIT)
+ ELSE
+ CALL FLAT_INVZ(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZDV_SOURCE,ZPHIT,&
+ PBFB,&
+ PBF_SXP2_YP1_Z)
+ ENDIF
+ELSE
+ SELECT CASE(HPRESOPT)
+ CASE('RICHA') ! Richardson's method
+!
+ CALL RICHARDSON(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,KTCOUNT,PRELAX,ZDV_SOURCE,ZPHIT)
+!
+ CASE('CGRAD') ! Conjugate Gradient method
+ CALL CONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT)
+ CASE('ZGRAD') ! Conjugate Gradient method
+ CALL ZCONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT)
+!
+ CASE('CRESI') ! Conjugate Residual method
+ CALL CONRESOL(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT)
+!
+ CASE('ZSOLV') ! Conjugate Residual method
+ CALL ZSOLVER(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+ CASE('ZRESI') ! Conjugate Residual method
+ CALL CONRESOLZ(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT, &
+ PBFB,&
+ PBF_SXP2_YP1_Z) !JUAN Z_SPLITING
+ END SELECT
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. ADD THE PRESSURE GRADIENT TO THE SOURCES
+! ----------------------------------------
+!
+IF ( HLBCX(1) /= 'CYCL' ) THEN
+ IF(LWEST_ll()) ZPHIT(IIB-1,:,IKB-1) = ZPHIT(IIB,:,IKB-1)
+ IF(LEAST_ll()) ZPHIT(IIE+1,:,IKB-1) = ZPHIT(IIE,:,IKB-1)
+ENDIF
+IF ( HLBCY(1) /= 'CYCL' ) THEN
+ IF (LSOUTH_ll()) ZPHIT(:,IJB-1,IKB-1) = ZPHIT(:,IJB,IKB-1)
+ IF (LNORTH_ll()) ZPHIT(:,IJE+1,IKB-1) = ZPHIT(:,IJE,IKB-1)
+ENDIF
+!
+IF ( L2D ) THEN
+ IF (LSOUTH_ll()) ZPHIT(:,IJB-1,:) = ZPHIT(:,IJB,:)
+ IF (LNORTH_ll()) ZPHIT(:,IJE+1,:) = ZPHIT(:,IJB,:)
+END IF
+!
+ZDV_SOURCE = GX_M_U(1,IKU,1,ZPHIT,PDXX,PDZZ,PDZX)
+!
+IF ( HLBCX(1) /= 'CYCL' ) THEN
+ IF(LWEST_ll()) THEN
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+ DO JK=2,IKU-1
+ ZDV_SOURCE(IIB,:,JK)= &
+ (ZPHIT(IIB,:,JK) - ZPHIT(IIB-1,:,JK) - 0.5 * ( &
+ PDZX(IIB,:,JK) * (ZPHIT(IIB,:,JK)-ZPHIT(IIB,:,JK-1)) / PDZZ(IIB,:,JK) &
+ +PDZX(IIB,:,JK+1) * (ZPHIT(IIB,:,JK+1)-ZPHIT(IIB,:,JK)) / PDZZ(IIB,:,JK+1) &
+ ) &
+ ) / PDXX(IIB,:,JK)
+ END DO
+ ENDIF
+ !
+ IF(LEAST_ll()) THEN
+ DO JK=2,IKU-1
+ ZDV_SOURCE(IIE+1,:,JK)= &
+ (ZPHIT(IIE+1,:,JK) - ZPHIT(IIE+1-1,:,JK) - 0.5 * ( &
+ PDZX(IIE+1,:,JK) * (ZPHIT(IIE+1-1,:,JK)-ZPHIT(IIE+1-1,:,JK-1)) &
+ / PDZZ(IIE+1-1,:,JK) &
+ +PDZX(IIE+1,:,JK+1) * (ZPHIT(IIE+1-1,:,JK+1)-ZPHIT(IIE+1-1,:,JK)) &
+ / PDZZ(IIE+1-1,:,JK+1) &
+ ) &
+ ) / PDXX(IIE+1,:,JK)
+ END DO
+ END IF
+END IF
+!
+CALL MPPDB_CHECK3DM("before MXM PRESSUREZ :PRU/V/WS",PRECISION,PRUS,PRVS,PRWS)
+IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+ PRUS = PRUS - MXM(PRHODJ * XCPD * ZTHETAV) * ZDV_SOURCE
+ PRWS = PRWS - MZM(PRHODJ * XCPD * ZTHETAV) * GZ_M_W(1,IKU,1,ZPHIT,PDZZ)
+ELSEIF(CEQNSYS=='LHE') THEN
+ PRUS = PRUS - MXM(PRHODJ) * ZDV_SOURCE
+ PRWS = PRWS - MZM(PRHODJ) * GZ_M_W(1,IKU,1,ZPHIT,PDZZ)
+END IF
+!
+IF(.NOT. L2D) THEN
+!
+ ZDV_SOURCE = GY_M_V(1,IKU,1,ZPHIT,PDYY,PDZZ,PDZY)
+!
+ IF ( HLBCY(1) /= 'CYCL' ) THEN
+ IF (LSOUTH_ll()) THEN
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+ DO JK=2,IKU-1
+ ZDV_SOURCE(:,IJB,JK)= &
+ (ZPHIT(:,IJB,JK) - ZPHIT(:,IJB-1,JK) - 0.5 * ( &
+ PDZY(:,IJB,JK) * (ZPHIT(:,IJB,JK)-ZPHIT(:,IJB,JK-1)) / PDZZ(:,IJB,JK) &
+ +PDZY(:,IJB,JK+1) * (ZPHIT(:,IJB,JK+1)-ZPHIT(:,IJB,JK)) / PDZZ(:,IJB,JK+1) &
+ ) &
+ ) / PDYY(:,IJB,JK)
+ END DO
+ END IF
+ !
+ IF (LNORTH_ll()) THEN
+ DO JK=2,IKU-1
+ ZDV_SOURCE(:,IJE+1,JK)= &
+ (ZPHIT(:,IJE+1,JK) - ZPHIT(:,IJE+1-1,JK) - 0.5 * ( &
+ PDZY(:,IJE+1,JK) * (ZPHIT(:,IJE+1-1,JK)-ZPHIT(:,IJE+1-1,JK-1)) &
+ / PDZZ(:,IJE+1-1,JK) &
+ +PDZY(:,IJE+1,JK+1) * (ZPHIT(:,IJE+1-1,JK+1)-ZPHIT(:,IJE+1-1,JK)) &
+ / PDZZ(:,IJE+1-1,JK+1) &
+ ) &
+ ) / PDYY(:,IJE+1,JK)
+ END DO
+ END IF
+ END IF
+!
+ CALL MPPDB_CHECK3DM("before MYM PRESSUREZ :PRU/V/WS",PRECISION,PRUS,PRVS,PRWS)
+ IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+ PRVS = PRVS - MYM(PRHODJ * XCPD * ZTHETAV) * ZDV_SOURCE
+ ELSEIF(CEQNSYS=='LHE') THEN
+ PRVS = PRVS - MYM(PRHODJ) * ZDV_SOURCE
+ END IF
+END IF
+!
+!! same boundary conditions as in gdiv ... !! (provisory coding)
+!! (necessary when NVERB=1)
+!!
+ PRUS(:,:,IKB-1)=PRUS(:,:,IKB)
+ PRUS(:,:,IKE+1)=PRUS(:,:,IKE)
+ PRVS(:,:,IKB-1)=PRVS(:,:,IKB)
+ PRVS(:,:,IKE+1)=PRVS(:,:,IKE)
+!
+NULLIFY(TZFIELDS2_ll)
+CALL ADD3DFIELD_ll( TZFIELDS2_ll, PRUS, 'PRESSUREZ::PRUS' )
+CALL ADD3DFIELD_ll( TZFIELDS2_ll, PRVS, 'PRESSUREZ::PRVS' )
+CALL ADD3DFIELD_ll( TZFIELDS2_ll, PRWS, 'PRESSUREZ::PRWS' )
+CALL UPDATE_HALO_ll(TZFIELDS2_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS2_ll)
+!
+! compute the residual divergence
+CALL GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRUS,PRVS,PRWS,ZDV_SOURCE)
+!
+IF ( CEQNSYS=='DUR' ) THEN
+ IF ( SIZE(PRVREF,1) == 0 ) THEN
+ ZDV_SOURCE=ZDV_SOURCE/PRHODJ/XTH00*PRHODREF*PTHVREF
+ ELSE
+ ZDV_SOURCE=ZDV_SOURCE/PRHODJ/XTH00*PRHODREF*PTHVREF*(1.+PRVREF)
+ END IF
+ELSEIF( CEQNSYS=='MAE' .OR. CEQNSYS=='LHE' ) THEN
+ ZDV_SOURCE=ZDV_SOURCE/PRHODJ*PRHODREF
+END IF
+!
+ZMAXVAL=MAX_ll(ABS(ZDV_SOURCE),IINFO_ll)
+!JUANZ
+IF (PRESENT(PRESIDUAL)) PRESIDUAL = ZMAXVAL
+!JUANZ
+IMAXLOC=GMAXLOC_ll( ABS(ZDV_SOURCE) )
+!
+WRITE(ILUOUT,*) 'residual divergence / 2 DT', ZMAXVAL, &
+ ' located at ', IMAXLOC
+FLUSH(unit=ILUOUT)
+IF (ABS(ZMAXVAL) .GT. 100.0 ) THEN
+ call Print_msg( NVERB_FATAL, 'GEN', 'PRESSUREZ', 'something wrong with pressure: abs(residual) > 100.0' )
+END IF
+! number of iterations adjusted
+IF (LRES) THEN
+ ZMAXRES = XRES
+ELSEIF (LFLAT .AND. LCARTESIAN) THEN
+ ZMAXRES = XRES_FLAT_CART
+ELSE
+ ZMAXRES = XRES_OTHER
+END IF
+!
+IF (OITRADJ) THEN
+ IF (ZMAXVAL>10.*ZMAXRES) THEN
+ KITR=KITR+2
+ WRITE(ILUOUT,*) 'NITR adjusted to ', KITR
+ ELSE IF (ZMAXVAL<ZMAXRES) THEN
+ KITR=MAX(KITR-1,1)
+ WRITE(ILUOUT,*) 'NITR adjusted to ', KITR
+ ENDIF
+ENDIF
+!
+!* 7. STORAGE OF THE FIELDS IN BUDGET ARRAYS
+! --------------------------------------
+!
+IF (LBUDGET_U) CALL BUDGET (PRUS,1,'PRES_BU_RU')
+IF (LBUDGET_V) CALL BUDGET (PRVS,2,'PRES_BU_RV')
+IF (LBUDGET_W) CALL BUDGET (PRWS,3,'PRES_BU_RW')
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. ABSOLUTE PRESSURE COMPUTATION
+! -----------------------------
+!
+ZMAX = MAXVAL(ABS ( PRHODREF(:,:,IKB)-PRHODREF(:,:,IKE)) )
+CALL MPI_ALLREDUCE(ZMAX, ZMAX_ll, 1, MNHREAL_MPI, MPI_MAX, &
+ NMNH_COMM_WORLD, KINFO)
+!IF ( ABS(PRHODREF(IIB,IJB,IKB)-PRHODREF(IIB,IJB,IKE)) > 1.E-12 &
+! .AND. KTCOUNT >0 ) THEN
+IF ((ZMAX_ll > 1.E-12) .AND. KTCOUNT >0 ) THEN
+!IF ( KTCOUNT >0 .AND. .NOT.LBOUSS ) THEN
+ CALL P_ABS ( KRR, KRRL, KRRI, PDRYMASST, PREFMASS, PMASS_O_PHI0, &
+ PTHT, PRT, PRHODJ, PRHODREF, ZTHETAV, PTHVREF, &
+ PRVREF, PEXNREF, ZPHIT )
+!
+ IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+ PPABST(:,:,:)=XP00*(ZPHIT+PEXNREF)**(XCPD/XRD)
+ ELSEIF(CEQNSYS=='LHE') THEN
+ PPABST(:,:,:)=XP00*(ZPHIT/(XCPD*PTHVREF)+PEXNREF)**(XCPD/XRD)
+ ENDIF
+!
+ IF( HLBCX(1) == 'CYCL' ) THEN
+ IF (LWEST_ll()) THEN
+ ZPABS_W(:,:)= PPABST(IIB,:,:)
+ END IF
+!
+ IF (LEAST_ll()) THEN
+ ZPABS_E(:,:)= PPABST(IIE+1,:,:)
+ END IF
+!
+ END IF
+!
+ IF( HLBCY(1) == 'CYCL' ) THEN
+ IF (LSOUTH_ll()) THEN
+ ZPABS_S(:,:)= PPABST(:,IJB,:)
+ END IF
+!
+ IF (LNORTH_ll()) THEN
+ ZPABS_N(:,:)= PPABST(:,IJE+1,:)
+ END IF
+!
+ END IF
+!
+ CALL ADD3DFIELD_ll( TZFIELDS_ll, PPABST, 'PRESSUREZ::PPABST' )
+ CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELDS_ll)
+!
+ IF( HLBCX(1) == 'CYCL' ) THEN
+ IF (LWEST_ll()) THEN
+ PPABST(IIB,:,:) = ZPABS_W(:,:)
+ END IF
+!
+ IF (LEAST_ll()) THEN
+ PPABST(IIE+1,:,:) = ZPABS_E(:,:)
+ END IF
+!
+ END IF
+!
+ IF( HLBCY(1) == 'CYCL' ) THEN
+ IF (LSOUTH_ll()) THEN
+ PPABST(:,IJB,:) = ZPABS_S(:,:)
+ END IF
+!
+ IF (LNORTH_ll()) THEN
+ PPABST(:,IJE+1,:) = ZPABS_N(:,:)
+ END IF
+!
+ END IF
+!
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE PRESSUREZ
diff --git a/src/ZSOLVER/read_exsegn.f90 b/src/ZSOLVER/read_exsegn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..85e867132c14957b8d40a881ad9fe9d337879228
--- /dev/null
+++ b/src/ZSOLVER/read_exsegn.f90
@@ -0,0 +1,2853 @@
+!MNH_LIC Copyright 1994-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! ######################
+ MODULE MODI_READ_EXSEG_n
+! ######################
+!
+INTERFACE
+!
+ SUBROUTINE READ_EXSEG_n(KMI,TPEXSEGFILE,HCONF,OFLAT,OUSERV, &
+ OUSERC,OUSERR,OUSERI,OUSECI,OUSERS,OUSERG,OUSERH, &
+ OUSECHEM,OUSECHAQ,OUSECHIC,OCH_PH,OCH_CONV_LINOX,OSALT, &
+ ODEPOS_SLT, ODUST,ODEPOS_DST, OCHTRANS, &
+ OORILAM,ODEPOS_AER, OLG,OPASPOL, &
+#ifdef MNH_FOREFIRE
+ OFOREFIRE, &
+#endif
+ OLNOX_EXPLICIT, &
+ OCONDSAMP,OBLOWSNOW, &
+ KRIMX,KRIMY, KSV_USER, &
+ HTURB,HTOM,ORMC01,HRAD,HDCONV,HSCONV,HCLOUD,HELEC, &
+ HEQNSYS,PTSTEP_ALL,HSTORAGE_TYPE,HINIFILEPGD )
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPEXSEGFILE ! EXSEG file
+! The following variables are read by READ_DESFM in DESFM descriptor :
+CHARACTER (LEN=*), INTENT(IN) :: HCONF ! configuration var. linked to FMfile
+LOGICAL, INTENT(IN) :: OFLAT ! Logical for zero orography
+LOGICAL, INTENT(IN) :: OUSERV,OUSERC,OUSERR,OUSERI,OUSERS, &
+ OUSERG,OUSERH ! kind of moist variables in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECI ! ice concentration in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECHEM ! Chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHAQ ! Aqueous chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHIC ! Ice chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_PH ! pH FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_CONV_LINOX ! LiNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: ODUST ! Dust FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_DST ! Dust wet deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_SLT ! Sea Salt wet deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_AER ! Orilam wet deposition FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OSALT ! Sea Salt FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OORILAM ! Orilam FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OPASPOL ! Passive pollutant FLAG in FMFILE
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN) :: OFOREFIRE ! ForeFire FLAG in FMFILE
+#endif
+LOGICAL, INTENT(IN) :: OLNOX_EXPLICIT ! explicit LNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCONDSAMP ! Conditional sampling FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OBLOWSNOW ! Blowing snow FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCHTRANS ! LCHTRANS FLAG in FMFILE
+
+LOGICAL, INTENT(IN) :: OLG ! lagrangian FLAG in FMFILE
+INTEGER, INTENT(IN) :: KRIMX, KRIMY ! number of points for the
+ ! horizontal relaxation for the outermost verticals
+INTEGER, INTENT(IN) :: KSV_USER ! number of additional scalar
+ ! variables in FMfile
+CHARACTER (LEN=*), INTENT(IN) :: HTURB ! Kind of turbulence parameterization
+ ! used to produce FMFILE
+CHARACTER (LEN=*), INTENT(IN) :: HTOM ! Kind of third order moment
+LOGICAL, INTENT(IN) :: ORMC01 ! flag for RMC01 SBL computations
+CHARACTER (LEN=*), INTENT(IN) :: HRAD ! Kind of radiation scheme
+CHARACTER (LEN=4), INTENT(IN) :: HDCONV ! Kind of deep convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HSCONV ! Kind of shallow convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of microphysical scheme
+CHARACTER (LEN=4), INTENT(IN) :: HELEC ! Kind of electrical scheme
+CHARACTER (LEN=*), INTENT(IN) :: HEQNSYS! type of equations' system
+REAL,DIMENSION(:), INTENT(INOUT):: PTSTEP_ALL ! Time STEP of ALL models
+CHARACTER (LEN=*), INTENT(IN) :: HSTORAGE_TYPE ! type of initial file
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILEPGD ! name of PGD file
+!
+END SUBROUTINE READ_EXSEG_n
+!
+END INTERFACE
+!
+END MODULE MODI_READ_EXSEG_n
+!
+!
+! #########################################################################
+ SUBROUTINE READ_EXSEG_n(KMI,TPEXSEGFILE,HCONF,OFLAT,OUSERV, &
+ OUSERC,OUSERR,OUSERI,OUSECI,OUSERS,OUSERG,OUSERH, &
+ OUSECHEM,OUSECHAQ,OUSECHIC,OCH_PH,OCH_CONV_LINOX,OSALT, &
+ ODEPOS_SLT, ODUST,ODEPOS_DST, OCHTRANS, &
+ OORILAM,ODEPOS_AER, OLG,OPASPOL, &
+#ifdef MNH_FOREFIRE
+ OFOREFIRE, &
+#endif
+ OLNOX_EXPLICIT, &
+ OCONDSAMP, OBLOWSNOW, &
+ KRIMX,KRIMY, KSV_USER, &
+ HTURB,HTOM,ORMC01,HRAD,HDCONV,HSCONV,HCLOUD,HELEC, &
+ HEQNSYS,PTSTEP_ALL,HSTORAGE_TYPE,HINIFILEPGD )
+! #########################################################################
+!
+!!**** *READ_EXSEG_n * - routine to read the descriptor file EXSEG
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to read the descriptor file called
+! EXSEG and to control the coherence with FMfile data .
+!
+!!
+!!** METHOD
+!! ------
+!! The descriptor file is read. Namelists (NAMXXXn) which contain
+!! variables linked to one nested model are at the beginning of the file.
+!! Namelists (NAMXXX) which contain variables common to all models
+!! are at the end of the file. When the model index is different from 1,
+!! the end of the file (namelists NAMXXX) is not read.
+!!
+!! Coherence between the initial file (description read in DESFM file)
+!! and the segment to perform (description read in EXSEG file)
+!! is checked for segment achievement configurations
+!! or postprocessing configuration. The get indicators are set according
+!! to the following check :
+!!
+!! - segment achievement and preinit configurations :
+!!
+!! * if there is no turbulence kinetic energy in initial
+!! file (HTURB='NONE'), and the segment to perform requires a turbulence
+!! parameterization (CTURB /= 'NONE'), the get indicators for turbulence
+!! kinetic energy variables are set to 'INIT'; i.e. these variables will be
+!! set equal to zero by READ_FIELD according to the get indicators.
+!! * The same procedure is applied to the dissipation of TKE.
+!! * if there is no moist variables RRn in initial file (OUSERn=.FALSE.)
+!! and the segment to perform requires moist variables RRn
+!! (LUSERn=.TRUE.), the get indicators for moist variables RRn are set
+!! equal to 'INIT'; i.e. these variables will be set equal to zero by
+!! READ_FIELD according to the get indicators.
+!! * if there are KSV_USER additional scalar variables in initial file and the
+!! segment to perform needs more than KSV_USER additional variables, the get
+!! indicators for these (NSV_USER-KSV_USER) additional scalar variables are set
+!! equal to 'INIT'; i.e. these variables will be set equal to zero by
+!! READ_FIELD according to the get indicators. If the segment to perform
+!! needs less additional scalar variables than there are in initial file,
+!! the get indicators for these (KSV_USER - NSV_USER) additional scalar variables are
+!! set equal to 'SKIP'.
+!! * warning messages are printed if the fields in initial file are the
+!! same at time t and t-dt (HCONF='START') and a leap-frog advance
+!! at first time step will be used for the segment to perform
+!! (CCONF='RESTA'); It is likewise when HCONF='RESTA' and CCONF='START'.
+!! * A warning message is printed if the orography in initial file is zero
+!! (OFLAT=.TRUE.) and the segment to perform considers no-zero orography
+!! (LFLAT=.FALSE.). It is likewise for LFLAT=.TRUE. and OFLAT=.FALSE..
+!! If the segment to perform requires zero orography (LFLAT=.TRUE.), the
+!! orography (XZS) will not read in initial file but set equal to zero
+!! by SET_GRID.
+!! * check of the depths of the Lateral Damping Layer in x and y
+!! direction is performed
+!! * If some coupling files are specified, LSTEADYLS is set to T
+!! * If no coupling files are specified, LSTEADYLS is set to F
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_CONF : CCONF,LTHINSHELL,LFLAT,NMODEL,NVERB
+!!
+!! Module MODN_DYN : LCORIO, LZDIFFU
+!!
+!! Module MODN_NESTING : NDAD(m),NDTRATIO(m),XWAY(m)
+!!
+!! Module MODN_BUDGET : CBUTYPE,XBULEN
+!!
+!! Module MODN_CONF1 : LUSERV,LUSERC,LUSERR,LUSERI,LUSERS,LUSERG,LUSERH,CSEG
+!!
+!! Module MODN_DYN1 : XTSTEP,CPRESOPT,NITR,XRELAX
+!!
+!! Module MODD_ADV1 : CMET_ADV_SCHEME,CSV_ADV_SCHEME,CUVW_ADV_SCHEME,NLITER
+!!
+!! Module MODN_PARAM1 : CTURB,CRAD,CDCONV,CSCONV
+!!
+!! Module MODN_LUNIT1 :
+!! Module MODN_LBC1 : CLBCX,CLBCY,NLBLX,NLBLY,XCPHASE,XPOND
+!!
+!! Module MODN_TURB_n : CTURBLEN,CTURBDIM
+!!
+!! Module MODD_GET1:
+!! CGETTKEM,CGETTKET,
+!! CGETRVM,CGETRCM,CGETRRM,CGETRIM,CGETRSM,CGETRGM,CGETRHM
+!! CGETRVT,CGETRCT,CGETRRT,CGETRIT,CGETRST,CGETRGT,CGETRHT,CGETSVM
+!! CGETSVT,CGETSIGS,CGETSRCM,CGETSRCT
+!! NCPL_NBR,NCPL_TIMES,NCPL_CUR
+!! Module MODN_LES : contains declaration of the control parameters
+!! for Large Eddy Simulations' storages
+!! for the forcing
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation (routine READ_EXSEG_n)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/06/94
+!! Modification 26/10/94 (Stein) remove NAM_GET from the Namelists
+!! present in DESFM + change the namelist names
+!! Modification 22/11/94 (Stein) add GET indicator for phi
+!! Modification 21/12/94 (Stein) add GET indicator for LS fields
+!! Modification 06/01/95 (Stein) bug in the test for Scalar Var.
+!! Modifications 09/01/95 (Stein) add the turbulence scheme
+!! Modifications 09/01/95 (Stein) add the 1D switch
+!! Modifications 10/03/95 (Mallet) add coherence in coupling case
+!! Modifications 16/03/95 (Stein) remove R from the historical variables
+!! Modifications 01/03/95 (Hereil) add the budget namelists
+!! Modifications 16/06/95 (Stein) coherence control for the
+!! microphysical scheme + remove the wrong messge for RESTA conf
+!! Modifications 30/06/95 (Stein) conditionnal reading of the fields
+!! used by the moist turbulence scheme
+!! Modifications 12/09/95 (Pinty) add the radiation scheme
+!! Modification 06/02/96 (J.Vila) implement scalar advection schemes
+!! Modifications 24/02/96 (Stein) change the default value for CCPLFILE
+!! Modifications 02/05/96 (Stein Jabouille) change the Z0SEA activation
+!! Modifications 24/05/96 (Stein) change the SRC SIGS control
+!! Modifications 08/09/96 (Masson) the coupling file names are reset to
+!! default value " " before reading in EXSEG1.nam
+!! to avoid extra non-existant coupling files
+!!
+!! Modifications 25/04/95 (K.Suhre)add namelist NAM_BLANK
+!! add read for LFORCING
+!! 25/04/95 (K.Suhre)add namelist NAM_FRC
+!! and switch checking
+!! 06/08/96 (K.Suhre)add namelist NAM_CH_MNHCn
+!! and NAM_CH_SOLVER
+!! Modifications 10/10/96 (Stein) change SRC into SRCM and SRCT
+!! Modifications 11/04/96 (Pinty) add the rain-ice microphysical scheme
+!! Modifications 11/01/97 (Pinty) add the deep convection scheme
+!! Modifications 22/05/97 (Lafore) gridnesting implementation
+!! Modifications 22/06/97 (Stein) add the absolute pressure + cleaning
+!! Modifications 25/08/97 (Masson) add tests on surface schemes
+!! 22/10/97 (Stein) remove the RIMX /= 0 control
+!! + new namelist + cleaning
+!! Modifications 17/04/98 (Masson) add tests on character variables
+!! Modification 15/03/99 (Masson) add tests on PROGRAM
+!! Modification 04/01/00 (Masson) removes TSZ0 case
+!! Modification 04/06/00 (Pinty) add C2R2 scheme
+!! 11/12/00 (Tomasini) add CSEA_FLUX to MODD_PARAMn
+!! delete the test on SST_FRC only in 1D
+!! Modification 22/01/01 (Gazen) change NSV,KSV to NSV_USER,KSV_USER and add
+!! NSV_* variables initialization
+!! Modification 15/10/01 (Mallet) allow namelists in different orders
+!! Modification 18/03/02 (Solmon) new radiation scheme test
+!! Modification 29/11/02 (JP Pinty) add C3R5, ICE2, ICE4, ELEC
+!! Modification 06/11/02 (Masson) new LES BL height diagnostic
+!! Modification 06/11/02 (Jabouille) remove LTHINSHELL LFORCING test
+!! Modification 01/12/03 (Gazen) change Chemical scheme interface
+!! Modification 01/2004 (Masson) removes surface (externalization)
+!! Modification 01/2005 (Masson) removes 1D and 2D switches
+!! Modification 04/2005 (Tulet) add dust, orilam
+!! Modification 03/2006 (O.Geoffroy) Add KHKO scheme
+!! Modification 04/2006 (Maric) include 4th order advection scheme
+!! Modification 05/2006 (Masson) add nudging
+!! Modification 05/2006 Remove KEPS
+!! Modification 04/2006 (Maric) include PPM advection scheme
+!! Modification 04/2006 (J.Escobar) Bug dollarn add CALL UPDATE_NAM_CONFN
+!! Modifications 01/2007 (Malardel,Pergaud) add the MF shallow
+!! convection scheme MODN_PARAM_MFSHALL_n
+!! Modification 09/2009 (J.Escobar) add more info on relaxation problems
+!! Modification 09/2011 (J.Escobar) re-add 'ZRESI' choose
+!! Modification 12/2011 (C.Lac) Adaptation to FIT temporal scheme
+!! Modification 12/2012 (S.Bielli) add NAM_NCOUT for netcdf output (removed 08/07/2016)
+!! Modification 02/2012 (Pialat/Tulet) add ForeFire
+!! Modification 02/2012 (T.Lunet) add of new Runge-Kutta methods
+!! Modification 01/2015 (C. Barthe) add explicit LNOx
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! M.Leriche 18/12/2015 : bug chimie glace dans prep_real_case
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Modification 02/2016 (M.Leriche) treat gas and aq. chemicals separately
+!! P.Wautelet 08/07/2016 : removed MNH_NCWRIT define
+!! Modification 10/2016 (C.LAC) Add OSPLIT_WENO + Add droplet
+!! deposition + Add max values
+!! Modification 11/2016 (Ph. Wautelet) Allocate/initialise some output/backup structures
+!! Modification 03/2017 (JP Chaboureau) Fix the initialization of
+!! LUSERx-type variables for LIMA
+!! M.Leriche 06/2017 for spawn and prep_real avoid abort if wet dep for
+!! aerosol and no cloud scheme defined
+!! Q.Libois 02/2018 ECRAD
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Modification 07/2017 (V. Vionnet) add blowing snow scheme
+!! Modification 01/2019 (Q. Rodier) define XCEDIS depending on BL89 or RM17 mixing length
+!! Modification 01/2019 (P. Wautelet) bugs correction: incorrect writes
+!! Modification 01/2019 (R. Honnert) remove SURF in CMF_UPDRAFT
+!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+!!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_CONFZ
+USE MODD_CONF_n, ONLY: CSTORAGE_TYPE
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_VAR_ll, ONLY: NPROC
+!
+USE MODN_BACKUP
+USE MODN_BUDGET
+USE MODN_LES
+USE MODN_CONF
+USE MODN_CONFZ
+USE MODN_FRC
+USE MODN_DYN
+USE MODN_NESTING
+USE MODN_OUTPUT
+USE MODN_CONF_n
+USE MODN_LBC_n ! routine is used for each nested model. This has been done
+USE MODN_DYN_n ! to avoid the duplication of this routine for each model.
+USE MODN_ADV_n ! The final filling of these modules for the model n is
+USE MODN_PARAM_n ! realized in subroutine ini_model n
+USE MODN_PARAM_RAD_n
+USE MODN_PARAM_ECRAD_n
+USE MODN_PARAM_KAFR_n
+USE MODN_PARAM_MFSHALL_n
+USE MODN_PARAM_ICE
+USE MODN_LUNIT_n
+USE MODN_NUDGING_n
+USE MODN_TURB_n
+USE MODN_DRAG_n
+USE MODN_BLANK
+USE MODN_CH_MNHC_n
+USE MODN_CH_SOLVER_n
+USE MODN_PARAM_C2R2, ONLY : EPARAM_CCN=>HPARAM_CCN, EINI_CCN=>HINI_CCN, &
+ WNUC=>XNUC, WALPHAC=>XALPHAC, NAM_PARAM_C2R2
+USE MODN_PARAM_C1R3, ONLY : NAM_PARAM_C1R3, CPRISTINE_ICE_C1R3, &
+ CHEVRIMED_ICE_C1R3
+USE MODN_PARAM_LIMA, ONLY : FINI_CCN=>HINI_CCN,NAM_PARAM_LIMA,NMOD_CCN,LSCAV, &
+ CPRISTINE_ICE_LIMA, CHEVRIMED_ICE_LIMA, NMOD_IFN, &
+ LCOLD, LACTI, LNUCL, XALPHAC, XNUC, LMEYERS, LHAIL
+USE MODN_ELEC
+USE MODN_SERIES
+USE MODN_SERIES_n
+USE MODN_TURB_CLOUD
+USE MODN_TURB
+USE MODN_MEAN
+USE MODN_DRAGTREE
+USE MODN_LATZ_EDFLX
+!
+USE MODD_NSV,NSV_USER_n=>NSV_USER
+USE MODD_DYN
+USE MODD_DYN_n, ONLY : LHORELAX_SVLIMA
+USE MODD_GET_n
+USE MODD_GR_FIELD_n
+!
+USE MODE_POS
+USE MODE_MSG
+!
+USE MODI_TEST_NAM_VAR
+USE MODI_INI_NSV
+USE MODI_CH_INIT_SCHEME_n
+USE MODN_CH_ORILAM
+USE MODD_CH_AEROSOL
+USE MODD_DUST
+USE MODD_SALT
+USE MODD_PASPOL
+#ifdef MNH_FOREFIRE
+USE MODD_FOREFIRE
+USE MODN_FOREFIRE
+#endif
+USE MODD_CONDSAMP
+USE MODD_BLOWSNOW
+USE MODN_DUST
+USE MODN_SALT
+USE MODD_CH_M9_n, ONLY : NEQ
+USE MODN_PASPOL
+USE MODN_CONDSAMP
+USE MODN_BLOWSNOW
+USE MODN_BLOWSNOW_n
+USE MODN_2D_FRC
+USE MODN_VISCOSITY
+USE MODD_VISCOSITY
+USE MODD_DRAG_n
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPEXSEGFILE ! EXSEG file
+! The following variables are read by READ_DESFM in DESFM descriptor :
+CHARACTER (LEN=*), INTENT(IN) :: HCONF ! configuration var. linked to FMfile
+LOGICAL, INTENT(IN) :: OFLAT ! Logical for zero orography
+LOGICAL, INTENT(IN) :: OUSERV,OUSERC,OUSERR,OUSERI,OUSERS, &
+ OUSERG,OUSERH ! kind of moist variables in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECI ! ice concentration in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECHEM ! Chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHAQ ! Aqueous chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHIC ! Ice chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_PH ! pH FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_CONV_LINOX ! LiNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: ODUST ! Dust FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_DST ! Dust Deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_SLT ! Sea Salt wet deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_AER ! Orilam wet deposition FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OSALT ! Sea Salt FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OORILAM ! Orilam FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OPASPOL ! Passive pollutant FLAG in FMFILE
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN) :: OFOREFIRE ! ForeFire FLAG in FMFILE
+#endif
+LOGICAL, INTENT(IN) :: OLNOX_EXPLICIT ! explicit LNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCONDSAMP ! Conditional sampling FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCHTRANS ! LCHTRANS FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OBLOWSNOW ! Blowing snow FLAG in FMFILE
+
+LOGICAL, INTENT(IN) :: OLG ! lagrangian FLAG in FMFILE
+INTEGER, INTENT(IN) :: KRIMX, KRIMY ! number of points for the
+ ! horizontal relaxation for the outermost verticals
+INTEGER, INTENT(IN) :: KSV_USER ! number of additional scalar
+ ! variables in FMfile
+CHARACTER (LEN=*), INTENT(IN) :: HTURB ! Kind of turbulence parameterization
+ ! used to produce FMFILE
+CHARACTER (LEN=*), INTENT(IN) :: HTOM ! Kind of third order moment
+LOGICAL, INTENT(IN) :: ORMC01 ! flag for RMC01 SBL computations
+CHARACTER (LEN=*), INTENT(IN) :: HRAD ! Kind of radiation scheme
+CHARACTER (LEN=4), INTENT(IN) :: HDCONV ! Kind of deep convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HSCONV ! Kind of shallow convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of microphysical scheme
+CHARACTER (LEN=4), INTENT(IN) :: HELEC ! Kind of electrical scheme
+CHARACTER (LEN=*), INTENT(IN) :: HEQNSYS! type of equations' system
+REAL,DIMENSION(:), INTENT(INOUT):: PTSTEP_ALL ! Time STEP of ALL models
+CHARACTER (LEN=*), INTENT(IN) :: HSTORAGE_TYPE ! type of initial file
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILEPGD ! name of PGD file
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILUSEG,ILUOUT ! logical unit numbers of EXSEG file and outputlisting
+INTEGER :: JS,JCI,JI,JSV ! Loop indexes
+LOGICAL :: GRELAX
+LOGICAL :: GFOUND ! Return code when searching namelist
+!
+INTEGER :: IMOMENTS, JMODE, IMODEIDX, JMOM, JSV_NAME, JMOD, I
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. READ EXSEG FILE
+! ---------------
+!
+CALL PRINT_MSG(NVERB_DEBUG,'IO','READ_EXSEG_n','called for '//TRIM(TPEXSEGFILE%CNAME))
+!
+ILUSEG = TPEXSEGFILE%NLU
+ILUOUT = TLUOUT%NLU
+!
+CALL INIT_NAM_LUNITN
+CCPLFILE(:)=" "
+CALL INIT_NAM_CONFN
+CALL INIT_NAM_DYNN
+CALL INIT_NAM_ADVN
+CALL INIT_NAM_PARAMN
+CALL INIT_NAM_PARAM_RADN
+#ifdef MNH_ECRAD
+CALL INIT_NAM_PARAM_ECRADN
+#endif
+CALL INIT_NAM_PARAM_KAFRN
+CALL INIT_NAM_PARAM_MFSHALLN
+CALL INIT_NAM_LBCN
+CALL INIT_NAM_NUDGINGN
+CALL INIT_NAM_TURBN
+CALL INIT_NAM_DRAGN
+CALL INIT_NAM_CH_MNHCN
+CALL INIT_NAM_CH_SOLVERN
+CALL INIT_NAM_SERIESN
+CALL INIT_NAM_BLOWSNOWN
+!
+WRITE(UNIT=ILUOUT,FMT="(/,'READING THE EXSEG.NAM FILE')")
+CALL POSNAM(ILUSEG,'NAM_LUNITN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LUNITn)
+CALL POSNAM(ILUSEG,'NAM_CONFN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONFn)
+CALL POSNAM(ILUSEG,'NAM_DYNN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DYNn)
+CALL POSNAM(ILUSEG,'NAM_ADVN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_ADVn)
+CALL POSNAM(ILUSEG,'NAM_PARAMN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAMn)
+CALL POSNAM(ILUSEG,'NAM_PARAM_RADN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_RADn)
+#ifdef MNH_ECRAD
+CALL POSNAM(ILUSEG,'NAM_PARAM_ECRADN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_ECRADn)
+#endif
+CALL POSNAM(ILUSEG,'NAM_PARAM_KAFRN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_KAFRn)
+CALL POSNAM(ILUSEG,'NAM_PARAM_MFSHALLN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_MFSHALLn)
+CALL POSNAM(ILUSEG,'NAM_LBCN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LBCn)
+CALL POSNAM(ILUSEG,'NAM_NUDGINGN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_NUDGINGn)
+CALL POSNAM(ILUSEG,'NAM_TURBN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_TURBn)
+CALL POSNAM(ILUSEG,'NAM_DRAGN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DRAGn)
+CALL POSNAM(ILUSEG,'NAM_CH_MNHCN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CH_MNHCn)
+CALL POSNAM(ILUSEG,'NAM_CH_SOLVERN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CH_SOLVERn)
+CALL POSNAM(ILUSEG,'NAM_SERIESN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_SERIESn)
+CALL POSNAM(ILUSEG,'NAM_BLOWSNOWN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BLOWSNOWn)
+!
+IF (KMI == 1) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' namelists common to all the models ')")
+ CALL POSNAM(ILUSEG,'NAM_CONF',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONF)
+ CALL POSNAM(ILUSEG,'NAM_CONFZ',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONFZ)
+ CALL POSNAM(ILUSEG,'NAM_DYN',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DYN)
+ CALL POSNAM(ILUSEG,'NAM_NESTING',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_NESTING)
+ CALL POSNAM(ILUSEG,'NAM_BACKUP',GFOUND,ILUOUT)
+ IF (GFOUND) THEN
+ !Should have been allocated before in READ_DESFM_n
+ IF (.NOT.ALLOCATED(XBAK_TIME)) THEN
+ ALLOCATE(XBAK_TIME(NMODEL,JPOUTMAX))
+ XBAK_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(XOUT_TIME)) THEN
+ ALLOCATE(XOUT_TIME(NMODEL,JPOUTMAX)) !Allocate *OUT* variables to prevent
+ XOUT_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NBAK_STEP)) THEN
+ ALLOCATE(NBAK_STEP(NMODEL,JPOUTMAX))
+ NBAK_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NOUT_STEP)) THEN
+ ALLOCATE(NOUT_STEP(NMODEL,JPOUTMAX)) !problems if NAM_OUTPUT does not exist
+ NOUT_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(COUT_VAR)) THEN
+ ALLOCATE(COUT_VAR (NMODEL,JPOUTVARMAX))
+ COUT_VAR(:,:) = ''
+ END IF
+ READ(UNIT=ILUSEG,NML=NAM_BACKUP)
+ ELSE
+ CALL POSNAM(ILUSEG,'NAM_FMOUT',GFOUND)
+ IF (GFOUND) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'IO','READ_EXSEG_n','use namelist NAM_BACKUP instead of namelist NAM_FMOUT')
+ ELSE
+ IF (CPROGRAM=='MESONH') CALL PRINT_MSG(NVERB_ERROR,'IO','READ_EXSEG_n','namelist NAM_BACKUP not found')
+ END IF
+ END IF
+ CALL POSNAM(ILUSEG,'NAM_OUTPUT',GFOUND,ILUOUT)
+ IF (GFOUND) THEN
+ !Should have been allocated before in READ_DESFM_n
+ IF (.NOT.ALLOCATED(XBAK_TIME)) THEN
+ ALLOCATE(XBAK_TIME(NMODEL,JPOUTMAX)) !Allocate *BAK* variables to prevent
+ XBAK_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(XOUT_TIME)) THEN
+ ALLOCATE(XOUT_TIME(NMODEL,JPOUTMAX))
+ XOUT_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NBAK_STEP)) THEN
+ ALLOCATE(NBAK_STEP(NMODEL,JPOUTMAX)) !problems if NAM_BACKUP does not exist
+ NBAK_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NOUT_STEP)) THEN
+ ALLOCATE(NOUT_STEP(NMODEL,JPOUTMAX))
+ NOUT_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(COUT_VAR)) THEN
+ ALLOCATE(COUT_VAR (NMODEL,JPOUTVARMAX))
+ COUT_VAR(:,:) = ''
+ END IF
+ READ(UNIT=ILUSEG,NML=NAM_OUTPUT)
+ END IF
+ CALL POSNAM(ILUSEG,'NAM_BUDGET',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BUDGET)
+ CALL POSNAM(ILUSEG,'NAM_BU_RU',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RU)
+ CALL POSNAM(ILUSEG,'NAM_BU_RV',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RV)
+ CALL POSNAM(ILUSEG,'NAM_BU_RW',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RW)
+ CALL POSNAM(ILUSEG,'NAM_BU_RTH',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RTH)
+ CALL POSNAM(ILUSEG,'NAM_BU_RTKE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RTKE)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRV',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRV)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRC)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRR',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRR)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRI',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRI)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRS',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRS)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRG',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRG)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRH',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRH)
+ CALL POSNAM(ILUSEG,'NAM_BU_RSV',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RSV)
+ CALL POSNAM(ILUSEG,'NAM_LES',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LES)
+ CALL POSNAM(ILUSEG,'NAM_MEAN',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_MEAN)
+ CALL POSNAM(ILUSEG,'NAM_PDF',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PDF)
+ CALL POSNAM(ILUSEG,'NAM_BLANK',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BLANK)
+ CALL POSNAM(ILUSEG,'NAM_FRC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_FRC)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_ICE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_ICE)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_C2R2',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_C2R2)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_C1R3',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_C1R3)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_LIMA',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_LIMA)
+ CALL POSNAM(ILUSEG,'NAM_ELEC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_ELEC)
+ CALL POSNAM(ILUSEG,'NAM_SERIES',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_SERIES)
+ CALL POSNAM(ILUSEG,'NAM_TURB_CLOUD',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_TURB_CLOUD)
+ CALL POSNAM(ILUSEG,'NAM_TURB',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_TURB)
+ CALL POSNAM(ILUSEG,'NAM_CH_ORILAM',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CH_ORILAM)
+ CALL POSNAM(ILUSEG,'NAM_DUST',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DUST)
+ CALL POSNAM(ILUSEG,'NAM_SALT',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_SALT)
+ CALL POSNAM(ILUSEG,'NAM_PASPOL',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PASPOL)
+#ifdef MNH_FOREFIRE
+ CALL POSNAM(ILUSEG,'NAM_FOREFIRE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_FOREFIRE)
+#endif
+ CALL POSNAM(ILUSEG,'NAM_CONDSAMP',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONDSAMP)
+ CALL POSNAM(ILUSEG,'NAM_DRAGTREE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DRAGTREE)
+ CALL POSNAM(ILUSEG,'NAM_2D_FRC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_2D_FRC)
+ CALL POSNAM(ILUSEG,'NAM_LATZ_EDFLX',GFOUND)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LATZ_EDFLX)
+ CALL POSNAM(ILUSEG,'NAM_BLOWSNOW',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BLOWSNOW)
+ CALL POSNAM(ILUSEG,'NAM_VISC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_VISC)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+CALL TEST_NAM_VAR(ILUOUT,'CPRESOPT',CPRESOPT,'RICHA','CGRAD','CRESI','ZRESI','ZSOLV',&
+ 'ZGRAD')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CUVW_ADV_SCHEME',CUVW_ADV_SCHEME, &
+ 'CEN4TH','CEN2ND','WENO_K' )
+CALL TEST_NAM_VAR(ILUOUT,'CMET_ADV_SCHEME',CMET_ADV_SCHEME, &
+ &'PPM_00','PPM_01','PPM_02')
+CALL TEST_NAM_VAR(ILUOUT,'CSV_ADV_SCHEME',CSV_ADV_SCHEME, &
+ &'PPM_00','PPM_01','PPM_02')
+CALL TEST_NAM_VAR(ILUOUT,'CTEMP_SCHEME',CTEMP_SCHEME, &
+ &'RK11','RK21','RK33','RKC4','RK53','RK4B','RK62','RK65','NP32','SP32','LEFR')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CTURB',CTURB,'NONE','TKEL')
+CALL TEST_NAM_VAR(ILUOUT,'CRAD',CRAD,'NONE','FIXE','ECMW',&
+#ifdef MNH_ECRAD
+ 'ECRA',&
+#endif
+ 'TOPA')
+CALL TEST_NAM_VAR(ILUOUT,'CCLOUD',CCLOUD,'NONE','REVE','KESS', &
+ & 'ICE3','ICE4','C2R2','C3R5','KHKO','LIMA')
+CALL TEST_NAM_VAR(ILUOUT,'CDCONV',CDCONV,'NONE','KAFR')
+CALL TEST_NAM_VAR(ILUOUT,'CSCONV',CSCONV,'NONE','KAFR','EDKF')
+CALL TEST_NAM_VAR(ILUOUT,'CELEC',CELEC,'NONE','ELE3','ELE4')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CAER',CAER,'TANR','TEGE','SURF','NONE')
+CALL TEST_NAM_VAR(ILUOUT,'CAOP',CAOP,'CLIM','EXPL')
+CALL TEST_NAM_VAR(ILUOUT,'CLW',CLW,'RRTM','MORC')
+CALL TEST_NAM_VAR(ILUOUT,'CEFRADL',CEFRADL,'PRES','OCLN','MART','C2R2','LIMA')
+CALL TEST_NAM_VAR(ILUOUT,'CEFRADI',CEFRADI,'FX40','LIOU','SURI','C3R5','LIMA')
+CALL TEST_NAM_VAR(ILUOUT,'COPWLW',COPWLW,'SAVI','SMSH','LILI','MALA')
+CALL TEST_NAM_VAR(ILUOUT,'COPILW',COPILW,'FULI','EBCU','SMSH','FU98')
+CALL TEST_NAM_VAR(ILUOUT,'COPWSW',COPWSW,'SLIN','FOUQ','MALA')
+CALL TEST_NAM_VAR(ILUOUT,'COPISW',COPISW,'FULI','EBCU','FU96')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CLBCX(1)',CLBCX(1),'CYCL','WALL','OPEN')
+CALL TEST_NAM_VAR(ILUOUT,'CLBCX(2)',CLBCX(2),'CYCL','WALL','OPEN')
+CALL TEST_NAM_VAR(ILUOUT,'CLBCY(1)',CLBCY(1),'CYCL','WALL','OPEN')
+CALL TEST_NAM_VAR(ILUOUT,'CLBCY(2)',CLBCY(2),'CYCL','WALL','OPEN')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CTURBDIM',CTURBDIM,'1DIM','3DIM')
+CALL TEST_NAM_VAR(ILUOUT,'CTURBLEN',CTURBLEN,'DELT','BL89','RM17','DEAR','BLKR')
+CALL TEST_NAM_VAR(ILUOUT,'CTOM',CTOM,'NONE','TM06')
+CALL TEST_NAM_VAR(ILUOUT,'CSUBG_AUCV',CSUBG_AUCV,'NONE','CLFR','SIGM','PDF')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CCH_TDISCRETIZATION',CCH_TDISCRETIZATION, &
+ 'SPLIT ','CENTER ','LAGGED ')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CCONF',CCONF,'START','RESTA')
+CALL TEST_NAM_VAR(ILUOUT,'CEQNSYS',CEQNSYS,'LHE','DUR','MAE')
+CALL TEST_NAM_VAR(ILUOUT,'CSPLIT',CSPLIT,'BSPLITTING','XSPLITTING','YSPLITTING')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CBUTYPE',CBUTYPE,'NONE','CART','MASK')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CRELAX_HEIGHT_TYPE',CRELAX_HEIGHT_TYPE,'FIXE','THGR')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CLES_NORM_TYPE',CLES_NORM_TYPE,'NONE','CONV','EKMA','MOBU')
+CALL TEST_NAM_VAR(ILUOUT,'CBL_HEIGHT_DEF',CBL_HEIGHT_DEF,'TKE','KE','WTV','FRI','DTH')
+CALL TEST_NAM_VAR(ILUOUT,'CTURBLEN_CLOUD',CTURBLEN_CLOUD,'NONE','DEAR','DELT','BL89')
+!
+! The test on the mass flux scheme for shallow convection
+!
+CALL TEST_NAM_VAR(ILUOUT,'CMF_UPDRAFT',CMF_UPDRAFT,'NONE','EDKF','RHCJ',&
+ 'HRIO','BOUT')
+CALL TEST_NAM_VAR(ILUOUT,'CMF_CLOUD',CMF_CLOUD,'NONE','STAT','DIRE')
+!
+! The test on the CSOLVER name is made elsewhere
+!
+CALL TEST_NAM_VAR(ILUOUT,'CPRISTINE_ICE',CPRISTINE_ICE,'PLAT','COLU','BURO')
+CALL TEST_NAM_VAR(ILUOUT,'CSEDIM',CSEDIM,'SPLI','STAT','NONE')
+IF( CCLOUD == 'C3R5' ) THEN
+ CALL TEST_NAM_VAR(ILUOUT,'CPRISTINE_ICE_C1R3',CPRISTINE_ICE_C1R3, &
+ 'PLAT','COLU','BURO')
+ CALL TEST_NAM_VAR(ILUOUT,'CHEVRIMED_ICE_C1R3',CHEVRIMED_ICE_C1R3, &
+ 'GRAU','HAIL')
+END IF
+!
+IF( CCLOUD == 'LIMA' ) THEN
+ CALL TEST_NAM_VAR(ILUOUT,'CPRISTINE_ICE_LIMA',CPRISTINE_ICE_LIMA, &
+ 'PLAT','COLU','BURO')
+ CALL TEST_NAM_VAR(ILUOUT,'CHEVRIMED_ICE_LIMA',CHEVRIMED_ICE_LIMA, &
+ 'GRAU','HAIL')
+END IF
+IF(LBLOWSNOW) THEN
+ CALL TEST_NAM_VAR(ILUOUT,'CSNOWSEDIM',CSNOWSEDIM,'NONE','MITC','CARR','TABC')
+ IF (XALPHA_SNOW .NE. 3 .AND. CSNOWSEDIM=='TABC') THEN
+ WRITE(ILUOUT,*) '*****************************************'
+ WRITE(ILUOUT,*) '* XALPHA_SNW must be set to 3 when '
+ WRITE(ILUOUT,*) '* CSNOWSEDIM = TABC '
+ WRITE(ILUOUT,*) '* Update the look-up table in BLOWSNOW_SEDIM_LKT1D '
+ WRITE(ILUOUT,*) '* to use TABC with a different value of XEMIALPHA_SNW'
+ WRITE(ILUOUT,*) '*****************************************'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ ENDIF
+END IF
+!
+!-------------------------------------------------------------------------------!
+!* 2. FIRST INITIALIZATIONS
+! ---------------------
+!
+!* 2.1 Time step in gridnesting case
+!
+IF (KMI /= 1 .AND. NDAD(KMI) /= KMI) THEN
+ XTSTEP = PTSTEP_ALL(NDAD(KMI)) / NDTRATIO(KMI)
+END IF
+PTSTEP_ALL(KMI) = XTSTEP
+!
+!* 2.2 Fill the global configuration module
+!
+! Check coherence between the microphysical scheme and water species and
+!initialize the logicals LUSERn
+!
+SELECT CASE ( CCLOUD )
+ CASE ( 'NONE' )
+ IF (.NOT. ( (.NOT. LUSERC) .AND. (.NOT. LUSERR) .AND. (.NOT. LUSERI) .AND. &
+ (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) .AND. CPROGRAM=='MESONH' ) THEN
+!
+ LUSERC=.FALSE.
+ LUSERR=.FALSE.; LUSERI=.FALSE.
+ LUSERS=.FALSE.; LUSERG=.FALSE.
+ LUSERH=.FALSE.
+!
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM') THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE THE SUBGRID AUTOCONVERSION SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT MICROPHYSICS'
+ WRITE(UNIT=ILUOUT,FMT=*) ' CSUBG_AUCV IS PUT TO "NONE"'
+!
+ CSUBG_AUCV = 'NONE'
+!
+ END IF
+!
+ CASE ( 'REVE' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. (.NOT. LUSERR) .AND. (.NOT. LUSERI) &
+ .AND. (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) ) THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A REVERSIBLE MICROPHYSICAL " ,&
+ &" SCHEME. YOU WILL ONLY HAVE VAPOR AND CLOUD WATER ",/, &
+ &" LUSERV AND LUSERC ARE TO TRUE AND THE OTHERS TO FALSE ")')
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE.
+ LUSERR=.FALSE.; LUSERI=.FALSE.
+ LUSERS=.FALSE.; LUSERG=.FALSE.
+ LUSERH=.FALSE.
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM') THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH A REVERSIBLE MICROPHYSICAL SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) ' AND THE SUBGRID AUTOCONVERSION SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT YOU DO NOT HAVE RAIN in the "REVE" SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) ' CSUBG_AUCV IS PUT TO "NONE"'
+!
+ CSUBG_AUCV = 'NONE'
+!
+ END IF
+!
+ CASE ( 'KESS' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. (.NOT. LUSERI) .AND. &
+ (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) ) THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A KESSLER MICROPHYSICAL " , &
+ &" SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER AND RAIN ",/, &
+ &" LUSERV, LUSERC AND LUSERR ARE SET TO TRUE AND THE OTHERS TO FALSE ")')
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.FALSE.; LUSERS=.FALSE.
+ LUSERG=.FALSE.; LUSERH=.FALSE.
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM') THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH A KESSLER MICROPHYSICAL SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) ' AND THE SUBGRID AUTOCONVERSION SCHEME USING'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SIGMA_RC.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET CSUBG_AUCV TO "CLFR" or "NONE" OR CCLOUD TO "ICE3"'
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ CASE ( 'ICE3' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. LUSECI &
+ .AND. LUSERS .AND. LUSERG .AND. (.NOT. LUSERH)) &
+ .AND. CPROGRAM=='MESONH' ) THEN
+ !
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE THE ice3 SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYSICAL SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER,'
+ WRITE(UNIT=ILUOUT,FMT=*) 'RAIN WATER, CLOUD ICE (MIXING RATIO AND CONCENTRATION)'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SNOW-AGGREGATES AND GRAUPELN.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSERV,LUSERC,LUSERR,LUSERI,LUSECI,LUSERS,LUSERG ARE SET TO TRUE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'AND LUSERH TO FALSE'
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=.FALSE.
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM' .AND. .NOT. LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID AUTOCONVERSION SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT THE SUBGRID CONDENSATION SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: CSUBG_AUCV is SET to NONE'
+ CSUBG_AUCV='NONE'
+ END IF
+!
+ IF (CSUBG_AUCV == 'CLFR' .AND. CSCONV /= 'EDKF') THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID AUTOCONVERSION SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) 'WITH THE CONVECTIVE CLOUD FRACTION WITHOUT EDKF'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: CSUBG_AUCV is SET to NONE'
+ CSUBG_AUCV='NONE'
+ END IF
+!
+ CASE ( 'ICE4' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. LUSECI &
+ .AND. LUSERS .AND. LUSERG .AND. LUSERH) &
+ .AND. CPROGRAM=='MESONH' ) THEN
+ !
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE THE ice4 SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYSICAL SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER,'
+ WRITE(UNIT=ILUOUT,FMT=*) 'RAIN WATER, CLOUD ICE (MIXING RATIO AND CONCENTRATION)'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SNOW-AGGREGATES, GRAUPELN AND HAILSTONES.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSERV,LUSERC,LUSERR,LUSERI,LUSECI,LUSERS,LUSERG'
+ WRITE(UNIT=ILUOUT,FMT=*) 'AND LUSERH ARE SET TO TRUE'
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE. ; LUSERH=.TRUE.
+ END IF
+!
+ IF (CSUBG_AUCV /= 'NONE' .AND. .NOT. LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID AUTOCONVERSION SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT THE SUBGRID CONDENSATION SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: CSUBG_AUCV is SET to NONE'
+ CSUBG_AUCV='NONE'
+ END IF
+!
+ CASE ( 'C2R2','C3R5', 'KHKO' )
+ IF (( EPARAM_CCN == 'XXX') .OR. (EINI_CCN == 'XXX')) THEN
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 2-MOMENT MICROPHYSICAL ", &
+ &" SCHEME BUT YOU DIDNT FILL CORRECTLY NAM_PARAM_C2R2", &
+ &" YOU HAVE TO FILL HPARAM_CCN and HINI_CCN ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (HCLOUD == 'NONE') THEN
+ CGETCLOUD = 'SKIP'
+ ELSE IF (HCLOUD == 'REVE' ) THEN
+ CGETCLOUD = 'INI1'
+ ELSE IF (HCLOUD == 'KESS' ) THEN
+ CGETCLOUD = 'INI2'
+ ELSE IF (HCLOUD == 'ICE3' ) THEN
+ IF (CCLOUD == 'C3R5') THEN
+ CGETCLOUD = 'INI2'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE WARM MICROPHYSICAL ", &
+ &" SCHEME BUT YOU WERE USING THE ICE3 SCHEME PREVIOUSLY.",/, &
+ &" AS THIS IS A LITTLE BIT STUPID IT IS NOT AUTHORIZED !!!")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ ELSE
+ CGETCLOUD = 'READ' ! This is automatically done
+ END IF
+!
+ IF ((CCLOUD == 'C2R2' ).OR. (CCLOUD == 'KHKO' )) THEN
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. (.NOT. LUSERI) .AND. &
+ (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE C2R2 MICROPHYSICAL ", &
+ &" SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER AND RAIN ",/, &
+ &"LUSERV, LUSERC AND LUSERR ARE SET TO TRUE AND THE OTHERS TO FALSE ")')
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.FALSE.; LUSERS=.FALSE.
+ LUSERG=.FALSE.; LUSERH=.FALSE.
+ END IF
+ ELSE IF (CCLOUD == 'C3R5') THEN
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. &
+ LUSERS .AND. LUSERG .AND. (.NOT. LUSERH) &
+ ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE C3R5 MICROPHYS. SCHEME.",&
+ &" YOU WILL HAVE VAPOR, CLOUD WATER/ICE, RAIN, SNOW AND GRAUPEL ",/, &
+ &"LUSERV, LUSERC, LUSERR, LUSERI, LUSERS, LUSERG ARE SET TO TRUE")' )
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=.FALSE.
+ END IF
+ ELSE IF (CCLOUD == 'LIMA') THEN
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. &
+ LUSERS .AND. LUSERG .AND. (.NOT. LUSERH) &
+ ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LIMA MICROPHYS. SCHEME.",&
+ &" YOU WILL HAVE VAPOR, CLOUD WATER/ICE, RAIN, SNOW AND GRAUPEL ",/, &
+ &"LUSERV, LUSERC, LUSERR, LUSERI, LUSERS, LUSERG ARE SET TO TRUE")' )
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=.FALSE.
+ END IF
+ END IF
+!
+ IF (LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYS. SCHEME AND THE SUBGRID COND. SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LSUBG_COND TO FALSE OR CCLOUD TO "REVE", "KESS"'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( CEFRADL /= 'C2R2') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADL=C2R2 FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADL=C2R2 '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME'
+ END IF
+!
+ IF ( CCLOUD == 'C3R5' .AND. CEFRADI /= 'C3R5') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADI=C3R5 FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADI=C3R5 '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME'
+ END IF
+!
+ IF ( WALPHAC /= 3.0 .OR. WNUC /= 2.0) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'IT IS ADVISED TO USE XALPHAC=3. and XNUC=2.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'FOR STRATOCUMULUS WITH KHKO SCHEME. '
+ END IF
+!
+ IF ( CEFRADL /= 'C2R2') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADL=C2R2 FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADL=C2R2 '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME'
+ END IF
+!
+ CASE ( 'LIMA')
+ IF ((LACTI .AND. FINI_CCN == 'XXX')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 2-MOMENT MICROPHYSICAL ", &
+ &" SCHEME BUT YOU DIDNT FILL CORRECTLY NAM_PARAM_LIMA", &
+ &" YOU HAVE TO FILL FINI_CCN ")')
+ call Print_msg( NVERB_FATAL, 'GEN', 'READ_EXSEG_n', '' )
+ END IF
+!
+ IF(LACTI .AND. NMOD_CCN == 0) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ACTIVATION OF AEROSOL PARTICLES IS NOT ", &
+ &"POSSIBLE IF NMOD_CCN HAS VALUE ZERO. YOU HAVE TO SET AN UPPER ", &
+ &"VALUE OF NMOD_CCN IN ORDER TO USE LIMA WARM ACTIVATION SCHEME.")')
+ call Print_msg( NVERB_FATAL, 'GEN', 'READ_EXSEG_n', '' )
+ END IF
+!
+ IF(LNUCL .AND. NMOD_IFN == 0 .AND. (.NOT.LMEYERS)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("NUCLEATION BY DEPOSITION AND CONTACT IS NOT ", &
+ &"POSSIBLE IF NMOD_IFN HAS VALUE ZERO. YOU HAVE TO SET AN UPPER", &
+ &"VALUE OF NMOD_IFN IN ORDER TO USE LIMA COLD NUCLEATION SCHEME.")')
+ END IF
+!
+ IF (HCLOUD == 'NONE') THEN
+ CGETCLOUD = 'SKIP'
+ ELSE IF (HCLOUD == 'REVE' ) THEN
+ CGETCLOUD = 'INI1'
+ ELSE IF (HCLOUD == 'KESS' ) THEN
+ CGETCLOUD = 'INI2'
+ ELSE IF (HCLOUD == 'ICE3' ) THEN
+ CGETCLOUD = 'INI2'
+ ELSE
+ CGETCLOUD = 'READ' ! This is automatically done
+ END IF
+!
+ IF (LWARM) THEN
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.FALSE.; LUSERS=.FALSE. ; LUSERG=.FALSE.; LUSERH=.FALSE.
+ END IF
+!
+ IF (LCOLD) THEN
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=LHAIL
+ END IF
+!
+ IF (LSUBG_COND .AND. LCOLD) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYS. SCHEME AND THE SUBGRID COND. SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LSUBG_COND '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "REVE", "KESS" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( XALPHAC /= 3.0 .OR. XNUC /= 2.0) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'IT IS ADVISED TO USE XALPHAC=3. and XNUC=2.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'FOR STRATOCUMULUS. '
+ END IF
+!
+ IF ( CEFRADL /= 'LIMA') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADL=LIMA FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADL=LIMA '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME "LIMA"'
+ END IF
+
+ IF (LUSECHEM ) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH LIMA MICROPHYS. SCHEME AND CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LUSECHEM '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "ICE3" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (LDUST ) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH LIMA MICROPHYS. SCHEME AND DUSTS '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LDUST '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "ICE3" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (LSALT ) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH LIMA MICROPHYS. SCHEME AND SEA SALTS '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LSALT '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "ICE3" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+END SELECT
+!
+LUSERV_G(KMI) = LUSERV
+LUSERC_G(KMI) = LUSERC
+LUSERR_G(KMI) = LUSERR
+LUSERI_G(KMI) = LUSERI
+LUSERS_G(KMI) = LUSERS
+LUSERG_G(KMI) = LUSERG
+LUSERH_G(KMI) = LUSERH
+LUSETKE(KMI) = (CTURB /= 'NONE')
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.3 Chemical and NSV_* variables initializations
+!
+CALL UPDATE_NAM_PARAMN
+CALL UPDATE_NAM_DYNN
+CALL UPDATE_NAM_CONFN
+!
+IF (LORILAM .AND. .NOT. LUSECHEM) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU CANNOT USE ORILAM AEROSOL SCHEME WITHOUT '
+ WRITE(ILUOUT,FMT=*) 'CHEMICAL GASEOUS CHEMISTRY '
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LUSECHEM IS SET TO TRUE '
+ LUSECHEM=.TRUE.
+END IF
+!
+IF (LUSECHAQ.AND.(.NOT.LUSECHEM)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE AQUEOUS PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT THE CHEMISTRY IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHEM TO TRUE IF YOU WANT REALLY USE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'OR SET LUSECHAQ TO FALSE IF YOU DO NOT WANT USE IT'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+IF (LUSECHAQ.AND.(.NOT.LUSERC).AND.CPROGRAM=='MESONH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE AQUEOUS PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT CLOUD MICROPHYSICS IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSECHAQ IS SET TO FALSE'
+ LUSECHAQ = .FALSE.
+END IF
+IF (LUSECHAQ.AND.CCLOUD(1:3) == 'ICE'.AND. .NOT. LUSECHIC) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE AQUEOUS PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'WITH MIXED PHASE CLOUD MICROPHYSICS'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHIC TO TRUE IF YOU WANT TO ACTIVATE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'ICE PHASE CHEMICAL SPECIES'
+ IF (LCH_RET_ICE) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'LCH_RET_ICE TRUE MEANS ALL SOLUBLE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'GASES ARE RETAINED IN ICE PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'WHEN SUPERCOOLED WATER FREEZES'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=*) 'LCH_RET_ICE FALSE MEANS ALL SOLUBLE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'GASES GO BACK TO THE GAS PHASE WHEN'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SUPERCOOLED WATER FREEZES'
+ ENDIF
+ENDIF
+IF (LUSECHIC.AND. .NOT. CCLOUD(1:3) == 'ICE'.AND.CPROGRAM=='MESONH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE ICE PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT MIXED PHASE CLOUD MICROPHYSICS IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSECHIC IS SET TO FALSE'
+ LUSECHIC= .FALSE.
+ENDIF
+IF (LCH_PH.AND. (.NOT. LUSECHAQ)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'DIAGNOSTIC PH COMPUTATION IS ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT AQUEOUS PHASE CHEMISTRY IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHAQ TO TRUE IF YOU WANT TO ACTIVATE IT'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LCH_PH IS SET TO FALSE'
+ LCH_PH= .FALSE.
+ENDIF
+IF (LUSECHIC.AND.(.NOT.LUSECHAQ)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE ICE PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT THE AQUEOUS PHASE CHEMISTRY IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHAQ TO TRUE IF YOU WANT REALLY USE CLOUD CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'OR SET LUSECHIC TO FALSE IF YOU DO NOT WANT USE IT'
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+IF ((LUSECHIC).AND.(LCH_RET_ICE)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE RETENTION OF SOLUBLE GASES IN ICE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT THE ICE PHASE CHEMISTRY IS ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'FLAG LCH_RET_ICE IS ONLY USES WHEN LUSECHIC IS SET'
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE IE NO CHEMICAL SPECIES IN ICE'
+ENDIF
+!
+IF (LUSECHEM) THEN
+ CALL CH_INIT_SCHEME_n(KMI,LUSECHAQ,LUSECHIC,LCH_PH,ILUOUT,NVERB)
+ IF (LORILAM) CALL CH_AER_INIT_SOA(ILUOUT, NVERB)
+END IF
+!
+
+CALL UPDATE_NAM_CH_MNHCN
+CALL INI_NSV(KMI)
+!
+! From this point, all NSV* variables contain valid values for model KMI
+!
+DO JSV = 1,NSV
+ LUSESV(JSV,KMI) = .TRUE.
+END DO
+!
+IF ( CAOP=='EXPL' .AND. .NOT.LDUST .AND. .NOT.LORILAM &
+ .AND. .NOT.LSALT .AND. .NOT.(CCLOUD=='LIMA') ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU WANT TO USE EXPLICIT AEROSOL OPTICAL '
+ WRITE(UNIT=ILUOUT,FMT=*) 'PROPERTIES BUT YOU DONT HAVE DUST OR '
+ WRITE(UNIT=ILUOUT,FMT=*) 'AEROSOL OR SALT THEREFORE CAOP=CLIM'
+ CAOP='CLIM'
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 3. CHECK COHERENCE BETWEEN EXSEG VARIABLES AND FMFILE ATTRIBUTES
+! -------------------------------------------------------------
+!
+!
+!* 3.1 Turbulence variable
+!
+IF ((CTURB /= 'NONE').AND.(HTURB == 'NONE')) THEN
+ CGETTKET ='INIT'
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*)'YOU WANT TO USE TURBULENCE KINETIC ENERGY TKE'
+ WRITE(UNIT=ILUOUT,FMT=*)'WHEREAS IT IS NOT IN INITIAL FMFILE'
+ WRITE(UNIT=ILUOUT,FMT=*)'TKE WILL BE INITIALIZED TO ZERO'
+ELSE
+ IF (CTURB /= 'NONE') THEN
+ CGETTKET ='READ'
+ IF ((CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETTKET='INIT'
+ ELSE
+ CGETTKET ='SKIP'
+ END IF
+END IF
+!
+!
+IF ((CTOM == 'TM06').AND.(HTOM /= 'TM06')) THEN
+ CGETBL_DEPTH ='INIT'
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*)'YOU WANT TO USE BL DEPTH FOR THIRD ORDER MOMENTS'
+ WRITE(UNIT=ILUOUT,FMT=*)'WHEREAS IT IS NOT IN INITIAL FMFILE'
+ WRITE(UNIT=ILUOUT,FMT=*)'IT WILL BE INITIALIZED TO ZERO'
+ELSE
+ IF (CTOM == 'TM06') THEN
+ CGETBL_DEPTH ='READ'
+ ELSE
+ CGETBL_DEPTH ='SKIP'
+ END IF
+END IF
+!
+IF (LRMC01 .AND. .NOT. ORMC01) THEN
+ CGETSBL_DEPTH ='INIT'
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*)'YOU WANT TO USE SBL DEPTH FOR RMC01'
+ WRITE(UNIT=ILUOUT,FMT=*)'WHEREAS IT IS NOT IN INITIAL FMFILE'
+ WRITE(UNIT=ILUOUT,FMT=*)'IT WILL BE INITIALIZED TO ZERO'
+ELSE
+ IF (LRMC01) THEN
+ CGETSBL_DEPTH ='READ'
+ ELSE
+ CGETSBL_DEPTH ='SKIP'
+ END IF
+END IF
+!
+!
+!* 3.2 Moist variables
+!
+IF (LUSERV.AND. (.NOT.OUSERV)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE VAPOR VARIABLE Rv WHEREAS IT ", &
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & "Rv WILL BE INITIALIZED TO ZERO")')
+ CGETRVT='INIT'
+ELSE
+ IF (LUSERV) THEN
+ CGETRVT='READ'
+ ELSE
+ CGETRVT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERC.AND. (.NOT.OUSERC)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE CLOUD VARIABLE Rc WHEREAS IT ", &
+ & " IS NOT IN INITIAL FMFILE",/, &
+ & "Rc WILL BE INITIALIZED TO ZERO")')
+ CGETRCT='INIT'
+ELSE
+ IF (LUSERC) THEN
+ CGETRCT='READ'
+! IF(CCONF=='START') CGETRCT='INIT'
+ ELSE
+ CGETRCT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERR.AND. (.NOT.OUSERR)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE RAIN VARIABLE Rr WHEREAS IT ", &
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Rr WILL BE INITIALIZED TO ZERO")')
+
+ CGETRRT='INIT'
+ELSE
+ IF (LUSERR) THEN
+ CGETRRT='READ'
+! IF( (CCONF=='START').AND. CPROGRAM /= 'DIAG') CGETRRT='INIT'
+ ELSE
+ CGETRRT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERI.AND. (.NOT.OUSERI)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE ICE VARIABLE Ri WHEREAS IT ", &
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Ri WILL BE INITIALIZED TO ZERO")')
+ CGETRIT='INIT'
+ELSE
+ IF (LUSERI) THEN
+ CGETRIT='READ'
+! IF(CCONF=='START') CGETRIT='INIT'
+ ELSE
+ CGETRIT='SKIP'
+ END IF
+END IF
+!
+IF (LUSECI.AND. (.NOT.OUSECI)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE ICE CONC. VARIABLE Ci WHEREAS IT ",&
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Ci WILL BE INITIALIZED TO ZERO")')
+ CGETCIT='INIT'
+ELSE
+ IF (LUSECI) THEN
+ CGETCIT='READ'
+ ELSE
+ CGETCIT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERS.AND. (.NOT.OUSERS)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE SNOW VARIABLE Rs WHEREAS IT ",&
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Rs WILL BE INITIALIZED TO ZERO")')
+ CGETRST='INIT'
+ELSE
+ IF (LUSERS) THEN
+ CGETRST='READ'
+! IF ( (CCONF=='START').AND. CPROGRAM /= 'DIAG') CGETRST='INIT'
+ ELSE
+ CGETRST='SKIP'
+ END IF
+END IF
+!
+IF (LUSERG.AND. (.NOT.OUSERG)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE GRAUPEL VARIABLE Rg WHEREAS ",&
+ & " IT IS NOTIN INITIAL FMFILE",/, &
+ & "Rg WILL BE INITIALIZED TO ZERO")')
+ CGETRGT='INIT'
+ELSE
+ IF (LUSERG) THEN
+ CGETRGT='READ'
+! IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETRGT='INIT'
+ ELSE
+ CGETRGT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERH.AND. (.NOT.OUSERH)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE HAIL VARIABLE Rh WHEREAS",&
+ & "IT IS NOT IN INITIAL FMFILE",/, &
+ & " Rh WILL BE INITIALIZED TO ZERO")')
+ CGETRHT='INIT'
+ELSE
+ IF (LUSERH) THEN
+ CGETRHT='READ'
+! IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETRHT='INIT'
+ ELSE
+ CGETRHT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERC.AND. (.NOT.OUSERC)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE CLOUD FRACTION WILL BE INITIALIZED ACCORDING'
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO CLOUD MIXING RATIO VALUE OR SET TO 0'
+ CGETCLDFR = 'INIT'
+ELSE
+ IF ( LUSERC ) THEN
+ CGETCLDFR = 'READ'
+ IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETCLDFR='INIT'
+ ELSE
+ CGETCLDFR = 'SKIP'
+ END IF
+END IF
+!
+IF(CTURBLEN=='RM17') THEN
+ XCEDIS=0.34
+ELSE
+ XCEDIS=0.84
+END IF
+!
+!* 3.3 Moist turbulence
+!
+IF ( LUSERC .AND. CTURB /= 'NONE' ) THEN
+ IF ( .NOT. (OUSERC .AND. HTURB /= 'NONE') ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE MOIST TURBULENCE WHEREAS IT ",/, &
+ & " WAS NOT THE CASE FOR THE INITIAL FMFILE GENERATION",/, &
+ & "SRC AND SIGS ARE INITIALIZED TO 0")')
+ CGETSRCT ='INIT'
+ CGETSIGS ='INIT'
+ ELSE
+ CGETSRCT ='READ'
+ IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETSRCT ='INIT'
+ CGETSIGS ='READ'
+ END IF
+ELSE
+ CGETSRCT ='SKIP'
+ CGETSIGS ='SKIP'
+END IF
+!
+IF(NMODEL_CLOUD==KMI .AND. CTURBLEN_CLOUD/='NONE') THEN
+ IF (CTURB=='NONE' .OR. .NOT.LUSERC) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO COMPUTE A MIXING LENGTH FOR CLOUD=", &
+ & A4,/, &
+ & ", WHEREAS YOU DO NOT SPECIFY A TURBULENCE SCHEME OR ", &
+ & "USE OF RC,",/," CTURBLEN_CLOUD IS SET TO NONE")') &
+ CTURBLEN_CLOUD
+ CTURBLEN_CLOUD='NONE'
+ END IF
+ IF( XCEI_MIN > XCEI_MAX ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("PROBLEM OF CEI LIMITS FOR CLOUD MIXING ",/, &
+ & "LENGTH COMPUTATION: XCEI_MIN=",E9.3,", XCEI_MAX=",E9.3)')&
+ XCEI_MIN,XCEI_MAX
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+END IF
+!
+IF ( LSIGMAS ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE SIGMA_S FROM TURBULENCE SCHEME",/, &
+ & " IN ICE SUBGRID CONDENSATION, SO YOUR SIGMA_S"/, &
+ & " MIGHT BE SMALL ABOVE PBL DEPENDING ON LENGTH SCALE")')
+END IF
+!
+IF (LSUBG_COND .AND. CTURB=='NONE' ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID CONDENSATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT TURBULENCE '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: LSUBG_COND is SET to FALSE'
+ LSUBG_COND=.FALSE.
+END IF
+!
+IF (L1D .AND. CTURB/='NONE' .AND. CTURBDIM == '3DIM') THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE 3D TURBULENCE IN 1D CONFIGURATION '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT POSSIBLE: CTURBDIM IS SET TO 1DIM'
+ CTURBDIM = '1DIM'
+END IF
+!
+!* 3.4 Additional scalar variables
+!
+IF (NSV_USER == KSV_USER) THEN
+ DO JS = 1,KSV_USER ! to read all the variables in initial file
+ CGETSVT(JS)='READ' ! and to initialize them
+! IF(CCONF=='START')CGETSVT(JS)='INIT' ! with these values
+ END DO
+ELSEIF (NSV_USER > KSV_USER) THEN
+ IF (KSV_USER == 0) THEN
+ CGETSVT(1:NSV_USER)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE MORE ADDITIONAL SCALAR " ,&
+ &" VARIABLES THAN THERE ARE IN INITIAL FMFILE",/, &
+ & "THE SUPPLEMENTARY VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ DO JS = 1,KSV_USER ! to read all the variables in initial file
+ CGETSVT(JS)='READ' ! and to initialize them
+! IF(CCONF=='START')CGETSVT(JS)='INIT' ! with these values
+ END DO
+ DO JS = KSV_USER+1, NSV_USER ! to initialize to zero supplementary
+ CGETSVT(JS)='INIT' ! initial file)
+ END DO
+ END IF
+ELSE
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE LESS ADDITIONAL SCALAR " ,&
+ &" VARIABLES THAN THERE ARE IN INITIAL FMFILE")')
+ DO JS = 1,NSV_USER ! to read the first NSV_USER variables in initial file
+ CGETSVT(JS)='READ' ! and to initialize with these values
+! IF(CCONF=='START') CGETSVT(JS)='INIT'
+ END DO
+ DO JS = NSV_USER + 1, KSV_USER ! to skip the last (KSV_USER-NSV_USER) variables
+ CGETSVT(JS)='SKIP'
+ END DO
+END IF
+!
+! C2R2 and KHKO SV case
+!
+IF (CCLOUD == 'C2R2' .OR. CCLOUD == 'C3R5' .OR. CCLOUD == 'KHKO') THEN
+ IF (HCLOUD == 'C2R2' .OR. HCLOUD == 'C3R5' .OR. HCLOUD == 'KHKO') THEN
+ CGETSVT(NSV_C2R2BEG:NSV_C2R2END)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_C2R2BEG:NSV_C2R2END)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR C2R2 &
+ & (or KHKO) SCHEME IN INITIAL FMFILE",/,&
+ & "THE C2R2 (or KHKO) VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_C2R2BEG:NSV_C2R2END)='INIT'
+ END IF
+END IF
+!
+! C3R5 SV case
+!
+IF (CCLOUD == 'C3R5') THEN
+ IF (HCLOUD == 'C3R5') THEN
+ CGETSVT(NSV_C1R3BEG:NSV_C1R3END)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_C1R3BEG:NSV_C1R3END)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR C3R5 &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE C1R3 VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_C1R3BEG:NSV_C1R3END)='INIT'
+ END IF
+END IF
+!
+! LIMA SV case
+!
+IF (CCLOUD == 'LIMA') THEN
+ IF (HCLOUD == 'LIMA') THEN
+ CGETSVT(NSV_LIMA_BEG:NSV_LIMA_END)='READ'
+!!JPP IF(HSTORAGE_TYPE=='TT') CGETSVT(NSV_LIMA_BEG:NSV_LIMA_END)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR LIMA &
+ & SCHEME IN INITIAL FMFILE",/,&
+ & "THE LIMA VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_LIMA_BEG:NSV_LIMA_END)='INIT'
+ END IF
+END IF
+!
+! Electrical SV case
+!
+IF (CELEC /= 'NONE') THEN
+ IF (HELEC /= 'NONE') THEN
+ CGETSVT(NSV_ELECBEG:NSV_ELECEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_ELECBEG:NSV_ELECEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR ELECTRICAL &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE ELECTRICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_ELECBEG:NSV_ELECEND)='INIT'
+ END IF
+END IF
+!
+! (explicit) LINOx SV case
+!
+IF (CELEC /= 'NONE' .AND. LLNOX_EXPLICIT) THEN
+ IF (HELEC /= 'NONE' .AND. OLNOX_EXPLICIT) THEN
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='READ'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR LINOX &
+ & IN INITIAL FMFILE",/,&
+ & "THE LINOX VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='INIT'
+ END IF
+END IF
+!
+! Chemical SV case (excluding aqueous chemical species)
+!
+IF (LUSECHEM) THEN
+ IF (OUSECHEM) THEN
+ CGETSVT(NSV_CHGSBEG:NSV_CHGSEND)='READ'
+ IF(CCONF=='START' .AND. LCH_INIT_FIELD ) CGETSVT(NSV_CHGSBEG:NSV_CHGSEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR CHEMICAL &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE CHEMICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_CHGSBEG:NSV_CHGSEND)='INIT'
+ END IF
+END IF
+! add aqueous chemical species
+IF (LUSECHAQ) THEN
+ IF (OUSECHAQ) THEN
+ CGETSVT(NSV_CHACBEG:NSV_CHACEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_CHACBEG:NSV_CHACEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR CHEMICAL &
+ &SCHEME IN AQUEOUS PHASE IN INITIAL FMFILE",/,&
+ & "THE AQUEOUS PHASE CHEMICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_CHACBEG:NSV_CHACEND)='INIT'
+ END IF
+END IF
+! add ice phase chemical species
+IF (LUSECHIC) THEN
+ IF (OUSECHIC) THEN
+ CGETSVT(NSV_CHICBEG:NSV_CHICEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_CHICBEG:NSV_CHICEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR CHEMICAL &
+ &SPECIES IN ICE PHASE IN INITIAL FMFILE",/,&
+ & "THE ICE PHASE CHEMICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_CHICBEG:NSV_CHICEND)='INIT'
+ END IF
+END IF
+! pH values = diagnostics
+IF (LCH_PH .AND. .NOT. OCH_PH) THEN
+ CGETPHC ='INIT' !will be initialized to XCH_PHINIT
+ IF (LUSERR) THEN
+ CGETPHR = 'INIT' !idem
+ ELSE
+ CGETPHR = 'SKIP'
+ ENDIF
+ELSE
+ IF (LCH_PH) THEN
+ CGETPHC ='READ'
+ IF (LUSERR) THEN
+ CGETPHR = 'READ'
+ ELSE
+ CGETPHR = 'SKIP'
+ ENDIF
+ ELSE
+ CGETPHC ='SKIP'
+ CGETPHR ='SKIP'
+ END IF
+END IF
+!
+! Dust case
+!
+IF (LDUST) THEN
+ IF (ODUST) THEN
+ CGETSVT(NSV_DSTBEG:NSV_DSTEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_DSTBEG:NSV_DSTEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR DUST &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE DUST VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_DSTBEG:NSV_DSTEND)='INIT'
+ END IF
+ IF (LDEPOS_DST(KMI)) THEN
+
+ IF((CCLOUD /= 'ICE3').AND.(CCLOUD /= 'ICE4').AND.(CCLOUD /= 'KESS')&
+ .AND.(CCLOUD /= 'KHKO').AND.(CCLOUD /= 'C2R2').AND. &
+ (CPROGRAM/='SPAWN').AND.(CPROGRAM/='REAL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ERROR: WET DEPOSITION OF DUST IS ONLY CODED FOR THE",/,&
+ & "MICROPHYSICAL SCHEME as ICE3, ICE4, KESS, KHKO and C2R2")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+
+ IF (ODEPOS_DST(KMI) ) THEN
+ CGETSVT(NSV_DSTDEPBEG:NSV_DSTDEPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_DSTDEPBEG:NSV_DSTDEPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR RAIN and CLOUD DUST &
+ & SCHEME IN INITIAL FMFILE",/,&
+ & "THE MOIST DUST VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_DSTDEPBEG:NSV_DSTDEPEND)='INIT'
+ END IF
+ END IF
+
+ IF(NMODE_DST.GT.3 .OR. NMODE_DST.LT.1) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("DUST MODES MUST BE BETWEEN 1 and 3 ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF(.NOT.ALLOCATED(CDUSTNAMES)) THEN
+ IMOMENTS = (NSV_DSTEND - NSV_DSTBEG +1 )/NMODE_DST
+ ALLOCATE(CDUSTNAMES(IMOMENTS*NMODE_DST))
+ !Loop on all dust modes
+ IF (IMOMENTS == 1) THEN
+ DO JMODE=1,NMODE_DST
+ IMODEIDX=JPDUSTORDER(JMODE)
+ JSV_NAME = (IMODEIDX - 1)*3 + 2
+ CDUSTNAMES(JMODE) = YPDUST_INI(JSV_NAME)
+ END DO
+ ELSE
+ DO JMODE=1,NMODE_DST
+ !Find which mode we are dealing with
+ IMODEIDX=JPDUSTORDER(JMODE)
+ DO JMOM=1,IMOMENTS
+ !Find which number this is of the list of scalars
+ JSV = (JMODE-1)*IMOMENTS + JMOM
+ !Find what name this corresponds to, always 3 moments assumed in YPDUST_INI
+ JSV_NAME = (IMODEIDX - 1)*3 + JMOM
+ !Get the right CDUSTNAMES which should follow the list of scalars transported in XSVM/XSVT
+ CDUSTNAMES(JSV) = YPDUST_INI(JSV_NAME)
+ ENDDO ! Loop on moments
+ ENDDO ! Loop on dust modes
+ END IF
+ END IF
+ ! Initialization of deposition scheme
+ IF (LDEPOS_DST(KMI)) THEN
+ IF(.NOT.ALLOCATED(CDEDSTNAMES)) THEN
+ ALLOCATE(CDEDSTNAMES(NMODE_DST*2))
+ DO JMODE=1,NMODE_DST
+ IMODEIDX=JPDUSTORDER(JMODE)
+ CDEDSTNAMES(JMODE) = YPDEDST_INI(IMODEIDX)
+ CDEDSTNAMES(NMODE_DST+JMODE) = YPDEDST_INI(NMODE_DST+IMODEIDX)
+ ENDDO
+ ENDIF
+ ENDIF
+
+END IF
+!
+! Sea Salt case
+!
+IF (LSALT) THEN
+ IF (OSALT) THEN
+ CGETSVT(NSV_SLTBEG:NSV_SLTEND)='READ'
+ CGETZWS='READ'
+! IF(CCONF=='START') CGETSVT(NSV_SLTBEG:NSV_SLTEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR SALT &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE SALT VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_SLTBEG:NSV_SLTEND)='INIT'
+ CGETZWS='INIT'
+ END IF
+ IF (LDEPOS_SLT(KMI)) THEN
+
+ IF((CCLOUD /= 'ICE3').AND.(CCLOUD /= 'ICE4').AND.(CCLOUD /= 'KESS')&
+ .AND.(CCLOUD /= 'KHKO').AND.(CCLOUD /= 'C2R2').AND. &
+ (CPROGRAM/='SPAWN').AND.(CPROGRAM/='REAL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ERROR: WET DEPOSITION OF SEA SALT AEROSOLS IS ONLY CODED FOR THE",/,&
+ & "MICROPHYSICAL SCHEME as ICE3, ICE4, KESS, KHKO and C2R2")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+
+ IF (ODEPOS_SLT(KMI) ) THEN
+ CGETSVT(NSV_SLTDEPBEG:NSV_SLTDEPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_SLTDEPBEG:NSV_SLTDEPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR RAIN and CLOUD SEA SALT &
+ & SCHEME IN INITIAL FMFILE",/,&
+ & "THE MOIST SEA SALT VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_SLTDEPBEG:NSV_SLTDEPEND)='INIT'
+ END IF
+ END IF
+ IF(NMODE_SLT.GT.5 .OR. NMODE_SLT.LT.1) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("SALT MODES MUST BE BETWEEN 1 and 5 ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF(.NOT.ALLOCATED(CSALTNAMES)) THEN
+ IMOMENTS = (NSV_SLTEND - NSV_SLTBEG +1 )/NMODE_SLT
+ ALLOCATE(CSALTNAMES(IMOMENTS*NMODE_SLT))
+ !Loop on all dust modes
+ IF (IMOMENTS == 1) THEN
+ DO JMODE=1,NMODE_SLT
+ IMODEIDX=JPSALTORDER(JMODE)
+ JSV_NAME = (IMODEIDX - 1)*3 + 2
+ CSALTNAMES(JMODE) = YPSALT_INI(JSV_NAME)
+ END DO
+ ELSE
+ DO JMODE=1,NMODE_SLT
+ !Find which mode we are dealing with
+ IMODEIDX=JPSALTORDER(JMODE)
+ DO JMOM=1,IMOMENTS
+ !Find which number this is of the list of scalars
+ JSV = (JMODE-1)*IMOMENTS + JMOM
+ !Find what name this corresponds to, always 3 moments assumed in YPSALT_INI
+ JSV_NAME = (IMODEIDX - 1)*3 + JMOM
+ !Get the right CSALTNAMES which should follow the list of scalars transported in XSVM/XSVT
+ CSALTNAMES(JSV) = YPSALT_INI(JSV_NAME)
+ ENDDO ! Loop on moments
+ ENDDO ! Loop on dust modes
+ END IF
+ END IF
+ ! Initialization of deposition scheme
+ IF (LDEPOS_SLT(KMI)) THEN
+ IF(.NOT.ALLOCATED(CDESLTNAMES)) THEN
+ ALLOCATE(CDESLTNAMES(NMODE_SLT*2))
+ DO JMODE=1,NMODE_SLT
+ IMODEIDX=JPSALTORDER(JMODE)
+ CDESLTNAMES(JMODE) = YPDESLT_INI(IMODEIDX)
+ CDESLTNAMES(NMODE_SLT+JMODE) = YPDESLT_INI(NMODE_SLT+IMODEIDX)
+ ENDDO
+ ENDIF
+ ENDIF
+END IF
+!
+! Orilam SV case
+!
+IF (LORILAM) THEN
+ IF (OORILAM) THEN
+ CGETSVT(NSV_AERBEG:NSV_AEREND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_AERBEG:NSV_AEREND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR AEROSOL &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE AEROSOLS VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_AERBEG:NSV_AEREND)='INIT'
+ END IF
+ IF (LDEPOS_AER(KMI)) THEN
+
+ IF((CCLOUD /= 'ICE3').AND.(CCLOUD /= 'ICE4').AND.(CCLOUD /= 'KESS')&
+ .AND.(CCLOUD /= 'KHKO').AND.(CCLOUD /= 'C2R2').AND. &
+ (CPROGRAM/='SPAWN').AND.(CPROGRAM/='REAL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ERROR: WET DEPOSITION OF ORILAM AEROSOLS IS ONLY CODED FOR THE",/,&
+ & "MICROPHYSICAL SCHEME as ICE3, ICE4, KESS, KHKO and C2R2")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+
+ IF (ODEPOS_AER(KMI) ) THEN
+ CGETSVT(NSV_AERDEPBEG:NSV_AERDEPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_AERDEPBEG:NSV_AERDEPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR RAIN and IN CLOUD &
+ & AEROSOL SCHEME IN INITIAL FMFILE",/,&
+ & "THE MOIST AEROSOL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_AERDEPBEG:NSV_AERDEPEND)='INIT'
+ END IF
+ END IF
+! Initialization of deposition scheme
+ IF (LDEPOS_AER(KMI)) THEN
+ IF(.NOT.ALLOCATED(CDEAERNAMES)) THEN
+ ALLOCATE(CDEAERNAMES(JPMODE*2))
+ CDEAERNAMES(:) = YPDEAER_INI(:)
+ ENDIF
+ ENDIF
+END IF
+!
+! Lagrangian variables
+!
+IF (LINIT_LG .AND. .NOT.(LLG)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("IT IS INCOHERENT TO HAVE LINIT_LG=.T. AND LLG=.F.",/,&
+ & "IF YOU WANT LAGRANGIAN TRACERS CHANGE LLG TO .T. ")')
+ENDIF
+IF (LLG) THEN
+ IF (OLG .AND. .NOT.(LINIT_LG .AND. CPROGRAM=='MESONH')) THEN
+ CGETSVT(NSV_LGBEG:NSV_LGEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_LGBEG:NSV_LGEND)='INIT'
+ ELSE
+ IF(.NOT.(LINIT_LG) .AND. CPROGRAM=='MESONH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO LAGRANGIAN VARIABLES IN INITIAL FMFILE",/,&
+ & "THE LAGRANGIAN VARIABLES HAVE BEEN REINITIALIZED")')
+ LINIT_LG=.TRUE.
+ ENDIF
+ CGETSVT(NSV_LGBEG:NSV_LGEND)='INIT'
+ END IF
+END IF
+!
+!
+! LINOx SV case
+!
+IF (.NOT.LUSECHEM .AND. LCH_CONV_LINOX) THEN
+ IF (.NOT.OUSECHEM .AND. OCH_CONV_LINOX) THEN
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='READ'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR LINOX &
+ &IN INITIAL FMFILE",/,&
+ & "THE LINOX VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='INIT'
+ END IF
+END IF
+!
+! Passive pollutant case
+!
+IF (LPASPOL) THEN
+ IF (OPASPOL) THEN
+ CGETSVT(NSV_PPBEG:NSV_PPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_PPBEG:NSV_PPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO PASSIVE SCALAR VARIABLES IN INITIAL FMFILE",/,&
+ & "THE VARIABLES HAVE BEEN INITIALIZED TO ZERO")')
+ CGETSVT(NSV_PPBEG:NSV_PPEND)='INIT'
+ END IF
+END IF
+!
+#ifdef MNH_FOREFIRE
+! ForeFire
+!
+IF (LFOREFIRE) THEN
+ IF (OFOREFIRE) THEN
+ CGETSVT(NSV_FFBEG:NSV_FFEND)='READ'
+ IF(HSTORAGE_TYPE=='TT') THEN
+ CGETSVT(NSV_FFBEG:NSV_FFEND)='INIT'
+ END IF
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO FOREFIRE SCALAR VARIABLES IN INITIAL FMFILE",/,&
+ & "THE VARIABLES HAVE BEEN INITIALIZED TO ZERO")')
+ CGETSVT(NSV_FFBEG:NSV_FFEND)='INIT'
+ END IF
+END IF
+#endif
+!
+! Conditional sampling case
+!
+IF (LCONDSAMP) THEN
+ IF (OCONDSAMP) THEN
+ CGETSVT(NSV_CSBEG:NSV_CSEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_CSBEG:NSV_CSEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO PASSIVE SCALAR VARIABLES IN INITIAL FMFILE",/,&
+ & "THE VARIABLES HAVE BEEN INITIALIZED TO ZERO")')
+ CGETSVT(NSV_CSBEG:NSV_CSEND)='INIT'
+ END IF
+END IF
+!
+! Blowing snow scheme
+!
+IF (LBLOWSNOW) THEN
+ IF (OBLOWSNOW) THEN
+ CGETSVT(NSV_SNWBEG:NSV_SNWEND)='READ'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR BLOWING SNOW &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE BLOWING SNOW VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_SNWBEG:NSV_SNWEND)='INIT'
+ END IF
+ IF(.NOT.ALLOCATED(CSNOWNAMES)) THEN
+ IMOMENTS = (NSV_SNWEND - NSV_SNWBEG +1 )
+ ALLOCATE(CSNOWNAMES(IMOMENTS))
+ DO JMOM=1,IMOMENTS
+ CSNOWNAMES(JMOM) = YPSNOW_INI(JMOM)
+ ENDDO ! Loop on moments
+ END IF
+END IF
+!
+!
+!
+!* 3.5 Check coherence between the radiation control parameters
+!
+IF( CRAD == 'ECMW' .AND. CPROGRAM=='MESONH' ) THEN
+ IF(CLW == 'RRTM' .AND. COPILW == 'SMSH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'the SMSH parametrisation of LW optical properties for cloud ice'
+ WRITE(UNIT=ILUOUT,FMT=*) '(COPILW) can not be used with RRTM radiation scheme'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ ENDIF
+ IF(CLW == 'MORC' .AND. COPWLW == 'LILI') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'the LILI parametrisation of LW optical properties for cloud water'
+ WRITE(UNIT=ILUOUT,FMT=*) '(COPWLW) can not be used with MORC radiation scheme'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ ENDIF
+ IF( .NOT. LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU DO NOT WANT TO USE SUBGRID CONDENSATION'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE OVERLAP OPTION IS NOVLP=5 IN ini_radconf.f90'
+ ELSE IF (CLW == 'MORC') THEN
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE MORCRETTE LW SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE OVERLAP OPTION IS NOVLP=5 IN ini_radconf.f90'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE OVERLAP OPTION IS NOVLP=6 IN ini_radconf.f90'
+ ENDIF
+!
+ IF( LCLEAR_SKY .AND. XDTRAD_CLONLY /= XDTRAD) THEN
+ ! Check the validity of the LCLEAR_SKY approximation
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE CLEAR-SKY APPROXIMATION'
+ WRITE(UNIT=ILUOUT,FMT=*) '(i.e. AVERAGE THE WHOLE CLOUDFREE VERTICALS BUT KEEP'
+ WRITE(UNIT=ILUOUT,FMT=*) 'ALL THE CLOUDY VERTICALS) AND'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE CLOUD-ONLY APPROXIMATION (i.e. YOU CALL MORE OFTEN THE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'RADIATIONS FOR THE CLOUDY VERTICALS THAN FOR CLOUDFREE ONES).'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT POSSIBLE, SO CHOOSE BETWEEN :'
+ WRITE(UNIT=ILUOUT,FMT=*) 'XDTRAD_CLONLY = XDTRAD and LCLEAR_SKY = FALSE'
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF( XDTRAD_CLONLY > XDTRAD ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("BAD USE OF THE CLOUD-ONLY APPROXIMATION " ,&
+ &" XDTRAD SHOULD BE LARGER THAN XDTRAD_CLONLY ")')
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF(( XDTRAD < XTSTEP ).OR. ( XDTRAD_CLONLY < XTSTEP )) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THE RADIATION CALL XDTRAD OR XDTRAD_CLONLY " ,&
+ &" IS MORE FREQUENT THAN THE TIME STEP SO ADJUST XDTRAD OR XDTRAD_CLONLY ")')
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+END IF
+!
+IF ( CRAD /= 'NONE' .AND. CPROGRAM=='MESONH' ) THEN
+ CGETRAD='READ'
+ IF( HRAD == 'NONE' .AND. CCONF=='RESTA') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU ARE PERFORMING A RESTART. FOR THIS SEGMENT, YOU ARE USING A RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SCHEME AND NO RADIATION SCHEME WAS USED FOR THE PREVIOUS SEGMENT.'
+ CGETRAD='INIT'
+ END IF
+ IF(CCONF=='START') THEN
+ CGETRAD='INIT'
+ END IF
+END IF
+!
+! 3.6 check the initialization of the deep convection scheme
+!
+IF ( (CDCONV /= 'KAFR') .AND. &
+ (CSCONV /= 'KAFR') .AND. LCHTRANS ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LCHTRANS OPTION= ",&
+ &"CONVECTIVE TRANSPORT OF TRACERS BUT IT CAN ONLY",&
+ &"BE USED FOR THE KAIN FRITSCH SCHEME ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+SELECT CASE ( CDCONV )
+ CASE( 'KAFR' )
+ IF (.NOT. ( LUSERV ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH DEEP CONV. ",&
+ &" SCHEME. YOU MUST HAVE VAPOR ",/,"LUSERV IS SET TO TRUE ")')
+ LUSERV=.TRUE.
+ ELSE IF (.NOT. ( LUSERI ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" DEEP CONV. SCHEME. BUT THE DETRAINED CLOUD ICE WILL BE ADDED TO ",&
+ &" THE CLOUD WATER ")')
+ ELSE IF (.NOT. ( LUSERI.AND.LUSERC ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" DEEP CONV. SCHEME. BUT THE DETRAINED CLOUD WATER AND CLOUD ICE ",&
+ &" WILL BE ADDED TO THE WATER VAPOR FIELD ")')
+ END IF
+ IF ( LCHTRANS .AND. NSV == 0 ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LCHTRANS OPTION= ",&
+ &"CONVECTIVE TRANSPORT OF TRACERS BUT YOUR TRACER ",&
+ &"NUMBER NSV IS ZERO ",/,"LCHTRANS IS SET TO FALSE")')
+ LCHTRANS=.FALSE.
+ END IF
+END SELECT
+!
+IF ( CDCONV == 'KAFR' .AND. LCHTRANS .AND. NSV > 0 ) THEN
+ IF( OCHTRANS ) THEN
+ CGETSVCONV='READ'
+ ELSE
+ CGETSVCONV='INIT'
+ END IF
+END IF
+!
+SELECT CASE ( CSCONV )
+ CASE( 'KAFR' )
+ IF (.NOT. ( LUSERV ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH SHALLOW CONV. ",&
+ &" SCHEME. YOU MUST HAVE VAPOR ",/,"LUSERV IS SET TO TRUE ")')
+ LUSERV=.TRUE.
+ ELSE IF (.NOT. ( LUSERI ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" SHALLOW CONV. SCHEME. BUT THE DETRAINED CLOUD ICE WILL BE ADDED TO ",&
+ &" THE CLOUD WATER ")')
+ ELSE IF (.NOT. ( LUSERI.AND.LUSERC ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" SHALLOW CONV. SCHEME. BUT THE DETRAINED CLOUD WATER AND CLOUD ICE ",&
+ &" WILL BE ADDED TO THE WATER VAPOR FIELD ")')
+ END IF
+ IF ( LCHTRANS .AND. NSV == 0 ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LCHTRANS OPTION= ",&
+ &"CONVECTIVE TRANSPORT OF TRACERS BUT YOUR TRACER ",&
+ &"NUMBER NSV IS ZERO ",/,"LCHTRANS IS SET TO FALSE")')
+ LCHTRANS=.FALSE.
+ END IF
+ CASE( 'EDKF' )
+ IF (CTURB == 'NONE' ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE EDKF ", &
+ &"SHALLOW CONVECTION WITHOUT TURBULENCE SCHEME : ", &
+ &"IT IS NOT POSSIBLE")')
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+END SELECT
+!
+!
+CGETCONV = 'SKIP'
+!
+IF ( (CDCONV /= 'NONE' .OR. CSCONV == 'KAFR' ) .AND. CPROGRAM=='MESONH') THEN
+ CGETCONV = 'READ'
+ IF( HDCONV == 'NONE' .AND. CCONF=='RESTA') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='(" YOU ARE PERFORMING A RESTART. FOR THIS ",&
+ &" SEGMENT, YOU ARE USING A DEEP CONVECTION SCHEME AND NO DEEP ",&
+ &" CONVECTION SCHEME WAS USED FOR THE PREVIOUS SEGMENT. ")')
+!
+ CGETCONV = 'INIT'
+ END IF
+ IF(CCONF=='START') THEN
+ CGETCONV = 'INIT'
+ END IF
+END IF
+!
+!* 3.7 configuration and model version
+!
+IF (KMI == 1) THEN
+!
+ IF (L1D.AND.(CLBCX(1)/='CYCL'.AND.CLBCX(2)/='CYCL' &
+ .AND.CLBCY(1)/='CYCL'.AND.CLBCY(2)/='CYCL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 1D MODEL VERSION WITH NON-CYCL",&
+ & "CLBCX OR CLBCY VALUES")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (L2D.AND.(CLBCY(1)/='CYCL'.AND.CLBCY(2)/='CYCL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 2D MODEL VERSION WITH NON-CYCL",&
+ & " CLBCY VALUES")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ !
+ IF ( (.NOT. LCARTESIAN) .AND. ( LCORIO) .AND. (.NOT. LGEOST_UV_FRC) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("BE CAREFUL YOU COULD HAVE SPURIOUS MOTIONS " ,&
+ & " NEAR THE LBC AS LCORIO=T and LGEOST_UV_FRC=F")')
+ END IF
+ !
+ IF ((.NOT.LFLAT).AND.OFLAT) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'ZERO OROGRAPHY IN INITIAL FILE'
+ WRITE(UNIT=ILUOUT,FMT=*) '***** ALL TERMS HAVE BEEN NEVERTHELESS COMPUTED WITHOUT SIMPLIFICATION*****'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS SHOULD LEAD TO ERRORS IN THE PRESSURE COMPUTATION'
+ END IF
+ IF (LFLAT.AND.(.NOT.OFLAT)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='(" OROGRAPHY IS NOT EQUAL TO ZERO ", &
+ & "IN INITIAL FILE" ,/, &
+ & "******* OROGRAPHY HAS BEEN SET TO ZERO *********",/, &
+ & "ACCORDING TO ZERO OROGRAPHY, SIMPLIFICATIONS HAVE ", &
+ & "BEEN MADE IN COMPUTATIONS")')
+ END IF
+END IF
+!
+!* 3.8 System of equations
+!
+IF ( HEQNSYS /= CEQNSYS ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU HAVE CHANGED THE SYSTEM OF EQUATIONS'
+ WRITE(ILUOUT,FMT=*) 'THE ANELASTIC CONSTRAINT IS PERHAPS CHANGED :'
+ WRITE(ILUOUT,FMT=*) 'FOR THE INITIAL FILE YOU HAVE USED ',HEQNSYS
+ WRITE(ILUOUT,FMT=*) 'FOR THE RUN YOU PLAN TO USE ',CEQNSYS
+ WRITE(ILUOUT,FMT=*) 'THIS CAN LEAD TO A NUMERICAL EXPLOSION IN THE FIRST TIME STEPS'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+! 3.9 Numerical schemes
+!
+IF ( (CUVW_ADV_SCHEME == 'CEN4TH') .AND. &
+ (CTEMP_SCHEME /= 'LEFR') .AND. (CTEMP_SCHEME /= 'RKC4') ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("CEN4TH SCHEME HAS TO BE USED WITH ",&
+ &"CTEMP_SCHEME = LEFR of RKC4 ONLY")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF ( (CUVW_ADV_SCHEME == 'WENO_K') .AND. LNUMDIFU ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE NUMERICAL DIFFUSION ",&
+ &"WITH WENO SCHEME ALREADY DIFFUSIVE")')
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 4. CHECK COHERENCE BETWEEN EXSEG VARIABLES
+! ---------------------------------------
+!
+!* 4.1 coherence between coupling variables in EXSEG file
+!
+IF (KMI == 1) THEN
+ NCPL_NBR = 0
+ DO JCI = 1,JPCPLFILEMAX
+ IF (LEN_TRIM(CCPLFILE(JCI)) /= 0) THEN ! Finds the number
+ NCPL_NBR = NCPL_NBR + 1 ! of coupling files
+ ENDIF
+ IF (JCI/=JPCPLFILEMAX) THEN ! Deplaces the coupling files
+ IF ((LEN_TRIM(CCPLFILE(JCI)) == 0) .AND. &! names if one missing
+ (LEN_TRIM(CCPLFILE(JCI+1)) /= 0)) THEN
+ DO JI=JCI,JPCPLFILEMAX-1
+ CCPLFILE(JI)=CCPLFILE(JI+1)
+ END DO
+ CCPLFILE(JPCPLFILEMAX)=' '
+ END IF
+ END IF
+ END DO
+!
+ IF (NCPL_NBR /= 0) THEN
+ LSTEADYLS = .FALSE.
+ ELSE
+ LSTEADYLS = .TRUE.
+ ENDIF
+END IF
+!
+!* 4.3 check consistency in forcing switches
+!
+IF ( LFORCING ) THEN
+ IF ( LRELAX_THRV_FRC .AND. ( LTEND_THRV_FRC .OR. LGEOST_TH_FRC ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU CHOSE A TEMPERATURE AND HUMIDITY RELAXATION'
+ WRITE(ILUOUT,FMT=*) 'TOGETHER WITH TENDENCY OR GEOSTROPHIC FORCING'
+ WRITE(ILUOUT,FMT=*) &
+ 'YOU MIGHT CHECK YOUR SWITCHES: LRELAX_THRV_FRC, LTEND_THRV_FRC, AND'
+ WRITE(ILUOUT,FMT=*) 'LGEOST_TH_FRC'
+ END IF
+!
+ IF ( LRELAX_UV_FRC .AND. LGEOST_UV_FRC ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU MUST NOT USE A WIND RELAXATION'
+ WRITE(ILUOUT,FMT=*) 'TOGETHER WITH A GEOSTROPHIC FORCING'
+ WRITE(ILUOUT,FMT=*) 'CHECK SWITCHES: LRELAX_UV_FRC, LGEOST_UV_FRC'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( CRELAX_HEIGHT_TYPE.NE."FIXE" .AND. CRELAX_HEIGHT_TYPE.NE."THGR" ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'CRELAX_HEIGHT_TYPE MUST BE EITHER "FIXE" OR "THGR"'
+ WRITE(ILUOUT,FMT=*) 'BUT IT IS "', CRELAX_HEIGHT_TYPE, '"'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( .NOT.LCORIO .AND. LGEOST_UV_FRC ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU CANNOT HAVE A GEOSTROPHIC FORCING WITHOUT'
+ WRITE(ILUOUT,FMT=*) 'ACTIVATING LCORIOLIS OPTION'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( LPGROUND_FRC ) THEN
+ WRITE(ILUOUT,FMT=*) 'SURFACE PRESSURE FORCING NOT YET IMPLEMENTED'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+END IF
+!
+IF (LTRANS .AND. .NOT. LFLAT ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU ASK FOR A CONSTANT SPEED DOMAIN TRANSLATION '
+ WRITE(ILUOUT,FMT=*) 'BUT NOT IN THE FLAT TERRAIN CASE:'
+ WRITE(ILUOUT,FMT=*) 'THIS IS NOT ALLOWED ACTUALLY'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+!* 4.4 Check the coherence between the LUSERn and LHORELAX
+!
+IF (.NOT. LUSERV .AND. LHORELAX_RV) THEN
+ LHORELAX_RV=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RV FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RV=FALSE'
+END IF
+!
+IF (.NOT. LUSERC .AND. LHORELAX_RC) THEN
+ LHORELAX_RC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RC FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RC=FALSE'
+END IF
+!
+IF (.NOT. LUSERR .AND. LHORELAX_RR) THEN
+ LHORELAX_RR=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RR FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RR=FALSE'
+END IF
+!
+IF (.NOT. LUSERI .AND. LHORELAX_RI) THEN
+ LHORELAX_RI=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RI FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RI=FALSE'
+END IF
+!
+IF (.NOT. LUSERS .AND. LHORELAX_RS) THEN
+ LHORELAX_RS=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RS FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RS=FALSE'
+END IF
+!
+IF (.NOT. LUSERG .AND. LHORELAX_RG) THEN
+ LHORELAX_RG=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RG FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RG=FALSE'
+END IF
+!
+IF (.NOT. LUSERH .AND. LHORELAX_RH) THEN
+ LHORELAX_RH=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RH FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RH=FALSE'
+END IF
+!
+IF (CTURB=='NONE' .AND. LHORELAX_TKE) THEN
+ LHORELAX_TKE=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX TKE FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_TKE=FALSE'
+END IF
+!
+!
+IF (CCLOUD/='C2R2' .AND. CCLOUD/='KHKO' .AND. LHORELAX_SVC2R2) THEN
+ LHORELAX_SVC2R2=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX C2R2 or KHKO FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVC2R2=FALSE'
+END IF
+!
+IF (CCLOUD/='C3R5' .AND. LHORELAX_SVC1R3) THEN
+ LHORELAX_SVC1R3=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX C3R5 FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVC1R3=FALSE'
+END IF
+!
+IF (CCLOUD/='LIMA' .AND. LHORELAX_SVLIMA) THEN
+ LHORELAX_SVLIMA=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX LIMA FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVLIMA=FALSE'
+END IF
+!
+IF (CELEC(1:3) /= 'ELE' .AND. LHORELAX_SVELEC) THEN
+ LHORELAX_SVELEC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX ELEC FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVELEC=FALSE'
+END IF
+!
+IF (.NOT. LUSECHEM .AND. LHORELAX_SVCHEM) THEN
+ LHORELAX_SVCHEM=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX CHEM FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVCHEM=FALSE'
+END IF
+!
+IF (.NOT. LUSECHIC .AND. LHORELAX_SVCHIC) THEN
+ LHORELAX_SVCHIC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX ICE CHEM FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVCHIC=FALSE'
+END IF
+!
+IF (.NOT. LORILAM .AND. LHORELAX_SVAER) THEN
+ LHORELAX_SVAER=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX AEROSOL FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVAER=FALSE'
+END IF
+
+IF (.NOT. LDUST .AND. LHORELAX_SVDST) THEN
+ LHORELAX_SVDST=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX DUST FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVDST=FALSE'
+END IF
+
+IF (.NOT. LSALT .AND. LHORELAX_SVSLT) THEN
+ LHORELAX_SVSLT=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX SEA SALT FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVSLT=FALSE'
+END IF
+
+IF (.NOT. LPASPOL .AND. LHORELAX_SVPP) THEN
+ LHORELAX_SVPP=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX PASSIVE POLLUTANT FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVPP=FALSE'
+END IF
+#ifdef MNH_FOREFIRE
+IF (.NOT. LFOREFIRE .AND. LHORELAX_SVFF) THEN
+ LHORELAX_SVFF=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX FOREFIRE FLUXES BUT THEY DO NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVFF=FALSE'
+END IF
+#endif
+IF (.NOT. LCONDSAMP .AND. LHORELAX_SVCS) THEN
+ LHORELAX_SVCS=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX CONDITIONAL SAMPLING FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVCS=FALSE'
+END IF
+
+IF (.NOT. LBLOWSNOW .AND. LHORELAX_SVSNW) THEN
+ LHORELAX_SVSNW=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX BLOWING SNOW FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVSNW=FALSE'
+END IF
+
+IF (ANY(LHORELAX_SV(NSV+1:))) THEN
+ LHORELAX_SV(NSV+1:)=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX SV(NSV+1:) FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SV(NSV+1:)=FALSE'
+END IF
+!
+!* 4.5 check the number of points for the horizontal relaxation
+!
+IF ( NRIMX > KRIMX .AND. .NOT.LHORELAX_SVELEC ) THEN
+ NRIMX = KRIMX
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE A LARGER NUMBER OF POINTS '
+ WRITE(ILUOUT,FMT=*) 'FOR THE HORIZONTAL RELAXATION THAN THE '
+ WRITE(ILUOUT,FMT=*) 'CORRESPONDING NUMBER OF LARGE SCALE FIELDS:'
+ WRITE(ILUOUT,FMT=*) 'IT IS THEREFORE REDUCED TO NRIMX =',NRIMX
+END IF
+!
+IF ( L2D .AND. KRIMY>0 ) THEN
+ NRIMY = 0
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE A 2D MODEL THEREFORE NRIMY=0 '
+END IF
+!
+IF ( NRIMY > KRIMY .AND. .NOT.LHORELAX_SVELEC ) THEN
+ NRIMY = KRIMY
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE A LARGER NUMBER OF POINTS '
+ WRITE(ILUOUT,FMT=*) 'FOR THE HORIZONTAL RELAXATION THAN THE '
+ WRITE(ILUOUT,FMT=*) 'CORRESPONDING NUMBER OF LARGE SCALE FIELDS:'
+ WRITE(ILUOUT,FMT=*) 'IT IS THEREFORE REDUCED TO NRIMY =',NRIMY
+END IF
+!
+IF ( (.NOT. LHORELAX_UVWTH) .AND. (.NOT.(ANY(LHORELAX_SV))) .AND. &
+ (.NOT. LHORELAX_SVC2R2).AND. (.NOT. LHORELAX_SVC1R3) .AND. &
+ (.NOT. LHORELAX_SVLIMA).AND. &
+ (.NOT. LHORELAX_SVELEC).AND. (.NOT. LHORELAX_SVCHEM) .AND. &
+ (.NOT. LHORELAX_SVLG) .AND. (.NOT. LHORELAX_SVPP) .AND. &
+ (.NOT. LHORELAX_SVCS) .AND. &
+#ifdef MNH_FOREFIRE
+ (.NOT. LHORELAX_SVFF) .AND. &
+#endif
+ (.NOT. LHORELAX_RV) .AND. (.NOT. LHORELAX_RC) .AND. &
+ (.NOT. LHORELAX_RR) .AND. (.NOT. LHORELAX_RI) .AND. &
+ (.NOT. LHORELAX_RS) .AND. (.NOT. LHORELAX_RG) .AND. &
+ (.NOT. LHORELAX_RH) .AND. (.NOT. LHORELAX_TKE) .AND. &
+ (.NOT. LHORELAX_SVCHIC).AND. &
+ (NRIMX /= 0 .OR. NRIMY /= 0)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU DO NOT WANT TO USE THE HORIZONTAL RELAXATION '
+ WRITE(ILUOUT,FMT=*) 'THEREFORE NRIMX=NRIMY=0 '
+ NRIMX=0
+ NRIMY=0
+END IF
+!
+IF ((LHORELAX_UVWTH .OR. LHORELAX_SVPP .OR. &
+ LHORELAX_SVCS .OR. &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF .OR. &
+#endif
+ LHORELAX_SVC2R2 .OR. LHORELAX_SVC1R3 .OR. &
+ LHORELAX_SVLIMA .OR. &
+ LHORELAX_SVELEC .OR. LHORELAX_SVCHEM .OR. &
+ LHORELAX_SVLG .OR. ANY(LHORELAX_SV) .OR. &
+ LHORELAX_RV .OR. LHORELAX_RC .OR. &
+ LHORELAX_RR .OR. LHORELAX_RI .OR. &
+ LHORELAX_RG .OR. LHORELAX_RS .OR. &
+ LHORELAX_RH .OR. LHORELAX_TKE.OR. &
+ LHORELAX_SVCHIC ) &
+ .AND. (NRIMX==0 .OR. (NRIMY==0 .AND. .NOT.(L2D) ))) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE THE HORIZONTAL RELAXATION '
+ WRITE(ILUOUT,FMT=*) 'BUT NRIMX OR NRIMY=0 CHANGE YOUR VALUES '
+ WRITE(ILUOUT,FMT=*) "LHORELAX_UVWTH=",LHORELAX_UVWTH
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVC2R2=",LHORELAX_SVC2R2
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVC1R3=",LHORELAX_SVC1R3
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVLIMA=",LHORELAX_SVLIMA
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVELEC=",LHORELAX_SVELEC
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVCHEM=",LHORELAX_SVCHEM
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVCHIC=",LHORELAX_SVCHIC
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVLG=",LHORELAX_SVLG
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVPP=",LHORELAX_SVPP
+#ifdef MNH_FOREFIRE
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVFF=",LHORELAX_SVFF
+#endif
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVCS=",LHORELAX_SVCS
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SV=",LHORELAX_SV
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RV=",LHORELAX_RV
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RC=",LHORELAX_RC
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RR=",LHORELAX_RR
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RI=",LHORELAX_RI
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RG=",LHORELAX_RG
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RS=",LHORELAX_RS
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RH=",LHORELAX_RH
+ WRITE(ILUOUT,FMT=*) "LHORELAX_TKE=", LHORELAX_TKE
+ WRITE(ILUOUT,FMT=*) "NRIMX=",NRIMX
+ WRITE(ILUOUT,FMT=*) "NRIMY=",NRIMY
+ WRITE(ILUOUT,FMT=*) "L2D=",L2D
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF ((LHORELAX_UVWTH .OR. LHORELAX_SVPP .OR. &
+ LHORELAX_SVCS .OR. &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF .OR. &
+#endif
+ LHORELAX_SVC2R2 .OR. LHORELAX_SVC1R3 .OR. &
+ LHORELAX_SVLIMA .OR. &
+ LHORELAX_SVELEC .OR. LHORELAX_SVCHEM .OR. &
+ LHORELAX_SVLG .OR. ANY(LHORELAX_SV) .OR. &
+ LHORELAX_RV .OR. LHORELAX_RC .OR. &
+ LHORELAX_RR .OR. LHORELAX_RI .OR. &
+ LHORELAX_RG .OR. LHORELAX_RS .OR. &
+ LHORELAX_RH .OR. LHORELAX_TKE.OR. &
+ LHORELAX_SVCHIC ) &
+ .AND. (KMI /=1)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE THE HORIZONTAL RELAXATION '
+ WRITE(ILUOUT,FMT=*) 'FOR A NESTED MODEL BUT THE COUPLING IS ALREADY DONE'
+ WRITE(ILUOUT,FMT=*) 'BY THE GRID NESTING. CHANGE LHORELAX TO FALSE'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERV) .AND. LUSERV .AND. LHORELAX_RV
+ELSE
+ GRELAX = .NOT.(LUSERV_G(NDAD(KMI))) .AND. LUSERV_G(KMI).AND. LHORELAX_RV
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RV=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RV FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RV=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERC) .AND. LUSERC .AND. LHORELAX_RC
+ELSE
+ GRELAX = .NOT.(LUSERC_G(NDAD(KMI))) .AND. LUSERC_G(KMI).AND. LHORELAX_RC
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RC FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RC=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERR) .AND. LUSERR .AND. LHORELAX_RR
+ELSE
+ GRELAX = .NOT.(LUSERR_G(NDAD(KMI))) .AND. LUSERR_G(KMI).AND. LHORELAX_RR
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RR=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RR FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RR=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERI) .AND. LUSERI .AND. LHORELAX_RI
+ELSE
+ GRELAX = .NOT.(LUSERI_G(NDAD(KMI))) .AND. LUSERI_G(KMI).AND. LHORELAX_RI
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RI=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RI FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RI=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERG) .AND. LUSERG .AND. LHORELAX_RG
+ELSE
+ GRELAX = .NOT.(LUSERG_G(NDAD(KMI))) .AND. LUSERG_G(KMI).AND. LHORELAX_RG
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RG=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RG FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RG=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERH) .AND. LUSERH .AND. LHORELAX_RH
+ELSE
+ GRELAX = .NOT.(LUSERH_G(NDAD(KMI))) .AND. LUSERH_G(KMI).AND. LHORELAX_RH
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RH=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RH FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RH=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERS) .AND. LUSERS .AND. LHORELAX_RS
+ELSE
+ GRELAX = .NOT.(LUSERS_G(NDAD(KMI))) .AND. LUSERS_G(KMI).AND. LHORELAX_RS
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RS=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RS FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RS=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = HTURB=='NONE' .AND. LUSETKE(1).AND. LHORELAX_TKE
+ELSE
+ GRELAX = .NOT.(LUSETKE(NDAD(KMI))) .AND. LUSETKE(KMI) .AND. LHORELAX_TKE
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_TKE=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE TKE FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_TKE=FALSE'
+END IF
+!
+!
+DO JSV = 1,NSV_USER
+!
+ IF (KMI==1) THEN
+ GRELAX = KSV_USER<JSV .AND. LUSESV(JSV,1).AND. LHORELAX_SV(JSV)
+ ELSE
+ GRELAX = .NOT.(LUSESV(JSV,NDAD(KMI))) .AND. LUSESV(JSV,KMI) .AND. LHORELAX_SV(JSV)
+ END IF
+ !
+ IF ( GRELAX ) THEN
+ LHORELAX_SV(JSV)=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE ',JSV,' SV FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SV(',JSV,')=FALSE'
+ END IF
+END DO
+!
+!* 4.6 consistency in LES diagnostics choices
+!
+IF (CLES_NORM_TYPE=='EKMA' .AND. .NOT. LCORIO) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE THE EKMAN NORMALIZATION'
+ WRITE(ILUOUT,FMT=*) 'BUT CORIOLIS FORCE IS NOT USED (LCORIO=.FALSE.)'
+ WRITE(ILUOUT,FMT=*) 'THEN, NO NORMALIZATION IS PERFORMED'
+ CLES_NORM_TYPE='NONE'
+END IF
+!
+!* 4.7 Check the coherence with LNUMDIFF
+!
+IF (L1D .AND. (LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE HORIZONTAL DIFFUSION '
+ WRITE(ILUOUT,FMT=*) 'BUT YOU ARE IN A COLUMN MODEL (L1D=.TRUE.).'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LNUMDIFU and LNUMDIFTH and LNUMDIFSV'
+ WRITE(ILUOUT,FMT=*) 'ARE SET TO FALSE'
+ LNUMDIFU=.FALSE.
+ LNUMDIFTH=.FALSE.
+ LNUMDIFSV=.FALSE.
+END IF
+!
+IF (.NOT. LNUMDIFTH .AND. LZDIFFU) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU DO NOT WANT TO USE HORIZONTAL DIFFUSION (LNUMDIFTH=F)'
+ WRITE(ILUOUT,FMT=*) 'BUT YOU WANT TO USE Z-NUMERICAL DIFFUSION '
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LNUMDIFTH IS SET TO TRUE'
+ LNUMDIFTH=.TRUE.
+END IF
+!
+!* 4.8 Other
+!
+IF (XTNUDGING < 4.*XTSTEP) THEN
+ XTNUDGING = 4.*XTSTEP
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("TIME SCALE FOR NUDGING CAN NOT BE SMALLER THAN", &
+ & " FOUR TIMES THE TIME STEP")')
+ WRITE(ILUOUT,FMT=*) 'XTNUDGING is SET TO ',XTNUDGING
+END IF
+!
+!
+IF (XWAY(KMI) == 3. ) THEN
+ XWAY(KMI) = 2.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("XWAY=3 DOES NOT EXIST ANYMORE; ", &
+ & " IT IS REPLACED BY XWAY=2 ")')
+END IF
+!
+IF ( (KMI == 1) .AND. XWAY(KMI) /= 0. ) THEN
+ XWAY(KMI) = 0.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("XWAY MUST BE EQUAL TO 0 FOR DAD MODEL")')
+END IF
+!
+!JUANZ ZRESI solver need BSPLITTING
+IF ( CPRESOPT == 'ZRESI' .AND. CSPLIT /= 'BSPLITTING' ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("Paralleliez in Z solver CPRESOPT=ZRESI need also CSPLIT=BSPLITTING ")')
+ WRITE(ILUOUT,FMT=*) ' ERROR you have to set also CSPLIT=BSPLITTING '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF ( LEN_TRIM(HINIFILEPGD)>0 ) THEN
+ IF ( CINIFILEPGD/=HINIFILEPGD ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) ' ERROR : in EXSEG1.nam, in NAM_LUNITn you have CINIFILEPGD= ',CINIFILEPGD
+ WRITE(ILUOUT,FMT=*) ' whereas in .des you have CINIFILEPGD= ',HINIFILEPGD
+ WRITE(ILUOUT,FMT=*) ' Please check your Namelist '
+ WRITE(ILUOUT,FMT=*) ' For example, you may have specified the un-nested PGD file instead of the nested PGD file '
+ WRITE(ILUOUT,FMT=*)
+ WRITE(ILUOUT,FMT=*) '###############'
+ WRITE(ILUOUT,FMT=*) ' MESONH ABORTS'
+ WRITE(ILUOUT,FMT=*) '###############'
+ WRITE(ILUOUT,FMT=*)
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ELSE
+ CINIFILEPGD = ''
+!* note that after a spawning, there is no value for CINIFILEPGD in the .des file,
+! so the checking cannot be made if the user starts a simulation directly from
+! a spawned file (without the prep_real_case stage)
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 5. WE DO NOT FORGET TO UPDATE ALL DOLLARN NAMELIST VARIABLES
+! ---------------------------------------------------------
+!
+CALL UPDATE_NAM_LUNITN
+CALL UPDATE_NAM_CONFN
+CALL UPDATE_NAM_DYNN
+CALL UPDATE_NAM_ADVN
+CALL UPDATE_NAM_PARAMN
+CALL UPDATE_NAM_PARAM_RADN
+#ifdef MNH_ECRAD
+CALL UPDATE_NAM_PARAM_ECRADN
+#endif
+CALL UPDATE_NAM_PARAM_KAFRN
+CALL UPDATE_NAM_PARAM_MFSHALLN
+CALL UPDATE_NAM_LBCN
+CALL UPDATE_NAM_NUDGINGN
+CALL UPDATE_NAM_TURBN
+CALL UPDATE_NAM_CH_MNHCN
+CALL UPDATE_NAM_CH_SOLVERN
+CALL UPDATE_NAM_SERIESN
+CALL UPDATE_NAM_BLOWSNOWN
+!-------------------------------------------------------------------------------
+WRITE(UNIT=ILUOUT,FMT='(/)')
+!-------------------------------------------------------------------------------
+!
+!* 6. FORMATS
+! -------
+!
+9000 FORMAT(/,'NOTE IN READ_EXSEG FOR MODEL ', I2, ' : ',/, &
+ '--------------------------------')
+9001 FORMAT(/,'CAUTION ERROR IN READ_EXSEG FOR MODEL ', I2,' : ',/, &
+ '----------------------------------------' )
+9002 FORMAT(/,'WARNING IN READ_EXSEG FOR MODEL ', I2,' : ',/, &
+ '----------------------------------' )
+9003 FORMAT(/,'FATAL ERROR IN READ_EXSEG FOR MODEL ', I2,' : ',/, &
+ '--------------------------------------' )
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE READ_EXSEG_n
diff --git a/src/ZSOLVER/spectre.f90 b/src/ZSOLVER/spectre.f90
new file mode 100644
index 0000000000000000000000000000000000000000..545c60629410ef29c5a16bfd5289f96038c41e28
--- /dev/null
+++ b/src/ZSOLVER/spectre.f90
@@ -0,0 +1,217 @@
+!MNH_LIC Copyright 2011-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! ######spl
+ PROGRAM SPECTRE
+! ############
+!
+!!****
+!!
+!! PURPOSE
+!! -------
+!! compute energy spectra from a MESONH file
+!!
+!!
+!!
+!!
+!! Modifications:
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+USE MODD_CONF
+USE MODD_IO, ONLY: NIO_VERB,NVERB_DEBUG,TFILEDATA
+USE MODD_LUNIT
+USE MODD_LUNIT_n
+USE MODD_TIME_n
+USE MODD_DIM_ll
+USE MODD_SPECTRE
+!
+USE MODI_SPECTRE_MESONH
+USE MODI_SPECTRE_AROME
+!
+USE MODE_MSG
+USE MODE_POS
+USE MODE_IO, only: IO_Config_set, IO_Init
+USE MODE_IO_FILE, only: IO_File_close, IO_File_open
+USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list, IO_Filelist_print
+use mode_init_ll, only: END_PARA_ll
+USE MODE_MODELN_HANDLER
+!USE MODD_TYPE_DATE
+USE MODI_VERSION
+!
+USE MODN_CONFZ
+USE MODN_CONFIO, ONLY : NAM_CONFIO
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of local variables
+!
+CHARACTER (LEN=28), DIMENSION(1) :: YINIFILE ! names of the INPUT FM-file
+CHARACTER (LEN=50) :: YOUTFILE ! names of the OUTPUT FM-file
+INTEGER :: IRESP ! return code in FM routines
+INTEGER :: ILUOUT0 ! Logical unit number for the output listing
+INTEGER :: ILUNAM ! Logical unit numbers for the namelist file
+ ! and for output_listing file
+LOGICAL :: GFOUND ! Return code when searching namelist
+!
+INTEGER :: IINFO_ll ! return code for _ll routines
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE:: ZWORK ! work array
+REAL,DIMENSION(:,:,:),ALLOCATABLE:: ZWORKAROME ! work array
+INTEGER :: NI,NJ,NK
+REAL ::XDELTAX,XDELTAY
+TYPE(TFILEDATA),POINTER :: TZNMLFILE => NULL()
+!
+NAMELIST/NAM_SPECTRE/ LSPECTRE_U,LSPECTRE_V,LSPECTRE_W,LSPECTRE_TH,LSPECTRE_RV,&
+ LSPECTRE_LSU,LSPECTRE_LSV,LSPECTRE_LSW,LSPECTRE_LSTH,LSPECTRE_LSRV,LSMOOTH
+!
+NAMELIST/NAM_SPECTRE_FILE/ YINIFILE,CTYPEFILE,YOUTFILE,LSTAT
+NAMELIST/NAM_ZOOM_SPECTRE/ LZOOM,NITOT,NJTOT,NXDEB,NYDEB
+NAMELIST/NAM_DOMAIN_AROME/ NI,NJ,NK,XDELTAX,XDELTAY
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.0 Initializations
+! ---------------
+!
+!
+CALL GOTO_MODEL(1)
+!
+CALL VERSION
+CPROGRAM='SPEC '
+!
+CALL IO_Init()
+!
+! initialization
+YINIFILE(:) = ' '
+CTYPEFILE = 'MESONH'
+LSPECTRE_U = .FALSE.
+LSPECTRE_V = .FALSE.
+LSPECTRE_W = .FALSE.
+LSPECTRE_TH = .FALSE.
+LSPECTRE_RV = .FALSE.
+LSPECTRE_LSU = .FALSE.
+LSPECTRE_LSV = .FALSE.
+LSPECTRE_LSW = .FALSE.
+LSPECTRE_LSTH = .FALSE.
+LSPECTRE_LSRV = .FALSE.
+LSMOOTH = .FALSE.
+LZOOM = .FALSE.
+YOUTFILE = ' '
+LSTAT = .FALSE.
+NI=750
+NJ=720
+NK=60
+XDELTAX=2500.
+XDELTAY=2500.
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.0 Namelist reading
+! ----------------
+!
+PRINT*, ' '
+PRINT*, '*********************************************************************'
+PRINT*, '*********************************************************************'
+PRINT*, ' '
+!
+CALL IO_File_add2list(TZNMLFILE,'SPEC1.nam','NML','READ')
+CALL IO_File_open(TZNMLFILE)
+ILUNAM = TZNMLFILE%NLU
+!
+PRINT*, 'READ THE SPEC1.NAM FILE'
+!
+CALL POSNAM(ILUNAM,'NAM_SPECTRE',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_SPECTRE)
+ PRINT*, ' namelist NAM_SPECTRE read'
+END IF
+!
+!
+CALL POSNAM(ILUNAM,'NAM_SPECTRE_FILE',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_SPECTRE_FILE)
+ PRINT*, ' namelist NAM_SPECTRE_FILE read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_ZOOM_SPECTRE',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_ZOOM_SPECTRE)
+ PRINT*, ' namelist NAM_ZOOM_SPECTRE read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_DOMAIN_AROME',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_DOMAIN_AROME)
+ PRINT*, ' namelist NAM_DOMAIN_AROME read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_CONFZ',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_CONFZ)
+ PRINT*, ' namelist NAM_CONFZ read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_CONFIO',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_CONFIO)
+ PRINT*, ' namelist NAM_CONFIO read'
+END IF
+CALL IO_Config_set()
+!
+CALL IO_File_close(TZNMLFILE)
+!
+CINIFILE = YINIFILE(1)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.0 file
+! -----------
+!
+IF ( LEN_TRIM(CINIFILE)==0 ) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','SPECTRE','LEN_TRIM(CINIFILE)==0')
+ENDIF
+!
+IF ( LEN_TRIM(YOUTFILE)==0 ) THEN
+ WRITE(YOUTFILE,FMT='(A,A)') "spectra_",TRIM(ADJUSTL(CINIFILE))
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3.0 Fields initialization and spectra computation
+!
+IF (CTYPEFILE=='MESONH') THEN
+ CALL SPECTRE_MESONH(YOUTFILE)
+ !
+ CALL IO_File_close(LUNIT_MODEL(1)%TINIFILE)
+ IF(NIO_VERB>=NVERB_DEBUG) CALL IO_Filelist_print()
+ CALL IO_File_close(TLUOUT0)
+ CALL IO_File_close(TLUOUT)
+ELSEIF (CTYPEFILE=='AROME ')THEN
+ CALL SPECTRE_AROME(CINIFILE,YOUTFILE,XDELTAX,XDELTAY,NI,NJ,NK)
+ELSE
+ print*,"This type of file is not accept for SPECTRE PROGRAM"
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. FINALIZE THE PARALLEL SESSION
+! -----------------------------
+!
+CALL END_PARA_ll(IINFO_ll)
+!
+PRINT*, ' '
+PRINT*, '****************************************************'
+PRINT*, '* EXIT SPECTRE CORRECTLY *'
+PRINT*, '****************************************************'
+PRINT*, ' '
+!-------------------------------------------------------------------------------
+END PROGRAM SPECTRE
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b7b1fef019a506cd0e79221c34ab869645069cc2
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
@@ -0,0 +1,1552 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! MPI communication routines for multigrid code
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module communication
+ use messages
+ use datatypes
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use timer
+
+ implicit none
+
+public::comm_preinitialise
+public::comm_initialise
+public::comm_finalise
+public::scalarprod_mnh
+public::scalarprod
+public::print_scalaprod2
+public::boundary_mnh
+public::haloswap_mnh
+public::haloswap
+public::ihaloswap_mnh
+public::ihaloswap
+public::collect
+public::distribute
+public::i_am_master_mpi
+public::master_rank
+public::pproc
+public::MPI_COMM_HORIZ
+public::comm_parameters
+public::comm_measuretime
+
+
+ ! Number of processors
+ ! n_proc = 2^(2*pproc), with integer pproc
+ integer :: pproc
+
+! Rank of master process
+ integer, parameter :: master_rank = 0
+! Am I the master process?
+ logical :: i_am_master_mpi
+
+ integer, parameter :: dim = 3 ! Dimension
+ integer, parameter :: dim_horiz = 2 ! Horizontal dimension
+ integer :: MPI_COMM_HORIZ ! Communicator with horizontal partitioning
+
+private
+
+! Data types for halo exchange in both x- and y-direction
+ integer, dimension(:,:,:), allocatable :: halo_type
+
+! MPI vector data types
+ ! Halo for data exchange in north-south direction
+ integer, allocatable, dimension(:,:) :: halo_ns
+ integer, allocatable, dimension(:,:) :: halo_nst
+ integer, allocatable, dimension(:,:) :: halo_wet
+ ! Vector data type for interior of field a(level,m)
+ integer, allocatable, dimension(:,:) :: interior
+ integer, allocatable, dimension(:,:) :: interiorT
+ ! Vector data type for one quarter of interior of field
+ ! at level a(level,m). This has the same size (and can be
+ ! used for communications with) the interior of a(level,m+1)
+ integer, allocatable, dimension(:,:) :: sub_interior
+ integer, allocatable, dimension(:,:) :: sub_interiorT
+ ! Timer for halo swaps
+ type(time), allocatable, dimension(:,:) :: t_haloswap
+ ! Timer for collect and distribute
+ type(time), allocatable, dimension(:) :: t_collect
+ type(time), allocatable, dimension(:) :: t_distribute
+ ! Parallelisation parameters
+ ! Measure communication times?
+ logical :: comm_measuretime
+
+ ! Parallel communication parameters
+ type comm_parameters
+ ! Size of halos
+ integer :: halo_size
+ end type comm_parameters
+
+ type(comm_parameters) :: comm_param
+
+! Data layout
+! ===========
+!
+! The number of processes has to be of the form nproc = 2^(2*pproc) to
+! ensure that data can be distributed between processes.
+! The processes are arranged in a (2^pproc) x (2^pproc) cartesian grid
+! in the horizontal plane (i.e. vertical columns are always local to one
+! process), which is implemented via the communicator MPI_COMM_HORIZ.
+! This MPI_cart_rank() and MPI_cart_shift() can then be used to
+! easily identify neighbouring processes.
+
+! The number of data grid cells in each direction has to be a multiply
+! of 2**(L-1) where L is the number of levels (including the coarse
+! and fine level), with the coarse level corresponding to level=1.
+! Also define L_split as the level where we start to pull together
+! data. For levels > L_split each position in the cartesian grid is
+! included in the work, below this only a subset of processes is
+! used.
+!
+! Each grid a(level,m) is identified by two numbers:
+! (1) The multigrid level it belongs to (level)
+! (2) The number of active processes that operate on it (2^(2*m)).
+!
+! For level > L_split, m=procp. For L_split we store a(L_split,pproc) and
+! a(L_split,pproc-1), and only processes with even coordinates in both
+! horizontal directions use this grid.
+! Below that level, store a(L_split-1,pproc-1) and a(L_split-1,pproc-2),
+! where only processes for which both horiontal coordinates are
+! multiples of four use the latter. This is continued until only on
+! process is left.
+!
+!
+! level
+! L a(L,pproc)
+! L-1 a(L-1,pproc)
+! ...
+! L_split a(L_split,pproc) a(L_split ,pproc-1)
+! L_split-1 a(L_split-1,pproc-1) a(L_split-1,pproc-2)
+!
+! ... a(3,1)
+! a(2,1)
+! a(1,1)
+!
+! When moving from left to right in the above graph the total number of
+! grid cells does not change, but the number of data points per process
+! increases by a factor of 4.
+!
+! Parallel operations
+! ===================
+!
+! (*) Halo exchange. Update halo with data from neighbouring
+! processors in cartesian grid on current (level,m)
+! (*) Collect data on all processes at (level,m) on those
+! processes that are still active on (level,m-1).
+! (*) Distribute data at (level,m-1) and duplicate on all processes
+! that are active at (level,m).
+!
+! Note that in the cartesian processor grid the first coordinate
+! is the North-South (y-) direction, the second coordinate is the
+! East-West (x-) direction, i.e. the layout is this:
+!
+! p_0 (0,0) p_1 (0,1) p_2 (0,2) p_3 (0,3)
+!
+! p_4 (1,0) p_5 (1,1) p_6 (1,2) p_7 (1,3)
+!
+! p_8 (2,0) p_9 (2,1) p_10 (2,2) p_11 (2,3)
+!
+! [...]
+!
+!
+! Normal multigrid restriction and prolongation are used to
+! move between levels with fixed m.
+!
+!
+
+contains
+
+!==================================================================
+! Pre-initialise communication routines
+!==================================================================
+ subroutine comm_preinitialise()
+ implicit none
+ integer :: nproc, ierr, rank
+ call mpi_comm_size(MPI_COMM_WORLD, nproc, ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)
+ i_am_master_mpi = (rank == master_rank)
+ ! Check that nproc = 2^(2*p)
+ pproc = floor(log(1.0d0*nproc)/log(4.0d0))
+ if ( (nproc - 4**pproc) .ne. 0) then
+ call fatalerror("Number of processors has to be 2^(2*pproc) with integer pproc.")
+ end if
+ if (i_am_master_mpi) then
+ write(STDOUT,'("PARALLEL RUN")')
+ write(STDOUT,'("Number of processors : 2^(2*pproc) = ",I10," with pproc = ",I6)') &
+ nproc, pproc
+ end if
+ ! Create halo data types
+
+ end subroutine comm_preinitialise
+
+!==================================================================
+! Initialise communication routines
+!==================================================================
+ subroutine comm_initialise(n_lev, & !} multigrid parameters
+ lev_split, & !}
+ grid_param, & ! Grid parameters
+ comm_param_in) ! Parallel communication
+ ! parameters
+ implicit none
+ integer, intent(in) :: n_lev
+ integer, intent(in) :: lev_split
+ type(grid_parameters), intent(inout) :: grid_param
+ type(comm_parameters), intent(in) :: comm_param_in
+ integer :: n
+ integer :: nz
+ integer :: rank, nproc, ierr
+ integer :: count, blocklength, stride
+ integer, dimension(2) :: p_horiz
+ integer :: m, level, nlocal
+ logical :: reduced_m
+ integer :: halo_size
+ character(len=32) :: t_label
+
+ integer,parameter :: nb_dims=3
+ integer,dimension(nb_dims) :: profil_tab,profil_sous_tab,coord_debut
+
+ n = grid_param%n
+ nz = grid_param%nz
+
+ comm_param = comm_param_in
+ halo_size = comm_param%halo_size
+
+ call mpi_comm_size(MPI_COMM_WORLD, nproc, ierr)
+
+ ! Create cartesian topology
+ call mpi_cart_create(MPI_COMM_WORLD, & ! Old communicator name
+ dim_horiz, & ! horizontal dimension
+ (/2**pproc,2**pproc/), & ! extent in each horizontal direction
+ (/.false.,.false./), & ! periodic?
+ .true., & ! reorder?
+ MPI_COMM_HORIZ, & ! Name of new communicator
+ ierr)
+ ! calculate and display rank and corrdinates in cartesian grid
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Local size of (horizontal) grid
+ nlocal = n/2**pproc
+
+ ! === Set up data types ===
+ ! Halo for exchange in north-south direction
+ if (LUseO) allocate(halo_ns(n_lev,0:pproc))
+ if (LUseT) allocate(halo_nst(n_lev,0:pproc))
+ if (LUseT) allocate(halo_wet(n_lev,0:pproc))
+ ! Interior data types
+ if (LUseO) allocate(interior(n_lev,0:pproc))
+ if (LUseO) allocate(sub_interior(n_lev,0:pproc))
+ if (LUseT) allocate(interiorT(n_lev,0:pproc))
+ if (LUseT) allocate(sub_interiorT(n_lev,0:pproc))
+ ! Timer
+ allocate(t_haloswap(n_lev,0:pproc))
+ allocate(t_collect(0:pproc))
+ allocate(t_distribute(0:pproc))
+ do m=0,pproc
+ write(t_label,'("t_collect(",I3,")")') m
+ call initialise_timer(t_collect(m),t_label)
+ write(t_label,'("t_distribute(",I3,")")') m
+ call initialise_timer(t_distribute(m),t_label)
+ end do
+
+ m = pproc
+ level = n_lev
+ reduced_m = .false.
+ do while (level > 0)
+ ! --- Create halo data types ---
+ if (LUseO) then
+ ! NS- (y-) direction
+ count = nlocal
+ blocklength = (nz+2)*halo_size
+ stride = (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION, &
+ halo_ns(level,m),ierr)
+ call mpi_type_commit(halo_ns(level,m),ierr)
+ endif
+ ! tranpose
+ if (LUseT) then
+ ! NS- (y-) transpose direction
+ count = nz+2 ! nlocal
+ blocklength = nlocal*halo_size ! (nz+2)*halo_size
+ stride = (nlocal+2*halo_size) * (nlocal+2*halo_size) ! (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION, &
+ halo_nst(level,m),ierr)
+ call mpi_type_commit(halo_nst(level,m),ierr)
+ ! WE- (x-) transpose direction
+ count = (nz+2)*(nlocal+2*halo_size)*halo_size ! nlocal
+ blocklength = 1*halo_size ! (nz+2)*halo_size
+ stride = nlocal+2*halo_size ! (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION, &
+ halo_wet(level,m),ierr)
+ call mpi_type_commit(halo_wet(level,m),ierr)
+ endif
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Commit halo_ns failed in mpi_type_commit().")
+#endif
+ ! --- Create interior data types ---
+ if (LUseO) then
+ count = nlocal
+ blocklength = nlocal*(nz+2)
+ stride = (nz+2)*(nlocal+2*halo_size)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION,interior(level,m),ierr)
+ call mpi_type_commit(interior(level,m),ierr)
+ count = nlocal/2
+ blocklength = nlocal/2*(nz+2)
+ stride = (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION,sub_interior(level,m),ierr)
+ call mpi_type_commit(sub_interior(level,m),ierr)
+ end if
+ if (LUseT) then
+ ! interiorT
+ if ( nlocal /= 0 ) then
+ profil_tab = (/ nlocal+2*halo_size , nlocal+2*halo_size , nz+2 /)
+ profil_sous_tab = (/ nlocal , nlocal , nz+2 /)
+ coord_debut = (/ 0 , 0 , 0 /)
+ call MPI_TYPE_CREATE_SUBARRAY(nb_dims,profil_tab,profil_sous_tab,coord_debut,&
+ MPI_ORDER_FORTRAN,MPI_DOUBLE_PRECISION,interiorT(level,m),ierr)
+ call mpi_type_commit(interiorT(level,m),ierr)
+ end if
+ ! sub_interiorT
+ if ( (nlocal/2) /= 0 ) then
+ profil_tab = (/ nlocal+2*halo_size , nlocal+2*halo_size , nz+2 /)
+ profil_sous_tab = (/ nlocal/2 , nlocal/2 , nz+2 /)
+ coord_debut = (/ 0 , 0 , 0 /)
+ call MPI_TYPE_CREATE_SUBARRAY(nb_dims,profil_tab,profil_sous_tab,coord_debut,&
+ MPI_ORDER_FORTRAN,MPI_DOUBLE_PRECISION,sub_interiorT(level,m),ierr)
+ call mpi_type_commit(sub_interiorT(level,m),ierr)
+ end if
+ end if
+ ! --- Create timers ---
+ write(t_label,'("t_haloswap(",I3,",",I3,")")') level,m
+ call initialise_timer(t_haloswap(level,m),t_label)
+
+ ! If we are below L_split, split data
+ if ( (level .le. lev_split) .and. (m > 0) .and. (.not. reduced_m)) then
+ reduced_m = .true.
+ m = m-1
+ nlocal = 2*nlocal
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ nlocal = nlocal/2
+ end do
+
+ end subroutine comm_initialise
+
+!==================================================================
+! Finalise communication routines
+!==================================================================
+ subroutine comm_finalise(n_lev, & ! } Multigrid parameters
+ lev_split, & !}
+ grid_param ) ! } Grid parameters
+ implicit none
+ integer, intent(in) :: n_lev
+ integer, intent(in) :: lev_split
+ type(grid_parameters), intent(in) :: grid_param
+ ! local var
+ logical :: reduced_m
+ integer :: level, m
+ integer :: ierr
+ integer :: nlocal,n
+ character(len=80) :: s
+
+ ! Local size of (horizontal) grid
+ n = grid_param%n
+ nlocal = n/2**pproc
+
+ m = pproc
+ level = n_lev
+ reduced_m = .false.
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** Finalising communications ***")')
+ end if
+ call print_timerinfo("--- Communication timing results ---")
+ do while (level > 0)
+ write(s,'("level = ",I3,", m = ",I3)') level, m
+ call print_timerinfo(s)
+ ! --- Print out timer information ---
+ call print_elapsed(t_haloswap(level,m),.True.,1.0_rl)
+ ! --- Free halo data types ---
+ if (LUseO) call mpi_type_free(halo_ns(level,m),ierr)
+ if (LUseT) call mpi_type_free(halo_nst(level,m),ierr)
+ if (LUseT) call mpi_type_free(halo_wet(level,m),ierr)
+ ! --- Free interior data types ---
+ if (LUseO) call mpi_type_free(interior(level,m),ierr)
+ if (LUseO) call mpi_type_free(sub_interior(level,m),ierr)
+ if (LUseT .and. (nlocal /= 0 ) ) call mpi_type_free(interiorT(level,m),ierr)
+ if (LUseT .and. ( (nlocal/2) /= 0 ) ) call mpi_type_free(sub_interiorT(level,m),ierr)
+ ! If we are below L_split, split data
+ if ( (level .le. lev_split) .and. (m > 0) .and. (.not. reduced_m)) then
+ reduced_m = .true.
+ m = m-1
+ nlocal = 2*nlocal
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ nlocal = nlocal/2
+ end do
+ do m=pproc,0,-1
+ write(s,'("m = ",I3)') m
+ call print_timerinfo(s)
+ ! --- Print out timer information ---
+ call print_elapsed(t_collect(m),.True.,1.0_rl)
+ call print_elapsed(t_distribute(m),.True.,1.0_rl)
+ end do
+
+ ! Deallocate arrays
+ if (LUseO) deallocate(halo_ns)
+ if (LUseT) deallocate(halo_nst,halo_wet)
+ if (LUseO) deallocate(interior)
+ if (LUseO) deallocate(sub_interior)
+ if (LUseT) deallocate(interiorT)
+ if (LUseT) deallocate(sub_interiorT)
+
+ deallocate(t_haloswap)
+ deallocate(t_collect)
+ deallocate(t_distribute)
+ if (i_am_master_mpi) then
+ write(STDOUT,'("")')
+ end if
+
+ end subroutine comm_finalise
+
+!==================================================================
+! Scalar product of two fields
+!==================================================================
+ subroutine scalarprod_mnh(m, a, b, s)
+ implicit none
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(out) :: s
+ !local var
+ integer :: nprocs, rank, ierr
+ integer :: p_horiz(2)
+ integer :: stepsize
+ integer, parameter :: dim_horiz = 2
+ real(kind=rl) :: local_sum, global_sum
+ real(kind=rl) :: local_sumt,global_sumt
+ integer :: nlocal, nz, i
+ integer :: ix,iy,iz
+ real(kind=rl) :: ddot
+
+ integer :: iy_min,iy_max, ix_min,ix_max
+ real , dimension(:,:,:) , pointer :: za_st,zb_st
+
+ nlocal = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+
+ iy_min = a%iy_min
+ iy_max = a%iy_max
+ ix_min = a%ix_min
+ ix_max = a%ix_max
+
+ ! Work out coordinates of processor
+ call mpi_comm_size(MPI_COMM_HORIZ,nprocs,ierr)
+ call mpi_comm_rank(MPI_COMM_HORIZ,rank,ierr)
+ stepsize = 2**(pproc-m)
+ if (nprocs > 1) then
+ ! Only inlcude local sum if the processor coordinates
+ ! are multiples of stepsize
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (stepsize > 1) .and. &
+ (mod(p_horiz(1),stepsize)==0) .and. &
+ (mod(p_horiz(2),stepsize)==0) ) ) then
+ if (LUseO) then
+ local_sum = 0.0_rl
+ do i = 1, nlocal
+ local_sum = local_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ end if
+ if (LUseT) then
+ local_sumt = 0.0_rl
+ do iz=0,nz+1
+ do iy=a%icompy_min,a%icompy_max
+ do ix=a%icompx_min,a%icompx_max
+ local_sumt = local_sumt &
+ + a%st(ix,iy,iz)*b%st(ix,iy,iz)
+ end do
+ end do
+ end do
+ end if
+ else
+ if (LUseO) local_sum = 0.0_rl
+ if (LUseT) local_sumt = 0.0_rl
+ end if
+ if (LUseO) call mpi_allreduce(local_sum,global_sum,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,MPI_COMM_HORIZ,ierr)
+ if (LUseT) call mpi_allreduce(local_sumt,global_sumt,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,MPI_COMM_HORIZ,ierr)
+ else
+ if (LUseO) then
+ global_sum = 0.0_rl
+ do i = 1, nlocal
+ global_sum = global_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ endif
+ if (LUseT) then
+ za_st => a%st
+ zb_st => b%st
+ global_sumt = 0.0_rl
+ !$acc kernels
+ do iz=0,nz+1
+ do iy=iy_min,iy_max
+ do ix=ix_min,ix_max
+ global_sumt = global_sumt &
+ + za_st(ix,iy,iz)*zb_st(ix,iy,iz)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ endif
+ end if
+ if (LUseO) then
+ s = global_sum
+ else
+ s = global_sumt
+ end if
+
+ end subroutine scalarprod_mnh
+!-------------------------------------------------------------------------------
+ subroutine scalarprod(m, a, b, s)
+ implicit none
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(out) :: s
+ integer :: nprocs, rank, ierr
+ integer :: p_horiz(2)
+ integer :: stepsize
+ integer, parameter :: dim_horiz = 2
+ real(kind=rl) :: local_sum, global_sum
+ integer :: nlocal, nz, i
+ real(kind=rl) :: ddot
+
+ nlocal = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ ! Work out coordinates of processor
+ call mpi_comm_size(MPI_COMM_HORIZ,nprocs,ierr)
+ call mpi_comm_rank(MPI_COMM_HORIZ,rank,ierr)
+ stepsize = 2**(pproc-m)
+ if (nprocs > 1) then
+ ! Only inlcude local sum if the processor coordinates
+ ! are multiples of stepsize
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (stepsize > 1) .and. &
+ (mod(p_horiz(1),stepsize)==0) .and. &
+ (mod(p_horiz(2),stepsize)==0) ) ) then
+ local_sum = 0.0_rl
+ do i = 1, nlocal
+ local_sum = local_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ else
+ local_sum = 0.0_rl
+ end if
+ call mpi_allreduce(local_sum,global_sum,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,MPI_COMM_HORIZ,ierr)
+ else
+ global_sum = 0.0_rl
+ do i = 1, nlocal
+ global_sum = global_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ end if
+ s = global_sum
+ end subroutine scalarprod
+!==================================================================
+! Pritn Scalar product^2 of 1 fields
+!==================================================================
+ subroutine print_scalaprod2(l,m, a, message )
+ implicit none
+ integer, intent(in) :: l,m
+ type(scalar3d), intent(in) :: a
+ character(len=*) , intent(in) :: message
+
+ !local
+ real(kind=rl) :: s
+
+ call scalarprod_mnh(m, a, a, s)
+ s = sqrt(s)
+ if (i_am_master_mpi) then
+ write(STDOUT,'("Print_norm::",A,2I3,E23.15)') message, l,m,s
+ call flush(STDOUT)
+ end if
+
+ end subroutine print_scalaprod2
+!==================================================================
+! Boundary Neumann
+!==================================================================
+ subroutine boundary_mnh(a) ! data field
+
+ implicit none
+
+ type(scalar3d), intent(inout) :: a
+
+ !local var
+ integer :: n, ix_min,ix_max,iy_min,iy_max
+ integer :: icompx_max,icompy_max
+
+ real , dimension(:,:,:) , pointer :: za_st
+
+ ! Update Real Boundary for Newman case u(0) = u(1) , etc ...
+
+ !return
+
+ n = a%grid_param%n
+ ix_min = a%ix_min
+ ix_max = a%ix_max
+ iy_min = a%iy_min
+ iy_max = a%iy_max
+ if (LUseO) then
+ if ( ix_min == 1 ) then
+ a%s(:,:,0) = a%s(:,:,1)
+ endif
+ if ( ix_max == n ) then
+ a%s(:,:,a%icompx_max+1) = a%s(:,:,a%icompx_max)
+ endif
+ if ( iy_min == 1 ) then
+ a%s(:,0,:) = a%s(:,1,:)
+ endif
+ if ( iy_max == n ) then
+ a%s(:,a%icompy_max+1,:) = a%s(:,a%icompy_max,:)
+ endif
+ endif
+ if (LUseT) then
+ ! transpose
+
+ za_st => a%st
+ icompx_max = a%icompx_max
+ icompy_max = a%icompy_max
+
+ !$acc kernels
+ if ( ix_min == 1 ) then
+ !acc kernels
+ za_st(0,:,:) = za_st(1,:,:)
+ !acc end kernels
+ endif
+ if ( ix_max == n ) then
+ !acc kernels
+ za_st(icompx_max+1,:,:) = za_st(icompx_max,:,:)
+ !acc end kernels
+ endif
+ if ( iy_min == 1 ) then
+ !acc kernels
+ za_st(:,0,:) = za_st(:,1,:)
+ !acc end kernels
+ endif
+ if ( iy_max == n ) then
+ !acc kernels
+ za_st(:,icompy_max+1,:) = za_st(:,icompy_max,:)
+ !acc end kernels
+ endif
+ !$acc end kernels
+
+ endif
+
+ end subroutine boundary_mnh
+!==================================================================
+! Initiate asynchronous halo exchange
+!
+! For all processes with horizontal indices that are multiples
+! of 2^(pproc-m), update halos with information held by
+! neighbouring processes, e.g. for pproc-m = 1, stepsize=2
+!
+! N (0,2)
+! ^
+! !
+! v
+!
+! W (2,0) <--> (2,2) <--> E (2,4)
+!
+! ^
+! !
+! v
+! S (4,2)
+!
+!==================================================================
+ subroutine ihaloswap_mnh(level,m, & ! multigrid- and processor- level
+ a, & ! data field
+ send_requests, & ! send requests (OUT)
+ recv_requests, & ! recv requests (OUT)
+ send_requestsT, & ! send requests T (OUT)
+ recv_requestsT & ! recv requests T (OUT)
+ )
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(out), dimension(4) :: send_requests
+ integer, intent(out), dimension(4) :: recv_requests
+ integer, intent(out), dimension(4) :: send_requestsT
+ integer, intent(out), dimension(4) :: recv_requestsT
+ type(scalar3d), intent(inout) :: a
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 1002
+ if (LUseO) call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(1), ierr)
+ recvtag = 1012
+ if (LUseT) call mpi_irecv(a%st(1,0-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(1), ierr)
+ ! Receive from south
+ recvtag = 1003
+ if (LUseO) call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(2), ierr)
+ recvtag = 1013
+ if (LUseT) call mpi_irecv(a%st(1,a_n+1,0),1, &
+ halo_nst(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(2), ierr)
+ ! Send to south
+ sendtag = 1002
+ if (LUseO) call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(1), ierr)
+ sendtag = 1012
+ if (LUseT) call mpi_isend(a%st(1,a_n-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(1), ierr)
+ ! Send to north
+ sendtag = 1003
+ if (LUseO) call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(2), ierr)
+ sendtag = 1013
+ if (LUseT) call mpi_isend(a%st(1,1,0),1, &
+ halo_nst(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(2), ierr)
+ ! Receive from west
+ recvtag = 1000
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(3), ierr)
+ recvtag = 1010
+ if (LUseT) call mpi_irecv(a%st(0-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(3), ierr)
+ ! Receive from east
+ sendtag = 1001
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(4), ierr)
+ sendtag = 1011
+ if (LUseT) call mpi_irecv(a%st(a_n+1,0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(4), ierr)
+ ! Send to east
+ sendtag = 1000
+ if (LUseO) call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(3), ierr)
+ sendtag = 1010
+ if (LUseT) call mpi_isend(a%st(a_n-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(3), ierr)
+ ! Send to west
+ recvtag = 1001
+ if (LUseO) call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(4), ierr)
+ recvtag = 1011
+ if (LUseT) call mpi_isend(a%st(1,0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(4), ierr)
+ end if
+ end if
+ end subroutine ihaloswap_mnh
+!==================================================================
+ subroutine ihaloswap(level,m, & ! multigrid- and processor- level
+ a, & ! data field
+ send_requests, & ! send requests (OUT)
+ recv_requests & ! recv requests (OUT)
+ )
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(out), dimension(4) :: send_requests
+ integer, intent(out), dimension(4) :: recv_requests
+ type(scalar3d), intent(inout) :: a
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 2
+ call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(1), ierr)
+ ! Receive from south
+ recvtag = 3
+ call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(2), ierr)
+ ! Send to south
+ sendtag = 2
+ call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(1), ierr)
+ ! Send to north
+ sendtag = 3
+ call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(2), ierr)
+ ! Receive from west
+ recvtag = 0
+ call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(3), ierr)
+ ! Receive from east
+ sendtag = 1
+ call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(4), ierr)
+ ! Send to east
+ sendtag = 0
+ call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(3), ierr)
+ ! Send to west
+ recvtag = 1
+ call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(4), ierr)
+ end if
+ end if
+ end subroutine ihaloswap
+
+!==================================================================
+! Halo exchange
+!
+! For all processes with horizontal indices that are multiples
+! of 2^(pproc-m), update halos with information held by
+! neighbouring processes, e.g. for pproc-m = 1, stepsize=2
+!
+! N (0,2)
+! ^
+! !
+! v
+!
+! W (2,0) <--> (2,2) <--> E (2,4)
+!
+! ^
+! !
+! v
+! S (4,2)
+!
+!==================================================================
+ subroutine haloswap_mnh(level,m, & ! multigrid- and processor- level
+ a) ! data field
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(inout) :: a
+ !local var
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+ integer, dimension(4) :: requests_ns
+ integer, dimension(4) :: requests_ew
+ integer, dimension(4) :: requests_nsT
+ integer, dimension(4) :: requests_ewT
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ if (comm_measuretime) then
+ call start_timer(t_haloswap(level,m))
+ end if
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 1002
+ if (LUseO) call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(1), ierr)
+ recvtag = 1012
+ if (LUseT) call mpi_irecv(a%st(1,0-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_nsT(1), ierr)
+ ! Receive from south
+ recvtag = 1003
+ if (LUseO) call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(2), ierr)
+ recvtag = 1013
+ if (LUseT) call mpi_irecv(a%st(1,a_n+1,0),1, &
+ halo_nst(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_nsT(2), ierr)
+ ! Send to south
+ sendtag = 1002
+ if (LUseO) call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(3), ierr)
+ sendtag = 1012
+ if (LUseT) call mpi_isend(a%st(1,a_n-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_nsT(3), ierr)
+ ! Send to north
+ sendtag = 1003
+ if (LUseO) call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(4), ierr)
+ sendtag = 1013
+ if (LUseT) call mpi_isend(a%st(1,1,0),1, &
+ halo_nst(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_nsT(4), ierr)
+ if (halo_size > 1) then
+ ! Wait for North <-> South communication to complete
+ if (LUseO) call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,requests_nsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ ! Receive from west
+ recvtag = 1000
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(1), ierr)
+ recvtag = 1010
+ if (LUseT) call mpi_irecv(a%st(0-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ewT(1), ierr)
+ ! Receive from east
+ sendtag = 1001
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(2), ierr)
+ sendtag = 1011
+ if (LUseT) call mpi_irecv(a%st(a_n+1,0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ewT(2), ierr)
+ ! Send to east
+ sendtag = 1000
+ if (LUseO) call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(3), ierr)
+ sendtag = 1010
+ if (LUseT) call mpi_isend(a%st(a_n-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ewT(3), ierr)
+ ! Send to west
+ recvtag = 1001
+ if (LUseO) call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(4), ierr)
+ recvtag = 1011
+ if (LUseT) call mpi_isend(a%st(1,0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ewT(4), ierr)
+ ! Wait for East <-> West communication to complete
+ if (halo_size == 1) then
+ ! Wait for North <-> South communication to complete
+ if (LUseO) call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,requests_nsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if (LUseO) call mpi_waitall(4,requests_ew, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,requests_ewT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if (comm_measuretime) then
+ call finish_timer(t_haloswap(level,m))
+ end if
+ end if
+
+ end subroutine haloswap_mnh
+!==================================================================
+ subroutine haloswap(level,m, & ! multigrid- and processor- level
+ a) ! data field
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(inout) :: a
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+ integer, dimension(4) :: requests_ns
+ integer, dimension(4) :: requests_ew
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ if (comm_measuretime) then
+ call start_timer(t_haloswap(level,m))
+ end if
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 2
+ call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(1), ierr)
+ ! Receive from south
+ recvtag = 3
+ call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(2), ierr)
+ ! Send to south
+ sendtag = 2
+ call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(3), ierr)
+ ! Send to north
+ sendtag = 3
+ call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(4), ierr)
+ if (halo_size > 1) then
+ ! Wait for North <-> South communication to complete
+ call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ end if
+ ! Receive from west
+ recvtag = 0
+ call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(1), ierr)
+ ! Receive from east
+ sendtag = 1
+ call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(2), ierr)
+ ! Send to east
+ sendtag = 0
+ call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(3), ierr)
+ ! Send to west
+ recvtag = 1
+ call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(4), ierr)
+ ! Wait for East <-> West communication to complete
+ if (halo_size == 1) then
+ ! Wait for North <-> South communication to complete
+ call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ end if
+ call mpi_waitall(4,requests_ew, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if (comm_measuretime) then
+ call finish_timer(t_haloswap(level,m))
+ end if
+ end if
+ end subroutine haloswap
+!==================================================================
+! Collect from a(level,m) and store on less processors
+! in b(level,m-1)
+!
+! Example for pproc-m = 1, i.e. stepsize = 2:
+!
+! NW (0,0) <-- NE (0,2)
+!
+! ^ .
+! ! .
+! .
+! SW (2,0) SE (2,2) [send to 0,0]
+!
+!==================================================================
+ subroutine collect(level,m, & ! multigrid and processor level
+ a, & ! IN: data on level (level,m)
+ b) ! OUT: data on level (level,m-1)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(inout) :: b
+ integer :: a_n, b_n ! horizontal grid sizes
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, source_rank, dest_rank, rank, recv_tag, send_tag, iz
+ logical :: corner_nw, corner_ne, corner_sw, corner_se
+ integer :: recv_request(3)
+ integer :: recv_requestT(3)
+
+ call start_timer(t_collect(m))
+
+ stepsize = 2**(pproc-m)
+
+ a_n = a%ix_max-a%ix_min+1
+ b_n = b%ix_max-b%ix_min+1
+ nz = b%grid_param%nz
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ ! Store position in process grid in in p_horiz
+ ! Note we can NOT use cart_shift as we need diagonal neighburs as well
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Ignore all processes that do not participate at this level
+ if ( (stepsize .eq. 1) .or. ((mod(p_horiz(1),stepsize) == 0) .and. (mod(p_horiz(2),stepsize)) == 0)) then
+ ! Determine position in local 2x2 block
+ if (stepsize .eq. 1) then
+ corner_nw = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 0))
+ corner_ne = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 1))
+ corner_sw = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 0))
+ corner_se = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 1))
+ else
+ corner_nw = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_ne = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ corner_sw = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_se = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ end if
+ ! NW receives from the other three processes
+ if ( corner_nw ) then
+ ! Receive from NE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)+stepsize/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1000
+ if (LUseO) call mpi_irecv(b%s(0,1,b_n/2+1),1,sub_interior(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_request(1),ierr)
+ recv_tag = 1010
+ if (LUseT) call mpi_irecv(b%st(b_n/2+1,1,0),1,sub_interiorT(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(1),ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: receive from NE failed in mpi_irecv().")
+#endif
+ ! Receive from SW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1001
+ if (LUseO) call mpi_irecv(b%s(0,b_n/2+1,1),1,sub_interior(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_request(2),ierr)
+ recv_tag = 1011
+ if (LUseT) call mpi_irecv(b%st(1,b_n/2+1,0),1,sub_interiorT(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(2),ierr)
+
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: receive from SW failed in mpi_irecv().")
+#endif
+ ! Receive from SE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)+stepsize/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1002
+ if (LUseO) call mpi_irecv(b%s(0,b_n/2+1,b_n/2+1),1,sub_interior(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_request(3),ierr)
+ recv_tag = 1012
+ if (LUseT) call mpi_irecv(b%st(b_n/2+1,b_n/2+1,0),1,sub_interiorT(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(3),ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: receive from SE failed in mpi_irecv().")
+#endif
+ ! Copy local data while waiting for data from other processes
+ if (LUseO) b%s(0:nz+1,1:a_n,1:a_n) = a%s(0:nz+1,1:a_n,1:a_n)
+ if (LUseT) b%st(1:a_n,1:a_n,0:nz+1) = a%st(1:a_n,1:a_n,0:nz+1)
+ ! Wait for receives to complete before proceeding
+ if (LUseO) call mpi_waitall(3,recv_request,MPI_STATUSES_IGNORE,ierr)
+ if (LUseT) call mpi_waitall(3,recv_requestT,MPI_STATUSES_IGNORE,ierr)
+ end if
+ if ( corner_ne ) then
+ ! Send to NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)-stepsize/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1000
+ if (LUseO) call mpi_send(a%s(0,1,1),1,interior(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ send_tag = 1010
+ if (LUseT) call mpi_send(a%st(1,1,0),1,interiorT(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: send from NE failed in mpi_send().")
+#endif
+ end if
+ if ( corner_sw ) then
+ ! Send to NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1001
+ if (LUseO) call mpi_send(a%s(0,1,1),1,interior(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ send_tag = 1011
+ if (LUseT) call mpi_send(a%st(1,1,0),1,interiorT(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: send from SW failed in mpi_send().")
+#endif
+ end if
+ if ( corner_se ) then
+ ! send to NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)-stepsize/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1002
+ if (LUseO) call mpi_send(a%s(0,1,1),1,interior(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ send_tag = 1012
+ if (LUseT) call mpi_send(a%st(1,1,0),1,interiorT(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: send from SE failed in mpi_send().")
+#endif
+ end if
+
+ end if
+ call finish_timer(t_collect(m))
+
+ end subroutine collect
+
+!==================================================================
+! Distribute data in a(level,m-1) and store in b(level,m)
+!
+! Example for p-m = 1, i.e. stepsize = 2:
+!
+! NW (0,0) --> NE (2,0)
+!
+! ! .
+! v .
+! .
+! SW (0,2) SE (2,2) [receive from to 0,0]
+!==================================================================
+ subroutine distribute(level,m, & ! multigrid and processor level
+ a, & ! IN: Data on level (level,m-1)
+ b) ! OUT: Data on level (level,m)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(inout) :: b
+ integer :: a_n, b_n ! horizontal grid sizes
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, source_rank, dest_rank, send_tag, recv_tag, rank, iz
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: send_request(3)
+ integer :: send_requestT(3)
+ logical :: corner_nw, corner_ne, corner_sw, corner_se
+
+ call start_timer(t_distribute(m))
+
+ stepsize = 2**(pproc-m)
+
+ a_n = a%ix_max-a%ix_min+1
+ b_n = b%ix_max-b%ix_min+1
+ nz = a%grid_param%nz
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Ignore all processes that do not participate at this level
+ if ( (stepsize .eq. 1) .or. ((mod(p_horiz(1),stepsize) == 0) .and. (mod(p_horiz(2),stepsize)) == 0)) then
+ ! Work out coordinates in local 2 x 2 block
+ if (stepsize .eq. 1) then
+ corner_nw = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 0))
+ corner_ne = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 1))
+ corner_sw = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 0))
+ corner_se = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 1))
+ else
+ corner_nw = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_ne = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ corner_sw = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_se = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ end if
+ if ( corner_nw ) then
+ ! (Asynchronous) send to NE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)+stepsize/), &
+ dest_rank, &
+ ierr)
+
+ send_tag = 1000
+ if (LUseO) call mpi_isend(a%s(0,1,a_n/2+1), 1,sub_interior(level,m-1),dest_rank, send_tag, &
+ MPI_COMM_HORIZ,send_request(1),ierr)
+ send_tag = 1010
+ if (LUseT) call mpi_isend(a%st(a_n/2+1,1,0), 1,sub_interiorT(level,m-1),dest_rank, send_tag, &
+ MPI_COMM_HORIZ,send_requestT(1),ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: send to NE failed in mpi_isend().")
+#endif
+ ! (Asynchronous) send to SW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1001
+ if (LUseO) call mpi_isend(a%s(0,a_n/2+1,1),1,sub_interior(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_request(2), ierr)
+ send_tag = 1011
+ if (LUseT) call mpi_isend(a%st(1,a_n/2+1,0),1,sub_interiorT(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_requestT(2), ierr)
+
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: send to SW failed in mpi_isend().")
+#endif
+ ! (Asynchronous) send to SE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)+stepsize/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1002
+ if (LUseO) call mpi_isend(a%s(0,a_n/2+1,a_n/2+1),1,sub_interior(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_request(3), ierr)
+ send_tag = 1012
+ if (LUseT) call mpi_isend(a%st(a_n/2+1,a_n/2+1,0),1,sub_interiorT(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_requestT(3), ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: send to SE failed in mpi_isend().")
+#endif
+ ! While sending, copy local data
+ if (LUseO) b%s(0:nz+1,1:b_n,1:b_n) = a%s(0:nz+1,1:b_n,1:b_n)
+ if (LUseT) b%st(1:b_n,1:b_n,0:nz+1) = a%st(1:b_n,1:b_n,0:nz+1)
+ ! Only proceed when async sends to complete
+ if (LUseO) call mpi_waitall(3, send_request, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(3, send_requestT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if ( corner_ne ) then
+
+ ! Receive from NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)-stepsize/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1000
+ if (LUseO) call mpi_recv(b%s(0,1,1),1,interior(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ recv_tag = 1010
+ if (LUseT) call mpi_recv(b%st(1,1,0),1,interiorT(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: receive on NE failed in mpi_recv().")
+#endif
+ end if
+ if ( corner_sw ) then
+ ! Receive from NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1001
+ if (LUseO) call mpi_recv(b%s(0,1,1),1,interior(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ recv_tag = 1011
+ if (LUseT) call mpi_recv(b%st(1,1,0),1,interiorT(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: receive on SW failed in mpi_recv().")
+#endif
+ end if
+ if ( corner_se ) then
+ ! Receive from NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)-stepsize/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1002
+ if (LUseO) call mpi_recv(b%s(0,1,1),1,interior(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ recv_tag = 1012
+ if (LUseT) call mpi_recv(b%st(1,1,0),1,interiorT(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: receive on NW failed in mpi_recv().")
+#endif
+ end if
+
+ end if
+ call finish_timer(t_distribute(m))
+
+ end subroutine distribute
+
+end module communication
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/compile_tensor b/src/ZSOLVER/tensorproductmultigrid_Source/compile_tensor
new file mode 100755
index 0000000000000000000000000000000000000000..dae8a91858520b10115f0e5e281d9ffe23234594
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/compile_tensor
@@ -0,0 +1,38 @@
+#!/bin/bash
+
+set -x
+set -e
+
+OPT_BASE=" -Mbackslash -Mextend -Kieee -nofma -Mallocatable=95 "
+#OPT_BASE=" -Mbackslash -Mextend -Mallocatable=95 "
+
+#OPTLEVEL=" -O2 -ta=multicore,tesla:nofma,managed "
+#OPTLEVEL=" -g -O2 -ta=multicore,tesla:managed "
+OPTLEVEL=" -tp=px -O2 -ta=multicore,tesla,nofma,cc35,cc50,cc70,cuda10.1,managed -Minfo=accel,ccff -Mprof=ccff "
+#OPTLEVEL=" -O2 -ta=tesla:nofma,managed "
+
+OPT="-r8 -DCARTESIANGEOMETRY -DOVERLAPCOMMS -DPIECEWISELINEAR -Mpreprocess ${OPT_BASE} ${OPTLEVEL} "
+
+F90="mpif90 ${OPT} "
+
+rm -f *.o *.mod mg_main_mnh
+
+pgf90 -show ${OPT} mg_main_mnh.f90
+
+
+for file in parameters.f90 messages.f90 datatypes.f90 timer.f90 communication.f90 discretisation.f90 \
+ solver.f90 conjugategradient.f90 multigrid.f90 profiles.f90 mode_mg_read_param.f90 \
+ mode_mg.f90 mode_mg_read_param.f90 \
+ dblas.f90
+do
+echo ====== file=$file
+${F90} -c $file
+done
+
+
+${F90} -o mg_main_mnh mg_main_mnh.f90 *.o
+
+rm -f *.o *.mod
+
+
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
new file mode 100644
index 0000000000000000000000000000000000000000..30277d8625ad6735444ad7335b761ab6ed369b7a
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
@@ -0,0 +1,529 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Conjugate gradient solver
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module conjugategradient
+
+ use parameters
+ use datatypes
+ use discretisation
+ use messages
+ use communication
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+
+public::cg_parameters
+public::cg_initialise
+public::cg_finalise
+public::cg_solve_mnh
+public::cg_solve
+
+private
+
+ ! --- Conjugate gradient parameters type ---
+ type cg_parameters
+ ! Verbosity level
+ integer :: verbose
+ ! Maximal number of iterations
+ integer :: maxiter
+ ! Required residual reduction
+ real(kind=rl) :: resreduction
+ ! Smoother iterations in preconditioner
+ integer :: n_prec
+ end type cg_parameters
+
+! --- Parameters ---
+ type(cg_parameters) :: cg_param
+ type(grid_parameters) :: grid_param
+
+contains
+
+!==================================================================
+! Initialise conjugate gradient module,
+!==================================================================
+ subroutine cg_initialise(cg_param_in) & ! Conjugate gradient
+ & ! parameters
+ implicit none
+ type(cg_parameters), intent(in) :: cg_param_in
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) '*** Initialising Conjugate gradient ***'
+ write(STDOUT,*) ''
+ end if
+ cg_param = cg_param_in
+ end subroutine cg_initialise
+
+!==================================================================
+! Finalise conjugate gradient module,
+!==================================================================
+ subroutine cg_finalise()
+ implicit none
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) '*** Finalising Conjugate gradient ***'
+ write(STDOUT,*) ''
+ end if
+ end subroutine cg_finalise
+
+!==================================================================
+! Solve A.u = b.
+!==================================================================
+ subroutine cg_solve_mnh(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b ! RHS vector
+ type(scalar3d), intent(inout) :: u ! solution vector
+ type(scalar3d) :: p ! } Auxilliary vectors
+ type(scalar3d) :: r ! } Auxilliary vectors
+ type(scalar3d) :: Ap ! }
+ type(scalar3d) :: z ! }
+ integer :: n_lin
+ real(kind=rl) :: res0, rz, rz_old, res, alpha
+ integer :: i
+ logical :: solver_converged = .false.
+ integer :: n, nz, nlocal, halo_size
+ real(kind=rl) :: pAp
+
+ ! Initialise auxiliary fields
+ p%grid_param = u%grid_param
+ p%ix_min = u%ix_min
+ p%ix_max = u%ix_max
+ p%iy_min = u%iy_min
+ p%iy_max = u%iy_max
+ p%icompx_min = u%icompx_min
+ p%icompx_max = u%icompx_max
+ p%icompy_min = u%icompy_min
+ p%icompy_max = u%icompy_max
+ p%halo_size = u%halo_size
+
+ r%grid_param = u%grid_param
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+
+ z%grid_param = u%grid_param
+ z%ix_min = u%ix_min
+ z%ix_max = u%ix_max
+ z%iy_min = u%iy_min
+ z%iy_max = u%iy_max
+ z%icompx_min = u%icompx_min
+ z%icompx_max = u%icompx_max
+ z%icompy_min = u%icompy_min
+ z%icompy_max = u%icompy_max
+ z%halo_size = u%halo_size
+
+ Ap%grid_param = u%grid_param
+ Ap%ix_min = u%ix_min
+ Ap%ix_max = u%ix_max
+ Ap%iy_min = u%iy_min
+ Ap%iy_max = u%iy_max
+ Ap%icompx_min = u%icompx_min
+ Ap%icompx_max = u%icompx_max
+ Ap%icompy_min = u%icompy_min
+ Ap%icompy_max = u%icompy_max
+ Ap%halo_size = u%halo_size
+
+ n = u%ix_max-u%ix_min+1
+ nz = u%grid_param%nz
+
+ nlocal = u%ix_max - u%ix_min + 1
+ halo_size = u%halo_size
+
+ n_lin = (nlocal+2*halo_size)**2 * (nz+2)
+
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(z%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(p%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(Ap%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ r%s = 0.0_rl
+ z%s = 0.0_rl
+ p%s = 0.0_rl
+ Ap%s = 0.0_rl
+ endif
+
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(z%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(p%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(Ap%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ r%st = 0.0_rl
+ z%st = 0.0_rl
+ p%st = 0.0_rl
+ Ap%st = 0.0_rl
+ endif
+
+
+ ! Initialise
+ ! r <- b - A.u
+ call calculate_residual_mnh(level,m,b,u,r)
+ ! z <- M^{-1} r
+ if (cg_param%n_prec > 0) then
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ ! p <- z
+ if (LUseO) call dcopy(n_lin,z%s,1,p%s,1)
+ if (LUseT) call dcopy(n_lin,z%st,1,p%st,1)
+ ! rz_old = <r,z>
+ call scalarprod_mnh(m,r,z,rz_old)
+ ! res0 <- ||r||
+ call scalarprod_mnh(m,r,r,res0)
+ res0 = dsqrt(res0)
+ if (cg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** CG Solver ( ",I10," dof ) ***")') n_lin
+ write(STDOUT,'(" <CG> Initial residual ||r_0|| = ",E12.6)') res0
+ end if
+ endif
+ if (res0 > tolerance) then
+ do i=1,cg_param%maxiter
+ ! Ap <- A.p
+ call haloswap_mnh(level,m,p)
+ call apply_mnh(p,Ap)
+ ! alpha <- res_old / <p,A.p>
+ call scalarprod_mnh(m,p,Ap,pAp)
+ alpha = rz_old/pAp
+ ! x <- x + alpha*p
+ if (LUseO) call daxpy(n_lin,alpha,p%s,1,u%s,1)
+ if (LUseT) call daxpy(n_lin,alpha,p%st,1,u%st,1)
+ ! r <- r - alpha*A.p
+ if (LUseO) call daxpy(n_lin,-alpha,Ap%s,1,r%s,1)
+ if (LUseT) call daxpy(n_lin,-alpha,Ap%st,1,r%st,1)
+ call scalarprod_mnh(m,r,r,res)
+ res = dsqrt(res)
+ if (cg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Iteration ",I6," ||r|| = ",E12.6)') &
+ i, res
+ end if
+ end if
+ if ( (res/res0 < cg_param%resreduction) .or. &
+ (res < tolerance ) ) then
+ solver_converged = .true.
+ exit
+ end if
+ ! z <- M^{-1} r
+ if (LUseO) z%s = 0.0_rl
+ if (LUseT) z%st = 0.0_rl
+ if (cg_param%n_prec > 0) then
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ call scalarprod_mnh(m,r,z,rz)
+ ! p <- res/res_old*p
+ if (LUseO) call dscal(n_lin,rz/rz_old,p%s,1)
+ if (LUseT) call dscal(n_lin,rz/rz_old,p%st,1)
+ ! p <- p + z
+ if (LUseO) call daxpy(n_lin,1.0_rl,z%s,1,p%s,1)
+ if (LUseT) call daxpy(n_lin,1.0_rl,z%st,1,p%st,1)
+ rz_old = rz
+ end do
+ else
+ res = res0
+ solver_converged = .true.
+ end if
+ if (cg_param%verbose>0) then
+ if (solver_converged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Final residual ||r|| = ",E12.6)') res
+ write(STDOUT,'(" <CG> CG solver converged after ",I6," iterations rho_avg = ",F10.6)') i, (res/res0)**(1.0_rl/i)
+ end if
+ else
+ call warning(" <CG> Solver did not converge")
+ endif
+ end if
+
+ if (LUseO) then
+ deallocate(r%s)
+ deallocate(z%s)
+ deallocate(p%s)
+ deallocate(Ap%s)
+ end if
+
+ if (LUseT) then
+ deallocate(r%st)
+ deallocate(z%st)
+ deallocate(p%st)
+ deallocate(Ap%st)
+ end if
+
+ end subroutine cg_solve_mnh
+!==================================================================
+! Solve A.u = b.
+!==================================================================
+ subroutine cg_solve(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b ! RHS vector
+ type(scalar3d), intent(inout) :: u ! solution vector
+ type(scalar3d) :: p ! } Auxilliary vectors
+ type(scalar3d) :: r ! } Auxilliary vectors
+ type(scalar3d) :: Ap ! }
+ type(scalar3d) :: z ! }
+ integer :: n_lin
+ real(kind=rl) :: res0, rz, rz_old, res, alpha
+ integer :: i
+ logical :: solver_converged = .false.
+ integer :: n, nz, nlocal, halo_size
+ real(kind=rl) :: pAp
+
+ ! Initialise auxiliary fields
+ p%grid_param = u%grid_param
+ p%ix_min = u%ix_min
+ p%ix_max = u%ix_max
+ p%iy_min = u%iy_min
+ p%iy_max = u%iy_max
+ p%icompx_min = u%icompx_min
+ p%icompx_max = u%icompx_max
+ p%icompy_min = u%icompy_min
+ p%icompy_max = u%icompy_max
+ p%halo_size = u%halo_size
+
+ r%grid_param = u%grid_param
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+
+ z%grid_param = u%grid_param
+ z%ix_min = u%ix_min
+ z%ix_max = u%ix_max
+ z%iy_min = u%iy_min
+ z%iy_max = u%iy_max
+ z%icompx_min = u%icompx_min
+ z%icompx_max = u%icompx_max
+ z%icompy_min = u%icompy_min
+ z%icompy_max = u%icompy_max
+ z%halo_size = u%halo_size
+
+ Ap%grid_param = u%grid_param
+ Ap%ix_min = u%ix_min
+ Ap%ix_max = u%ix_max
+ Ap%iy_min = u%iy_min
+ Ap%iy_max = u%iy_max
+ Ap%icompx_min = u%icompx_min
+ Ap%icompx_max = u%icompx_max
+ Ap%icompy_min = u%icompy_min
+ Ap%icompy_max = u%icompy_max
+ Ap%halo_size = u%halo_size
+
+ n = u%ix_max-u%ix_min+1
+ nz = u%grid_param%nz
+
+ nlocal = u%ix_max - u%ix_min + 1
+ halo_size = u%halo_size
+
+ n_lin = (nlocal+2*halo_size)**2 * (nz+2)
+
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(z%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(p%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(Ap%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ r%s = 0.0_rl
+ z%s = 0.0_rl
+ p%s = 0.0_rl
+ Ap%s = 0.0_rl
+ end if
+
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(z%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(p%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(Ap%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ r%st = 0.0_rl
+ z%st = 0.0_rl
+ p%st = 0.0_rl
+ Ap%st = 0.0_rl
+ end if
+
+ ! Initialise
+ ! r <- b - A.u
+ call calculate_residual(level,m,b,u,r)
+ ! z <- M^{-1} r
+ if (cg_param%n_prec > 0) then
+ call smooth(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ ! p <- z
+ if (LUseO) call dcopy(n_lin,z%s,1,p%s,1)
+ if (LUseT) call dcopy(n_lin,z%st,1,p%st,1)
+ ! rz_old = <r,z>
+ call scalarprod(m,r,z,rz_old)
+ ! res0 <- ||r||
+ call scalarprod(m,r,r,res0)
+ res0 = dsqrt(res0)
+ if (cg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** CG Solver ( ",I10," dof ) ***")') n_lin
+ write(STDOUT,'(" <CG> Initial residual ||r_0|| = ",E12.6)') res0
+ end if
+ endif
+ if (res0 > tolerance) then
+ do i=1,cg_param%maxiter
+ ! Ap <- A.p
+ call haloswap(level,m,p)
+ call apply(p,Ap)
+ ! alpha <- res_old / <p,A.p>
+ call scalarprod(m,p,Ap,pAp)
+ alpha = rz_old/pAp
+ ! x <- x + alpha*p
+ if (LUseO) call daxpy(n_lin,alpha,p%s,1,u%s,1)
+ if (LUseT) call daxpy(n_lin,alpha,p%st,1,u%st,1)
+ ! r <- r - alpha*A.p
+ if (LUseO) call daxpy(n_lin,-alpha,Ap%s,1,r%s,1)
+ if (LUseT) call daxpy(n_lin,-alpha,Ap%st,1,r%st,1)
+ call scalarprod(m,r,r,res)
+ res = dsqrt(res)
+ if (cg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Iteration ",I6," ||r|| = ",E12.6)') &
+ i, res
+ end if
+ end if
+ if ( (res/res0 < cg_param%resreduction) .or. &
+ (res < tolerance ) ) then
+ solver_converged = .true.
+ exit
+ end if
+ ! z <- M^{-1} r
+ if (LUseO) z%s = 0.0_rl
+ if (LUseT) z%st = 0.0_rl
+ if (cg_param%n_prec > 0) then
+ call smooth(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ call scalarprod(m,r,z,rz)
+ ! p <- res/res_old*p
+ if (LUseO) call dscal(n_lin,rz/rz_old,p%s,1)
+ if (LUseT) call dscal(n_lin,rz/rz_old,p%st,1)
+ ! p <- p + z
+ if (LUseO) call daxpy(n_lin,1.0_rl,z%s,1,p%s,1)
+ if (LUseT) call daxpy(n_lin,1.0_rl,z%st,1,p%st,1)
+ rz_old = rz
+ end do
+ else
+ res = res0
+ solver_converged = .true.
+ end if
+ if (cg_param%verbose>0) then
+ if (solver_converged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Final residual ||r|| = ",E12.6)') res
+ write(STDOUT,'(" <CG> CG solver converged after ",I6," iterations rho_avg = ",F10.6)') i, (res/res0)**(1.0_rl/i)
+ end if
+ else
+ call warning(" <CG> Solver did not converge")
+ endif
+ end if
+
+ if (LUseO) then
+ deallocate(r%s)
+ deallocate(z%s)
+ deallocate(p%s)
+ deallocate(Ap%s)
+ end if
+ if (LUseT) then
+ deallocate(r%st)
+ deallocate(z%st)
+ deallocate(p%st)
+ deallocate(Ap%st)
+ end if
+ end subroutine cg_solve
+
+end module conjugategradient
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7f7c6eab07766a2a9978a089b07262f4e0b405f6
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
@@ -0,0 +1,507 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Grid data types for three dimensional cell centred grids.
+! We always assume that the number of gridcells and size in
+! the x- and y- direction is identical.
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+
+module datatypes
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use parameters
+ use messages
+
+ implicit none
+
+! Vertical boundary conditions
+ integer, parameter :: VERTBC_DIRICHLET = 1
+ integer, parameter :: VERTBC_NEUMANN = 2
+
+! Parameters of three dimensional grid
+ type grid_parameters
+ integer :: n ! Total number of grid cells in horizontal direction
+ integer :: nz ! Total number of grid cells in vertical direction
+ real(kind=rl) :: L ! Global extent of grid in horizontal direction
+ real(kind=rl) :: H ! Global extent of grid in vertical direction
+ integer :: vertbc ! Vertical boundary condition (see VERTBC_DIRICHLET
+ ! and VERTBC_NEUMANN)
+ logical :: graded ! Is the vertical grid graded?
+ end type grid_parameters
+
+! Three dimensional scalar field s(z,y,x)
+ type scalar3d
+ integer :: ix_min ! } (Inclusive) range of locally owned cells
+ integer :: ix_max ! } in the x-direction
+ integer :: iy_min ! } (these ranges DO NOT include halo cells)
+ integer :: iy_max ! } in the y-direction
+ integer :: icompx_min ! } (Inclusive) ranges of computational cells,
+ integer :: icompx_max ! } in local coords. All cells in these ranges
+ integer :: icompy_min ! } are included in calculations, e.g. in the
+ integer :: icompy_max ! } smoother. This allows duplicating operations
+ ! } on part of the halo for RB Gauss Seidel
+ integer :: halo_size ! Size of halos
+ logical :: isactive ! Is this field active, i.e. used on one of the
+ ! active processes on coarser grids?
+ real(kind=rl),allocatable :: s(:,:,:)
+ real(kind=rl),pointer :: st(:,:,:)
+ type(grid_parameters) :: grid_param
+ end type scalar3d
+
+public::VERTBC_DIRICHLET
+public::VERTBC_NEUMANN
+public::scalar3d
+public::grid_parameters
+public::L2norm_mnh
+public::L2norm
+public::daxpy_scalar3d
+public::save_scalar3d
+public::create_scalar3d
+public::volscale_scalar3d_mnh
+public::volscale_scalar3d
+public::destroy_scalar3d
+public::volume_of_element
+public::r_grid
+
+private
+
+ ! Vertical grid, this array of length n_z+1 stores the
+ ! vertices of the grid in the vertical direction
+ real(kind=rl), allocatable :: r_grid(:)
+
+ contains
+
+!==================================================================
+! volume of element on cubed sphere grid
+! NB: ix,iy are global indices
+!==================================================================
+ real(kind=rl) function volume_of_element(ix,iy,grid_param)
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ type(grid_parameters), intent(in) :: grid_param
+ real(kind=rl) :: h
+ real(kind=rl) :: rho_i, sigma_j
+ h = 2.0_rl/grid_param%n
+ rho_i = 2.0_rl*(ix-0.5_rl)/grid_param%n-1.0_rl
+ sigma_j = 2.0_rl*(iy-0.5_rl)/grid_param%n-1.0_rl
+ volume_of_element = (1.0_rl+rho_i**2+sigma_j**2)**(-1.5_rl)*h**2
+ end function volume_of_element
+
+!==================================================================
+! Create scalar3d field on fine grid and set to zero
+!==================================================================
+ subroutine create_scalar3d(comm_horiz,grid_param, halo_size, phi)
+ implicit none
+
+ integer :: comm_horiz ! Horizontal communicator
+ type(grid_parameters), intent(in) :: grid_param ! Grid parameters
+ integer, intent(in) :: halo_size ! Halo size
+ type(scalar3d), intent(inout) :: phi ! Field to create
+ integer :: nproc ! Number of processes
+ integer :: rank, ierr ! rank and MPI error
+ integer, dimension(2) :: p_horiz ! position in 2d
+ ! processor grid
+ integer :: nlocal ! Local number of
+ ! cells in horizontal
+ ! direction
+ integer, parameter :: dim_horiz = 2 ! horiz. dimension
+
+ phi%grid_param = grid_param
+ call mpi_comm_size(comm_horiz, nproc, ierr)
+ nlocal = grid_param%n/sqrt(1.0*nproc)
+
+ ! Work out position in 2d processor grid
+ call mpi_comm_rank(comm_horiz, rank, ierr)
+ call mpi_cart_coords(comm_horiz,rank,dim_horiz,p_horiz,ierr)
+ ! Set local data ranges
+ ! NB: p_horiz stores (py,px) in that order (see comment in
+ ! communication module)
+ phi%iy_min = p_horiz(1)*nlocal + 1
+ phi%iy_max = (p_horiz(1)+1)*nlocal
+ phi%ix_min = p_horiz(2)*nlocal + 1
+ phi%ix_max = (p_horiz(2)+1)*nlocal
+ ! Set computational ranges. Note that these are different at
+ ! the edges of the domain!
+ if (p_horiz(1) == 0) then
+ phi%icompy_min = 1
+ else
+ phi%icompy_min = 1 - (halo_size - 1)
+ end if
+ if (p_horiz(1) == floor(sqrt(1.0_rl*nproc))-1) then
+ phi%icompy_max = nlocal
+ else
+ phi%icompy_max = nlocal + (halo_size - 1)
+ end if
+ if (p_horiz(2) == 0) then
+ phi%icompx_min = 1
+ else
+ phi%icompx_min = 1 - (halo_size - 1)
+ end if
+ if (p_horiz(2) == floor(sqrt(1.0_rl*nproc))-1) then
+ phi%icompx_max = nlocal
+ else
+ phi%icompx_max = nlocal + (halo_size - 1)
+ end if
+ ! Set halo size
+ phi%halo_size = halo_size
+ ! Set field to active
+ phi%isactive = .true.
+ ! Allocate memory
+ if (LUseO) then
+ allocate(phi%s(0:grid_param%nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ phi%s(:,:,:) = 0.0_rl
+ end if
+ if (LUseT) then
+ allocate(phi%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:grid_param%nz+1))
+ phi%st(:,:,:) = 0.0_rl
+ end if
+
+ end subroutine create_scalar3d
+
+!==================================================================
+! Destroy scalar3d field on fine grid
+!==================================================================
+ subroutine destroy_scalar3d(phi)
+ implicit none
+ type(scalar3d), intent(inout) :: phi
+
+ if (LUseO) deallocate(phi%s)
+ if (LUseT) deallocate(phi%st)
+
+ end subroutine destroy_scalar3d
+
+!==================================================================
+! Scale fields with volume of element
+! Either multiply with volume factor |T| v_k (power = 1)
+! or divide by it (power = -1)
+!==================================================================
+ subroutine volscale_scalar3d_mnh(phi,power)
+ implicit none
+ type(scalar3d), intent(inout) :: phi
+ integer, intent(in) :: power
+ integer :: ix, iy, iz
+ integer :: ierr
+ integer :: nlocalx, nlocaly, nz
+ real(kind=rl) :: vol_h, vol_r, h, tmp
+
+ if (.not. ( ( power .eq. 1) .or. (power .eq. -1) ) ) then
+ call fatalerror("power has to be -1 or 1 when volume-scaling fields")
+ end if
+
+ if (phi%isactive) then
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+ nz = phi%grid_param%nz
+
+ h = phi%grid_param%L/phi%grid_param%n
+ vol_h = h**2
+ vol_r = 1.0_rl ! r_grid(iz+1)-r_grid(iz)
+ if (power == 1) then
+ tmp = vol_h*vol_r
+ else
+ tmp = 1.0_rl/(vol_h*vol_r)
+ end if
+
+ if (LUseO) phi%s (1:nz,1:nlocaly,1:nlocalx) = tmp*phi%s (1:nz,1:nlocaly,1:nlocalx)
+ if (LUseT) phi%st(1:nlocalx,1:nlocaly,1:nz) = tmp*phi%st(1:nlocalx,1:nlocaly,1:nz)
+
+ end if
+
+ end subroutine volscale_scalar3d_mnh
+
+!==================================================================
+! Scale fields with volume of element
+! Either multiply with volume factor |T| v_k (power = 1)
+! or divide by it (power = -1)
+!==================================================================
+ subroutine volscale_scalar3d(phi,power)
+ implicit none
+ type(scalar3d), intent(inout) :: phi
+ integer, intent(in) :: power
+ integer :: ix, iy, iz
+ integer :: ierr
+ integer :: nlocalx, nlocaly
+ real(kind=rl) :: vol_h, vol_r, h, tmp
+
+ if (.not. ( ( power .eq. 1) .or. (power .eq. -1) ) ) then
+ call fatalerror("power has to be -1 or 1 when volume-scaling fields")
+ end if
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+
+ if (phi%isactive) then
+ do ix=1,nlocalx
+ do iy=1,nlocaly
+#ifdef CARTESIANGEOMETRY
+ h = phi%grid_param%L/phi%grid_param%n
+ vol_h = h**2
+#else
+ vol_h = volume_of_element(ix+(phi%ix_min-1), &
+ iy+(phi%iy_min-1), &
+ phi%grid_param)
+#endif
+ do iz=1,phi%grid_param%nz
+#ifdef CARTESIANGEOMETRY
+ vol_r = r_grid(iz+1)-r_grid(iz)
+#else
+ vol_r = (r_grid(iz+1)**3 - r_grid(iz)**3)/3.0_rl
+#endif
+ if (power == 1) then
+ tmp = vol_h*vol_r
+ else
+ tmp = 1.0_rl/(vol_h*vol_r)
+ end if
+ if (LUseO) phi%s(iz,iy,ix) = tmp*phi%s(iz,iy,ix)
+ if (LUseT) phi%st(ix,iy,iz) = tmp*phi%st(ix,iy,iz)
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine volscale_scalar3d
+
+!==================================================================
+! Calculate L2 norm
+! If phi_is_volumeintegral is .true. then phi is interpreted
+! as the volume integral in a cell, otherwise it is interpreted as the
+! average value in a cell.
+!==================================================================
+ real(kind=rl) function l2norm_mnh(phi,phi_is_volumeintegral)
+ implicit none
+ type(scalar3d), intent(in) :: phi
+ logical, optional :: phi_is_volumeintegral
+ !local var
+ integer :: ix, iy, iz
+ real(kind=rl) :: tmp, global_tmp
+ real(kind=rl) :: tmpt, global_tmpt
+ integer :: ierr
+ integer :: nlocalx, nlocaly, nz
+ real(kind=rl) :: vol_h, vol_r, h
+ logical :: divide_by_volume
+ real(kind=rl) :: volume_factor
+
+ real , dimension(:,:,:) , pointer :: zphi_st
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+ nz = phi%grid_param%nz
+
+ tmp = 0.0_rl
+ tmpt = 0.0_rl
+ if (phi%isactive) then
+
+ if (LUseO) then
+ do ix=1,nlocalx
+ do iy=1,nlocaly
+ do iz=1,nz
+ tmp = tmp + phi%s(iz,iy,ix)**2 ! * volume_factor
+ end do
+ end do
+ end do
+ end if
+
+ if (LUseT) then
+ zphi_st => phi%st
+ !$acc kernels loop dtype(nvidia) collapse(3)
+ do iz=1,nz
+ do iy=1,nlocaly
+ do ix=1,nlocalx
+ tmpt = tmpt + zphi_st(ix,iy,iz)**2 ! * volume_factor
+ end do
+ end do
+ end do
+ !$acc end kernels
+
+ end if
+ end if
+
+ if (LUseO) then
+ call mpi_allreduce(tmp,global_tmp, 1, &
+ MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+ global_tmp = dsqrt(global_tmp)
+ endif
+ if (LUseT) then
+ call mpi_allreduce(tmpt,global_tmpt, 1, &
+ MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+ global_tmpt = dsqrt(global_tmpt)
+ end if
+ if (LUseO) then
+ l2norm_mnh = global_tmp
+ else
+ l2norm_mnh = global_tmpt
+ endif
+
+ end function l2norm_mnh
+!----------------------------------------------------------------------------
+ real(kind=rl) function l2norm(phi,phi_is_volumeintegral)
+ implicit none
+ type(scalar3d), intent(in) :: phi
+ logical, optional :: phi_is_volumeintegral
+ integer :: ix, iy, iz
+ real(kind=rl) :: tmp, global_tmp
+ integer :: ierr
+ integer :: nlocalx, nlocaly
+ real(kind=rl) :: vol_h, vol_r, h
+ logical :: divide_by_volume
+ real(kind=rl) :: volume_factor
+ if (present(phi_is_volumeintegral)) then
+ divide_by_volume = phi_is_volumeintegral
+ else
+ divide_by_volume = .false.
+ end if
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+
+ tmp = 0.0_rl
+ if (phi%isactive) then
+ do ix=1,nlocalx
+ do iy=1,nlocaly
+#ifdef CARTESIANGEOMETRY
+ h = phi%grid_param%L/phi%grid_param%n
+ vol_h = h**2
+#else
+ vol_h = volume_of_element(ix+(phi%ix_min-1), &
+ iy+(phi%iy_min-1), &
+ phi%grid_param)
+#endif
+ do iz=1,phi%grid_param%nz
+#ifdef CARTESIANGEOMETRY
+ vol_r = r_grid(iz+1)-r_grid(iz)
+#else
+ vol_r = (r_grid(iz+1)**3 - r_grid(iz)**3)/3.0_rl
+#endif
+ if (divide_by_volume) then
+ volume_factor = 1.0_rl/(vol_h*vol_r)
+ else
+ volume_factor = vol_h*vol_r
+ end if
+ tmp = tmp + volume_factor*phi%s(iz,iy,ix)**2
+ end do
+ end do
+ end do
+ end if
+
+ call mpi_allreduce(tmp,global_tmp, 1, &
+ MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+ l2norm = dsqrt(global_tmp)
+ end function l2norm
+
+!==================================================================
+! calculate phi <- phi + alpha*dphi
+!==================================================================
+ subroutine daxpy_scalar3d(alpha,dphi,phi)
+ implicit none
+ real(kind=rl), intent(in) :: alpha
+ type(scalar3d), intent(in) :: dphi
+ type(scalar3d), intent(inout) :: phi
+ integer :: nlin
+ integer :: nlocalx, nlocaly
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+ nlin = (nlocalx+2*phi%halo_size) &
+ * (nlocaly+2*phi%halo_size) &
+ * (phi%grid_param%nz+2)
+
+ if (LUseO) call daxpy(nlin,alpha,dphi%s,1,phi%s,1)
+ if (LUseT) call daxpy(nlin,alpha,dphi%st,1,phi%st,1)
+
+
+ end subroutine daxpy_scalar3d
+
+!==================================================================
+! Save scalar field to file
+!==================================================================
+ subroutine save_scalar3d(comm_horiz,phi,filename)
+ implicit none
+ integer, intent(in) :: comm_horiz
+ type(scalar3d), intent(in) :: phi
+ character(*), intent(in) :: filename
+ integer :: file_id = 100
+ integer :: ix,iy,iz
+ integer :: nlocal
+ integer :: rank, nproc, ierr
+ character(len=21) :: s
+
+ nlocal = phi%ix_max-phi%ix_min+1
+
+ ! Get number of processes and rank
+ call mpi_comm_size(comm_horiz, nproc, ierr)
+ call mpi_comm_rank(comm_horiz, rank, ierr)
+
+ write(s,'(I10.10,"_",I10.10)') nproc, rank
+
+ open(unit=file_id,file=trim(filename)//"_"//trim(s)//".dat")
+ write(file_id,*) "# 3d scalar data file"
+ write(file_id,*) "# ==================="
+ write(file_id,*) "# Data is written as s(iz,iy,ix) "
+ write(file_id,*) "# with the leftmost index running fastest"
+ write(file_id,'(" n = ",I8)') phi%grid_param%n
+ write(file_id,'(" nz = ",I8)') phi%grid_param%nz
+ write(file_id,'(" L = ",F20.10)') phi%grid_param%L
+ write(file_id,'(" H = ",F20.10)') phi%grid_param%H
+ write(file_id,'(" ix_min = ",I10)') phi%ix_min
+ write(file_id,'(" ix_max = ",I10)') phi%ix_max
+ write(file_id,'(" iy_min = ",I10)') phi%iy_min
+ write(file_id,'(" iy_max = ",I10)') phi%iy_max
+ write(file_id,'(" icompx_min = ",I10)') phi%icompx_min
+ write(file_id,'(" icompx_max = ",I10)') phi%icompx_max
+ write(file_id,'(" icompy_min = ",I10)') phi%icompy_min
+ write(file_id,'(" icompy_max = ",I10)') phi%icompy_max
+ write(file_id,'(" halosize = ",I10)') phi%halo_size
+
+
+ do ix=1-phi%halo_size,nlocal+phi%halo_size
+ do iy=1-phi%halo_size,nlocal+phi%halo_size
+ do iz=0,phi%grid_param%nz+1
+ write(file_id,'(E24.15)') phi%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ close(file_id)
+ end subroutine save_scalar3d
+
+end module datatypes
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
new file mode 100644
index 0000000000000000000000000000000000000000..48d5dcdce4f328566fd6e968cd8ba21311c5dd30
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
@@ -0,0 +1,241 @@
+subroutine dcopy(n,sx,incx,sy,incy)
+!
+! copies a vector, x, to a vector, y.
+! uses unrolled loops for increments equal to 1.
+! jack dongarra, linpack, 3/11/78.
+! modified 12/3/93, array(1) declarations changed to array(*)
+! modified 12/12/00 change name to avoid confusion with spline routine
+!
+ real sx(*),sy(*)
+ integer i,incx,incy,ix,iy,m,mp1,n
+!
+ if(n.le.0)return
+ if(incx.eq.1.and.incy.eq.1)go to 20
+!
+! code for unequal increments or equal increments
+! not equal to 1
+!
+ ix = 1
+ iy = 1
+ if(incx.lt.0)ix = (-n+1)*incx + 1
+ if(incy.lt.0)iy = (-n+1)*incy + 1
+ do 10 i = 1,n
+ sy(iy) = sx(ix)
+ ix = ix + incx
+ iy = iy + incy
+ 10 continue
+ return
+!
+! code for both increments equal to 1
+!
+!
+! clean-up loop
+!
+ 20 m = mod(n,7)
+ if( m .eq. 0 ) go to 40
+ do 30 i = 1,m
+ sy(i) = sx(i)
+ 30 continue
+ if( n .lt. 7 ) return
+ 40 mp1 = m + 1
+ !$acc kernels
+ do 50 i = mp1,n,7
+ sy(i) = sx(i)
+ sy(i + 1) = sx(i + 1)
+ sy(i + 2) = sx(i + 2)
+ sy(i + 3) = sx(i + 3)
+ sy(i + 4) = sx(i + 4)
+ sy(i + 5) = sx(i + 5)
+ sy(i + 6) = sx(i + 6)
+ 50 continue
+ !$acc end kernels
+ return
+
+end subroutine dcopy
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE DAXPY( N, SA, SX, INCX, SY, INCY )
+
+! Y = A*X + Y (X, Y = VECTORS, A = SCALAR)
+
+! --INPUT--
+! N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
+! SA SINGLE PRECISION SCALAR MULTIPLIER 'A'
+! SX SING-PREC ARRAY CONTAINING VECTOR 'X'
+! INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
+! SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
+! INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
+
+! --OUTPUT--
+! SY FOR I = 0 TO N-1, OVERWRITE SY(LY+I*INCY) WITH
+! SA*SX(LX+I*INCX) + SY(LY+I*INCY),
+! WHERE LX = 1 IF INCX .GE. 0,
+! = (-INCX)*N IF INCX .LT. 0
+! AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
+
+ REAL SX(*), SY(*), SA
+
+
+ IF( N.LE.0 .OR. SA.EQ.0.0 ) RETURN
+
+ IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
+
+ DO 10 I = 1, 1+(N-1)*INCX, INCX
+ SY(I) = SY(I) + SA * SX(I)
+ 10 CONTINUE
+
+ ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
+
+! ** EQUAL, UNIT INCREMENTS
+ M = MOD(N,4)
+ IF( M .NE. 0 ) THEN
+! ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
+! ** IS A MULTIPLE OF 4.
+ DO 20 I = 1, M
+ SY(I) = SY(I) + SA * SX(I)
+ 20 CONTINUE
+ ENDIF
+! ** UNROLL LOOP FOR SPEED
+ !$acc kernels
+ DO 30 I = M+1, N, 4
+ SY(I) = SY(I) + SA * SX(I)
+ SY(I+1) = SY(I+1) + SA * SX(I+1)
+ SY(I+2) = SY(I+2) + SA * SX(I+2)
+ SY(I+3) = SY(I+3) + SA * SX(I+3)
+ 30 CONTINUE
+ !$acc end kernels
+
+ ELSE
+! ** NONEQUAL OR NONPOSITIVE INCREMENTS.
+ IX = 1
+ IY = 1
+ IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
+ IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
+ DO 40 I = 1, N
+ SY(IY) = SY(IY) + SA*SX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 40 CONTINUE
+
+ ENDIF
+
+ RETURN
+END SUBROUTINE DAXPY
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE DSCAL( N, SA, SX, INCX )
+
+! CALCULATE X = A*X (X = VECTOR, A = SCALAR)
+
+! --INPUT-- N NUMBER OF ELEMENTS IN VECTOR
+! SA SINGLE PRECISION SCALE FACTOR
+! SX SING-PREC ARRAY, LENGTH 1+(N-1)*INCX, CONTAINING VECTOR
+! INCX SPACING OF VECTOR ELEMENTS IN 'SX'
+
+! --OUTPUT-- SX REPLACE SX(1+I*INCX) WITH SA * SX(1+I*INCX)
+! FOR I = 0 TO N-1
+
+ REAL SA, SX(*)
+
+
+ IF( N.LE.0 ) RETURN
+
+ IF( INCX.NE.1 ) THEN
+
+ DO 10 I = 1, 1+(N-1)*INCX, INCX
+ SX(I) = SA * SX(I)
+ 10 CONTINUE
+
+ ELSE
+
+ M = MOD(N,5)
+ IF( M.NE.0 ) THEN
+! ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
+! ** IS A MULTIPLE OF 5.
+ DO 30 I = 1, M
+ SX(I) = SA * SX(I)
+ 30 CONTINUE
+ ENDIF
+! ** UNROLL LOOP FOR SPEED
+ DO 50 I = M+1, N, 5
+ SX(I) = SA * SX(I)
+ SX(I+1) = SA * SX(I+1)
+ SX(I+2) = SA * SX(I+2)
+ SX(I+3) = SA * SX(I+3)
+ SX(I+4) = SA * SX(I+4)
+ 50 CONTINUE
+
+ ENDIF
+
+ RETURN
+END SUBROUTINE DSCAL
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+FUNCTION DDOT( N, SX, INCX, SY, INCY )
+! ##############################
+
+! S.P. DOT PRODUCT OF VECTORS 'X' AND 'Y'
+
+! --INPUT--
+! N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
+! SX SING-PREC ARRAY CONTAINING VECTOR 'X'
+! INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
+! SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
+! INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
+
+! --OUTPUT--
+! DDOT SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX) * SY(LY+I*INCY),
+! WHERE LX = 1 IF INCX .GE. 0,
+! = (-INCX)*N IF INCX .LT. 0,
+! AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
+
+ IMPLICIT NONE
+ INTEGER N,INCX,INCY
+ REAL SX(*), SY(*)
+ REAL DDOT
+ INTEGER I,M, IX, IY
+
+
+ DDOT = 0.0
+ IF( N.LE.0 ) RETURN
+
+ IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
+
+ DO 10 I = 1, 1+(N-1)*INCX, INCX
+ DDOT = DDOT + SX(I) * SY(I)
+ 10 CONTINUE
+
+ ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
+
+! ** EQUAL, UNIT INCREMENTS
+ M = MOD(N,5)
+ IF( M .NE. 0 ) THEN
+! ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
+! ** IS A MULTIPLE OF 4.
+ DO 20 I = 1, M
+ DDOT = DDOT + SX(I) * SY(I)
+ 20 CONTINUE
+ ENDIF
+! ** UNROLL LOOP FOR SPEED
+ DO 30 I = M+1, N, 5
+ DDOT = DDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) &
+ + SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) &
+ + SX(I+4)*SY(I+4)
+ 30 CONTINUE
+
+ ELSE
+! ** NONEQUAL OR NONPOSITIVE INCREMENTS.
+ IX = 1
+ IY = 1
+ IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
+ IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
+ DO 40 I = 1, N
+ DDOT = DDOT + SX(IX) * SY(IY)
+ IX = IX + INCX
+ IY = IY + INCY
+ 40 CONTINUE
+
+ ENDIF
+
+ RETURN
+END FUNCTION DDOT
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9fa41dd2779aac88d52de2f14bc225b1351e1c0d
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
@@ -0,0 +1,1959 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Discretisation module of the model problem
+!
+!
+! -omega2 * (d^2/dx^2 + d^2/dy^2 + lambda2 * d^2/dz^2 ) u
+! + delta u = RHS
+! [Cartesian]
+!
+! or
+!
+! -omega2 * (laplace_{2d} + lambda2/r^2 d/dr (r^2 d/dr)) u
+! + delta u = RHS
+! [Spherical]
+!
+! We use a cell centered finite volume discretisation with
+! The equation is discretised either in a unit cube or on 1/6th
+! of a cubed sphere grid.
+!
+! The vertical grid spacing is not necessarily uniform and can
+! be chosen by specifying the vertical grid in a vector.
+!
+! The following boundary conditions are used:
+!
+! * Dirichlet in the horizontal
+! * Neumann in the vertical
+!
+! For delta = 0 the operator reduces to the Poisson operator.
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module discretisation
+
+ use parameters
+ use messages
+ use datatypes
+ use communication
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+
+private
+
+ type model_parameters
+ real(kind=rl) :: omega2 ! omega^2
+ real(kind=rl) :: lambda2 ! lambda^2
+ real(kind=rl) :: delta ! delta
+ end type model_parameters
+
+! --- Stencil ---
+!
+
+! Grid traversal direction in SOR
+ integer, parameter :: DIRECTION_FORWARD = 1
+ integer, parameter :: DIRECTION_BACKWARD = 2
+
+! Ordering in SOR
+ ! Lexicographic ordering
+ integer, parameter :: ORDERING_LEX = 1
+ ! Red-black ordering
+ integer, parameter :: ORDERING_RB = 2
+
+ type smoother_parameters
+ ! smoother
+ integer :: smoother
+ ! relaxation parameter
+ real(kind=rl) :: rho
+ ! ordering of degrees of freedom
+ integer :: ordering
+ end type smoother_parameters
+
+ ! Allowed smoothers
+ integer, parameter :: SMOOTHER_LINE_SOR = 3
+ integer, parameter :: SMOOTHER_LINE_SSOR = 4
+ integer, parameter :: SMOOTHER_LINE_JAC = 6
+
+ ! Number of levels
+ integer :: nlev
+
+ ! Grid parameters
+ type(grid_parameters) :: grid_param
+
+ ! Model parameters
+ type(model_parameters) :: model_param
+
+ ! Smoother parameters
+ type(smoother_parameters) :: smoother_param
+
+ ! Arrays for measuring the residual reduction
+ real(kind=rl), allocatable :: log_resreduction(:)
+ integer, allocatable :: nsmooth_total(:)
+
+ ! Data structure for storing the vertical discretisation
+ type vertical_coefficients
+ real(kind=rl), pointer :: a(:)
+ real(kind=rl), pointer :: b(:)
+ real(kind=rl), pointer :: c(:)
+ real(kind=rl), pointer :: d(:)
+ end type vertical_coefficients
+
+ ! Stoarge for vertical coefficients
+ type(vertical_coefficients) :: vert_coeff
+
+public::discretisation_initialise_mnh
+public::discretisation_initialise
+public::discretisation_finalise
+public::smooth_mnh
+public::smooth
+public::line_SOR
+public::line_SSOR
+public::line_jacobi_mnh
+public::line_jacobi
+public::calculate_residual_mnh
+public::calculate_residual
+public::apply_mnh
+public::apply
+public::model_parameters
+public::smoother_parameters
+public::volume_of_element
+public::SMOOTHER_LINE_SOR
+public::SMOOTHER_LINE_SSOR
+public::SMOOTHER_LINE_JAC
+public::DIRECTION_FORWARD
+public::DIRECTION_BACKWARD
+public::ORDERING_LEX
+public::ORDERING_RB
+
+contains
+
+!==================================================================
+! Initialise module
+!==================================================================
+ subroutine discretisation_initialise_mnh(grid_param_in, &
+ model_param_in, &
+ smoother_param_in, &
+ nlev_in, &
+ PA_K,PB_K,PC_K,PD_K)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param_in
+ type(model_parameters), intent(in) :: model_param_in
+ type(smoother_parameters), intent(in) :: smoother_param_in
+ integer, intent(in) :: nlev_in
+ real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+
+ ! local var
+ integer :: k
+
+ grid_param = grid_param_in
+ model_param = model_param_in
+ smoother_param = smoother_param_in
+ nlev = nlev_in
+ allocate(log_resreduction(nlev))
+ allocate(nsmooth_total(nlev))
+ log_resreduction(:) = 0.0_rl
+ nsmooth_total(:) = 0
+ allocate(r_grid(grid_param%nz+1))
+ if (grid_param%graded) then
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)**2
+ end do
+ else
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)
+ end do
+ end if
+ ! Allocate arrays for vertical discretisation matrices
+ ! and calculate matrix entries
+ allocate(vert_coeff%a(grid_param%nz))
+ allocate(vert_coeff%b(grid_param%nz))
+ allocate(vert_coeff%c(grid_param%nz))
+ allocate(vert_coeff%d(grid_param%nz))
+ call construct_vertical_coeff_mnh(PA_K,PB_K,PC_K,PD_K)
+ end subroutine discretisation_initialise_mnh
+
+ subroutine discretisation_initialise(grid_param_in, &
+ model_param_in, &
+ smoother_param_in, &
+ nlev_in)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param_in
+ type(model_parameters), intent(in) :: model_param_in
+ type(smoother_parameters), intent(in) :: smoother_param_in
+ integer, intent(in) :: nlev_in
+ integer :: k
+ grid_param = grid_param_in
+ model_param = model_param_in
+ smoother_param = smoother_param_in
+ nlev = nlev_in
+ allocate(log_resreduction(nlev))
+ allocate(nsmooth_total(nlev))
+ log_resreduction(:) = 0.0_rl
+ nsmooth_total(:) = 0
+ allocate(r_grid(grid_param%nz+1))
+ if (grid_param%graded) then
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)**2
+ end do
+ else
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)
+ end do
+ end if
+#ifdef CARTESIANGEOMETRY
+#else
+ r_grid(:) = 1.0_rl + r_grid(:)
+#endif
+ ! Allocate arrays for vertical discretisation matrices
+ ! and calculate matrix entries
+ allocate(vert_coeff%a(grid_param%nz))
+ allocate(vert_coeff%b(grid_param%nz))
+ allocate(vert_coeff%c(grid_param%nz))
+ allocate(vert_coeff%d(grid_param%nz))
+ call construct_vertical_coeff()
+ end subroutine discretisation_initialise
+
+!==================================================================
+! Finalise module
+!==================================================================
+ subroutine discretisation_finalise()
+ implicit none
+ integer :: level
+ real(kind=rl) :: rho_avg
+#ifdef MEASURESMOOTHINGRATE
+ if (i_am_master_mpi) then
+ write(STDOUT,'("Average smoothing rates:")')
+ do level=nlev,1,-1
+ if (nsmooth_total(level) > 0) then
+ rho_avg = exp(log_resreduction(level)/nsmooth_total(level))
+ else
+ rho_avg = 1.0_rl
+ end if
+ write(STDOUT,'("rho_{avg}(",I3,") = ",E10.4," ( ",I5," x )")') &
+ level, rho_avg, nsmooth_total(level)
+ end do
+ end if
+#endif
+ deallocate(log_resreduction)
+ deallocate(nsmooth_total)
+ deallocate(r_grid)
+ ! Deallocate storage for vertical discretisation matrices
+ deallocate(vert_coeff%a)
+ deallocate(vert_coeff%b)
+ deallocate(vert_coeff%c)
+ deallocate(vert_coeff%d)
+ end subroutine discretisation_finalise
+
+!==================================================================
+! Construct alpha_{i',j'} and |T_{ij}| needed for the
+! horizontal stencil
+! ( alpha_{i+1,j},
+! alpha_{i-1,j},
+! alpha_{i,j+1},
+! alpha_{i,j-1},
+! alpha_{ij})
+! (ix,iy) are LOCAL indices of the grid boxes, which are
+! converted to global indices
+!==================================================================
+ subroutine construct_alpha_T_mnh(grid_param,ix,iy,alpha_T,Tij)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(5) :: alpha_T
+ real(kind=rl), intent(out) :: Tij
+
+ !local var
+ real(kind=rl) :: h, rho_i, sigma_j
+ real(kind=rl) :: xcoef
+ logical :: l2nd
+
+ h = grid_param%L/grid_param%n
+ ! Cartesian coefficients
+ Tij = h**2
+ ! optimisation for newman MNH case = all coef constant
+ alpha_T(1:4) = 1.0_rl
+ alpha_T(5) = 4.0_rl
+ return
+ xcoef = 0.5_rl ! 0.0
+ l2nd = .false. ! .true. ! .false.
+ alpha_T(1) = 1.0
+ alpha_T(2) = 1.0
+ if (ix == grid_param%n) then
+ alpha_T(1) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(2) = 2.0_rl
+ end if
+ if (ix == 1) then
+ alpha_T(2) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(1) = 2.0_rl
+ end if
+ alpha_T(3) = 1.0
+ alpha_T(4) = 1.0
+ if (iy == grid_param%n) then
+ alpha_T(3) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(4) = 2.0
+ end if
+ if (iy == 1) then
+ alpha_T(4) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(3) = 2.0
+ end if
+
+ alpha_T(5) = alpha_T(1) + alpha_T(2) + alpha_T(3) + alpha_T(4)
+ end subroutine construct_alpha_T_mnh
+! constant coef for MNH
+ subroutine construct_alpha_T_cst_mnh(grid_param,alpha_T,Tij)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ real(kind=rl), intent(inout), dimension(5) :: alpha_T
+ real(kind=rl), intent(out) :: Tij
+
+ !local var
+ real(kind=rl) :: h
+
+ h = grid_param%L/grid_param%n
+ ! Cartesian coefficients
+ Tij = h**2
+ ! optimisation for newman MNH case = all coef constant
+ alpha_T(1:4) = 1.0_rl
+ alpha_T(5) = 4.0_rl
+
+ end subroutine construct_alpha_T_cst_mnh
+!==================================================================
+ subroutine construct_alpha_T(grid_param,ix,iy,alpha_T,Tij)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(5) :: alpha_T
+ real(kind=rl), intent(out) :: Tij
+ real(kind=rl) :: h, rho_i, sigma_j
+#ifdef CARTESIANGEOMETRY
+ h = grid_param%L/grid_param%n
+ ! Cartesian coefficients
+ Tij = h**2
+ if (ix == grid_param%n) then
+ alpha_T(1) = 2.0_rl
+ else
+ alpha_T(1) = 1.0_rl
+ end if
+ if (ix == 1) then
+ alpha_T(2) = 2.0_rl
+ else
+ alpha_T(2) = 1.0_rl
+ end if
+ if (iy == grid_param%n) then
+ alpha_T(3) = 2.0_rl
+ else
+ alpha_T(3) = 1.0_rl
+ end if
+ if (iy == 1) then
+ alpha_T(4) = 2.0_rl
+ else
+ alpha_T(4) = 1.0_rl
+ end if
+#else
+ ! Coefficients in cubed sphere geometry
+ ! (rho_i,sigma_j) \in [-1,1] x [-1,1] are the coordinates of the
+ ! cubed sphere segment
+ h = 2.0_rl/grid_param%n
+ Tij = volume_of_element(ix,iy,grid_param)
+ rho_i = 2.0_rl*(1.0_rl*ix-0.5_rl)/grid_param%n-1.0_rl
+ sigma_j = 2.0_rl*(1.0_rl*iy-0.5_rl)/grid_param%n-1.0_rl
+ ! alpha_{i+1,j}
+ if (ix == grid_param%n) then
+ alpha_T(1) = 2.0_rl*DSQRT((1.0_rl+(rho_i+0.25_rl*h)**2)/(1.0_rl+sigma_j**2))
+ else
+ alpha_T(1) = DSQRT((1.0_rl+(rho_i+0.5_rl*h)**2)/(1.0_rl+sigma_j**2))
+ end if
+ ! alpha_{i-1,j}
+ if (ix == 1) then
+ alpha_T(2) = 2.0_rl*DSQRT((1.0_rl+(rho_i-0.25_rl*h)**2)/(1.0_rl+sigma_j**2))
+ else
+ alpha_T(2) = DSQRT((1.0_rl+(rho_i-0.5_rl*h)**2)/(1.0_rl+sigma_j**2))
+ end if
+ ! alpha_{i,j+1}
+ if (iy == grid_param%n) then
+ alpha_T(3) = 2.0_rl*DSQRT((1.0_rl+(sigma_j+0.25_rl*h)**2)/(1.0_rl+rho_i**2))
+ else
+ alpha_T(3) = DSQRT((1.0_rl+(sigma_j+0.5_rl*h)**2)/(1.0_rl+rho_i**2))
+ end if
+ ! alpha_{i,j-1}
+ if (iy == 1) then
+ alpha_T(4) = 2.0_rl*DSQRT((1.0_rl+(sigma_j-0.25_rl*h)**2)/(1.0_rl+rho_i**2))
+ else
+ alpha_T(4) = DSQRT((1.0_rl+(sigma_j-0.5_rl*h)**2)/(1.0_rl+rho_i**2))
+ end if
+#endif
+ alpha_T(5) = alpha_T(1) + alpha_T(2) + alpha_T(3) + alpha_T(4)
+ end subroutine construct_alpha_T
+!==================================================================
+! Construct coefficients of tridiagonal matrix A_T
+! describing the coupling in the vertical direction and the
+! diagonal matrix diag(d)
+!==================================================================
+subroutine construct_vertical_coeff_mnh(PA_K,PB_K,PC_K,PD_K)
+ implicit none
+ real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+ !local var
+ real(kind=rl) :: a_k_tmp, b_k_tmp, c_k_tmp, d_k_tmp
+ real(kind=rl) :: omega2, lambda2, delta, vol_r, surface_k, surface_kp1
+ integer :: k
+
+ IF (.NOT. PRESENT(PA_K)) THEN
+ omega2 = model_param%omega2
+ lambda2 = model_param%lambda2
+ delta = model_param%delta
+ do k = 1, grid_param%nz
+
+ vol_r = r_grid(k+1)-r_grid(k)
+ surface_k = 1.0_rl
+ surface_kp1 = 1.0_rl
+
+ ! Diagonal element
+ a_k_tmp = delta*vol_r
+ ! off diagonal elements
+ ! Boundary conditions
+ ! Top
+ if (k == grid_param%nz) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ b_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_kp1/(r_grid(k+1)-r_grid(k))
+ else
+ b_k_tmp = 0.0_rl
+ end if
+ else
+ b_k_tmp = - 2.0_rl*omega2*lambda2 &
+ * surface_kp1/(r_grid(k+2)-r_grid(k))
+ end if
+ ! Bottom
+ if (k == 1) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ c_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k))
+ else
+ c_k_tmp = 0.0_rl
+ end if
+ else
+ c_k_tmp = - 2.0_rl * omega2 * lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k-1))
+ end if
+ ! Diagonal matrix d_k
+ d_k_tmp = - omega2 * (r_grid(k+1)-r_grid(k))
+ vert_coeff%a(k) = a_k_tmp/d_k_tmp
+ vert_coeff%b(k) = b_k_tmp/d_k_tmp
+ vert_coeff%c(k) = c_k_tmp/d_k_tmp
+ vert_coeff%d(k) = d_k_tmp
+ end do
+ ELSE
+ do k = 1, grid_param%nz
+ vert_coeff%a(k) = PA_K(k)
+ vert_coeff%b(k) = PB_K(k)
+ vert_coeff%c(k) = PC_K(k)
+ vert_coeff%d(k) = PD_K(k)
+ end do
+ ENDIF
+end subroutine construct_vertical_coeff_mnh
+
+subroutine construct_vertical_coeff()
+ implicit none
+ real(kind=rl) :: a_k_tmp, b_k_tmp, c_k_tmp, d_k_tmp
+ real(kind=rl) :: omega2, lambda2, delta, vol_r, surface_k, surface_kp1
+ integer :: k
+ omega2 = model_param%omega2
+ lambda2 = model_param%lambda2
+ delta = model_param%delta
+ do k = 1, grid_param%nz
+#ifdef CARTESIANGEOMETRY
+ vol_r = r_grid(k+1)-r_grid(k)
+ surface_k = 1.0_rl
+ surface_kp1 = 1.0_rl
+#else
+ vol_r = (r_grid(k+1)**3 - r_grid(k)**3)/3.0_rl
+ surface_k = r_grid(k)**2
+ surface_kp1 = r_grid(k+1)**2
+#endif
+ ! Diagonal element
+ a_k_tmp = delta*vol_r
+ ! off diagonal elements
+ ! Boundary conditions
+ ! Top
+ if (k == grid_param%nz) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ b_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_kp1/(r_grid(k+1)-r_grid(k))
+ else
+ b_k_tmp = 0.0_rl
+ end if
+ else
+ b_k_tmp = - 2.0_rl*omega2*lambda2 &
+ * surface_kp1/(r_grid(k+2)-r_grid(k))
+ end if
+ ! Bottom
+ if (k == 1) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ c_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k))
+ else
+ c_k_tmp = 0.0_rl
+ end if
+ else
+ c_k_tmp = - 2.0_rl * omega2 * lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k-1))
+ end if
+ ! Diagonal matrix d_k
+ d_k_tmp = - omega2 * (r_grid(k+1)-r_grid(k))
+ vert_coeff%a(k) = a_k_tmp/d_k_tmp
+ vert_coeff%b(k) = b_k_tmp/d_k_tmp
+ vert_coeff%c(k) = c_k_tmp/d_k_tmp
+ vert_coeff%d(k) = d_k_tmp
+ end do
+end subroutine construct_vertical_coeff
+
+!==================================================================
+! Calculate local residual r = b - A.u
+!==================================================================
+ subroutine calculate_residual_mnh(level,m,b,u,r)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ type(scalar3d), intent(inout) :: r
+ integer :: ix,iy,iz
+ integer :: iib,iie,ijb,ije,ikb,ike
+
+ real , dimension(:,:,:) , pointer :: zr_st , zb_st
+
+ ! r <- A.u
+ !call boundary_mnh(u)
+ call apply_mnh(u,r)
+ ! r <- b - r = b - A.u
+ if (LUseO) then
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ do iz=1,u%grid_param%nz
+ r%s(iz,iy,ix) = b%s(iz,iy,ix) - r%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+!!$ do iz=1,u%grid_param%nz
+!!$ do iy=u%icompy_min,u%icompy_max
+!!$ do ix=u%icompx_min,u%icompx_max
+!!$ r%st(ix,iy,iz) = b%st(ix,iy,iz) - r%st(ix,iy,iz)
+!!$ end do
+!!$ end do
+!!$ end do
+ !-----------------
+ iib=u%icompx_min
+ iie=u%icompx_max
+ ijb=u%icompy_min
+ ije=u%icompy_max
+ ikb=1
+ ike=u%grid_param%nz
+
+ zr_st => r%st
+ zb_st => b%st
+ !$acc kernels
+ zr_st(iib:iie,ijb:ije,ikb:ike) = zb_st(iib:iie,ijb:ije,ikb:ike) - zr_st(iib:iie,ijb:ije,ikb:ike)
+ !$acc end kernels
+ endif
+
+ end subroutine calculate_residual_mnh
+
+ subroutine calculate_residual(level,m,b,u,r)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ type(scalar3d), intent(inout) :: r
+ integer :: ix,iy,iz
+
+
+ ! r <- A.u
+ call apply(u,r)
+ ! r <- b - r = b - A.u
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ do iz=1,u%grid_param%nz
+ r%s(iz,iy,ix) = b%s(iz,iy,ix) - r%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ end subroutine calculate_residual
+
+!==================================================================
+! Apply operator v = A.u
+!==================================================================
+ subroutine apply_mnh(u,v)
+ implicit none
+ type(scalar3d), intent(inout) :: u
+ type(scalar3d), intent(inout) :: v
+
+ ! local var
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: a_k, b_k, c_k, d_k
+ integer :: ix,iy,iz
+ real(kind=rl) :: tmp
+ integer :: iib,iie,ijb,ije
+
+ real(kind=rl), dimension(:,:,:) , pointer :: zv_st , zu_st
+ real(kind=rl), dimension(:) , pointer :: za_k, zb_k, zc_k, zd_k
+ integer :: ii,ij
+ integer :: ize
+
+ call boundary_mnh(u)
+
+ if (LUseO) then
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ ! Construct horizontal part of stencil
+ call construct_alpha_T_mnh(u%grid_param, &
+ ix+u%ix_min-1, &
+ iy+u%iy_min-1, &
+ alpha_T,Tij)
+ do iz=1,u%grid_param%nz
+ a_k = vert_coeff%a(iz)
+ b_k = vert_coeff%b(iz)
+ c_k = vert_coeff%c(iz)
+ d_k = vert_coeff%d(iz)
+ tmp = ((a_k-b_k-c_k)*Tij ) * u%s(iz,iy,ix)
+ if (iz < grid_param%nz) then
+ tmp = tmp + b_k*Tij * u%s(iz+1,iy,ix)
+ end if
+ if (iz > 1) then
+ tmp = tmp + c_k*Tij * u%s(iz-1,iy,ix)
+ end if
+ if ((iz > 1) .and. (iz < grid_param%nz)) then
+ tmp = tmp - alpha_T(5) * u%s(iz, iy ,ix ) &
+ + alpha_T(1) * u%s(iz, iy ,ix+1) &
+ + alpha_T(2) * u%s(iz, iy ,ix-1) &
+ + alpha_T(3) * u%s(iz, iy+1,ix ) &
+ + alpha_T(4) * u%s(iz, iy-1,ix )
+ end if
+ v%s(iz,iy,ix) = d_k*tmp
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+ call construct_alpha_T_cst_mnh(u%grid_param,alpha_T,Tij)
+ !-----------------------------------------------------------
+ iib=u%icompx_min
+ iie=u%icompx_max
+ ijb=u%icompy_min
+ ije=u%icompy_max
+ ize=u%grid_param%nz
+ !
+ zv_st => v%st
+ zu_st => u%st
+ zb_k => vert_coeff%b
+ zc_k => vert_coeff%c
+ zd_k => vert_coeff%d
+
+ !$acc kernels
+ iz=1
+ !$acc loop independent dtype(nvidia) collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zv_st(ii,ij,iz) = zd_k(iz)* ( (-zb_k(iz)-zc_k(iz))*Tij * zu_st(ii,ij,iz ) &
+ +zb_k(iz) *Tij * zu_st(ii,ij,iz+1) )
+ end do
+ end do
+ !
+ do iz=2,ize-1
+ !$acc loop independent dtype(nvidia) collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zv_st(ii,ij,iz) = zd_k(iz)* ( ((-zb_k(iz)-zc_k(iz))*Tij - 4.0_rl ) * zu_st(ii,ij,iz) &
+ +zb_k(iz) *Tij * zu_st(ii,ij,iz+1) &
+ +zc_k(iz) *Tij * zu_st(ii,ij,iz-1) &
+ + zu_st(ii+1,ij,iz) &
+ + zu_st(ii-1,ij,iz) &
+ + zu_st(ii,ij+1,iz) &
+ + zu_st(ii,ij-1,iz) &
+ )
+ end do
+ end do
+ end do
+ !
+ iz=ize
+ !$acc loop independent dtype(nvidia) collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zv_st(ii,ij,iz) = zd_k(iz)* ( (-zb_k(iz)-zc_k(iz))*Tij * zu_st(ii,ij,iz) &
+ +zc_k(iz) *Tij * zu_st(ii,ij,iz-1) )
+ end do
+ end do
+
+ !$acc end kernels
+ endif
+
+ end subroutine apply_mnh
+
+ subroutine apply(u,v)
+ implicit none
+ type(scalar3d), intent(in) :: u
+ type(scalar3d), intent(inout) :: v
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: a_k, b_k, c_k, d_k
+ integer :: ix,iy,iz
+ real(kind=rl) :: tmp
+
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ ! Construct horizontal part of stencil
+ call construct_alpha_T(u%grid_param, &
+ ix+u%ix_min-1, &
+ iy+u%iy_min-1, &
+ alpha_T,Tij)
+ do iz=1,u%grid_param%nz
+ a_k = vert_coeff%a(iz)
+ b_k = vert_coeff%b(iz)
+ c_k = vert_coeff%c(iz)
+ d_k = vert_coeff%d(iz)
+ tmp = ((a_k-b_k-c_k)*Tij - alpha_T(5)) * u%s(iz,iy,ix)
+ if (iz < grid_param%nz) then
+ tmp = tmp + b_k*Tij * u%s(iz+1,iy,ix)
+ end if
+ if (iz > 1) then
+ tmp = tmp + c_k*Tij * u%s(iz-1,iy,ix)
+ end if
+ tmp = tmp + alpha_T(1) * u%s(iz, iy ,ix+1) &
+ + alpha_T(2) * u%s(iz, iy ,ix-1) &
+ + alpha_T(3) * u%s(iz, iy+1,ix ) &
+ + alpha_T(4) * u%s(iz, iy-1,ix )
+ v%s(iz,iy,ix) = d_k*tmp
+ end do
+ end do
+ end do
+ end subroutine apply
+!==================================================================
+!==================================================================
+!
+! S M O O T H E R S
+!
+!==================================================================
+!==================================================================
+
+!==================================================================
+! Perform nsmooth smoother iterations
+!==================================================================
+ subroutine smooth_mnh(level,m,nsmooth,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: nsmooth ! Number of smoothing steps
+ integer, intent(in) :: direction ! Direction
+ type(scalar3d), intent(inout) :: b ! RHS
+ type(scalar3d), intent(inout) :: u ! solution vector
+ integer :: i
+ real(kind=rl) :: log_res_initial, log_res_final
+ type(scalar3d) :: r
+ integer :: halo_size
+ integer :: nlocal, nz
+
+#ifdef MEASURESMOOTHINGRATE
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+ r%isactive = u%isactive
+ r%grid_param = u%grid_param
+ nlocal = r%ix_max-r%ix_min+1
+ halo_size = r%halo_size
+ nz = r%grid_param%nz
+
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ end if
+
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ end if
+
+ call calculate_residual(level,m,b,u,r)
+ log_res_initial = log(l2norm(r))
+#endif
+ ! Carry out nsmooth iterations of the smoother
+ if (smoother_param%smoother == SMOOTHER_LINE_SOR) then
+ do i=1,nsmooth
+ call line_SOR_mnh(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_SSOR) then
+ do i=1,nsmooth
+ call line_SSOR_mnh(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_JAC) then
+ do i=1,nsmooth
+ call line_jacobi_mnh(level,m,b,u)
+ end do
+ end if
+#ifdef MEASURESMOOTHINGRATE
+ call calculate_residual_mnh(level,m,b,u,r)
+ log_res_final = log(l2norm(r))
+ log_resreduction(level) = log_resreduction(level) &
+ + (log_res_final - log_res_initial)
+ nsmooth_total(level) = nsmooth_total(level) + nsmooth
+ if (LUseO) deallocate(r%s)
+ if (LUseT) deallocate(r%st)
+#endif
+ end subroutine smooth_mnh
+!==================================================================
+! Perform nsmooth smoother iterations
+!==================================================================
+ subroutine smooth(level,m,nsmooth,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: nsmooth ! Number of smoothing steps
+ integer, intent(in) :: direction ! Direction
+ type(scalar3d), intent(inout) :: b ! RHS
+ type(scalar3d), intent(inout) :: u ! solution vector
+ integer :: i
+ real(kind=rl) :: log_res_initial, log_res_final
+ type(scalar3d) :: r
+ integer :: halo_size
+ integer :: nlocal, nz
+
+#ifdef MEASURESMOOTHINGRATE
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+ r%isactive = u%isactive
+ r%grid_param = u%grid_param
+ nlocal = r%ix_max-r%ix_min+1
+ halo_size = r%halo_size
+ nz = r%grid_param%nz
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ call calculate_residual(level,m,b,u,r)
+ endif
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ endif
+ log_res_initial = log(l2norm(r))
+#endif
+ ! Carry out nsmooth iterations of the smoother
+ if (smoother_param%smoother == SMOOTHER_LINE_SOR) then
+ do i=1,nsmooth
+ call line_SOR(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_SSOR) then
+ do i=1,nsmooth
+ call line_SSOR(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_JAC) then
+ do i=1,nsmooth
+ call line_jacobi(level,m,b,u)
+ end do
+ end if
+#ifdef MEASURESMOOTHINGRATE
+ call calculate_residual(level,m,b,u,r)
+ log_res_final = log(l2norm(r))
+ log_resreduction(level) = log_resreduction(level) &
+ + (log_res_final - log_res_initial)
+ nsmooth_total(level) = nsmooth_total(level) + nsmooth
+ if (LUseO) deallocate(r%s)
+ if (LUseT) deallocate(r%st)
+#endif
+ end subroutine smooth
+!==================================================================
+! SOR line smoother mnh
+!==================================================================
+ subroutine line_SOR_mnh(level,m,direction,b,u)
+
+ implicit none
+
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+
+ !local Var
+ real(kind=rl), allocatable :: r(:)
+ integer :: nz, nlocal
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ integer :: ixmin(5), ixmax(5), dix
+ integer :: iymin(5), iymax(5), diy
+ integer :: color
+ integer :: nsweeps, isweep
+ integer :: ordering
+ real(kind=rl) :: rho
+ integer, dimension(4) :: send_requests, recv_requests
+ integer, dimension(4) :: send_requestsT, recv_requestsT
+ integer :: tmp, ierr
+ integer :: iblock
+ logical :: overlap_comms
+
+ call boundary_mnh(u)
+
+ ordering = smoother_param%ordering
+ rho = smoother_param%rho
+
+ nz = u%grid_param%nz
+
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+ nlocal = u%ix_max-u%ix_min+1
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+ dix = +1
+ diy = +1
+ color = 1
+ ! When iteration backwards over the grid, reverse the direction
+ if (direction == DIRECTION_BACKWARD) then
+ do iblock = 1, 5
+ tmp = ixmax(iblock)
+ ixmax(iblock) = ixmin(iblock)
+ ixmin(iblock) = tmp
+ tmp = iymax(iblock)
+ iymax(iblock) = iymin(iblock)
+ iymin(iblock) = tmp
+ end do
+ dix = -1
+ diy = -1
+ color = 0
+ end if
+ nsweeps = 1
+ if (ordering == ORDERING_LEX) then
+ nsweeps = 1
+ else if (ordering == ORDERING_RB) then
+ nsweeps = 2
+ end if
+ do isweep = 1, nsweeps
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid_mnh(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap_mnh(level,m,u,send_requests,recv_requests,send_requestsT,recv_requestsT)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid_mnh(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ if (LUseO) call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseO) call mpi_waitall(4,send_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,recv_requestsT, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,send_requestsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap_mnh(level,m,u)
+ end if
+ color = 1-color
+ end do
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ deallocate(utmp)
+
+ contains
+
+ !------------------------------------------------------------------
+ ! Loop over grid, for a given block
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock),dix
+ do iy=iymin(iblock),iymax(iblock),diy
+ if (ordering == ORDERING_RB) then
+ if (mod((ix+u%ix_min)+(iy+u%iy_min),2) .ne. color) cycle
+ end if
+ call apply_tridiag_solve_mnh(ix,iy,r,c,b, &
+ u%s(1:nz,iy ,ix+1), &
+ u%s(1:nz,iy ,ix-1), &
+ u%s(1:nz,iy+1,ix ), &
+ u%s(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add to field with overrelaxation-factor
+ do iz=1,nz
+ u%s(iz,iy,ix) = (1.0_rl-rho)*u%s(iz,iy,ix) + rho*utmp(iz)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do ix=ixmin(iblock),ixmax(iblock),dix
+ do iy=iymin(iblock),iymax(iblock),diy
+ if (ordering == ORDERING_RB) then
+ if (mod((ix+u%ix_min)+(iy+u%iy_min),2) .ne. color) cycle
+ end if
+ call apply_tridiag_solve_mnhT(ix,iy,r,c,b, &
+ u%st(ix+1,iy ,1:nz), &
+ u%st(ix-1,iy ,1:nz), &
+ u%st(ix ,iy+1,1:nz), &
+ u%st(ix ,iy-1,1:nz), &
+ utmp)
+ ! Add to field with overrelaxation-factor
+ do iz=1,nz
+ u%st(ix,iy,iz) = (1.0_rl-rho)*u%st(ix,iy,iz) + rho*utmp(iz)
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine loop_over_grid_mnh
+
+ end subroutine line_SOR_mnh
+!==================================================================
+! SOR line smoother
+!==================================================================
+ subroutine line_SOR(level,m,direction,b,u)
+
+ implicit none
+
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ real(kind=rl), allocatable :: r(:)
+ integer :: nz, nlocal
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ integer :: ixmin(5), ixmax(5), dix
+ integer :: iymin(5), iymax(5), diy
+ integer :: color
+ integer :: nsweeps, isweep
+ integer :: ordering
+ real(kind=rl) :: rho
+ integer, dimension(4) :: send_requests, recv_requests
+ integer :: tmp, ierr
+ integer :: iblock
+ logical :: overlap_comms
+
+ ordering = smoother_param%ordering
+ rho = smoother_param%rho
+
+ nz = u%grid_param%nz
+
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+ nlocal = u%ix_max-u%ix_min+1
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+ dix = +1
+ diy = +1
+ color = 1
+ ! When iteration backwards over the grid, reverse the direction
+ if (direction == DIRECTION_BACKWARD) then
+ do iblock = 1, 5
+ tmp = ixmax(iblock)
+ ixmax(iblock) = ixmin(iblock)
+ ixmin(iblock) = tmp
+ tmp = iymax(iblock)
+ iymax(iblock) = iymin(iblock)
+ iymin(iblock) = tmp
+ end do
+ dix = -1
+ diy = -1
+ color = 0
+ end if
+ nsweeps = 1
+ if (ordering == ORDERING_LEX) then
+ nsweeps = 1
+ else if (ordering == ORDERING_RB) then
+ nsweeps = 2
+ end if
+ do isweep = 1, nsweeps
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap(level,m,u,send_requests,recv_requests)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap(level,m,u)
+ end if
+ color = 1-color
+ end do
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ deallocate(utmp)
+
+ contains
+
+ !------------------------------------------------------------------
+ ! Loop over grid, for a given block
+ !------------------------------------------------------------------
+ subroutine loop_over_grid(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock),dix
+ do iy=iymin(iblock),iymax(iblock),diy
+ if (ordering == ORDERING_RB) then
+ if (mod((ix+u%ix_min)+(iy+u%iy_min),2) .ne. color) cycle
+ end if
+ call apply_tridiag_solve(ix,iy,r,c,b, &
+ u%s(1:nz,iy ,ix+1), &
+ u%s(1:nz,iy ,ix-1), &
+ u%s(1:nz,iy+1,ix ), &
+ u%s(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add to field with overrelaxation-factor
+ do iz=1,nz
+ u%s(iz,iy,ix) = (1.0_rl-rho)*u%s(iz,iy,ix) + rho*utmp(iz)
+ end do
+ end do
+ end do
+ end subroutine loop_over_grid
+
+ end subroutine line_SOR
+
+!==================================================================
+! SSOR line smoother mnh
+!==================================================================
+ subroutine line_SSOR_mnh(level,m,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ if (direction == DIRECTION_FORWARD) then
+ call line_SOR_mnh(level,m,DIRECTION_FORWARD,b,u)
+ call line_SOR_mnh(level,m,DIRECTION_BACKWARD,b,u)
+ else
+ call line_SOR_mnh(level,m,DIRECTION_BACKWARD,b,u)
+ call line_SOR_mnh(level,m,DIRECTION_FORWARD,b,u)
+ end if
+ end subroutine line_SSOR_mnh
+
+!==================================================================
+! SSOR line smoother
+!==================================================================
+ subroutine line_SSOR(level,m,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ if (direction == DIRECTION_FORWARD) then
+ call line_SOR(level,m,DIRECTION_FORWARD,b,u)
+ call line_SOR(level,m,DIRECTION_BACKWARD,b,u)
+ else
+ call line_SOR(level,m,DIRECTION_BACKWARD,b,u)
+ call line_SOR(level,m,DIRECTION_FORWARD,b,u)
+ end if
+ end subroutine line_SSOR
+
+!==================================================================
+! Jacobi line smoother
+!==================================================================
+ subroutine line_Jacobi_mnh(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ real(kind=rl), allocatable :: r(:)
+ integer :: ix,iy,iz, nz
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ real(kind=rl), allocatable :: u0(:,:,:)
+ real(kind=rl), allocatable :: ut0(:,:,:)
+ integer :: nlocal, halo_size
+ real(kind=rl) :: rho
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer, dimension(4) :: send_requestsT, recv_requestsT
+ integer :: ixmin(5), ixmax(5)
+ integer :: iymin(5), iymax(5)
+ integer :: iblock, ierr
+
+ integer :: iib,iie,ijb,ije
+ type(scalar3d) :: Sr,Sc,Sut0,Sutmp
+
+ real , dimension(:,:,:) , pointer :: zSut0_st , zu_st
+
+ call boundary_mnh(u)
+
+ ! Set optimal smoothing parameter on each level
+ !rho = 2.0_rl/(2.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2/(1.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2))
+ rho = smoother_param%rho
+
+ nz = u%grid_param%nz
+ nlocal = u%ix_max -u%ix_min + 1
+ halo_size = u%halo_size
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! Temporary vector
+ if (LUseO) allocate(u0(0:u%grid_param%nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ if (LUseT) allocate(ut0(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+ if (LUseO) u0(:,:,:) = u%s(:,:,:)
+ if (LUseT) then
+ zu_st => u%st
+ !$acc kernels
+ ut0(:,:,:) = zu_st(:,:,:)
+ !$acc end kernels
+ end if
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+ if (LUseT) then
+ allocate(Sr%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+ allocate(Sut0%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+
+ zSut0_st => Sut0%st
+ zu_st => u%st
+
+ !$acc kernels
+ zSut0_st(:,:,:) = zu_st(:,:,:)
+ !$acc end kernels
+
+ allocate(Sutmp%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+
+ endif
+
+ ! Loop over grid
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid_jacobi_mnh(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap_mnh(level,m,u,send_requests,recv_requests,send_requestsT,recv_requestsT)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid_jacobi_mnh(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ if (LUseO) call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseO) call mpi_waitall(4,send_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,recv_requestsT, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,send_requestsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap_mnh(level,m,u)
+ end if
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ if (LUseO) deallocate(u0)
+ if (LUseT) deallocate(ut0)
+ deallocate(utmp)
+ if (LUseT) deallocate(Sr%st,Sut0%st,Sutmp%st)
+
+ contains
+
+ subroutine loop_over_grid_jacobi_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+
+ real , dimension(:,:,:) , pointer :: zu_st , zSutmp_st , zSut0_st
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ call apply_tridiag_solve_mnh(ix,iy,r,c,b, &
+ u0(1:nz,iy ,ix+1), &
+ u0(1:nz,iy ,ix-1), &
+ u0(1:nz,iy+1,ix ), &
+ u0(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add correction
+ do iz=1,nz
+ u%s(iz,iy,ix) = rho*utmp(iz) + (1.0_rl-rho)*u0(iz,iy,ix)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ iib=ixmin(iblock)
+ iie=ixmax(iblock)
+ ijb=iymin(iblock)
+ ije=iymax(iblock)
+
+ zu_st => u%st
+ zSutmp_st => Sutmp%st
+ zSut0_st => Sut0%st
+
+ call apply_tridiag_solve_mnh_allT(iib,iie,ijb,ije,Sr,c,b, &
+ Sut0, &
+ Sutmp )
+ !$acc kernels
+ zu_st(iib:iie,ijb:ije,1:nz) = &
+ rho*zSutmp_st(iib:iie,ijb:ije,1:nz) &
+ + (1.0_rl-rho)*zSut0_st(iib:iie,ijb:ije,1:nz)
+ !$acc end kernels
+ end if
+
+ end subroutine loop_over_grid_jacobi_mnh
+
+end subroutine line_Jacobi_mnh
+!==================================================================
+! Jacobi line smoother
+!==================================================================
+ subroutine line_Jacobi(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ real(kind=rl), allocatable :: r(:)
+ integer :: ix,iy,iz, nz
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ real(kind=rl), allocatable :: u0(:,:,:)
+ integer :: nlocal, halo_size
+ real(kind=rl) :: rho
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer :: ixmin(5), ixmax(5)
+ integer :: iymin(5), iymax(5)
+ integer :: iblock, ierr
+
+ ! Set optimal smoothing parameter on each level
+ rho = 2.0_rl/(2.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2/(1.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2))
+
+ nz = u%grid_param%nz
+ nlocal = u%ix_max -u%ix_min + 1
+ halo_size = u%halo_size
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! Temporary vector
+ allocate(u0(0:u%grid_param%nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ u0(:,:,:) = u%s(:,:,:)
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+
+ ! Loop over grid
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap(level,m,u,send_requests,recv_requests)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap(level,m,u)
+ end if
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ deallocate(u0)
+ deallocate(utmp)
+
+ contains
+
+ subroutine loop_over_grid(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ call apply_tridiag_solve(ix,iy,r,c,b, &
+ u0(1:nz,iy ,ix+1), &
+ u0(1:nz,iy ,ix-1), &
+ u0(1:nz,iy+1,ix ), &
+ u0(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add correction
+ do iz=1,nz
+ u%s(iz,iy,ix) = rho*utmp(iz) + (1.0_rl-rho)*u0(iz,iy,ix)
+ end do
+ end do
+ end do
+ end subroutine loop_over_grid
+
+ end subroutine line_Jacobi
+!==================================================================
+! At a given horizontal position (ix,iy) (local coordinates),
+! calculate
+!
+! u_out = T(ix,iy)^{-1} (b_(ix,iy)
+! - sum_{ix',iy' != ix,iy} A_{(ix,iy),(ix',iy')}*u_in(ix',iy'))
+!
+!==================================================================
+ subroutine apply_tridiag_solve_mnh(ix,iy,r,c,b, &
+ u_in_1, &
+ u_in_2, &
+ u_in_3, &
+ u_in_4, &
+ u_out)
+
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(:) :: r
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(in), dimension(:) :: u_in_1
+ real(kind=rl), intent(in), dimension(:) :: u_in_2
+ real(kind=rl), intent(in), dimension(:) :: u_in_3
+ real(kind=rl), intent(in), dimension(:) :: u_in_4
+ real(kind=rl), intent(inout), dimension(:) :: u_out
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ real(kind=rl) :: xctop_boot
+
+ nz = b%grid_param%nz
+ xctop_boot = 0.0
+
+ call construct_alpha_T_mnh(b%grid_param, &
+ ix+b%ix_min-1, &
+ iy+b%iy_min-1, &
+ alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ !alpha_T(5) = 4
+ if (LUseO) then
+ iz=1
+ r(iz) = b%s(iz,iy,ix)
+ do iz=2,nz-1
+ r(iz) = b%s(iz,iy,ix) - vert_coeff%d(iz) * ( &
+ alpha_T(1) * u_in_1(iz) + &
+ alpha_T(2) * u_in_2(iz) + &
+ alpha_T(3) * u_in_3(iz) + &
+ alpha_T(4) * u_in_4(iz) )
+ end do
+ iz=nz
+ r(iz) = b%s(iz,iy,ix)
+
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (vert_coeff%a(iz)-vert_coeff%b(iz)-vert_coeff%c(iz)) &
+ - xctop_boot*alpha_div_Tij
+ c(iz) = vert_coeff%b(iz)/tmp
+ u_out(iz) = r(iz) / (tmp*Tij*vert_coeff%d(iz))
+ do iz=2,nz-1
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+ iz=nz
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)- xctop_boot*alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+ end if
+ !
+
+ end subroutine apply_tridiag_solve_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! tranpose version
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine apply_tridiag_solve_mnhT(ix,iy,r,c,b, &
+ u_in_1, &
+ u_in_2, &
+ u_in_3, &
+ u_in_4, &
+ u_out)
+
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(:) :: r
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(in), dimension(:) :: u_in_1
+ real(kind=rl), intent(in), dimension(:) :: u_in_2
+ real(kind=rl), intent(in), dimension(:) :: u_in_3
+ real(kind=rl), intent(in), dimension(:) :: u_in_4
+ real(kind=rl), intent(inout), dimension(:) :: u_out
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ real(kind=rl) :: xctop_boot
+
+ nz = b%grid_param%nz
+ xctop_boot = 0.0
+
+ call construct_alpha_T_cst_mnh(b%grid_param,alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ if (LUseT ) then
+ iz=1
+ r(iz) = b%st(ix,iy,iz)
+ do iz=2,nz-1
+ r(iz) = b%st(ix,iy,iz) - vert_coeff%d(iz) * ( &
+ alpha_T(1) * u_in_1(iz) + &
+ alpha_T(2) * u_in_2(iz) + &
+ alpha_T(3) * u_in_3(iz) + &
+ alpha_T(4) * u_in_4(iz) )
+ end do
+ iz=nz
+ r(iz) = b%st(ix,iy,iz)
+
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (vert_coeff%a(iz)-vert_coeff%b(iz)-vert_coeff%c(iz)) &
+ - xctop_boot*alpha_div_Tij
+ c(iz) = vert_coeff%b(iz)/tmp
+ u_out(iz) = r(iz) / (tmp*Tij*vert_coeff%d(iz))
+ do iz=2,nz-1
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+ iz=nz
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)- xctop_boot*alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+ end if
+
+ end subroutine apply_tridiag_solve_mnhT
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! tranpose version all xyz
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine apply_tridiag_solve_mnh_allT(iib,iie,ijb,ije, &
+ Sr,c,b,Su_in,Su_out)
+
+ implicit none
+ integer, intent(in) :: iib,iie,ijb,ije
+ type(scalar3d), intent(inout) :: Sr
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(in) :: Su_in
+ type(scalar3d), intent(inout) :: Su_out
+
+ !local
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ real, dimension(:,:,:) , pointer :: zSr_st , zb_st , zSu_in_st , zSu_out_st
+ real, dimension(:) , pointer :: za_k, zb_k, zc_k, zd_k , tmp_k
+ integer :: ii,ij
+
+ nz = b%grid_param%nz
+
+ call construct_alpha_T_cst_mnh(b%grid_param,alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ if (LUseT ) then
+
+ zSr_st => Sr%st
+ zb_st => b%st
+ zSu_in_st => Su_in%st
+ zSu_out_st => Su_out%st
+ za_k => vert_coeff%a
+ zb_k => vert_coeff%b
+ zc_k => vert_coeff%c
+ zd_k => vert_coeff%d
+ allocate(tmp_k(size(zb_k)))
+
+ !$acc kernels
+ iz=1
+ zSr_st(iib:iie,ijb:ije,iz) = zb_st(iib:iie,ijb:ije,iz)
+ do iz=2,nz-1
+ zSr_st(iib:iie,ijb:ije,iz) = zb_st(iib:iie,ijb:ije,iz) - zd_k(iz) * ( &
+ zSu_in_st(iib+1:iie+1,ijb:ije,iz) + &
+ zSu_in_st(iib-1:iie-1,ijb:ije,iz) + &
+ zSu_in_st(iib:iie,ijb+1:ije+1,iz) + &
+ zSu_in_st(iib:iie,ijb-1:ije-1,iz) )
+ end do
+ iz=nz
+ zSr_st(iib:iie,ijb:ije,iz) = zb_st(iib:iie,ijb:ije,iz)
+
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (za_k(iz)-vert_coeff%b(iz)-vert_coeff%c(iz))
+ c(iz) = vert_coeff%b(iz)/tmp
+ zSu_out_st(iib:iie,ijb:ije,iz) = zSr_st(iib:iie,ijb:ije,iz) / (tmp*Tij*zd_k(iz))
+ !
+ do iz=2,nz-1
+ b_k_tmp = zb_k(iz)
+ c_k_tmp = zc_k(iz)
+ tmp_k(iz) = ((za_k(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp_k(iz)
+ end do
+ do iz=2,nz-1
+ !$acc loop independent collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zSu_out_st(ii,ij,iz) = (zSr_st(ii,ij,iz) / (Tij*zd_k(iz)) &
+ - zSu_out_st(ii,ij,iz-1)*c_k_tmp) / tmp_k(iz)
+ end do
+ end do
+ end do
+ !
+ iz=nz
+ b_k_tmp = zb_k(iz)
+ c_k_tmp = zc_k(iz)
+ tmp = ((za_k(iz)-b_k_tmp-c_k_tmp)) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ zSu_out_st(iib:iie,ijb:ije,iz) = (zSr_st(iib:iie,ijb:ije,iz) / (Tij*zd_k(iz)) &
+ - zSu_out_st(iib:iie,ijb:ije,iz-1)*c_k_tmp) / tmp
+
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ zSu_out_st(iib:iie,ijb:ije,iz) = zSu_out_st(iib:iie,ijb:ije,iz) &
+ - c(iz) * zSu_out_st(iib:iie,ijb:ije,iz+1)
+ end do
+ !$acc end kernels
+
+ deallocate(tmp_k)
+
+ end if
+
+ end subroutine apply_tridiag_solve_mnh_allT
+ !==================================================================
+! At a given horizontal position (ix,iy) (local coordinates),
+! calculate
+!
+! u_out = T(ix,iy)^{-1} (b_(ix,iy)
+! - sum_{ix',iy' != ix,iy} A_{(ix,iy),(ix',iy')}*u_in(ix',iy'))
+!
+!==================================================================
+ subroutine apply_tridiag_solve(ix,iy,r,c,b, &
+ u_in_1, &
+ u_in_2, &
+ u_in_3, &
+ u_in_4, &
+ u_out)
+
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(:) :: r
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(in), dimension(:) :: u_in_1
+ real(kind=rl), intent(in), dimension(:) :: u_in_2
+ real(kind=rl), intent(in), dimension(:) :: u_in_3
+ real(kind=rl), intent(in), dimension(:) :: u_in_4
+ real(kind=rl), intent(inout), dimension(:) :: u_out
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ nz = b%grid_param%nz
+
+ call construct_alpha_T(b%grid_param, &
+ ix+b%ix_min-1, &
+ iy+b%iy_min-1, &
+ alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ !alpha_T(5) = 4.0
+ do iz=1,nz
+ r(iz) = b%s(iz,iy,ix) - vert_coeff%d(iz) * ( &
+ alpha_T(1) * u_in_1(iz) + &
+ alpha_T(2) * u_in_2(iz) + &
+ alpha_T(3) * u_in_3(iz) + &
+ alpha_T(4) * u_in_4(iz) )
+ end do
+ !r(1:nz) = b%s(1:nz,iy,ix)
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (vert_coeff%a(iz)-vert_coeff%b(iz)-vert_coeff%c(iz)) &
+ - alpha_div_Tij
+ c(iz) = vert_coeff%b(iz)/tmp
+ u_out(iz) = r(iz) / (tmp*Tij*vert_coeff%d(iz))
+ do iz=2,nz
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+ end subroutine apply_tridiag_solve
+
+end module discretisation
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/messages.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/messages.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7b4345777a92dcb235e12c456284ecc66b06c980
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/messages.f90
@@ -0,0 +1,104 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Module for error/warning/info messages
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module messages
+
+ use parameters
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+
+contains
+
+!==================================================================
+! Print error message and exit
+!==================================================================
+ subroutine fatalerror(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ integer, parameter :: errorcode = -1
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("FATAL ERROR: ",A)') message
+ end if
+ call mpi_finalize(ierr)
+ STOP
+ end subroutine fatalerror
+
+!==================================================================
+! Print error message
+!==================================================================
+ subroutine error(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("ERROR: ",A)') message
+ end if
+ end subroutine error
+
+!==================================================================
+! Print warning message
+!==================================================================
+ subroutine warning(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("WARNING: ",A)') message
+ end if
+ end subroutine warning
+
+!==================================================================
+! Print info message
+!==================================================================
+ subroutine information(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("INFO: ",A)') message
+ end if
+ end subroutine information
+
+end module messages
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mg_main.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a97d51b494603178c8f34336f074d49d4f8aa8ec
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main.f90
@@ -0,0 +1,85 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Main program for multigrid solver code for Helmholtz/Poisson
+! equation, discretised in the cell centred finite volume scheme
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+!==================================================================
+! Main program
+!==================================================================
+
+program mg_main
+
+ use discretisation
+ use parameters
+ use datatypes
+ use multigrid
+ use conjugategradient
+ use solver
+ use profiles
+ use messages
+ use communication
+ use timer
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ use mode_mg_read_param
+ use mode_mg
+
+ implicit none
+
+ call mg_init()
+
+ ! Initialise ghosts in initial solution, as mg_solve assumes that they
+ ! are up-to-date
+ call haloswap(mg_param%n_lev,pproc,xu_fine)
+
+ ! Solve using multigrid
+ call initialise_timer(t_solve,"t_solve")
+ call start_timer(t_solve)
+ comm_measuretime = .True.
+#ifdef MEASUREHALOSWAP
+ call measurehaloswap()
+#else
+ call mg_solve(xb_fine,xu_fine,solver_param)
+#endif
+ comm_measuretime = .False.
+ call finish_timer(t_solve)
+
+call mg_finalize()
+
+end program mg_main
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mg_main_mnh.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main_mnh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..21999316883d4dcffe25e5fa84fd544f2485a6b7
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main_mnh.f90
@@ -0,0 +1,203 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Main program for multigrid solver code for Helmholtz/Poisson
+! equation, discretised in the cell centred finite volume scheme
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+!==================================================================
+! Main program
+!==================================================================
+
+module mode_mg_main_mnh
+
+ use discretisation
+ use parameters
+ use datatypes
+ use multigrid
+ use conjugategradient
+ use solver
+ use profiles
+ use messages
+ use communication
+ use timer
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ use mode_mg_read_param
+ use mode_mg
+
+contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mg_main_mnh_init(KN,KNZ,PL,PH,PA_K,PB_K,PC_K,PD_K)
+
+ use parameters , only : LMean
+
+ implicit none
+
+ integer , optional , intent (in) :: KN,KNZ
+ real(kind=rl) , optional , intent (in) :: PL,PH
+ real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+
+ call mg_init_mnh(KN,KNZ,PL,PH,PA_K,PB_K,PC_K,PD_K)
+
+ ! Initialise ghosts in initial solution, as mg_solve assumes that they
+ ! are up-to-date
+ call haloswap_mnh(mg_param%n_lev,pproc,xu_fine)
+
+ if (.NOT. PRESENT(KN)) then
+ !
+ ! Force some parameter for Idealized StandAlone Newman Solver until convergence
+ !
+ ! -> Mean must by set to 0 for covergence with Newmann boundaries
+ LMean = .true.
+ ! -> converge up to 1e-10 in 50 iteration
+ solver_param%resreduction = 1.0d-10
+ solver_param%maxiter = 50
+
+ if (i_am_master_mpi) then
+ call flush(STDOUT)
+ write(STDOUT,*)
+ write(STDOUT,*) "!!!!! WARNING mg_main_mnh_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! "
+ write(STDOUT,*) "!!!!! FORCED PARAMETER FOR StandAlone Newman Solver until convergence !!!! "
+ write(STDOUT,*) "!!!!! LMean = " , LMean
+ write(STDOUT,*) "!!!!! solver_param%resreduction = " , solver_param%resreduction
+ write(STDOUT,*) "!!!!! solver_param%maxiter = " , solver_param%maxiter
+ write(STDOUT,*) "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! "
+ write(STDOUT,*)
+ call flush(STDOUT)
+ end if
+ endif
+
+ end subroutine mg_main_mnh_init
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine mg_main_initialise_rhs_mnh(KIB,KIE,KIU,KJB,KJE,KJU,KKU,PY)
+
+implicit none
+
+integer , optional , intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+real(kind=rl) , optional , intent(in) :: PY(:,:,:)
+
+ call initialise_rhs_mnh(grid_param,model_param,xb_fine,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PY)
+ call haloswap_mnh(mg_param%n_lev,pproc,xb_fine)
+
+end subroutine mg_main_initialise_rhs_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine mg_main_initialise_u_mnh(KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+
+implicit none
+
+integer , optional , intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+real(kind=rl) , optional , intent(in) :: PU(:,:,:)
+
+ call initialise_u_mnh(grid_param,model_param,xu_fine,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+ call haloswap_mnh(mg_param%n_lev,pproc,xu_fine)
+
+end subroutine mg_main_initialise_u_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine mg_main_get_u_mnh(KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+
+implicit none
+
+integer , optional , intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+real(kind=rl) , optional , intent(inout) :: PU(:,:,:)
+
+ call get_u_mnh(grid_param,model_param,xu_fine,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+
+end subroutine mg_main_get_u_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine mg_main_mnh_solve()
+
+ implicit none
+
+ ! Solve using multigrid
+ call initialise_timer(t_solve,"t_solve")
+ call start_timer(t_solve)
+ comm_measuretime = .True.
+
+ call mg_solve_mnh(xb_fine,xu_fine,solver_param)
+
+ comm_measuretime = .False.
+ call finish_timer(t_solve)
+
+ end subroutine mg_main_mnh_solve
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mg_main_mnh_finalize()
+
+
+ end subroutine mg_main_mnh_finalize
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mg_main_mnh
+
+ implicit none
+
+ integer :: it
+
+ call mg_main_mnh_init()
+
+ DO it=1,1
+
+ call mg_main_initialise_rhs_mnh()
+ call mg_main_initialise_u_mnh()
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*),'************************ IT=',it,' ***************************'
+ call flush(STDOUT)
+ end if
+
+ call mg_main_mnh_solve()
+
+ ENDDO
+
+ call mg_finalize()
+
+ end subroutine mg_main_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+end module mode_mg_main_mnh
+
+program mg_main_mnh_all
+
+ use mode_mg_main_mnh
+
+ call mg_main_mnh()
+
+end program mg_main_mnh_all
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg.f90
new file mode 100644
index 0000000000000000000000000000000000000000..806825f1b47d9e14c0d528fe57666e2931faeb0e
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg.f90
@@ -0,0 +1,331 @@
+module mode_mg
+
+ use datatypes
+ use communication
+ use discretisation
+ use multigrid
+ use conjugategradient
+ use solver
+ use parameters
+ use timer
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use profiles
+
+ use mode_mg_read_param
+
+implicit none
+
+ type(grid_parameters) :: grid_param
+ type(comm_parameters) :: comm_param
+ type(model_parameters) :: model_param
+ type(smoother_parameters) :: smoother_param
+ type(mg_parameters) :: mg_param
+ type(cg_parameters) :: cg_param
+ type(solver_parameters) :: solver_param
+
+ type(scalar3d) :: xu_fine
+ type(scalar3d) :: xb_fine
+ type(scalar3d) :: xr_fine
+#ifdef TESTCONVERGENCE
+ type(scalar3d) :: uerror
+ real(kind=rl) :: l2error
+#endif
+
+ ! --- Name of executable ---
+ character(len=256) :: executable
+
+ ! --- Parameter file ---
+ character(len=256) :: parameterfile
+
+ ! --- General parameters ---
+ logical :: savefields ! Save fields to disk?
+
+ integer :: i, int_size
+ integer :: i_arg
+ integer :: ierr
+
+ ! Timers
+ type(time) :: t_solve
+ type(time) :: t_readparam
+ type(time) :: t_initialise
+ type(time) :: t_finalise
+
+contains
+
+subroutine mg_init_mnh(KN,KNZ,PL,PH,PA_K,PB_K,PC_K,PD_K)
+
+implicit none
+
+integer , optional , intent (in) :: KN,KNZ
+real(kind=rl) , optional , intent (in) :: PL,PH
+real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+
+! local var
+
+logical :: gisinit
+
+ ! Initialise MPI ...
+ call mpi_initialized(gisinit, ierr )
+ if (.not. gisinit ) then
+ call mpi_init(ierr)
+ end if
+
+ ! ... and pre initialise communication module
+ call comm_preinitialise()
+
+ parameterfile="parameters_mg.nam"
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ write(STDOUT,*) 'Compile time parameters:'
+ write(STDOUT,*) ''
+#ifdef CARTESIANGEOMETRY
+ write(STDOUT,*) ' Geometry: Cartesian'
+#else
+ write(STDOUT,*) ' Geometry: Spherical'
+#endif
+#ifdef USELAPACK
+ write(STDOUT,*) ' Use Lapack: Yes'
+#else
+ write(STDOUT,*) ' Use Lapack: No'
+#endif
+#ifdef OVERLAPCOMMS
+ write(STDOUT,*) ' Overlap communications and calculation: Yes'
+#else
+ write(STDOUT,*) ' Overlap communications and calculation: No'
+#endif
+ write(STDOUT,*) ''
+
+ end if
+
+ ! Initialise timing module
+ call initialise_timing("timing.txt")
+
+ ! Read parameter files
+ call initialise_timer(t_readparam,"t_readparam")
+ call start_timer(t_readparam)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) "Reading parameters from file '" // &
+ trim(parameterfile) // "'"
+ end if
+ call read_general_parameters(parameterfile,savefields)
+ call read_solver_parameters(parameterfile,solver_param)
+ call read_grid_parameters_mnh(parameterfile,grid_param,KN,KNZ,PL,PH)
+ call read_comm_parameters(parameterfile,comm_param)
+ call read_model_parameters(parameterfile,model_param)
+ call read_smoother_parameters(parameterfile,smoother_param)
+ call read_multigrid_parameters(parameterfile,mg_param)
+ call read_conjugategradient_parameters(parameterfile,cg_param)
+ call finish_timer(t_readparam)
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+ ! Initialise discretisation module
+ call discretisation_initialise_mnh(grid_param, &
+ model_param, &
+ smoother_param, &
+ mg_param%n_lev, &
+ PA_K,PB_K,PC_K,PD_K )
+
+ ! Initialise communication module
+ call initialise_timer(t_initialise,"t_initialise")
+ call start_timer(t_initialise)
+ call comm_initialise(mg_param%n_lev, &
+ mg_param%lev_split, &
+ grid_param, &
+ comm_param)
+
+ ! Initialise multigrid
+ call mg_initialise(grid_param, &
+ comm_param, &
+ model_param, &
+ smoother_param, &
+ mg_param, &
+ cg_param &
+ )
+
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xu_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xb_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xr_fine)
+
+!!$ call mg_initialise_rhs_mnh()
+
+ call finish_timer(t_initialise)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+end subroutine mg_init_mnh
+
+subroutine mg_init()
+
+implicit none
+
+ ! Initialise MPI ...
+ call mpi_init(ierr)
+
+ ! ... and pre initialise communication module
+ call comm_preinitialise()
+
+ parameterfile="parameters_mg.nam"
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ write(STDOUT,*) 'Compile time parameters:'
+ write(STDOUT,*) ''
+#ifdef CARTESIANGEOMETRY
+ write(STDOUT,*) ' Geometry: Cartesian'
+#else
+ write(STDOUT,*) ' Geometry: Spherical'
+#endif
+#ifdef USELAPACK
+ write(STDOUT,*) ' Use Lapack: Yes'
+#else
+ write(STDOUT,*) ' Use Lapack: No'
+#endif
+#ifdef OVERLAPCOMMS
+ write(STDOUT,*) ' Overlap communications and calculation: Yes'
+#else
+ write(STDOUT,*) ' Overlap communications and calculation: No'
+#endif
+ write(STDOUT,*) ''
+
+ end if
+
+ ! Initialise timing module
+ call initialise_timing("timing.txt")
+
+ ! Read parameter files
+ call initialise_timer(t_readparam,"t_readparam")
+ call start_timer(t_readparam)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) "Reading parameters from file '" // &
+ trim(parameterfile) // "'"
+ end if
+ call read_general_parameters(parameterfile,savefields)
+ call read_solver_parameters(parameterfile,solver_param)
+ call read_grid_parameters(parameterfile,grid_param)
+ call read_comm_parameters(parameterfile,comm_param)
+ call read_model_parameters(parameterfile,model_param)
+ call read_smoother_parameters(parameterfile,smoother_param)
+ call read_multigrid_parameters(parameterfile,mg_param)
+ call read_conjugategradient_parameters(parameterfile,cg_param)
+ call finish_timer(t_readparam)
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+ ! Initialise discretisation module
+ call discretisation_initialise(grid_param, &
+ model_param, &
+ smoother_param, &
+ mg_param%n_lev )
+
+ ! Initialise communication module
+ call initialise_timer(t_initialise,"t_initialise")
+ call start_timer(t_initialise)
+ call comm_initialise(mg_param%n_lev, &
+ mg_param%lev_split, &
+ grid_param, &
+ comm_param)
+
+ ! Initialise multigrid
+ call mg_initialise(grid_param, &
+ comm_param, &
+ model_param, &
+ smoother_param, &
+ mg_param, &
+ cg_param &
+ )
+
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xu_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xb_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xr_fine)
+ call initialise_rhs(grid_param,model_param,xb_fine)
+#ifdef TESTCONVERGENCE
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,uerror)
+ call analytical_solution(grid_param,uerror)
+#endif
+ call finish_timer(t_initialise)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+end subroutine mg_init
+
+subroutine mg_finalize()
+
+implicit none
+
+#ifdef TESTCONVERGENCE
+ call daxpy_scalar3d(-1.0_rl,xu_fine,uerror)
+ call haloswap(mg_param%n_lev,pproc,uerror)
+ l2error = l2norm(uerror)
+ if (i_am_master_mpi) then
+ write(STDOUT,'("||error|| = ",E20.12," log_2(||error||) = ",E20.12)') &
+ l2error, log(l2error)/log(2.0_rl)
+ end if
+#endif
+
+#ifdef TESTCONVERGENCE
+ if (savefields) then
+ call save_scalar3d(MPI_COMM_HORIZ,uerror,"error")
+ end if
+#endif
+
+ ! Save fields to disk
+ if (savefields) then
+ call haloswap(mg_param%n_lev,pproc,xu_fine)
+ call save_scalar3d(MPI_COMM_HORIZ,xu_fine,"solution")
+ call volscale_scalar3d(xb_fine,1)
+ call calculate_residual(mg_param%n_lev,pproc,xb_fine,xu_fine,xr_fine)
+ call volscale_scalar3d(xb_fine,-1)
+ call volscale_scalar3d(xr_fine,-1)
+ call haloswap(mg_param%n_lev,pproc,xr_fine)
+ call save_scalar3d(MPI_COMM_HORIZ,xr_fine,"residual")
+ end if
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+ call discretisation_finalise()
+
+ ! Finalise
+ call initialise_timer(t_finalise,"t_finalise")
+ call start_timer(t_finalise)
+ call mg_finalise()
+ call cg_finalise()
+ ! Deallocate memory
+ call destroy_scalar3d(xu_fine)
+ call destroy_scalar3d(xb_fine)
+ call destroy_scalar3d(xr_fine)
+#ifdef TESTCONVERGENCE
+ call destroy_scalar3d(uerror)
+#endif
+
+
+ ! Finalise communications ...
+ call comm_finalise(mg_param%n_lev,mg_param%lev_split,grid_param)
+ call finish_timer(t_finalise)
+ call print_timerinfo("# --- Main timing results ---")
+ call print_elapsed(t_readparam,.true.,1.0_rl)
+ call print_elapsed(t_initialise,.true.,1.0_rl)
+ call print_elapsed(t_solve,.true.,1.0_rl)
+ call print_elapsed(t_finalise,.true.,1.0_rl)
+ ! Finalise timing
+ call finalise_timing()
+ ! ... and MPI
+ call mpi_finalize(ierr)
+
+
+end subroutine mg_finalize
+
+end module mode_mg
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg_read_param.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg_read_param.f90
new file mode 100644
index 0000000000000000000000000000000000000000..63c7f5ff7a00cc85146093b2641d84209fb2867d
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg_read_param.f90
@@ -0,0 +1,561 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+module mode_mg_read_param
+
+contains
+
+!==================================================================
+! Read general parameters from namelist file
+!==================================================================
+subroutine read_general_parameters(filename,savefields_out)
+ use parameters
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ logical, intent(out) :: savefields_out
+ integer, parameter :: file_id = 16
+ logical :: savefields
+ integer :: ierr
+ namelist /parameters_general/ savefields
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_general)
+ close(file_id)
+ write(STDOUT,NML=parameters_general)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("General parameters")')
+ write(STDOUT,'(" Save fields = ",L6)') savefields
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(savefields,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ savefields_out = savefields
+end subroutine read_general_parameters
+
+!==================================================================
+! Read solver parameters from namelist file
+!==================================================================
+subroutine read_solver_parameters(filename,solver_param_out)
+ use solver
+ use parameters
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(solver_parameters), intent(out) :: solver_param_out
+ integer :: solvertype
+ real(kind=rl) :: resreduction
+ integer :: maxiter
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_solver/ solvertype,resreduction, maxiter &
+ , LUseO , LUseT , LMean
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_solver)
+ close(file_id)
+ write(STDOUT,NML=parameters_solver)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'(" LMean = ",L8)') LMean
+ write(STDOUT,'(" LUseO = ",L8)') LUseO
+ write(STDOUT,'(" LUseT = ",L8)') LUseT
+ write(STDOUT,'("Solver parameters ")')
+ if (solvertype == SOLVER_RICHARDSON) then
+ write(STDOUT,'(" solver = Richardson")')
+ else if (solvertype == SOLVER_CG) then
+ write(STDOUT,'(" solver = CG")')
+ else
+ call fatalerror("Unknown solver type")
+ end if
+ write(STDOUT,'(" maxiter = ",I8)') maxiter
+ write(STDOUT,'(" resreduction = ",E15.6)') resreduction
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(*,'("")')
+ end if
+ call mpi_bcast(solvertype,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(maxiter,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(resreduction,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(LMean,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(LUseO,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(LUseT,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ solver_param_out%solvertype = solvertype
+ solver_param_out%maxiter = maxiter
+ solver_param_out%resreduction = resreduction
+end subroutine read_solver_parameters
+
+!==================================================================
+! Read grid parameters from namelist file
+!==================================================================
+subroutine read_grid_parameters_mnh(filename,grid_param,KN,KNZ,PL,PH)
+ use parameters
+ use datatypes
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(grid_parameters), intent(out) :: grid_param
+
+ integer , optional , intent (in) :: KN,KNZ
+ real(kind=rl) , optional , intent (in) :: PL,PH
+
+ ! Grid parameters
+ integer :: n, nz
+ real(kind=rl) :: L, H
+ integer :: vertbc
+ logical :: graded
+ integer, parameter :: file_id = 106
+ integer :: ierr
+ namelist /parameters_grid/ n, nz, L, H, vertbc, graded
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_grid)
+ close(file_id)
+
+ if (vertbc == VERTBC_DIRICHLET) then
+ write(STDOUT,'(" vertbc = DIRICHLET")')
+ else if (vertbc == VERTBC_NEUMANN) then
+ write(STDOUT,'(" vertbc = NEUMANN")')
+ else
+ vertbc = -1
+ end if
+ write(STDOUT,'(" graded =",L3)') graded
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(n,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(nz,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(L,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(H,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(vertbc,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(graded,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ IF (PRESENT(KN)) THEN
+ n = KN
+ nz = KNZ
+ L = PL
+ H = PH
+ END IF
+ if (i_am_master_mpi) then
+ write(STDOUT,NML=parameters_grid)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Grid parameters")')
+ write(STDOUT,'(" n = ",I15)') n
+ write(STDOUT,'(" nz = ",I15)') nz
+ write(STDOUT,'(" L = ",E15.6)') L
+ write(STDOUT,'(" H = ",E15.6)') H
+ end if
+ grid_param%n = n
+ grid_param%nz = nz
+ grid_param%L = L
+ grid_param%H = H
+ grid_param%vertbc = vertbc
+ grid_param%graded = graded
+ if (vertbc == -1) then
+ call fatalerror("vertbc has to be either 1 (Dirichlet) or 2 (Neumann)")
+ end if
+end subroutine read_grid_parameters_mnh
+!==================================================================
+! Read grid parameters from namelist file
+!==================================================================
+subroutine read_grid_parameters(filename,grid_param)
+ use parameters
+ use datatypes
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+ character(*), intent(in) :: filename
+ type(grid_parameters), intent(out) :: grid_param
+ ! Grid parameters
+ integer :: n, nz
+ real(kind=rl) :: L, H
+ integer :: vertbc
+ logical :: graded
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_grid/ n, nz, L, H, vertbc, graded
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_grid)
+ close(file_id)
+ write(STDOUT,NML=parameters_grid)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Grid parameters")')
+ write(STDOUT,'(" n = ",I15)') n
+ write(STDOUT,'(" nz = ",I15)') nz
+ write(STDOUT,'(" L = ",E15.6)') L
+ write(STDOUT,'(" H = ",E15.6)') H
+ if (vertbc == VERTBC_DIRICHLET) then
+ write(STDOUT,'(" vertbc = DIRICHLET")')
+ else if (vertbc == VERTBC_NEUMANN) then
+ write(STDOUT,'(" vertbc = NEUMANN")')
+ else
+ vertbc = -1
+ end if
+ write(STDOUT,'(" graded =",L3)') graded
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(n,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(nz,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(L,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(H,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(vertbc,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(graded,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ grid_param%n = n
+ grid_param%nz = nz
+ grid_param%L = L
+ grid_param%H = H
+ grid_param%vertbc = vertbc
+ grid_param%graded = graded
+ if (vertbc == -1) then
+ call fatalerror("vertbc has to be either 1 (Dirichlet) or 2 (Neumann)")
+ end if
+end subroutine read_grid_parameters
+!==================================================================
+! Read parallel communication parameters from namelist file
+!==================================================================
+subroutine read_comm_parameters(filename,comm_param)
+ use parameters
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(comm_parameters), intent(out) :: comm_param
+ ! Grid parameters
+ integer :: halo_size
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_communication/ halo_size
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_communication)
+ close(file_id)
+ write(STDOUT,NML=parameters_communication)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Communication parameters")')
+ write(STDOUT,'(" halosize = ",I3)') halo_size
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ if ( (halo_size .ne. 1) ) then
+ halo_size = -1
+ end if
+ end if
+ call mpi_bcast(halo_size,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ comm_param%halo_size = halo_size
+ if (halo_size == -1) then
+ call fatalerror("Halo size has to be 1.")
+ end if
+end subroutine read_comm_parameters
+
+!==================================================================
+! Read model parameters from namelist file
+!==================================================================
+subroutine read_model_parameters(filename,model_param)
+ use parameters
+ use discretisation
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(model_parameters), intent(out) :: model_param
+ real(kind=rl) :: omega2, lambda2, delta
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_model/ omega2, lambda2, delta
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_model)
+ close(file_id)
+ write(STDOUT,NML=parameters_model)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Model parameters")')
+ write(STDOUT,'(" omega2 = ",E15.6)') omega2
+ write(STDOUT,'(" lambda2 = ",E15.6)') lambda2
+ write(STDOUT,'(" delta = ",E15.6)') delta
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(omega2,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(lambda2,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(delta,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ model_param%omega2 = omega2
+ model_param%lambda2 = lambda2
+ model_param%delta = delta
+end subroutine read_model_parameters
+
+!==================================================================
+! Read smoother parameters from namelist file
+!==================================================================
+subroutine read_smoother_parameters(filename,smoother_param)
+ use parameters
+ use discretisation
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(smoother_parameters), intent(out) :: smoother_param
+ integer, parameter :: file_id = 16
+ integer :: smoother, ordering
+ real(kind=rl) :: rho
+ integer :: ierr
+ namelist /parameters_smoother/ smoother, &
+ ordering, &
+ rho
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_smoother)
+ close(file_id)
+ write(STDOUT,NML=parameters_smoother)
+
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Smoother parameters")')
+ ! Smoother
+ if (smoother == SMOOTHER_LINE_SOR) then
+ write(STDOUT,'(" smoother = LINE_SOR")')
+ else if (smoother == SMOOTHER_LINE_SSOR) then
+ write(STDOUT,'(" smoother = LINE_SSOR")')
+ else if (smoother == SMOOTHER_LINE_JAC) then
+ write(STDOUT,'(" smoother = LINE_JACOBI")')
+ else
+ smoother = -1
+ end if
+
+ if (ordering == ORDERING_LEX) then
+ write(STDOUT,'(" ordering = LEX")')
+ else if (ordering == ORDERING_RB) then
+ write(STDOUT,'(" ordering = RB")')
+ else
+ ordering = -1
+ end if
+ write(STDOUT,'(" rho = ",E15.6)') rho
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(smoother,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(ordering,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(rho,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ smoother_param%smoother = smoother
+ smoother_param%ordering = ordering
+ smoother_param%rho = rho
+ if (smoother == -1) then
+ call fatalerror('Unknown smoother.')
+ end if
+ if (ordering == -1) then
+ call fatalerror('Unknown ordering.')
+ end if
+
+end subroutine read_smoother_parameters
+
+!==================================================================
+! Read multigrid parameters from namelist file
+!==================================================================
+subroutine read_multigrid_parameters(filename,mg_param)
+ use parameters
+ use multigrid
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(mg_parameters), intent(out) :: mg_param
+ integer, parameter :: file_id = 16
+ integer :: verbose, n_lev, lev_split, n_presmooth, n_postsmooth, &
+ prolongation, restriction, n_coarsegridsmooth, &
+ coarsegridsolver
+ integer :: ierr
+ namelist /parameters_multigrid/ verbose, &
+ n_lev, &
+ lev_split, &
+ n_presmooth, &
+ n_postsmooth, &
+ n_coarsegridsmooth, &
+ prolongation, &
+ restriction, &
+ coarsegridsolver
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_multigrid)
+ close(file_id)
+ write(STDOUT,NML=parameters_multigrid)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Multigrid parameters")')
+ write(STDOUT,'(" verbose = ",L6)') verbose
+ write(STDOUT,'(" levels = ",I3)') n_lev
+ write(STDOUT,'(" splitlevel = ",I3)') lev_split
+ write(STDOUT,'(" n_presmooth = ",I6)') n_presmooth
+ write(STDOUT,'(" n_postsmooth = ",I6)') n_postsmooth
+ if (restriction == REST_CELLAVERAGE) then
+ write(STDOUT,'(" restriction = CELLAVERAGE")')
+ else if (restriction == REST_KHALIL) then
+ write(STDOUT,'(" restriction = KHALIL ")')
+ else
+ restriction = -1
+ endif
+ if (prolongation == PROL_CONSTANT) then
+ write(STDOUT,'(" prolongation = CONSTANT")')
+ else if (prolongation == PROL_TRILINEAR) then
+#ifdef PIECEWISELINEAR
+ write(STDOUT,'(" prolongation = TRILINEAR (piecewise linear)")')
+#else
+ write(STDOUT,'(" prolongation = TRILINEAR (regression plane)")')
+#endif
+ else
+ prolongation = -1
+ endif
+ if (coarsegridsolver == COARSEGRIDSOLVER_CG) then
+ write(STDOUT,'(" coarse solver = CG")')
+ else if (coarsegridsolver == COARSEGRIDSOLVER_SMOOTHER) then
+ write(STDOUT,'(" coarse solver = SMOOTHER (",I6," iterations)")') &
+ n_coarsegridsmooth
+ else
+ coarsegridsolver = -1
+ end if
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(*,'("")')
+
+ end if
+ call mpi_bcast(verbose,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_lev,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(lev_split,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_presmooth,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_postsmooth,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_coarsegridsmooth,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD, &
+ ierr)
+ call mpi_bcast(prolongation,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(restriction,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(coarsegridsolver,1,MPI_Integer,master_rank,MPI_COMM_WORLD,ierr)
+ mg_param%verbose = verbose
+ mg_param%n_lev = n_lev
+ mg_param%lev_split = lev_split
+ mg_param%n_presmooth = n_presmooth
+ mg_param%n_postsmooth = n_postsmooth
+ mg_param%n_coarsegridsmooth = n_coarsegridsmooth
+ mg_param%prolongation = prolongation
+ mg_param%restriction = restriction
+ mg_param%coarsegridsolver = coarsegridsolver
+ if (restriction == -1) then
+ call fatalerror('Unknown restriction.')
+ end if
+ if (prolongation == -1) then
+ call fatalerror('Unknown prolongation.')
+ end if
+ if (coarsegridsolver == -1) then
+ call fatalerror('Unknown coarse grid solver.')
+ end if
+end subroutine read_multigrid_parameters
+
+!==================================================================
+! Read conjugate gradient parameters from namelist file
+!==================================================================
+subroutine read_conjugategradient_parameters(filename,cg_param)
+ use parameters
+ use communication
+ use conjugategradient
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(cg_parameters), intent(out) :: cg_param
+ integer, parameter :: file_id = 16
+ integer :: verbose, maxiter, n_prec
+ real(kind=rl) :: resreduction
+ integer :: ierr
+ namelist /parameters_conjugategradient/ verbose, &
+ maxiter, &
+ resreduction, &
+ n_prec
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_conjugategradient)
+ close(file_id)
+ write(STDOUT,NML=parameters_conjugategradient)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Conjugate gradient parameters")')
+ write(STDOUT,'(" verbose = ",I6)') verbose
+ write(STDOUT,'(" maxiter = ",I6)') maxiter
+ write(STDOUT,'(" resreduction = ",E15.6)') resreduction
+ write(STDOUT,'(" n_prec = ",I6)') n_prec
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(verbose,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(maxiter,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(resreduction,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_prec,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ cg_param%verbose = verbose
+ cg_param%maxiter = maxiter
+ cg_param%resreduction = resreduction
+ cg_param%n_prec = n_prec
+end subroutine read_conjugategradient_parameters
+
+end module mode_mg_read_param
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d00404df25f62bc23ed6844d84f92a913cd9ad39
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
@@ -0,0 +1,1892 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Geometric multigrid module for cell centred finite volume
+! discretisation.
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module multigrid
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use parameters
+ use datatypes
+ use discretisation
+ use messages
+ use solver
+ use conjugategradient
+ use communication
+ use timer
+
+ implicit none
+
+public::mg_parameters
+public::mg_initialise
+public::mg_finalise
+public::mg_solve_mnh
+public::mg_solve
+public::measurehaloswap
+public::REST_CELLAVERAGE
+public::REST_KHALIL
+public::PROL_CONSTANT
+public::PROL_TRILINEAR
+public::COARSEGRIDSOLVER_SMOOTHER
+public::COARSEGRIDSOLVER_CG
+
+private
+
+ ! --- multigrid parameter constants ---
+ ! restriction
+ integer, parameter :: REST_CELLAVERAGE = 1
+ integer, parameter :: REST_KHALIL = 2
+ ! prolongation method
+ integer, parameter :: PROL_CONSTANT = 1
+ integer, parameter :: PROL_TRILINEAR = 2
+ ! Coarse grid solver
+ integer, parameter :: COARSEGRIDSOLVER_SMOOTHER = 1
+ integer, parameter :: COARSEGRIDSOLVER_CG = 2
+
+ ! --- Multigrid parameters type ---
+ type mg_parameters
+ ! Verbosity level
+ integer :: verbose
+ ! Number of MG levels
+ integer :: n_lev
+ ! First level where data is pulled together
+ integer :: lev_split
+ ! Number of presmoothing steps
+ integer :: n_presmooth
+ ! Number of postsmoothing steps
+ integer :: n_postsmooth
+ ! Number of smoothing steps on coarsest level
+ integer :: n_coarsegridsmooth
+ ! Prolongation (see PROL_... for allowed values)
+ integer :: prolongation
+ ! Restriction (see RESTR_... for allowed values)
+ integer :: restriction
+ ! Smoother (see SMOOTHER_... for allowed values)
+ integer :: smoother
+ ! Relaxation factor
+ real(kind=rl) :: omega
+ ! Smoother on coarse grid
+ integer :: coarsegridsolver
+ ! ordering of grid points for smoother
+ integer :: ordering
+ end type mg_parameters
+
+! --- Parameters ---
+ type(mg_parameters) :: mg_param
+ type(model_parameters) :: model_param
+ type(smoother_parameters) :: smoother_param
+ type(grid_parameters) :: grid_param
+ type(comm_parameters) :: comm_param
+ type(cg_parameters) :: cg_param
+
+
+! --- Gridded and scalar data structures ---
+ ! Solution vector
+ type(scalar3d), allocatable :: xu_mg(:,:)
+ ! RHS vector
+ type(scalar3d), allocatable :: xb_mg(:,:)
+ ! residual
+ type(scalar3d), allocatable :: xr_mg(:,:)
+
+! --- Timer ---
+ type(time), allocatable, dimension(:,:) :: t_restrict
+ type(time), allocatable, dimension(:,:) :: t_prolongate
+ type(time), allocatable, dimension(:,:) :: t_residual
+ type(time), allocatable, dimension(:,:) :: t_addcorr
+ type(time), allocatable, dimension(:,:) :: t_smooth
+ type(time), allocatable, dimension(:,:) :: t_coarsesolve
+ type(time), allocatable, dimension(:,:) :: t_total
+
+contains
+
+!==================================================================
+! Initialise multigrid module, check and print out out parameters
+!==================================================================
+ subroutine mg_initialise(grid_param_in, & ! Grid parameters
+ comm_param_in, & ! Comm parameters
+ model_param_in, & ! Model parameters
+ smoother_param_in, & ! Smoother parameters
+ mg_param_in, & ! Multigrid parameters
+ cg_param_in & ! CG parameters
+ )
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param_in
+ type(comm_parameters), intent(in) :: comm_param_in
+ type(model_parameters), intent(in) :: model_param_in
+ type(smoother_parameters), intent(in) :: smoother_param_in
+ type(mg_parameters), intent(in) :: mg_param_in
+ type(cg_parameters), intent(in) :: cg_param_in
+ real(kind=rl) :: L, H
+ integer :: n, nz, m, nlocal
+ logical :: reduced_m
+ integer :: level
+ integer :: rank, ierr
+ integer, dimension(2) :: p_horiz
+ integer, parameter :: dim_horiz = 2
+ logical :: grid_active
+ integer :: ix_min, ix_max, iy_min, iy_max
+ integer :: icompx_min, icompx_max, &
+ icompy_min, icompy_max
+ integer :: halo_size
+ integer :: vertbc
+ character(len=32) :: t_label
+
+
+
+ if (i_am_master_mpi) &
+ write(STDOUT,*) '*** Initialising multigrid ***'
+ ! Check that cell counts are valid
+ grid_param = grid_param_in
+ comm_param = comm_param_in
+ mg_param = mg_param_in
+ model_param = model_param_in
+ smoother_param = smoother_param_in
+ cg_param = cg_param_in
+ halo_size = comm_param%halo_size
+ vertbc = grid_param%vertbc
+
+ ! Check parameters
+ if (grid_param%n < 2**(mg_param%n_lev-1) ) then
+ call fatalerror('Number of cells in x-/y- direction has to be at least 2^{n_lev-1}.')
+ endif
+
+ if (mod(grid_param%n,2**(mg_param%n_lev-1)) .ne. 0 ) then
+ call fatalerror('Number of cells in x-/y- direction is not a multiple of 2^{n_lev-1}.')
+ end if
+ if (i_am_master_mpi) &
+ write(STDOUT,*) ''
+
+ ! Allocate memory for timers
+ allocate(t_smooth(mg_param%n_lev,0:pproc))
+ allocate(t_total(mg_param%n_lev,0:pproc))
+ allocate(t_restrict(mg_param%n_lev,0:pproc))
+ allocate(t_residual(mg_param%n_lev,0:pproc))
+ allocate(t_prolongate(mg_param%n_lev,0:pproc))
+ allocate(t_addcorr(mg_param%n_lev,0:pproc))
+ allocate(t_coarsesolve(mg_param%n_lev,0:pproc))
+
+ ! Allocate memory for all levels and initialise fields
+ allocate(xu_mg(mg_param%n_lev,0:pproc))
+ allocate(xb_mg(mg_param%n_lev,0:pproc))
+ allocate(xr_mg(mg_param%n_lev,0:pproc))
+ n = grid_param%n
+ nlocal = n/(2**pproc)
+ nz = grid_param%nz
+ L = grid_param%L
+ H = grid_param%H
+ level = mg_param%n_lev
+ m = pproc
+ reduced_m = .false.
+ ! Work out local processor coordinates (this is necessary to identify
+ ! global coordinates)
+ call mpi_comm_rank(MPI_COMM_HORIZ,rank,ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+ if (i_am_master_mpi) then
+ write(STDOUT, &
+ '(" Global gridsize (x,y,z) (pproc = ",I4," ) : ",I8," x ",I8," x ",I8)') &
+ pproc, n, n, nz
+ end if
+ do while (level > 0)
+ if (i_am_master_mpi) &
+ write(STDOUT, &
+ '(" Local gridsize (x,y,z) on level ",I3," m = ",I4," : ",I8," x ",I8," x ",I8)') &
+ level, m, nlocal, nlocal, nz
+ if (nlocal < 1) then
+ call fatalerror('Number of grid points < 1')
+ end if
+
+ ! Set sizes of computational grid (take care at boundaries)
+ if (p_horiz(1) == 0) then
+ icompy_min = 1
+ else
+ icompy_min = 1 - (halo_size - 1)
+ end if
+
+ if (p_horiz(2) == 0) then
+ icompx_min = 1
+ else
+ icompx_min = 1 - (halo_size - 1)
+ end if
+
+ if (p_horiz(1) == 2**pproc-1) then
+ icompy_max = nlocal
+ else
+ icompy_max = nlocal + (halo_size - 1)
+ end if
+
+ if (p_horiz(2) == 2**pproc-1) then
+ icompx_max = nlocal
+ else
+ icompx_max = nlocal + (halo_size - 1)
+ end if
+
+ ! Allocate data
+ if (LUseO) then
+ allocate(xu_mg(level,m)%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ allocate(xb_mg(level,m)%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ allocate(xr_mg(level,m)%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ xu_mg(level,m)%s(:,:,:) = 0.0_rl
+ xb_mg(level,m)%s(:,:,:) = 0.0_rl
+ xr_mg(level,m)%s(:,:,:) = 0.0_rl
+ endif
+
+ if (LUseT) then
+ allocate(xu_mg(level,m)%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ allocate(xb_mg(level,m)%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ allocate(xr_mg(level,m)%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ xu_mg(level,m)%st(:,:,:) = 0.0_rl
+ xb_mg(level,m)%st(:,:,:) = 0.0_rl
+ xr_mg(level,m)%st(:,:,:) = 0.0_rl
+ endif
+
+ ! NB: 1st coordinate is in the y-direction of the processor grid,
+ ! second coordinate is in the x-direction (see comments in
+ ! communication module)
+ iy_min = (p_horiz(1)/2**(pproc-m))*nlocal+1
+ iy_max = (p_horiz(1)/2**(pproc-m)+1)*nlocal
+ ix_min = p_horiz(2)/2**(pproc-m)*nlocal+1
+ ix_max = (p_horiz(2)/2**(pproc-m)+1)*nlocal
+ ! Set grid parameters and local data ranges
+ ! Note that only n (and possibly nz) change as we
+ ! move down the levels
+ xu_mg(level,m)%grid_param%L = L
+ xu_mg(level,m)%grid_param%H = H
+ xu_mg(level,m)%grid_param%n = n
+ xu_mg(level,m)%grid_param%nz = nz
+ xu_mg(level,m)%grid_param%vertbc = vertbc
+ xu_mg(level,m)%ix_min = ix_min
+ xu_mg(level,m)%ix_max = ix_max
+ xu_mg(level,m)%iy_min = iy_min
+ xu_mg(level,m)%iy_max = iy_max
+ xu_mg(level,m)%icompx_min = icompx_min
+ xu_mg(level,m)%icompx_max = icompx_max
+ xu_mg(level,m)%icompy_min = icompy_min
+ xu_mg(level,m)%icompy_max = icompy_max
+ xu_mg(level,m)%halo_size = halo_size
+
+ xb_mg(level,m)%grid_param%L = L
+ xb_mg(level,m)%grid_param%H = H
+ xb_mg(level,m)%grid_param%n = n
+ xb_mg(level,m)%grid_param%nz = nz
+ xb_mg(level,m)%grid_param%vertbc = vertbc
+ xb_mg(level,m)%ix_min = ix_min
+ xb_mg(level,m)%ix_max = ix_max
+ xb_mg(level,m)%iy_min = iy_min
+ xb_mg(level,m)%iy_max = iy_max
+ xb_mg(level,m)%icompx_min = icompx_min
+ xb_mg(level,m)%icompx_max = icompx_max
+ xb_mg(level,m)%icompy_min = icompy_min
+ xb_mg(level,m)%icompy_max = icompy_max
+ xb_mg(level,m)%halo_size = halo_size
+
+ xr_mg(level,m)%grid_param%L = L
+ xr_mg(level,m)%grid_param%H = H
+ xr_mg(level,m)%grid_param%n = n
+ xr_mg(level,m)%grid_param%nz = nz
+ xr_mg(level,m)%grid_param%vertbc = vertbc
+ xr_mg(level,m)%ix_min = ix_min
+ xr_mg(level,m)%ix_max = ix_max
+ xr_mg(level,m)%iy_min = iy_min
+ xr_mg(level,m)%iy_max = iy_max
+ xr_mg(level,m)%icompx_min = icompx_min
+ xr_mg(level,m)%icompx_max = icompx_max
+ xr_mg(level,m)%icompy_min = icompy_min
+ xr_mg(level,m)%icompy_max = icompy_max
+ xr_mg(level,m)%halo_size = halo_size
+
+ ! Are these grids active?
+ if ( (m == pproc) .or. &
+ ( (mod(p_horiz(1),2**(pproc-m)) == 0) .and. &
+ (mod(p_horiz(2),2**(pproc-m)) == 0) ) ) then
+ grid_active = .true.
+ else
+ grid_active = .false.
+ end if
+ xu_mg(level,m)%isactive = grid_active
+ xb_mg(level,m)%isactive = grid_active
+ xr_mg(level,m)%isactive = grid_active
+ write(t_label,'("t_total(",I3,",",I3,")")') level, m
+ call initialise_timer(t_total(level,m),t_label)
+ write(t_label,'("t_smooth(",I3,",",I3,")")') level, m
+ call initialise_timer(t_smooth(level,m),t_label)
+ write(t_label,'("t_restrict(",I3,",",I3,")")') level, m
+ call initialise_timer(t_restrict(level,m),t_label)
+ write(t_label,'("t_residual(",I3,",",I3,")")') level, m
+ call initialise_timer(t_residual(level,m),t_label)
+ write(t_label,'("t_prolongate(",I3,",",I3,")")') level, m
+ call initialise_timer(t_prolongate(level,m),t_label)
+ write(t_label,'("t_addcorrection(",I3,",",I3,")")') level, m
+ call initialise_timer(t_addcorr(level,m),t_label)
+ write(t_label,'("t_coarsegridsolver(",I3,",",I3,")")') level, m
+ call initialise_timer(t_coarsesolve(level,m),t_label)
+
+ ! If we are below L_split, split data
+ if ( (level .le. mg_param%lev_split) .and. &
+ (m > 0) .and. (.not. reduced_m) ) then
+ reduced_m = .true.
+ m = m-1
+ nlocal = 2*nlocal
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ n = n/2
+ nlocal = nlocal/2
+ end do
+ if (i_am_master_mpi) &
+ write(STDOUT,*) ''
+ call cg_initialise(cg_param)
+ end subroutine mg_initialise
+
+!==================================================================
+! Finalise, free memory for all data structures
+!==================================================================
+ subroutine mg_finalise()
+ implicit none
+ integer :: level, m
+ logical :: reduced_m
+ character(len=80) :: s
+ integer :: ierr
+
+ if (i_am_master_mpi) &
+ write(STDOUT,*) '*** Finalising multigrid ***'
+ ! Deallocate memory
+ level = mg_param%n_lev
+ m = pproc
+ reduced_m = .false.
+ call print_timerinfo("--- V-cycle timing results ---")
+ do while (level > 0)
+ write(s,'("level = ",I3,", m = ",I3)') level,m
+ call print_timerinfo(s)
+ call print_elapsed(t_smooth(level,m),.True.,1.0_rl)
+ call print_elapsed(t_restrict(level,m),.True.,1.0_rl)
+ call print_elapsed(t_prolongate(level,m),.True.,1.0_rl)
+ call print_elapsed(t_residual(level,m),.True.,1.0_rl)
+ call print_elapsed(t_addcorr(level,m),.True.,1.0_rl)
+ call print_elapsed(t_coarsesolve(level,m),.True.,1.0_rl)
+ call print_elapsed(t_total(level,m),.True.,1.0_rl)
+
+ if (LUseO) then
+ deallocate(xu_mg(level,m)%s)
+ deallocate(xb_mg(level,m)%s)
+ deallocate(xr_mg(level,m)%s)
+ endif
+
+ if (LUseT) then
+ deallocate(xu_mg(level,m)%st)
+ deallocate(xb_mg(level,m)%st)
+ deallocate(xr_mg(level,m)%st)
+ endif
+
+ ! If we are below L_split, split data
+ if ( (level .le. mg_param%lev_split) .and. &
+ (m > 0) .and. (.not. reduced_m) ) then
+ reduced_m = .true.
+ m = m-1
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ end do
+ deallocate(xu_mg)
+ deallocate(xb_mg)
+ deallocate(xr_mg)
+ deallocate(t_total)
+ deallocate(t_smooth)
+ deallocate(t_restrict)
+ deallocate(t_prolongate)
+ deallocate(t_residual)
+ deallocate(t_addcorr)
+ deallocate(t_coarsesolve)
+ if (i_am_master_mpi) write(STDOUT,'("")')
+ end subroutine mg_finalise
+
+!==================================================================
+! Restrict from fine -> coarse
+!==================================================================
+ subroutine restrict_mnh(phifine,phicoarse)
+ implicit none
+ type(scalar3d), intent(in) :: phifine
+ type(scalar3d), intent(inout) :: phicoarse
+ ! local var
+ integer :: ix,iy,iz
+ integer :: ix_min, ix_max, iy_min, iy_max, n
+ real(kind=rl) :: xn,xs,xw,xe
+
+ real , dimension(:,:,:) , pointer :: zphifine_st , zphicoarse_st
+
+ n = phicoarse%grid_param%n
+ ix_min = phicoarse%icompx_min
+ ix_max = phicoarse%icompx_max
+ iy_min = phicoarse%icompy_min
+ iy_max = phicoarse%icompy_max
+ ! three dimensional cell average
+ if (mg_param%restriction == REST_CELLAVERAGE) then
+ ! Do not coarsen in z-direction
+ if (LUseO) then
+ do ix=ix_min,ix_max
+ do iy=iy_min,iy_max
+ do iz=1,phicoarse%grid_param%nz
+ phicoarse%s(iz,iy,ix) = &
+ phifine%s(iz ,2*iy ,2*ix ) + &
+ phifine%s(iz ,2*iy-1,2*ix ) + &
+ phifine%s(iz ,2*iy ,2*ix-1) + &
+ phifine%s(iz ,2*iy-1,2*ix-1)
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+ zphifine_st => phifine%st
+ zphicoarse_st => phicoarse%st
+ !$acc kernels loop independent dtype(nvidia) collapse(3)
+ do iz=1,phicoarse%grid_param%nz
+ do iy=iy_min,iy_max
+ do ix=ix_min,ix_max
+ zphicoarse_st(ix,iy,iz) = &
+ zphifine_st(2*ix ,2*iy ,iz) + &
+ zphifine_st(2*ix ,2*iy-1,iz) + &
+ zphifine_st(2*ix-1,2*iy ,iz) + &
+ zphifine_st(2*ix-1,2*iy-1,iz)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ endif
+
+ elseif(mg_param%restriction == REST_KHALIL) then
+ if (LUseO) then
+ do ix=ix_min,ix_max
+ xw=1.0
+ xe=1.0
+ if (ix==1) xw=0.0
+ if (ix==n) xe=0.0
+ do iy=iy_min,iy_max
+ xs=1.0
+ xn=1.0
+ if (iy==1) xs=0.0
+ if (iy==n) xn=0.0
+ do iz=1,phicoarse%grid_param%nz
+ phicoarse%s(iz,iy,ix) = 0.25_rl * ( &
+ phifine%s(iz,2*iy+1,2*ix-1) * xn + &
+ phifine%s(iz,2*iy+1,2*ix ) * xn + &
+ phifine%s(iz,2*iy ,2*ix-2) * xw + &
+ phifine%s(iz,2*iy ,2*ix-1) * (4-xw-xn) + &
+ phifine%s(iz,2*iy ,2*ix ) * (4-xe-xn) + &
+ phifine%s(iz,2*iy ,2*ix+1) * xe + &
+ phifine%s(iz,2*iy-1,2*ix-2) * xw + &
+ phifine%s(iz,2*iy-1,2*ix-1) * (4-xw-xs) + &
+ phifine%s(iz,2*iy-1,2*ix ) * (4-xe-xs) + &
+ phifine%s(iz,2*iy-2,2*ix-1) * xs + &
+ phifine%s(iz,2*iy-2,2*ix ) * xs &
+ & )
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do iz=1,phicoarse%grid_param%nz
+ do iy=iy_min,iy_max
+ xs=1.0
+ xn=1.0
+ if (iy==1) xs=0.0
+ if (iy==n) xn=0.0
+ do ix=ix_min,ix_max
+ xw=1.0
+ xe=1.0
+ if (ix==1) xw=0.0
+ if (ix==n) xe=0.0
+ phicoarse%st(ix,iy,iz) = 0.25_rl * ( &
+ phifine%s(2*ix-1,2*iy+1,iz) * xn + &
+ phifine%s(2*ix ,2*iy+1,iz) * xn + &
+ phifine%s(2*ix-2,2*iy ,iz) * xw + &
+ phifine%s(2*ix-1,2*iy ,iz) * (4-xw-xn) + &
+ phifine%s(2*ix ,2*iy ,iz) * (4-xe-xn) + &
+ phifine%s(2*ix+1,2*iy ,iz) * xe + &
+ phifine%s(2*ix-2,2*iy-1,iz) * xw + &
+ phifine%s(2*ix-1,2*iy-1,iz) * (4-xw-xs) + &
+ phifine%s(2*ix ,2*iy-1,iz) * (4-xe-xs) + &
+ phifine%s(2*ix-1,2*iy-2,iz) * xs + &
+ phifine%s(2*ix ,2*iy-2,iz) * xs &
+ & )
+ end do
+ end do
+ end do
+ end if
+
+ end if
+ end subroutine restrict_mnh
+!==================================================================
+! Restrict from fine -> coarse
+!==================================================================
+ subroutine restrict(phifine,phicoarse)
+ implicit none
+ type(scalar3d), intent(in) :: phifine
+ type(scalar3d), intent(inout) :: phicoarse
+ integer :: ix,iy,iz
+ integer :: ix_min, ix_max, iy_min, iy_max
+
+ ix_min = phicoarse%icompx_min
+ ix_max = phicoarse%icompx_max
+ iy_min = phicoarse%icompy_min
+ iy_max = phicoarse%icompy_max
+ ! three dimensional cell average
+ if (mg_param%restriction == REST_CELLAVERAGE) then
+ ! Do not coarsen in z-direction
+ if (LUseO) then
+ do ix=ix_min,ix_max
+ do iy=iy_min,iy_max
+ do iz=1,phicoarse%grid_param%nz
+ phicoarse%s(iz,iy,ix) = &
+ phifine%s(iz ,2*iy ,2*ix ) + &
+ phifine%s(iz ,2*iy-1,2*ix ) + &
+ phifine%s(iz ,2*iy ,2*ix-1) + &
+ phifine%s(iz ,2*iy-1,2*ix-1)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do iz=1,phicoarse%grid_param%nz
+ do iy=iy_min,iy_max
+ do ix=ix_min,ix_max
+ phicoarse%st(ix,iy,iz) = &
+ phifine%st(2*ix ,2*iy ,iz) + &
+ phifine%st(2*ix ,2*iy-1,iz) + &
+ phifine%st(2*ix-1,2*iy ,iz) + &
+ phifine%st(2*ix-1,2*iy-1,iz)
+ end do
+ end do
+ end do
+ endif
+ end if
+ end subroutine restrict
+!==================================================================
+! Prolongate from coarse -> fine
+! level, m is the correspong to the fine grid level
+!==================================================================
+ subroutine prolongate_mnh(level,m,phicoarse,phifine)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: phicoarse
+ type(scalar3d), intent(inout) :: phifine
+ real(kind=rl) :: tmp
+ integer :: nlocal
+ integer, dimension(5) :: ixmin, ixmax, iymin, iymax
+ integer :: n, nz
+ integer :: ix, iy, iz
+ integer :: dix, diy, diz
+ real(kind=rl) :: rhox, rhoy, rhoz
+ real(kind=rl) :: rho_i, sigma_j, h, c1, c2
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer, dimension(4) :: send_requestsT, recv_requestsT
+ integer :: ierr
+ integer :: iblock
+
+ ! Needed for interpolation matrix
+#ifdef PIECEWISELINEAR
+#else
+ real(kind=rl) :: dx(4,3), A(3,3), dx_fine(4,2)
+ integer :: i,j,k
+ real(kind=rl) :: dxu(2), grad(2)
+ dx(1,3) = 1.0_rl
+ dx(2,3) = 1.0_rl
+ dx(3,3) = 1.0_rl
+ dx(4,3) = 1.0_rl
+#endif
+
+ nlocal = phicoarse%ix_max-phicoarse%ix_min+1
+ n = phicoarse%grid_param%n
+ nz = phicoarse%grid_param%nz
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! *** Constant prolongation or (tri-) linear prolongation ***
+ if ( (mg_param%prolongation == PROL_CONSTANT) .or. &
+ (mg_param%prolongation == PROL_TRILINEAR) ) then
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant_mnh(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear_mnh(iblock)
+ end if
+ end do
+ ! Initiate halo exchange
+ call ihaloswap_mnh(level,m,phifine,send_requests,recv_requests,send_requestsT,recv_requestsT)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant_mnh(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear_mnh(iblock)
+ end if
+ if (overlap_comms) then
+ if (m > 0) then
+ if (LUseO) call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseO) call mpi_waitall(4,send_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,recv_requestsT, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,send_requestsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap_mnh(level,m,phifine)
+ end if
+ else
+ call fatalerror("Unsupported prolongation.")
+ end if
+
+ contains
+
+ !------------------------------------------------------------------
+ ! The actual loops over the grid for the individual blocks,
+ ! when overlapping calculation and communication
+ !------------------------------------------------------------------
+
+ !------------------------------------------------------------------
+ ! (1) Constant interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_constant_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ do dix = -1,0
+ do diy = -1,0
+ do iz=1,phicoarse%grid_param%nz
+ phifine%s(iz,2*iy+diy,2*ix+dix) = phicoarse%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ do dix = -1,0
+ do diy = -1,0
+ do iz=1,phicoarse%grid_param%nz
+ phifine%st(2*ix+dix,2*iy+diy,iz) = phicoarse%st(ix,iy,iz)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine loop_over_grid_constant_mnh
+
+ !------------------------------------------------------------------
+ ! (2) Linear interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_linear_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ !local var
+ integer :: ix,iy,iz
+
+ real , dimension(:,:,:) , pointer :: zphifine_st , zphicoarse_st
+
+ ! optimisation for newman MNH case : all coef constant
+ rhox = 0.25_rl
+ rhoy = 0.25_rl
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ ! Piecewise linear interpolation
+ do iz=1,phicoarse%grid_param%nz
+ do dix = -1,0
+ do diy = -1,0
+ phifine%s(iz,2*iy+diy,2*ix+dix) = &
+ phicoarse%s(iz,iy,ix) + &
+ rhox*(phicoarse%s(iz,iy,ix+(2*dix+1)) &
+ - phicoarse%s(iz,iy,ix)) + &
+ rhoy*(phicoarse%s(iz,iy+(2*diy+1),ix) &
+ - phicoarse%s(iz,iy,ix))
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ ! Piecewise linear interpolation
+
+ zphifine_st => phifine%st
+ zphicoarse_st => phicoarse%st
+
+ !$acc kernels loop independent dtype(nvidia) collapse(5)
+ do iz=1,phicoarse%grid_param%nz
+ do diy = -1,0
+ do dix = -1,0
+ do iy=iymin(iblock),iymax(iblock)
+ do ix=ixmin(iblock),ixmax(iblock)
+ zphifine_st(2*ix+dix,2*iy+diy,iz) = &
+ zphicoarse_st(ix,iy,iz) + &
+ rhox*(zphicoarse_st(ix+(2*dix+1),iy,iz) &
+ - zphicoarse_st(ix,iy,iz)) + &
+ rhoy*(zphicoarse_st(ix,iy+(2*diy+1),iz) &
+ - zphicoarse_st(ix,iy,iz))
+ end do
+ end do
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+
+ end subroutine loop_over_grid_linear_mnh
+
+ end subroutine prolongate_mnh
+!==================================================================
+! Prolongate from coarse -> fine
+! level, m is the correspong to the fine grid level
+!==================================================================
+ subroutine prolongate(level,m,phicoarse,phifine)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: phicoarse
+ type(scalar3d), intent(inout) :: phifine
+ real(kind=rl) :: tmp
+ integer :: nlocal
+ integer, dimension(5) :: ixmin, ixmax, iymin, iymax
+ integer :: n, nz
+ integer :: ix, iy, iz
+ integer :: dix, diy, diz
+ real(kind=rl) :: rhox, rhoy, rhoz
+ real(kind=rl) :: rho_i, sigma_j, h, c1, c2
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer :: ierr
+ integer :: iblock
+
+ ! Needed for interpolation matrix
+#ifdef PIECEWISELINEAR
+#else
+ real(kind=rl) :: dx(4,3), A(3,3), dx_fine(4,2)
+ integer :: i,j,k
+ real(kind=rl) :: dxu(2), grad(2)
+ dx(1,3) = 1.0_rl
+ dx(2,3) = 1.0_rl
+ dx(3,3) = 1.0_rl
+ dx(4,3) = 1.0_rl
+#endif
+
+ nlocal = phicoarse%ix_max-phicoarse%ix_min+1
+ n = phicoarse%grid_param%n
+ nz = phicoarse%grid_param%nz
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! *** Constant prolongation or (tri-) linear prolongation ***
+ if ( (mg_param%prolongation == PROL_CONSTANT) .or. &
+ (mg_param%prolongation == PROL_TRILINEAR) ) then
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear(iblock)
+ end if
+ end do
+ ! Initiate halo exchange
+ call ihaloswap(level,m,phifine,send_requests,recv_requests)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear(iblock)
+ end if
+ if (overlap_comms) then
+ if (m > 0) then
+ call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap(level,m,phifine)
+ end if
+ else
+ call fatalerror("Unsupported prolongation.")
+ end if
+
+ contains
+
+ !------------------------------------------------------------------
+ ! The actual loops over the grid for the individual blocks,
+ ! when overlapping calculation and communication
+ !------------------------------------------------------------------
+
+ !------------------------------------------------------------------
+ ! (1) Constant interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_constant(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ do dix = -1,0
+ do diy = -1,0
+ do iz=1,phicoarse%grid_param%nz
+ phifine%s(iz,2*iy+diy,2*ix+dix) = phicoarse%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end subroutine loop_over_grid_constant
+
+ !------------------------------------------------------------------
+ ! (2) Linear interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_linear(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+#ifdef PIECEWISELINEAR
+ ! Piecewise linear interpolation
+ do iz=1,phicoarse%grid_param%nz
+ do dix = -1,0
+ do diy = -1,0
+ if ( (ix+(2*dix+1)+phicoarse%ix_min-1 < 1 ) .or. &
+ (ix+(2*dix+1)+phicoarse%ix_min-1 > n ) ) then
+ rhox = 0.5_rl
+ else
+ rhox = 0.25_rl
+ end if
+ if ( (iy+(2*diy+1)+phicoarse%iy_min-1 < 1 ) .or. &
+ (iy+(2*diy+1)+phicoarse%iy_min-1 > n ) ) then
+ rhoy = 0.5_rl
+ else
+ rhoy = 0.25_rl
+ end if
+ phifine%s(iz,2*iy+diy,2*ix+dix) = &
+ phicoarse%s(iz,iy,ix) + &
+ rhox*(phicoarse%s(iz,iy,ix+(2*dix+1)) &
+ - phicoarse%s(iz,iy,ix)) + &
+ rhoy*(phicoarse%s(iz,iy+(2*diy+1),ix) &
+ - phicoarse%s(iz,iy,ix))
+ end do
+ end do
+ end do
+#else
+ ! Fit a plane through the four neighbours of each
+ ! coarse grid point. Use the gradient of this plane and
+ ! the value of the field on the coarse grid point for
+ ! the linear interpolation
+ ! Calculate the displacement vectors
+#ifdef CARTESIANGEOMETRY
+ ! (ix-1, iy)
+ dx(1,1) = -1.0_rl
+ dx(1,2) = 0.0_rl
+ ! (ix+1, iy)
+ dx(2,1) = +1.0_rl
+ dx(2,2) = 0.0_rl
+ ! (ix, iy-1)
+ dx(3,1) = 0.0_rl
+ dx(3,2) = -1.0_rl
+ ! (ix, iy+1)
+ dx(4,1) = 0.0_rl
+ dx(4,2) = +1.0_rl
+#else
+ rho_i = 2.0_rl*(ix+(phicoarse%ix_min-1)-0.5_rl)/n-1.0_rl
+ sigma_j = 2.0_rl*(iy+(phicoarse%iy_min-1)-0.5_rl)/n-1.0_rl
+ if (abs(rho_i**2+sigma_j**2) > 1.0E-12) then
+ c1 = (1.0_rl+rho_i**2+sigma_j**2)/sqrt(rho_i**2+sigma_j**2)
+ c2 = sqrt(1.0_rl+rho_i**2+sigma_j**2)/sqrt(rho_i**2+sigma_j**2)
+ else
+ rho_i = 1.0_rl
+ sigma_j = 1.0_rl
+ c1 = sqrt(0.5_rl)
+ c2 = sqrt(0.5_rl)
+ end if
+ ! (ix-1, iy)
+ dx(1,1) = -c1*rho_i
+ dx(1,2) = +c2*sigma_j
+ ! (ix+1, iy)
+ dx(2,1) = +c1*rho_i
+ dx(2,2) = -c2*sigma_j
+ ! (ix, iy-1)
+ dx(3,1) = -c1*sigma_j
+ dx(3,2) = -c2*rho_i
+ ! (ix, iy+1)
+ dx(4,1) = +c1*sigma_j
+ dx(4,2) = +c2*rho_i
+ dx_fine(1,1) = 0.25_rl*(dx(1,1)+dx(3,1))
+ dx_fine(1,2) = 0.25_rl*(dx(1,2)+dx(3,2))
+ dx_fine(2,1) = 0.25_rl*(dx(2,1)+dx(3,1))
+ dx_fine(2,2) = 0.25_rl*(dx(2,2)+dx(3,2))
+ dx_fine(3,1) = 0.25_rl*(dx(1,1)+dx(4,1))
+ dx_fine(3,2) = 0.25_rl*(dx(1,2)+dx(4,2))
+ dx_fine(4,1) = 0.25_rl*(dx(2,1)+dx(4,1))
+ dx_fine(4,2) = 0.25_rl*(dx(2,2)+dx(4,2))
+#endif
+ ! Boundaries
+ if (ix-1+phicoarse%ix_min-1 < 1 ) then
+ dx(1,1) = 0.5_rl*dx(1,1)
+ dx(1,2) = 0.5_rl*dx(1,2)
+ end if
+ if (ix+1+phicoarse%ix_min-1 > n ) then
+ dx(2,1) = 0.5_rl*dx(2,1)
+ dx(2,2) = 0.5_rl*dx(2,2)
+ end if
+ if (iy-1+phicoarse%iy_min-1 < 1 ) then
+ dx(3,1) = 0.5_rl*dx(3,1)
+ dx(3,2) = 0.5_rl*dx(3,2)
+ end if
+ if (iy+1+phicoarse%iy_min-1 > n ) then
+ dx(4,1) = 0.5_rl*dx(4,1)
+ dx(4,2) = 0.5_rl*dx(4,2)
+ end if
+ ! Calculate matrix used for least squares linear fit
+ A(:,:) = 0.0_rl
+ do i = 1,4
+ do j=1,3
+ do k=1,3
+ A(j,k) = A(j,k) + dx(i,j)*dx(i,k)
+ end do
+ end do
+ end do
+ ! invert A
+ call invertA(A)
+ do iz=1,phicoarse%grid_param%nz
+ ! Calculate gradient on each level
+ dxu(1:2) = dx(1,1:2)*phicoarse%s(iz,iy ,ix-1) &
+ + dx(2,1:2)*phicoarse%s(iz,iy ,ix+1) &
+ + dx(3,1:2)*phicoarse%s(iz,iy-1,ix ) &
+ + dx(4,1:2)*phicoarse%s(iz,iy+1,ix )
+ grad(:) = 0.0_rl
+ do j=1,2
+ do k=1,2
+ grad(j) = grad(j) + A(j,k)*dxu(k)
+ end do
+ end do
+ ! Use the gradient and the field value in the centre of
+ ! the coarse grid cell to interpolate to the fine grid
+ ! cells
+#ifdef CARTESIANGEOMETRY
+ do dix=-1,0
+ do diy=-1,0
+ phifine%s(iz,2*iy+diy,2*ix+dix) = &
+ phicoarse%s(iz,iy,ix) &
+ + 0.25_rl*( grad(1)*(2.0*dix+1) &
+ + grad(2)*(2.0*diy+1))
+ end do
+ end do
+#else
+ phifine%s(iz,2*iy-1, 2*ix-1) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(1,1) + &
+ grad(2)*dx_fine(1,2) )
+ phifine%s(iz,2*iy-1, 2*ix ) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(2,1) + &
+ grad(2)*dx_fine(2,2) )
+ phifine%s(iz,2*iy , 2*ix-1) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(3,1) + &
+ grad(2)*dx_fine(3,2) )
+ phifine%s(iz,2*iy , 2*ix ) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(4,1) + &
+ grad(2)*dx_fine(4,2) )
+#endif
+ end do
+#endif
+ end do
+ end do
+ end subroutine loop_over_grid_linear
+
+ end subroutine prolongate
+ !------------------------------------------------------------------
+ ! Invert the 3x3 matrix A either using LaPack or the explicit
+ ! formula
+ !------------------------------------------------------------------
+ subroutine invertA(A)
+ implicit none
+ real(kind=rl), intent(inout), dimension(3,3) :: A
+ real(kind=rl), dimension(3,3) :: Anew
+ real(kind=rl) :: invdetA
+ integer :: ipiv(3), info
+ real(kind=rl) :: work(3)
+#ifdef USELAPACK
+ call DGETRF( 3, 3, A, 3, ipiv, info )
+ call DGETRI( 3, A, 3, ipiv, work, 3, info )
+#else
+ invdetA = 1.0_rl / ( A(1,1) * (A(3,3)*A(2,2) - A(3,2)*A(2,3)) &
+ - A(2,1) * (A(3,3)*A(1,2) - A(3,2)*A(1,3)) &
+ + A(3,1) * (A(2,3)*A(1,2) - A(2,2)*A(1,3)) )
+ Anew(1,1) = A(3,3)*A(2,2) - A(3,2)*A(2,3)
+ Anew(1,2) = - ( A(3,3)*A(1,2) - A(3,2)*A(1,3) )
+ Anew(1,3) = A(2,3)*A(1,2) - A(2,2)*A(1,3)
+ Anew(2,1) = - ( A(3,3)*A(2,1) - A(3,1)*A(2,3) )
+ Anew(2,2) = A(3,3)*A(1,1) - A(3,1)*A(1,3)
+ Anew(2,3) = - ( A(2,3)*A(1,1) - A(2,1)*A(1,3) )
+ Anew(3,1) = A(3,2)*A(2,1) - A(3,1)*A(2,2)
+ Anew(3,2) = - ( A(3,2)*A(1,1) - A(3,1)*A(1,2) )
+ Anew(3,3) = A(2,2)*A(1,1) - A(2,1)*A(1,2)
+ A(:,:) = invdetA*Anew(:,:)
+#endif
+ end subroutine invertA
+
+!==================================================================
+! Multigrid V-cycle
+!==================================================================
+ recursive subroutine mg_vcycle_mnh(b,u,r,finelevel,splitlevel,level,m)
+ implicit none
+ integer, intent(in) :: finelevel
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: b
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: u
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: r
+ integer, intent(in) :: splitlevel
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ !local var
+ integer :: n_gridpoints
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+
+ real , dimension(:,:,:) , pointer :: zu_level_1_m_st
+
+ nlocalx = u(level,m)%ix_max-u(level,m)%ix_min+1
+ nlocaly = u(level,m)%iy_max-u(level,m)%iy_min+1
+ halo_size = u(level,m)%halo_size
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (u(level,m)%grid_param%nz+2)
+
+ if (level > 1) then
+ ! Perform n_presmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth_mnh(level,m,mg_param%n_presmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ ! Calculate residual
+ call start_timer(t_residual(level,m))
+ call start_timer(t_total(level,m))
+ call calculate_residual_mnh(level,m,b(level,m),u(level,m),r(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_residual(level,m))
+ ! Restrict residual
+ call start_timer(t_restrict(level,m))
+ call start_timer(t_total(level,m))
+ call restrict_mnh(r(level,m),b(level-1,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_restrict(level,m))
+ if ( ((level-1) .le. splitlevel) .and. (m > 0) ) then
+ ! Collect data on coarser level
+ call start_timer(t_total(level,m))
+ call collect(level-1,m,b(level-1,m),b(level-1,m-1))
+!!$ call print_scalaprod2(level-1, m , b(level-1,m) , "After collect b(level-1,m )=" )
+!!$ call print_scalaprod2(level-1, m-1, b(level-1,m-1), "After collect b(level-1,m-1)=" )
+ call finish_timer(t_total(level,m))
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m-1)%s(:,:,:) = 0.0_rl
+ if (LUseT) u(level-1,m-1)%st(:,:,:) = 0.0_rl
+ ! solve on coarser grid
+ call mg_vcycle_mnh(b,u,r,finelevel,splitlevel,level-1,m-1)
+ ! Distribute data on coarser grid
+ call start_timer(t_total(level,m))
+ call distribute(level-1,m,u(level-1,m-1),u(level-1,m))
+!!$ call print_scalaprod2(level-1, m , u(level-1,m) , "After distribute u(level-1,m )=" )
+!!$ call print_scalaprod2(level-1, m-1, u(level-1,m-1), "After distribute u(level-1,m-1)=" )
+ call finish_timer(t_total(level,m))
+ else
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m)%s(:,:,:) = 0.0_rl
+ if (LUseT) then
+ zu_level_1_m_st => u(level-1,m)%st(:,:,:)
+ !$acc kernels
+ zu_level_1_m_st(:,:,:) = 0.0_rl
+ !$acc end kernels
+ end if
+ ! solve on coarser grid
+ call mg_vcycle_mnh(b,u,r,finelevel,splitlevel,level-1,m)
+ end if
+ ! Prolongate error
+ call start_timer(t_prolongate(level,m))
+ call start_timer(t_total(level,m))
+ call haloswap_mnh(level-1,m,u(level-1,m))
+ call boundary_mnh(u(level-1,m))
+!!$ call print_scalaprod2(level-1 , m , u(level-1,m) , "Befor prolongate_mnh u(level-1,m )=" )
+!!$ call print_scalaprod2(level , m , r(level ,m) , "Befor prolongate_mnh r(level ,m )=" )
+ call prolongate_mnh(level,m,u(level-1,m),r(level,m))
+!!$ call print_scalaprod2(level-1 , m , u(level-1,m) , "After prolongate_mnh u(level-1,m )=" )
+!!$ call print_scalaprod2(level , m , r(level ,m) , "After prolongate_mnh r(level ,m )=" )
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_prolongate(level,m))
+ ! Add error to fine grid solution
+ call start_timer(t_addcorr(level,m))
+ call start_timer(t_total(level,m))
+ if (LUseO) call daxpy(n_gridpoints,1.0_rl,r(level,m)%s,1,u(level,m)%s,1)
+ if (LUseT) call daxpy(n_gridpoints,1.0_rl,r(level,m)%st,1,u(level,m)%st,1)
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_addcorr(level,m))
+ ! Perform n_postsmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth_mnh(level,m, &
+ mg_param%n_postsmooth, &
+ DIRECTION_BACKWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ else
+ call start_timer(t_coarsesolve(level,m))
+ call start_timer(t_total(level,m))
+ if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_CG) then
+ call cg_solve_mnh(level,m,b(level,m),u(level,m))
+!!$ call print_scalaprod2(level, m , u(level,m), "After cg_solve_mnh u=(level,m)" )
+ else if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_SMOOTHER) then
+ ! Smooth on coarsest level
+ call smooth_mnh(level,m, &
+ mg_param%n_coarsegridsmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ end if
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_coarsesolve(level,m))
+ end if
+
+ end subroutine mg_vcycle_mnh
+!==================================================================
+! Multigrid V-cycle
+!==================================================================
+ recursive subroutine mg_vcycle(b,u,r,finelevel,splitlevel,level,m)
+ implicit none
+ integer, intent(in) :: finelevel
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: b
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: u
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: r
+ integer, intent(in) :: splitlevel
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer :: n_gridpoints
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+
+ nlocalx = u(level,m)%ix_max-u(level,m)%ix_min+1
+ nlocaly = u(level,m)%iy_max-u(level,m)%iy_min+1
+ halo_size = u(level,m)%halo_size
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (u(level,m)%grid_param%nz+2)
+
+ if (level > 1) then
+ ! Perform n_presmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth(level,m,mg_param%n_presmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ ! Calculate residual
+ call start_timer(t_residual(level,m))
+ call start_timer(t_total(level,m))
+ call calculate_residual(level,m,b(level,m),u(level,m),r(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_residual(level,m))
+ ! Restrict residual
+ call start_timer(t_restrict(level,m))
+ call start_timer(t_total(level,m))
+ call restrict(r(level,m),b(level-1,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_restrict(level,m))
+ if ( ((level-1) .le. splitlevel) .and. (m > 0) ) then
+ ! Collect data on coarser level
+ call start_timer(t_total(level,m))
+ call collect(level-1,m,b(level-1,m),b(level-1,m-1))
+ call haloswap_mnh(level-1,m-1,b(level-1,m-1))
+ call finish_timer(t_total(level,m))
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m-1)%s(:,:,:) = 0.0_rl
+ if (LUseT) u(level-1,m-1)%st(:,:,:) = 0.0_rl
+ ! solve on coarser grid
+ call mg_vcycle(b,u,r,finelevel,splitlevel,level-1,m-1)
+ ! Distribute data on coarser grid
+ call start_timer(t_total(level,m))
+ call distribute(level-1,m,u(level-1,m-1),u(level-1,m))
+ call haloswap(level-1,m,u(level-1,m))
+ call finish_timer(t_total(level,m))
+ else
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m)%s(:,:,:) = 0.0_rl
+ if (LUseT) u(level-1,m)%st(:,:,:) = 0.0_rl
+ ! solve on coarser grid
+ call mg_vcycle(b,u,r,finelevel,splitlevel,level-1,m)
+ end if
+ ! Prolongate error
+ call start_timer(t_prolongate(level,m))
+ call start_timer(t_total(level,m))
+ call prolongate(level,m,u(level-1,m),r(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_prolongate(level,m))
+ ! Add error to fine grid solution
+ call start_timer(t_addcorr(level,m))
+ call start_timer(t_total(level,m))
+ if (LUseO) call daxpy(n_gridpoints,1.0_rl,r(level,m)%s,1,u(level,m)%s,1)
+ if (LUseT) call daxpy(n_gridpoints,1.0_rl,r(level,m)%st,1,u(level,m)%st,1)
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_addcorr(level,m))
+ ! Perform n_postsmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth(level,m, &
+ mg_param%n_postsmooth, &
+ DIRECTION_BACKWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ else
+ call start_timer(t_coarsesolve(level,m))
+ call start_timer(t_total(level,m))
+ if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_CG) then
+ call cg_solve(level,m,b(level,m),u(level,m))
+ else if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_SMOOTHER) then
+ ! Smooth on coarsest level
+ call smooth(level,m, &
+ mg_param%n_coarsegridsmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ end if
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_coarsesolve(level,m))
+ end if
+
+ end subroutine mg_vcycle
+
+!==================================================================
+! Test halo exchanges
+!==================================================================
+ recursive subroutine mg_vcyclehaloswaponly(b,u,r,finelevel,splitlevel,level,m)
+ implicit none
+ integer, intent(in) :: finelevel
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: b
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: u
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: r
+ integer, intent(in) :: splitlevel
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, parameter :: nhaloswap = 100
+ integer :: i
+ integer :: ierr
+
+ if (level > 1) then
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ do i=1,nhaloswap
+ call haloswap(level,m,u(level,m))
+ end do
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ if ( ((level-1) .le. splitlevel) .and. (m > 0) ) then
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ do i=1,nhaloswap
+ call haloswap(level-1,m,u(level-1,m))
+ end do
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ call mg_vcyclehaloswaponly(b,u,r,finelevel,splitlevel,level-1,m-1)
+ else
+ call mg_vcyclehaloswaponly(b,u,r,finelevel,splitlevel,level-1,m)
+ end if
+ else
+ ! Haloswap on coarsest level
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ do i=1,nhaloswap
+ call haloswap(level,m,u(level,m))
+ end do
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ end if
+
+ end subroutine mg_vcyclehaloswaponly
+
+!==================================================================
+! Multigrid solve
+! Assumes that ghosts in initial solution are up-to-date
+!==================================================================
+ subroutine mg_solve_mnh(bRHS,usolution,solver_param)
+ implicit none
+ type(scalar3d), intent(in) :: bRHS
+ type(scalar3d), intent(inout) :: usolution
+ type(solver_parameters), intent(in) :: solver_param
+ integer :: solvertype
+ real(kind=rl) :: resreduction
+ integer :: maxiter
+ integer :: n_gridpoints
+ integer :: iter, level, finelevel, splitlevel
+ real(kind=rl) :: res_old, res_new, res_initial , mean_initial , norm_initial
+ logical :: solverconverged = .false.
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+ type(time) :: t_prec, t_res, t_apply, t_l2norm, t_scalprod, t_mainloop
+ type(scalar3d) :: pp
+ type(scalar3d) :: q
+ type(scalar3d) :: z_one
+ real(kind=rl) :: alpha, beta, pq, rz, rz_old
+ integer :: ierr
+
+ solvertype = solver_param%solvertype
+ resreduction = solver_param%resreduction
+ maxiter = solver_param%maxiter
+ nlocalx = usolution%ix_max - usolution%ix_min+1
+ nlocaly = usolution%iy_max - usolution%iy_min+1
+ halo_size = usolution%halo_size
+
+ level = mg_param%n_lev
+ finelevel = level
+ splitlevel = mg_param%lev_split
+
+ ! Initialise timers
+ call initialise_timer(t_prec,"t_prec")
+ call initialise_timer(t_apply,"t_apply")
+ call initialise_timer(t_l2norm,"t_l2norm")
+ call initialise_timer(t_scalprod,"t_scalarprod")
+ call initialise_timer(t_res,"t_residual")
+ call initialise_timer(t_mainloop,"t_mainloop")
+
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (usolution%grid_param%nz+2)
+ !
+ ! Init 1 vector = z_one
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,z_one)
+ if (LUseO) then
+ z_one%s(:,:,:) = 0.0_rl
+ z_one%s(1:z_one%grid_param%nz,1:z_one%icompy_max,1:z_one%icompx_max) = 1.0_rl
+ end if
+ if (LUseT) then
+ z_one%st(:,:,:) = 0.0_rl
+ z_one%st(1:z_one%icompx_max,1:z_one%icompy_max,1:z_one%grid_param%nz) = 1.0_rl
+ end if
+ ! Mean / Norm of B
+ call scalarprod_mnh(pproc,z_one,z_one, mean_initial )
+ call scalarprod_mnh(pproc,z_one,bRHS, mean_initial )
+ norm_initial = l2norm_mnh(bRHS,.true.)
+ mean_initial = mean_initial / (( z_one%grid_param%nz ) * ( z_one%grid_param%n )**2)
+ norm_initial = mean_initial / norm_initial
+ if (LMean) then
+ ! b <- b -mean_initial * z_one
+ if (LUseO) call daxpy(n_gridpoints,-mean_initial,z_one%s,1,bRHS%s,1)
+ if (LUseT) call daxpy(n_gridpoints,-mean_initial,z_one%st,1,bRHS%st,1)
+ call scalarprod_mnh(pproc,z_one,bRHS, mean_initial )
+ endif
+ !
+ ! Copy b to b(1)
+ ! Copy usolution to u(1)
+ if (LUseO) call dcopy(n_gridpoints,bRHS%s,1,xb_mg(level,pproc)%s,1)
+ if (LUseT) call dcopy(n_gridpoints,bRHS%st,1,xb_mg(level,pproc)%st,1)
+ if (LUseO) call dcopy(n_gridpoints,usolution%s,1,xu_mg(level,pproc)%s,1)
+ if (LUseT) call dcopy(n_gridpoints,usolution%st,1,xu_mg(level,pproc)%st,1)
+
+! Scale with volume of grid cells
+ call volscale_scalar3d_mnh(xb_mg(level,pproc),1)
+ call scalarprod_mnh(pproc,z_one,xb_mg(level,pproc), mean_initial )
+
+ call start_timer(t_res)
+ call calculate_residual_mnh(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_initial = l2norm_mnh(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ res_old = res_initial
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** Multigrid solver ***")')
+ write(STDOUT,'(" <MG> Initial residual : ",E10.5)') res_initial
+ end if
+ end if
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> iter : residual rho")')
+ write(STDOUT,'(" <MG> --------------------------------")')
+ end if
+ end if
+
+ call mpi_barrier(MPI_COMM_WORLD,ierr)
+ call start_timer(t_mainloop)
+ if (solvertype == SOLVER_CG) then
+ ! NB: b(level,pproc) will be used as r in the following
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,pp)
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,q)
+ ! Apply preconditioner: Calculate p = M^{-1} r
+ ! (1) copy b <- r
+ if (LUseO) call dcopy(n_gridpoints,xr_mg(level,pproc)%s,1,xb_mg(level,pproc)%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xr_mg(level,pproc)%st,1,xb_mg(level,pproc)%st,1)
+ ! (2) set u <- 0
+ if (LUseO) xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ if (LUseT) xu_mg(level,pproc)%st(:,:,:) = 0.0_rl
+ ! (3) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle_mnh(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (4) copy pp <- u (=solution from MG Vcycle)
+ if (LUseO) call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,pp%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xu_mg(level,pproc)%st,1,pp%st,1)
+ ! Calculate rz_old = <pp,b>
+ call start_timer(t_scalprod)
+ call scalarprod_mnh(pproc,pp,xb_mg(level,pproc),rz_old)
+ call finish_timer(t_scalprod)
+ do iter = 1, maxiter
+ ! Apply matrix q <- A.pp
+ call start_timer(t_apply)
+ call apply_mnh(pp,q)
+ call finish_timer(t_apply)
+ ! Calculate pq <- <pp,q>
+ call start_timer(t_scalprod)
+ call scalarprod_mnh(pproc,pp,q,pq)
+ call finish_timer(t_scalprod)
+ alpha = rz_old/pq
+ ! x <- x + alpha*p
+ if (LUseO) call daxpy(n_gridpoints,alpha,pp%s,1,usolution%s,1)
+ if (LUseT) call daxpy(n_gridpoints,alpha,pp%st,1,usolution%st,1)
+ ! b <- b - alpha*q
+ if (LUseO) call daxpy(n_gridpoints,-alpha,q%s,1,xb_mg(level,pproc)%s,1)
+ if (LUseT) call daxpy(n_gridpoints,-alpha,q%st,1,xb_mg(level,pproc)%st,1)
+ ! Calculate norm of residual and exit if it has been
+ ! reduced sufficiently
+ call start_timer(t_l2norm)
+ res_new = l2norm_mnh(xb_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ ! Apply preconditioner q <- M^{-1} b
+ ! (1) Initialise solution u <- 0
+ if (LUseO) xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ if (LUseT) xu_mg(level,pproc)%st(:,:,:) = 0.0_rl
+ ! (2) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle_mnh(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (3) copy q <- u (solution from MG Vcycle)
+ if (LUseO) call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,q%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xu_mg(level,pproc)%st,1,q%st,1)
+ call start_timer(t_scalprod)
+ call scalarprod_mnh(pproc,q,xb_mg(level,pproc),rz)
+ call finish_timer(t_scalprod)
+ beta = rz/rz_old
+ ! p <- beta*p
+ if (LUseO) call dscal(n_gridpoints,beta,pp%s,1)
+ if (LUseT) call dscal(n_gridpoints,beta,pp%st,1)
+ ! p <- p+q
+ if (LUseO) call daxpy(n_gridpoints,1.0_rl,q%s,1,pp%s,1)
+ if (LUseT) call daxpy(n_gridpoints,1.0_rl,q%st,1,pp%st,1)
+ rz_old = rz
+ end do
+ call destroy_scalar3d(pp)
+ call destroy_scalar3d(q)
+ else if (solvertype == SOLVER_RICHARDSON) then
+ ! Iterate until convergence
+ do iter=1,maxiter
+ call start_timer(t_prec)
+ call mg_vcycle_mnh(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ call start_timer(t_res)
+ ! Ghosts are up-to-date here, so no need for halo exchange
+ call calculate_residual_mnh(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_new = l2norm_mnh(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ end do
+ ! Copy u(1) to usolution
+ if (LUseO) call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,usolution%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xu_mg(level,pproc)%st,1,usolution%st,1)
+ end if
+
+ call destroy_scalar3d(z_one)
+
+ call finish_timer(t_mainloop)
+
+ ! Print out solver information
+ if (mg_param%verbose > 0) then
+ if (solverconverged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Final residual ||r|| = ",E12.6)') res_new
+ write(STDOUT,'(" <MG> Solver converged in ",I7," iterations rho_{avg} = ",F10.5)') &
+ iter, (res_new/res_initial)**(1./(iter))
+ end if
+ else
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Solver failed to converge after ",I7," iterations rho_{avg} = ",F10.5)') &
+ maxiter, (res_new/res_initial)**(1./(iter))
+ end if
+ end if
+ end if
+ call print_timerinfo("--- Main iteration timing results ---")
+ call print_elapsed(t_apply,.True.,1.0_rl)
+ call print_elapsed(t_res,.True.,1.0_rl)
+ call print_elapsed(t_prec,.True.,1.0_rl)
+ call print_elapsed(t_l2norm,.True.,1.0_rl)
+ call print_elapsed(t_scalprod,.True.,1.0_rl)
+ call print_elapsed(t_mainloop,.True.,1.0_rl)
+ if (i_am_master_mpi) write(STDOUT,'("")')
+ end subroutine mg_solve_mnh
+
+ subroutine mg_solve(bRHS,usolution,solver_param)
+ implicit none
+ type(scalar3d), intent(in) :: bRHS
+ type(scalar3d), intent(inout) :: usolution
+ type(solver_parameters), intent(in) :: solver_param
+ integer :: solvertype
+ real(kind=rl) :: resreduction
+ integer :: maxiter
+ integer :: n_gridpoints
+ integer :: iter, level, finelevel, splitlevel
+ real(kind=rl) :: res_old, res_new, res_initial
+ logical :: solverconverged = .false.
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+ type(time) :: t_prec, t_res, t_apply, t_l2norm, t_scalprod, t_mainloop
+ type(scalar3d) :: pp
+ type(scalar3d) :: q
+ real(kind=rl) :: alpha, beta, pq, rz, rz_old
+ integer :: ierr
+
+ solvertype = solver_param%solvertype
+ resreduction = solver_param%resreduction
+ maxiter = solver_param%maxiter
+ nlocalx = usolution%ix_max - usolution%ix_min+1
+ nlocaly = usolution%iy_max - usolution%iy_min+1
+ halo_size = usolution%halo_size
+
+ level = mg_param%n_lev
+ finelevel = level
+ splitlevel = mg_param%lev_split
+
+ ! Initialise timers
+ call initialise_timer(t_prec,"t_prec")
+ call initialise_timer(t_apply,"t_apply")
+ call initialise_timer(t_l2norm,"t_l2norm")
+ call initialise_timer(t_scalprod,"t_scalarprod")
+ call initialise_timer(t_res,"t_residual")
+ call initialise_timer(t_mainloop,"t_mainloop")
+
+ ! Copy b to b(1)
+ ! Copy usolution to u(1)
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (usolution%grid_param%nz+2)
+ call dcopy(n_gridpoints,bRHS%s,1,xb_mg(level,pproc)%s,1)
+ call dcopy(n_gridpoints,usolution%s,1,xu_mg(level,pproc)%s,1)
+! Scale with volume of grid cells
+ call volscale_scalar3d(xb_mg(level,pproc),1)
+ call start_timer(t_res)
+ call calculate_residual(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_initial = l2norm(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ res_old = res_initial
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** Multigrid solver ***")')
+ write(STDOUT,'(" <MG> Initial residual : ",E10.5)') res_initial
+ end if
+ end if
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> iter : residual rho")')
+ write(STDOUT,'(" <MG> --------------------------------")')
+ end if
+ end if
+
+ call mpi_barrier(MPI_COMM_WORLD,ierr)
+ call start_timer(t_mainloop)
+ if (solvertype == SOLVER_CG) then
+ ! NB: b(level,pproc) will be used as r in the following
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,pp)
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,q)
+ ! Apply preconditioner: Calculate p = M^{-1} r
+ ! (1) copy b <- r
+ call dcopy(n_gridpoints,xr_mg(level,pproc)%s,1,xb_mg(level,pproc)%s,1)
+ ! (2) set u <- 0
+ xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ ! (3) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (4) copy pp <- u (=solution from MG Vcycle)
+ call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,pp%s,1)
+ ! Calculate rz_old = <pp,b>
+ call start_timer(t_scalprod)
+ call scalarprod(pproc,pp,xb_mg(level,pproc),rz_old)
+ call finish_timer(t_scalprod)
+ do iter = 1, maxiter
+ ! Apply matrix q <- A.pp
+ call start_timer(t_apply)
+ call apply(pp,q)
+ call finish_timer(t_apply)
+ ! Calculate pq <- <pp,q>
+ call start_timer(t_scalprod)
+ call scalarprod(pproc,pp,q,pq)
+ call finish_timer(t_scalprod)
+ alpha = rz_old/pq
+ ! x <- x + alpha*p
+ call daxpy(n_gridpoints,alpha,pp%s,1,usolution%s,1)
+ ! b <- b - alpha*q
+ call daxpy(n_gridpoints,-alpha,q%s,1,xb_mg(level,pproc)%s,1)
+ ! Calculate norm of residual and exit if it has been
+ ! reduced sufficiently
+ call start_timer(t_l2norm)
+ res_new = l2norm(xb_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ ! Apply preconditioner q <- M^{-1} b
+ ! (1) Initialise solution u <- 0
+ xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ ! (2) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (3) copy q <- u (solution from MG Vcycle)
+ call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,q%s,1)
+ call start_timer(t_scalprod)
+ call scalarprod(pproc,q,xb_mg(level,pproc),rz)
+ call finish_timer(t_scalprod)
+ beta = rz/rz_old
+ ! p <- beta*p
+ call dscal(n_gridpoints,beta,pp%s,1)
+ ! p <- p+q
+ call daxpy(n_gridpoints,1.0_rl,q%s,1,pp%s,1)
+ rz_old = rz
+ end do
+ call destroy_scalar3d(pp)
+ call destroy_scalar3d(q)
+ else if (solvertype == SOLVER_RICHARDSON) then
+ ! Iterate until convergence
+ do iter=1,maxiter
+ call start_timer(t_prec)
+ call mg_vcycle(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ call start_timer(t_res)
+ ! Ghosts are up-to-date here, so no need for halo exchange
+ call calculate_residual(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_new = l2norm(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ end do
+ ! Copy u(1) to usolution
+ call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,usolution%s,1)
+ end if
+ call finish_timer(t_mainloop)
+
+ ! Print out solver information
+ if (mg_param%verbose > 0) then
+ if (solverconverged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Final residual ||r|| = ",E12.6)') res_new
+ write(STDOUT,'(" <MG> Solver converged in ",I7," iterations rho_{avg} = ",F10.5)') &
+ iter, (res_new/res_initial)**(1./(iter))
+ end if
+ else
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Solver failed to converge after ",I7," iterations rho_{avg} = ",F10.5)') &
+ maxiter, (res_new/res_initial)**(1./(iter))
+ end if
+ end if
+ end if
+ call print_timerinfo("--- Main iteration timing results ---")
+ call print_elapsed(t_apply,.True.,1.0_rl)
+ call print_elapsed(t_res,.True.,1.0_rl)
+ call print_elapsed(t_prec,.True.,1.0_rl)
+ call print_elapsed(t_l2norm,.True.,1.0_rl)
+ call print_elapsed(t_scalprod,.True.,1.0_rl)
+ call print_elapsed(t_mainloop,.True.,1.0_rl)
+ if (i_am_master_mpi) write(STDOUT,'("")')
+ end subroutine mg_solve
+
+!==================================================================
+! Test haloswap on all levels
+!==================================================================
+ subroutine measurehaloswap()
+ implicit none
+ integer :: iter, level, finelevel, splitlevel
+
+ level = mg_param%n_lev
+ finelevel = level
+ splitlevel = mg_param%lev_split
+ call mg_vcyclehaloswaponly(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ end subroutine measurehaloswap
+
+end module multigrid
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/parameters.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/parameters.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5195982fdeffc44390f2a2fa9fd116f6e0d76660
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/parameters.f90
@@ -0,0 +1,64 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! General parameters
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module parameters
+
+ implicit none
+
+! floating point precision. Always use rl_kind in code
+ integer, parameter :: single_precision=4 ! single precision
+ integer, parameter :: double_precision=8 ! double precision
+ integer, parameter :: rl=double_precision ! global switch between
+ ! single/double precision
+! NOTE: As we still use BLAS subroutines, these need to be
+! replaced as well when switching between double and
+! single precision!
+ real(kind=rl), parameter :: Tolerance = 1.0e-15
+
+! Output units
+ integer, parameter :: STDOUT = 6
+ integer, parameter :: STDERR = 0
+
+! Numerical constants
+ real(kind=rl), parameter :: two_pi = 6.2831853071795862_rl
+
+! Use Original (K,J,I) or Transposed (I,J,K) array
+ logical :: LUseO = .false.
+ logical :: LUseT = .true. ! .false. ! .true.
+! Remove mean to B = Right Hand side
+ logical :: LMean = .false.
+
+end module parameters
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
new file mode 100644
index 0000000000000000000000000000000000000000..489210645307e67cfc4c21e87f668963db60cbf4
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
@@ -0,0 +1,334 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Analytical forms of RHS vectors
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module profiles
+
+ use communication
+ use parameters
+ use datatypes
+ use discretisation
+
+ implicit none
+
+ public::initialise_u_mnh
+ public::get_u_mnh
+ public::initialise_rhs_mnh
+ public::initialise_rhs
+ public::analytical_solution
+
+private
+ contains
+!==================================================================
+! Initialise U vector
+!==================================================================
+ subroutine initialise_u_mnh(grid_param,model_param,u,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: u
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+ integer , optional, intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+ real(kind=rl) , optional, intent(in) :: PU(:,:,:)
+
+ ix_min = u%ix_min
+ ix_max = u%ix_max
+ iy_min = u%iy_min
+ iy_max = u%iy_max
+ IF (.NOT. PRESENT(KIB) ) THEN
+ ! Initialise RHS
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+
+ if (LUseO) u%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
+ if (LUseT) u%st(ix-ix_min+1,iy-iy_min+1,iz) = 0.0_rl
+
+ end do
+ end do
+ end do
+ ELSE
+ ! Initialise RHS
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) = PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do iz=1,u%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ u%st(ix-ix_min+1,iy-iy_min+1,iz) = PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ end if
+ END IF
+ end subroutine initialise_u_mnh
+!==================================================================
+! Get U vector
+!==================================================================
+ subroutine get_u_mnh(grid_param,model_param,u,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: u
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+ integer , optional, intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+ real(kind=rl) , optional, intent(inout) :: PU(:,:,:)
+
+ ix_min = u%ix_min
+ ix_max = u%ix_max
+ iy_min = u%iy_min
+ iy_max = u%iy_max
+ IF (.NOT. PRESENT(KIB) ) THEN
+ !
+ ELSE
+ ! Get PU
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+ PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ) = u%s(iz,iy-iy_min+1,ix-ix_min+1)
+ end do
+ end do
+ end do
+ else
+ do iz=1,u%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ) = u%st(ix-ix_min+1,iy-iy_min+1,iz)
+ end do
+ end do
+ end do
+ end if
+ END IF
+ end subroutine get_u_mnh
+!==================================================================
+! Initialise RHS vector
+!==================================================================
+ subroutine initialise_rhs_mnh(grid_param,model_param,b,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PY)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: b
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+ integer , optional, intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+ real(kind=rl) , optional, intent(in) :: PY(:,:,:)
+
+ ix_min = b%ix_min
+ ix_max = b%ix_max
+ iy_min = b%iy_min
+ iy_max = b%iy_max
+ IF (.NOT. PRESENT(KIB) ) THEN
+ ! Initialise RHS
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,b%grid_param%nz
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+
+ if (LUseO) b%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
+ if (LUseT) b%st(ix-ix_min+1,iy-iy_min+1,iz) = 0.0_rl
+
+ if ( ( x .ge. 0.1_rl ) .and. ( x .le. 0.4_rl ) &
+ .and. (y .ge. 0.3_rl ) .and. ( y .le. 0.6_rl ) &
+ .and. (z .ge. 0.2_rl ) .and. ( z .le. 0.7_rl ) ) &
+ then
+ if (LUseO) b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+ if (LUseT) b%st(ix-ix_min+1,iy-iy_min+1,iz) = 1.0_rl
+ end if
+
+ end do
+ end do
+ end do
+ ELSE
+ ! Initialise RHS
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,b%grid_param%nz
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = PY(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do iz=1,b%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ b%st(ix-ix_min+1,iy-iy_min+1,iz) = PY(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ end if
+ END IF
+ end subroutine initialise_rhs_mnh
+!==================================================================
+! Initialise RHS vector
+!==================================================================
+ subroutine initialise_rhs(grid_param,model_param,b)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: b
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+#ifdef TESTCONVERGENCE
+ real(kind=rl) :: px,py,pz
+#endif
+
+ ix_min = b%ix_min
+ ix_max = b%ix_max
+ iy_min = b%iy_min
+ iy_max = b%iy_max
+ b_low = 1.0_rl+0.25*b%grid_param%H
+ b_up = 1.0_rl+0.75*b%grid_param%H
+ pi = 4.0_rl*atan2(1.0_rl,1.0_rl)
+ ! Initialise RHS
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,b%grid_param%nz
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+#ifdef TESTCONVERGENCE
+ ! RHS for analytical solution x*(1-x)*y*(1-y)*z*(1-z)
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ px = x*(1.0_rl-x)
+ py = y*(1.0_rl-y)
+ pz = z*(1.0_rl-z)
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = &
+ ( 2.0_rl*model_param%omega2*((px+py)*pz &
+ + model_param%lambda2*px*py)+model_param%delta*px*py*pz)
+ else
+ px = x*(1.0_rl-x)
+ py = y*(1.0_rl-y)
+ pz = 1.0_rl
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = &
+ ( 2.0_rl*model_param%omega2*((px+py)*pz)+model_param%delta*px*py*pz)
+ end if
+#else
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
+#ifdef CARTESIANGEOMETRY
+ if ( ( x .ge. 0.1_rl ) .and. ( x .le. 0.4_rl ) &
+ .and. (y .ge. 0.3_rl ) .and. ( y .le. 0.6_rl ) &
+ .and. (z .ge. 0.2_rl ) .and. ( z .le. 0.7_rl ) ) &
+ then
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+ end if
+#else
+ rho = 2.0_rl*(1.0_rl*ix-0.5_rl)/grid_param%n-1.0_rl
+ sigma = 2.0_rl*(1.0_rl*iy-0.5_rl)/grid_param%n-1.0_rl
+ phi = atan(sigma)
+ theta = atan(rho/sqrt(1.0_rl+sigma**2))
+ x = sin(theta)
+ y = cos(theta)*sin(phi)
+ z = cos(theta)*cos(phi)
+ phi = atan2(x,y)
+ theta = atan2(sqrt(x**2+y**2),z)
+ r = 0.5_rl*(r_grid(iz)+r_grid(iz+1))
+ if (( (r > b_low) .and. (r < b_up) ) .and. &
+ (((theta>pi/10.0_rl) .and. (theta<pi/5.0_rl )) .or. &
+ ((theta>3.0_rl*pi/8.0_rl) .and. (theta<5.0_rl*pi/8.0_rl )) .or. &
+ ((theta>4.0_rl*pi/5.0_rl) .and. (theta<9.0_rl*pi/10.0_rl)))) then
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+ end if
+! RHS used in GPU code:
+! if ( (r > b_low) .and. (r < b_up) .and. &
+! (rho > -0.5) .and. (rho < 0.5) .and. &
+! (sigma > -0.5).and. (sigma < 0.5) ) then
+! b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+! end if
+#endif
+#endif
+ end do
+ end do
+ end do
+ end subroutine initialise_rhs
+!==================================================================
+! Exact solution for test problem
+! u(x,y,z) = x*(1-x)*y*(1-y)*z*(1-z)
+!==================================================================
+ subroutine analytical_solution(grid_param,u)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(scalar3d), intent(inout) :: u
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+
+ ix_min = u%ix_min
+ ix_max = u%ix_max
+ iy_min = u%iy_min
+ iy_max = u%iy_max
+
+ ! Initialise RHS
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+ x = u%grid_param%L*((ix-0.5_rl)/(1.0_rl*u%grid_param%n))
+ y = u%grid_param%L*((iy-0.5_rl)/(1.0_rl*u%grid_param%n))
+ z = u%grid_param%H*((iz-0.5_rl)/(1.0_rl*u%grid_param%nz))
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) &
+ = x*(1.0_rl-x) &
+ * y*(1.0_rl-y) &
+ * z*(1.0_rl-z)
+ else
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) &
+ = x*(1.0_rl-x) &
+ * y*(1.0_rl-y)
+ end if
+ end do
+ end do
+ end do
+ end subroutine analytical_solution
+
+end module profiles
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/solver.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/solver.f90
new file mode 100644
index 0000000000000000000000000000000000000000..97f5a7b840cc0030902eaf39b55bb1d9c0460041
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/solver.f90
@@ -0,0 +1,61 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Solver parameters
+!
+! Eike Mueller, University of Bath, May 2012
+!
+!==================================================================
+module solver
+
+ use parameters
+ use datatypes
+
+ implicit none
+
+public::solver_parameters
+public::SOLVER_RICHARDSON
+public::SOLVER_CG
+
+private
+
+ integer, parameter :: SOLVER_RICHARDSON = 1
+ integer, parameter :: SOLVER_CG = 2
+
+
+ ! --- Solver parameters ---
+ type solver_parameters
+ integer :: solvertype ! Type of solver
+ real(kind=rl) :: resreduction ! Required relative residual reduction
+ integer :: maxiter ! Maximal number of iterations
+ end type solver_parameters
+
+end module solver
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/timer.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/timer.f90
new file mode 100644
index 0000000000000000000000000000000000000000..da0f17907a28016c0aad1fee4b78d348cf72ecfd
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/timer.f90
@@ -0,0 +1,193 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Timer module
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module timer
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use parameters
+
+ implicit none
+
+public::initialise_timing
+public::finalise_timing
+public::time
+public::initialise_timer
+public::start_timer
+public::finish_timer
+public::print_timerinfo
+public::print_elapsed
+
+private
+
+! Timer type
+ type time
+ character(len=32) :: label
+ real(kind=rl) :: start
+ real(kind=rl) :: finish
+ integer :: ncall
+ real(kind=rl) :: elapsed
+ end type time
+
+ ! id of timer output file
+ integer, parameter :: TIMEROUT = 9
+
+ ! used my MPI
+ integer :: rank, ierr
+
+contains
+
+!==================================================================
+! Initialise timer module
+!==================================================================
+ subroutine initialise_timing(filename)
+ implicit none
+ character(len=*), intent(in) :: filename
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank==0) then
+ open(UNIT=TIMEROUT,FILE=trim(filename))
+ write(STDOUT,'("Writing timer information to file ",A40)') filename
+ write(TIMEROUT,'("# ----------------------------------------------")')
+ write(TIMEROUT,'("# Timer information for geometric multigrid code")')
+ write(TIMEROUT,'("# ----------------------------------------------")')
+ end if
+ end subroutine initialise_timing
+
+!==================================================================
+! Finalise timer module
+!==================================================================
+ subroutine finalise_timing()
+ implicit none
+ if (rank==0) then
+ close(TIMEROUT)
+ end if
+ end subroutine finalise_timing
+
+!==================================================================
+! Initialise timer
+!==================================================================
+ subroutine initialise_timer(t,label)
+ implicit none
+ type(time), intent(inout) :: t
+ character(len=*), intent(in) :: label
+ t%label = label
+ t%start = 0.0_rl
+ t%ncall = 0
+ t%finish = 0.0_rl
+ t%elapsed = 0.0_rl
+ end subroutine initialise_timer
+
+!==================================================================
+! Start timer
+!==================================================================
+ subroutine start_timer(t)
+ implicit none
+ type(time), intent(inout) :: t
+ t%start = mpi_wtime()
+ end subroutine start_timer
+
+!==================================================================
+! Finish timer
+!==================================================================
+ subroutine finish_timer(t)
+ implicit none
+ type(time), intent(inout) :: t
+ t%finish = mpi_wtime()
+ t%elapsed = t%elapsed + (t%finish-t%start)
+ t%ncall = t%ncall + 1
+ end subroutine finish_timer
+
+!==================================================================
+! Print to timer file
+!==================================================================
+ subroutine print_timerinfo(msg)
+ implicit none
+ character(len=*), intent(in) :: msg
+ if (rank == 0) then
+ write(TIMEROUT,*) "# " // trim(msg)
+ end if
+ end subroutine print_timerinfo
+
+!==================================================================
+! Print timer information
+!==================================================================
+ subroutine print_elapsed(t,summaryonly,factor)
+ implicit none
+ type(time), intent(in) :: t
+ logical, intent(in) :: summaryonly
+ real(kind=rl), intent(in) :: factor
+ real(kind=rl) :: elapsedtime
+ real(kind=rl) :: t_min
+ real(kind=rl) :: t_max
+ real(kind=rl) :: t_avg
+ integer :: rank, nprocs, ierr
+ integer :: nc
+
+ t_min = 0.0_rl
+ t_max = 0.0_rl
+ t_avg = 0.0_rl
+
+
+ elapsedtime = (t%elapsed) * factor
+ call mpi_reduce(elapsedtime,t_min,1,MPI_DOUBLE_PRECISION, &
+ MPI_MIN, 0, MPI_COMM_WORLD,ierr)
+ call mpi_reduce(elapsedtime,t_avg,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM, 0, MPI_COMM_WORLD,ierr)
+ call mpi_reduce(elapsedtime,t_max,1,MPI_DOUBLE_PRECISION, &
+ MPI_MAX, 0, MPI_COMM_WORLD,ierr)
+ call mpi_comm_size(MPI_COMM_WORLD,nprocs,ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ t_avg = t_avg/nprocs
+ nc = t%ncall
+ if (nc == 0) nc = 1
+ if (summaryonly) then
+ if (rank == 0) then
+ write(TIMEROUT,'(A32," [",I7,"]: ",E10.4," / ",E10.4," / ",E10.4," (min/avg/max)")') &
+ t%label,t%ncall,t_min,t_avg,t_max
+ write(TIMEROUT,'(A32," t/call: ",E10.4," / ",E10.4," / ",E10.4," (min/avg/max)")') &
+ t%label,t_min/nc,t_avg/nc,t_max/nc
+ end if
+ else
+ write(TIMEROUT,'(A32," : ",I8," calls ",E10.4," (rank ",I8,")")') &
+ t%label,elapsedtime, rank
+ end if
+ write(TIMEROUT,'("")')
+ end subroutine print_elapsed
+
+end module timer
diff --git a/src/ZSOLVER/tridz.f90 b/src/ZSOLVER/tridz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..203c413f8251bcfb5bd4d6e242198a7923efd16d
--- /dev/null
+++ b/src/ZSOLVER/tridz.f90
@@ -0,0 +1,848 @@
+!MNH_LIC Copyright 1994-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! ################
+ MODULE MODI_TRIDZ
+! ################
+!
+INTERFACE
+!
+ SUBROUTINE TRIDZ(HLBCX,HLBCY, &
+ PMAP,PDXHAT,PDYHAT,HPRESOPT, &
+ PDXHATM,PDYHATM,PRHOM, &
+ PAF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PRHODJ,PTHVREF,PZZ,PBFY,PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+!
+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, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Potential
+ ! Temperature of the reference state
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! scale factor
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height z
+!
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane
+ ! x y localized at a mass
+ ! level
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements (yslice) of the tri-diag.
+ ! matrix in the pressure eq.
+!JUAN
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements (bsplit slide) of the tri-diag.
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+!JUAN
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXY ! - along y
+
+!
+END SUBROUTINE TRIDZ
+!
+END INTERFACE
+!
+END MODULE MODI_TRIDZ
+!
+! ###################################################################
+ SUBROUTINE TRIDZ(HLBCX,HLBCY, &
+ PMAP,PDXHAT,PDYHAT,HPRESOPT, &
+ PDXHATM,PDYHATM,PRHOM, &
+ PAF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PRHODJ,PTHVREF,PZZ,PBFY,PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+! ####################################################################
+!
+!!**** *TRIDZ * - Compute coefficients for the flat operator
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to compute the vertical time independent
+! coefficients a(k), b(k), c(k) required for the calculation of the "flat"
+! (i.e. neglecting the orography) operator Laplacian. RHOJ is averaged on
+! the whole horizontal domain. The form of the eigenvalues of the flat
+! operator depends on the lateral boundary conditions. Furthermore, this
+! routine initializes TRIGS and IFAX arrays required for the FFT transform
+! used in the routine PRECOND.
+!
+!!** METHOD
+!! ------
+!! The forms of the eigenvalues of the horizontal Laplacian are given by:
+!! Cyclic conditions:
+!! -----------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( imax ) <dyy> <dyy> ( jmax )
+!!
+!! Open conditions:
+!! -----------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( 2imax ) <dyy> <dyy> ( 2jmax )
+!!
+!! Cyclic condition along x and open condition along y:
+!! ------------------------------------------------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( imax ) <dyy> <dyy> ( 2jmax )
+!!
+!! Open condition along x and cyclic condition along y:
+!! ------------------------------------------------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( 2imax ) <dyy> <dyy> ( jmax )
+!!
+!! where m = 0,1,2....imax-1, n = 0,1,2....jmax-1
+!! Note that rhoj contains the Jacobian J = Deltax*Deltay*Deltaz = volume of
+!! an elementary mesh.
+
+!!
+!! EXTERNAL
+!! --------
+!! Function FFTFAX: initialization of TRIGSX,IFAXX,TRIGSY,IFAXY for
+!! the FFT transform
+!! GET_DIM_EXT_ll : get extended sub-domain sizes
+!! GET_INDICE_ll : get physical sub-domain bounds
+!! GET_DIM_PHYS_ll : get physical sub-domain sizes
+!! GET_GLOBALDIMS_ll : get physical global domain sizes
+!! GET_OR_ll : get origine coordonates of the physical sub-domain in global indices
+!! REDUCESUM_ll : sum into a scalar variable
+!! GET_SLICE_ll : get a slice of the global domain
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : define constants
+!! XPI : pi
+!! XCPD
+!! 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
+!! LCARTESIAN: logical for CARTESIAN geometry
+!! .TRUE. = Cartesian geometry used
+!! L2D: logical for 2D model version
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine TRIDZ)
+!!
+!! AUTHOR
+!! ------
+!! P. HÃ…reil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/07/94
+!! 14/04/95 (J. Stein) bug in the ZDZM computation
+!! ( stretched case)
+!! 8/07/96 (P. Jabouille) change the FFT initialization
+!! which now works for odd number.
+!! 14/01/97 Durran anelastic equation (Stein,Lafore)
+!! 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! 10/08/98 (N. Asencio) add parallel code
+!! use PDXHAT, PDYHAT and not PXHAT,PYHAT
+!! PBFY is initialized
+!! 20/08/00 (J. Stein, J. Escobar) optimisation of the solver
+!! PBFY transposition
+!! 14/03/02 (P. Jabouille) set values for meaningless spectral coefficients
+!! (to avoid problem in bouissinesq configuration)
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_CST
+USE MODD_CONF
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_PARAMETERS
+!
+USE MODE_ll
+USE MODE_MSG
+!JUAN P1/P2 SPLITTING
+USE MODE_SPLITTINGZ_ll , ONLY : GET_DIM_EXTZ_ll,GET_ORZ_ll,LWESTZ_ll,LSOUTHZ_ll
+!JUAN
+!
+!JUAN
+USE MODE_REPRO_SUM
+!JUAN
+USE MODE_MPPDB
+!
+USE mode_mg_main_mnh
+!
+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, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Potential
+ ! Temperature of the reference state
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! scale factor
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height z
+!
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane
+ ! x y localized at a mass
+ ! level
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements (yslice) of the tri-diag.
+! matrix in the pressure eq. which is transposed. PBFY is a y-slices structure
+!JUAN
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements (bsplit slide) of the tri-diag.
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+!JUAN
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXY ! - along y
+
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: IRESP ! FM return code
+INTEGER :: ILUOUT ! Logical unit number for
+ ! output-listing
+INTEGER :: IIB,IIE,IJB,IJE,IKB,IKE ! indice values of the physical subdomain
+INTEGER :: IKU , IKBE ! size of the arrays along z
+INTEGER :: IIB_ll,IIE_ll,IJB_ll,IJE_ll ! indice values of the physical global domain
+INTEGER :: IIMAX,IJMAX ! Number of points of the physical subdomain
+INTEGER :: IIMAX_ll,IJMAX_ll ! Number of points of Global physical domain
+!
+INTEGER :: JI,JJ,JK ! loop indexes
+!
+INTEGER :: INN ! temporary result for the computation of array TRIGS
+!
+REAL, DIMENSION (:,:), ALLOCATABLE :: ZEIGEN_ll ! eigenvalues b(m,n) in global representation
+REAL, DIMENSION (:), ALLOCATABLE :: ZEIGENX_ll ! used for the computation of ZEIGEN_ll
+!
+REAL, DIMENSION( SIZE(PDXHAT)) :: ZWORKX ! work array to compute PDXHATM
+REAL, DIMENSION( SIZE(PDYHAT)) :: ZWORKY ! work array to compute PDYHATM
+!
+REAL :: ZGWNX,ZGWNY ! greater wave numbers allowed by the model
+ ! configuration in x and y directions respectively
+!
+REAL, DIMENSION (SIZE(PZZ,3)) :: ZDZM ! mean of deltaz on the plane x y
+ ! localized at a w-level
+!
+REAL :: ZANGLE,ZDEL ! needed for the initialization of the arrays used by the FFT
+!
+REAL :: ZINVMEAN ! inverse of inner points number in an horizontal grid
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+REAL, DIMENSION (SIZE(PMAP,1)) :: ZXMAP ! extraction of PMAP array along x
+REAL, DIMENSION (SIZE(PMAP,2)) :: ZYMAP ! extraction of PMAP array along y
+INTEGER :: IORXY_ll,IORYY_ll ! origin's coordinates of the y-slices subdomain
+INTEGER :: IIUY_ll,IJUY_ll ! dimensions of the y-slices subdomain
+INTEGER :: IXMODE_ll,IYMODE_ll ! number of modes in the x and y direction for global point of view
+INTEGER :: IXMODEY_ll,IYMODEY_ll ! number of modes in the x and y direction for y_slice point of view
+!JUAN Z_SPLITTING
+INTEGER :: IORXB_ll,IORYB_ll ! origin's coordinates of the b-slices subdomain
+INTEGER :: IIUB_ll,IJUB_ll ! dimensions of the b-slices subdomain
+INTEGER :: IXMODEB_ll,IYMODEB_ll ! number of modes in the x and y direction for b_slice point of view
+!
+INTEGER :: IORX_SXP2_YP1_Z_ll,IORY_SXP2_YP1_Z_ll ! origin's coordinates of the b-slices subdomain
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll ! dimensions of the b-slices subdomain
+INTEGER :: IXMODE_SXP2_YP1_Z_ll,IYMODE_SXP2_YP1_Z_ll ! number of modes in the x and y direction for b_slice point of view
+!JUAN Z_SPLITTING
+!JUAN16
+!TYPE(DOUBLE_DOUBLE) , DIMENSION (SIZE(PZZ,3)) :: ZRHOM_ll , ZDZM_ll
+REAL, ALLOCATABLE, DIMENSION(:,:) :: ZRHOM_2D , ZDZM_2D
+REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ZDZM_ZS
+!JUAN16
+!
+!
+!
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATION
+! --------------
+!
+!* 1.1 retrieve a logical unit number
+! ------------------------------
+!
+ILUOUT = TLUOUT%NLU
+!
+!* 1.2 compute loop bounds
+! -------------------
+!
+! extended sub-domain
+CALL GET_DIM_EXT_ll ('Y',IIUY_ll,IJUY_ll)
+!JUAN Z_SPLITTING
+CALL GET_DIM_EXT_ll ('B',IIUB_ll,IJUB_ll)
+! P1/P2 splitting
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+!JUAN Z_SPLITTING
+IKU=SIZE(PRHODJ,3)
+!
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+IKB=1 +JPVEXT
+IKE=IKU -JPVEXT
+! physical sub-domain
+CALL GET_DIM_PHYS_ll ( 'B',IIMAX,IJMAX)
+!
+! global physical domain limits
+CALL GET_GLOBALDIMS_ll ( IIMAX_ll, IJMAX_ll)
+IIB_ll = 1 + JPHEXT
+IIE_ll = IIMAX_ll + JPHEXT
+IJB_ll = 1 + JPHEXT
+IJE_ll = IJMAX_ll + JPHEXT
+!
+! the use of local array ZEIGENX and ZEIGEN would require some technical modifications
+!
+ALLOCATE (ZEIGENX_ll(IIMAX_ll+2*JPHEXT))
+ALLOCATE (ZEIGEN_ll(IIMAX_ll+2*JPHEXT,IJMAX_ll+2*JPHEXT))
+
+ZEIGEN_ll = 0.0
+! Get the origin coordinates of the extended sub-domain in global landmarks
+CALL GET_OR_ll('Y',IORXY_ll,IORYY_ll)
+!JUAN Z_SPLITING
+CALL GET_OR_ll('B',IORXB_ll,IORYB_ll)
+! P1/P2 Splitting
+CALL GET_ORZ_ll('SXP2_YP1_Z',IORX_SXP2_YP1_Z_ll,IORY_SXP2_YP1_Z_ll)
+!JUAN Z_SPLITING
+!
+!* 1.3 allocate x-slice array
+
+!
+!* 1.4 variables for the eigenvalues computation
+!
+ZGWNX = XPI/REAL(IIMAX_ll)
+ZGWNY = XPI/REAL(IJMAX_ll)
+!
+!------------------------------------------------------------------------------
+!
+!* 2. COMPUTE THE AVERAGE OF RHOJ*CPD*THETAVREF ALONG XY
+! --------------------------------------------------
+!
+ZINVMEAN = 1./REAL(IIMAX_ll*IJMAX_ll)
+!JUAN16
+ALLOCATE(ZRHOM_2D(IIB:IIE, IJB:IJE))
+PRHO_ZS = 1.0
+!
+DO JK = 1,SIZE(PZZ,3)
+ IF ( CEQNSYS == 'DUR' .OR. CEQNSYS == 'MAE' ) THEN
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZRHOM_2D(JI,JJ) = PRHODJ(JI,JJ,JK)*XCPD*PTHVREF(JI,JJ,JK)
+ PRHO_ZS(JI,JJ,JK) = ZRHOM_2D(JI,JJ)
+ END DO
+ END DO
+ ELSEIF ( CEQNSYS == 'LHE' ) THEN
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZRHOM_2D(JI,JJ) = PRHODJ(JI,JJ,JK)
+ PRHO_ZS(JI,JJ,JK) = ZRHOM_2D(JI,JJ)
+ END DO
+ END DO
+ END IF
+ ! global sum
+ PRHOM(JK) = SUM_DD_R2_ll(ZRHOM_2D) * ZINVMEAN
+END DO
+
+!
+!------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE MEAN INCREMENT BETWEEN Z LEVELS
+! -------------------------------------------
+!
+ALLOCATE(ZDZM_2D(IIB:IIE, IJB:IJE))
+ALLOCATE(ZDZM_ZS(IIB:IIE, IJB:IJE,IKU))
+ZDZM_ZS = 1.0
+!
+DO JK = IKB-1,IKE
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZDZM_2D(JI,JJ) = (PZZ(JI,JJ,JK+1)-PZZ(JI,JJ,JK))
+ ZDZM_ZS(JI,JJ,JK) = ZDZM_2D(JI,JJ)
+ END DO
+ END DO
+ ZDZM(JK) = SUM_DD_R2_ll(ZDZM_2D) * ZINVMEAN
+END DO
+ZDZM(IKE+1) = ZDZM(IKE)
+ZDZM_ZS(:,:,IKE+1) = ZDZM_ZS(:,:,IKE)
+!
+! vertical average to arrive at a w-level
+DO JK = IKE+1,IKB,-1
+ ZDZM(JK) = (ZDZM(JK) + ZDZM(JK-1))*0.5
+ ZDZM_ZS(IIB:IIE,IJB:IJE,JK) = (ZDZM_ZS(IIB:IIE,IJB:IJE,JK) + ZDZM_ZS(IIB:IIE,IJB:IJE,JK-1)) * 0.5
+END DO
+!
+ZDZM(IKB-1) = -999.
+ZDZM_ZS(IIB:IIE,IJB:IJE,IKB-1) = -999.
+!
+!------------------------------------------------------------------------------
+!
+!* 4. COMPUTE THE MEAN INCREMENT BETWEEN X LEVELS
+! -------------------------------------------
+!
+PDXHATM =0.
+! . local sum
+IF (LCARTESIAN) THEN
+ PDXHATM = SUM_1DFIELD_ll ( PDXHAT,'X',IIB_ll,IIE_ll,IINFO_ll)
+ DO JJ=1,SIZE(PDXATH_ZS,2)
+ PDXATH_ZS(:,JJ) = PDXHAT(:)
+ END DO
+ELSE
+ ! Extraction of x-slice PMAP at j=(IJB_ll+IJE_ll)/2
+ CALL GET_SLICE_ll (PMAP,'X',(IJB_ll+IJE_ll)/2,ZXMAP(IIB:IIE) &
+ ,IIB,IIE,IINFO_ll)
+ ! initialize the work array = PDXHAT/ZXMAP
+ ZWORKX(IIB:IIE) = PDXHAT(IIB:IIE)/ ZXMAP (IIB:IIE)
+ PDXHATM = SUM_1DFIELD_ll ( ZWORKX,'X',IIB_ll,IIE_ll,IINFO_ll)
+ DO JJ=1,SIZE(PDXATH_ZS,2)
+ PDXATH_ZS(:,JJ) = PDXHAT(:) / PMAP(:,JJ)
+ END DO
+END IF
+! . division to complete sum
+PDXHATM = PDXHATM / REAL(IIMAX_ll)
+!
+!------------------------------------------------------------------------------
+!
+!* 5. COMPUTE THE MEAN INCREMENT BETWEEN Y LEVELS
+! -------------------------------------------
+!
+PDYHATM = 0.
+IF (LCARTESIAN) THEN
+ PDYHATM = SUM_1DFIELD_ll ( PDYHAT,'Y',IJB_ll,IJE_ll,IINFO_ll)
+ DO JI=1,SIZE(PDYATH_ZS,1)
+ PDYATH_ZS(JI,:) = PDYHAT(:)
+ END DO
+ELSE
+ ! Extraction of y-slice PMAP at i=IIB_ll+IIE_ll/2
+ CALL GET_SLICE_ll (PMAP,'Y',(IIB_ll+IIE_ll)/2,ZYMAP(IJB:IJE) &
+ ,IJB,IJE,IINFO_ll)
+ ! initialize the work array = PDYHAT / ZYMAP
+ ZWORKY(IJB:IJE) = PDYHAT(IJB:IJE) / ZYMAP (IJB:IJE)
+ PDYHATM = SUM_1DFIELD_ll ( ZWORKY,'Y',IJB_ll,IJE_ll,IINFO_ll)
+ DO JI=1,SIZE(PDYATH_ZS,1)
+ PDYATH_ZS(JI,:) = PDYHAT(:) / PMAP(JI,:)
+ END DO
+END IF
+! . division to complete sum
+PDYHATM= PDYHATM / REAL(IJMAX_ll)
+!
+!------------------------------------------------------------------------------
+!
+!* 6. COMPUTE THE OUT-DIAGONAL ELEMENTS A AND C OF THE MATRIX
+! -------------------------------------------------------
+!
+PAF_ZS = 1.0
+PCF_ZS = 1.0
+A_K = 0.0
+B_K = 0.0
+C_K = 0.0
+DO JK = IKB,IKE
+ PAF(JK) = 0.5 * ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2
+ PCF(JK) = 0.5 * ( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1) **2
+
+ PAF_ZS(IIB:IIE,IJB:IJE,JK) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,JK-1) + PRHO_ZS(IIB:IIE,IJB:IJE,JK) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,JK) **2
+ PCF_ZS(IIB:IIE,IJB:IJE,JK) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,JK) + PRHO_ZS(IIB:IIE,IJB:IJE,JK+1) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,JK+1) **2
+
+ D_K(JK) = PRHOM(JK) ! / ZDZM(JK)
+ B_K(JK) = PCF(JK) / D_K(JK)
+ C_K(JK) = PAF(JK) / D_K(JK)
+
+END DO
+
+!
+! at the upper and lower levels PAF and PCF are computed using the Neumann
+! conditions applying on the vertical component of the gradient
+!
+PAF(IKE+1) = -0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / ZDZM(IKE+1) **2
+D_K(IKE+1) = PRHOM(IKE+1) ! / ZDZM(IKE+1)
+C_K(IKE+1) = PAF(IKE+1) / D_K(IKE+1)
+
+PCF(IKB-1) = 0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / ZDZM(IKB) **2
+D_K(IKB-1) = PRHOM(IKB-1) ! / ZDZM(IKB-1)
+B_K(IKB-1) = PCF(IKB-1) / D_K(IKB-1)
+
+!
+PAF(IKB-1) = 0.0 ! 0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / ZDZM(IKB) **2
+C_K(IKB-1) = 0.0
+
+PCF(IKE+1) = 0.0 ! 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / ZDZM(IKE+1) **2
+B_K(IKE+1) = 0.0
+
+PAF_ZS(IIB:IIE,IJB:IJE,IKE+1) = -0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKE) + PRHO_ZS(IIB:IIE,IJB:IJE,IKE+1) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKE+1) **2
+PCF_ZS(IIB:IIE,IJB:IJE,IKB-1) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKB-1) + PRHO_ZS(IIB:IIE,IJB:IJE,IKB) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKB) **2
+
+PAF_ZS(IIB:IIE,IJB:IJE,IKB-1) = 0.0
+PCF_ZS(IIB:IIE,IJB:IJE,IKE+1) = 0.0
+
+IKBE = IKU
+
+IF ( HPRESOPT == 'ZSOLV' ) THEN
+ call mg_main_mnh_init(IIMAX_ll,IKBE,PDXHATM*IIMAX_ll,ZDZM(IKB)*IKBE,&
+ A_K,B_K,C_K,D_K)
+END IF
+
+!------------------------------------------------------------------------------
+!* 7. COMPUTE THE DIAGONAL ELEMENTS B OF THE MATRIX
+! ---------------------------------------------
+!
+!* 7.1 compute the horizontal eigenvalues
+!
+!
+!* 7.1.1 compute the eigenvalues along the x direction
+!
+SELECT CASE (HLBCX(1))
+! in the cyclic case, the eigenvalues are the same for two following JM values:
+! it corresponds to the real and complex parts of the FFT
+ CASE('CYCL') ! cyclic case
+ IXMODE_ll = IIMAX_ll+2*JPHEXT ! +2
+ IXMODEY_ll = IIUY_ll
+ IXMODEB_ll = IIUB_ll !JUAN Z_SPLITTING
+!
+ DO JI = 1,IXMODE_ll
+ ZEIGENX_ll(JI) = - ( 2. * SIN ( (JI-1)/2*ZGWNX ) / PDXHATM )**2
+ END DO
+ CASE DEFAULT ! other cases
+ IXMODE_ll = IIMAX_ll
+!
+!
+ IF (LEAST_ll(HSPLITTING='Y')) THEN
+ IXMODEY_ll = IIUY_ll - 2*JPHEXT ! -2
+ ELSE
+ IXMODEY_ll = IIUY_ll
+ END IF
+!JUAN Z_SPLITTING
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ IXMODEB_ll = IIUB_ll - 2*JPHEXT ! -2
+ ELSE
+ IXMODEB_ll = IIUB_ll
+ END IF
+!JUAN Z_SPLITTING
+!
+!
+ DO JI = 1,IXMODE_ll
+ ZEIGENX_ll(JI) = - ( 2. *SIN (0.5*REAL(JI-1)*ZGWNX ) / PDXHATM )**2
+ END DO
+END SELECT
+!
+!* 7.1.2 compute the eventual eigenvalues along the y direction
+!
+IF (.NOT. L2D) THEN
+!
+! y lateral boundary conditions for three-dimensional cases
+!
+ SELECT CASE (HLBCY(1))
+! in the cyclic case, the eigenvalues are the same for two following JN values:
+! it corresponds to the real and complex parts of the FFT result
+!
+ CASE('CYCL') ! 3D cyclic case
+ IYMODE_ll = IJMAX_ll+2*JPHEXT ! +2
+ IYMODEY_ll = IJUY_ll
+ IYMODEB_ll = IJUB_ll !JUAN Z_SPLITTING
+!
+ DO JJ = 1,IYMODE_ll
+ DO JI = 1,IXMODE_ll
+ ZEIGEN_ll(JI,JJ) = ZEIGENX_ll(JI) - &
+ ( 2.* SIN ( (JJ-1)/2*ZGWNY ) / PDYHATM )**2
+ END DO
+ END DO
+!
+ CASE DEFAULT ! 3D non-cyclic cases
+ IYMODE_ll = IJMAX_ll
+ IYMODEY_ll = IJUY_ll - 2*JPHEXT ! -2
+ IYMODEB_ll = IJUB_ll - 2*JPHEXT ! -2 JUAN Z_SPLITTING
+!
+ DO JJ = 1,IYMODE_ll
+ DO JI = 1,IXMODE_ll
+ ZEIGEN_ll(JI,JJ) = ZEIGENX_ll(JI) - ( 2.* SIN (0.5*REAL(JJ-1)*ZGWNY ) / &
+ PDYHATM )**2
+ END DO
+ END DO
+!
+ END SELECT
+ELSE
+!
+! copy the x eigenvalue array in a 2D array for a 2D case
+!
+ IYMODE_ll = 1
+ IYMODEY_ll = 1
+ ZEIGEN_ll(1:IXMODE_ll,1)=ZEIGENX_ll(1:IXMODE_ll)
+!
+END IF
+!
+DEALLOCATE(ZEIGENX_ll)
+!
+!CALL MPPDB_CHECK2D(ZEIGEN_ll,"TRIDZ::ZEIGEN_ll",PRECISION)
+!
+!
+!* 7.2 compute the matrix diagonal elements
+!
+!
+PBFY = 1.
+PBFB = 1. ! JUAN Z_SLIDE
+PBF_SXP2_YP1_Z = 1. ! JUAN Z_SLIDE
+!
+IF (L2D) THEN
+ DO JK= IKB,IKE
+ DO JJ= 1, IYMODEY_ll
+ DO JI= 1, IXMODEY_ll
+ PBFY(JI,JJ,JK) = PRHOM(JK)* ZEIGEN_ll(JI+IORXY_ll-1,JJ+IORYY_ll-1) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFY is computed using the Neumann
+! condition
+!
+ PBFY(1:IXMODEY_ll,1:IYMODEY_ll,IKB-1) = -0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / &
+ ZDZM(IKB) **2
+ !
+ PBFY(1:IXMODEY_ll,1:IYMODEY_ll,IKE+1) = 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / &
+ ZDZM(IKE+1) **2
+ !
+ELSE
+ DO JK= IKB,IKE
+ DO JJ= 1, IYMODEY_ll
+ DO JI= 1, IXMODEY_ll
+ PBFY(JJ,JI,JK) = PRHOM(JK)* ZEIGEN_ll(JI+IORXY_ll-1,JJ+IORYY_ll-1) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFY is computed using the Neumann
+! condition
+!
+ PBFY(1:IYMODEY_ll,1:IXMODEY_ll,IKB-1) = -0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / &
+ ZDZM(IKB) **2
+ !
+ PBFY(1:IYMODEY_ll,1:IXMODEY_ll,IKE+1) = 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / &
+ ZDZM(IKE+1) **2
+ !
+
+!JUAN Z_SPLITTING
+!JUAN for Z splitting we need to do the vertical substitution
+!JUAN in Bsplitting slides so need PBFB
+PBF_ZS = 1.0
+ DO JK= IKB,IKE
+ DO JJ= IJB,IJE
+ DO JI= IIB,IIE
+
+ PBFB(JI,JJ,JK) = PRHOM(JK)* ( -2.0 / PDXHATM**2 -2.0 /PDYHATM**2 ) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+
+ PBF_ZS(JI,JJ,JK) = PRHO_ZS(JI,JJ,JK)* ( -2.0 / PDXATH_ZS(JI,JJ)**2 -2.0 /PDYATH_ZS(JI,JJ)**2 ) - 0.5 * &
+ ( ( PRHO_ZS(JI,JJ,JK-1) + PRHO_ZS(JI,JJ,JK) ) / ZDZM_ZS(JI,JJ,JK) **2 &
+ +( PRHO_ZS(JI,JJ,JK) + PRHO_ZS(JI,JJ,JK+1) ) / ZDZM_ZS(JI,JJ,JK+1)**2 )
+
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFB is computed using the Neumann
+! condition
+!
+ PBFB(IIB:IIE,IJB:IJE,IKB-1) = - 0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / ZDZM(IKB) **2
+ !
+ PBFB(IIB:IIE,IJB:IJE,IKE+1) = + 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / ZDZM(IKE+1) **2
+
+ PBF_ZS(IIB:IIE,IJB:IJE,IKB-1) = - 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKB-1) + PRHO_ZS(IIB:IIE,IJB:IJE,IKB) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKB)**2
+
+ PBF_ZS(IIB:IIE,IJB:IJE,IKE+1) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKE) + PRHO_ZS(IIB:IIE,IJB:IJE,IKE+1) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKE+1)**2
+!
+IF (HLBCX(1) == 'CYCL' .AND. .NOT.(L2D) ) THEN
+ !JUAN
+ ! fil unused 2 coef with NI+1 coef (lost in Z transposition elsewhere )
+ JI = IXMODE_ll -1
+ ZEIGEN_ll(2,:) = ZEIGEN_ll(JI,:)
+END IF
+IF (HLBCY(1) == 'CYCL' .AND. .NOT.(L2D) ) THEN
+ !JUAN
+ ! fill unused (:,2,:) coef with NJ+1 coef (lost in Z transposition elsewhere )
+ JJ = IYMODE_ll -1
+ ZEIGEN_ll(:,2) = ZEIGEN_ll(:,JJ)
+END IF
+ !
+!JUAN Z_SPLITTING
+!JUAN Z_SPLITTING
+!JUAN for Z splitting we need to do the vertical substitution
+!JUAN in _SXP2_YP1_Zsplitting slides so need PBF_SXP2_YP1_Z
+ DO JK=IKB,IKE
+ DO JJ= 1, IJU_SXP2_YP1_Z_ll
+ DO JI= 1, IIU_SXP2_YP1_Z_ll
+ PBF_SXP2_YP1_Z(JI,JJ,JK) = PRHOM(JK)* ZEIGEN_ll(JI+IORX_SXP2_YP1_Z_ll-IIB_ll,JJ+IORY_SXP2_YP1_Z_ll-IJB_ll) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFB is computed using the Neumann
+! condition
+!
+ PBF_SXP2_YP1_Z(1:IIU_SXP2_YP1_Z_ll,1:IJU_SXP2_YP1_Z_ll,IKB-1) = -0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / &
+ ZDZM(IKB) **2
+ !
+ PBF_SXP2_YP1_Z(1:IIU_SXP2_YP1_Z_ll,1:IJU_SXP2_YP1_Z_ll,IKE+1) = 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / &
+ ZDZM(IKE+1) **2
+ !
+!JUAN Z_SPLITTING
+END IF
+!
+! second coefficent is meaningless in cyclic case
+IF (HLBCX(1) == 'CYCL' .AND. L2D .AND. SIZE(PBFY,1) .GE. 2 ) PBFY(2,:,:)=1.
+IF (HLBCX(1) == 'CYCL' .AND. .NOT.(L2D) .AND. LWEST_ll(HSPLITTING='Y') .AND. SIZE(PBFY,2) .GE.2 ) &
+ PBFY(:,2,:)=1.
+IF (HLBCY(1) == 'CYCL' .AND. .NOT.(L2D) .AND. SIZE(PBFY,1) .GE. 2 ) PBFY(2,:,:)=1.
+!JUAN Z_SPLITTING
+! second coefficent is meaningless in cyclic case
+!IF (HLBCX(1) == 'CYCL' .AND. L2D .AND. SIZE(PBFB,1) .GE. 2 ) PBFB(2,:,:)=1.
+!IF (HLBCX(1) == 'CYCL' .AND. .NOT.(L2D) .AND. LWEST_ll(HSPLITTING='B') .AND. SIZE(PBFB,2) .GE.2 ) &
+! PBFB(:,2,:)=1.
+!IF (HLBCY(1) == 'CYCL' .AND. .NOT.(L2D) .AND. SIZE(PBFB,1) .GE. 2 ) PBFB(2,:,:)=1.
+!JUAN Z_SPLITTING
+!
+DEALLOCATE(ZEIGEN_ll)
+!
+!
+!------------------------------------------------------------------------------
+!* 8. INITIALIZATION OF THE TRIGS AND IFAX ARRAYS FOR THE FFT
+! -------------------------------------------------------
+!
+! 8.1 x lateral boundary conditions
+!
+CALL SET99(PTRIGSX,KIFAXX,IIMAX_ll)
+!
+! test on the value of KIMAX: KIMAX must be factorizable as a product
+! of powers of 2,3 and 5. KIFAXX(10) is equal to IIMAX if the decomposition
+! is correct, then KIFAXX(1) contains the number of decomposition factors
+! of KIMAX.
+!
+IF (KIFAXX(10) /= IIMAX_ll) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' ERROR',/, &
+ &' : THE FORM OF THE FFT USED FOR THE INVERSION OF THE FLAT ',/,&
+ &' OPERATOR REQUIRES THAT KIMAX MUST BE FACTORIZABLE' ,/,&
+ & ' AS A PRODUCT OF POWERS OF 2, 3 AND 5.')")
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','TRIDZ','')
+END IF
+!
+IF (HLBCX(1) /= 'CYCL') THEN
+!
+! extra trigs for shifted (co) sine transform (FFT55)
+!
+ INN=2*(IIMAX_ll)
+ ZDEL=ASIN(1.0)/REAL(IIMAX_ll)
+ DO JI=1,IIMAX_ll
+ ZANGLE=REAL(JI)*ZDEL
+ PTRIGSX(INN+JI)=SIN(ZANGLE)
+ END DO
+!
+ENDIF
+!
+! 8.2 y lateral boundary conditions
+!
+IF (.NOT. L2D) THEN
+ CALL SET99(PTRIGSY,KIFAXY,IJMAX_ll)
+ !
+ ! test on the value of KJMAX: KJMAX must be factorizable as a product
+ ! of powers of 2,3 and 5. KIFAXY(10) is equal to IJMAX_ll if the decomposition
+ ! is correct, then KIFAXX(1) contains the number of decomposition factors
+ ! of IIMAX_ll.
+ !
+ IF (KIFAXY(10) /= IJMAX_ll) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' ERROR',/, &
+ &' : THE FORM OF THE FFT USED FOR THE INVERSION OF THE FLAT ',/,&
+ &' OPERATOR REQUIRES THAT KJMAX MUST BE FACTORIZABLE' ,/,&
+ & ' AS A PRODUCT OF POWERS OF 2, 3 AND 5.')")
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','TRIDZ','')
+ END IF
+ !
+ !
+ ! other cases
+ !
+ IF (HLBCY(1) /= 'CYCL') THEN
+ !
+ ! extra trigs for shifted (co) sine transform
+ !
+ INN=2*(IJMAX_ll)
+ ZDEL=ASIN(1.0)/REAL(IJMAX_ll)
+ DO JJ=1,IJMAX_ll
+ ZANGLE=REAL(JJ)*ZDEL
+ PTRIGSY(INN+JJ)=SIN(ZANGLE)
+ END DO
+ !
+ ENDIF
+ !
+ENDIF
+!
+!------------------------------------------------------------------------------
+!
+END SUBROUTINE TRIDZ
diff --git a/src/ZSOLVER/zconjgrad.f90 b/src/ZSOLVER/zconjgrad.f90
new file mode 100644
index 0000000000000000000000000000000000000000..35d82862f990a91586103de8401beed89b72f1a0
--- /dev/null
+++ b/src/ZSOLVER/zconjgrad.f90
@@ -0,0 +1,292 @@
+!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_ZCONJGRAD
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE ZCONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI)
+!
+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
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+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
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+!
+END SUBROUTINE ZCONJGRAD
+!
+END INTERFACE
+!
+END MODULE MODI_ZCONJGRAD
+!
+!
+!
+! #########################################################################
+ SUBROUTINE ZCONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI)
+! #########################################################################
+!
+!!**** *CONJGRAD * - solve an elliptic equation by the conjugate gradient
+!! method
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to solve an elliptic equation using
+! the preditioned conjugate gradient (CG) method. This is a version of the
+! CG called ORTHOMIN (Young and Jea 1980).
+!
+!!** METHOD
+!! ------
+!! The equation to be solved reads:
+!!
+!! Q (PHI) = Y
+!!
+!! where Q is the quasi-Laplacian ( subroutine QLAP ) and PHI the pressure
+!! function.
+!! We precondition the problem by the operator F :
+!! -1 -1
+!! F * Q (PHI) = F (Y)
+!! F represents the flat Laplacian ie. without orography. Its inversion is
+!! realized in the routine FLAT_INV. This equation is solved with a Conjugate
+!! Gradient method.
+!! The initial guess is given by the pressure at the previous time step.
+!! The resolution stops after ITR iterations of the solver.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine GDIV: compute J times the divergence of 1/J times a vector
+!! Function QLAP: compute the complete quasi-Laplacian Q
+!! Subroutine FLAT_INV : invert the flat quasi-laplacien F
+!! Function DOTPROD: compute the dot product of 2 vectors
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODI_GDIV: interface for the subroutine GDIV
+!! Module MODI_QLAP: interface for the function QLAP
+!! Module MODI_FLAT_INV: interface for the subroutine FLAT_INV
+!! Module MODI_DOTPROD: interface for the function DOTPROD
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine CONJGRAD)
+!! Kapitza and Eppel (1992) Beit. Physik ...
+!! Young and Jea (1980) ....
+!!
+!! AUTHOR
+!! ------
+!! P. HÅreil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/07/94
+!!
+!! 14/01/97 Durran anelastic equation (Stein,Lafore)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_GDIV
+USE MODI_QLAP
+USE MODI_FLAT_INV
+USE MODI_DOTPROD
+USE MODI_ZSOLVER_INV
+!
+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
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+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
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: JM ! loop index
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZDELTA
+ ! array containing the auxilary field DELTA of the CG method
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZP
+ ! array containing the auxilary field P of the CG method
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZWORK ! work
+ ! array containing the source term to be multiplied by the F inverse
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZWORKD ! work
+ ! array containing the result of the F inversion * Q (DELTA)
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZWORKP ! work
+ ! array containing the result of the F inversion * Q (P)
+!
+REAL :: ZALPHA, ZLAMBDA ! amplitude of the descent in the Conjugate
+ ! directions
+REAL :: ZDOTPP ! dot product of ZWORKP by itself
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATIONS
+! ---------------
+!
+ZLAMBDA = 0.
+ZP = 0.
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ITERATIVE LOOP
+! --------------
+!
+DO JM = 1,KITR
+!
+!* 2.1 compute the new pressure function
+!
+ PPHI = PPHI + ZLAMBDA * ZP ! the case JM =0 is special because
+ ! PPHI is not changed
+!
+!* 2.2 compute the auxiliary field DELTA
+!
+! -1
+! compute the vector DELTA = F * ( Y - Q ( PHI ) )
+!
+ ZWORK = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PPHI)
+ ! Q (PHI)
+!
+ ZWORK = PY - ZWORK ! Y - Q (PHI)
+!
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &! -1
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZWORK,ZDELTA) ! F (Y - Q (PHI)))
+!
+!* 2.3 compute the auxiliary field P
+!
+! -1
+! compute the vector P = DELTA + alpha F * Q ( DELTA )
+!
+ IF (JM == 1) THEN
+ ZP = ZDELTA ! P = DELTA at the first solver iteration
+ ELSE
+ ZWORK = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY, &
+ PDZZ,PRHODJ,PTHETAV,ZDELTA) ! Q ( DELTA )
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, & ! -1
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZWORK,ZWORKD) ! F * Q ( DELTA )
+!
+ ZALPHA = - DOTPROD(ZWORKD,ZWORKP,HLBCX,HLBCY)/ZDOTPP ! ZWORKP,ZDOTPP come
+ ! from the previous solver iteration (section 2.4)
+ ZP = ZDELTA + ZALPHA * ZP ! new vector P
+!
+ END IF
+!
+!* 2.4 compute LAMBDA
+!
+!
+ ZWORK = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,&
+ PDZZ,PRHODJ,PTHETAV,ZP) ! Q ( P )
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,& ! -1
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZWORK,ZWORKP) ! F * Q ( P )
+!
+! store the scalar product to compute lambda and next P
+ ZDOTPP = DOTPROD(ZWORKP,ZWORKP,HLBCX,HLBCY)
+!
+ ZLAMBDA = DOTPROD(ZDELTA,ZWORKP,HLBCX,HLBCY) / ZDOTPP ! lambda
+!
+!
+END DO ! end of the loop for the iterative solver
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE FINAL PRESSURE FUNCTION
+! -----------------------------------
+!
+PPHI = PPHI + ZLAMBDA * ZP
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE ZCONJGRAD
diff --git a/src/ZSOLVER/zsolver.f90 b/src/ZSOLVER/zsolver.f90
new file mode 100644
index 0000000000000000000000000000000000000000..67c35779264fbbf9c63b31a89c940a7c27ad8c41
--- /dev/null
+++ b/src/ZSOLVER/zsolver.f90
@@ -0,0 +1,295 @@
+!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_ZSOLVER
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE ZSOLVER(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+!
+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
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual pot. temp. at time t
+!
+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 ! XRHODJ mean on the X Y plane
+ ! 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
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+!
+END SUBROUTINE ZSOLVER
+!
+END INTERFACE
+!
+END MODULE MODI_ZSOLVER
+!
+!
+!
+! #########################################################################
+ SUBROUTINE ZSOLVER(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+! #########################################################################
+!
+!!**** *CONRESOL * - solve an elliptic equation by the conjugate residual
+!! method
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to solve an elliptic equation using
+! the preconditioned conjugate residual (CR) method. This is a version
+! of the scheme proposed by Skamarock, Smolarkiewicz and Klemp (MWR, 1997).
+!
+!!** METHOD
+!! ------
+!! The equation to be solved reads:
+!!
+!! Q (PHI) = Y
+!!
+!! where Q is the quasi-Laplacian ( subroutine QLAP ) and PHI the pressure
+!! function.
+!! We precondition the problem by the operator F :
+!! -1 -1
+!! F * Q (PHI) = F (Y)
+!! F represents the flat Laplacian ie. without orography. Its inversion is
+!! realized in the routine FLAT_INV. This equation is solved with a Conjugate
+!! Residual method.
+!! The initial guess is given by the pressure at the previous time step.
+!! The resolution stops after ITR iterations of the solver.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine GDIV: compute J times the divergence of 1/J times a vector
+!! Function QLAP: compute the complete quasi-Laplacian Q
+!! Subroutine FLAT_INV : invert the flat quasi-laplacien F
+!! Function DOTPROD: compute the dot product of 2 vectors
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODI_GDIV: interface for the subroutine GDIV
+!! Module MODI_QLAP: interface for the function QLAP
+!! Module MODI_FLAT_INV: interface for the subroutine FLAT_INV
+!! Module MODI_DOTPROD: interface for the function DOTPROD
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine CONRESOL)
+!! Skamarock, Smolarkiewicz and Klemp (1997) MWR
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty *Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/08/99
+!! J.-P. Pinty & P. Jabouille
+!! 11/07/00 bug in ZALPHA
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_GDIV
+USE MODI_QLAP
+USE MODI_FLAT_INV
+USE MODI_ZSOLVER_INV
+USE MODI_DOTPROD
+!
+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
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual pot. temp. at time t
+!
+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
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: JM ! loop index
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZDELTA, ZKSI
+ ! array containing the auxilary fields DELTA and KSI of the CR method
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZP, ZQ
+ ! array containing the auxilary fields P and Q of the CR method
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZRESIDUE
+ ! array containing the error field at each iteration Q(PHI) - Y
+!
+REAL :: ZALPHA, ZLAMBDA ! amplitude of the descent in the Conjugate
+ ! directions
+REAL :: ZDOT_DELTA ! dot product of ZDELTA by itself
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATIONS
+! ---------------
+!
+!
+!* 1.1 compute the vector: r^(0) = Q(PHI) - Y
+!
+ZRESIDUE = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PPHI) - PY
+!
+!* 1.2 compute the vector: p^(0) = F^(-1)*( Q(PHI) - Y )
+!
+CALL ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZRESIDUE,ZP, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+!* 1.3 compute the vector: delta^(0) = Q ( p^(0) )
+!
+ZDELTA = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZP)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ITERATIVE LOOP
+! --------------
+!
+DO JM = 1,KITR
+!
+!* 2.1 compute the step LAMBDA
+!
+ ZDOT_DELTA = DOTPROD(ZDELTA, ZDELTA,HLBCX,HLBCY) ! norm of DELTA
+ ZLAMBDA = - DOTPROD(ZRESIDUE,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA
+!
+!* 2.2 update the pressure function PHI
+!
+ PPHI = PPHI + ZLAMBDA * ZP
+!
+!
+ IF( JM == KITR ) EXIT
+!
+!
+!* 2.3 update the residual error: r
+!
+ ZRESIDUE = ZRESIDUE + ZLAMBDA * ZDELTA
+!
+!* 2.4 compute the vector: q = F^(-1)*( Q(PHI) - Y )
+!
+ CALL ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZRESIDUE,ZQ, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+!* 2.5 compute the auxiliary field: ksi = Q ( q )
+!
+ ZKSI= QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZQ)
+! -1
+!* 2.6 compute the step ALPHA
+!
+ ZALPHA = - DOTPROD(ZKSI,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA ! lambda
+!
+!* 2.7 update p and DELTA
+!
+ ZP = ZQ + ZALPHA * ZP
+ ZDELTA = ZKSI + ZALPHA * ZDELTA
+!
+END DO ! end of the loop for the iterative solver
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE ZSOLVER
diff --git a/src/ZSOLVER/zsolver_inv.f90 b/src/ZSOLVER/zsolver_inv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..781ebb8f4f98ea8a6436e84983805513ca65fc5e
--- /dev/null
+++ b/src/ZSOLVER/zsolver_inv.f90
@@ -0,0 +1,1132 @@
+!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_ZSOLVER_INV
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+!
+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
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+!
+!
+END SUBROUTINE ZSOLVER_INV
+!
+END INTERFACE
+!
+END MODULE MODI_ZSOLVER_INV
+! ######################################################################
+SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+ ! ######################################################################
+ !
+ !!**** *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
+ USE MODI_GET_HALO
+ USE MODI_FLAT_INV
+ USE MODI_DOTPROD
+ !
+ USE mode_mg_main_mnh
+ !
+ 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
+ !
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+ REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+ REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+ !
+ !* 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
+ !
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZF_1_Y,ZCORREC,ZP
+ !
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRESIDUE,ZDELTA,ZQ,ZKSI
+ !
+ REAL :: ZDOT_DELTA,ZLAMBDA,ZALPHA
+ !
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZY_RES_FLAT,ZF_1_Y_FLAT
+ !
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZY_K , ZF_1_Y_K , ZPF_1_Y_K , ZP_K, ZCORREC_K
+ !
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZY_MG,ZPF_1_Y_MG
+ !
+ INTEGER :: JM , KITR
+ !
+ LOGICAL :: GRICHARDSON , GMG_K
+ !
+ LOGICAL,SAVE :: GFIRST_CALL_ZSOL = .TRUE.
+ !
+ INTEGER :: IIU,IJU
+ REAL :: ZMEAN
+ INTEGER :: IT , NT
+ REAL :: ZOMEGA
+ !
+ REAL , DIMENSION(5) :: Alpha_T
+ !-------------------------------------------------------------------------------
+ !
+ !* 1. COMPUTE LOOP BOUNDS
+ ! -------------------
+ !
+ !CALL GET_PHYSICAL_ll(IIB,IJB,IIE,IJE)
+ CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+ CALL GET_DIM_EXT_ll('X',IIX,IJX)
+ CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+ CALL GET_DIM_EXT_ll('B',IIU,IJU)
+ 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(IIU,IJU))
+ ALLOCATE(ZGAM(IIU,IJU,IKU))
+ IF (.NOT. L2D) THEN
+ ALLOCATE(ZBAND_YT(IJY,IIY,IKU))
+ ALLOCATE(ZBAND_YRT(IJY,IIY,IKU))
+ END IF
+ ALLOCATE(ZF_1_Y(IIU,IJU,IKU))
+ ALLOCATE(ZCORREC(IIU,IJU,IKU))
+ ALLOCATE(ZP(IIU,IJU,IKU))
+ ALLOCATE(ZRESIDUE(IIU,IJU,IKU))
+ ALLOCATE(ZDELTA(IIU,IJU,IKU))
+ ALLOCATE(ZQ(IIU,IJU,IKU))
+ ALLOCATE(ZKSI(IIU,IJU,IKU))
+ ALLOCATE(ZY_RES_FLAT(IIU,IJU,IKU))
+ ALLOCATE(ZF_1_Y_FLAT(IIU,IJU,IKU))
+ !
+ ALLOCATE(ZY_K(IIU,IJU,IKU))
+ ALLOCATE(ZF_1_Y_K(IIU,IJU,IKU))
+ ALLOCATE(ZPF_1_Y_K(IIU,IJU,IKU))
+ ALLOCATE(ZCORREC_K(IIU,IJU,IKU))
+ ALLOCATE(ZP_K(IIU,IJU,IKU))
+ ALLOCATE(ZY_MG(IIU,IJU,IKU))
+ ALLOCATE(ZPF_1_Y_MG(IIU,IJU,IKU))
+ !
+ ZDXM2 = PDXHATM*PDXHATM
+ ZDYM2 = PDYHATM*PDYHATM
+ !
+ !
+!!$ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &! -1
+!!$ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,ZF_1_Y_FLAT) ! F (Y - Q (PHI)))
+!!$ CALL PF(ZY_RES_FLAT,ZF_1_Y_FLAT)
+!!$ ZY_RES_FLAT = ZY_RES_FLAT - PY
+!!$
+!!$ ZPF_1_Y_K = 0.0
+!!$ ZF_1_Y_K = 0.0
+!!$ ZF_1_Y_K(IIB:IIE,IJB:IJE,:) = ZF_1_Y_FLAT(IIB:IIE,IJB:IJE,:)
+!!$
+!!$
+!!$ CALL PF_K(ZY_K,ZF_1_Y_K)
+!!$ !ZY_K = ZY_K / ZDXM2
+!!$ ZY_K = ZY_K - PY
+
+ !
+ !-------------------------------------------------------------------------------
+ !
+ !* 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)
+ !ZY(IIB,JJ,JK) = 2.0 * ZY(IIB+2,JJ,JK) - ZY(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)
+ !ZY(IIE,JJ,JK) = 2.0 * ZY(IIE-2,JJ,JK) - ZY(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)
+ !ZY(JI,IJB,JK) = 2.0 * ZY(JI,IJB+2,JK) - ZY(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)
+ !ZY(JI,IJE,JK) = 2.0 * ZY(JI,IJE-2,JK) - ZY(JI,IJE-1,JK)
+ END DO
+ END DO
+ END IF
+ END IF
+ !
+ !-------------------------------------------------------------------------------
+ !
+ !* 5. MATRIX INVERSION FOR THE FLAT OPERATOR
+ ! --------------------------------------
+ !
+ IF (L2D) THEN
+ CALL FAST_SUBSTITUTION_2D(ZBAND_YR,ZBETX,PBFB,ZGAM,PCF,ZAF &
+ ,ZBAND_Y,IIY,IJY,IKU)
+ ELSE
+
+ call mg_main_initialise_rhs_mnh(IIB,IIE,IIU,IJB,IJE,IJU,IKU,ZY)
+ ZPF_1_Y_MG = 0.
+ call mg_main_initialise_u_mnh(IIB,IIE,IIU,IJB,IJE,IJU,IKU,ZPF_1_Y_MG)
+
+ !print*,'************************ mg_main_mnh_solve ***************************'
+
+ call mg_main_mnh_solve()
+ call mg_main_get_u_mnh(IIB,IIE,IIU,IJB,IJE,IJU,IKU,ZPF_1_Y_MG)
+
+ PF_1_Y = ZPF_1_Y_MG
+ !goto 10000
+
+!!$ CALL PF_K(ZY_MG,ZPF_1_Y_MG)
+!!$ !ZY_MG = ZY_MG / ZDXM2
+!!$ ZY_MG = ZY_MG - PY
+ goto 10000
+
+GMG_K = .TRUE. ! .FALSE. ! .TRUE.
+
+ IF (GMG_K) THEN
+ ZY_K = ZY
+ CALL TRIDIAG_SOLVE_K(ZY_K,ZF_1_Y_K)
+ CALL GET_HALO(ZF_1_Y_K)
+ ELSE
+ CALL FAST_SUBSTITUTION_3D(ZF_1_Y,ZBETX,PBFB,ZGAM,PCF,PAF &
+ ,ZY,IIU,IJU,IKU)
+ CALL PF_1_Y_BOUND(ZF_1_Y)
+
+ CALL GET_HALO(ZF_1_Y)
+ END IF
+
+ IF (GFIRST_CALL_ZSOL) THEN
+ !GFIRST_CALL_ZSOL = .FALSE.
+ IF (GMG_K) THEN
+ ZPF_1_Y_K = ZF_1_Y_K
+ ELSE
+ PF_1_Y = ZF_1_Y ! when no first guess is available, we take the solution
+ END IF
+ ! for the flat problem
+ END IF
+!
+!
+GRICHARDSON = .FALSE. ! .FALSE. ! .TRUE.
+ ! FLAT_INV :: 4IT 3D_128X128 / 5IT REU 128x128
+ KITR = 11 ! CONRES :: 16IT 3D 128X128 / 7IT REU 128x128
+ NT = 11 ; ZOMEGA = 1.0 ! RICH :: 36IT 3D 128X128 / 26IT REU 128x128
+IF ( GRICHARDSON ) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!! RICHARDSON
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !NT = 1000 ; ZOMEGA = 1.0
+ !NT = 11 ; ZOMEGA = 1.0 ! 12IT
+ !NT = 101 ; ZOMEGA = 1.0 ! 6IT
+ NT = 401 ; ZOMEGA = 1.0 ! 1.0 ! 5IT
+
+IF (GMG_K) THEN
+
+DO IT = 1,NT
+!
+ CALL PF_K(ZP_K,ZPF_1_Y_K) ! Q (PF_1_Y)
+!
+ ZCORREC_K = 0.
+!
+ CALL TRIDIAG_SOLVE_K(ZP_K,ZCORREC_K) ! zcorrec = F-1 * Q (PF_1_Y)
+! -1 -1
+! update the iterative solution PHI = PHI + relax* (F (Y) - F * Q (PHI))
+!
+ ZP_K = ZF_1_Y_K - ZCORREC_K ! for totalview
+ ZPF_1_Y_K = ZPF_1_Y_K + ZOMEGA * (ZF_1_Y_K - ZCORREC_K)
+ CALL GET_HALO(ZPF_1_Y_K)
+!
+END DO
+
+PF_1_Y = ZPF_1_Y_K
+
+ELSE
+
+DO IT = 1,NT
+!
+ CALL PF(ZP,PF_1_Y) ! Q (PF_1_Y)
+!
+ ZCORREC = 0.
+!
+ CALL FAST_SUBSTITUTION_3D(ZCORREC,ZBETX,PBFB,ZGAM,PCF,PAF &
+ ,ZP,IIU,IJU,IKU) ! zcorrec = F-1 * Q (PF_1_Y)
+ CALL PF_1_Y_BOUND(ZCORREC)
+! -1 -1
+! update the iterative solution PHI = PHI + relax* (F (Y) - F * Q (PHI))
+!
+ ZP = ZF_1_Y - ZCORREC ! for totalview
+ PF_1_Y = PF_1_Y + ZOMEGA * (ZF_1_Y - ZCORREC)
+ CALL PF_1_Y_BOUND(PF_1_Y)
+ CALL GET_HALO(PF_1_Y)
+!
+END DO
+
+ENDIF
+
+ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!! CONJUGE RESIDUAL
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!$KITR = 101
+ZRESIDUE = 0.0
+ZP=0.0
+ZDELTA=0.0
+ZQ=0.0
+ZKSI=0.0
+
+IF (GMG_K) THEN
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATIONS
+! ---------------
+!
+!
+!* 1.1 compute the vector: r^(0) = Q(PHI) - Y
+!
+CALL PF_K(ZRESIDUE,ZPF_1_Y_K)
+ZRESIDUE = ZRESIDUE - ZY_K
+!
+!* 1.2 compute the vector: p^(0) = F^(-1)*( Q(PHI) - Y )
+!
+CALL TRIDIAG_SOLVE_K(ZRESIDUE,ZP)
+CALL GET_HALO(ZP)
+!
+!* 1.3 compute the vector: delta^(0) = Q ( p^(0) )
+!
+CALL PF_K(ZDELTA,ZP)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ITERATIVE LOOP
+! --------------
+!
+DO JM = 1,KITR
+ !
+ !* 2.1 compute the step LAMBDA
+ !
+ ZDOT_DELTA = DOTPROD(ZDELTA, ZDELTA,HLBCX,HLBCY) ! norm of DELTA
+ ZLAMBDA = - DOTPROD(ZRESIDUE,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA
+ !
+ !* 2.2 update the pressure function PHI
+ !
+ ZPF_1_Y_K = ZPF_1_Y_K + ZLAMBDA * ZP
+ CALL GET_HALO(ZPF_1_Y_K)
+ !
+ !
+ IF( JM == KITR ) EXIT
+ !
+ !
+ !* 2.3 update the residual error: r
+ !
+ ZRESIDUE = ZRESIDUE + ZLAMBDA * ZDELTA
+ !
+ !* 2.4 compute the vector: q = F^(-1)*( Q(PHI) - Y )
+ !
+ CALL TRIDIAG_SOLVE_K(ZRESIDUE,ZQ)
+ CALL GET_HALO(ZQ)
+ !
+ !* 2.5 compute the auxiliary field: ksi = Q ( q )
+ !
+ CALL PF_K(ZKSI,ZQ)
+ ! -1
+ !* 2.6 compute the step ALPHA
+ !
+ ZALPHA = - DOTPROD(ZKSI,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA ! lambda
+ !
+ !* 2.7 update p and DELTA
+ !
+ ZP = ZQ + ZALPHA * ZP
+ ZDELTA = ZKSI + ZALPHA * ZDELTA
+ !
+END DO ! end of the loop for the iterative solver
+
+PF_1_Y = ZPF_1_Y_K
+
+ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!! CONJUGE RESIDUAL
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATIONS
+! ---------------
+!
+!
+!* 1.1 compute the vector: r^(0) = Q(PHI) - Y
+!
+CALL PF(ZRESIDUE,PF_1_Y)
+ZRESIDUE = ZRESIDUE - PY
+!
+!* 1.2 compute the vector: p^(0) = F^(-1)*( Q(PHI) - Y )
+!
+CALL FAST_SUBSTITUTION_3D(ZP,ZBETX,PBFB,ZGAM,PCF,PAF &
+ ,ZRESIDUE,IIU,IJU,IKU)
+CALL PF_1_Y_BOUND(ZP)
+CALL GET_HALO(ZP)
+!
+!* 1.3 compute the vector: delta^(0) = Q ( p^(0) )
+!
+CALL PF(ZDELTA,ZP)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ITERATIVE LOOP
+! --------------
+!
+DO JM = 1,KITR
+ !
+ !* 2.1 compute the step LAMBDA
+ !
+ ZDOT_DELTA = DOTPROD(ZDELTA, ZDELTA,HLBCX,HLBCY) ! norm of DELTA
+ ZLAMBDA = - DOTPROD(ZRESIDUE,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA
+ !
+ !* 2.2 update the pressure function PHI
+ !
+ PF_1_Y = PF_1_Y + ZLAMBDA * ZP
+ CALL PF_1_Y_BOUND(PF_1_Y)
+ CALL GET_HALO(PF_1_Y)
+ !
+ !
+ IF( JM == KITR ) EXIT
+ !
+ !
+ !* 2.3 update the residual error: r
+ !
+ ZRESIDUE = ZRESIDUE + ZLAMBDA * ZDELTA
+ !
+ !* 2.4 compute the vector: q = F^(-1)*( Q(PHI) - Y )
+ !
+ !CALL FLAT_INVZ(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ ! PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZRESIDUE,ZQ, &
+ ! PBFB,&
+ ! PBF_SXP2_YP1_Z) !JUAN Z_SPLITTING
+ CALL FAST_SUBSTITUTION_3D(ZQ,ZBETX,PBFB,ZGAM,PCF,PAF &
+ ,ZRESIDUE,IIU,IJU,IKU)
+ CALL PF_1_Y_BOUND(ZQ)
+ CALL GET_HALO(ZQ)
+ !
+ !* 2.5 compute the auxiliary field: ksi = Q ( q )
+ !
+ ! ZKSI= QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZQ)
+ CALL PF(ZKSI,ZQ)
+ ! -1
+ !* 2.6 compute the step ALPHA
+ !
+ ZALPHA = - DOTPROD(ZKSI,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA ! lambda
+ !
+ !* 2.7 update p and DELTA
+ !
+ ZP = ZQ + ZALPHA * ZP
+ ZDELTA = ZKSI + ZALPHA * ZDELTA
+ !
+END DO ! end of the loop for the iterative solver
+
+ENDIF ! CRESI
+
+ENDIF ! GMG_K
+
+!!$ZMEAN = SUM ( PF_1_Y(IIB:IIE,IJB:IJE,IKU) ) / FLOAT( (IIE-IIB+1)*(IJE-IJB+1) )
+!!$PF_1_Y(IIB:IIE,IJB:IJE,:) = PF_1_Y(IIB:IIE,IJB:IJE,:) - ZMEAN
+!CALL PF_1_Y_BOUND(PF_1_Y)
+!CALL GET_HALO(PF_1_Y)
+
+
+
+ END IF
+ !
+
+10000 CONTINUE
+ CALL PF_1_Y_BOUND(PF_1_Y)
+ !
+ 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)
+ !
+ !PF_1_Y = ZF_1_Y
+ !
+!!$ CALL PF(ZRESIDUE,PF_1_Y) ! for totalview
+!!$ ZRESIDUE = ZRESIDUE - ZY
+ !
+ CALL GET_HALO(PF_1_Y)
+ !-------------------------------------------------------------------------------
+ !
+CONTAINS
+
+ SUBROUTINE CONSTRUCT_ALPHA(JI,JJ)
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: JI,JJ
+
+ IF ( (HLBCX(1) /= 'CYCL') .AND. ( JI == IIE ) .AND. LEAST_ll(HSPLITTING='B' ) ) THEN
+ Alpha_T(1) = 0.0 ! 2.0
+ ELSE
+ Alpha_T(1) = 1.0
+ END IF
+ IF ( (HLBCX(1) /= 'CYCL') .AND. ( JI == IIB ) .AND. LWEST_ll(HSPLITTING='B' ) ) THEN
+ Alpha_T(2) = 0.0 ! 2.0
+ ELSE
+ Alpha_T(2) = 1.0
+ END IF
+ IF ( (HLBCY(1) /= 'CYCL') .AND. ( JJ == IJE ) .AND. LNORTH_ll(HSPLITTING='B' ) ) THEN
+ Alpha_T(3) = 0.0 ! 2.0
+ ELSE
+ Alpha_T(3) = 1.0
+ END IF
+ IF ( (HLBCY(1) /= 'CYCL') .AND. ( JJ == IJB ) .AND. LSOUTH_ll(HSPLITTING='B' ) ) THEN
+ Alpha_T(4) = 0.0 ! 2.0
+ ELSE
+ Alpha_T(4) = 1.0
+ END IF
+
+ Alpha_T(5) = Alpha_T(1) + Alpha_T(2) + Alpha_T(3) + Alpha_T(4)
+
+ END SUBROUTINE CONSTRUCT_ALPHA
+
+SUBROUTINE PF_K(PY,PF_1_Y)
+IMPLICIT NONE
+
+REAL , DIMENSION(:,:,:) , INTENT(INOUT) :: PY
+REAL , DIMENSION(:,:,:) , INTENT(IN) :: PF_1_Y
+
+REAL :: Tij
+
+Tij = ZDXM2
+
+PY = 0.0
+
+ DO JJ=IJB,IJE
+ DO JI=IIB,IIE
+ CALL CONSTRUCT_ALPHA(JI,JJ)
+ DO JK=IKB-1,IKE+1
+ PY(JI,JJ,JK) = ( (A_K(JK) -B_K(JK) -C_K(JK) )*Tij ) * PF_1_Y(JI,JJ,JK)
+ IF ( (JK >= IKB) .AND. (JK <= IKE) ) THEN
+ PY(JI,JJ,JK) = PY(JI,JJ,JK) - Alpha_T(5) * PF_1_Y(JI,JJ,JK) &
+ + Alpha_T(1) * PF_1_Y(JI+1,JJ,JK) &
+ + Alpha_T(2) * PF_1_Y(JI-1,JJ,JK) &
+ + Alpha_T(3) * PF_1_Y(JI,JJ+1,JK) &
+ + Alpha_T(4) * PF_1_Y(JI,JJ-1,JK)
+ END IF
+ IF (JK >= IKB ) THEN
+ PY(JI,JJ,JK) = PY(JI,JJ,JK) + C_K(JK) *Tij * PF_1_Y(JI,JJ,JK-1)
+ END IF
+
+ IF (JK <= IKE ) THEN
+ PY(JI,JJ,JK) = PY(JI,JJ,JK) + B_K(JK) *Tij * PF_1_Y(JI,JJ,JK+1)
+ ENDIF
+
+ PY(JI,JJ,JK) = D_K(JK) * PY(JI,JJ,JK) / ZDXM2 ! /ZDXM2 <=> Temporaire pour comparer avec MNH FAST_SUB
+
+ END DO
+
+ END DO
+ END DO
+
+!
+CALL GET_HALO(PY)
+!
+END SUBROUTINE PF_K
+
+SUBROUTINE TRIDIAG_SOLVE_K(PY,PF_1_Y)
+IMPLICIT NONE
+
+REAL , DIMENSION(:,:,:) ,INTENT(IN) :: PY
+REAL , DIMENSION(:,:,:) ,INTENT(INOUT) :: PF_1_Y
+
+! local var
+
+REAL, DIMENSION(SIZE(PY,3)) :: C, u_out
+REAL :: Tij , tmp , alpha_div_Tij , b_k_tmp , c_k_tmp , xctop_boot
+
+INTEGER :: JI,JJ,JK,iz
+
+Tij = ZDXM2
+xctop_boot = 0.0
+
+PF_1_Y = 0.0
+
+ DO JJ=IJB,IJE
+ DO JI=IIB,IIE
+ CALL CONSTRUCT_ALPHA(JI,JJ)
+ alpha_T(5) = 4.0 ! temporaire to compare to MNH FLATINV
+ ! Calculate r_i = b_i - A_{ij} u_i
+ ! do iz= IKB,IKE ! 1,nz
+ ! r(iz) = b%s(iz,iy,ix) - vert_coeff%d(iz) * ( &
+ ! alpha_T(1) * u_in_1(iz) + &
+ ! alpha_T(2) * u_in_2(iz) + &
+ ! alpha_T(3) * u_in_3(iz) + &
+ ! alpha_T(4) * u_in_4(iz) )
+ ! end do
+ !
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = IKB-1 ! 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (A_K(iz)-B_K(iz)-C_K(iz)) &
+ - xctop_boot*alpha_div_Tij
+ c(iz) = B_K(iz)/tmp
+ u_out(iz) = PY(JI,JJ,iz) / (tmp*Tij*D_K(iz))
+
+ do iz=IKB,IKE! 2,nz
+ b_k_tmp = B_K(iz)
+ c_k_tmp = C_K(iz)
+ tmp = ((A_K(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (PY(JI,JJ,iz) / (Tij*D_K(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+
+ iz=IKE+1
+ b_k_tmp = B_K(iz)
+ c_k_tmp = C_K(iz)
+ tmp = ((A_K(iz)-b_k_tmp-c_k_tmp) - xctop_boot*alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (PY(JI,JJ,iz) / (Tij*D_K(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+
+ ! STEP 2: back substitution
+ do iz=IKE,IKB-1,-1 ! nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+
+ PF_1_Y(JI,JJ,:) = u_out(:) * ZDXM2 ! * ZDXM2 <=> Temporaire pour comparer avec MNH FAST_SUB
+
+ END DO
+ END DO
+
+!
+CALL GET_HALO(PF_1_Y)
+!
+END SUBROUTINE TRIDIAG_SOLVE_K
+
+SUBROUTINE PF(PY,PF_1_Y)
+IMPLICIT NONE
+
+REAL , DIMENSION(:,:,:) :: PY,PF_1_Y
+
+PY = 0.0
+DO JK=IKB,IKE
+ DO JJ=IJB,IJE
+ DO JI=IIB,IIE
+ PY(JI,JJ,JK) = &
+ PBFB(JI,JJ,JK) * PF_1_Y(JI,JJ,JK) &
+ + PAF(JK) * PF_1_Y(JI,JJ,JK-1) &
+ + PCF(JK) * PF_1_Y(JI,JJ,JK+1) &
+ + PRHOM(JK) / ZDXM2 * PF_1_Y(JI+1,JJ,JK) &
+ + PRHOM(JK) / ZDXM2 * PF_1_Y(JI-1,JJ,JK) &
+ + PRHOM(JK) / ZDYM2 * PF_1_Y(JI,JJ+1,JK) &
+ + PRHOM(JK) / ZDYM2 * PF_1_Y(JI,JJ-1,JK)
+ END DO
+ END DO
+END DO
+PY(IIB:IIE,IJB:IJE,IKB-1) = PBFB(IIB:IIE,IJB:IJE,IKB-1) * PF_1_Y(IIB:IIE,IJB:IJE,IKB-1) &
+ + PCF(IKB-1) * PF_1_Y(IIB:IIE,IJB:IJE,IKB)
+PY(IIB:IIE,IJB:IJE,IKE+1) = PAF(IKE+1) * PF_1_Y(IIB:IIE,IJB:IJE,IKE) &
+ + PBFB(IIB:IIE,IJB:IJE,IKE+1) * PF_1_Y(IIB:IIE,IJB:IJE,IKE+1)
+!
+CALL GET_HALO(PY)
+!
+END SUBROUTINE PF
+
+
+SUBROUTINE PF_1_Y_BOUND(PF_1_Y)
+
+IMPLICIT NONE
+
+REAL , DIMENSION (:,:,:) :: PF_1_Y
+
+ !-------------------------------------------------------------------------------
+ !
+ !* 7. RETURN TO A NON HOMOGENEOUS NEUMAN CONDITION FOR NON-CYCLIC CASES
+ ! -----------------------------------------------------------------
+ !
+ !* 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,:) ! 0.0
+ 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,:) ! 0.0
+ 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,:) ! 0.0
+ 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,:) ! 0.0
+ END IF
+ END IF
+END SUBROUTINE PF_1_Y_BOUND
+
+ SUBROUTINE FAST_SUBSTITUTION_3D_ZS(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
+ REAL, DIMENSION (KIY*KJY) :: PBETX
+ REAL, DIMENSION (KIY*KJY,KKU) :: PPCF,PAF
+ 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_ZS
+
+ 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
+ REAL, DIMENSION (KIY*KJY) :: PBETX
+ REAL, DIMENSION (KKU) :: PPCF,PAF
+ 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
+
+ !------------------------------------------------------------------------------
+END SUBROUTINE ZSOLVER_INV