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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 178 - (show annotations)
Fri Mar 11 18:47:26 2016 UTC (8 years, 2 months ago) by guez
File size: 4745 byte(s) 
Moved variables date0, deltat, datasz_max, ncvar_ids, point, buff_pos,
buffer, regular from module histcom_var to modules where they are
defined.

Removed procedure ioipslmpp, useless for a sequential program.

Added argument datasz_max to histwrite_real (to avoid circular
dependency with histwrite).

Removed useless variables and computations everywhere.

Changed real litteral constants from default kind to double precision
in lwb, lwu, lwvn, sw1s, swtt, swtt1, swu.

Removed unused arguments: paer of sw, sw1s, sw2s, swclr; pcldsw of
sw1s, sw2s; pdsig, prayl of swr; co2_ppm of clmain, clqh; tsol of
transp_lay; nsrf of screenp; kcrit and kknu of gwstress; pstd of
orosetup.

Added output of relative humidity.
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, 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.8d0, 0.75d0/
62 DATA zprh2o, zprumg/30000.d0, 30000.d0/
63 DATA rtdh2o, rtdumg/0.40d0, 0.375d0/
64 DATA rth2o, rtumg/240.d0, 240.d0/
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 DO jl = 1, kdlon
109 zrth = (rth2o/ptave(jl,jk))**rtdh2o
110 zrtu = (rtumg/ptave(jl,jk))**rtdumg
111 zwh2o = max(pwv(jl,jk), zepscq)
112 zsign(jl) = 100.*ppmb(jl, jkp1)
113 pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
114 zn175(jl) = zsign(jl)**(zpdumg+1.)
115 zn190(jl) = zsign(jl)**(zpdh2o+1.)
116 zdsco2 = zo175(jl) - zn175(jl)
117 zdsh2o = zo190(jl) - zn190(jl)
118 pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &
119 zrth
120 pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &
121 zrtu
122 zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)
123 pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
124 pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
125 zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
126 zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
127 zsigo(jl) = zsign(jl)
128 zo175(jl) = zn175(jl)
129 zo190(jl) = zn190(jl)
130
131 IF (novlp==1) THEN
132 zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
133 zcloud(jl),1.-zepsec))
134 zc1j(jl, jkl) = 1.0 - zclear(jl)
135 zcloud(jl) = pcldsw(jl, jkl)
136 ELSE IF (novlp==2) THEN
137 zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
138 zc1j(jl, jkl) = zcloud(jl)
139 ELSE IF (novlp==3) THEN
140 zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
141 zcloud(jl) = 1.0 - zclear(jl)
142 zc1j(jl, jkl) = zcloud(jl)
143 END IF
144 END DO
145 END DO
146 DO jl = 1, kdlon
147 pclear(jl) = 1. - zc1j(jl, 1)
148 END DO
149 DO jk = 1, kflev
150 DO jl = 1, kdlon
151 IF (pclear(jl)<1.) THEN
152 pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
153 ELSE
154 pcld(jl, jk) = 0.
155 END IF
156 END DO
157 END DO
158
159
160 ! * 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
161 ! -----------------------------------------------
162
163
164 DO ja = 1, 2
165 DO jl = 1, kdlon
166 zud(jl, ja) = zud(jl, ja)*psec(jl)
167 END DO
168 END DO
169
170 CALL swtt1(2, 2, iind, zud, zr)
171
172 DO ja = 1, 2
173 DO jl = 1, kdlon
174 paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
175 END DO
176 END DO
177
178 END SUBROUTINE swu
  ViewVC Help
Powered by ViewVC 1.1.21