source: LMDZ5/branches/testing/libf/phylmd/rrtm/rrtm_gasabs1a_140gp.F90

Last change on this file was 1999, checked in by Laurent Fairhead, 11 years ago

Merged trunk changes r1920:1997 into testing branch
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 6.6 KB
Line 
1SUBROUTINE RRTM_GASABS1A_140GP (KLEV,P_ATR1,P_OD,P_TF1,P_COLDRY,P_WX,&
2 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,P_ONEMINUS,&
3 & P_COLH2O,P_COLCO2,P_COLO3,P_COLN2O,P_COLCH4,P_COLO2,P_CO2MULT,&
4 & K_LAYTROP,K_LAYSWTCH,K_LAYLOW,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
5
6!     Reformatted for F90 by JJMorcrette, ECMWF, 980714
7
8USE PARKIND1  ,ONLY : JPIM     ,JPRB
9USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
10
11USE PARRRTM  , ONLY : JPLAY    ,JPBAND   ,JPGPT   ,JPXSEC
12USE YOERRTAB , ONLY : TRANS    ,BPADE
13
14IMPLICIT NONE
15
16INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
17REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_ATR1(JPGPT,JPLAY)
18REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_OD(JPGPT,JPLAY)
19REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TF1(JPGPT,JPLAY)
20REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLDRY(JPLAY)
21REAL(KIND=JPRB)   ,INTENT(IN)    :: P_WX(JPXSEC,JPLAY) ! Amount of trace gases
22REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(JPLAY,JPBAND)
23REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(JPLAY)
24REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(JPLAY)
25REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(JPLAY)
26REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(JPLAY)
27REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(JPLAY)
28INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(JPLAY)
29INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(JPLAY)
30INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(JPLAY)
31REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS
32REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(JPLAY)
33REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCO2(JPLAY)
34REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLO3(JPLAY)
35REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLN2O(JPLAY)
36REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCH4(JPLAY)
37REAL(KIND=JPRB)                  :: P_COLO2(JPLAY) ! Argument NOT used
38REAL(KIND=JPRB)   ,INTENT(IN)    :: P_CO2MULT(JPLAY)
39INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP
40INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYSWTCH
41INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYLOW
42REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(JPLAY)
43REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(JPLAY)
44INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(JPLAY)
45REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(JPGPT,JPLAY)
46!- from AER
47!- from INTFAC     
48!- from INTIND
49!- from PRECISE             
50!- from PROFDATA             
51!- from SELF             
52!- from SP             
53REAL(KIND=JPRB) :: Z_TAU   (JPGPT,JPLAY)
54
55INTEGER(KIND=JPIM) :: IPR, ITR, I_LAY
56
57REAL(KIND=JPRB) :: Z_ODEPTH, Z_SECANG, Z_TF
58REAL(KIND=JPRB) :: ZHOOK_HANDLE
59
60#include "rrtm_taumol1.intfb.h"
61#include "rrtm_taumol10.intfb.h"
62#include "rrtm_taumol11.intfb.h"
63#include "rrtm_taumol12.intfb.h"
64#include "rrtm_taumol13.intfb.h"
65#include "rrtm_taumol14.intfb.h"
66#include "rrtm_taumol15.intfb.h"
67#include "rrtm_taumol16.intfb.h"
68#include "rrtm_taumol2.intfb.h"
69#include "rrtm_taumol3.intfb.h"
70#include "rrtm_taumol4.intfb.h"
71#include "rrtm_taumol5.intfb.h"
72#include "rrtm_taumol6.intfb.h"
73#include "rrtm_taumol7.intfb.h"
74#include "rrtm_taumol8.intfb.h"
75#include "rrtm_taumol9.intfb.h"
76
77!- SECANG is equal to the secant of the diffusivity angle.
78IF (LHOOK) CALL DR_HOOK('RRTM_GASABS1A_140GP',0,ZHOOK_HANDLE)
79Z_SECANG = 1.66_JPRB
80
81CALL RRTM_TAUMOL1  (KLEV,Z_TAU,&
82 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,&
83 & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
84CALL RRTM_TAUMOL2  (KLEV,Z_TAU,P_COLDRY,&
85 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,&
86 & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
87CALL RRTM_TAUMOL3  (KLEV,Z_TAU,&
88 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,P_ONEMINUS,&
89 & P_COLH2O,P_COLCO2,P_COLN2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
90CALL RRTM_TAUMOL4  (KLEV,Z_TAU,&
91 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,P_ONEMINUS,&
92 & P_COLH2O,P_COLCO2,P_COLO3,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
93CALL RRTM_TAUMOL5  (KLEV,Z_TAU,P_WX,&
94 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,P_ONEMINUS,&
95 & P_COLH2O,P_COLCO2,P_COLO3,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
96CALL RRTM_TAUMOL6  (KLEV,Z_TAU,P_WX,&
97 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,&
98 & P_COLH2O,P_CO2MULT,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
99CALL RRTM_TAUMOL7  (KLEV,Z_TAU,&
100 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,&
101 & P_COLH2O,P_COLO3,P_CO2MULT,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
102CALL RRTM_TAUMOL8  (KLEV,Z_TAU,P_WX,&
103 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,&
104 & P_COLH2O,P_COLO3,P_COLN2O,P_CO2MULT,K_LAYSWTCH,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
105CALL RRTM_TAUMOL9  (KLEV,Z_TAU,&
106 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,&
107 & P_COLH2O,P_COLN2O,P_COLCH4,K_LAYTROP,K_LAYSWTCH,K_LAYLOW,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
108CALL RRTM_TAUMOL10 (KLEV,Z_TAU,&
109 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,&
110 & P_COLH2O,K_LAYTROP,PFRAC) 
111CALL RRTM_TAUMOL11 (KLEV,Z_TAU,&
112 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,&
113 & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
114CALL RRTM_TAUMOL12 (KLEV,Z_TAU,&
115 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,&
116 & P_COLH2O,P_COLCO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
117CALL RRTM_TAUMOL13 (KLEV,Z_TAU,&
118 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,&
119 & P_COLH2O,P_COLN2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
120CALL RRTM_TAUMOL14 (KLEV,Z_TAU,&
121 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,&
122 & P_COLCO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
123CALL RRTM_TAUMOL15 (KLEV,Z_TAU,&
124 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,&
125 & P_COLH2O,P_COLCO2,P_COLN2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
126CALL RRTM_TAUMOL16 (KLEV,Z_TAU,&
127 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,&
128 & P_COLH2O,P_COLCH4,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) 
129
130!- Loop over g-channels.
131DO I_LAY = 1, KLEV
132  DO IPR = 1, JPGPT
133    Z_ODEPTH = Z_SECANG * Z_TAU(IPR,I_LAY)
134    P_OD(IPR,I_LAY) = Z_ODEPTH
135    Z_ODEPTH=0.5D0*(ABS(Z_ODEPTH)+Z_ODEPTH)
136
137!-- revised code to get the pre-computed transmission
138!          IF (ODEPTH.LE.0.) PRINT*, 'ODEPTH = ',ODEPTH
139!!  IF (ODEPTH <= _ZERO_)THEN
140!!    ATR1(IPR,LAY) = _ONE_ - TRANS(0)
141!!    TF1(IPR,LAY) = _ZERO_
142!!  ELSE
143
144    Z_TF = Z_ODEPTH/(BPADE+Z_ODEPTH)
145    ITR=INT(5.E+03_JPRB*Z_TF+0.5_JPRB)
146    IF (ITR.LT.0) ITR=0     ! MPL 12.12.08
147    P_ATR1(IPR,I_LAY) = 1.0_JPRB - TRANS(ITR)
148    P_TF1(IPR,I_LAY) = Z_TF
149
150!!  ENDIF
151  ENDDO
152ENDDO
153
154!     -----------------------------------------------------------------
155
156IF (LHOOK) CALL DR_HOOK('RRTM_GASABS1A_140GP',1,ZHOOK_HANDLE)
157END SUBROUTINE RRTM_GASABS1A_140GP
Note: See TracBrowser for help on using the repository browser.