/[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

revision 118 by guez, Thu Dec 18 17:30:24 2014 UTC revision 254 by guez, Mon Feb 5 10:39:38 2018 UTC
# Line 1  Line 1 
1  SUBROUTINE swu(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, paki, &  module swu_m
     pcld, pclear, pdsig, pfact, prmu, psec, pud)  
2    
   USE dimens_m  
   USE dimphy  
   USE clesphys  
   USE suphec_m  
   USE raddim  
   USE radepsi  
   USE radopt  
3    IMPLICIT NONE    IMPLICIT NONE
4    
5    ! * ARGUMENTS:  contains
6    
7    DOUBLE PRECISION psct    SUBROUTINE swu(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, paki, &
8    ! IM ctes ds clesphys.h   DOUBLE PRECISION RCO2         pcld, pclear, pdsig, pfact, prmu, psec, pud)
9    DOUBLE PRECISION pcldsw(kdlon, kflev)  
10    DOUBLE PRECISION ppmb(kdlon, kflev+1)      USE clesphys, only: rco2
11    DOUBLE PRECISION ppsol(kdlon)      USE suphec_m, only: rg
12    DOUBLE PRECISION prmu0(kdlon)      USE raddim, only: kdlon, kflev
13    DOUBLE PRECISION pfrac(kdlon)      USE radepsi, only: zepscq, zepsec
14    DOUBLE PRECISION ptave(kdlon, kflev)      USE radopt, only: novlp
15    DOUBLE PRECISION pwv(kdlon, kflev)  
16        ! ARGUMENTS:
17    DOUBLE PRECISION paki(kdlon, 2)  
18    DOUBLE PRECISION pcld(kdlon, kflev)      DOUBLE PRECISION, intent(in):: psct
19    DOUBLE PRECISION pclear(kdlon)      DOUBLE PRECISION, intent(in):: pcldsw(kdlon, kflev)
20    DOUBLE PRECISION pdsig(kdlon, kflev)      DOUBLE PRECISION, intent(in):: ppmb(kdlon, kflev + 1)
21    DOUBLE PRECISION pfact(kdlon)      DOUBLE PRECISION, intent(in):: ppsol(kdlon)
22    DOUBLE PRECISION prmu(kdlon)      DOUBLE PRECISION, intent(in):: prmu0(kdlon)
23    DOUBLE PRECISION psec(kdlon)      DOUBLE PRECISION, intent(in):: pfrac(kdlon)
24    DOUBLE PRECISION pud(kdlon, 5, kflev+1)      DOUBLE PRECISION, intent(in):: ptave(kdlon, kflev)
25        DOUBLE PRECISION, intent(in):: pwv(kdlon, kflev)
26    ! * LOCAL VARIABLES:  
27        DOUBLE PRECISION paki(kdlon, 2)
28    INTEGER iind(2)      DOUBLE PRECISION pcld(kdlon, kflev)
29    DOUBLE PRECISION zc1j(kdlon, kflev+1)      DOUBLE PRECISION pclear(kdlon)
30    DOUBLE PRECISION zclear(kdlon)      DOUBLE PRECISION pdsig(kdlon, kflev)
31    DOUBLE PRECISION zcloud(kdlon)      DOUBLE PRECISION pfact(kdlon)
32    DOUBLE PRECISION zn175(kdlon)      DOUBLE PRECISION prmu(kdlon)
33    DOUBLE PRECISION zn190(kdlon)      DOUBLE PRECISION psec(kdlon)
34    DOUBLE PRECISION zo175(kdlon)      DOUBLE PRECISION pud(kdlon, 5, kflev + 1)
35    DOUBLE PRECISION zo190(kdlon)  
36    DOUBLE PRECISION zsign(kdlon)      ! Local:
37    DOUBLE PRECISION zr(kdlon, 2)  
38    DOUBLE PRECISION zsigo(kdlon)      INTEGER iind(2)
39    DOUBLE PRECISION zud(kdlon, 2)      DOUBLE PRECISION zc1j(kdlon, kflev + 1)
40    DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw      DOUBLE PRECISION zclear(kdlon)
41    INTEGER jl, jk, jkp1, jkl, jklp1, ja      DOUBLE PRECISION zcloud(kdlon)
42        DOUBLE PRECISION zn175(kdlon)
43    ! * Prescribed Data:      DOUBLE PRECISION zn190(kdlon)
44        DOUBLE PRECISION zo175(kdlon)
45    DOUBLE PRECISION zpdh2o, zpdumg      DOUBLE PRECISION zo190(kdlon)
46    SAVE zpdh2o, zpdumg      DOUBLE PRECISION zsign(kdlon)
47    DOUBLE PRECISION zprh2o, zprumg      DOUBLE PRECISION zr(kdlon, 2)
48    SAVE zprh2o, zprumg      DOUBLE PRECISION zsigo(kdlon)
49    DOUBLE PRECISION rtdh2o, rtdumg      DOUBLE PRECISION zud(kdlon, 2)
50    SAVE rtdh2o, rtdumg      DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
51    DOUBLE PRECISION rth2o, rtumg      INTEGER jl, jk, jkp1, jkl, ja
52    SAVE rth2o, rtumg  
53    DATA zpdh2o, zpdumg/0.8, 0.75/      ! Prescribed Data:
54    DATA zprh2o, zprumg/30000., 30000./  
55    DATA rtdh2o, rtdumg/0.40, 0.375/      DOUBLE PRECISION zpdh2o, zpdumg
56    DATA rth2o, rtumg/240., 240./      SAVE zpdh2o, zpdumg
57    ! ------------------------------------------------------------------      DOUBLE PRECISION zprh2o, zprumg
58        SAVE zprh2o, zprumg
59    ! *         1.     COMPUTES AMOUNTS OF ABSORBERS      DOUBLE PRECISION rtdh2o, rtdumg
60    ! -----------------------------      SAVE rtdh2o, rtdumg
61        DOUBLE PRECISION rth2o, rtumg
62        SAVE rth2o, rtumg
63    iind(1) = 1      DATA zpdh2o, zpdumg /0.8d0, 0.75d0/
64    iind(2) = 2      DATA zprh2o, zprumg /30000.d0, 30000.d0/
65        DATA rtdh2o, rtdumg /0.40d0, 0.375d0/
66        DATA rth2o, rtumg /240.d0, 240.d0/
67    ! *         1.1    INITIALIZES QUANTITIES  
68    ! ----------------------      !------------------------------------------------------------------
   
   
   DO jl = 1, kdlon  
     pud(jl, 1, kflev+1) = 0.  
     pud(jl, 2, kflev+1) = 0.  
     pud(jl, 3, kflev+1) = 0.  
     pud(jl, 4, kflev+1) = 0.  
     pud(jl, 5, kflev+1) = 0.  
     pfact(jl) = prmu0(jl)*pfrac(jl)*psct  
     prmu(jl) = sqrt(1224.*prmu0(jl)*prmu0(jl)+1.)/35.  
     psec(jl) = 1./prmu(jl)  
     zc1j(jl, kflev+1) = 0.  
   END DO  
   
   ! *          1.3    AMOUNTS OF ABSORBERS  
   ! --------------------  
   
   
   DO jl = 1, kdlon  
     zud(jl, 1) = 0.  
     zud(jl, 2) = 0.  
     zo175(jl) = ppsol(jl)**(zpdumg+1.)  
     zo190(jl) = ppsol(jl)**(zpdh2o+1.)  
     zsigo(jl) = ppsol(jl)  
     zclear(jl) = 1.  
     zcloud(jl) = 0.  
   END DO  
   
   DO jk = 1, kflev  
     jkp1 = jk + 1  
     jkl = kflev + 1 - jk  
     jklp1 = jkl + 1  
     DO jl = 1, kdlon  
       zrth = (rth2o/ptave(jl,jk))**rtdh2o  
       zrtu = (rtumg/ptave(jl,jk))**rtdumg  
       zwh2o = max(pwv(jl,jk), zepscq)  
       zsign(jl) = 100.*ppmb(jl, jkp1)  
       pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)  
       zn175(jl) = zsign(jl)**(zpdumg+1.)  
       zn190(jl) = zsign(jl)**(zpdh2o+1.)  
       zdsco2 = zo175(jl) - zn175(jl)  
       zdsh2o = zo190(jl) - zn190(jl)  
       pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &  
         zrth  
       pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &  
         zrtu  
       zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)  
       pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw  
       pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)  
       zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)  
       zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)  
       zsigo(jl) = zsign(jl)  
       zo175(jl) = zn175(jl)  
       zo190(jl) = zn190(jl)  
   
       IF (novlp==1) THEN  
         zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &  
           zcloud(jl),1.-zepsec))  
         zc1j(jl, jkl) = 1.0 - zclear(jl)  
         zcloud(jl) = pcldsw(jl, jkl)  
       ELSE IF (novlp==2) THEN  
         zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))  
         zc1j(jl, jkl) = zcloud(jl)  
       ELSE IF (novlp==3) THEN  
         zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))  
         zcloud(jl) = 1.0 - zclear(jl)  
         zc1j(jl, jkl) = zcloud(jl)  
       END IF  
     END DO  
   END DO  
   DO jl = 1, kdlon  
     pclear(jl) = 1. - zc1j(jl, 1)  
   END DO  
   DO jk = 1, kflev  
     DO jl = 1, kdlon  
       IF (pclear(jl)<1.) THEN  
         pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))  
       ELSE  
         pcld(jl, jk) = 0.  
       END IF  
     END DO  
   END DO  
