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