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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 118 - (show annotations)
Thu Dec 18 17:30:24 2014 UTC (9 years, 4 months ago) by guez
File size: 4756 byte(s) 
In file grilles_gcm.nc, renamed variable phis to orog, deleted
variable presnivs.

Removed variable bug_ozone from module clesphys.

In procedure ozonecm, moved computation of sint and cost out of the
loops on horizontal position and vertical level. Inverted the order of
the two loops. We can then move all computations from slat to aprim
out of the loop on vertical levels. Created variable slat2, following
LMDZ. Moved the limitation of column-density of ozone in cell at 1e-12
from radlwsw to ozonecm, following LMDZ.

Removed unused arguments u, albsol, rh, cldfra, rneb, diafra, cldliq,
pmflxr, pmflxs, prfl, psfl of phytrac.

In procedure yamada4, for all the arrays, replaced the dimension klon
by ngrid. At the end of the procedure, for the computation of kmn,kn,
kq and q2, changed the upper limit of the loop index from klon to ngrid.

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