/[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/libf/phylmd/Radlwsw/swu.f revision 38 by guez, Thu Jan 6 17:52:19 2011 UTC trunk/phylmd/Radlwsw/swu.f revision 82 by guez, Wed Mar 5 14:57:53 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        REAL*8 PSCT    DOUBLE PRECISION psct
18  cIM ctes ds clesphys.h   REAL*8 RCO2    ! IM ctes ds clesphys.h   DOUBLE PRECISION RCO2
19        REAL*8 PCLDSW(KDLON,KFLEV)    DOUBLE PRECISION pcldsw(kdlon, kflev)
20        REAL*8 PPMB(KDLON,KFLEV+1)    DOUBLE PRECISION ppmb(kdlon, kflev+1)
21        REAL*8 PPSOL(KDLON)    DOUBLE PRECISION ppsol(kdlon)
22        REAL*8 PRMU0(KDLON)    DOUBLE PRECISION prmu0(kdlon)
23        REAL*8 PFRAC(KDLON)    DOUBLE PRECISION pfrac(kdlon)
24        REAL*8 PTAVE(KDLON,KFLEV)    DOUBLE PRECISION ptave(kdlon, kflev)
25        REAL*8 PWV(KDLON,KFLEV)    DOUBLE PRECISION pwv(kdlon, kflev)
26  C  
27        REAL*8 PAKI(KDLON,2)    DOUBLE PRECISION paki(kdlon, 2)
28        REAL*8 PCLD(KDLON,KFLEV)    DOUBLE PRECISION pcld(kdlon, kflev)
29        REAL*8 PCLEAR(KDLON)    DOUBLE PRECISION pclear(kdlon)
30        REAL*8 PDSIG(KDLON,KFLEV)    DOUBLE PRECISION pdsig(kdlon, kflev)
31        REAL*8 PFACT(KDLON)    DOUBLE PRECISION pfact(kdlon)
32        REAL*8 PRMU(KDLON)    DOUBLE PRECISION prmu(kdlon)
33        REAL*8 PSEC(KDLON)    DOUBLE PRECISION psec(kdlon)
34        REAL*8 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        REAL*8 ZC1J(KDLON,KFLEV+1)    DOUBLE PRECISION zc1j(kdlon, kflev+1)
40        REAL*8 ZCLEAR(KDLON)    DOUBLE PRECISION zclear(kdlon)
41        REAL*8 ZCLOUD(KDLON)    DOUBLE PRECISION zcloud(kdlon)
42        REAL*8 ZN175(KDLON)    DOUBLE PRECISION zn175(kdlon)
43        REAL*8 ZN190(KDLON)    DOUBLE PRECISION zn190(kdlon)
44        REAL*8 ZO175(KDLON)    DOUBLE PRECISION zo175(kdlon)
45        REAL*8 ZO190(KDLON)    DOUBLE PRECISION zo190(kdlon)
46        REAL*8 ZSIGN(KDLON)    DOUBLE PRECISION zsign(kdlon)
47        REAL*8 ZR(KDLON,2)    DOUBLE PRECISION zr(kdlon, 2)
48        REAL*8 ZSIGO(KDLON)    DOUBLE PRECISION zsigo(kdlon)
49        REAL*8 ZUD(KDLON,2)    DOUBLE PRECISION zud(kdlon, 2)
50        REAL*8 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        REAL*8 ZPDH2O,ZPDUMG    DOUBLE PRECISION zpdh2o, zpdumg
56        SAVE ZPDH2O,ZPDUMG    SAVE zpdh2o, zpdumg
57        REAL*8 ZPRH2O,ZPRUMG    DOUBLE PRECISION zprh2o, zprumg
58        SAVE ZPRH2O,ZPRUMG    SAVE zprh2o, zprumg
59        REAL*8 RTDH2O,RTDUMG    DOUBLE PRECISION rtdh2o, rtdumg
60        SAVE RTDH2O,RTDUMG    SAVE rtdh2o, rtdumg
61        REAL*8 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.38  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.21