source: LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_taumol1.F90 @ 5456

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

Nouvelle version qui inclut les effets des aérosols et propose les mêmes diagnostics des effets
directs et indirects que l'ancienne version du rayonnement.
OB

New RRTM version that includes the effects of aerosols and outputs the same direct and indirect effects
diagnostics as the old version
OB
  • 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: 13.4 KB
Line 
1!******************************************************************************
2!                                                                             *
3!                  Optical depths developed for the                           *
4!                                                                             *
5!                RAPID RADIATIVE TRANSFER MODEL (RRTM)                        *
6!                                                                             *
7!            ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                     *
8!                        840 MEMORIAL DRIVE                                   *
9!                        CAMBRIDGE, MA 02139                                  *
10!                                                                             *
11!                           ELI J. MLAWER                                     *
12!                         STEVEN J. TAUBMAN                                   *
13!                         SHEPARD A. CLOUGH                                   *
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! Modified by:                                                                *
23!      JJ Morcrette 980714 ECMWF      for use on ECMWF's Fujitsu VPP770       *
24!         Reformatted for F90 by JJMorcrette, ECMWF                           *
25!         - replacing COMMONs by MODULEs                                      *
26!         - changing labelled to unlabelled DO loops                          *
27!         - creating set-up routines for all block data statements            *
28!         - reorganizing the parameter statements                             *
29!         - passing KLEV as argument                                          *
30!         - suppressing some equivalencing                                    *
31!                                                                             *
32!      D Salmond    9907   ECMWF      Speed-up modifications                  *
33!      D Salmond    000515 ECMWF      Speed-up modifications                  *
34!******************************************************************************
35!     TAUMOL                                                                  *
36!                                                                             *
37!     This file contains the subroutines TAUGBn (where n goes from            *
38!     1 to 16).  TAUGBn calculates the optical depths and Planck fractions    *
39!     per g-value and layer for band n.                                       *
40!                                                                             *
41!  Output:  optical depths (unitless)                                         *
42!           fractions needed to compute Planck functions at every layer       *
43!               and g-value                                                   *
44!                                                                             *
45!     COMMON /TAUGCOM/  TAUG(MXLAY,MG)                                        *
46!     COMMON /PLANKG/   FRACS(MXLAY,MG)                                       *
47!                                                                             *
48!  Input                                                                      *
49!                                                                             *
50!     COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS)                  *
51!     COMMON /PRECISE/  ONEMINUS                                              *
52!     COMMON /PROFILE/  NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY),                    *
53!    &                  PZ(0:MXLAY),TZ(0:MXLAY),TBOUND                        *
54!     COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW,                              *
55!    &                  COLH2O(MXLAY),COLCO2(MXLAY),                          *
56!    &                  COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY),             *
57!    &                  COLO2(MXLAY),CO2MULT(MXLAY)                           *
58!     COMMON /INTFAC/   FAC00(MXLAY),FAC01(MXLAY),                            *
59!    &                  FAC10(MXLAY),FAC11(MXLAY)                             *
60!     COMMON /INTIND/   JP(MXLAY),JT(MXLAY),JT1(MXLAY)                        *
61!     COMMON /SELF/     SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY)       *
62!                                                                             *
63!     Description:                                                            *
64!     NG(IBAND) - number of g-values in band IBAND                            *
65!     NSPA(IBAND) - for the lower atmosphere, the number of reference         *
66!                   atmospheres that are stored for band IBAND per            *
67!                   pressure level and temperature.  Each of these            *
68!                   atmospheres has different relative amounts of the         *
69!                   key species for the band (i.e. different binary           *
70!                   species parameters).                                      *
71!     NSPB(IBAND) - same for upper atmosphere                                 *
72!     ONEMINUS - since problems are caused in some cases by interpolation     *
73!                parameters equal to or greater than 1, for these cases       *
74!                these parameters are set to this value, slightly < 1.        *
75!     PAVEL - layer pressures (mb)                                            *
76!     TAVEL - layer temperatures (degrees K)                                  *
77!     PZ - level pressures (mb)                                               *
78!     TZ - level temperatures (degrees K)                                     *
79!     LAYTROP - layer at which switch is made from one combination of         *
80!               key species to another                                        *
81!     COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water         *
82!               vapor,carbon dioxide, ozone, nitrous ozide, methane,          *
83!               respectively (molecules/cm**2)                                *
84!     CO2MULT - for bands in which carbon dioxide is implemented as a         *
85!               trace species, this is the factor used to multiply the        *
86!               band's average CO2 absorption coefficient to get the added    *
87!               contribution to the optical depth relative to 355 ppm.        *
88!     FACij(LAY) - for layer LAY, these are factors that are needed to        *
89!                  compute the interpolation factors that multiply the        *
90!                  appropriate reference k-values.  A value of 0 (1) for      *
91!                  i,j indicates that the corresponding factor multiplies     *
92!                  reference k-value for the lower (higher) of the two        *
93!                  appropriate temperatures, and altitudes, respectively.     *
94!     JP - the index of the lower (in altitude) of the two appropriate        *
95!          reference pressure levels needed for interpolation                 *
96!     JT, JT1 - the indices of the lower of the two appropriate reference     *
97!               temperatures needed for interpolation (for pressure           *
98!               levels JP and JP+1, respectively)                             *
99!     SELFFAC - scale factor needed to water vapor self-continuum, equals     *
100!               (water vapor density)/(atmospheric density at 296K and        *
101!               1013 mb)                                                      *
102!     SELFFRAC - factor needed for temperature interpolation of reference     *
103!                water vapor self-continuum data                              *
104!     INDSELF - index of the lower of the two appropriate reference           *
105!               temperatures needed for the self-continuum interpolation      *
106!                                                                             *
107!  Data input                                                                 *
108!     COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) *
109!        (note:  n is the band number)                                        *
110!                                                                             *
111!     Description:                                                            *
112!     KA - k-values for low reference atmospheres (no water vapor             *
113!          self-continuum) (units: cm**2/molecule)                            *
114!     KB - k-values for high reference atmospheres (all sources)              *
115!          (units: cm**2/molecule)                                            *
116!     SELFREF - k-values for water vapor self-continuum for reference         *
117!               atmospheres (used below LAYTROP)                              *
118!               (units: cm**2/molecule)                                       *
119!                                                                             *
120!     DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG)                     *
121!     EQUIVALENCE (KA,ABSA),(KB,ABSB)                                         *
122!                                                                             *
123!******************************************************************************
124
125SUBROUTINE RRTM_TAUMOL1 (KLEV,P_TAU,&
126 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,&
127 & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
128
129!     Written by Eli J. Mlawer, Atmospheric & Environmental Research.
130!     Revised by Michael J. Iacono, Atmospheric & Environmental Research.
131
132!     BAND 1:  10-250 cm-1 (low - H2O; high - H2O)
133 
134! Modifications
135!        M.Hamrud      01-Oct-2003 CY28 Cleaning
136
137!     D Salmond   2000-05-15 speed-up
138!     JJMorcrette 2000-05-17 speed-up
139
140USE PARKIND1  ,ONLY : JPIM     ,JPRB
141USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
142
143USE PARRRTM  , ONLY : JPLAY  ,JPBAND ,JPGPT  ,NG1
144USE YOERRTWN , ONLY :      NSPA   ,NSPB
145USE YOERRTA1 , ONLY : ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
146 & FORREF   ,SELFREF   
147
148!#include "yoeratm.h"
149
150!      REAL TAUAER(JPLAY)
151
152IMPLICIT NONE
153
154!  Output
155INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
156REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAU(JPGPT,JPLAY)
157REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(JPLAY,JPBAND)
158REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(JPLAY)
159REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(JPLAY)
160REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(JPLAY)
161REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(JPLAY)
162REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(JPLAY)
163INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(JPLAY)
164INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(JPLAY)
165INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(JPLAY)
166REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(JPLAY)
167INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP
168REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(JPLAY)
169REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(JPLAY)
170INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(JPLAY)
171REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(JPGPT,JPLAY)
172!- from AER
173!- from INTFAC     
174!- from INTIND
175!- from PRECISE             
176!- from PROFDATA             
177!- from SELF             
178!- from SP             
179INTEGER(KIND=JPIM) :: IND0(JPLAY),IND1(JPLAY),INDS(JPLAY)
180
181INTEGER(KIND=JPIM) :: IG, I_LAY
182REAL(KIND=JPRB) :: ZHOOK_HANDLE
183
184!      EQUIVALENCE (TAUAERL(1,1),TAUAER)
185
186!     Compute the optical depth by interpolating in ln(pressure) and
187!     temperature.  Below LAYTROP, the water vapor self-continuum
188!     is interpolated (in temperature) separately. 
189
190IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',0,ZHOOK_HANDLE)
191!--ajout OB
192IF (K_LAYTROP.GT.100) THEN
193PRINT *,'ATTENTION KLAY_TROP > 100 PROBLEME ARRAY DANS RRTM ON ARRETE'
194STOP
195!--fin ajout OB
196ENDIF
197DO I_LAY = 1, K_LAYTROP
198  IND0(I_LAY) = ((K_JP(I_LAY)-1)*5+(K_JT(I_LAY)-1))*NSPA(1) + 1
199  IND1(I_LAY) = (K_JP(I_LAY)*5+(K_JT1(I_LAY)-1))*NSPA(1) + 1
200  INDS(I_LAY) = K_INDSELF(I_LAY)
201ENDDO
202
203DO IG = 1, NG1
204  DO I_LAY = 1, K_LAYTROP
205!-- DS_000515 
206    P_TAU (IG,I_LAY) = P_COLH2O(I_LAY) *&
207     & (P_FAC00(I_LAY) * ABSA(IND0(I_LAY)  ,IG) +&
208     & P_FAC10(I_LAY) * ABSA(IND0(I_LAY)+1,IG) +&
209     & P_FAC01(I_LAY) * ABSA(IND1(I_LAY)  ,IG) +&
210     & P_FAC11(I_LAY) * ABSA(IND1(I_LAY)+1,IG) +&
211     & P_SELFFAC(I_LAY) * (SELFREF(INDS(I_LAY),IG) + &
212     & P_SELFFRAC(I_LAY) *&
213     & (SELFREF(INDS(I_LAY)+1,IG) - SELFREF(INDS(I_LAY),IG)))&
214     & + P_FORFAC(I_LAY) * FORREF(IG) ) &
215     & + P_TAUAERL(I_LAY,1) 
216    PFRAC(IG,I_LAY) = FRACREFA(IG)
217  ENDDO
218ENDDO
219
220DO I_LAY = K_LAYTROP+1, KLEV
221  IND0(I_LAY) = ((K_JP(I_LAY)-13)*5+(K_JT(I_LAY)-1))*NSPB(1) + 1
222  IND1(I_LAY) = ((K_JP(I_LAY)-12)*5+(K_JT1(I_LAY)-1))*NSPB(1) + 1
223ENDDO
224
225!-- JJM000517
226DO IG = 1, NG1
227  DO I_LAY = K_LAYTROP+1, KLEV
228!-- JJM000517
229    P_TAU (IG,I_LAY) = P_COLH2O(I_LAY) *&
230     & (P_FAC00(I_LAY) * ABSB(IND0(I_LAY)  ,IG) +&
231     & P_FAC10(I_LAY) * ABSB(IND0(I_LAY)+1,IG) +&
232     & P_FAC01(I_LAY) * ABSB(IND1(I_LAY)  ,IG) +&
233     & P_FAC11(I_LAY) * ABSB(IND1(I_LAY)+1,IG)&
234     & + P_FORFAC(I_LAY) * FORREF(IG) ) &
235     & + P_TAUAERL(I_LAY,1) 
236    PFRAC(IG,I_LAY) = FRACREFB(IG)
237  ENDDO
238ENDDO
239
240IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',1,ZHOOK_HANDLE)
241END SUBROUTINE RRTM_TAUMOL1
Note: See TracBrowser for help on using the repository browser.