/[lmdze]/trunk/phylmd/Conflx/flxddraf.f
ViewVC logotype

Diff of /trunk/phylmd/Conflx/flxddraf.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/phylmd/Conflx/flxddraf.f90 revision 52 by guez, Fri Sep 23 12:28:01 2011 UTC trunk/Sources/phylmd/Conflx/flxddraf.f revision 134 by guez, Wed Apr 29 15:47:56 2015 UTC
# Line 1  Line 1 
1        SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, &  module flxddraf_m
2                   ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, &  
3                   lddraf, pen_d, pde_d)    IMPLICIT none
4        use dimens_m  
5        use dimphy  contains
6        use SUPHEC_M  
7        use yoethf_m    SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, ptd, pqd, pmfd, pmfds, &
8              use yoecumf         pmfdq, pdmfdp, lddraf, pen_d, pde_d)
9        IMPLICIT none  
10  !      ! This routine calculates cumulus downdraft descent
11  !----------------------------------------------------------------------  
12  !          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT      ! To produce the vertical profiles for cumulus downdrafts
13  !      ! (i.e. T, q, u and v and fluxes)
14  !          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS  
15  !          (I.E. T,Q,U AND V AND FLUXES)      ! Input is T, q, p, Phi, u, v at half levels.
16  !      ! It returns fluxes of s, q and evaporation rate
17  !          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.      ! and u, v at levels where downdraft occurs
18  !          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE  
19  !          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS      ! Calculate moist descent for entraining/detraining plume by
20  !      ! A) moving air dry-adiabatically to next level below and
21  !          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY      ! B) correcting for evaporation to obtain saturated state.
22  !          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND  
23  !          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.      USE dimphy, ONLY: klev, klon
24  !      USE flxadjtq_m, ONLY: flxadjtq
25  !----------------------------------------------------------------------      USE suphec_m, ONLY: rcpd, rd, retv, rg
26  !      USE yoecumf, ONLY: cmfcmin, entrdd
27        REAL ptenh(klon,klev), pqenh(klon,klev)  
28        REAL pgeoh(klon,klev), paph(klon,klev+1)      REAL ptenh(klon, klev), pqenh(klon, klev)
29  !      REAL, intent(in):: pgeoh(klon, klev), paph(klon, klev + 1)
30        REAL ptd(klon,klev), pqd(klon,klev)      REAL prfl(klon)
31        REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)      REAL ptd(klon, klev), pqd(klon, klev)
32        REAL pdmfdp(klon,klev)      REAL pmfd(klon, klev), pmfds(klon, klev), pmfdq(klon, klev)
33        REAL prfl(klon)      REAL pdmfdp(klon, klev)
34        LOGICAL lddraf(klon)      LOGICAL lddraf(klon)
35  !      REAL pen_d(klon, klev), pde_d(klon, klev)
36        REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)  
37        LOGICAL llo2(klon), llo1      ! Local:
38        INTEGER i, k, is, icall, itopde      real zcond(klon)
39        REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp      LOGICAL llo2(klon), llo1
40        REAL zbuo      INTEGER i, k, is, icall, itopde
41  !----------------------------------------------------------------------      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
42  ! CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY      REAL zbuo
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*      ! Calculate moist descent for cumulus downdraft by
47  !       (C) CHECKING FOR NEGATIVE BUOYANCY AND  
48  !           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES      ! (A) calculating entrainment rates, assuming linear decrease of
49  !      ! massflux in PBL
50        DO 180 k = 3, klev  
51  !      ! (B) doing moist descent - evaporative cooling and moistening is
52        is = 0      ! calculated in flxadjtq
53        DO i = 1, klon  
54           llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.      ! (C) checking for negative buoyancy and specifying final T, q, u,
55           IF (llo2(i)) is = is + 1      ! v and downward fluxes
56        ENDDO  
57        IF (is.EQ.0) GOTO 180      DO k = 3, klev
58  !         is = 0
59        DO i = 1, klon         DO i = 1, klon
60        IF (llo2(i)) THEN            llo2(i)=lddraf(i).AND.pmfd(i, k-1).LT.0.
61           zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/ &            IF (llo2(i)) is = is + 1
62                   (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))         ENDDO
63           pen_d(i,k) = zentr         IF (is.EQ.0) cycle
64           pde_d(i,k) = zentr  
65        ENDIF         DO i = 1, klon
66        ENDDO            IF (llo2(i)) THEN
67  !               zentr = ENTRDD*pmfd(i, k-1)*RD*ptenh(i, k-1)/ &
68        itopde = klev-2                    (RG*paph(i, k-1))*(paph(i, k)-paph(i, k-1))
69        IF (k.GT.itopde) THEN               pen_d(i, k) = zentr
70           DO i = 1, klon               pde_d(i, k) = zentr
71           IF (llo2(i)) THEN            ENDIF
72              pen_d(i,k)=0.         ENDDO
73              pde_d(i,k)=pmfd(i,itopde)* &  
74              (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))         itopde = klev-2
75           ENDIF         IF (k.GT.itopde) THEN
76           ENDDO            DO i = 1, klon
77        ENDIF               IF (llo2(i)) THEN
78  !                  pen_d(i, k)=0.
79        DO i = 1, klon                  pde_d(i, k) = pmfd(i, itopde) * (paph(i, k) - paph(i, k - 1)) &
80        IF (llo2(i)) THEN                       / (paph(i, klev + 1) - paph(i, itopde))
81           pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)               ENDIF
82           zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)            ENDDO
83           zqeen = pqenh(i,k-1)*pen_d(i,k)         ENDIF
84           zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)  
85           zqdde = pqd(i,k-1)*pde_d(i,k)         DO i = 1, klon
86           zmfdsk = pmfds(i,k-1)+zseen-zsdde            IF (llo2(i)) THEN
87           zmfdqk = pmfdq(i,k-1)+zqeen-zqdde               pmfd(i, k) = pmfd(i, k-1) + pen_d(i, k)-pde_d(i, k)
88           pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))               zseen = (RCPD*ptenh(i, k-1) + pgeoh(i, k-1))*pen_d(i, k)
89           ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))- &               zqeen = pqenh(i, k-1)*pen_d(i, k)
90                       pgeoh(i,k))/RCPD               zsdde = (RCPD*ptd(i, k-1) + pgeoh(i, k-1))*pde_d(i, k)
91           ptd(i,k) = MIN(400.,ptd(i,k))               zqdde = pqd(i, k-1)*pde_d(i, k)
92           ptd(i,k) = MAX(100.,ptd(i,k))               zmfdsk = pmfds(i, k-1) + zseen-zsdde
93           zcond(i) = pqd(i,k)               zmfdqk = pmfdq(i, k-1) + zqeen-zqdde
94        ENDIF               pqd(i, k) = zmfdqk*(1./MIN(-CMFCMIN, pmfd(i, k)))
95        ENDDO               ptd(i, k) = (zmfdsk*(1./MIN(-CMFCMIN, pmfd(i, k)))- &
96  !                    pgeoh(i, k))/RCPD
97        icall = 2               ptd(i, k) = MIN(400., ptd(i, k))
98        CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)               ptd(i, k) = MAX(100., ptd(i, k))
99  !               zcond(i) = pqd(i, k)
100        DO i = 1, klon            ENDIF
101        IF (llo2(i)) THEN         ENDDO
102           zcond(i) = zcond(i)-pqd(i,k)  
103           zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))- &         icall = 2
104                  ptenh(i,k)*(1.+RETV  *pqenh(i,k))         CALL flxadjtq(paph(:, k), ptd(1, k), pqd(1, k), llo2, icall)
105           llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)  
106           IF (.not.llo1) pmfd(i,k) = 0.0         DO i = 1, klon
107           pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)            IF (llo2(i)) THEN
108           pmfdq(i,k) = pqd(i,k)*pmfd(i,k)               zcond(i) = zcond(i)-pqd(i, k)
109           zdmfdp = -pmfd(i,k)*zcond(i)               zbuo = ptd(i, k)*(1. + RETV *pqd(i, k))- &
110           pdmfdp(i,k-1) = zdmfdp                    ptenh(i, k)*(1. + RETV *pqenh(i, k))
111           prfl(i) = prfl(i)+zdmfdp               llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i, k)*zcond(i).GT.0.)
112        ENDIF               IF (.not.llo1) pmfd(i, k) = 0.0
113        ENDDO               pmfds(i, k) = (RCPD*ptd(i, k) + pgeoh(i, k))*pmfd(i, k)
114  !               pmfdq(i, k) = pqd(i, k)*pmfd(i, k)
115    180 CONTINUE               zdmfdp = -pmfd(i, k)*zcond(i)
116        RETURN               pdmfdp(i, k-1) = zdmfdp
117        END               prfl(i) = prfl(i) + zdmfdp
118              ENDIF
119           ENDDO
120        end DO
121    
122      END SUBROUTINE flxddraf
123    
124    end module flxddraf_m
Legend:
Removed from v.52  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.21