69    
70        ! 1. COMPUTES AMOUNTS OF ABSORBERS
71    
72    ! *         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS      iind(1) = 1
73    ! -----------------------------------------------      iind(2) = 2
74    
75        ! 1.1 INITIALIZES QUANTITIES
76    
   DO ja = 1, 2  
77      DO jl = 1, kdlon      DO jl = 1, kdlon
78        zud(jl, ja) = zud(jl, ja)*psec(jl)         pud(jl, 1, kflev + 1) = 0.
79           pud(jl, 2, kflev + 1) = 0.
80           pud(jl, 3, kflev + 1) = 0.
81           pud(jl, 4, kflev + 1) = 0.
82           pud(jl, 5, kflev + 1) = 0.
83           pfact(jl) = prmu0(jl) * pfrac(jl) * psct
84           prmu(jl) = sqrt(1224. * prmu0(jl) * prmu0(jl) + 1.) / 35.
85           psec(jl) = 1. / prmu(jl)
86           zc1j(jl, kflev + 1) = 0.
87      END DO      END DO
   END DO  
88    
89    CALL swtt1(2, 2, iind, zud, zr)      ! 1.3 AMOUNTS OF ABSORBERS
90    
   DO ja = 1, 2  
91      DO jl = 1, kdlon      DO jl = 1, kdlon
92        paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)         zud(jl, 1) = 0.
93           zud(jl, 2) = 0.
94           zo175(jl) = ppsol(jl)**(zpdumg + 1.)
95           zo190(jl) = ppsol(jl)**(zpdh2o + 1.)
96           zsigo(jl) = ppsol(jl)
97           zclear(jl) = 1.
98           zcloud(jl) = 0.
99        END DO
100    
101        DO jk = 1, kflev
102           jkp1 = jk + 1
103           jkl = kflev + 1 - jk
104           DO jl = 1, kdlon
105              zrth = (rth2o / ptave(jl, jk))**rtdh2o
106              zrtu = (rtumg / ptave(jl, jk))**rtdumg
107              zwh2o = max(pwv(jl, jk), zepscq)
108              zsign(jl) = 100. * ppmb(jl, jkp1)
109              pdsig(jl, jk) = (zsigo(jl) - zsign(jl)) / ppsol(jl)
110              zn175(jl) = zsign(jl)**(zpdumg + 1.)
111              zn190(jl) = zsign(jl)**(zpdh2o + 1.)
112              zdsco2 = zo175(jl) - zn175(jl)
113              zdsh2o = zo190(jl) - zn190(jl)
114              pud(jl, 1, jk) = 1. / (10. * rg * (zpdh2o + 1.)) / zprh2o**zpdh2o &
115                   * zdsh2o * zwh2o * zrth
116              pud(jl, 2, jk) = 1. / (10. * rg * (zpdumg + 1.)) / zprumg**zpdumg &
117                   * zdsco2 * rco2 * zrtu
118              zfppw = 1.6078 * zwh2o / (1. + 0.608 * zwh2o)
119              pud(jl, 4, jk) = pud(jl, 1, jk) * zfppw
120              pud(jl, 5, jk) = pud(jl, 1, jk) * (1. - zfppw)
121              zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
122              zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
123              zsigo(jl) = zsign(jl)
124              zo175(jl) = zn175(jl)
125              zo190(jl) = zn190(jl)
126    
127              IF (novlp==1) THEN
128                 zclear(jl) = zclear(jl) &
129                      * (1. - max(pcldsw(jl, jkl), zcloud(jl))) &
130                      / (1. - min(zcloud(jl), 1. - zepsec))
131                 zc1j(jl, jkl) = 1.0 - zclear(jl)
132                 zcloud(jl) = pcldsw(jl, jkl)
133              ELSE IF (novlp==2) THEN
134                 zcloud(jl) = max(pcldsw(jl, jkl), zcloud(jl))
135                 zc1j(jl, jkl) = zcloud(jl)
136              ELSE IF (novlp==3) THEN
137                 zclear(jl) = zclear(jl) * (1. - pcldsw(jl, jkl))
138                 zcloud(jl) = 1.0 - zclear(jl)
139                 zc1j(jl, jkl) = zcloud(jl)
140              END IF
141           END DO
142        END DO
143        DO jl = 1, kdlon
144           pclear(jl) = 1. - zc1j(jl, 1)
145      END DO      END DO
146    END DO      DO jk = 1, kflev
147           DO jl = 1, kdlon
148              IF (pclear(jl)<1.) THEN
149                 pcld(jl, jk) = pcldsw(jl, jk) / (1. - pclear(jl))
150              ELSE
151                 pcld(jl, jk) = 0.
152              END IF
153           END DO
154        END DO
155    
156        ! 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
157    
158        DO ja = 1, 2
159           DO jl = 1, kdlon
160              zud(jl, ja) = zud(jl, ja) * psec(jl)
161           END DO
162        END DO
163    
164        CALL swtt1(2, 2, iind, zud, zr)
165    
166        DO ja = 1, 2
167           DO jl = 1, kdlon
168              paki(jl, ja) = - log(zr(jl, ja)) / zud(jl, ja)
169           END DO
170        END DO
171    
172      END SUBROUTINE swu
173    
174  END SUBROUTINE swu  end module swu_m
Legend:
Removed from v.118  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21