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

Annotation of /trunk/phylmd/Radlwsw/lwvn.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 166 - (hide annotations)
Wed Jul 29 14:32:55 2015 UTC (8 years, 10 months ago) by guez
Original Path: trunk/Sources/phylmd/Radlwsw/lwvn.f
File size: 5503 byte(s) 
Split ppm3d.f into files containing a single procedure.

Factorized computations of filtering matrices into a procedure
inifilr_hemisph. Had then to change the matrices from allocatable to
pointer and from customized lower bound to lower bound 1. The change
in lower bounds does not matter because the matrices are only used as
a whole as actual arguments.

Also, in infilr, instead of finding jfilt[ns][uv] from approximately
jjm /2, start at index j1 that corresponds to the equator. This is not
the same if there is a zoom in latitude.

Also, the test (rlamda(modfrst[ns][uv](j)) * cos(rlat[uv](j)) < 1) in
the loops on filtered latitudes is not useful now that we start from
j1: it is necessarily true. See notes.

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