source: LMDZ5/trunk/libf/phymar/rrtm_cmbgb11.F90 @ 3373

Last change on this file since 3373 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
RevLine 
[2089]1!***************************************************************************
2SUBROUTINE RRTM_CMBGB11
3!***************************************************************************
4
5!     BAND 11:  1480-1800 cm-1 (low - H2O; high - H2O)
6!***************************************************************************
7
8! Parameters
9#include "tsmbkind.h"
10
11USE PARRRTM  , ONLY : JPBAND   ,JPG      ,JPXSEC   ,JPGPT
12
13USE YOERRTO11, ONLY : KAO     ,KBO     ,SELFREFO    ,FRACREFAO ,FRACREFBO
14USE YOERRTA11, ONLY : KA      ,KB      ,SELFREF     ,FRACREFA  ,FRACREFB   &
15             &      , ABSA    ,ABSB    ,NG11
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(11)
33      SUMK = _ZERO_
34      DO IPR = 1, NGN(NGS(10)+IGC)
35        IPRSM = IPRSM + 1
36
37        SUMK = SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+160)
38      ENDDO
39
40      KA(JT,JP,IGC) = SUMK
41    ENDDO
42  ENDDO
43ENDDO
44DO JT = 1,5
45  DO JP = 13,59
46    IPRSM = 0
47    DO IGC = 1,NGC(11)
48      SUMK = _ZERO_
49      DO IPR = 1, NGN(NGS(10)+IGC)
50        IPRSM = IPRSM + 1
51
52        SUMK = SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+160)
53      ENDDO
54
55      KB(JT,JP,IGC) = SUMK
56    ENDDO
57  ENDDO
58ENDDO
59
60DO JT = 1,10
61  IPRSM = 0
62  DO IGC = 1,NGC(11)
63    SUMK = _ZERO_
64    DO IPR = 1, NGN(NGS(10)+IGC)
65      IPRSM = IPRSM + 1
66
67      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+160)
68    ENDDO
69
70    SELFREF(JT,IGC) = SUMK
71  ENDDO
72ENDDO
73
74IPRSM = 0
75DO IGC = 1,NGC(11)
76  SUMF1= _ZERO_
77  SUMF2= _ZERO_
78  DO IPR = 1, NGN(NGS(10)+IGC)
79    IPRSM = IPRSM + 1
80
81
82    SUMF1= SUMF1+ FRACREFAO(IPRSM)
83    SUMF2= SUMF2+ FRACREFBO(IPRSM)
84  ENDDO
85
86
87  FRACREFA(IGC) = SUMF1
88  FRACREFB(IGC) = SUMF2
89ENDDO
90
91DO IGC = 1,NGC(11)
92
93
94  FREFA(NGS(10)+IGC,1) = FRACREFA(IGC)
95  FREFB(NGS(10)+IGC,1) = FRACREFB(IGC)
96ENDDO
97
98
99! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
100! +  ============================
101
102! +--ABSA
103! +  ^^^^
104         JT  = 0
105         JP  = 1
106         IGC = 1
107      DO NEQ=1,NG11
108      DO MEQ=1,65
109             JT =  JT  + 1
110       IF  ( JT == 5   + 1 )                                        THEN
111             JT =  1
112             JP =  JP  + 1
113        IF ( JP == 13  + 1 )                                        THEN
114             JP =  1
115             IGC=  IGC + 1
116        END IF
117       END IF
118             ABSA(MEQ,NEQ) = KA(JT,JP,IGC)
119      ENDDO
120      ENDDO
121
122! +--ABSB
123! +  ^^^^
124         JT  = 0
125         JP  = 13
126         IGC = 1
127      DO NEQ=1,NG11
128      DO MEQ=1,235
129             JT =  JT  + 1
130       IF  ( JT == 5   + 1 )                                        THEN
131             JT =  1
132             JP =  JP  + 1
133        IF ( JP == 59  + 1 )                                        THEN
134             JP =  13
135             IGC=  IGC + 1
136        END IF
137       END IF
138             ABSB(MEQ,NEQ) = KB(JT,JP,IGC)
139      ENDDO
140      ENDDO
141
142! +--Force the equivalence: END   (HG, 13-DEC-2003)
143! +  ==========================
144
145
146RETURN
147END SUBROUTINE RRTM_CMBGB11
Note: See TracBrowser for help on using the repository browser.