trunk/phylmd/concvl.f

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	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	69	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	guez	13
12	guez	47	! From phylmd/concvl.F, version 1.3 2005/04/15 12:36:17
13	guez	62	! Author: Z. X. Li (LMD/CNRS)
14	guez	69	! Date: 1993/08/18
15	guez	62	! Objet : schéma de convection d'Emanuel (1991), interface
16	guez	69	! (driver commun aux versions 3 et 4)
17	guez	13
18	guez	69	use clesphys2, only: iflag_con
19	guez	52	use cv_driver_m, only: cv_driver
20	guez	69	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	guez	13
26	guez	62	INTEGER, PARAMETER:: ntrac = nqmx - 2
27	guez	13
28	guez	69	REAL, INTENT (IN):: dtime ! pas d'integration (s)
29			REAL, INTENT (IN):: paprs(klon, klev+1)
30			REAL, INTENT (IN):: pplay(klon, klev)
31	guez	52	REAL, intent(in):: t(klon, klev)
32	guez	69	real q(klon, klev) ! input vapeur d'eau (en kg/kg)
33			real u(klon, klev), v(klon, klev)
34	guez	47	REAL, INTENT (IN):: tra(klon, klev, ntrac)
35	guez	69	INTEGER, intent(in):: ntra ! number of tracers
36	guez	47	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	69	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	guez	3
136	guez	47	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