trunk/phylmd/concvl.f

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
    use cv_driver_m, only: cv_driver

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