/[lmdze]/trunk/phylmd/Radlwsw/swu.f90
ViewVC logotype

Diff of /trunk/phylmd/Radlwsw/swu.f90

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

trunk/phylmd/Radlwsw/swu.f revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/Sources/phylmd/Radlwsw/swu.f revision 178 by guez, Fri Mar 11 18:47:26 2016 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 SUPHEC_M    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        DOUBLE PRECISION PSCT    DOUBLE PRECISION pcldsw(kdlon, kflev)
18  cIM ctes ds clesphys.h   DOUBLE PRECISION RCO2    DOUBLE PRECISION ppmb(kdlon, kflev+1)
19        DOUBLE PRECISION PCLDSW(KDLON,KFLEV)    DOUBLE PRECISION ppsol(kdlon)
20        DOUBLE PRECISION PPMB(KDLON,KFLEV+1)    DOUBLE PRECISION prmu0(kdlon)
21        DOUBLE PRECISION PPSOL(KDLON)    DOUBLE PRECISION pfrac(kdlon)
22        DOUBLE PRECISION PRMU0(KDLON)    DOUBLE PRECISION ptave(kdlon, kflev)
23        DOUBLE PRECISION PFRAC(KDLON)    DOUBLE PRECISION pwv(kdlon, kflev)
24        DOUBLE PRECISION PTAVE(KDLON,KFLEV)  
25        DOUBLE PRECISION PWV(KDLON,KFLEV)    DOUBLE PRECISION paki(kdlon, 2)
26  C    DOUBLE PRECISION pcld(kdlon, kflev)
27        DOUBLE PRECISION PAKI(KDLON,2)    DOUBLE PRECISION pclear(kdlon)
28        DOUBLE PRECISION PCLD(KDLON,KFLEV)    DOUBLE PRECISION pdsig(kdlon, kflev)
29        DOUBLE PRECISION PCLEAR(KDLON)    DOUBLE PRECISION pfact(kdlon)
30        DOUBLE PRECISION PDSIG(KDLON,KFLEV)    DOUBLE PRECISION prmu(kdlon)
31        DOUBLE PRECISION PFACT(KDLON)    DOUBLE PRECISION psec(kdlon)
32        DOUBLE PRECISION PRMU(KDLON)    DOUBLE PRECISION pud(kdlon, 5, kflev+1)
33        DOUBLE PRECISION PSEC(KDLON)  
34        DOUBLE PRECISION 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        DOUBLE PRECISION ZC1J(KDLON,KFLEV+1)    DOUBLE PRECISION zcloud(kdlon)
40        DOUBLE PRECISION ZCLEAR(KDLON)    DOUBLE PRECISION zn175(kdlon)
41        DOUBLE PRECISION ZCLOUD(KDLON)    DOUBLE PRECISION zn190(kdlon)
42        DOUBLE PRECISION ZN175(KDLON)    DOUBLE PRECISION zo175(kdlon)
43        DOUBLE PRECISION ZN190(KDLON)    DOUBLE PRECISION zo190(kdlon)
44        DOUBLE PRECISION ZO175(KDLON)    DOUBLE PRECISION zsign(kdlon)
45        DOUBLE PRECISION ZO190(KDLON)    DOUBLE PRECISION zr(kdlon, 2)
46        DOUBLE PRECISION ZSIGN(KDLON)    DOUBLE PRECISION zsigo(kdlon)
47        DOUBLE PRECISION ZR(KDLON,2)    DOUBLE PRECISION zud(kdlon, 2)
48        DOUBLE PRECISION ZSIGO(KDLON)    DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
49        DOUBLE PRECISION ZUD(KDLON,2)    INTEGER jl, jk, jkp1, jkl, ja
50        DOUBLE PRECISION 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        DOUBLE PRECISION ZPDH2O,ZPDUMG    DOUBLE PRECISION zprh2o, zprumg
56        SAVE ZPDH2O,ZPDUMG    SAVE zprh2o, zprumg
57        DOUBLE PRECISION ZPRH2O,ZPRUMG    DOUBLE PRECISION rtdh2o, rtdumg
58        SAVE ZPRH2O,ZPRUMG    SAVE rtdh2o, rtdumg
59        DOUBLE PRECISION RTDH2O,RTDUMG    DOUBLE PRECISION rth2o, rtumg
60        SAVE RTDH2O,RTDUMG    SAVE rth2o, rtumg
61        DOUBLE PRECISION RTH2O ,RTUMG    DATA zpdh2o, zpdumg/0.8d0, 0.75d0/
62        SAVE RTH2O ,RTUMG    DATA zprh2o, zprumg/30000.d0, 30000.d0/
63        DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /    DATA rtdh2o, rtdumg/0.40d0, 0.375d0/
64        DATA ZPRH2O,ZPRUMG / 30000., 30000. /    DATA rth2o, rtumg/240.d0, 240.d0/
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      DO jl = 1, kdlon
109  C        zrth = (rth2o/ptave(jl,jk))**rtdh2o
110        DO 133 JK = 1 , KFLEV        zrtu = (rtumg/ptave(jl,jk))**rtdumg
111        JKP1 = JK + 1        zwh2o = max(pwv(jl,jk), zepscq)
112        JKL = KFLEV+1 - JK        zsign(jl) = 100.*ppmb(jl, jkp1)
113        JKLP1 = JKL+1        pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
114        DO 132 JL = 1, KDLON        zn175(jl) = zsign(jl)**(zpdumg+1.)
115        ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O        zn190(jl) = zsign(jl)**(zpdh2o+1.)
116        ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG        zdsco2 = zo175(jl) - zn175(jl)
117        ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )        zdsh2o = zo190(jl) - zn190(jl)
118        ZSIGN(JL) = 100. * PPMB(JL,JKP1)        pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &
119        PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)          zrth
120        ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)        pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &
121        ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)          zrtu
122        ZDSCO2 = ZO175(JL) - ZN175(JL)        zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)
123        ZDSH2O = ZO190(JL) - ZN190(JL)        pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
124        PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)        pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
125       .             * ZDSH2O * ZWH2O  * ZRTH        zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
126        PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)        zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
127       .             * ZDSCO2 * RCO2 * ZRTU        zsigo(jl) = zsign(jl)
128        ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)        zo175(jl) = zn175(jl)
129        PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW        zo190(jl) = zn190(jl)
130        PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)  
131        ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)        IF (novlp==1) THEN
132        ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)          zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
133        ZSIGO(JL) = ZSIGN(JL)            zcloud(jl),1.-zepsec))
134        ZO175(JL) = ZN175(JL)          zc1j(jl, jkl) = 1.0 - zclear(jl)
135        ZO190(JL) = ZN190(JL)          zcloud(jl) = pcldsw(jl, jkl)
136  C              ELSE IF (novlp==2) THEN
137        IF (NOVLP.EQ.1) THEN          zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
138           ZCLEAR(JL)=ZCLEAR(JL)          zc1j(jl, jkl) = zcloud(jl)
139       S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))        ELSE IF (novlp==3) THEN
140       S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))          zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
141           ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)          zcloud(jl) = 1.0 - zclear(jl)
142           ZCLOUD(JL) = PCLDSW(JL,JKL)          zc1j(jl, jkl) = zcloud(jl)
       ELSE IF (NOVLP.EQ.2) THEN  
          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)  
