/[lmdze]/trunk/Sources/phylmd/Radlwsw/swu.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/swu.f

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

trunk/libf/phylmd/Radlwsw/swu.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/Sources/phylmd/Radlwsw/swu.f revision 134 by guez, Wed Apr 29 15:47:56 2015 UTC
# Line 1  Line 1 
1  c  SUBROUTINE swu(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, paki, &
2  cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,      pcld, pclear, pdsig, pfact, prmu, psec, pud)
3        SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,  
4       S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,    USE dimens_m
5       S                PRMU,PSEC,PUD)    USE dimphy
6        use dimens_m    USE clesphys
7        use dimphy    USE suphec_m
8        use clesphys    USE raddim
9        use YOMCST    USE radepsi
10        use raddim    USE radopt
11        use radepsi    IMPLICIT NONE
12        use radopt  
13        IMPLICIT none    ! * ARGUMENTS:
14  C  
15  C* ARGUMENTS:    DOUBLE PRECISION psct
16  C    ! IM ctes ds clesphys.h   DOUBLE PRECISION RCO2
17        REAL*8 PSCT    DOUBLE PRECISION pcldsw(kdlon, kflev)
18  cIM ctes ds clesphys.h   REAL*8 RCO2    DOUBLE PRECISION ppmb(kdlon, kflev+1)
19        REAL*8 PCLDSW(KDLON,KFLEV)    DOUBLE PRECISION ppsol(kdlon)
20        REAL*8 PPMB(KDLON,KFLEV+1)    DOUBLE PRECISION prmu0(kdlon)
21        REAL*8 PPSOL(KDLON)    DOUBLE PRECISION pfrac(kdlon)
22        REAL*8 PRMU0(KDLON)    DOUBLE PRECISION ptave(kdlon, kflev)
23        REAL*8 PFRAC(KDLON)    DOUBLE PRECISION pwv(kdlon, kflev)
24        REAL*8 PTAVE(KDLON,KFLEV)  
25        REAL*8 PWV(KDLON,KFLEV)    DOUBLE PRECISION paki(kdlon, 2)
26  C    DOUBLE PRECISION pcld(kdlon, kflev)
27        REAL*8 PAKI(KDLON,2)    DOUBLE PRECISION pclear(kdlon)
28        REAL*8 PCLD(KDLON,KFLEV)    DOUBLE PRECISION pdsig(kdlon, kflev)
29        REAL*8 PCLEAR(KDLON)    DOUBLE PRECISION pfact(kdlon)
30        REAL*8 PDSIG(KDLON,KFLEV)    DOUBLE PRECISION prmu(kdlon)
31        REAL*8 PFACT(KDLON)    DOUBLE PRECISION psec(kdlon)
32        REAL*8 PRMU(KDLON)    DOUBLE PRECISION pud(kdlon, 5, kflev+1)
33        REAL*8 PSEC(KDLON)  
34        REAL*8 PUD(KDLON,5,KFLEV+1)    ! * LOCAL VARIABLES:
35  C  
36  C* LOCAL VARIABLES:    INTEGER iind(2)
37  C    DOUBLE PRECISION zc1j(kdlon, kflev+1)
38        INTEGER IIND(2)    DOUBLE PRECISION zclear(kdlon)
39        REAL*8 ZC1J(KDLON,KFLEV+1)    DOUBLE PRECISION zcloud(kdlon)
40        REAL*8 ZCLEAR(KDLON)    DOUBLE PRECISION zn175(kdlon)
41        REAL*8 ZCLOUD(KDLON)    DOUBLE PRECISION zn190(kdlon)
42        REAL*8 ZN175(KDLON)    DOUBLE PRECISION zo175(kdlon)
43        REAL*8 ZN190(KDLON)    DOUBLE PRECISION zo190(kdlon)
44        REAL*8 ZO175(KDLON)    DOUBLE PRECISION zsign(kdlon)
45        REAL*8 ZO190(KDLON)    DOUBLE PRECISION zr(kdlon, 2)
46        REAL*8 ZSIGN(KDLON)    DOUBLE PRECISION zsigo(kdlon)
47        REAL*8 ZR(KDLON,2)    DOUBLE PRECISION zud(kdlon, 2)
48        REAL*8 ZSIGO(KDLON)    DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
49        REAL*8 ZUD(KDLON,2)    INTEGER jl, jk, jkp1, jkl, jklp1, ja
50        REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW  
51        INTEGER jl, jk, jkp1, jkl, jklp1, ja    ! * Prescribed Data:
52  C  
53  C* Prescribed Data:    DOUBLE PRECISION zpdh2o, zpdumg
54  c    SAVE zpdh2o, zpdumg
55        REAL*8 ZPDH2O,ZPDUMG    DOUBLE PRECISION zprh2o, zprumg
56        SAVE ZPDH2O,ZPDUMG    SAVE zprh2o, zprumg
57        REAL*8 ZPRH2O,ZPRUMG    DOUBLE PRECISION rtdh2o, rtdumg
58        SAVE ZPRH2O,ZPRUMG    SAVE rtdh2o, rtdumg
59        REAL*8 RTDH2O,RTDUMG    DOUBLE PRECISION rth2o, rtumg
60        SAVE RTDH2O,RTDUMG    SAVE rth2o, rtumg
61        REAL*8 RTH2O ,RTUMG    DATA zpdh2o, zpdumg/0.8, 0.75/
62        SAVE RTH2O ,RTUMG    DATA zprh2o, zprumg/30000., 30000./
63        DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /    DATA rtdh2o, rtdumg/0.40, 0.375/
64        DATA ZPRH2O,ZPRUMG / 30000., 30000. /    DATA rth2o, rtumg/240., 240./
65        DATA RTDH2O,RTDUMG /  0.40  , 0.375 /    ! ------------------------------------------------------------------
66        DATA RTH2O ,RTUMG  /  240.  , 240.  /  
67  C     ------------------------------------------------------------------    ! *         1.     COMPUTES AMOUNTS OF ABSORBERS
68  C    ! -----------------------------
69  C*         1.     COMPUTES AMOUNTS OF ABSORBERS  
70  C                 -----------------------------  
71  C    iind(1) = 1
72   100  CONTINUE    iind(2) = 2
73  C  
74        IIND(1)=1  
75        IIND(2)=2    ! *         1.1    INITIALIZES QUANTITIES
76  C          ! ----------------------
77  C  
78  C*         1.1    INITIALIZES QUANTITIES  
79  C                 ----------------------    DO jl = 1, kdlon
80  C      pud(jl, 1, kflev+1) = 0.
81   110  CONTINUE      pud(jl, 2, kflev+1) = 0.
82  C      pud(jl, 3, kflev+1) = 0.
83        DO 111 JL = 1, KDLON      pud(jl, 4, kflev+1) = 0.
84        PUD(JL,1,KFLEV+1)=0.      pud(jl, 5, kflev+1) = 0.
85        PUD(JL,2,KFLEV+1)=0.      pfact(jl) = prmu0(jl)*pfrac(jl)*psct
86        PUD(JL,3,KFLEV+1)=0.      prmu(jl) = sqrt(1224.*prmu0(jl)*prmu0(jl)+1.)/35.
87        PUD(JL,4,KFLEV+1)=0.      psec(jl) = 1./prmu(jl)
88        PUD(JL,5,KFLEV+1)=0.      zc1j(jl, kflev+1) = 0.
89        PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT    END DO
90        PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.  
91        PSEC(JL)=1./PRMU(JL)    ! *          1.3    AMOUNTS OF ABSORBERS
92        ZC1J(JL,KFLEV+1)=0.    ! --------------------
93   111  CONTINUE  
94  C  
95  C*          1.3    AMOUNTS OF ABSORBERS    DO jl = 1, kdlon
96  C                  --------------------      zud(jl, 1) = 0.
97  C      zud(jl, 2) = 0.
98   130  CONTINUE      zo175(jl) = ppsol(jl)**(zpdumg+1.)
99  C      zo190(jl) = ppsol(jl)**(zpdh2o+1.)
100        DO 131 JL= 1, KDLON      zsigo(jl) = ppsol(jl)
101        ZUD(JL,1) = 0.      zclear(jl) = 1.
102        ZUD(JL,2) = 0.      zcloud(jl) = 0.
103        ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)    END DO
104        ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)  
105        ZSIGO(JL) = PPSOL(JL)    DO jk = 1, kflev
106        ZCLEAR(JL)=1.      jkp1 = jk + 1
107        ZCLOUD(JL)=0.      jkl = kflev + 1 - jk
108   131  CONTINUE      jklp1 = jkl + 1
109  C      DO jl = 1, kdlon
110        DO 133 JK = 1 , KFLEV        zrth = (rth2o/ptave(jl,jk))**rtdh2o
111        JKP1 = JK + 1        zrtu = (rtumg/ptave(jl,jk))**rtdumg
112        JKL = KFLEV+1 - JK        zwh2o = max(pwv(jl,jk), zepscq)
113        JKLP1 = JKL+1        zsign(jl) = 100.*ppmb(jl, jkp1)
114        DO 132 JL = 1, KDLON        pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
115        ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O        zn175(jl) = zsign(jl)**(zpdumg+1.)
116        ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG        zn190(jl) = zsign(jl)**(zpdh2o+1.)
117        ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )        zdsco2 = zo175(jl) - zn175(jl)
118        ZSIGN(JL) = 100. * PPMB(JL,JKP1)        zdsh2o = zo190(jl) - zn190(jl)
119        PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)        pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &
120        ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)          zrth
121        ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)        pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &
122        ZDSCO2 = ZO175(JL) - ZN175(JL)          zrtu
123        ZDSH2O = ZO190(JL) - ZN190(JL)        zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)
124        PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)        pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
125       .             * ZDSH2O * ZWH2O  * ZRTH        pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
126        PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)        zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
127       .             * ZDSCO2 * RCO2 * ZRTU        zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
128        ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)        zsigo(jl) = zsign(jl)
129        PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW        zo175(jl) = zn175(jl)
130        PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)        zo190(jl) = zn190(jl)
131        ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)  
132        ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)        IF (novlp==1) THEN
133        ZSIGO(JL) = ZSIGN(JL)          zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
134        ZO175(JL) = ZN175(JL)            zcloud(jl),1.-zepsec))
135        ZO190(JL) = ZN190(JL)          zc1j(jl, jkl) = 1.0 - zclear(jl)
136  C                zcloud(jl) = pcldsw(jl, jkl)
137        IF (NOVLP.EQ.1) THEN        ELSE IF (novlp==2) THEN
138           ZCLEAR(JL)=ZCLEAR(JL)          zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
139       S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))          zc1j(jl, jkl) = zcloud(jl)
140       S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))        ELSE IF (novlp==3) THEN
141           ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)          zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
142           ZCLOUD(JL) = PCLDSW(JL,JKL)          zcloud(jl) = 1.0 - zclear(jl)
143        ELSE IF (NOVLP.EQ.2) THEN          zc1j(jl, jkl) = zcloud(jl)
          ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))  
          ZC1J(JL,JKL) = ZCLOUD(JL)  
       ELSE IF (NOVLP.EQ.3) THEN  
          ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))  
          ZCLOUD(JL) = 1.0 - ZCLEAR(JL)  
          ZC1J(JL,JKL) = ZCLOUD(JL)  
