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, dnwd0, 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 d'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

    INTEGER, PARAMETER:: ntrac = nqmx - 2

    INTEGER, INTENT (IN) :: iflag_con
    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), u(klon, klev), v(klon, klev)
    ! q-------input-R-vapeur d'eau (en kg/kg)
    REAL, INTENT (IN):: tra(klon, klev, ntrac)
    INTEGER ntra
    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

    ! 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, 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	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	guez	62	ktop, upwd, dnwd, dnwd0, ma, cape, tvp, iflag, pbase, bbase, &
10	guez	47	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	guez	62	! Author: Z. X. Li (LMD/CNRS)
15	guez	47	! date: 1993/08/18
16	guez	62	! Objet : schéma de convection d'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	62	INTEGER, PARAMETER:: ntrac = nqmx - 2
26	guez	13
27	guez	47	INTEGER, INTENT (IN) :: iflag_con
28	guez	62	REAL, INTENT (IN) :: dtime ! pas d'integration (s)
29	guez	47	REAL, INTENT (IN) :: paprs(klon, klev+1)
30			REAL, INTENT (IN) :: pplay(klon, klev)
31	guez	52	REAL, intent(in):: t(klon, klev)
32			real q(klon, klev), u(klon, klev), v(klon, klev)
33	guez	62	! q-------input-R-vapeur d'eau (en kg/kg)
34	guez	47	REAL, INTENT (IN):: tra(klon, klev, ntrac)
35			INTEGER ntra
36			REAL work1(klon, klev), work2(klon, klev)
37	guez	62	! work*: input et output: deux variables de travail,
38			! on peut les mettre a 0 au debut
39	guez	47	REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
40	guez	13
41	guez	47	REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, &
42			klev)
43	guez	62	! d_q-----output-R-increment de la vapeur d'eau
44	guez	47	REAL d_tra(klon, klev, ntrac)
45			REAL rain(klon), snow(klon)
46	guez	62	! rain----output-R-la pluie (mm/s)
47			! snow----output-R-la neige (mm/s)
48	guez	13
49	guez	47	INTEGER kbas(klon), ktop(klon)
50			REAL em_ph(klon, klev+1), em_p(klon, klev)
51	guez	62
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	guez	47	REAL ma(klon, klev), cape(klon), tvp(klon, klev)
62	guez	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	guez	47	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	guez	13
73	guez	47	REAL zx_t, zdelta, zx_qs, zcor
74	guez	13
75	guez	47	INTEGER i, k, itra
76			REAL qs(klon, klev)
77	guez	62	REAL, save:: cbmf(klon)
78			INTEGER:: ifrst = 0
79	guez	13
80	guez	47	!-----------------------------------------------------------------
81	guez	13
82	guez	62	snow = 0
83	guez	13
84	guez	47	IF (ifrst==0) THEN
85			ifrst = 1
86			DO i = 1, klon
87			cbmf(i) = 0.
88			END DO
89			END IF
90	guez	13
91	guez	47	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	guez	13
98	guez	47	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	guez	3
104
105	guez	47	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	guez	3
131	guez	47	! Main driver for convection:
132			! iflag_con = 3 -> equivalent to convect3
133			! iflag_con = 4 -> equivalent to convect1/2
134	guez	3
135	guez	62	CALL cv_driver(klon, klev, klev+1, ntra, iflag_con, t, q, qs, u, v, tra, &
136			em_p, em_ph, iflag, d_t, d_q, d_u, d_v, d_tra, rain, pmflxr, cbmf, &
137			work1, work2, kbas, ktop, dtime, ma, upwd, dnwd, dnwd0, qcondc, &
138			wd, cape, da, phi, mp)
139	guez	13
140	guez	47	DO i = 1, klon
141			rain(i) = rain(i)/86400.
142			END DO
143
144			DO k = 1, klev
145			DO i = 1, klon
146			d_t(i, k) = dtime*d_t(i, k)
147			d_q(i, k) = dtime*d_q(i, k)
148			d_u(i, k) = dtime*d_u(i, k)
149			d_v(i, k) = dtime*d_v(i, k)
150			END DO
151			END DO
152			DO itra = 1, ntra
153			DO k = 1, klev
154			DO i = 1, klon
155			d_tra(i, k, itra) = dtime*d_tra(i, k, itra)
156			END DO
157			END DO
158			END DO
159			! les traceurs ne sont pas mis dans cette version de convect4:
160			IF (iflag_con==4) THEN
161			DO itra = 1, ntra
162			DO k = 1, klev
163			DO i = 1, klon
164			d_tra(i, k, itra) = 0.
165			END DO
166			END DO
167			END DO
168			END IF
169
170			END SUBROUTINE concvl
171
172			end module concvl_m