LMDZ
lwu.F90
Go to the documentation of this file.
1 !
2 ! $Id: lwu.F90 2027 2014-04-29 13:38:53Z fairhead $
3 !
4 SUBROUTINE lwu &
5  & ( kidia, kfdia, klon, klev,&
6  & paer , pcco2, pdp , ppmb, pqof , ptave, pview, pwv,&
7  & pabcu &
8  & )
9 
10 !**** *LWU* - LONGWAVE EFFECTIVE ABSORBER AMOUNTS
11 
12 ! PURPOSE.
13 ! --------
14 ! COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
15 ! TEMPERATURE EFFECTS
16 
17 !** INTERFACE.
18 ! ----------
19 
20 ! EXPLICIT ARGUMENTS :
21 ! --------------------
22 ! ==== INPUTS ===
23 ! PAER : (KLON,6,KLEV) ; OPTICAL THICKNESS OF THE AEROSOLS
24 ! PCCO2 : ; CONCENTRATION IN CO2 (PA/PA)
25 ! PDP : (KLON,KLEV) ; LAYER PRESSURE THICKNESS (PA)
26 ! PPMB : (KLON,KLEV+1) ; HALF LEVEL PRESSURE
27 ! PQOF : (KLON,KLEV) ; CONCENTRATION IN OZONE (PA/PA)
28 ! PTAVE : (KLON,KLEV) ; TEMPERATURE
29 ! PWV : (KLON,KLEV) ; SPECIFIC HUMIDITY PA/PA
30 ! PVIEW : (KLON) ; COSECANT OF VIEWING ANGLE
31 ! ==== OUTPUTS ===
32 ! PABCU :(KLON,NUA,3*KLEV+1); EFFECTIVE ABSORBER AMOUNTS
33 
34 ! IMPLICIT ARGUMENTS : NONE
35 ! --------------------
36 
37 ! METHOD.
38 ! -------
39 
40 ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
41 ! ABSORBERS.
42 
43 ! EXTERNALS.
44 ! ----------
45 
46 ! NONE
47 
48 ! REFERENCE.
49 ! ----------
50 
51 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
52 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
53 
54 ! AUTHOR.
55 ! -------
56 ! JEAN-JACQUES MORCRETTE *ECMWF*
57 
58 ! MODIFICATIONS.
59 ! --------------
60 ! ORIGINAL : 89-07-14
61 ! JJ Morcrette 97-04-18 Revised Continuum + Clean-up
62 ! M.Hamrud 01-Oct-2003 CY28 Cleaning
63 
64 !-----------------------------------------------------------------------
65 
66 USE parkind1 ,ONLY : jpim ,jprb
67 USE yomhook ,ONLY : lhook, dr_hook
68 
69 USE yomcst , ONLY : rg
70 USE yoesw , ONLY : raer
71 USE yoelw , ONLY : nsil ,nua ,ng1 ,ng1p1 ,&
72  & alwt ,blwt ,ro3t ,rt1 ,tref ,&
73  & rvgco2 ,rvgh2o ,rvgo3
74 !USE YOERDI , ONLY : RCH4 ,RN2O ,RCFC11 ,RCFC12
75 USE yoerdu , ONLY : r10e ,repsco ,repscq
76 
77 
78 IMPLICIT NONE
79 
80 INTEGER(KIND=JPIM),INTENT(IN) :: KLON
81 INTEGER(KIND=JPIM),INTENT(IN) :: KLEV
82 INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA
83 INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA
84 REAL(KIND=JPRB) ,INTENT(IN) :: PAER(klon,6,klev)
85 REAL(KIND=JPRB) ,INTENT(IN) :: PCCO2
86 REAL(KIND=JPRB) ,INTENT(IN) :: PDP(klon,klev)
87 REAL(KIND=JPRB) ,INTENT(IN) :: PPMB(klon,klev+1)
88 REAL(KIND=JPRB) ,INTENT(IN) :: PQOF(klon,klev)
89 REAL(KIND=JPRB) ,INTENT(IN) :: PTAVE(klon,klev)
90 REAL(KIND=JPRB) ,INTENT(IN) :: PVIEW(klon)
91 REAL(KIND=JPRB) ,INTENT(IN) :: PWV(klon,klev)
92 REAL(KIND=JPRB) ,INTENT(OUT) :: PABCU(klon,nua,3*klev+1)
93 
94 #include "clesphys.h"
95 !-----------------------------------------------------------------------
96 
97 !* 0.1 ARGUMENTS
98 ! ---------
99 
100 !-----------------------------------------------------------------------
101 
102 ! ------------
103 REAL(KIND=JPRB) :: ZABLY(klon,7,3*klev+1) , ZDPM(klon,3*klev)&
104  & , ZDUC(KLON, 3*KLEV+1) , ZFACT(KLON)&
105  & , ZUPM(KLON,3*KLEV)
106 REAL(KIND=JPRB) :: ZPHIO(klon),ZPSC2(klon) , ZPSC3(klon), ZPSH1(klon)&
107  & , ZPSH2(KLON),ZPSH3(KLON) , ZPSH4(KLON), ZPSH5(KLON)&
108  & , ZPSH6(KLON),ZPSIO(KLON) , ZTCON(KLON)&
109  & , ZPHM6(KLON),ZPSM6(KLON) , ZPHN6(KLON), ZPSN6(KLON)
110 REAL(KIND=JPRB) :: ZSSIG(klon,3*klev+1) , ZTAVI(klon)&
111  & , ZUAER(KLON,NSIL) , ZXOZ(KLON) , ZXWV(KLON)
112 
113 INTEGER(KIND=JPIM) :: IAE1, IAE2, IAE3, IC, ICP1, IG1, IJ, IJPN,&
114  & IKIP1, IKJ, IKJP, IKJPN, IKJR, IKL, JA, JAE, &
115  & JK, JKI, JKK, JL
116 
117 REAL(KIND=JPRB) :: ZALUP, ZCAC8, ZCAH1, ZCAH2, ZCAH3, ZCAH4,&
118  & ZCAH5, ZCAH6, ZCBC8, ZCBH1, ZCBH2, ZCBH3, &
119  & ZCBH4, ZCBH5, ZCBH6, ZDIFF, ZDPMG, ZDPMP0, &
120  & ZFPPW, ZTX, ZTX2, ZU6, ZUP, ZUPMCO2, ZUPMG, &
121  & ZUPMH2O, ZUPMO3, ZZABLY
122 REAL(KIND=JPRB) :: ZHOOK_HANDLE
123 
124 
125 !-----------------------------------------------------------------------
126 
127 !* 1. INITIALIZATION
128 ! --------------
129 
130 !-----------------------------------------------------------------------
131 
132 !* 2. PRESSURE OVER GAUSS SUB-LEVELS
133 ! ------------------------------
134 
135 IF (lhook) CALL dr_hook('LWU',0,zhook_handle)
136 DO jl = kidia,kfdia
137  zssig(jl, 1 ) = ppmb(jl,1) * 100._jprb
138 ENDDO
139 
140 DO jk = 1 , klev
141  ikj=(jk-1)*ng1p1+1
142  ikjr = ikj
143  ikjp = ikj + ng1p1
144  DO jl = kidia,kfdia
145  zssig(jl,ikjp)=ppmb(jl,jk+1)* 100._jprb
146  ENDDO
147  DO ig1=1,ng1
148  ikj=ikj+1
149  DO jl = kidia,kfdia
150  zssig(jl,ikj)= (zssig(jl,ikjr) + zssig(jl,ikjp)) * 0.5_jprb &
151  & + rt1(ig1) * (zssig(jl,ikjp) - zssig(jl,ikjr)) * 0.5_jprb
152  ENDDO
153  ENDDO
154 ENDDO
155 
156 !-----------------------------------------------------------------------
157 
158 !* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
159 ! --------------------------------------------------
160 
161 DO jki=1,3*klev
162  ikip1=jki+1
163  DO jl = kidia,kfdia
164  zupm(jl,jki)=(zssig(jl,jki)+zssig(jl,ikip1))*0.5_jprb
165  zdpm(jl,jki)=(zssig(jl,jki)-zssig(jl,ikip1))/(10._jprb*rg)
166  ENDDO
167 ENDDO
168 
169 DO jk = 1 , klev
170  ikl = klev+1 - jk
171  DO jl = kidia,kfdia
172  zxwv(jl) = max(pwv(jl,ikl) , repscq )
173  zxoz(jl) = max(pqof(jl,ikl) / pdp(jl,ikl) , repsco )
174  ENDDO
175  ikj=(jk-1)*ng1p1+1
176  ikjpn=ikj+ng1
177  DO jkk=ikj,ikjpn
178  DO jl = kidia,kfdia
179  zdpmg = zdpm(jl,jkk)
180  zdpmp0 = zdpmg / 101325._jprb
181  zupmg = zupm(jl,jkk) * zdpmp0
182  zupmco2 = ( zupm(jl,jkk) + rvgco2 ) * zdpmp0
183  zupmh2o = ( zupm(jl,jkk) + rvgh2o ) * zdpmp0
184  zupmo3 = ( zupm(jl,jkk) + rvgo3 ) * zdpmp0
185  zduc(jl,jkk) = zdpmg
186  zably(jl,6,jkk) = zxoz(jl) * zdpmg
187  zably(jl,7,jkk) = zxoz(jl) * zupmo3
188  zu6 = zxwv(jl) * zupmg
189  zfppw = 1.6078_jprb * zxwv(jl) / (1.0_jprb+0.608_jprb*zxwv(jl))
190  zably(jl,1,jkk) = zxwv(jl) * zupmh2o
191  zably(jl,5,jkk) = zu6 * zfppw
192  zably(jl,4,jkk) = zu6 * (1.0_jprb-zfppw)
193  zably(jl,3,jkk) = pcco2 * zupmco2
194  zably(jl,2,jkk) = pcco2 * zdpmg
195  ENDDO
196  ENDDO
197 ENDDO
198 
199 !-----------------------------------------------------------------------
200 
201 !* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
202 ! --------------------------------------------------
203 
204 DO ja = 1, nua
205  DO jl = kidia,kfdia
206  pabcu(jl,ja,3*klev+1) = 0.0_jprb
207  ENDDO
208 ENDDO
209 
210 DO jk = 1 , klev
211  ij=(jk-1)*ng1p1+1
212  ijpn=ij+ng1
213  ikl=klev+1-jk
214 
215 !* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
216 ! --------------------------------------------------
217 ! -- NB: 'PAER' AEROSOLS ARE ENTERED FROM TOP TO BOTTOM
218 
219  iae1=3*klev+1-ij
220  iae2=3*klev+1-(ij+1)
221  iae3=3*klev+1-ijpn
222 ! print *,'IAE1= ',IAE1
223 ! print *,'IAE2= ',IAE2
224 ! print *,'IAE3= ',IAE3
225 ! print *,'KIDIA= ',KIDIA
226 ! print *,'KFDIA= ',KFDIA
227 ! print *,'KLEV= ',KLEV
228  DO jae=1,6
229  DO jl = kidia,kfdia
230 ! print *,'JL= ',JL,'-JAE= ',JAE,'-JK= ',JK,'-NSIL= ',NSIL
231  zuaer(jl,jae) =&
232  & (raer(jae,1)*paer(jl,1,jk)+raer(jae,2)*paer(jl,2,jk)&
233  & +raer(jae,3)*paer(jl,3,jk)+raer(jae,4)*paer(jl,4,jk)&
234  & +raer(jae,5)*paer(jl,5,jk)+raer(jae,6)*paer(jl,6,jk))&
235  & /(zduc(jl,iae1)+zduc(jl,iae2)+zduc(jl,iae3))
236  ENDDO
237  ENDDO
238 
239 !* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
240 ! --------------------------------------------------
241 
242  DO jl = kidia,kfdia
243  ztavi(jl)=ptave(jl,ikl)
244  zfact(jl)=1.0_jprb-ztavi(jl)/296._jprb
245  ztcon(jl)=exp(6.08_jprb*(296._jprb/ztavi(jl)-1.0_jprb))
246 ! ZTCON(JL)=EXP(6.08*ZFACT(JL))
247  ztx=ztavi(jl)-tref
248  ztx2=ztx*ztx
249  zzably = zably(jl,1,iae1)+zably(jl,1,iae2)+zably(jl,1,iae3)
250  zup=min( max( 0.5_jprb*r10e*log( zzably ) + 5._jprb, 0.0_jprb), 6.0_jprb)
251  zcah1=alwt(1,1)+zup*(alwt(1,2)+zup*(alwt(1,3)))
252  zcbh1=blwt(1,1)+zup*(blwt(1,2)+zup*(blwt(1,3)))
253  zpsh1(jl)=exp( zcah1 * ztx + zcbh1 * ztx2 )
254  zcah2=alwt(2,1)+zup*(alwt(2,2)+zup*(alwt(2,3)))
255  zcbh2=blwt(2,1)+zup*(blwt(2,2)+zup*(blwt(2,3)))
256  zpsh2(jl)=exp( zcah2 * ztx + zcbh2 * ztx2 )
257  zcah3=alwt(3,1)+zup*(alwt(3,2)+zup*(alwt(3,3)))
258  zcbh3=blwt(3,1)+zup*(blwt(3,2)+zup*(blwt(3,3)))
259  zpsh3(jl)=exp( zcah3 * ztx + zcbh3 * ztx2 )
260  zcah4=alwt(4,1)+zup*(alwt(4,2)+zup*(alwt(4,3)))
261  zcbh4=blwt(4,1)+zup*(blwt(4,2)+zup*(blwt(4,3)))
262  zpsh4(jl)=exp( zcah4 * ztx + zcbh4 * ztx2 )
263  zcah5=alwt(5,1)+zup*(alwt(5,2)+zup*(alwt(5,3)))
264  zcbh5=blwt(5,1)+zup*(blwt(5,2)+zup*(blwt(5,3)))
265  zpsh5(jl)=exp( zcah5 * ztx + zcbh5 * ztx2 )
266  zcah6=alwt(6,1)+zup*(alwt(6,2)+zup*(alwt(6,3)))
267  zcbh6=blwt(6,1)+zup*(blwt(6,2)+zup*(blwt(6,3)))
268  zpsh6(jl)=exp( zcah6 * ztx + zcbh6 * ztx2 )
269  zphm6(jl)=exp(-5.81e-4_jprb * ztx - 1.13e-6_jprb * ztx2 )
270  zpsm6(jl)=exp(-5.57e-4_jprb * ztx - 3.30e-6_jprb * ztx2 )
271  zphn6(jl)=exp(-3.46e-5_jprb * ztx + 2.05e-7_jprb * ztx2 )
272  zpsn6(jl)=exp( 3.70e-3_jprb * ztx - 2.30e-6_jprb * ztx2 )
273  ENDDO
274 
275  DO jl = kidia,kfdia
276  ztavi(jl)=ptave(jl,ikl)
277  ztx=ztavi(jl)-tref
278  ztx2=ztx*ztx
279  zzably = zably(jl,3,iae1)+zably(jl,3,iae2)+zably(jl,3,iae3)
280  zalup = r10e * log( zzably )
281  zup = max( 0.0_jprb , 5.0_jprb + 0.5_jprb * zalup )
282  zpsc2(jl) = (ztavi(jl)/tref) ** zup
283  zcac8=alwt(8,1)+zup*(alwt(8,2)+zup*(alwt(8,3)))
284  zcbc8=blwt(8,1)+zup*(blwt(8,2)+zup*(blwt(8,3)))
285  zpsc3(jl)=exp( zcac8 * ztx + zcbc8 * ztx2 )
286  zphio(jl) = exp( ro3t(1) * ztx + ro3t(2) * ztx2)
287  zpsio(jl) = exp( 2.0_jprb* (ro3t(3)*ztx+ro3t(4)*ztx2))
288  ENDDO
289 
290  DO jkk=ij,ijpn
291  ic=3*klev+1-jkk
292  icp1=ic+1
293  DO jl = kidia,kfdia
294  zdiff = pview(jl)
295 !- H2O continuum
296  pabcu(jl,10,ic)=pabcu(jl,10,icp1)+ zably(jl,4,ic) *zdiff
297  pabcu(jl,11,ic)=pabcu(jl,11,icp1)+ zably(jl,5,ic)*ztcon(jl)*zdiff
298 !- O3
299  pabcu(jl,12,ic)=pabcu(jl,12,icp1)+ zably(jl,6,ic)*zphio(jl)*zdiff
300  pabcu(jl,13,ic)=pabcu(jl,13,icp1)+ zably(jl,7,ic)*zpsio(jl)*zdiff
301 !- CO2
302  pabcu(jl,7,ic)=pabcu(jl,7,icp1)+ zably(jl,3,ic)*zpsc2(jl)*zdiff
303  pabcu(jl,8,ic)=pabcu(jl,8,icp1)+ zably(jl,3,ic)*zpsc3(jl)*zdiff
304  pabcu(jl,9,ic)=pabcu(jl,9,icp1)+ zably(jl,3,ic)*zpsc3(jl)*zdiff
305 !- H2O
306  pabcu(jl,1,ic)=pabcu(jl,1,icp1)+ zably(jl,1,ic)*zpsh1(jl)
307  pabcu(jl,2,ic)=pabcu(jl,2,icp1)+ zably(jl,1,ic)*zpsh2(jl)
308  pabcu(jl,3,ic)=pabcu(jl,3,icp1)+ zably(jl,1,ic)*zpsh5(jl)*zdiff
309  pabcu(jl,4,ic)=pabcu(jl,4,icp1)+ zably(jl,1,ic)*zpsh3(jl)
310  pabcu(jl,5,ic)=pabcu(jl,5,icp1)+ zably(jl,1,ic)*zpsh4(jl)
311  pabcu(jl,6,ic)=pabcu(jl,6,icp1)+ zably(jl,1,ic)*zpsh6(jl)*zdiff
312 !- aerosols
313  pabcu(jl,14,ic)=pabcu(jl,14,icp1)+ zuaer(jl,1) *zduc(jl,ic)*zdiff
314  pabcu(jl,15,ic)=pabcu(jl,15,icp1)+ zuaer(jl,2) *zduc(jl,ic)*zdiff
315  pabcu(jl,16,ic)=pabcu(jl,16,icp1)+ zuaer(jl,3) *zduc(jl,ic)*zdiff
316  pabcu(jl,17,ic)=pabcu(jl,17,icp1)+ zuaer(jl,4) *zduc(jl,ic)*zdiff
317  pabcu(jl,18,ic)=pabcu(jl,18,icp1)+ zuaer(jl,5) *zduc(jl,ic)*zdiff
318 !- CH4
319  pabcu(jl,19,ic)=pabcu(jl,19,icp1)&
320  & + zably(jl,2,ic)*rch4/pcco2*zphm6(jl)*zdiff
321  pabcu(jl,20,ic)=pabcu(jl,20,icp1)&
322  & + zably(jl,3,ic)*rch4/pcco2*zpsm6(jl)*zdiff
323 !- N2O
324  pabcu(jl,21,ic)=pabcu(jl,21,icp1)&
325  & + zably(jl,2,ic)*rn2o/pcco2*zphn6(jl)*zdiff
326  pabcu(jl,22,ic)=pabcu(jl,22,icp1)&
327  & + zably(jl,3,ic)*rn2o/pcco2*zpsn6(jl)*zdiff
328 !- CFC11
329  pabcu(jl,23,ic)=pabcu(jl,23,icp1)&
330  & + zably(jl,2,ic)*rcfc11/pcco2 *zdiff
331 !- CFC12
332  pabcu(jl,24,ic)=pabcu(jl,24,icp1)&
333  & + zably(jl,2,ic)*rcfc12/pcco2 *zdiff
334  ENDDO
335  ENDDO
336 
337 ENDDO
338 ! print *,'END OF LWU'
339 
340 
341 
342 !-----------------------------------------------------------------------
343 
344 IF (lhook) CALL dr_hook('LWU',1,zhook_handle)
345 END SUBROUTINE lwu
lwu
subroutine lwu(KIDIA, KFDIA, KLON, KLEV, PAER, PCCO2, PDP, PPMB, PQOF, PTAVE, PVIEW, PWV, PABCU)
Definition: lwu.F90:9
pcco2
INTERFACE SUBROUTINE RRTM_ECRT_140GP pcco2
Definition: rrtm_ecrt_140gp.intfb.h:3
yoelw::tref
real(kind=jprb) tref
Definition: yoelw.F90:35
yoelw::blwt
real(kind=jprb), dimension(8, 3) blwt
Definition: yoelw.F90:23
yoelw::rvgco2
real(kind=jprb) rvgco2
Definition: yoelw.F90:40
yoesw
Definition: yoesw.F90:1
yoelw
Definition: yoelw.F90:1
yoelw::nsil
integer(kind=jpim) nsil
Definition: yoelw.F90:14
yoesw::raer
real(kind=jprb), dimension(6, 6) raer
Definition: yoesw.F90:118
dimphy::kidia
integer, save kidia
Definition: dimphy.F90:6
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
yoelw::rvgo3
real(kind=jprb) rvgo3
Definition: yoelw.F90:42
yoelw::nua
integer(kind=jpim) nua
Definition: yoelw.F90:19
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
yomcst::rg
real(kind=jprb) rg
Definition: yomcst.F90:29
dimphy::kfdia
integer, save kfdia
Definition: dimphy.F90:5
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:31
yoelw::ng1
integer(kind=jpim) ng1
Definition: yoelw.F90:20
yoelw::ro3t
real(kind=jprb), dimension(4) ro3t
Definition: yoelw.F90:31
yoerdu::r10e
real(kind=jprb) r10e
Definition: yoerdu.F90:18
yomhook::lhook
logical lhook
Definition: yomhook.F90:12
yoerdu::repscq
real(kind=jprb) repscq
Definition: yoerdu.F90:22
yoelw::alwt
real(kind=jprb), dimension(8, 3) alwt
Definition: yoelw.F90:22
yomhook::dr_hook
subroutine dr_hook(CDNAME, KSWITCH, PKEY)
Definition: yomhook.F90:17
yoelw::ng1p1
integer(kind=jpim) ng1p1
Definition: yoelw.F90:21
yoelw::rvgh2o
real(kind=jprb) rvgh2o
Definition: yoelw.F90:41
parkind1::jpim
integer, parameter jpim
Definition: parkind1.F90:13
yoelw::rt1
real(kind=jprb), dimension(2) rt1
Definition: yoelw.F90:33
paer
INTERFACE SUBROUTINE RRTM_ECRT_140GP && paer
Definition: rrtm_ecrt_140gp.intfb.h:3
yomcst
Definition: yomcst.F90:1
yoerdu
Definition: yoerdu.F90:1
yoerdu::repsco
real(kind=jprb) repsco
Definition: yoerdu.F90:21