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

Contents of /trunk/Sources/phylmd/Radlwsw/lwvn.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: 5354 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 module lwvn_m
2
3 IMPLICIT NONE
4
5 contains
6
7 SUBROUTINE lwvn(kuaer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, pdbdt)
8 USE dimens_m
9 USE dimphy
10 USE raddim
11 USE raddimlw
12 ! -----------------------------------------------------------------------
13 ! PURPOSE.
14 ! --------
15 ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
16 ! TO GIVE LONGWAVE FLUXES OR RADIANCES
17
18 ! METHOD.
19 ! -------
20
21 ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
22 ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
23
24 ! REFERENCE.
25 ! ----------
26
27 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
28 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
29
30 ! AUTHOR.
31 ! -------
32 ! JEAN-JACQUES MORCRETTE *ECMWF*
33
34 ! MODIFICATIONS.
35 ! --------------
36 ! ORIGINAL : 89-07-14
37 ! -----------------------------------------------------------------------
38
39 ! * ARGUMENTS:
40
41 INTEGER kuaer
42
43 DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
44 DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
45 DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
46 DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
47
48 DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
49 DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
50 DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
51 DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
52
53 ! * LOCAL ARRAYS:
54
55 DOUBLE PRECISION zglayd(kdlon)
56 DOUBLE PRECISION zglayu(kdlon)
57 DOUBLE PRECISION ztt(kdlon, ntra)
58 DOUBLE PRECISION zuu(kdlon, nua)
59
60 INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
61 INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
62 DOUBLE PRECISION zwtr
63
64 ! * Data Block:
65
66 DOUBLE PRECISION wg1(2)
67 SAVE wg1
68 DATA (wg1(jk), jk=1, 2)/1d0, 1d0/
69 ! -----------------------------------------------------------------------
70
71 ! * 1. INITIALIZATION
72 ! --------------
73
74
75 ! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
76 ! ------------------------------
77
78
79 DO jk = 1, kflev + 1
80 DO jl = 1, kdlon
81 padjd(jl, jk) = 0.
82 padju(jl, jk) = 0.
83 END DO
84 END DO
85
86 ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
87 ! ---------------------------------
88
89
90 DO ja = 1, ntra
91 DO jl = 1, kdlon
92 ztt(jl, ja) = 1.0
93 END DO
94 END DO
95
96 DO ja = 1, nua
97 DO jl = 1, kdlon
98 zuu(jl, ja) = 0.
99 END DO
100 END DO
101
102 ! ------------------------------------------------------------------
103
104 ! * 2. VERTICAL INTEGRATION
105 ! --------------------
106
107
108
109 ! * 2.1 CONTRIBUTION FROM ADJACENT LAYERS
110 ! ---------------------------------
111
112
113 DO jk = 1, kflev
114
115 ! * 2.1.1 DOWNWARD LAYERS
116 ! ---------------
117
118
119 im12 = 2*(jk-1)
120 ind = (jk-1)*ng1p1 + 1
121 ixd = ind
122 inu = jk*ng1p1 + 1
123 ixu = ind
124
125 DO jl = 1, kdlon
126 zglayd(jl) = 0.
127 zglayu(jl) = 0.
128 END DO
129
130 DO jg = 1, ng1
131 ibs = im12 + jg
132 idd = ixd + jg
133 DO ja = 1, kuaer
134 DO jl = 1, kdlon
135 zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
136 END DO
137 END DO
138
139
140 CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
141
142 DO jl = 1, kdlon
143 zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
144 pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
145 pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
146 pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
147 pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
148 pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
149 zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
150 END DO
151
152 ! * 2.1.2 DOWNWARD LAYERS
153 ! ---------------
154
155
156 imu = ixu + jg
157 DO ja = 1, kuaer
158 DO jl = 1, kdlon
159 zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
160 END DO
161 END DO
162
163
164 CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
165
166 DO jl = 1, kdlon
167 zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
168 pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
169 pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
170 pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
171 pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
172 pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
173 zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
174 END DO
175
176 END DO
177
178 DO jl = 1, kdlon
179 padjd(jl, jk) = zglayd(jl)
180 pcntrb(jl, jk, jk+1) = zglayd(jl)
181 padju(jl, jk+1) = zglayu(jl)
182 pcntrb(jl, jk+1, jk) = zglayu(jl)
183 pcntrb(jl, jk, jk) = 0.0
184 END DO
185 END DO
186
187 DO jk = 1, kflev
188 jk2 = 2*jk
189 jk1 = jk2 - 1
190 DO jnu = 1, ninter
191 DO jl = 1, kdlon
192 pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
193 END DO
194 END DO
195 END DO
196
197 END SUBROUTINE lwvn
198
199 end module lwvn_m
  ViewVC Help
Powered by ViewVC 1.1.21