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	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