source: LMDZ6/trunk/libf/phylmd/rrtm/rrtm_rrtm_140gp.F90 @ 5833

Last change on this file since 5833 was 5677, checked in by Laurent Fairhead, 6 months ago

Added outputs for spectral bands in RRTM (with dummy variables for ECRAD at present)
FC
  • 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.4 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 & PTOAG, PTOACG) !FC
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
90
91REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTOAG(KLON,JPGPT) ! full-sky TOA G !FC
92REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTOACG(KLON,JPGPT) ! clear-sky TOA G !FC
93
94INTEGER(KIND=JPIM) :: ICLDLYR(JPLAY)        ! Cloud indicator
95REAL(KIND=JPRB) :: Z_CLDFRAC(JPLAY)           ! Cloud fraction
96REAL(KIND=JPRB) :: Z_TAUCLD(JPLAY,JPBAND)     ! Spectral optical thickness
97
98REAL(KIND=JPRB) :: Z_ABSS1 (JPGPT*JPLAY)
99REAL(KIND=JPRB) :: Z_ATR1  (JPGPT,JPLAY)
100EQUIVALENCE (Z_ABSS1(1),Z_ATR1(1,1))
101
102REAL(KIND=JPRB) :: Z_OD    (JPGPT,JPLAY)
103
104REAL(KIND=JPRB) :: Z_TAUSF1(JPGPT*JPLAY)
105REAL(KIND=JPRB) :: Z_TF1   (JPGPT,JPLAY)
106EQUIVALENCE (Z_TAUSF1(1),Z_TF1(1,1))
107
108REAL(KIND=JPRB) :: Z_COLDRY(JPLAY)
109REAL(KIND=JPRB) :: Z_WKL(JPINPX,JPLAY)
110
111REAL(KIND=JPRB) :: Z_WX(JPXSEC,JPLAY)         ! Amount of trace gases
112
113REAL(KIND=JPRB) :: Z_CLFNET  (0:JPLAY)
114REAL(KIND=JPRB) :: Z_CLHTR   (0:JPLAY)
115REAL(KIND=JPRB) :: Z_FNET    (0:JPLAY)
116REAL(KIND=JPRB) :: Z_HTR     (0:JPLAY)
117REAL(KIND=JPRB) :: Z_TOTDFLUC(0:JPLAY)
118REAL(KIND=JPRB) :: Z_TOTDFLUX(0:JPLAY)
119REAL(KIND=JPRB) :: Z_TOTUFLUC(0:JPLAY)
120REAL(KIND=JPRB) :: Z_TOTUFLUX(0:JPLAY)
121
122REAL(KIND=JPRB) :: Z_TOAG(JPGPT) !FC
123REAL(KIND=JPRB) :: Z_TOACG(JPGPT) !FC
124
125
126INTEGER(KIND=JPIM) :: i, icld, iplon, I_K ,JI !FC
127INTEGER(KIND=JPIM) :: ISTART
128INTEGER(KIND=JPIM) :: IEND
129
130REAL(KIND=JPRB) :: Z_FLUXFAC, Z_HEATFAC, Z_PI, ZEPSEC, ZTCLEAR
131
132!- from AER
133REAL(KIND=JPRB) :: Z_TAUAERL(JPLAY,JPBAND)
134
135!- from INTFAC     
136REAL(KIND=JPRB) :: Z_FAC00(JPLAY)
137REAL(KIND=JPRB) :: Z_FAC01(JPLAY)
138REAL(KIND=JPRB) :: Z_FAC10(JPLAY)
139REAL(KIND=JPRB) :: Z_FAC11(JPLAY)
140REAL(KIND=JPRB) :: Z_FORFAC(JPLAY)
141
142!- from INTIND
143INTEGER(KIND=JPIM) :: JP(JPLAY)
144INTEGER(KIND=JPIM) :: JT(JPLAY)
145INTEGER(KIND=JPIM) :: JT1(JPLAY)
146
147!- from PRECISE             
148REAL(KIND=JPRB) :: Z_ONEMINUS
149
150!- from PROFDATA             
151REAL(KIND=JPRB) :: Z_COLH2O(JPLAY)
152REAL(KIND=JPRB) :: Z_COLCO2(JPLAY)
153REAL(KIND=JPRB) :: Z_COLO3 (JPLAY)
154REAL(KIND=JPRB) :: Z_COLN2O(JPLAY)
155REAL(KIND=JPRB) :: Z_COLCH4(JPLAY)
156REAL(KIND=JPRB) :: Z_COLO2 (JPLAY)
157REAL(KIND=JPRB) :: Z_CO2MULT(JPLAY)
158INTEGER(KIND=JPIM) :: I_LAYTROP
159INTEGER(KIND=JPIM) :: I_LAYSWTCH
160INTEGER(KIND=JPIM) :: I_LAYLOW
161
162!- from PROFILE             
163REAL(KIND=JPRB) :: Z_PAVEL(JPLAY)
164REAL(KIND=JPRB) :: Z_TAVEL(JPLAY)
165REAL(KIND=JPRB) :: Z_PZ(0:JPLAY)
166REAL(KIND=JPRB) :: Z_TZ(0:JPLAY)
167REAL(KIND=JPRB) :: Z_TBOUND
168INTEGER(KIND=JPIM) :: I_NLAYERS
169
170!- from SELF             
171REAL(KIND=JPRB) :: Z_SELFFAC(JPLAY)
172REAL(KIND=JPRB) :: Z_SELFFRAC(JPLAY)
173INTEGER(KIND=JPIM) :: INDSELF(JPLAY)
174
175!- from SP             
176REAL(KIND=JPRB) :: Z_PFRAC(JPGPT,JPLAY)
177
178!- from SURFACE             
179REAL(KIND=JPRB) :: Z_SEMISS(JPBAND)
180REAL(KIND=JPRB) :: Z_SEMISLW
181INTEGER(KIND=JPIM) :: IREFLECT
182REAL(KIND=JPRB) :: ZHOOK_HANDLE
183
184#include "rrtm_ecrt_140gp.intfb.h"
185#include "rrtm_gasabs1a_140gp.intfb.h"
186#include "rrtm_rtrn1a_140gp.intfb.h"
187#include "rrtm_setcoef_140gp.intfb.h"
188
189!     HEATFAC is the factor by which one must multiply delta-flux/
190!     delta-pressure, with flux in w/m-2 and pressure in mbar, to get
191!     the heating rate in units of degrees/day.  It is equal to
192!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
193!        =  (9.8066)(86400)(1e-5)/(1.004)
194
195IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP',0,ZHOOK_HANDLE)
196ZEPSEC = 1.E-06_JPRB
197Z_ONEMINUS = 1.0_JPRB - ZEPSEC
198Z_PI = 2.0_JPRB*ASIN(1.0_JPRB)
199Z_FLUXFAC = Z_PI * 2.D4
200Z_HEATFAC = 8.4391_JPRB
201
202! *** mji ***
203! For use with ECRT, this loop is over atmospheres (or longitudes)
204DO iplon = kidia,kfdia
205
206! *** mji ***
207!- Prepare atmospheric profile from ECRT for use in RRTM, and define
208!  other RRTM input parameters.  Arrays are passed back through the
209!  existing RRTM commons and arrays.
210  ZTCLEAR=1.0_JPRB
211
212  CALL RRTM_ECRT_140GP &
213   & ( iplon, klon , klev, icld,&
214   & paer , paph , pap,&
215   & pts  , pth  , pt,&
216   & P_ZEMIS, P_ZEMIW,&
217   & pq   , pcco2, pozn, pcldf, ptaucld, ztclear,&
218   & Z_CLDFRAC,Z_TAUCLD,&
219   & PTAU_LW,&
220   & Z_COLDRY,Z_WKL,Z_WX,&
221   & Z_TAUAERL,Z_PAVEL,Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,I_NLAYERS,Z_SEMISS,IREFLECT) 
222
223  PTCLEAR(iplon)=ztclear
224
225  ISTART = 1
226  IEND   = 16
227
228!  Calculate information needed by the radiative transfer routine
229!  that is specific to this atmosphere, especially some of the
230!  coefficients and indices needed to compute the optical depths
231!  by interpolating data from stored reference atmospheres.
232
233  CALL RRTM_SETCOEF_140GP (KLEV,Z_COLDRY,Z_WKL,&
234   & Z_FAC00,Z_FAC01,Z_FAC10,Z_FAC11,Z_FORFAC,JP,JT,JT1,&
235   & Z_COLH2O,Z_COLCO2,Z_COLO3,Z_COLN2O,Z_COLCH4,Z_COLO2,Z_CO2MULT,&
236   & I_LAYTROP,I_LAYSWTCH,I_LAYLOW,Z_PAVEL,Z_TAVEL,Z_SELFFAC,Z_SELFFRAC,INDSELF) 
237
238  CALL RRTM_GASABS1A_140GP (KLEV,Z_ATR1,Z_OD,Z_TF1,Z_COLDRY,Z_WX,&
239   & Z_TAUAERL,Z_FAC00,Z_FAC01,Z_FAC10,Z_FAC11,Z_FORFAC,JP,JT,JT1,Z_ONEMINUS,&
240   & Z_COLH2O,Z_COLCO2,Z_COLO3,Z_COLN2O,Z_COLCH4,Z_COLO2,Z_CO2MULT,&
241   & I_LAYTROP,I_LAYSWTCH,I_LAYLOW,Z_SELFFAC,Z_SELFFRAC,INDSELF,Z_PFRAC) 
242
243!- Call the radiative transfer routine.
244
245! *** mji ***
246!  Check for cloud in column.  Use ECRT threshold set as flag icld in
247!  routine ECRTATM.  If icld=1 then column is cloudy, otherwise it is
248!  clear.  Also, set up flag array, icldlyr, for use in radiative
249!  transfer.  Set icldlyr to one for each layer with non-zero cloud
250!  fraction.
251
252  DO I_K = 1, KLEV
253    IF (ICLD == 1.AND.Z_CLDFRAC(I_K) > ZEPSEC) THEN
254      ICLDLYR(I_K) = 1
255    ELSE
256      ICLDLYR(I_K) = 0
257    ENDIF
258  ENDDO
259
260!  Clear and cloudy parts of column are treated together in RTRN.
261!  Clear radiative transfer is done for clear layers and cloudy radiative
262!  transfer is done for cloudy layers as identified by icldlyr.
263!FC
264
265  CALL RRTM_RTRN1A_140GP (KLEV,ISTART,IEND,ICLDLYR,Z_CLDFRAC,Z_TAUCLD,Z_ABSS1,&
266   & Z_OD,Z_TAUSF1,Z_CLFNET,Z_CLHTR,Z_FNET,Z_HTR,Z_TOTDFLUC,Z_TOTDFLUX,Z_TOTUFLUC,Z_TOTUFLUX,&
267   & Z_TOAG, Z_TOACG,&   
268   & Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,Z_PFRAC,Z_SEMISS,Z_SEMISLW,IREFLECT) 
269
270! ***   Pass clear sky and total sky up and down flux profiles to ECRT
271!       output arrays (zflux, zfluc). Array indexing from bottom to top
272!       is preserved for ECRT.
273!       Invert down flux arrays for consistency with ECRT sign conventions.
274
275  pemit(iplon) = Z_SEMISLW
276  DO i = 0, KLEV
277    PFLUC(iplon,1,i+1) =  Z_TOTUFLUC(i)*Z_FLUXFAC
278    PFLUC(iplon,2,i+1) = -Z_TOTDFLUC(i)*Z_FLUXFAC
279    PFLUX(iplon,1,i+1) =  Z_TOTUFLUX(i)*Z_FLUXFAC
280    PFLUX(iplon,2,i+1) = -Z_TOTDFLUX(i)*Z_FLUXFAC
281  ENDDO
282!FC
283  DO JI = 1, JPGPT
284   PTOAG(iplon,JI) = Z_TOAG(JI)*Z_FLUXFAC !FC faire attention aux niveaux (i+1 et i)
285   PTOACG(iplon,JI) = Z_TOACG(JI)*Z_FLUXFAC
286  ENDDO
287!FC
288ENDDO
289
290IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP',1,ZHOOK_HANDLE)
291END SUBROUTINE RRTM_RRTM_140GP
Note: See TracBrowser for help on using the repository browser.