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

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