source: LMDZ6/trunk/libf/phylmd/ecrad/ifsrrtm/srtm_taumol19.F90 @ 4773

Last change on this file since 4773 was 4773, checked in by idelkadi, 6 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_TAUMOL19 &
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_COLCO2 , 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 19:  4650-5150 cm-1 (low - H2O,CO2; high - CO2)
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 : NG19
25USE YOESRTA19, 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_COLCO2(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
63!REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,&
64! & Z_FAC110, Z_FAC111
65REAL(KIND=JPRB) :: Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, Z_TAURAY 
66REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
67
68INTEGER(KIND=JPIM) :: I_LAY_NEXT
69
70IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL19',0,ZHOOK_HANDLE)
71
72I_NLAYERS = KLEV
73
74!     Compute the optical depth by interpolating in ln(pressure),
75!     temperature, and appropriate species.  Below LAYTROP, the water
76!     vapor self-continuum is interpolated (in temperature) separately. 
77
78I_LAYSOLFR(KIDIA:KFDIA) = K_LAYTROP(KIDIA:KFDIA)
79
80DO I_LAY = 1, I_NLAYERS
81  I_LAY_NEXT = MIN(I_NLAYERS, I_LAY+1)
82  DO IPLON = KIDIA, KFDIA
83    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
84      IF (I_LAY <= K_LAYTROP(IPLON)) THEN
85        IF (K_JP(IPLON,I_LAY) < LAYREFFR .AND. K_JP(IPLON,I_LAY_NEXT) >= LAYREFFR) &
86         & I_LAYSOLFR(IPLON) = MIN(I_LAY+1,K_LAYTROP(IPLON)) 
87        Z_SPECCOMB = P_COLH2O(IPLON,I_LAY) + STRRAT*P_COLCO2(IPLON,I_LAY)
88        Z_SPECPARM = P_COLH2O(IPLON,I_LAY)/Z_SPECCOMB
89        IF (Z_SPECPARM >= P_ONEMINUS(IPLON)) Z_SPECPARM = P_ONEMINUS(IPLON)
90        Z_SPECMULT = 8.*(Z_SPECPARM)
91        JS = 1 + INT(Z_SPECMULT)
92        Z_FS = MOD(Z_SPECMULT, 1.0_JPRB )
93        ! Z_FAC000 = (1. - Z_FS) * P_FAC00(I_LAY)
94        ! Z_FAC010 = (1. - Z_FS) * P_FAC10(I_LAY)
95        ! Z_FAC100 = Z_FS * P_FAC00(I_LAY)
96        ! Z_FAC110 = Z_FS * P_FAC10(I_LAY)
97        ! Z_FAC001 = (1. - Z_FS) * P_FAC01(I_LAY)
98        ! Z_FAC011 = (1. - Z_FS) * P_FAC11(I_LAY)
99        ! Z_FAC101 = Z_FS * P_FAC01(I_LAY)
100        ! Z_FAC111 = Z_FS * P_FAC11(I_LAY)
101        IND0 = ((K_JP(IPLON,I_LAY)-1)*5+(K_JT(IPLON,I_LAY)-1))*NSPA(19) + JS
102        IND1 = (K_JP(IPLON,I_LAY)*5+(K_JT1(IPLON,I_LAY)-1))*NSPA(19) + JS
103        INDS = K_INDSELF(IPLON,I_LAY)
104        INDF = K_INDFOR(IPLON,I_LAY)
105        Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYL
106
107        !  DO IG = 1, NG(19)
108!CDIR UNROLL=NG19
109        DO IG = 1 , NG19
110          P_TAUG(IPLON,I_LAY,IG) = Z_SPECCOMB * &
111           !    & (Z_FAC000 * ABSA(IND0,IG) + &
112           !    & Z_FAC100 * ABSA(IND0+1,IG) + &
113           !    & Z_FAC010 * ABSA(IND0+9,IG) + &
114           !    & Z_FAC110 * ABSA(IND0+10,IG) + &
115           !    & Z_FAC001 * ABSA(IND1,IG) + &
116           !    & Z_FAC101 * ABSA(IND1+1,IG) + &
117           !    & Z_FAC011 * ABSA(IND1+9,IG) + &
118           !    & Z_FAC111 * ABSA(IND1+10,IG)) + &
119           & (&
120           & (1. - Z_FS) * ( ABSA(IND0,IG) * P_FAC00(IPLON,I_LAY) + &
121           &                 ABSA(IND0+9,IG) * P_FAC10(IPLON,I_LAY) + &
122           &                 ABSA(IND1,IG) * P_FAC01(IPLON,I_LAY) + &
123           &                 ABSA(IND1+9,IG) * P_FAC11(IPLON,I_LAY) ) + &
124           & Z_FS        * ( ABSA(IND0+1,IG) * P_FAC00(IPLON,I_LAY) + &
125           &                 ABSA(IND0+10,IG) * P_FAC10(IPLON,I_LAY) + &
126           &                 ABSA(IND1+1,IG) * P_FAC01(IPLON,I_LAY) + &
127           &                 ABSA(IND1+10,IG) * P_FAC11(IPLON,I_LAY) ) &
128           & ) + &
129           & P_COLH2O(IPLON,I_LAY) * &
130           & (P_SELFFAC(IPLON,I_LAY) * (SELFREFC(INDS,IG) + &
131           & P_SELFFRAC(IPLON,I_LAY) * &
132           & (SELFREFC(INDS+1,IG) - SELFREFC(INDS,IG))) +  &
133           & P_FORFAC(IPLON,I_LAY) * (FORREFC(INDF,IG) + &
134           & P_FORFRAC(IPLON,I_LAY) * &
135           & (FORREFC(INDF+1,IG) - FORREFC(INDF,IG))))   
136          !     &           + TAURAY
137          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
138          IF (I_LAY == I_LAYSOLFR(IPLON)) P_SFLUXZEN(IPLON,IG) = SFLUXREFC(IG,JS) &
139           & + Z_FS * (SFLUXREFC(IG,JS+1) - SFLUXREFC(IG,JS)) 
140          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY   
141        ENDDO
142      ENDIF
143    ENDIF
144  ENDDO
145ENDDO
146
147DO I_LAY = 1, I_NLAYERS
148  DO IPLON = KIDIA, KFDIA
149    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
150      IF (I_LAY >= K_LAYTROP(IPLON)+1) THEN
151        IND0 = ((K_JP(IPLON,I_LAY)-13)*5+(K_JT(IPLON,I_LAY)-1))*NSPB(19) + 1
152        IND1 = ((K_JP(IPLON,I_LAY)-12)*5+(K_JT1(IPLON,I_LAY)-1))*NSPB(19) + 1
153        Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYL
154
155        !  DO IG = 1, NG(19)
156!CDIR UNROLL=NG19
157        DO IG = 1 , NG19
158          P_TAUG(IPLON,I_LAY,IG) = P_COLCO2(IPLON,I_LAY) * &
159           & (P_FAC00(IPLON,I_LAY) * ABSB(IND0,IG) + &
160           & P_FAC10(IPLON,I_LAY) * ABSB(IND0+1,IG) + &
161           & P_FAC01(IPLON,I_LAY) * ABSB(IND1,IG) + &
162           & P_FAC11(IPLON,I_LAY) * ABSB(IND1+1,IG))   
163          !     &           + TAURAY
164          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
165          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY   
166        ENDDO
167      ENDIF
168    ENDIF
169  ENDDO
170ENDDO
171
172!-----------------------------------------------------------------------
173IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL19',1,ZHOOK_HANDLE)
174
175END SUBROUTINE SRTM_TAUMOL19
Note: See TracBrowser for help on using the repository browser.