source: trunk/LMDZ.GENERIC/libf/phystd/largescale.F90 @ 919

      subroutine largescale(ngrid,nq,ptimestep, pplev, pplay, pt, pq,   &
                        pdt, pdq, pdtlsc, pdqvaplsc, pdqliqlsc, rneb)

      use watercommon_h, only : RLVTT, RCPD, RVTMP2,  &
          T_h2O_ice_clouds,T_h2O_ice_liq,Psat_water,Lcpdqsat_water
      USE tracer_h
      IMPLICIT none

!==================================================================
!     
!     Purpose
!     -------
!     Calculates large-scale (stratiform) H2O condensation.
!     
!     Authors
!     -------
!     Adapted from the LMDTERRE code by R. Wordsworth (2009)
!     Original author Z. X. Li (1993)
!     
!==================================================================

#include "dimensions.h" 
#include "dimphys.h"
#include "comcstfi.h"

#include "callkeys.h"

      INTEGER ngrid,nq

!     Arguments
      REAL ptimestep                 ! intervalle du temps (s)
      REAL pplev(ngrid,nlayermx+1) ! pression a inter-couche
      REAL pplay(ngrid,nlayermx)   ! pression au milieu de couche
      REAL pt(ngrid,nlayermx)      ! temperature (K)
      real pq(ngrid,nlayermx,nq) ! tracer mixing ratio (kg/kg)
      REAL pdt(ngrid,nlayermx)     ! physical temperature tenedency (K/s)
      REAL pdq(ngrid,nlayermx,nq)! physical tracer tenedency (K/s)
      REAL pdtlsc(ngrid,nlayermx)  ! incrementation de la temperature (K)
      REAL pdqvaplsc(ngrid,nlayermx) ! incrementation de la vapeur d'eau
      REAL pdqliqlsc(ngrid,nlayermx) ! incrementation de l'eau liquide
      REAL rneb(ngrid,nlayermx)    ! fraction nuageuse


!     Options du programme
      REAL ratqs   ! determine largeur de la distribution de vapeur
      PARAMETER (ratqs=0.2)

!     Variables locales
      REAL CBRT
      EXTERNAL CBRT
      INTEGER i, k , nn
      INTEGER,PARAMETER :: nitermax=2000
      REAL,PARAMETER :: alpha=.5,qthreshold=1.e-6 
      ! JL13: if "careful, T<Tmin in psat water" appears often, you may want to stabilise the model by
      !                   decreasing alpha and increasing nitermax accordingly
      REAL zt(ngrid), zq(ngrid)
      REAL zcond(ngrid),zcond_iter
      REAL zdelq(ngrid)
      REAL zqs(ngrid), zdqs(ngrid)
      REAL psat_tmp,dlnpsat_tmp
      
! evaporation calculations
      REAL dqevap(ngrid,nlayermx),dtevap(ngrid,nlayermx)     
      REAL qevap(ngrid,nlayermx,nq)
      REAL tevap(ngrid,nlayermx)

      REAL zcor(ngrid), zdelta(ngrid), zcvm5(ngrid)
      REAL zx_q(ngrid)
      REAL Nmix_local,zfice

!     GCM -----> subroutine variables, initialisation of outputs

      pdtlsc(1:ngrid,1:nlayermx)  = 0.0
      pdqvaplsc(1:ngrid,1:nlayermx)  = 0.0
      pdqliqlsc(1:ngrid,1:nlayermx) = 0.0
      rneb(1:ngrid,1:nlayermx) = 0.0


      ! Evaporate cloud water/ice
      call evap(ngrid,nq,ptimestep,pt,pq,pdq,pdt,dqevap,dtevap,qevap,tevap)
      ! note: we use qevap but not tevap in largescale/moistadj
            ! otherwise is a big mess


!  Boucle verticale (du haut vers le bas)
   DO k = nlayermx, 1, -1

      zt(1:ngrid)=pt(1:ngrid,k)+(pdt(1:ngrid,k)+dtevap(1:ngrid,k))*ptimestep
      zq(1:ngrid)=qevap(1:ngrid,k,igcm_h2o_vap) !liquid water is included in qevap

