source: LMDZ5/branches/testing/libf/phymar/rrtm_taumol1.F90 @ 5434

Last change on this file since 5434 was 2160, checked in by Laurent Fairhead, 10 years ago

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand
File size: 12.5 KB
RevLine 
[2089]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
125
126SUBROUTINE RRTM_TAUMOL1 (KLEV,TAU,&
127  &TAUAERL,FAC00,FAC01,FAC10,FAC11,FORFAC,JP,JT,JT1,&
128  &COLH2O,LAYTROP,SELFFAC,SELFFRAC,INDSELF,PFRAC)
129
130!     Written by Eli J. Mlawer, Atmospheric & Environmental Research.
131!     Revised by Michael J. Iacono, Atmospheric & Environmental Research.
132
133!     BAND 1:  10-250 cm-1 (low - H2O; high - H2O)
134 
135! Modifications
136!
137!     D Salmond   2000-05-15 speed-up
138!     JJMorcrette 2000-05-17 speed-up
139
140
141#include "tsmbkind.h"
142
143USE PARRRTM  , ONLY : JPLAY  ,JPBAND ,JPGPT  ,JPXSEC
144USE YOERRTWN , ONLY : NG     ,NSPA   ,NSPB
145USE YOERRTA1 , ONLY : NG1    ,ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
146            &FORREF   ,KA     ,KB     ,SELFREF
147
148!#include "yoeratm.h"
149
150!      REAL TAUAER(JPLAY)
151
152IMPLICIT NONE
153
154!  Output
155REAL_B :: TAU   (JPGPT,JPLAY)
156
157!     DUMMY INTEGER SCALARS
158INTEGER_M :: KLEV
159
160!- from AER
161REAL_B :: TAUAERL(JPLAY,JPBAND)
162
163!- from INTFAC     
164REAL_B :: FAC00(JPLAY)
165REAL_B :: FAC01(JPLAY)
166REAL_B :: FAC10(JPLAY)
167REAL_B :: FAC11(JPLAY)
168REAL_B :: FORFAC(JPLAY)
169
170!- from INTIND
171INTEGER_M :: JP(JPLAY)
172INTEGER_M :: JT(JPLAY)
173INTEGER_M :: JT1(JPLAY)
174
175!- from PRECISE             
176REAL_B :: ONEMINUS
177
178!- from PROFDATA             
179REAL_B :: COLH2O(JPLAY)
180INTEGER_M :: LAYTROP
181
182!- from SELF             
183REAL_B :: SELFFAC(JPLAY)
184REAL_B :: SELFFRAC(JPLAY)
185INTEGER_M :: INDSELF(JPLAY)
186
187!- from SP             
188REAL_B :: PFRAC(JPGPT,JPLAY)
189
190INTEGER_M :: IND0(JPLAY),IND1(JPLAY),INDS(JPLAY)
191
192!     LOCAL INTEGER SCALARS
193INTEGER_M :: IG, LAY
194
195!      EQUIVALENCE (TAUAERL(1,1),TAUAER)
196
197!     Compute the optical depth by interpolating in ln(pressure) and
198!     temperature.  Below LAYTROP, the water vapor self-continuum
199!     is interpolated (in temperature) separately. 
200
201DO LAY = 1, LAYTROP
202  IND0(LAY) = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(1) + 1
203  IND1(LAY) = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(1) + 1
204  INDS(LAY) = INDSELF(LAY)
205ENDDO
206
207DO IG = 1, NG1
208  DO LAY = 1, LAYTROP
209!-- DS_000515 
210    TAU (IG,LAY) = COLH2O(LAY) *&
211     &(FAC00(LAY) * ABSA(IND0(LAY)  ,IG) +&
212     & FAC10(LAY) * ABSA(IND0(LAY)+1,IG) +&
213     & FAC01(LAY) * ABSA(IND1(LAY)  ,IG) +&
214     & FAC11(LAY) * ABSA(IND1(LAY)+1,IG) +&
215     &SELFFAC(LAY) * (SELFREF(INDS(LAY),IG) + &
216     &SELFFRAC(LAY) *&
217     &(SELFREF(INDS(LAY)+1,IG) - SELFREF(INDS(LAY),IG)))&
218     &+ FORFAC(LAY) * FORREF(IG) ) &
219     &+ TAUAERL(LAY,1)
220    PFRAC(IG,LAY) = FRACREFA(IG)
221  ENDDO
222ENDDO
223
224DO LAY = LAYTROP+1, KLEV
225  IND0(LAY) = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(1) + 1
226  IND1(LAY) = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(1) + 1
227ENDDO
228
229!-- JJM000517
230DO IG = 1, NG1
231  DO LAY = LAYTROP+1, KLEV
232!-- JJM000517
233    TAU (IG,LAY) = COLH2O(LAY) *&
234     &(FAC00(LAY) * ABSB(IND0(LAY)  ,IG) +&
235     & FAC10(LAY) * ABSB(IND0(LAY)+1,IG) +&
236     & FAC01(LAY) * ABSB(IND1(LAY)  ,IG) +&
237     & FAC11(LAY) * ABSB(IND1(LAY)+1,IG)&
238     &+ FORFAC(LAY) * FORREF(IG) ) &
239     &+ TAUAERL(LAY,1)
240    PFRAC(IG,LAY) = FRACREFB(IG)
241  ENDDO
242ENDDO
243
244RETURN
245END SUBROUTINE RRTM_TAUMOL1
Note: See TracBrowser for help on using the repository browser.