source: LMDZ6/branches/Optimisation_LMDZ/libf/phymar/rrtm_cmbgb1.F90 @ 5428

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

Inclusion de la physique de MAR


Integration of MAR physics

File size: 3.7 KB
Line 
1!***************************************************************************
2SUBROUTINE RRTM_CMBGB1
3!***************************************************************************
4
5!  The subroutines CMBGB1->CMBGB16 input the absorption coefficient
6!  data for each band, which are defined for 16 g-points and 16 spectral
7!  bands. The data are combined with appropriate weighting following the
8!  g-point mapping arrays specified in RRTMINIT.  Plank fraction data
9!  in arrays FRACREFA and FRACREFB are combined without weighting.  All
10!  g-point reduced data are put into new arrays for use in RRTM.
11
12!  BAND 1:  10-250 cm-1 (low - H2O; high - H2O)
13!***************************************************************************
14!  INSTRUCTION EQUIVALENCE SUPPRESSED (H. Gallée, LGGE, 15 décembre 2003)
15!***************************************************************************
16
17! Parameters
18#include "tsmbkind.h"
19
20USE PARRRTM  , ONLY : JPBAND   ,JPG      ,JPXSEC   ,JPGPT
21
22USE YOERRTO1 , ONLY : KAO , KBO  , SELFREFO, FORREFO, FRACREFAO,FRACREFBO
23USE YOERRTA1 , ONLY : KA  , KB   , SELFREF , FORREF , FRACREFA ,FRACREFB      &
24             &      , ABSA, ABSB , NG1
25USE YOERRTRWT, ONLY : FREFA    ,FREFB    ,FREFADF  ,FREFBDF   ,RWGT
26USE YOERRTFTR, ONLY : NGC      ,NGS      ,NGN      ,NGB       ,NGM     , WT
27
28IMPLICIT NONE
29
30!     LOCAL INTEGER SCALARS
31INTEGER_M :: IGC, IPR, IPRSM, JP, JT
32INTEGER_M :: MEQ, NEQ                    ! To force equivalence, HG, 13-DEC-2003
33
34!     LOCAL REAL SCALARS
35REAL_B :: SUMF1, SUMF2, SUMK
36
37
38DO JT = 1,5
39  DO JP = 1,13
40    IPRSM = 0
41    DO IGC = 1,NGC(1)
42      SUMK = _ZERO_
43      DO IPR = 1, NGN(IGC)
44        IPRSM = IPRSM + 1
45
46        SUMK = SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM)
47      ENDDO
48
49      KA(JT,JP,IGC) = SUMK
50    ENDDO
51  ENDDO
52  DO JP = 13,59
53    IPRSM = 0
54    DO IGC = 1,NGC(1)
55      SUMK = _ZERO_
56      DO IPR = 1, NGN(IGC)
57        IPRSM = IPRSM + 1
58
59        SUMK = SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM)
60      ENDDO
61
62      KB(JT,JP,IGC) = SUMK
63    ENDDO
64  ENDDO
65ENDDO
66
67DO JT = 1,10
68  IPRSM = 0
69  DO IGC = 1,NGC(1)
70    SUMK = _ZERO_
71    DO IPR = 1, NGN(IGC)
72      IPRSM = IPRSM + 1
73
74      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM)
75    ENDDO
76
77    SELFREF(JT,IGC) = SUMK
78  ENDDO
79ENDDO
80
81IPRSM = 0
82DO IGC = 1,NGC(1)
83  SUMK = _ZERO_
84  SUMF1 = _ZERO_
85  SUMF2 = _ZERO_
86  DO IPR = 1, NGN(IGC)
87    IPRSM = IPRSM + 1
88
89
90
91    SUMK = SUMK + FORREFO(IPRSM)*RWGT(IPRSM)
92    SUMF1= SUMF1+ FRACREFAO(IPRSM)
93    SUMF2= SUMF2+ FRACREFBO(IPRSM)
94  ENDDO
95
96
97
98  FORREF(IGC) = SUMK
99  FRACREFA(IGC) = SUMF1
100  FRACREFB(IGC) = SUMF2
101ENDDO
102
103DO IGC = 1,NGC(1)
104
105
106  FREFA(IGC,1) = FRACREFA(IGC)
107  FREFB(IGC,1) = FRACREFB(IGC)
108ENDDO
109
110
111! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
112! +  ============================
113
114! +--ABSA
115! +  ^^^^
116         JT  = 0
117         JP  = 1
118         IGC = 1
119      DO NEQ=1,NG1
120      DO MEQ=1,65
121             JT =  JT  + 1
122       IF  ( JT == 5   + 1 )                                        THEN
123             JT =  1
124             JP =  JP  + 1
125        IF ( JP == 13  + 1 )                                        THEN
126             JP =  1
127             IGC=  IGC + 1
128        END IF
129       END IF
130             ABSA(MEQ,NEQ) = KA(JT,JP,IGC)
131      ENDDO
132      ENDDO
133
134! +--ABSB
135! +  ^^^^
136         JT  = 0
137         JP  = 13
138         IGC = 1
139      DO NEQ=1,NG1
140      DO MEQ=1,235
141             JT =  JT  + 1
142       IF  ( JT == 5   + 1 )                                        THEN
143             JT =  1
144             JP =  JP  + 1
145        IF ( JP == 59  + 1 )                                        THEN
146             JP =  13
147             IGC=  IGC + 1
148        END IF
149       END IF
150             ABSB(MEQ,NEQ) = KB(JT,JP,IGC)
151      ENDDO
152      ENDDO
153
154! +--Force the equivalence: END   (HG, 13-DEC-2003)
155! +  ==========================
156
157
158RETURN
159END SUBROUTINE RRTM_CMBGB1
Note: See TracBrowser for help on using the repository browser.