144        END IF        END IF
145   132  CONTINUE      END DO
146   133  CONTINUE    END DO
147        DO 134 JL=1, KDLON    DO jl = 1, kdlon
148        PCLEAR(JL)=1.-ZC1J(JL,1)      pclear(jl) = 1. - zc1j(jl, 1)
149   134  CONTINUE    END DO
150        DO 136 JK=1,KFLEV    DO jk = 1, kflev
151        DO 135 JL=1, KDLON      DO jl = 1, kdlon
152        IF (PCLEAR(JL).LT.1.) THEN        IF (pclear(jl)<1.) THEN
153           PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))          pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
154        ELSE        ELSE
155           PCLD(JL,JK)=0.          pcld(jl, jk) = 0.
156        END IF        END IF
157   135  CONTINUE      END DO
158   136  CONTINUE              END DO
159  C        
160  C  
161  C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS    ! *         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
162  C                 -----------------------------------------------    ! -----------------------------------------------
163  C  
164   140  CONTINUE  
165  C    DO ja = 1, 2
166        DO 142 JA = 1,2      DO jl = 1, kdlon
167        DO 141 JL = 1, KDLON        zud(jl, ja) = zud(jl, ja)*psec(jl)
168        ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)      END DO
169   141  CONTINUE    END DO
170   142  CONTINUE  
171  C    CALL swtt1(2, 2, iind, zud, zr)
172        CALL SWTT1(2, 2, IIND, ZUD, ZR)  
173  C    DO ja = 1, 2
174        DO 144 JA = 1,2      DO jl = 1, kdlon
175        DO 143 JL = 1, KDLON        paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
176        PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)      END DO
177   143  CONTINUE    END DO
178   144  CONTINUE  
179  C  END SUBROUTINE swu
 C  
 C     ------------------------------------------------------------------  
 C  
       RETURN  
       END  
Legend:
Removed from v.24  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.21