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

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

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 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 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, jklp1, 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.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.76  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.21