/[lmdze]/trunk/phylmd/Radlwsw/swu.f
ViewVC logotype

Annotation of /trunk/phylmd/Radlwsw/swu.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 81 - (hide annotations)
Wed Mar 5 14:38:41 2014 UTC (10 years, 3 months ago) by guez
Original Path: trunk/phylmd/Radlwsw/swu.f90
File size: 4923 byte(s) 
 Converted to free source form files which were still in fixed source
form. The conversion was done using the polish mode of the NAG Fortran
Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

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