source: LMDZ5/trunk/libf/phylmd/rrtm/lwu.F90 @ 2027

Last change on this file since 2027 was 2027, checked in by Laurent Fairhead, 11 years ago

Problèmes sur les concentrations de certains gaz

  1. Baek

Problems on some gases concentrations

  1. Baek
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:keywords set to Author Date Id Revi
File size: 11.4 KB
RevLine 
[2027]1!
2! $Id: lwu.F90 2027 2014-04-29 13:38:53Z fairhead $
3!
[1989]4SUBROUTINE 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
66USE PARKIND1  ,ONLY : JPIM     ,JPRB
67USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
68
69USE YOMCST   , ONLY : RG
70USE YOESW    , ONLY : RAER
71USE YOELW    , ONLY : NSIL     ,NUA      ,NG1      ,NG1P1    ,&
72 & ALWT     ,BLWT     ,RO3T     ,RT1      ,TREF     ,&
73 & RVGCO2   ,RVGH2O   ,RVGO3 
[2027]74!USE YOERDI   , ONLY : RCH4     ,RN2O     ,RCFC11   ,RCFC12
[1989]75USE YOERDU   , ONLY : R10E     ,REPSCO   ,REPSCQ
76
[2027]77
[1989]78IMPLICIT NONE
79
80INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
81INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
82INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
83INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
84REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KLON,6,KLEV)
85REAL(KIND=JPRB)   ,INTENT(IN)    :: PCCO2
86REAL(KIND=JPRB)   ,INTENT(IN)    :: PDP(KLON,KLEV)
87REAL(KIND=JPRB)   ,INTENT(IN)    :: PPMB(KLON,KLEV+1)
88REAL(KIND=JPRB)   ,INTENT(IN)    :: PQOF(KLON,KLEV)
89REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(KLON,KLEV)
90REAL(KIND=JPRB)   ,INTENT(IN)    :: PVIEW(KLON)
91REAL(KIND=JPRB)   ,INTENT(IN)    :: PWV(KLON,KLEV)
92REAL(KIND=JPRB)   ,INTENT(OUT)   :: PABCU(KLON,NUA,3*KLEV+1)
[2027]93
94#include "clesphys.h"
[1989]95!-----------------------------------------------------------------------
96
97!*       0.1   ARGUMENTS
98!              ---------
99
100!-----------------------------------------------------------------------
101
102!              ------------
103REAL(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) 
106REAL(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) 
110REAL(KIND=JPRB) :: ZSSIG(KLON,3*KLEV+1)    , ZTAVI(KLON)&
111 & ,  ZUAER(KLON,NSIL)        , ZXOZ(KLON) , ZXWV(KLON) 
112
113INTEGER(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
117REAL(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 
122REAL(KIND=JPRB) :: ZHOOK_HANDLE
123
[2027]124
[1989]125!-----------------------------------------------------------------------
126
127!*         1.    INITIALIZATION
128!                --------------
129
130!-----------------------------------------------------------------------
131
132!*         2.    PRESSURE OVER GAUSS SUB-LEVELS
133!                ------------------------------
134
135IF (LHOOK) CALL DR_HOOK('LWU',0,ZHOOK_HANDLE)
136DO JL = KIDIA,KFDIA
137  ZSSIG(JL, 1 ) = PPMB(JL,1) * 100._JPRB
138ENDDO
139
140DO 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
154ENDDO
155
156!-----------------------------------------------------------------------
157
158!*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
159!                --------------------------------------------------
160
161DO 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
167ENDDO
168
169DO 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
197ENDDO
198
199!-----------------------------------------------------------------------
200
201!*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
202!                --------------------------------------------------
203
204DO JA = 1, NUA
205  DO JL = KIDIA,KFDIA
206    PABCU(JL,JA,3*KLEV+1) = 0.0_JPRB
207  ENDDO
208ENDDO
209
210DO 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
337ENDDO
338!      print *,'END OF LWU'
339
[2027]340
341
[1989]342!-----------------------------------------------------------------------
343
344IF (LHOOK) CALL DR_HOOK('LWU',1,ZHOOK_HANDLE)
345END SUBROUTINE LWU
Note: See TracBrowser for help on using the repository browser.