/[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/libf/phylmd/Radlwsw/swu.f revision 71 by guez, Mon Jul 8 18:12:18 2013 UTC trunk/phylmd/Radlwsw/swu.f revision 254 by guez, Mon Feb 5 10:39:38 2018 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 SUPHEC_M  
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        DOUBLE PRECISION PSCT  
18  cIM ctes ds clesphys.h   DOUBLE PRECISION RCO2      DOUBLE PRECISION, intent(in):: psct
19        DOUBLE PRECISION PCLDSW(KDLON,KFLEV)      DOUBLE PRECISION, intent(in):: pcldsw(kdlon, kflev)
20        DOUBLE PRECISION PPMB(KDLON,KFLEV+1)      DOUBLE PRECISION, intent(in):: ppmb(kdlon, kflev + 1)
21        DOUBLE PRECISION PPSOL(KDLON)      DOUBLE PRECISION, intent(in):: ppsol(kdlon)
22        DOUBLE PRECISION PRMU0(KDLON)      DOUBLE PRECISION, intent(in):: prmu0(kdlon)
23        DOUBLE PRECISION PFRAC(KDLON)      DOUBLE PRECISION, intent(in):: pfrac(kdlon)
24        DOUBLE PRECISION PTAVE(KDLON,KFLEV)      DOUBLE PRECISION, intent(in):: ptave(kdlon, kflev)
25        DOUBLE PRECISION PWV(KDLON,KFLEV)      DOUBLE PRECISION, intent(in):: 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:
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, 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.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.71  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21