!     Calculer la vapeur d'eau saturante et 
!     determiner la condensation partielle
      DO i = 1, ngrid

         if(zt(i).le.15.) then
            print*,'in lsc',i,k,zt(i)
!           zt(i)=15.   ! check too low temperatures
         endif
         call Psat_water(zt(i),pplay(i,k),psat_tmp,zqs(i))
 
         zdelq(i) = MAX(MIN(ratqs * zq(i),1.-zq(i)),1.e-12)
         rneb(i,k) = (zq(i)+zdelq(i)-zqs(i)) / (2.0*zdelq(i))
!        print*,zq(i),zdelq(i),zqs(i),rneb(i,k)
         if (rneb(i,k).lt.0.) then  !no clouds

            rneb(i,k)=0.
            zcond(i)=0.

         else if (rneb(i,k).gt.1.) then    !complete cloud cover, we start without evaporating

            rneb(i,k)=1.
            zt(i)=pt(i,k)+pdt(i,k)*ptimestep
            zx_q(i) = pq(i,k,igcm_h2o_vap)+pdq(i,k,igcm_h2o_vap)*ptimestep
            dqevap(i,k)=0.
!           iterative process to stabilize the scheme when large water amounts JL12
            zcond(i) = 0.0
            Do nn=1,nitermax  
               call Psat_water(zt(i),pplay(i,k),psat_tmp,zqs(i))
               call Lcpdqsat_water(zt(i),pplay(i,k),psat_tmp,zqs(i),zdqs(i),dlnpsat_tmp)
               zcond_iter = alpha*(zx_q(i)-zqs(i))/(1.+zdqs(i))    
                  !zcond can be negative here
               zx_q(i) = zx_q(i) - zcond_iter
               zcond(i) = zcond(i) + zcond_iter
               zt(i) = zt(i) + zcond_iter*RLVTT/RCPD
               if (ABS(zcond_iter/alpha).lt.qthreshold) exit
            End do ! niter
            zcond(i)=MAX(zcond(i),-(pq(i,k,igcm_h2o_ice)+pdq(i,k,igcm_h2o_ice)*ptimestep))

         else   !standard case      

            zx_q(i) = (zq(i)+zdelq(i)+zqs(i))/2.0 !water vapor in cloudy sky
!           iterative process to stabilize the scheme when large water amounts JL12
            zcond(i) = 0.0
            Do nn=1,nitermax  
               call Lcpdqsat_water(zt(i),pplay(i,k),psat_tmp,zqs(i),zdqs(i),dlnpsat_tmp)
               zcond_iter = MAX(0.0,alpha*(zx_q(i)-zqs(i))/(1.+zdqs(i)))           
                  !zcond always postive! cannot evaporate clouds!
                  !this is why we must reevaporate before largescale
               zx_q(i) = zx_q(i) - zcond_iter
               zcond(i) = zcond(i) + zcond_iter
               if (ABS(zcond_iter/alpha).lt.qthreshold) exit
               zt(i) = zt(i) + zcond_iter*RLVTT/RCPD*rneb(i,k)
               call Psat_water(zt(i),pplay(i,k),psat_tmp,zqs(i))
            End do ! niter

         Endif

         zcond(i) = zcond(i)*rneb(i,k)/ptimestep ! JL12

      ENDDO

!     Tendances de t et q
         pdqvaplsc(1:ngrid,k)  = dqevap(1:ngrid,k) - zcond(1:ngrid)
         pdqliqlsc(1:ngrid,k) = - pdqvaplsc(1:ngrid,k)
         pdtlsc(1:ngrid,k)  = pdqliqlsc(1:ngrid,k)*RLVTT/RCPD

   Enddo ! k= nlayermx, 1, -1
   
      !print*,'qsat=',zqs
      !print*,'q=',q
      !print*,'dq=',pdqvaplsc*ptimestep
      !print*,'dT in LS=',pdtlsc*ptimestep

      !print*,'rice=',rice
      !print*,'rneb=',rneb

      return
      end