phylmd/Conflx/flxddraf.f90

      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, &
                 ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, &
                 lddraf, pen_d, pde_d)
      use dimens_m
      use dimphy
      use SUPHEC_M
      use yoethf_m
            use yoecumf
      IMPLICIT none
!
!----------------------------------------------------------------------
!          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
!
!          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
!          (I.E. T,Q,U AND V AND FLUXES)
!
!          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
!          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
!          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
!
!          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
!          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
!          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
!
!----------------------------------------------------------------------
!
      REAL ptenh(klon,klev), pqenh(klon,klev)
      REAL pgeoh(klon,klev), paph(klon,klev+1)
!
      REAL ptd(klon,klev), pqd(klon,klev)
      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
      REAL pdmfdp(klon,klev)
      REAL prfl(klon)
      LOGICAL lddraf(klon)
!
      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
      LOGICAL llo2(klon), llo1
      INTEGER i, k, is, icall, itopde
      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
      REAL zbuo
!----------------------------------------------------------------------
! CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
!       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
!           LINEAR DECREASE OF MASSFLUX IN PBL
!       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
!           AND MOISTENING IS CALCULATED IN *flxadjtq*
!       (C) CHECKING FOR NEGATIVE BUOYANCY AND
!           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
!
      DO 180 k = 3, klev
!
      is = 0
      DO i = 1, klon
         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
         IF (llo2(i)) is = is + 1
      ENDDO
      IF (is.EQ.0) GOTO 180
!
      DO i = 1, klon
      IF (llo2(i)) THEN
         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/ &
                 (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
         pen_d(i,k) = zentr
         pde_d(i,k) = zentr
      ENDIF
      ENDDO
!
      itopde = klev-2
      IF (k.GT.itopde) THEN
         DO i = 1, klon
         IF (llo2(i)) THEN
            pen_d(i,k)=0.
            pde_d(i,k)=pmfd(i,itopde)* &
            (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
         ENDIF
         ENDDO
      ENDIF
!
      DO i = 1, klon
      IF (llo2(i)) THEN
         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
         zqeen = pqenh(i,k-1)*pen_d(i,k)
         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
         zqdde = pqd(i,k-1)*pde_d(i,k)
         zmfdsk = pmfds(i,k-1)+zseen-zsdde
         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))- &
                     pgeoh(i,k))/RCPD
         ptd(i,k) = MIN(400.,ptd(i,k))
         ptd(i,k) = MAX(100.,ptd(i,k))
         zcond(i) = pqd(i,k)
      ENDIF
      ENDDO
!
      icall = 2
      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
!
      DO i = 1, klon
      IF (llo2(i)) THEN
         zcond(i) = zcond(i)-pqd(i,k)
         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))- &
                ptenh(i,k)*(1.+RETV  *pqenh(i,k))
         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
         IF (.not.llo1) pmfd(i,k) = 0.0
         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
         zdmfdp = -pmfd(i,k)*zcond(i)
         pdmfdp(i,k-1) = zdmfdp
         prfl(i) = prfl(i)+zdmfdp
      ENDIF
      ENDDO
!
  180 CONTINUE
      RETURN
      END
1	guez	52	SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, &
2			ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, &
3			lddraf, pen_d, pde_d)
4			use dimens_m
5			use dimphy
6			use SUPHEC_M
7			use yoethf_m
8			use yoecumf
9			IMPLICIT none
10			!
11			!----------------------------------------------------------------------
12			! THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
13			!
14			! TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
15			! (I.E. T,Q,U AND V AND FLUXES)
16			!
17			! INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
18			! IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
19			! AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
20			!
21			! CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
22			! A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
23			! B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
24			!
25			!----------------------------------------------------------------------
26			!
27			REAL ptenh(klon,klev), pqenh(klon,klev)
28			REAL pgeoh(klon,klev), paph(klon,klev+1)
29			!
30			REAL ptd(klon,klev), pqd(klon,klev)
31			REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
32			REAL pdmfdp(klon,klev)
33			REAL prfl(klon)
34			LOGICAL lddraf(klon)
35			!
36			REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
37			LOGICAL llo2(klon), llo1
38			INTEGER i, k, is, icall, itopde
39			REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
40			REAL zbuo
41			!----------------------------------------------------------------------
42			! CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
43			! (A) CALCULATING ENTRAINMENT RATES, ASSUMING
44			! LINEAR DECREASE OF MASSFLUX IN PBL
45			! (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
46			! AND MOISTENING IS CALCULATED IN flxadjtq
47			! (C) CHECKING FOR NEGATIVE BUOYANCY AND
48			! SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
49			!
50			DO 180 k = 3, klev
51			!
52			is = 0
53			DO i = 1, klon
54			llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
55			IF (llo2(i)) is = is + 1
56			ENDDO
57			IF (is.EQ.0) GOTO 180
58			!
59			DO i = 1, klon
60			IF (llo2(i)) THEN
61			zentr = ENTRDDpmfd(i,k-1)RD*ptenh(i,k-1)/ &
62			(RGpaph(i,k-1))(paph(i,k)-paph(i,k-1))
63			pen_d(i,k) = zentr
64			pde_d(i,k) = zentr
65			ENDIF
66			ENDDO
67			!
68			itopde = klev-2
69			IF (k.GT.itopde) THEN
70			DO i = 1, klon
71			IF (llo2(i)) THEN
72			pen_d(i,k)=0.
73			pde_d(i,k)=pmfd(i,itopde)* &
74			(paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
75			ENDIF
76			ENDDO
77			ENDIF
78			!
79			DO i = 1, klon
80			IF (llo2(i)) THEN
81			pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
82			zseen = (RCPDptenh(i,k-1)+pgeoh(i,k-1))pen_d(i,k)
83			zqeen = pqenh(i,k-1)*pen_d(i,k)
84			zsdde = (RCPDptd(i,k-1)+pgeoh(i,k-1))pde_d(i,k)
85			zqdde = pqd(i,k-1)*pde_d(i,k)
86			zmfdsk = pmfds(i,k-1)+zseen-zsdde
87			zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
88			pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
89			ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))- &
90			pgeoh(i,k))/RCPD
91			ptd(i,k) = MIN(400.,ptd(i,k))
92			ptd(i,k) = MAX(100.,ptd(i,k))
93			zcond(i) = pqd(i,k)
94			ENDIF
95			ENDDO
96			!
97			icall = 2
98			CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
99			!
100			DO i = 1, klon
101			IF (llo2(i)) THEN
102			zcond(i) = zcond(i)-pqd(i,k)
103			zbuo = ptd(i,k)(1.+RETV pqd(i,k))- &
104			ptenh(i,k)(1.+RETV pqenh(i,k))
105			llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
106			IF (.not.llo1) pmfd(i,k) = 0.0
107			pmfds(i,k) = (RCPDptd(i,k)+pgeoh(i,k))pmfd(i,k)
108			pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
109			zdmfdp = -pmfd(i,k)*zcond(i)
110			pdmfdp(i,k-1) = zdmfdp
111			prfl(i) = prfl(i)+zdmfdp
112			ENDIF
113			ENDDO
114			!
115			180 CONTINUE
116			RETURN
117			END