source: LMDZ6/trunk/libf/phylmd/ecrad/ifsrrtm/srtm_taumol18.F90 @ 4999

Last change on this file since 4999 was 4773, checked in by idelkadi, 7 months ago
  • Update of Ecrad in LMDZ The same organization of the Ecrad offline version is retained in order to facilitate the updating of Ecrad in LMDZ and the comparison between online and offline results. version 1.6.1 of Ecrad (​https://github.com/lguez/ecrad.git)
  • Implementation of the double call of Ecrad in LMDZ


File size: 7.3 KB
Line 
1SUBROUTINE SRTM_TAUMOL18 &
2 & ( KIDIA   , KFDIA    , KLEV,&
3 & P_FAC00   , P_FAC01  , P_FAC10   , P_FAC11,&
4 & K_JP      , K_JT     , K_JT1     , P_ONEMINUS,&
5 & P_COLH2O  , P_COLCH4 , P_COLMOL,&
6 & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF  , P_FORFAC, P_FORFRAC, K_INDFOR,&
7 & P_SFLUXZEN, P_TAUG   , P_TAUR    , PRMU0   &
8 & ) 
9
10!     Written by Eli J. Mlawer, Atmospheric & Environmental Research.
11
12!     BAND 18:  4000-4650 cm-1 (low - H2O,CH4; high - CH4)
13
14! Modifications
15!        M.Hamrud      01-Oct-2003 CY28 Cleaning
16
17!     JJMorcrette 2003-02-24 adapted to ECMWF environment
18!        D.Salmond  31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC
19!     JJMorcrette 20110610 Flexible configuration for number of g-points
20
21USE PARKIND1 , ONLY : JPIM, JPRB
22USE YOMHOOK  , ONLY : LHOOK, DR_HOOK, JPHOOK
23USE PARSRTM  , ONLY : JPG
24USE YOESRTM  , ONLY : NG18
25USE YOESRTA18, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT 
26USE YOESRTWN , ONLY : NSPA, NSPB
27
28IMPLICIT NONE
29
30!-- Output
31INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA, KFDIA
32INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
33REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(KIDIA:KFDIA,KLEV)
34REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(KIDIA:KFDIA,KLEV)
35REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(KIDIA:KFDIA,KLEV)
36REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(KIDIA:KFDIA,KLEV)
37INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(KIDIA:KFDIA,KLEV)
38INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(KIDIA:KFDIA,KLEV)
39INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(KIDIA:KFDIA,KLEV)
40REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS(KIDIA:KFDIA)
41REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(KIDIA:KFDIA,KLEV)
42REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCH4(KIDIA:KFDIA,KLEV)
43REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLMOL(KIDIA:KFDIA,KLEV)
44INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP(KIDIA:KFDIA)
45REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(KIDIA:KFDIA,KLEV)
46REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(KIDIA:KFDIA,KLEV)
47INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(KIDIA:KFDIA,KLEV)
48REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(KIDIA:KFDIA,KLEV)
49REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFRAC(KIDIA:KFDIA,KLEV)
50INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDFOR(KIDIA:KFDIA,KLEV)
51
52REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SFLUXZEN(KIDIA:KFDIA,JPG)
53REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUG(KIDIA:KFDIA,KLEV,JPG)
54REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUR(KIDIA:KFDIA,KLEV,JPG)
55REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(KIDIA:KFDIA)
56!- from INTFAC     
57!- from INTIND
58!- from PRECISE             
59!- from PROFDATA             
60!- from SELF             
61INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON
62
63INTEGER(KIND=JPIM) :: I_LAY_NEXT
64
65REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,&
66 & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, &
67 & Z_TAURAY 
68REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
69
70IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL18',0,ZHOOK_HANDLE)
71I_NLAYERS = KLEV
72
73!     Compute the optical depth by interpolating in ln(pressure),
74!     temperature, and appropriate species.  Below LAYTROP, the water
75!     vapor self-continuum is interpolated (in temperature) separately. 
76
77I_LAYSOLFR(KIDIA:KFDIA) = K_LAYTROP(KIDIA:KFDIA)
78
79DO I_LAY = 1, I_NLAYERS
80  I_LAY_NEXT = MIN(I_NLAYERS, I_LAY+1)
81  DO IPLON = KIDIA, KFDIA
82    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
83      IF (I_LAY <= K_LAYTROP(IPLON)) THEN
84        IF (K_JP(IPLON,I_LAY) < LAYREFFR .AND. K_JP(IPLON,I_LAY_NEXT) >= LAYREFFR) &
85         & I_LAYSOLFR(IPLON) = MIN(I_LAY+1,K_LAYTROP(IPLON)) 
86        Z_SPECCOMB = P_COLH2O(IPLON,I_LAY) + STRRAT*P_COLCH4(IPLON,I_LAY)
87        Z_SPECPARM = P_COLH2O(IPLON,I_LAY)/Z_SPECCOMB
88        IF (Z_SPECPARM >= P_ONEMINUS(IPLON)) Z_SPECPARM = P_ONEMINUS(IPLON)
89        Z_SPECMULT = 8.*(Z_SPECPARM)
90        JS = 1 + INT(Z_SPECMULT)
91        Z_FS = MOD(Z_SPECMULT, 1.0_JPRB )
92        ! Z_FAC000 = (1. - Z_FS) * P_FAC00(I_LAY)
93        ! Z_FAC010 = (1. - Z_FS) * P_FAC10(I_LAY)
94        ! Z_FAC100 = Z_FS * P_FAC00(I_LAY)
95        ! Z_FAC110 = Z_FS * P_FAC10(I_LAY)
96        ! Z_FAC001 = (1. - Z_FS) * P_FAC01(I_LAY)
97        ! Z_FAC011 = (1. - Z_FS) * P_FAC11(I_LAY)
98        ! Z_FAC101 = Z_FS * P_FAC01(I_LAY)
99        ! Z_FAC111 = Z_FS * P_FAC11(I_LAY)
100        IND0 = ((K_JP(IPLON,I_LAY)-1)*5+(K_JT(IPLON,I_LAY)-1))*NSPA(18) + JS
101        IND1 = (K_JP(IPLON,I_LAY)*5+(K_JT1(IPLON,I_LAY)-1))*NSPA(18) + JS
102        INDS = K_INDSELF(IPLON,I_LAY)
103        INDF = K_INDFOR(IPLON,I_LAY)
104        Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYL
105
106        !  DO IG = 1, NG(18)
107!CDIR UNROLL=NG18
108        DO IG = 1, NG18
109          P_TAUG(IPLON,I_LAY,IG) = Z_SPECCOMB * &
110           !    & (Z_FAC000 * ABSA(IND0,IG) + &
111           !    & Z_FAC100 * ABSA(IND0+1,IG) + &
112           !    & Z_FAC010 * ABSA(IND0+9,IG) + &
113           !    & Z_FAC110 * ABSA(IND0+10,IG) + &
114           !    & Z_FAC001 * ABSA(IND1,IG) + &
115           !    & Z_FAC101 * ABSA(IND1+1,IG) + &
116           !    & Z_FAC011 * ABSA(IND1+9,IG) + &
117           !    & Z_FAC111 * ABSA(IND1+10,IG)) + &
118           & (&
119           & (1. - Z_FS) * ( ABSA(IND0,IG) * P_FAC00(IPLON,I_LAY) + &
120           &                 ABSA(IND0+9,IG) * P_FAC10(IPLON,I_LAY) + &
121           &                 ABSA(IND1,IG) * P_FAC01(IPLON,I_LAY) + &
122           &                 ABSA(IND1+9,IG) * P_FAC11(IPLON,I_LAY) ) + &
123           & Z_FS        * ( ABSA(IND0+1,IG) * P_FAC00(IPLON,I_LAY) + &
124           &                 ABSA(IND0+10,IG) * P_FAC10(IPLON,I_LAY) + &
125           &                 ABSA(IND1+1,IG) * P_FAC01(IPLON,I_LAY) + &
126           &                 ABSA(IND1+10,IG) * P_FAC11(IPLON,I_LAY) ) &
127           & ) + &
128           & P_COLH2O(IPLON,I_LAY) * &
129           & (P_SELFFAC(IPLON,I_LAY) * (SELFREFC(INDS,IG) + &
130           & P_SELFFRAC(IPLON,I_LAY) * &
131           & (SELFREFC(INDS+1,IG) - SELFREFC(INDS,IG))) + &
132           & P_FORFAC(IPLON,I_LAY) * (FORREFC(INDF,IG) + &
133           & P_FORFRAC(IPLON,I_LAY) * &
134           & (FORREFC(INDF+1,IG) - FORREFC(INDF,IG))))   
135          !     &           + TAURAY
136          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
137          IF (I_LAY == I_LAYSOLFR(IPLON)) P_SFLUXZEN(IPLON,IG) = SFLUXREFC(IG,JS)  &
138           & + Z_FS * (SFLUXREFC(IG,JS+1) - SFLUXREFC(IG,JS)) 
139          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY
140        ENDDO
141      ENDIF
142    ENDIF
143  ENDDO
144ENDDO
145
146DO I_LAY = 1, I_NLAYERS
147  DO IPLON = KIDIA, KFDIA
148    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
149      IF (I_LAY >= K_LAYTROP(IPLON)+1) THEN
150        IND0 = ((K_JP(IPLON,I_LAY)-13)*5+(K_JT(IPLON,I_LAY)-1))*NSPB(18) + 1
151        IND1 = ((K_JP(IPLON,I_LAY)-12)*5+(K_JT1(IPLON,I_LAY)-1))*NSPB(18) + 1
152        Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYL
153
154        !  DO IG = 1, NG(18)
155!CDIR UNROLL=NG18
156        DO IG = 1, NG18
157          P_TAUG(IPLON,I_LAY,IG) = P_COLCH4(IPLON,I_LAY) * &
158           & (P_FAC00(IPLON,I_LAY) * ABSB(IND0,IG) + &
159           & P_FAC10(IPLON,I_LAY) * ABSB(IND0+1,IG) + &
160           & P_FAC01(IPLON,I_LAY) * ABSB(IND1,IG) +       &
161           & P_FAC11(IPLON,I_LAY) * ABSB(IND1+1,IG))   
162          !     &           + TAURAY
163          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
164          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY
165        ENDDO
166      ENDIF
167    ENDIF
168  ENDDO
169ENDDO
170
171!-----------------------------------------------------------------------
172IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL18',1,ZHOOK_HANDLE)
173
174END SUBROUTINE SRTM_TAUMOL18
Note: See TracBrowser for help on using the repository browser.