source: LMDZ5/trunk/libf/phylmd/rrtm/lwb.F90

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

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • 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: 7.5 KB
Line 
1SUBROUTINE LWB &
2 & ( KIDIA, KFDIA, KLON  , KLEV  , KMODE,&
3 & PDT0 , PTAVE, PTL,&
4 & PB   , PBINT, PBSUR , PBTOP , PDBSL,&
5 & PGA  , PGB  , PGASUR, PGBSUR, PGATOP, PGBTOP    &
6 & ) 
7
8!**** *LWB*   - COMPUTES BLACK-BODY FUNCTIONS FOR LONGWAVE CALCULATIONS
9
10!     PURPOSE.
11!     --------
12!           COMPUTES PLANCK FUNCTIONS
13
14!**   INTERFACE.
15!     ----------
16
17!        EXPLICIT ARGUMENTS :
18!        --------------------
19!     ==== INPUTS ===
20! PDT0   : (KLON)            ; SURFACE TEMPERATURE DISCONTINUITY
21! PTAVE  : (KLON,KLEV)       ; TEMPERATURE
22! PTL    : (KLON,KLEV+1)     ; HALF LEVEL TEMPERATURE
23!     ==== OUTPUTS ===
24! PB     : (KLON,NSIL,KLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
25! PBINT  : (KLON,KLEV+1)     ; HALF LEVEL PLANCK FUNCTION
26! PBSUR  : (KLON,NSIL)       ; SURFACE SPECTRAL PLANCK FUNCTION
27! PBTOP  : (KLON,NSIL)       ; TOP SPECTRAL PLANCK FUNCTION
28! PDBSL  : (KLON,NSIL,KLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
29! PGA    : (KLON,8,2,KLEV)   ; dB/dT-weighted LAYER PADE APPROXIMANTS
30! PGB    : (KLON,8,2,KLEV)   ; dB/dT-weighted LAYER PADE APPROXIMANTS
31! PGASUR, PGBSUR (KLON,8,2)  ; SURFACE PADE APPROXIMANTS
32! PGATOP, PGBTOP (KLON,8,2)  ; T.O.A. PADE APPROXIMANTS
33
34!        IMPLICIT ARGUMENTS :   NONE
35!        --------------------
36
37!     METHOD.
38!     -------
39
40!          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
41!     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
42
43!     EXTERNALS.
44!     ----------
45
46!          NONE
47
48!     REFERENCE.
49!     ----------
50
51!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
52!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
53
54!     AUTHOR.
55!     -------
56!        JEAN-JACQUES MORCRETTE  *ECMWF*
57
58!     MODIFICATIONS.
59!     --------------
60!        ORIGINAL : 89-07-14
61!        MODIFIED : 99-06-14  D.SALMOND  Optimisation
62!        M.Hamrud      01-Oct-2003 CY28 Cleaning
63
64!-----------------------------------------------------------------------
65
66USE PARKIND1  ,ONLY : JPIM     ,JPRB
67USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
68
69USE YOELW    , ONLY : MXIXT    ,NSIL     ,NIPD     ,PDGA     ,&
70 & PDGB     ,TINTP    ,TSTAND   ,TSTP     ,XP 
71
72IMPLICIT NONE
73
74INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
75INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
76INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
77INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
78INTEGER(KIND=JPIM),INTENT(IN)    :: KMODE
79REAL(KIND=JPRB)   ,INTENT(IN)    :: PDT0(KLON)
80REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(KLON,KLEV)
81REAL(KIND=JPRB)   ,INTENT(IN)    :: PTL(KLON,KLEV+1)
82REAL(KIND=JPRB)   ,INTENT(OUT)   :: PB(KLON,NSIL,KLEV+1)
83REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBINT(KLON,KLEV+1)
84REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBSUR(KLON,NSIL)
85REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBTOP(KLON,NSIL)
86REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDBSL(KLON,NSIL,KLEV*2)
87REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGA(KLON,NIPD,2,KLEV)
88REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGB(KLON,NIPD,2,KLEV)
89REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGASUR(KLON,NIPD,2)
90REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGBSUR(KLON,NIPD,2)
91REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGATOP(KLON,NIPD,2)
92REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGBTOP(KLON,NIPD,2)
93!-----------------------------------------------------------------------
94
95!*       0.1   ARGUMENTS
96!              ---------
97
98!-------------------------------------------------------------------------
99
100!              ------------
101INTEGER(KIND=JPIM) :: INDB(KLON)   , INDS(KLON)
102REAL(KIND=JPRB) :: ZBLAY(KLON,KLEV), ZBLEV(KLON,KLEV+1)&
103 & ,  ZRES(KLON)      , ZRES2(KLON)&
104 & ,  ZTI(KLON)       , ZTI2(KLON) 
105
106INTEGER(KIND=JPIM) :: ILEV2, INDSU, INDT, INDTO, INDTP, INUE, INUS,&
107 & IXTOX, IXTX, JF, JG, JK, JK1, JK2, JL, JNU 
108
109REAL(KIND=JPRB) :: ZDST1, ZDSTO1, ZDSTOX, ZDSTX
110REAL(KIND=JPRB) :: ZHOOK_HANDLE
111
112!     ------------------------------------------------------------------
113
114!*         1.0     PLANCK FUNCTIONS AND GRADIENTS
115!                  ------------------------------
116
117print *,'dans LWB'
118IF (LHOOK) CALL DR_HOOK('LWB',0,ZHOOK_HANDLE)
119ILEV2=2*KLEV
120INUS=1
121INUE=NSIL
122IF (KMODE == 2) THEN
123  INUS=3
124  INUE=4
125ENDIF
126
127DO JK = 1 , KLEV+1
128  DO JL = KIDIA,KFDIA
129    PBINT(JL,JK) = 0.0_JPRB
130  ENDDO
131ENDDO
132
133DO JNU=1,NSIL
134  DO JL=KIDIA,KFDIA
135    PBSUR(JL,JNU)=0.0_JPRB
136    PBTOP(JL,JNU)=0.0_JPRB
137  ENDDO
138  DO JK=1,KLEV
139    DO JL=KIDIA,KFDIA
140      PB(JL,JNU,JK)=0.0_JPRB
141    ENDDO
142  ENDDO
143  DO JK=1,ILEV2
144    DO JL=KIDIA,KFDIA
145      PDBSL(JL,JNU,JK)=0.0_JPRB
146    ENDDO
147  ENDDO
148ENDDO
149
150DO JNU=INUS,INUE
151
152!*         1.1   LEVELS FROM SURFACE TO KLEV
153!                ----------------------------
154
155  DO JK = 1 , KLEV
156    DO JL = KIDIA,KFDIA
157      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
158      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)&
159       & +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)&
160       & ))))) 
161      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
162      PB(JL,JNU,JK)= ZRES(JL)
163      ZBLEV(JL,JK) = ZRES(JL)
164
165      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
166      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)&
167       & +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,&
168       & JNU)&
169       & ))))) 
170      ZBLAY(JL,JK) = ZRES2(JL)
171    ENDDO
172  ENDDO
173
174!*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
175!                ---------------------------------
176
177  DO JL = KIDIA,KFDIA
178    ZTI(JL)=(PTL(JL,KLEV+1)-TSTAND)/TSTAND
179    ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
180    ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)&
181     & +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)&
182     & ))))) 
183    ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)&
184     & +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)&
185     & ))))) 
186    PBINT(JL,KLEV+1) = PBINT(JL,KLEV+1)+ZRES(JL)
187    PB(JL,JNU,KLEV+1)= ZRES(JL)
188    ZBLEV(JL,KLEV+1) = ZRES(JL)
189    PBTOP(JL,JNU) = ZRES(JL)
190    PBSUR(JL,JNU) = ZRES2(JL)
191  ENDDO
192
193!*         1.3   GRADIENTS IN SUB-LAYERS
194!                -----------------------
195
196  DO JK = 1 , KLEV
197    JK2 = 2 * JK
198    JK1 = JK2 - 1
199    DO JL = KIDIA,KFDIA
200      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
201      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
202    ENDDO
203  ENDDO
204
205ENDDO
206
207!*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
208!                ---------------------------------------------
209
210DO JL=KIDIA,KFDIA
211  ZDSTO1 = (PTL(JL,KLEV+1)-TINTP(1)) / TSTP
212  IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1.0_JPRB ) ) )
213  ZDSTOX = (PTL(JL,KLEV+1)-TINTP(IXTOX))/TSTP
214  IF (ZDSTOX < 0.5_JPRB) THEN
215    INDTO=IXTOX
216  ELSE
217    INDTO=IXTOX+1
218  ENDIF
219  INDB(JL)=INDTO
220  ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
221  IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1.0_JPRB ) ) )
222  ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
223  IF (ZDSTX < 0.5_JPRB) THEN
224    INDT=IXTX
225  ELSE
226    INDT=IXTX+1
227  ENDIF
228  INDS(JL)=INDT
229ENDDO
230
231DO JF=1,2
232  DO JG=1,NIPD
233    DO JL=KIDIA,KFDIA
234      INDSU=INDS(JL)
235      PGASUR(JL,JG,JF)=PDGA(INDSU,2*JG-1,JF)
236      PGBSUR(JL,JG,JF)=PDGB(INDSU,2*JG-1,JF)
237      INDTP=INDB(JL)
238      PGATOP(JL,JG,JF)=PDGA(INDTP,2*JG-1,JF)
239      PGBTOP(JL,JG,JF)=PDGB(INDTP,2*JG-1,JF)
240    ENDDO
241  ENDDO
242ENDDO
243
244DO JK=1,KLEV
245  DO JL=KIDIA,KFDIA
246    ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
247    IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1.0_JPRB ) ) )
248    ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
249    IF (ZDSTX < 0.5_JPRB) THEN
250      INDT=IXTX
251    ELSE
252      INDT=IXTX+1
253    ENDIF
254    INDB(JL)=INDT
255  ENDDO
256
257  DO JF=1,2
258    DO JL=KIDIA,KFDIA
259      INDT=INDB(JL)
260      DO JG=1,NIPD
261        PGA(JL,JG,JF,JK)=PDGA(INDT,2*JG,JF)
262        PGB(JL,JG,JF,JK)=PDGB(INDT,2*JG,JF)
263      ENDDO
264    ENDDO
265  ENDDO
266
267ENDDO
268
269!     ------------------------------------------------------------------
270
271IF (LHOOK) CALL DR_HOOK('LWB',1,ZHOOK_HANDLE)
272END SUBROUTINE LWB
Note: See TracBrowser for help on using the repository browser.