143        END IF        END IF
144   132  CONTINUE      END DO
145   133  CONTINUE    END DO
146        DO 134 JL=1, KDLON    DO jl = 1, kdlon
147        PCLEAR(JL)=1.-ZC1J(JL,1)      pclear(jl) = 1. - zc1j(jl, 1)
148   134  CONTINUE    END DO
149        DO 136 JK=1,KFLEV    DO jk = 1, kflev
150        DO 135 JL=1, KDLON      DO jl = 1, kdlon
151        IF (PCLEAR(JL).LT.1.) THEN        IF (pclear(jl)<1.) THEN
152           PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))          pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
153        ELSE        ELSE
154           PCLD(JL,JK)=0.          pcld(jl, jk) = 0.
155        END IF        END IF
156   135  CONTINUE      END DO
157   136  CONTINUE              END DO
158  C        
159  C  
160  C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS    ! *         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
161  C                 -----------------------------------------------    ! -----------------------------------------------
162  C  
163   140  CONTINUE  
164  C    DO ja = 1, 2
165        DO 142 JA = 1,2      DO jl = 1, kdlon
166        DO 141 JL = 1, KDLON        zud(jl, ja) = zud(jl, ja)*psec(jl)
167        ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)      END DO
168   141  CONTINUE    END DO
169   142  CONTINUE  
170  C    CALL swtt1(2, 2, iind, zud, zr)
171        CALL SWTT1(2, 2, IIND, ZUD, ZR)  
172  C    DO ja = 1, 2
173        DO 144 JA = 1,2      DO jl = 1, kdlon
174        DO 143 JL = 1, KDLON        paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
175        PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)      END DO
176   143  CONTINUE    END DO
177   144  CONTINUE  
178  C  END SUBROUTINE swu
 C  
 C     ------------------------------------------------------------------  
 C  
       RETURN  
       END  
Legend:
Removed from v.76  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21