libf/phylmd/concvl.f90

module concvl_m

  IMPLICIT NONE

contains

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

    ! 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 d'Emanuel (1991), interface
    ! (driver commun aux versions 3 et 4)

    use clesphys2, only: iflag_con
    use cv_driver_m, only: cv_driver
    USE dimens_m, ONLY: nqmx
    USE dimphy, ONLY: klev, klon
    USE fcttre, ONLY: foeew
    USE suphec_m, ONLY: retv, rtt
    USE yoethf_m, ONLY: r2es

    INTEGER, PARAMETER:: ntrac = nqmx - 2

    REAL, INTENT (IN):: dtime ! pas d'integration (s)
    REAL, INTENT (IN):: paprs(klon, klev+1)
    REAL, INTENT (IN):: pplay(klon, klev)
    REAL, intent(in):: t(klon, klev)
    real q(klon, klev) ! input vapeur d'eau (en kg/kg)
    real u(klon, klev), v(klon, klev)
    REAL, INTENT (IN):: tra(klon, klev, ntrac)
    INTEGER, intent(in):: ntra ! number of tracers
    REAL work1(klon, klev), work2(klon, klev)
    ! work*: input et output: deux variables de travail,
    !                            on peut les mettre a 0 au debut
    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)
    ! d_q-----output-R-increment de la vapeur d'eau
    REAL d_tra(klon, klev, ntrac)
    REAL rain(klon), snow(klon)
    ! rain----output-R-la pluie (mm/s)
    ! snow----output-R-la neige (mm/s)

    INTEGER kbas(klon), ktop(klon)
    REAL em_ph(klon, klev+1), em_p(klon, klev)

    REAL, intent(out):: upwd(klon, klev)
    ! saturated updraft mass flux (kg/m**2/s)

    real, intent(out):: dnwd(klon, klev)
    ! saturated downdraft mass flux (kg/m**2/s)

    real, intent(out):: dnwd0(klon, klev)
    ! unsaturated downdraft mass flux (kg/m**2/s)

    REAL ma(klon, klev), cape(klon), tvp(klon, klev)
    ! Cape----output-R-CAPE (J/kg)
    ! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
    !                  adiabatiquement a partir du niveau 1 (K)
    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, save:: cbmf(klon)
    INTEGER:: 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

    CALL cv_driver(klon, klev, klev+1, ntra, 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, dnwd0, 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(dtime, paprs, pplay, t, q, u, v, tra, work1, work2, &
8	d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwd0, &
9	ma, cape, tvp, iflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, &
10	dplcldr, qcondc, wd, pmflxr, pmflxs, da, phi, mp, ntra)
11
12	! From phylmd/concvl.F, version 1.3 2005/04/15 12:36:17
13	! Author: Z. X. Li (LMD/CNRS)
14	! Date: 1993/08/18
15	! Objet : schéma de convection d'Emanuel (1991), interface
16	! (driver commun aux versions 3 et 4)
17
18	use clesphys2, only: iflag_con
19	use cv_driver_m, only: cv_driver
20	USE dimens_m, ONLY: nqmx
21	USE dimphy, ONLY: klev, klon
22	USE fcttre, ONLY: foeew
23	USE suphec_m, ONLY: retv, rtt
24	USE yoethf_m, ONLY: r2es
25
26	INTEGER, PARAMETER:: ntrac = nqmx - 2
27
28	REAL, INTENT (IN):: dtime ! pas d'integration (s)
29	REAL, INTENT (IN):: paprs(klon, klev+1)
30	REAL, INTENT (IN):: pplay(klon, klev)
31	REAL, intent(in):: t(klon, klev)
32	real q(klon, klev) ! input vapeur d'eau (en kg/kg)
33	real u(klon, klev), v(klon, klev)
34	REAL, INTENT (IN):: tra(klon, klev, ntrac)
35	INTEGER, intent(in):: ntra ! number of tracers
36	REAL work1(klon, klev), work2(klon, klev)
37	! work*: input et output: deux variables de travail,
38	! on peut les mettre a 0 au debut
39	REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
40
41	REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, &
42	klev)
43	! d_q-----output-R-increment de la vapeur d'eau
44	REAL d_tra(klon, klev, ntrac)
45	REAL rain(klon), snow(klon)
46	! rain----output-R-la pluie (mm/s)
47	! snow----output-R-la neige (mm/s)
48
49	INTEGER kbas(klon), ktop(klon)
50	REAL em_ph(klon, klev+1), em_p(klon, klev)
51
52	REAL, intent(out):: upwd(klon, klev)
53	! saturated updraft mass flux (kg/m**2/s)
54
55	real, intent(out):: dnwd(klon, klev)
56	! saturated downdraft mass flux (kg/m**2/s)
57
58	real, intent(out):: dnwd0(klon, klev)
59	! unsaturated downdraft mass flux (kg/m**2/s)
60
61	REAL ma(klon, klev), cape(klon), tvp(klon, klev)
62	! Cape----output-R-CAPE (J/kg)
63	! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
64	! adiabatiquement a partir du niveau 1 (K)
65	REAL da(klon, klev), phi(klon, klev, klev), mp(klon, klev)
66	INTEGER iflag(klon)
67	REAL pbase(klon), bbase(klon)
68	REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
69	REAL dplcldt(klon), dplcldr(klon)
70	REAL qcondc(klon, klev)
71	REAL wd(klon)
72
73	REAL zx_t, zdelta, zx_qs, zcor
74
75	INTEGER i, k, itra
76	REAL qs(klon, klev)
77	REAL, save:: cbmf(klon)
78	INTEGER:: ifrst = 0
79
80	!-----------------------------------------------------------------
81
82	snow = 0
83
84	IF (ifrst==0) THEN
85	ifrst = 1
86	DO i = 1, klon
87	cbmf(i) = 0.
88	END DO
89	END IF
90
91	DO k = 1, klev + 1
92	DO i = 1, klon
93	em_ph(i, k) = paprs(i, k)/100.0
94	pmflxs(i, k) = 0.
95	END DO
96	END DO
97
98	DO k = 1, klev
99	DO i = 1, klon
100	em_p(i, k) = pplay(i, k)/100.0
101	END DO
102	END DO
103
104
105	IF (iflag_con==4) THEN
106	DO k = 1, klev
107	DO i = 1, klon
108	zx_t = t(i, k)
109	zdelta = max(0., sign(1., rtt-zx_t))
110	zx_qs = min(0.5, r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0)
111	zcor = 1./(1.-retv*zx_qs)
112	qs(i, k) = zx_qs*zcor
113	END DO
114	END DO
115	ELSE
116	! iflag_con=3 (modif de puristes qui fait la diffce pour la
117	! convergence numerique)
118	DO k = 1, klev
119	DO i = 1, klon
120	zx_t = t(i, k)
121	zdelta = max(0., sign(1., rtt-zx_t))
122	zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
123	zx_qs = min(0.5, zx_qs)
124	zcor = 1./(1.-retv*zx_qs)
125	zx_qs = zx_qs*zcor
126	qs(i, k) = zx_qs
127	END DO
128	END DO
129	END IF
130
131	CALL cv_driver(klon, klev, klev+1, ntra, t, q, qs, u, v, tra, em_p, &
132	em_ph, iflag, d_t, d_q, d_u, d_v, d_tra, rain, pmflxr, cbmf, work1, &
133	work2, kbas, ktop, dtime, ma, upwd, dnwd, dnwd0, qcondc, wd, cape, &
134	da, phi, mp)
135
136	DO i = 1, klon
137	rain(i) = rain(i)/86400.
138	END DO
139
140	DO k = 1, klev
141	DO i = 1, klon
142	d_t(i, k) = dtime*d_t(i, k)
143	d_q(i, k) = dtime*d_q(i, k)
144	d_u(i, k) = dtime*d_u(i, k)
145	d_v(i, k) = dtime*d_v(i, k)
146	END DO
147	END DO
148	DO itra = 1, ntra
149	DO k = 1, klev
150	DO i = 1, klon
151	d_tra(i, k, itra) = dtime*d_tra(i, k, itra)
152	END DO
153	END DO
154	END DO
155	! les traceurs ne sont pas mis dans cette version de convect4:
156	IF (iflag_con==4) THEN
157	DO itra = 1, ntra
158	DO k = 1, klev
159	DO i = 1, klon
160	d_tra(i, k, itra) = 0.
161	END DO
162	END DO
163	END DO
164	END IF
165
166	END SUBROUTINE concvl
167
168	end module concvl_m