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
    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	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: schéma 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	use cv_driver_m, only: cv_driver
24
25	! 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
35	! 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
39	! 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
54	INTEGER ntrac
55	PARAMETER (ntrac=nqmx-2)
56
57	INTEGER, INTENT (IN) :: iflag_con
58
59	REAL, INTENT (IN) :: dtime
60	REAL, INTENT (IN) :: paprs(klon, klev+1)
61	REAL, INTENT (IN) :: pplay(klon, klev)
62	REAL, intent(in):: t(klon, klev)
63	real q(klon, klev), u(klon, klev), v(klon, klev)
64	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
69	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
74	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
86	REAL zx_t, zdelta, zx_qs, zcor
87
88	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
96	!-----------------------------------------------------------------
97
98	snow(:) = 0
99
100	IF (ifrst==0) THEN
101	ifrst = 1
102	DO i = 1, klon
103	cbmf(i) = 0.
104	END DO
105	END IF
106
107	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
114	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
120
121	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
147	! Main driver for convection:
148	! iflag_con = 3 -> equivalent to convect3
149	! iflag_con = 4 -> equivalent to convect1/2
150
151	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
156	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