libf/phylmd/concvl.f90

module concvl_m

  IMPLICIT NONE

contains

  SUBROUTINE concvl(iflag_con, dtime, paprs, pplay, t, q, u, v, tra, &
       ntra, work1, work2, d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, &
       ktop, upwd, dnwd, dnwdbis, ma, cape, tvp, iflag, pbase, bbase, &
       dtvpdt1, dtvpdq1, dplcldt, dplcldr, qcondc, wd, pmflxr, pmflxs, &
       da, phi, mp)

    ! From phylmd/concvl.F, version 1.3 2005/04/15 12:36:17
    ! Author: Z.X. Li (LMD/CNRS)
    ! date: 1993/08/18
    ! Objet: schéma de convection de Emanuel (1991) interface

    USE dimens_m, ONLY : nqmx
    USE dimphy, ONLY : klev, klon
    USE suphec_m, ONLY : retv, rtt
    USE yoethf_m, ONLY : r2es
    USE fcttre, ONLY : foeew

    ! Arguments:
    ! dtime--input-R-pas d'integration (s)
    ! s-------input-R-la valeur "s" pour chaque couche
    ! sigs----input-R-la valeur "sigma" de chaque couche
    ! sig-----input-R-la valeur de "sigma" pour chaque niveau
    ! psolpa--input-R-la pression au sol (en Pa)
    ! pskapa--input-R-exponentiel kappa de psolpa
    ! h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
    ! q-------input-R-vapeur d'eau (en kg/kg)

    ! work*: input et output: deux variables de travail,
    !                            on peut les mettre a 0 au debut
    ! ALE-----input-R-energie disponible pour soulevement

    ! d_h-----output-R-increment de l'enthalpie potentielle (h)
    ! d_q-----output-R-increment de la vapeur d'eau
    ! rain----output-R-la pluie (mm/s)
    ! snow----output-R-la neige (mm/s)
    ! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
    ! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
    ! dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
    ! Cape----output-R-CAPE (J/kg)
    ! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
    !                  adiabatiquement a partir du niveau 1 (K)
    ! deltapb-output-R-distance entre LCL et base de la colonne (<0 ;
    !  Pa)
    ! Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de
    !  la glace

    INTEGER ntrac
    PARAMETER (ntrac=nqmx-2)

    INTEGER, INTENT (IN) :: iflag_con

    REAL, INTENT (IN) :: dtime
    REAL, INTENT (IN) :: paprs(klon, klev+1)
    REAL, INTENT (IN) :: pplay(klon, klev)
    REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
    REAL, INTENT (IN):: tra(klon, klev, ntrac)
    INTEGER ntra
    REAL work1(klon, klev), work2(klon, klev)
    REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)

    REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, &
         klev)
    REAL d_tra(klon, klev, ntrac)
    REAL rain(klon), snow(klon)

    INTEGER kbas(klon), ktop(klon)
    REAL em_ph(klon, klev+1), em_p(klon, klev)
    REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
    REAL ma(klon, klev), cape(klon), tvp(klon, klev)
    REAL da(klon, klev), phi(klon, klev, klev), mp(klon, klev)
    INTEGER iflag(klon)
    REAL pbase(klon), bbase(klon)
    REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
    REAL dplcldt(klon), dplcldr(klon)
    REAL qcondc(klon, klev)
    REAL wd(klon)

    REAL zx_t, zdelta, zx_qs, zcor

    INTEGER i, k, itra
    REAL qs(klon, klev)
    REAL cbmf(klon)
    SAVE cbmf
    INTEGER ifrst
    SAVE ifrst
    DATA ifrst/0/

    !-----------------------------------------------------------------

    snow(:) = 0

    IF (ifrst==0) THEN
       ifrst = 1
       DO i = 1, klon
          cbmf(i) = 0.
       END DO
    END IF

    DO k = 1, klev + 1
       DO i = 1, klon
          em_ph(i, k) = paprs(i, k)/100.0
          pmflxs(i, k) = 0.
       END DO
    END DO

    DO k = 1, klev
       DO i = 1, klon
          em_p(i, k) = pplay(i, k)/100.0
       END DO
    END DO


    IF (iflag_con==4) THEN
       DO k = 1, klev
          DO i = 1, klon
             zx_t = t(i, k)
             zdelta = max(0., sign(1., rtt-zx_t))
             zx_qs = min(0.5, r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0)
             zcor = 1./(1.-retv*zx_qs)
             qs(i, k) = zx_qs*zcor
          END DO
       END DO
    ELSE
       ! iflag_con=3 (modif de puristes qui fait la diffce pour la
       ! convergence numerique)
       DO k = 1, klev
          DO i = 1, klon
             zx_t = t(i, k)
             zdelta = max(0., sign(1., rtt-zx_t))
             zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
             zx_qs = min(0.5, zx_qs)
             zcor = 1./(1.-retv*zx_qs)
             zx_qs = zx_qs*zcor
             qs(i, k) = zx_qs
          END DO
       END DO
    END IF

    ! Main driver for convection:
    !           iflag_con = 3  -> equivalent to convect3
    !           iflag_con = 4  -> equivalent to convect1/2

    CALL cv_driver(klon, klev, klev+1, ntra, iflag_con, t, q, qs, u, v, &
         tra, em_p, em_ph, iflag, d_t, d_q, d_u, d_v, d_tra, rain, &
         pmflxr, cbmf, work1, work2, kbas, ktop, dtime, ma, upwd, dnwd, &
         dnwdbis, qcondc, wd, cape, da, phi, mp)

    DO i = 1, klon
       rain(i) = rain(i)/86400.
    END DO

    DO k = 1, klev
       DO i = 1, klon
          d_t(i, k) = dtime*d_t(i, k)
          d_q(i, k) = dtime*d_q(i, k)
          d_u(i, k) = dtime*d_u(i, k)
          d_v(i, k) = dtime*d_v(i, k)
       END DO
    END DO
    DO itra = 1, ntra
       DO k = 1, klev
          DO i = 1, klon
             d_tra(i, k, itra) = dtime*d_tra(i, k, itra)
          END DO
       END DO
    END DO
    ! les traceurs ne sont pas mis dans cette version de convect4:
    IF (iflag_con==4) THEN
       DO itra = 1, ntra
          DO k = 1, klev
             DO i = 1, klon
                d_tra(i, k, itra) = 0.
             END DO
          END DO
       END DO
    END IF

  END SUBROUTINE concvl

