source: LMDZ5/trunk/libf/phylmd/rrtm/rrtm_rrtm_140gp.F90 @ 2031

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

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • 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: 10.8 KB
RevLine 
[1989]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 & PEMIT , PFLUX , PFLUC, PTCLEAR &
43 & ) 
44
45! *** This program is the driver for RRTM, the AER rapid model. 
46!     For each atmosphere the user wishes to analyze, this routine
47!     a) calls ECRTATM to read in the atmospheric profile
48!     b) calls SETCOEF to calculate various quantities needed for
49!        the radiative transfer algorithm
50!     c) calls RTRN to do the radiative transfer calculation for
51!        clear or cloudy sky
52!     d) writes out the upward, downward, and net flux for each
53!        level and the heating rate for each layer
54
55USE PARKIND1  ,ONLY : JPIM     ,JPRB
56USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
57
58USE PARRRTM  , ONLY : JPBAND   ,JPXSEC   ,JPGPT    ,JPLAY    ,&
59 & JPINPX 
60!------------------------------Arguments--------------------------------
61
62! Input arguments
63
64IMPLICIT NONE
65INTEGER(KIND=JPIM),INTENT(IN)    :: KLON! Number of atmospheres (longitudes)
66INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV! Number of atmospheric layers
67INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA ! First atmosphere index
68INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA ! Last atmosphere index
69REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KLON,6,KLEV) ! Aerosol optical thickness
70REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPH(KLON,KLEV+1) ! Interface pressures (Pa)
71REAL(KIND=JPRB)   ,INTENT(IN)    :: PAP(KLON,KLEV) ! Layer pressures (Pa)
72REAL(KIND=JPRB)   ,INTENT(IN)    :: PTS(KLON) ! Surface temperature (I_K)
73REAL(KIND=JPRB)   ,INTENT(IN)    :: PTH(KLON,KLEV+1) ! Interface temperatures (I_K)
74REAL(KIND=JPRB)   ,INTENT(IN)    :: PT(KLON,KLEV) ! Layer temperature (I_K)
75REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIS(KLON) ! Non-window surface emissivity
76REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIW(KLON) ! Window surface emissivity
77REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ(KLON,KLEV) ! H2O specific humidity (mmr)
78REAL(KIND=JPRB)   ,INTENT(IN)    :: PCCO2 ! CO2 mass mixing ratio
79REAL(KIND=JPRB)   ,INTENT(IN)    :: POZN(KLON,KLEV) ! O3 mass mixing ratio
80REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDF(KLON,KLEV) ! Cloud fraction
81REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUCLD(KLON,KLEV,JPBAND) ! Cloud optical depth
82REAL(KIND=JPRB)   ,INTENT(OUT)   :: PEMIT(KLON) ! Surface LW emissivity
83REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUX(KLON,2,KLEV+1) ! LW total sky flux (1=up, 2=down)
84REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUC(KLON,2,KLEV+1) ! LW clear sky flux (1=up, 2=down)
85REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTCLEAR(KLON) ! clear-sky fraction of column
86INTEGER(KIND=JPIM) :: ICLDLYR(JPLAY)        ! Cloud indicator
87REAL(KIND=JPRB) :: Z_CLDFRAC(JPLAY)           ! Cloud fraction
88REAL(KIND=JPRB) :: Z_TAUCLD(JPLAY,JPBAND)     ! Spectral optical thickness
89
90REAL(KIND=JPRB) :: Z_ABSS1 (JPGPT*JPLAY)
91REAL(KIND=JPRB) :: Z_ATR1  (JPGPT,JPLAY)
92EQUIVALENCE (Z_ABSS1(1),Z_ATR1(1,1))
93
94REAL(KIND=JPRB) :: Z_OD    (JPGPT,JPLAY)
95
96REAL(KIND=JPRB) :: Z_TAUSF1(JPGPT*JPLAY)
97REAL(KIND=JPRB) :: Z_TF1   (JPGPT,JPLAY)
98EQUIVALENCE (Z_TAUSF1(1),Z_TF1(1,1))
99
100REAL(KIND=JPRB) :: Z_COLDRY(JPLAY)
101REAL(KIND=JPRB) :: Z_WKL(JPINPX,JPLAY)
102
103REAL(KIND=JPRB) :: Z_WX(JPXSEC,JPLAY)         ! Amount of trace gases
104
105REAL(KIND=JPRB) :: Z_CLFNET  (0:JPLAY)
106REAL(KIND=JPRB) :: Z_CLHTR   (0:JPLAY)
107REAL(KIND=JPRB) :: Z_FNET    (0:JPLAY)
108REAL(KIND=JPRB) :: Z_HTR     (0:JPLAY)
109REAL(KIND=JPRB) :: Z_TOTDFLUC(0:JPLAY)
110REAL(KIND=JPRB) :: Z_TOTDFLUX(0:JPLAY)
111REAL(KIND=JPRB) :: Z_TOTUFLUC(0:JPLAY)
112REAL(KIND=JPRB) :: Z_TOTUFLUX(0:JPLAY)
113
114INTEGER(KIND=JPIM) :: i, icld, iplon, I_K
115INTEGER(KIND=JPIM) :: ISTART
116INTEGER(KIND=JPIM) :: IEND
117
118REAL(KIND=JPRB) :: Z_FLUXFAC, Z_HEATFAC, Z_PI, ZEPSEC, ZTCLEAR
119
120!- from AER
121REAL(KIND=JPRB) :: Z_TAUAERL(JPLAY,JPBAND)
122
123!- from INTFAC     
124REAL(KIND=JPRB) :: Z_FAC00(JPLAY)
125REAL(KIND=JPRB) :: Z_FAC01(JPLAY)
126REAL(KIND=JPRB) :: Z_FAC10(JPLAY)
127REAL(KIND=JPRB) :: Z_FAC11(JPLAY)
128REAL(KIND=JPRB) :: Z_FORFAC(JPLAY)
129
130!- from INTIND
131INTEGER(KIND=JPIM) :: JP(JPLAY)
132INTEGER(KIND=JPIM) :: JT(JPLAY)
133INTEGER(KIND=JPIM) :: JT1(JPLAY)
134
135!- from PRECISE             
136REAL(KIND=JPRB) :: Z_ONEMINUS
137
138!- from PROFDATA             
139REAL(KIND=JPRB) :: Z_COLH2O(JPLAY)
140REAL(KIND=JPRB) :: Z_COLCO2(JPLAY)
141REAL(KIND=JPRB) :: Z_COLO3 (JPLAY)
142REAL(KIND=JPRB) :: Z_COLN2O(JPLAY)
143REAL(KIND=JPRB) :: Z_COLCH4(JPLAY)
144REAL(KIND=JPRB) :: Z_COLO2 (JPLAY)
145REAL(KIND=JPRB) :: Z_CO2MULT(JPLAY)
146INTEGER(KIND=JPIM) :: I_LAYTROP
147INTEGER(KIND=JPIM) :: I_LAYSWTCH
148INTEGER(KIND=JPIM) :: I_LAYLOW
149
150!- from PROFILE             
151REAL(KIND=JPRB) :: Z_PAVEL(JPLAY)
152REAL(KIND=JPRB) :: Z_TAVEL(JPLAY)
153REAL(KIND=JPRB) :: Z_PZ(0:JPLAY)
154REAL(KIND=JPRB) :: Z_TZ(0:JPLAY)
155REAL(KIND=JPRB) :: Z_TBOUND
156INTEGER(KIND=JPIM) :: I_NLAYERS
157
158!- from SELF             
159REAL(KIND=JPRB) :: Z_SELFFAC(JPLAY)
160REAL(KIND=JPRB) :: Z_SELFFRAC(JPLAY)
161INTEGER(KIND=JPIM) :: INDSELF(JPLAY)
162
163!- from SP             
164REAL(KIND=JPRB) :: Z_PFRAC(JPGPT,JPLAY)
165
166!- from SURFACE             
167REAL(KIND=JPRB) :: Z_SEMISS(JPBAND)
168REAL(KIND=JPRB) :: Z_SEMISLW
169INTEGER(KIND=JPIM) :: IREFLECT
170REAL(KIND=JPRB) :: ZHOOK_HANDLE
171
172#include "rrtm_ecrt_140gp.intfb.h"
173#include "rrtm_gasabs1a_140gp.intfb.h"
174#include "rrtm_rtrn1a_140gp.intfb.h"
175#include "rrtm_setcoef_140gp.intfb.h"
176
177!     HEATFAC is the factor by which one must multiply delta-flux/
178!     delta-pressure, with flux in w/m-2 and pressure in mbar, to get
179!     the heating rate in units of degrees/day.  It is equal to
180!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
181!        =  (9.8066)(86400)(1e-5)/(1.004)
182
183IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP',0,ZHOOK_HANDLE)
184ZEPSEC = 1.E-06_JPRB
185Z_ONEMINUS = 1.0_JPRB - ZEPSEC
186Z_PI = 2.0_JPRB*ASIN(1.0_JPRB)
187Z_FLUXFAC = Z_PI * 2.D4
188Z_HEATFAC = 8.4391_JPRB
189
190! *** mji ***
191! For use with ECRT, this loop is over atmospheres (or longitudes)
192DO iplon = kidia,kfdia
193
194! *** mji ***
195!- Prepare atmospheric profile from ECRT for use in RRTM, and define
196!  other RRTM input parameters.  Arrays are passed back through the
197!  existing RRTM commons and arrays.
198  ZTCLEAR=1.0_JPRB
199
200  CALL RRTM_ECRT_140GP &
201   & ( iplon, klon , klev, icld,&
202   & paer , paph , pap,&
203   & pts  , pth  , pt,&
204   & P_ZEMIS, P_ZEMIW,&
205   & pq   , pcco2, pozn, pcldf, ptaucld, ztclear,&
206   & Z_CLDFRAC,Z_TAUCLD,Z_COLDRY,Z_WKL,Z_WX,&
207   & Z_TAUAERL,Z_PAVEL,Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,I_NLAYERS,Z_SEMISS,IREFLECT) 
208
209  PTCLEAR(iplon)=ztclear
210
211  ISTART = 1
212  IEND   = 16
213
214!  Calculate information needed by the radiative transfer routine
215!  that is specific to this atmosphere, especially some of the
216!  coefficients and indices needed to compute the optical depths
217!  by interpolating data from stored reference atmospheres.
218
219  CALL RRTM_SETCOEF_140GP (KLEV,Z_COLDRY,Z_WKL,&
220   & Z_FAC00,Z_FAC01,Z_FAC10,Z_FAC11,Z_FORFAC,JP,JT,JT1,&
221   & Z_COLH2O,Z_COLCO2,Z_COLO3,Z_COLN2O,Z_COLCH4,Z_COLO2,Z_CO2MULT,&
222   & I_LAYTROP,I_LAYSWTCH,I_LAYLOW,Z_PAVEL,Z_TAVEL,Z_SELFFAC,Z_SELFFRAC,INDSELF) 
223
224  CALL RRTM_GASABS1A_140GP (KLEV,Z_ATR1,Z_OD,Z_TF1,Z_COLDRY,Z_WX,&
225   & Z_TAUAERL,Z_FAC00,Z_FAC01,Z_FAC10,Z_FAC11,Z_FORFAC,JP,JT,JT1,Z_ONEMINUS,&
226   & Z_COLH2O,Z_COLCO2,Z_COLO3,Z_COLN2O,Z_COLCH4,Z_COLO2,Z_CO2MULT,&
227   & I_LAYTROP,I_LAYSWTCH,I_LAYLOW,Z_SELFFAC,Z_SELFFRAC,INDSELF,Z_PFRAC) 
228
229!- Call the radiative transfer routine.
230
231! *** mji ***
232!  Check for cloud in column.  Use ECRT threshold set as flag icld in
233!  routine ECRTATM.  If icld=1 then column is cloudy, otherwise it is
234!  clear.  Also, set up flag array, icldlyr, for use in radiative
235!  transfer.  Set icldlyr to one for each layer with non-zero cloud
236!  fraction.
237
238  DO I_K = 1, KLEV
239    IF (ICLD == 1.AND.Z_CLDFRAC(I_K) > ZEPSEC) THEN
240      ICLDLYR(I_K) = 1
241    ELSE
242      ICLDLYR(I_K) = 0
243    ENDIF
244  ENDDO
245
246!  Clear and cloudy parts of column are treated together in RTRN.
247!  Clear radiative transfer is done for clear layers and cloudy radiative
248!  transfer is done for cloudy layers as identified by icldlyr.
249
250  CALL RRTM_RTRN1A_140GP (KLEV,ISTART,IEND,ICLDLYR,Z_CLDFRAC,Z_TAUCLD,Z_ABSS1,&
251   & Z_OD,Z_TAUSF1,Z_CLFNET,Z_CLHTR,Z_FNET,Z_HTR,Z_TOTDFLUC,Z_TOTDFLUX,Z_TOTUFLUC,Z_TOTUFLUX,&
252   & Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,Z_PFRAC,Z_SEMISS,Z_SEMISLW,IREFLECT) 
253
254! ***   Pass clear sky and total sky up and down flux profiles to ECRT
255!       output arrays (zflux, zfluc). Array indexing from bottom to top
256!       is preserved for ECRT.
257!       Invert down flux arrays for consistency with ECRT sign conventions.
258
259  pemit(iplon) = Z_SEMISLW
260  DO i = 0, KLEV
261    PFLUC(iplon,1,i+1) =  Z_TOTUFLUC(i)*Z_FLUXFAC
262    PFLUC(iplon,2,i+1) = -Z_TOTDFLUC(i)*Z_FLUXFAC
263    PFLUX(iplon,1,i+1) =  Z_TOTUFLUX(i)*Z_FLUXFAC
264    PFLUX(iplon,2,i+1) = -Z_TOTDFLUX(i)*Z_FLUXFAC
265  ENDDO
266ENDDO
267
268IF (LHOOK) CALL DR_HOOK('RRTM_RRTM_140GP',1,ZHOOK_HANDLE)
269END SUBROUTINE RRTM_RRTM_140GP
Note: See TracBrowser for help on using the repository browser.