source: LMDZ6/branches/LMDZ-QUEST/libf/phylmd/rrtm/rrtm_rrtm_140gp.F90 @ 5429

Last change on this file since 5429 was 2146, checked in by idelkadi, 10 years ago

Les modifications introduites ont pour but :
1/ d'autoriser le couplage entre INCA-aerosol et les parametrisations de
la nouvelle physique (NP) de LMDZ, en particulier les thermiques et le
transport convectif,
2/ generaliser les routines de calcul de proprietes optiques des
aerosols pour RRTM au cas ou les aerosols sont interactifs
3/ d'inclure les effets LW des aerosols stratospheriques pour RRTM
  • 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
File size: 11.0 KB
Line 
1!***************************************************************************
2!                                                                          *
3!                RRTM :  RAPID RADIATIVE TRANSFER MODEL                    *
4!                                                                          *
5!             ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                 *
6!                        840 MEMORIAL DRIVE                                *
7!                        CAMBRIDGE, MA 02139                               *
8!                                                                          *
9!                           ELI J. MLAWER                                  *
10!                         STEVEN J. TAUBMAN~                               *
11!                         SHEPARD A. CLOUGH                                *
12!                                                                          *
13!                        ~currently at GFDL                                *
14!                                                                          *
15!                       email:  mlawer@aer.com                             *
16!                                                                          *
17!        The authors wish to acknowledge the contributions of the          *
18!        following people:  Patrick D. Brown, Michael J. Iacono,           *
19!        Ronald E. Farren, Luke Chen, Robert Bergstrom.                    *
20!                                                                          *
21!***************************************************************************
22!     Reformatted for F90 by JJMorcrette, ECMWF, 980714                    *
23!                                                                          *
24!***************************************************************************
25! *** mji ***
26! *** This version of RRTM has been altered to interface with either
27!     the ECMWF numerical weather prediction model or the ECMWF column
28!     radiation model (ECRT) package.
29
30!     Revised, April, 1997;  Michael J. Iacono, AER, Inc.
31!          - initial implementation of RRTM in ECRT code
32!     Revised, June, 1999;  Michael J. Iacono and Eli J. Mlawer, AER, Inc.
33!          - to implement generalized maximum/random cloud overlap
34
35SUBROUTINE RRTM_RRTM_140GP &
36 & ( KIDIA , KFDIA , KLON , KLEV,&
37 & PAER  , PAPH  , PAP,&
38 & PTS   , PTH   , PT,&
39 & P_ZEMIS , P_ZEMIW,&
40 & PQ    , PCCO2 , POZN,&
41 & PCLDF , PTAUCLD,&
42 & PTAU_LW,&
43 & PEMIT , PFLUX , PFLUC, PTCLEAR &
44 & ) 
45
46! *** This program is the driver for RRTM, the AER rapid model. 
47!     For each atmosphere the user wishes to analyze, this routine
48!     a) calls ECRTATM to read in the atmospheric profile
49!     b) calls SETCOEF to calculate various quantities needed for
50!        the radiative transfer algorithm
51!     c) calls RTRN to do the radiative transfer calculation for
52!        clear or cloudy sky
53!     d) writes out the upward, downward, and net flux for each
54!        level and the heating rate for each layer
55
56USE PARKIND1  ,ONLY : JPIM     ,JPRB
57USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
58USE YOERAD    ,ONLY : NLW
59USE PARRRTM  , ONLY : JPBAND   ,JPXSEC   ,JPGPT    ,JPLAY    ,&
60 & JPINPX 
61!------------------------------Arguments--------------------------------
62
63! Input arguments
64
65IMPLICIT NONE
66INTEGER(KIND=JPIM),INTENT(IN)    :: KLON! Number of atmospheres (longitudes)
67INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV! Number of atmospheric layers
68INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA ! First atmosphere index
69INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA ! Last atmosphere index
70REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KLON,6,KLEV) ! Aerosol optical thickness
71REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPH(KLON,KLEV+1) ! Interface pressures (Pa)
72REAL(KIND=JPRB)   ,INTENT(IN)    :: PAP(KLON,KLEV) ! Layer pressures (Pa)
73REAL(KIND=JPRB)   ,INTENT(IN)    :: PTS(KLON) ! Surface temperature (I_K)
74REAL(KIND=JPRB)   ,INTENT(IN)    :: PTH(KLON,KLEV+1) ! Interface temperatures (I_K)
75REAL(KIND=JPRB)   ,INTENT(IN)    :: PT(KLON,KLEV) ! Layer temperature (I_K)
76REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIS(KLON) ! Non-window surface emissivity
77REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIW(KLON) ! Window surface emissivity
78REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ(KLON,KLEV) ! H2O specific humidity (mmr)
79REAL(KIND=JPRB)   ,INTENT(IN)    :: PCCO2 ! CO2 mass mixing ratio
80REAL(KIND=JPRB)   ,INTENT(IN)    :: POZN(KLON,KLEV) ! O3 mass mixing ratio
81REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDF(KLON,KLEV) ! Cloud fraction
82REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUCLD(KLON,KLEV,JPBAND) ! Cloud optical depth
83!--C.Kleinschmitt
84REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAU_LW(KLON,KLEV,NLW) ! LW Optical depth of aerosols
85!--end
86REAL(KIND=JPRB)   ,INTENT(OUT)   :: PEMIT(KLON) ! Surface LW emissivity
87REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUX(KLON,2,KLEV+1) ! LW total sky flux (1=up, 2=down)
88REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUC(KLON,2,KLEV+1) ! LW clear sky flux (1=up, 2=down)
89REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTCLEAR(KLON) ! clear-sky fraction of column
90INTEGER(KIND=JPIM) :: ICLDLYR(JPLAY)        ! Cloud indicator
91REAL(KIND=JPRB) :: Z_CLDFRAC(JPLAY)           ! Cloud fraction
92REAL(KIND=JPRB) :: Z_TAUCLD(JPLAY,JPBAND)     ! Spectral optical thickness
93
94REAL(KIND=JPRB) :: Z_ABSS1 (JPGPT*JPLAY)
95REAL(KIND=JPRB) :: Z_ATR1  (JPGPT,JPLAY)
96EQUIVALENCE (Z_ABSS1(1),Z_ATR1(1,1))
97
98REAL(KIND=JPRB) :: Z_OD    (JPGPT,JPLAY)
99
100REAL(KIND=JPRB) :: Z_TAUSF1(JPGPT*JPLAY)
101REAL(KIND=JPRB) :: Z_TF1   (JPGPT,JPLAY)
102EQUIVALENCE (Z_TAUSF1(1),Z_TF1(1,1))
103
104REAL(KIND=JPRB) :: Z_COLDRY(JPLAY)
105REAL(KIND=JPRB) :: Z_WKL(JPINPX,JPLAY)
106
107REAL(KIND=JPRB) :: Z_WX(JPXSEC,JPLAY)         ! Amount of trace gases
108
109REAL(KIND=JPRB) :: Z_CLFNET  (0:JPLAY)
110REAL(KIND=JPRB) :: Z_CLHTR   (0:JPLAY)
111REAL(KIND=JPRB) :: Z_FNET    (0:JPLAY)
112REAL(KIND=JPRB) :: Z_HTR     (0:JPLAY)
113REAL(KIND=JPRB) :: Z_TOTDFLUC(0:JPLAY)
114REAL(KIND=JPRB) :: Z_TOTDFLUX(0:JPLAY)
115REAL(KIND=JPRB) :: Z_TOTUFLUC(0:JPLAY)
116REAL(KIND=JPRB) :: Z_TOTUFLUX(0:JPLAY)
117
118INTEGER(KIND=JPIM) :: i, icld, iplon, I_K
119INTEGER(KIND=JPIM) :: ISTART
120INTEGER(KIND=JPIM) :: IEND
121
122REAL(KIND=JPRB) :: Z_FLUXFAC, Z_HEATFAC, Z_PI, ZEPSEC, ZTCLEAR
123
124!- from AER
125REAL(KIND=JPRB) :: Z_TAUAERL(JPLAY,JPBAND)
126
127!- from INTFAC     
128REAL(KIND=JPRB) :: Z_FAC00(JPLAY)
129REAL(KIND=JPRB) :: Z_FAC01(JPLAY)
130REAL(KIND=JPRB) :: Z_FAC10(JPLAY)
131REAL(KIND=JPRB) :: Z_FAC11(JPLAY)
132REAL(KIND=JPRB) :: Z_FORFAC(JPLAY)
133
134!- from INTIND
135INTEGER(KIND=JPIM) :: JP(JPLAY)
136INTEGER(KIND=JPIM) :: JT(JPLAY)
137INTEGER(KIND=JPIM) :: JT1(JPLAY)
138
139!- from PRECISE             
140REAL(KIND=JPRB) :: Z_ONEMINUS
141
142!- from PROFDATA             
143REAL(KIND=JPRB) :: Z_COLH2O(JPLAY)
144REAL(KIND=JPRB) :: Z_COLCO2(JPLAY)
145REAL(KIND=JPRB) :: Z_COLO3 (JPLAY)
146REAL(KIND=JPRB) :: Z_COLN2O(JPLAY)
147REAL(KIND=JPRB) :: Z_COLCH4(JPLAY)
148REAL(KIND=JPRB) :: Z_COLO2 (JPLAY)
149REAL(KIND=JPRB) :: Z_CO2MULT(JPLAY)
150INTEGER(KIND=JPIM) :: I_LAYTROP
151INTEGER(KIND=JPIM) :: I_LAYSWTCH
152INTEGER(KIND=JPIM) :: I_LAYLOW
153
154!- from PROFILE             
155REAL(KIND=JPRB) :: Z_PAVEL(JPLAY)
156REAL(KIND=JPRB) :: Z_TAVEL(JPLAY)
157REAL(KIND=JPRB) :: Z_PZ(0:JPLAY)
158REAL(KIND=JPRB) :: Z_TZ(0:JPLAY)
159REAL(KIND=JPRB) :: Z_TBOUND
160INTEGER(KIND=JPIM) :: I_NLAYERS
161
162!- from SELF             
163REAL(KIND=JPRB) :: Z_SELFFAC(JPLAY)
164REAL(KIND=JPRB) :: Z_SELFFRAC(JPLAY)
165INTEGER(KIND=JPIM) :: INDSELF(JPLAY)
166
167!- from SP             
168REAL(KIND=JPRB) :: Z_PFRAC(JPGPT,JPLAY)
169
170!- from SURFACE             
171REAL(KIND=JPRB) :: Z_SEMISS(JPBAND)
172REAL(KIND=JPRB) :: Z_SEMISLW
173INTEGER(KIND=JPIM) :: IREFLECT
174REAL(KIND=JPRB) :: ZHOOK_HANDLE
175
176#include "rrtm_ecrt_140gp.intfb.h"
177#include "rrtm_gasabs1a_140gp.intfb.h"
178#include "rrtm_rtrn1a_140gp.intfb.h"
179#include "rrtm_setcoef_140gp.intfb.h"
180
181!     HEATFAC is the factor by which one must multiply delta-flux/
182!     delta-pressure, with flux in w/m-2 and pressure in mbar, to get
183!     the heating rate in units of degrees/day.  It is equal to
184!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
185!        =  (9.8066)(86400)(1e-5)/(1.004)
186
187IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP',0,ZHOOK_HANDLE)
188ZEPSEC = 1.E-06_JPRB
189Z_ONEMINUS = 1.0_JPRB - ZEPSEC
190Z_PI = 2.0_JPRB*ASIN(1.0_JPRB)
191Z_FLUXFAC = Z_PI * 2.D4
192Z_HEATFAC = 8.4391_JPRB
193
194! *** mji ***
195! For use with ECRT, this loop is over atmospheres (or longitudes)
196DO iplon = kidia,kfdia
197
198! *** mji ***
199!- Prepare atmospheric profile from ECRT for use in RRTM, and define
200!  other RRTM input parameters.  Arrays are passed back through the
201!  existing RRTM commons and arrays.
202  ZTCLEAR=1.0_JPRB
203
204  CALL RRTM_ECRT_140GP &
205   & ( iplon, klon , klev, icld,&
206   & paer , paph , pap,&
207   & pts  , pth  , pt,&
208   & P_ZEMIS, P_ZEMIW,&
209   & pq   , pcco2, pozn, pcldf, ptaucld, ztclear,&
210   & Z_CLDFRAC,Z_TAUCLD,&
211   & PTAU_LW,&
212   & Z_COLDRY,Z_WKL,Z_WX,&
213   & Z_TAUAERL,Z_PAVEL,Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,I_NLAYERS,Z_SEMISS,IREFLECT) 
214
215  PTCLEAR(iplon)=ztclear
216
217  ISTART = 1
218  IEND   = 16
219
220!  Calculate information needed by the radiative transfer routine
221!  that is specific to this atmosphere, especially some of the
222!  coefficients and indices needed to compute the optical depths
223!  by interpolating data from stored reference atmospheres.
224
225  CALL RRTM_SETCOEF_140GP (KLEV,Z_COLDRY,Z_WKL,&
226   & Z_FAC00,Z_FAC01,Z_FAC10,Z_FAC11,Z_FORFAC,JP,JT,JT1,&
227   & Z_COLH2O,Z_COLCO2,Z_COLO3,Z_COLN2O,Z_COLCH4,Z_COLO2,Z_CO2MULT,&
228   & I_LAYTROP,I_LAYSWTCH,I_LAYLOW,Z_PAVEL,Z_TAVEL,Z_SELFFAC,Z_SELFFRAC,INDSELF) 
229
230  CALL RRTM_GASABS1A_140GP (KLEV,Z_ATR1,Z_OD,Z_TF1,Z_COLDRY,Z_WX,&
231   & Z_TAUAERL,Z_FAC00,Z_FAC01,Z_FAC10,Z_FAC11,Z_FORFAC,JP,JT,JT1,Z_ONEMINUS,&
232   & Z_COLH2O,Z_COLCO2,Z_COLO3,Z_COLN2O,Z_COLCH4,Z_COLO2,Z_CO2MULT,&
233   & I_LAYTROP,I_LAYSWTCH,I_LAYLOW,Z_SELFFAC,Z_SELFFRAC,INDSELF,Z_PFRAC) 
234
235!- Call the radiative transfer routine.
236
237! *** mji ***
238!  Check for cloud in column.  Use ECRT threshold set as flag icld in
239!  routine ECRTATM.  If icld=1 then column is cloudy, otherwise it is
240!  clear.  Also, set up flag array, icldlyr, for use in radiative
241!  transfer.  Set icldlyr to one for each layer with non-zero cloud
242!  fraction.
243
244  DO I_K = 1, KLEV
245    IF (ICLD == 1.AND.Z_CLDFRAC(I_K) > ZEPSEC) THEN
246      ICLDLYR(I_K) = 1
247    ELSE
248      ICLDLYR(I_K) = 0
249    ENDIF
250  ENDDO
251
252!  Clear and cloudy parts of column are treated together in RTRN.
253!  Clear radiative transfer is done for clear layers and cloudy radiative
254!  transfer is done for cloudy layers as identified by icldlyr.
255
256  CALL RRTM_RTRN1A_140GP (KLEV,ISTART,IEND,ICLDLYR,Z_CLDFRAC,Z_TAUCLD,Z_ABSS1,&
257   & Z_OD,Z_TAUSF1,Z_CLFNET,Z_CLHTR,Z_FNET,Z_HTR,Z_TOTDFLUC,Z_TOTDFLUX,Z_TOTUFLUC,Z_TOTUFLUX,&
258   & Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,Z_PFRAC,Z_SEMISS,Z_SEMISLW,IREFLECT) 
259
260! ***   Pass clear sky and total sky up and down flux profiles to ECRT
261!       output arrays (zflux, zfluc). Array indexing from bottom to top
262!       is preserved for ECRT.
263!       Invert down flux arrays for consistency with ECRT sign conventions.
264
265  pemit(iplon) = Z_SEMISLW
266  DO i = 0, KLEV
267    PFLUC(iplon,1,i+1) =  Z_TOTUFLUC(i)*Z_FLUXFAC
268    PFLUC(iplon,2,i+1) = -Z_TOTDFLUC(i)*Z_FLUXFAC
269    PFLUX(iplon,1,i+1) =  Z_TOTUFLUX(i)*Z_FLUXFAC
270    PFLUX(iplon,2,i+1) = -Z_TOTDFLUX(i)*Z_FLUXFAC
271  ENDDO
272ENDDO
273
274IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP',1,ZHOOK_HANDLE)
275END SUBROUTINE RRTM_RRTM_140GP
Note: See TracBrowser for help on using the repository browser.