end module concvl_m
1	guez	47	module concvl_m
2	guez	3
3	guez	47	IMPLICIT NONE
4	guez	3
5	guez	47	contains
6	guez	13
7	guez	47	SUBROUTINE concvl(iflag_con, dtime, paprs, pplay, t, q, u, v, tra, &
8			ntra, work1, work2, d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, &
9			ktop, upwd, dnwd, dnwdbis, ma, cape, tvp, iflag, pbase, bbase, &
10			dtvpdt1, dtvpdq1, dplcldt, dplcldr, qcondc, wd, pmflxr, pmflxs, &
11			da, phi, mp)
12	guez	13
13	guez	47	! From phylmd/concvl.F, version 1.3 2005/04/15 12:36:17
14			! Author: Z.X. Li (LMD/CNRS)
15			! date: 1993/08/18
16	guez	49	! Objet: schéma de convection de Emanuel (1991) interface
17	guez	13
18	guez	47	USE dimens_m, ONLY : nqmx
19			USE dimphy, ONLY : klev, klon
20			USE suphec_m, ONLY : retv, rtt
21			USE yoethf_m, ONLY : r2es
22			USE fcttre, ONLY : foeew
23	guez	13
24	guez	47	! Arguments:
25			! dtime--input-R-pas d'integration (s)
26			! s-------input-R-la valeur "s" pour chaque couche
27			! sigs----input-R-la valeur "sigma" de chaque couche
28			! sig-----input-R-la valeur de "sigma" pour chaque niveau
29			! psolpa--input-R-la pression au sol (en Pa)
30			! pskapa--input-R-exponentiel kappa de psolpa
31			! h-------input-R-enthalpie potentielle (CpT/P*kappa)
32			! q-------input-R-vapeur d'eau (en kg/kg)
33	guez	13
34	guez	47	! work*: input et output: deux variables de travail,
35			! on peut les mettre a 0 au debut
36			! ALE-----input-R-energie disponible pour soulevement
37	guez	13
38	guez	47	! d_h-----output-R-increment de l'enthalpie potentielle (h)
39			! d_q-----output-R-increment de la vapeur d'eau
40			! rain----output-R-la pluie (mm/s)
41			! snow----output-R-la neige (mm/s)
42			! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
43			! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
44			! dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
45			! Cape----output-R-CAPE (J/kg)
46			! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
47			! adiabatiquement a partir du niveau 1 (K)
48			! deltapb-output-R-distance entre LCL et base de la colonne (<0 ;
49			! Pa)
50			! Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de
51			! la glace
52	guez	13
53	guez	47	INTEGER ntrac
54			PARAMETER (ntrac=nqmx-2)
55	guez	13
56	guez	47	INTEGER, INTENT (IN) :: iflag_con
57	guez	13
58	guez	47	REAL, INTENT (IN) :: dtime
59			REAL, INTENT (IN) :: paprs(klon, klev+1)
60			REAL, INTENT (IN) :: pplay(klon, klev)
61			REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
62			REAL, INTENT (IN):: tra(klon, klev, ntrac)
63			INTEGER ntra
64			REAL work1(klon, klev), work2(klon, klev)
65			REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
66	guez	13
67	guez	47	REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, &
68			klev)
69			REAL d_tra(klon, klev, ntrac)
70			REAL rain(klon), snow(klon)
71	guez	13
72	guez	47	INTEGER kbas(klon), ktop(klon)
73			REAL em_ph(klon, klev+1), em_p(klon, klev)
74			REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
75			REAL ma(klon, klev), cape(klon), tvp(klon, klev)
76			REAL da(klon, klev), phi(klon, klev, klev), mp(klon, klev)
77			INTEGER iflag(klon)
78			REAL pbase(klon), bbase(klon)
79			REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
80			REAL dplcldt(klon), dplcldr(klon)
81			REAL qcondc(klon, klev)
82			REAL wd(klon)
83	guez	13
84	guez	47	REAL zx_t, zdelta, zx_qs, zcor
85	guez	13
86	guez	47	INTEGER i, k, itra
87			REAL qs(klon, klev)
88			REAL cbmf(klon)
89			SAVE cbmf
90			INTEGER ifrst
91			SAVE ifrst
92			DATA ifrst/0/
93	guez	13
94	guez	47	!-----------------------------------------------------------------
95	guez	13
96	guez	47	snow(:) = 0
97	guez	13
98	guez	47	IF (ifrst==0) THEN
99			ifrst = 1
100			DO i = 1, klon
101			cbmf(i) = 0.
102			END DO
103			END IF
104	guez	13
105	guez	47	DO k = 1, klev + 1
106			DO i = 1, klon
107			em_ph(i, k) = paprs(i, k)/100.0
108			pmflxs(i, k) = 0.
109			END DO
110			END DO
111	guez	13
112	guez	47	DO k = 1, klev
113			DO i = 1, klon
114			em_p(i, k) = pplay(i, k)/100.0
115			END DO
116			END DO
117	guez	3
118
119	guez	47	IF (iflag_con==4) THEN
120			DO k = 1, klev
121			DO i = 1, klon
122			zx_t = t(i, k)
123			zdelta = max(0., sign(1., rtt-zx_t))
124			zx_qs = min(0.5, r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0)
125			zcor = 1./(1.-retv*zx_qs)
126			qs(i, k) = zx_qs*zcor
127			END DO
128			END DO
129			ELSE
130			! iflag_con=3 (modif de puristes qui fait la diffce pour la
131			! convergence numerique)
132			DO k = 1, klev
133			DO i = 1, klon
134			zx_t = t(i, k)
135			zdelta = max(0., sign(1., rtt-zx_t))
136			zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
137			zx_qs = min(0.5, zx_qs)
138			zcor = 1./(1.-retv*zx_qs)
139			zx_qs = zx_qs*zcor
140			qs(i, k) = zx_qs
141			END DO
142			END DO
143			END IF
144	guez	3
145	guez	47	! Main driver for convection:
146			! iflag_con = 3 -> equivalent to convect3
147			! iflag_con = 4 -> equivalent to convect1/2
148	guez	3
149	guez	47	CALL cv_driver(klon, klev, klev+1, ntra, iflag_con, t, q, qs, u, v, &
150			tra, em_p, em_ph, iflag, d_t, d_q, d_u, d_v, d_tra, rain, &
151			pmflxr, cbmf, work1, work2, kbas, ktop, dtime, ma, upwd, dnwd, &
152			dnwdbis, qcondc, wd, cape, da, phi, mp)
153	guez	13
154	guez	47	DO i = 1, klon
155			rain(i) = rain(i)/86400.
156			END DO
157
158			DO k = 1, klev
159			DO i = 1, klon
160			d_t(i, k) = dtime*d_t(i, k)
161			d_q(i, k) = dtime*d_q(i, k)
162			d_u(i, k) = dtime*d_u(i, k)
163			d_v(i, k) = dtime*d_v(i, k)
164			END DO
165			END DO
166			DO itra = 1, ntra
167			DO k = 1, klev
168			DO i = 1, klon
169			d_tra(i, k, itra) = dtime*d_tra(i, k, itra)
170			END DO
171			END DO
172			END DO
173			! les traceurs ne sont pas mis dans cette version de convect4:
174			IF (iflag_con==4) THEN
175			DO itra = 1, ntra
176			DO k = 1, klev
177			DO i = 1, klon
178			d_tra(i, k, itra) = 0.
179			END DO
180			END DO
181			END DO
182			END IF
183
184			END SUBROUTINE concvl
185
186			end module concvl_m