source: LMDZ5/branches/testing/libf/phymar/rrtm_taumol4.F90 @ 3525

Last change on this file since 3525 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: 5.7 KB
RevLine 
[2089]1!----------------------------------------------------------------------------
2SUBROUTINE RRTM_TAUMOL4 (KLEV,TAU,&
3  &TAUAERL,FAC00,FAC01,FAC10,FAC11,FORFAC,JP,JT,JT1,ONEMINUS,&
4  &COLH2O,COLCO2,COLO3,LAYTROP,SELFFAC,SELFFRAC,INDSELF,PFRAC)
5
6!     BAND 4:  630-700 cm-1 (low - H2O,CO2; high - O3,CO2)
7
8! Modifications
9!
10!     D Salmond 2000-05-15 speed-up
11
12
13#include "tsmbkind.h"
14
15USE PARRRTM  , ONLY : JPLAY  ,JPBAND ,JPGPT  ,JPXSEC  , NGS3
16USE YOERRTWN , ONLY : NG     ,NSPA   ,NSPB
17USE YOERRTA4 , ONLY : NG4    ,ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
18            &KA       ,KB     ,SELFREF,STRRAT1 , STRRAT2
19
20!  Input
21!#include "yoeratm.h"
22
23!      REAL TAUAER(JPLAY)
24
25
26IMPLICIT NONE
27
28!  Output
29REAL_B :: TAU   (JPGPT,JPLAY)
30
31!     DUMMY INTEGER SCALARS
32INTEGER_M :: KLEV
33
34!- from AER
35REAL_B :: TAUAERL(JPLAY,JPBAND)
36
37!- from INTFAC     
38REAL_B :: FAC00(JPLAY)
39REAL_B :: FAC01(JPLAY)
40REAL_B :: FAC10(JPLAY)
41REAL_B :: FAC11(JPLAY)
42REAL_B :: FORFAC(JPLAY)
43
44!- from INTIND
45INTEGER_M :: JP(JPLAY)
46INTEGER_M :: JT(JPLAY)
47INTEGER_M :: JT1(JPLAY)
48
49!- from PRECISE             
50REAL_B :: ONEMINUS
51
52!- from PROFDATA             
53REAL_B :: COLH2O(JPLAY)
54REAL_B :: COLCO2(JPLAY)
55REAL_B :: COLO3 (JPLAY)
56INTEGER_M :: LAYTROP
57
58!- from SELF             
59REAL_B :: SELFFAC(JPLAY)
60REAL_B :: SELFFRAC(JPLAY)
61INTEGER_M :: INDSELF(JPLAY)
62
63!- from SP             
64REAL_B :: PFRAC(JPGPT,JPLAY)
65
66INTEGER_M :: IJS(JPLAY)
67REAL_B :: ZFS(JPLAY),SPECCOMB(JPLAY)
68INTEGER_M :: IND0(JPLAY),IND1(JPLAY),INDS(JPLAY)
69
70!     LOCAL INTEGER SCALARS
71INTEGER_M :: IG, JS, LAY
72
73!     LOCAL REAL SCALARS
74REAL_B :: FAC000, FAC001, FAC010, FAC011, FAC100, FAC101,&
75          &FAC110, FAC111, FS, SPECMULT, SPECPARM
76
77!      EQUIVALENCE (TAUAERL(1,4),TAUAER)
78
79!     Compute the optical depth by interpolating in ln(pressure),
80!     temperature, and appropriate species.  Below LAYTROP, the water
81!     vapor self-continuum is interpolated (in temperature) separately.
82 
83DO LAY = 1, LAYTROP
84  SPECCOMB(LAY) = COLH2O(LAY) + STRRAT1*COLCO2(LAY)
85  SPECPARM = COLH2O(LAY)/SPECCOMB(LAY)
86  SPECPARM=MIN(ONEMINUS,SPECPARM)
87  SPECMULT = 8._JPRB*(SPECPARM)
88  JS = 1 + INT(SPECMULT)
89  FS = MOD(SPECMULT,_ONE_)
90  IND0(LAY) = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(4) + JS
91  IND1(LAY) = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(4) + JS
92  INDS(LAY) = INDSELF(LAY)
93
94  ZFS(LAY)=FS
95  IJS(LAY)=JS
96
97ENDDO
98
99!-- DS_000515
100DO IG = 1, NG4
101  DO LAY = 1, LAYTROP
102!-- DS_000515
103
104    FS=ZFS(LAY)
105    JS=IJS(LAY)
106!--jjm         
107!    FAC000 = (_ONE_ - FS) * FAC00(LAY)
108!    FAC010 = (_ONE_ - FS) * FAC10(LAY)
109!    FAC100 = FS * FAC00(LAY)
110!    FAC110 = FS * FAC10(LAY)
111!    FAC001 = (_ONE_ - FS) * FAC01(LAY)
112!    FAC011 = (_ONE_ - FS) * FAC11(LAY)
113!    FAC101 = FS * FAC01(LAY)
114!    FAC111 = FS * FAC11(LAY)
115!---
116
117    TAU (NGS3+IG,LAY) = SPECCOMB(LAY) *   &
118!-- DS_000515
119     &((1. - FS) *(FAC00(LAY) * ABSA(IND0(LAY)   ,IG) +   &
120     &             FAC10(LAY) * ABSA(IND0(LAY)+ 9,IG) +   &
121     &             FAC01(LAY) * ABSA(IND1(LAY)   ,IG) +   &
122     &             FAC11(LAY) * ABSA(IND1(LAY)+ 9,IG))+   &
123     &    FS     *(FAC00(LAY) * ABSA(IND0(LAY)+ 1,IG) +   &
124     &             FAC10(LAY) * ABSA(IND0(LAY)+10,IG) +   &
125     &             FAC01(LAY) * ABSA(IND1(LAY)+ 1,IG) +   &
126     &             FAC11(LAY) * ABSA(IND1(LAY)+10,IG))) + &
127!     &(FAC000 * ABSA(IND0(LAY)   ,IG) +&
128!     & FAC100 * ABSA(IND0(LAY)+ 1,IG) +&
129!     & FAC010 * ABSA(IND0(LAY)+ 9,IG) +&
130!     & FAC110 * ABSA(IND0(LAY)+10,IG) +&
131!     & FAC001 * ABSA(IND1(LAY)   ,IG) +&
132!     & FAC101 * ABSA(IND1(LAY)+ 1,IG) +&
133!     & FAC011 * ABSA(IND1(LAY)+ 9,IG) +&
134!     & FAC111 * ABSA(IND1(LAY)+10,IG))+&
135!-- DS_000515
136     &COLH2O(LAY) * &
137     &SELFFAC(LAY) * (SELFREF(INDS(LAY),IG) + &
138     &SELFFRAC(LAY) *&
139     &(SELFREF(INDS(LAY)+1,IG) - SELFREF(INDS(LAY),IG)))&
140     &+ TAUAERL(LAY,4)
141    PFRAC(NGS3+IG,LAY) = FRACREFA(IG,JS) + FS *&
142     &(FRACREFA(IG,JS+1) - FRACREFA(IG,JS))
143  ENDDO
144ENDDO
145
146DO LAY = LAYTROP+1, KLEV
147  SPECCOMB(LAY) = COLO3(LAY) + STRRAT2*COLCO2(LAY)
148  SPECPARM = COLO3(LAY)/SPECCOMB(LAY)
149  SPECPARM=MIN(ONEMINUS,SPECPARM)
150  SPECMULT = 4._JPRB*(SPECPARM)
151  JS = 1 + INT(SPECMULT)
152  FS = MOD(SPECMULT,_ONE_)
153  IF (JS  >  1) THEN
154    JS = JS + 1
155  ELSEIF (FS  >=  0.0024_JPRB) THEN
156    JS = 2
157    FS = (FS - 0.0024_JPRB)/0.9976_JPRB
158  ELSE
159    JS = 1
160    FS = FS/0.0024_JPRB
161  ENDIF
162  IND0(LAY) = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(4) + JS
163  IND1(LAY) = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(4) + JS
164  ZFS(LAY)=FS
165  IJS(LAY)=JS
166ENDDO
167
168DO LAY = LAYTROP+1, KLEV
169  FS=ZFS(LAY)
170  JS=IJS(LAY)
171!--- jjm
172!  FAC000 = (_ONE_ - FS) * FAC00(LAY)
173!  FAC010 = (_ONE_ - FS) * FAC10(LAY)
174!  FAC100 = FS * FAC00(LAY)
175!  FAC110 = FS * FAC10(LAY)
176!  FAC001 = (_ONE_ - FS) * FAC01(LAY)
177!  FAC011 = (_ONE_ - FS) * FAC11(LAY)
178!  FAC101 = FS * FAC01(LAY)
179!  FAC111 = FS * FAC11(LAY)
180!------                   
181  DO IG = 1, NG4
182    TAU (NGS3+IG,LAY) = SPECCOMB(LAY) *   &
183!-- DS_000515
184     &( (1. - FS) *(FAC00(LAY) * ABSB(IND0(LAY)  ,IG) +   &
185     &              FAC10(LAY) * ABSB(IND0(LAY)+6,IG) +   &
186     &              FAC01(LAY) * ABSB(IND1(LAY)  ,IG) +   &
187     &              FAC11(LAY) * ABSB(IND1(LAY)+6,IG))+   &
188     &     FS     *(FAC00(LAY) * ABSB(IND0(LAY)+1,IG) +   &
189     &              FAC10(LAY) * ABSB(IND0(LAY)+7,IG) +   &
190     &              FAC01(LAY) * ABSB(IND1(LAY)+1,IG) +   &
191     &              FAC11(LAY) * ABSB(IND1(LAY)+7,IG)))   &
192!     &(FAC000 * ABSB(IND0(LAY)   ,IG) +&
193!     & FAC100 * ABSB(IND0(LAY)+ 1,IG) +&
194!     & FAC010 * ABSB(IND0(LAY)+ 6,IG) +&
195!     & FAC110 * ABSB(IND0(LAY)+ 7,IG) +&
196!     & FAC001 * ABSB(IND1(LAY)   ,IG) +&
197!     & FAC101 * ABSB(IND1(LAY)+ 1,IG) +&
198!     & FAC011 * ABSB(IND1(LAY)+ 6,IG) +&
199!     & FAC111 * ABSB(IND1(LAY)+ 7,IG))&
200!-- DS_000515
201     &+ TAUAERL(LAY,4)
202    PFRAC(NGS3+IG,LAY) = FRACREFB(IG,JS) + FS *&
203     &(FRACREFB(IG,JS+1) - FRACREFB(IG,JS))
204  ENDDO
205ENDDO
206
207RETURN
208END SUBROUTINE RRTM_TAUMOL4
Note: See TracBrowser for help on using the repository browser.