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