/[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 168 - (show annotations)
Wed Sep 9 10:41:47 2015 UTC (8 years, 9 months ago) by guez
File size: 5490 byte(s) 
In order to be able to choose finer resolutions, set large memory
model in compiler options and use dynamic libraries.

Variables rlatd, rlond, cuphy and cvphy of module comgeomphy were
never used. (In LMDZ, they are used only for Orchid.)

There is a bug in PGI Fortran 13.10 that does not accept the
combination of forall, pack and spread in regr_pr_av and
regr_pr_int. In order to circumvent this bug, created the function
gr_dyn_phy.

In program test_inifilr, use a single latitude coordinate for north
and south.
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 ztt1(kdlon, ntra)
59 DOUBLE PRECISION ztt2(kdlon, ntra)
60 DOUBLE PRECISION zuu(kdlon, nua)
61
62 INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
63 INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
64 DOUBLE PRECISION zwtr
65
66 ! * Data Block:
67
68 DOUBLE PRECISION wg1(2)
69 SAVE wg1
70 DATA (wg1(jk), jk=1, 2)/1.0, 1.0/
71 ! -----------------------------------------------------------------------
72
73 ! * 1. INITIALIZATION
74 ! --------------
75
76
77 ! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
78 ! ------------------------------
79
80
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 END DO
87
88 ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
89 ! ---------------------------------
90
91
92 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 END DO
99
100 DO ja = 1, nua
101 DO jl = 1, kdlon
102 zuu(jl, ja) = 0.
103 END DO
104 END DO
105
106 ! ------------------------------------------------------------------
107
108 ! * 2. VERTICAL INTEGRATION
109 ! --------------------
110
111
112
113 ! * 2.1 CONTRIBUTION FROM ADJACENT LAYERS
114 ! ---------------------------------
115
116
117 DO jk = 1, kflev
118
119 ! * 2.1.1 DOWNWARD LAYERS
120 ! ---------------
121
122
123 im12 = 2*(jk-1)
124 ind = (jk-1)*ng1p1 + 1
125 ixd = ind
126 inu = jk*ng1p1 + 1
127 ixu = ind
128
129 DO jl = 1, kdlon
130 zglayd(jl) = 0.
131 zglayu(jl) = 0.
132 END DO
133
134 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
143
144 CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
145
146 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
156 ! * 2.1.2 DOWNWARD LAYERS
157 ! ---------------
158
159
160 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
167
168 CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
169
170 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
180 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 END DO
190
191 DO jk = 1, kflev
192 jk2 = 2*jk
193 jk1 = jk2 - 1
194 DO jnu = 1, ninter
195 DO jl = 1, kdlon
196 pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
197 END DO
198 END DO
199 END DO
200
201 END SUBROUTINE lwvn
202
203 end module lwvn_m
  ViewVC Help
Powered by ViewVC 1.1.21