source: LMDZ6/branches/IPSLCM6.0.13/libf/phylmd/rrtm/rrtm_taumol3.F90 @ 4249

Last change on this file since 4249 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: 8.3 KB
Line 
1!----------------------------------------------------------------------------
2SUBROUTINE RRTM_TAUMOL3 (KLEV,P_TAU,&
3 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,P_ONEMINUS,&
4 & P_COLH2O,P_COLCO2,P_COLN2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
5
6!     BAND 3:  500-630 cm-1 (low - H2O,CO2; high - H2O,CO2)
7
8! Modifications
9!        M.Hamrud      01-Oct-2003 CY28 Cleaning
10
11!     D Salmond 2000-05-15 speed-up
12
13USE PARKIND1  ,ONLY : JPIM     ,JPRB
14USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
15
16USE PARRRTM  , ONLY : JPLAY  ,JPBAND ,JPGPT  ,NG3   ,NGS2
17USE YOERRTWN , ONLY :      NSPA   ,NSPB
18USE YOERRTA3 , ONLY : ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
19 & FORREF   ,SELFREF , ABSN2OA ,&
20 & ABSN2OB  ,ETAREF ,H2OREF ,N2OREF  , CO2REF  ,&
21 & STRRAT 
22
23!  Input
24!#include "yoeratm.h"
25
26!      REAL TAUAER(JPLAY)
27
28IMPLICIT NONE
29
30!  Output
31INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
32REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAU(JPGPT,JPLAY)
33REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(JPLAY,JPBAND)
34REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(JPLAY)
35REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(JPLAY)
36REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(JPLAY)
37REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(JPLAY)
38REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(JPLAY)
39INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(JPLAY)
40INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(JPLAY)
41INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(JPLAY)
42REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS
43REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(JPLAY)
44REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCO2(JPLAY)
45REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLN2O(JPLAY)
46INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP
47REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(JPLAY)
48REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(JPLAY)
49INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(JPLAY)
50REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(JPGPT,JPLAY)
51!- from AER
52!- from INTFAC     
53!- from INTIND
54!- from PRECISE             
55!- from PROFDATA             
56!- from SELF             
57!- from SP             
58INTEGER(KIND=JPIM) :: IJS(JPLAY)
59REAL(KIND=JPRB) :: ZFS(JPLAY),Z_SPECCOMB(JPLAY)
60INTEGER(KIND=JPIM) :: IND0(JPLAY),IND1(JPLAY),INDS(JPLAY)
61REAL(KIND=JPRB) :: Z_N2OMULT(JPLAY)
62
63INTEGER(KIND=JPIM) :: IG, JS, I_LAY, I_NS
64
65REAL(KIND=JPRB) :: Z_COLREF1, Z_COLREF2, Z_CURRN2O, Z_FAC000, Z_FAC001,&
66 & Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101, Z_FAC110, Z_FAC111, &
67 & Z_FP, Z_FS, Z_RATIO, Z_SPECMULT, Z_SPECPARM, Z_WCOMB1, &
68 & Z_WCOMB2 
69REAL(KIND=JPRB) :: ZHOOK_HANDLE
70
71!      EQUIVALENCE (TAUAERL(1,3),TAUAER)
72
73!     Compute the optical depth by interpolating in ln(pressure),
74!     temperature, and appropriate species.  Below LAYTROP, the water
75!     vapor self-continuum is interpolated (in temperature) separately. 
76
77IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL3',0,ZHOOK_HANDLE)
78DO I_LAY = 1, K_LAYTROP
79  Z_SPECCOMB(I_LAY) = P_COLH2O(I_LAY) + STRRAT*P_COLCO2(I_LAY)
80  Z_SPECPARM = P_COLH2O(I_LAY)/Z_SPECCOMB(I_LAY)
81  Z_SPECPARM=MIN(P_ONEMINUS,Z_SPECPARM)
82  Z_SPECMULT = 8._JPRB*(Z_SPECPARM)
83  JS = 1 + INT(Z_SPECMULT)
84  Z_FS = MOD(Z_SPECMULT,1.0_JPRB)
85  IF (JS  ==  8) THEN
86    IF (Z_FS  >=  0.9_JPRB) THEN
87      JS = 9
88      Z_FS = 10._JPRB * (Z_FS - 0.9_JPRB)
89    ELSE
90      Z_FS = Z_FS/0.9_JPRB
91    ENDIF
92  ENDIF
93
94  I_NS = JS + INT(Z_FS + 0.5_JPRB)
95  Z_FP = P_FAC01(I_LAY) + P_FAC11(I_LAY)
96  IND0(I_LAY) = ((K_JP(I_LAY)-1)*5+(K_JT(I_LAY)-1))*NSPA(3) + JS
97  IND1(I_LAY) = (K_JP(I_LAY)*5+(K_JT1(I_LAY)-1))*NSPA(3) + JS
98  INDS(I_LAY) = K_INDSELF(I_LAY)
99  Z_COLREF1 = N2OREF(K_JP(I_LAY))
100  Z_COLREF2 = N2OREF(K_JP(I_LAY)+1)
101  IF (I_NS  ==  10) THEN
102    Z_WCOMB1 = 1.0_JPRB/H2OREF(K_JP(I_LAY))
103    Z_WCOMB2 = 1.0_JPRB/H2OREF(K_JP(I_LAY)+1)
104  ELSE
105    Z_WCOMB1 = (1.0_JPRB-ETAREF(I_NS))/(STRRAT * CO2REF(K_JP(I_LAY)))
106    Z_WCOMB2 = (1.0_JPRB-ETAREF(I_NS))/(STRRAT * CO2REF(K_JP(I_LAY)+1))
107  ENDIF
108  Z_RATIO = (Z_COLREF1*Z_WCOMB1)+Z_FP*((Z_COLREF2*Z_WCOMB2)-(Z_COLREF1*Z_WCOMB1))
109  Z_CURRN2O = Z_SPECCOMB(I_LAY) * Z_RATIO
110  Z_N2OMULT(I_LAY) = P_COLN2O(I_LAY) - Z_CURRN2O
111
112  ZFS(I_LAY)=Z_FS
113  IJS(I_LAY)=JS
114
115ENDDO
116
117!-- DS_000515
118DO IG = 1, NG3
119  DO I_LAY = 1, K_LAYTROP
120!-- DS_000515
121
122    Z_FS=ZFS(I_LAY)
123    JS=IJS(I_LAY)
124
125!---jjm
126!    FAC000 = (_ONE_ - FS) * FAC00(LAY)
127!    FAC010 = (_ONE_ - FS) * FAC10(LAY)
128!    FAC100 = FS * FAC00(LAY)
129!    FAC110 = FS * FAC10(LAY)
130!    FAC001 = (_ONE_ - FS) * FAC01(LAY)
131!    FAC011 = (_ONE_ - FS) * FAC11(LAY)
132!    FAC101 = FS * FAC01(LAY)
133!    FAC111 = FS * FAC11(LAY)
134!------       
135
136    P_TAU (NGS2+IG,I_LAY) = Z_SPECCOMB(I_LAY) *   &
137     !-- DS_000515
138     & ( (1. - Z_FS) *(P_FAC00(I_LAY) * ABSA(IND0(I_LAY)   ,IG) +   &
139     & P_FAC10(I_LAY) * ABSA(IND0(I_LAY)+10,IG) +   &
140     & P_FAC01(I_LAY) * ABSA(IND1(I_LAY)   ,IG) +   &
141     & P_FAC11(I_LAY) * ABSA(IND1(I_LAY)+10,IG))+   &
142     & Z_FS     *(P_FAC00(I_LAY) * ABSA(IND0(I_LAY)+ 1,IG) +   &
143     & P_FAC10(I_LAY) * ABSA(IND0(I_LAY)+11,IG) +   &
144     & P_FAC01(I_LAY) * ABSA(IND1(I_LAY)+ 1,IG) +   &
145     & P_FAC11(I_LAY) * ABSA(IND1(I_LAY)+11,IG))) + &
146     !     &(Z_FAC000 * ABSA(IND0(I_LAY)   ,IG) +&
147     !     & Z_FAC100 * ABSA(IND0(I_LAY)+ 1,IG) +&
148     !     & Z_FAC010 * ABSA(IND0(I_LAY)+10,IG) +&
149     !     & Z_FAC110 * ABSA(IND0(I_LAY)+11,IG) +&
150     !     & Z_FAC001 * ABSA(IND1(I_LAY),   IG) +&
151     !     & Z_FAC101 * ABSA(IND1(I_LAY)+ 1,IG) +&
152     !     & Z_FAC011 * ABSA(IND1(I_LAY)+10,IG) +&
153     !     & Z_FAC111 * ABSA(IND1(I_LAY)+11,IG))+&
154     !-- DS_000515
155     & P_COLH2O(I_LAY) * &
156     & P_SELFFAC(I_LAY) * (SELFREF(INDS(I_LAY),IG) + &
157     & P_SELFFRAC(I_LAY) *&
158     & (SELFREF(INDS(I_LAY)+1,IG) - SELFREF(INDS(I_LAY),IG))&
159     & + P_FORFAC(I_LAY) * FORREF(IG) ) &
160     & + Z_N2OMULT(I_LAY) * ABSN2OA(IG) &
161     & + P_TAUAERL(I_LAY,3) 
162    PFRAC(NGS2+IG,I_LAY) = FRACREFA(IG,JS) + Z_FS *&
163     & (FRACREFA(IG,JS+1) - FRACREFA(IG,JS)) 
164  ENDDO
165ENDDO
166
167DO I_LAY = K_LAYTROP+1, KLEV
168  Z_SPECCOMB(I_LAY) = P_COLH2O(I_LAY) + STRRAT*P_COLCO2(I_LAY)
169  Z_SPECPARM = P_COLH2O(I_LAY)/Z_SPECCOMB(I_LAY)
170  Z_SPECPARM=MIN(P_ONEMINUS,Z_SPECPARM)
171  Z_SPECMULT = 4._JPRB*(Z_SPECPARM)
172  JS = 1 + INT(Z_SPECMULT)
173  Z_FS = MOD(Z_SPECMULT,1.0_JPRB)
174  I_NS = JS + INT(Z_FS + 0.5_JPRB)
175  Z_FP = P_FAC01(I_LAY) + P_FAC11(I_LAY)
176  IND0(I_LAY) = ((K_JP(I_LAY)-13)*5+(K_JT(I_LAY)-1))*NSPB(3) + JS
177  IND1(I_LAY) = ((K_JP(I_LAY)-12)*5+(K_JT1(I_LAY)-1))*NSPB(3) + JS
178  Z_COLREF1 = N2OREF(K_JP(I_LAY))
179  Z_COLREF2 = N2OREF(K_JP(I_LAY)+1)
180  IF (I_NS  ==  5) THEN
181    Z_WCOMB1 = 1.0_JPRB/H2OREF(K_JP(I_LAY))
182    Z_WCOMB2 = 1.0_JPRB/H2OREF(K_JP(I_LAY)+1)
183  ELSE
184    Z_WCOMB1 = (1.0_JPRB-ETAREF(I_NS))/(STRRAT * CO2REF(K_JP(I_LAY)))
185    Z_WCOMB2 = (1.0_JPRB-ETAREF(I_NS))/(STRRAT * CO2REF(K_JP(I_LAY)+1))
186  ENDIF
187  Z_RATIO = (Z_COLREF1*Z_WCOMB1)+Z_FP*((Z_COLREF2*Z_WCOMB2)-(Z_COLREF1*Z_WCOMB1))
188  Z_CURRN2O = Z_SPECCOMB(I_LAY) * Z_RATIO
189  Z_N2OMULT(I_LAY) = P_COLN2O(I_LAY) - Z_CURRN2O
190
191  ZFS(I_LAY)=Z_FS
192  IJS(I_LAY)=JS
193
194ENDDO
195
196DO I_LAY = K_LAYTROP+1, KLEV
197
198  Z_FS=ZFS(I_LAY)
199  JS=IJS(I_LAY)
200!---jjm
201!  FAC000 = (_ONE_ - FS) * FAC00(LAY)
202!  FAC010 = (_ONE_ - FS) * FAC10(LAY)
203!  FAC100 = FS * FAC00(LAY)
204!  FAC110 = FS * FAC10(LAY)
205!  FAC001 = (_ONE_ - FS) * FAC01(LAY)
206!  FAC011 = (_ONE_ - FS) * FAC11(LAY)
207!  FAC101 = FS * FAC01(LAY)
208!  FAC111 = FS * FAC11(LAY)
209!---       
210
211  DO IG = 1, NG3
212    P_TAU (NGS2+IG,I_LAY) = Z_SPECCOMB(I_LAY) *   &
213     !-- DS_000515
214     & ( (1. - Z_FS) *(P_FAC00(I_LAY) * ABSB(IND0(I_LAY)  ,IG) +   &
215     & P_FAC10(I_LAY) * ABSB(IND0(I_LAY)+5,IG) +   &
216     & P_FAC01(I_LAY) * ABSB(IND1(I_LAY)  ,IG) +    &
217     & P_FAC11(I_LAY) * ABSB(IND1(I_LAY)+5,IG))+   &
218     & Z_FS     *(P_FAC00(I_LAY) * ABSB(IND0(I_LAY)+1,IG) +   &
219     & P_FAC10(I_LAY) * ABSB(IND0(I_LAY)+6,IG) +   &
220     & P_FAC01(I_LAY) * ABSB(IND1(I_LAY)+1,IG) +   &
221     & P_FAC11(I_LAY) * ABSB(IND1(I_LAY)+6,IG)))   &
222     !     &(Z_FAC000 * ABSB(IND0(I_LAY)  ,IG) +&
223     !     & Z_FAC100 * ABSB(IND0(I_LAY)+1,IG) +&
224     !     & Z_FAC010 * ABSB(IND0(I_LAY)+5,IG) +&
225     !     & Z_FAC110 * ABSB(IND0(I_LAY)+6,IG) +&
226     !     & Z_FAC001 * ABSB(IND1(I_LAY)  ,IG) +&
227     !     & Z_FAC101 * ABSB(IND1(I_LAY)+1,IG) +&
228     !     & Z_FAC011 * ABSB(IND1(I_LAY)+5,IG) +&
229     !     & Z_FAC111 * ABSB(IND1(I_LAY)+6,IG))&
230     !-- DS_000515
231     & + P_COLH2O(I_LAY)*P_FORFAC(I_LAY)*FORREF(IG) &
232     & + Z_N2OMULT(I_LAY) * ABSN2OB(IG)&
233     & + P_TAUAERL(I_LAY,3) 
234    PFRAC(NGS2+IG,I_LAY) = FRACREFB(IG,JS) + Z_FS *&
235     & (FRACREFB(IG,JS+1) - FRACREFB(IG,JS)) 
236  ENDDO
237ENDDO
238
239IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL3',1,ZHOOK_HANDLE)
240END SUBROUTINE RRTM_TAUMOL3
Note: See TracBrowser for help on using the repository browser.