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: schema 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	module concvl_m
2
3	IMPLICIT NONE
4
5	contains
6
7	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
13	! 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	! Objet: schema de convection de Emanuel (1991) interface
17
18	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
24	! 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
34	! 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
38	! 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
53	INTEGER ntrac
54	PARAMETER (ntrac=nqmx-2)
55
56	INTEGER, INTENT (IN) :: iflag_con
57
58	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
67	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
72	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
84	REAL zx_t, zdelta, zx_qs, zcor
85
86	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
94	!-----------------------------------------------------------------
95
96	snow(:) = 0
97
98	IF (ifrst==0) THEN
99	ifrst = 1
100	DO i = 1, klon
101	cbmf(i) = 0.
102	END DO
103	END IF
104
105	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
112	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
118
119	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
145	! Main driver for convection:
146	! iflag_con = 3 -> equivalent to convect3
147	! iflag_con = 4 -> equivalent to convect1/2
148
149	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
154	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