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