source: LMDZ6/branches/DYNAMICO-conv/libf/phymar/rrtm_cmbgb14.F90 @ 3106

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

Inclusion de la physique de MAR


Integration of MAR physics

File size: 3.2 KB
Line 
1!***************************************************************************
2SUBROUTINE RRTM_CMBGB14
3!***************************************************************************
4
5!     BAND 14:  2250-2380 cm-1 (low - CO2; high - CO2)
6!***************************************************************************
7
8! Parameters
9#include "tsmbkind.h"
10
11USE PARRRTM  , ONLY : JPBAND   ,JPG      ,JPXSEC   ,JPGPT
12
13USE YOERRTO14, ONLY : KAO     ,KBO     ,SELFREFO   ,FRACREFAO  ,FRACREFBO
14USE YOERRTA14, ONLY : KA      ,KB      ,SELFREF    ,FRACREFA   ,FRACREFB   &
15             &      , ABSA    ,ABSB    ,NG14
16USE YOERRTRWT, ONLY : FREFA    ,FREFB    ,FREFADF  ,FREFBDF   ,RWGT
17USE YOERRTFTR, ONLY : NGC      ,NGS      ,NGN      ,NGB       ,NGM     , WT
18
19IMPLICIT NONE
20
21!     LOCAL INTEGER SCALARS
22INTEGER_M :: IGC, IPR, IPRSM, JP, JT
23INTEGER_M :: MEQ, NEQ                ! To force equivalence, HG, 13-DEC-2003
24
25!     LOCAL REAL SCALARS
26REAL_B :: SUMF1, SUMF2, SUMK
27
28
29DO JT = 1,5
30  DO JP = 1,13
31    IPRSM = 0
32    DO IGC = 1,NGC(14)
33      SUMK = _ZERO_
34      DO IPR = 1, NGN(NGS(13)+IGC)
35        IPRSM = IPRSM + 1
36
37        SUMK = SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+208)
38      ENDDO
39
40      KA(JT,JP,IGC) = SUMK
41    ENDDO
42  ENDDO
43ENDDO
44
45DO JT = 1,5
46  DO JP = 13,59
47    IPRSM = 0
48    DO IGC = 1,NGC(14)
49      SUMK = _ZERO_
50      DO IPR = 1, NGN(NGS(13)+IGC)
51        IPRSM = IPRSM + 1
52
53        SUMK = SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+208)
54      ENDDO
55
56      KB(JT,JP,IGC) = SUMK
57    ENDDO
58  ENDDO
59ENDDO
60
61DO JT = 1,10
62  IPRSM = 0
63  DO IGC = 1,NGC(14)
64    SUMK = _ZERO_
65    DO IPR = 1, NGN(NGS(13)+IGC)
66      IPRSM = IPRSM + 1
67
68      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+208)
69    ENDDO
70
71    SELFREF(JT,IGC) = SUMK
72  ENDDO
73ENDDO
74
75IPRSM = 0
76DO IGC = 1,NGC(14)
77  SUMF1= _ZERO_
78  SUMF2= _ZERO_
79  DO IPR = 1, NGN(NGS(13)+IGC)
80    IPRSM = IPRSM + 1
81
82
83    SUMF1= SUMF1+ FRACREFAO(IPRSM)
84    SUMF2= SUMF2+ FRACREFBO(IPRSM)
85  ENDDO
86
87
88  FRACREFA(IGC) = SUMF1
89  FRACREFB(IGC) = SUMF2
90ENDDO
91
92DO IGC = 1,NGC(14)
93
94
95  FREFA(NGS(13)+IGC,1) = FRACREFA(IGC)
96  FREFB(NGS(13)+IGC,1) = FRACREFB(IGC)
97ENDDO
98
99
100! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
101! +  ============================
102
103! +--ABSA
104! +  ^^^^
105         JT  = 0
106         JP  = 1
107         IGC = 1
108      DO NEQ=1,NG14
109      DO MEQ=1,65
110             JT =  JT  + 1
111       IF  ( JT == 5   + 1 )                                        THEN
112             JT =  1
113             JP =  JP  + 1
114        IF ( JP == 13  + 1 )                                        THEN
115             JP =  1
116             IGC=  IGC + 1
117        END IF
118       END IF
119             ABSA(MEQ,NEQ) = KA(JT,JP,IGC)
120      ENDDO
121      ENDDO
122
123! +--ABSB
124! +  ^^^^
125         JT  = 0
126         JP  = 13
127         IGC = 1
128      DO NEQ=1,NG14
129      DO MEQ=1,235
130             JT =  JT  + 1
131       IF  ( JT == 5   + 1 )                                        THEN
132             JT =  1
133             JP =  JP  + 1
134        IF ( JP == 59  + 1 )                                        THEN
135             JP =  13
136             IGC=  IGC + 1
137        END IF
138       END IF
139             ABSB(MEQ,NEQ) = KB(JT,JP,IGC)
140      ENDDO
141      ENDDO
142
143! +--Force the equivalence: END   (HG, 13-DEC-2003)
144! +  ==========================
145
146
147RETURN
148END SUBROUTINE RRTM_CMBGB14
Note: See TracBrowser for help on using the repository browser.