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

Annotation of /trunk/Sources/phylmd/Radlwsw/lwvd.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/lwvd.f90
File size: 5564 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 SUBROUTINE lwvd(kuaer, ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, pdisu)
2     USE dimens_m
3     USE dimphy
4     USE raddim
5     USE raddimlw
6     IMPLICIT NONE
7    
8     ! -----------------------------------------------------------------------
9     ! PURPOSE.
10     ! --------
11     ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
12    
13     ! METHOD.
14     ! -------
15    
16     ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
17     ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
18    
19     ! REFERENCE.
20     ! ----------
21    
22     ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
23     ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
24    
25     ! AUTHOR.
26     ! -------
27     ! JEAN-JACQUES MORCRETTE *ECMWF*
28    
29     ! MODIFICATIONS.
30     ! --------------
31     ! ORIGINAL : 89-07-14
32     ! -----------------------------------------------------------------------
33     ! * ARGUMENTS:
34    
35     INTEGER kuaer, ktraer
36    
37     DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
38     DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
39     DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
40     DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
41    
42     DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
43     DOUBLE PRECISION pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
44     DOUBLE PRECISION pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
45    
46     ! * LOCAL VARIABLES:
47    
48     DOUBLE PRECISION zglayd(kdlon)
49     DOUBLE PRECISION zglayu(kdlon)
50     DOUBLE PRECISION ztt(kdlon, ntra)
51     DOUBLE PRECISION ztt1(kdlon, ntra)
52     DOUBLE PRECISION ztt2(kdlon, ntra)
53    
54     INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
55     INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
56     INTEGER ind1, ind2, ind3, ind4, itt
57     DOUBLE PRECISION zww, zdzxdg, zdzxmg
58    
59     ! * 1. INITIALIZATION
60     ! --------------
61    
62    
63     ! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
64     ! ------------------------------
65    
66    
67     DO jk = 1, kflev + 1
68     DO jl = 1, kdlon
69     pdisd(jl, jk) = 0.
70     pdisu(jl, jk) = 0.
71     END DO
72     END DO
73    
74     ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
75     ! ---------------------------------
76    
77    
78    
79     DO ja = 1, ntra
80     DO jl = 1, kdlon
81     ztt(jl, ja) = 1.0
82     ztt1(jl, ja) = 1.0
83     ztt2(jl, ja) = 1.0
84     END DO
85     END DO
86    
87     ! ------------------------------------------------------------------
88    
89     ! * 2. VERTICAL INTEGRATION
90     ! --------------------
91    
92    
93     ind1 = 0
94     ind3 = 0
95     ind4 = 1
96     ind2 = 1
97    
98    
99     ! * 2.2 CONTRIBUTION FROM DISTANT LAYERS
100     ! ---------------------------------
101    
102    
103    
104     ! * 2.2.1 DISTANT AND ABOVE LAYERS
105     ! ------------------------
106    
107    
108    
109    
110     ! * 2.2.2 FIRST UPPER LEVEL
111     ! -----------------
112    
113    
114     DO jk = 1, kflev - 1
115     ikp1 = jk + 1
116     ikn = (jk-1)*ng1p1 + 1
117     ikd1 = jk*ng1p1 + 1
118    
119     CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
120     ztt1)
121    
122    
123    
124     ! * 2.2.3 HIGHER UP
125     ! ---------
126    
127    
128     itt = 1
129     DO jkj = ikp1, kflev
130     IF (itt==1) THEN
131     itt = 2
132 guez 24 ELSE
133 guez 81 itt = 1
134     END IF
135     ikjp1 = jkj + 1
136     ikd2 = jkj*ng1p1 + 1
137    
138     IF (itt==1) THEN
139     CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
140     pabcu(1,1,ikd2), ztt1)
141 guez 24 ELSE
142 guez 81 CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
143     pabcu(1,1,ikd2), ztt2)
144     END IF
145    
146     DO ja = 1, ktraer
147     DO jl = 1, kdlon
148     ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
149     END DO
150     END DO
151    
152     DO jl = 1, kdlon
153     zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
154     pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
155     pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
156     pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
157     pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
158     pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
159     zglayd(jl) = zww
160     zdzxdg = zglayd(jl)
161     pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
162     pcntrb(jl, jk, ikjp1) = zdzxdg
163     END DO
164    
165    
166     END DO
167     END DO
168    
169    
170     ! * 2.2.4 DISTANT AND BELOW LAYERS
171     ! ------------------------
172    
173    
174    
175    
176     ! * 2.2.5 FIRST LOWER LEVEL
177     ! -----------------
178    
179    
180     DO jk = 3, kflev + 1
181     ikn = (jk-1)*ng1p1 + 1
182     ikm1 = jk - 1
183     ikj = jk - 2
184     iku1 = ikj*ng1p1 + 1
185    
186    
187     CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
188     pabcu(1,1,ikn), ztt1)
189    
190    
191    
192     ! * 2.2.6 DOWN BELOW
193     ! ----------
194    
195    
196     itt = 1
197     DO jlk = 1, ikj
198     IF (itt==1) THEN
199     itt = 2
200 guez 24 ELSE
201 guez 81 itt = 1
202     END IF
203     ijkl = ikm1 - jlk
204     iku2 = (ijkl-1)*ng1p1 + 1
205    
206    
207     IF (itt==1) THEN
208     CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
209     pabcu(1,1,ikn), ztt1)
210 guez 24 ELSE
211 guez 81 CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
212     pabcu(1,1,ikn), ztt2)
213     END IF
214    
215     DO ja = 1, ktraer
216     DO jl = 1, kdlon
217     ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
218     END DO
219     END DO
220    
221     DO jl = 1, kdlon
222     zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
223     pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
224     pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
225     pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
226     pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
227     pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
228     zglayu(jl) = zww
229     zdzxmg = zglayu(jl)
230     pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
231     pcntrb(jl, jk, ijkl) = zdzxmg
232     END DO
233    
234    
235     END DO
236     END DO
237    
238     RETURN
239     END SUBROUTINE lwvd
  ViewVC Help
Powered by ViewVC 1.1.21