source: LMDZ6/branches/DYNAMICO-conv/libf/phymar/rrtm_cmbgb16.F90 @ 5412

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

Inclusion de la physique de MAR


Integration of MAR physics

File size: 2.7 KB
Line 
1!***************************************************************************
2SUBROUTINE RRTM_CMBGB16
3!***************************************************************************
4
5!     BAND 16:  2600-3000 cm-1 (low - H2O,CH4; high - nothing)
6!***************************************************************************
7
8! Parameters
9#include "tsmbkind.h"
10
11USE PARRRTM  , ONLY : JPBAND   ,JPG      ,JPXSEC   ,JPGPT
12
13USE YOERRTO16, ONLY : KAO     ,SELFREFO   ,FRACREFAO
14USE YOERRTA16, ONLY : KA      ,SELFREF    ,FRACREFA                        &
15             &      , ABSA    ,NG16
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, JN, JP, JT
23INTEGER_M :: MEQ, NEQ                ! To force equivalence, HG, 13-DEC-2003
24
25!     LOCAL REAL SCALARS
26REAL_B :: SUMF, SUMK
27
28
29DO JN = 1,9
30  DO JT = 1,5
31    DO JP = 1,13
32      IPRSM = 0
33      DO IGC = 1,NGC(16)
34        SUMK = _ZERO_
35        DO IPR = 1, NGN(NGS(15)+IGC)
36          IPRSM = IPRSM + 1
37
38          SUMK = SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+240)
39        ENDDO
40
41        KA(JN,JT,JP,IGC) = SUMK
42      ENDDO
43    ENDDO
44  ENDDO
45ENDDO
46
47DO JT = 1,10
48  IPRSM = 0
49  DO IGC = 1,NGC(16)
50    SUMK = _ZERO_
51    DO IPR = 1, NGN(NGS(15)+IGC)
52      IPRSM = IPRSM + 1
53
54      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+240)
55    ENDDO
56
57    SELFREF(JT,IGC) = SUMK
58  ENDDO
59ENDDO
60
61DO JP = 1,9
62  IPRSM = 0
63  DO IGC = 1,NGC(16)
64    SUMF = _ZERO_
65    DO IPR = 1, NGN(NGS(15)+IGC)
66      IPRSM = IPRSM + 1
67
68      SUMF = SUMF + FRACREFAO(IPRSM,JP)
69    ENDDO
70
71    FRACREFA(IGC,JP) = SUMF
72  ENDDO
73ENDDO
74
75DO JP = 1,9
76  DO IGC = 1,NGC(16)
77
78    FREFA(NGS(15)+IGC,JP) = FRACREFA(IGC,JP)
79  ENDDO
80ENDDO
81
82DO JP = 1,8
83  DO IGC = 1,NGC(16)
84
85
86    FREFADF(NGS(15)+IGC,JP) = FRACREFA(IGC,JP+1) -FRACREFA(IGC,JP)
87  ENDDO
88ENDDO
89
90
91! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
92! +  ============================
93
94! +--ABSA
95! +  ^^^^
96         JN  = 0
97         JT  = 1
98         JP  = 1
99         IGC = 1
100      DO NEQ=1,NG16
101      DO MEQ=1,585
102             JN =  JN  + 1
103      IF   ( JN == 9   + 1)                                         THEN
104             JN =  1
105             JT =  JT  + 1
106       IF  ( JT == 5   + 1 )                                        THEN
107             JT =  1
108             JP =  JP  + 1
109        IF ( JP == 13  + 1 )                                        THEN
110             JP =  1
111             IGC=  IGC + 1
112        END IF
113       END IF
114      END IF
115             ABSA(MEQ,NEQ) = KA(JN,JT,JP,IGC)
116      ENDDO
117      ENDDO
118
119! +--Force the equivalence: END   (HG, 13-DEC-2003)
120! +  ==========================
121
122
123RETURN
124END SUBROUTINE RRTM_CMBGB16
Note: See TracBrowser for help on using the repository browser.