source: LMDZ5/branches/testing/libf/phymar/lwb.F90 @ 3632

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

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand
File size: 6.8 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
63!-----------------------------------------------------------------------
64
65#include "tsmbkind.h"
66
67USE YOELW    , ONLY : MXIXT    ,NSIL     ,NIPD     ,PDGA     ,&
68            &PDGB     ,TINTP    ,TSTAND   ,TSTP     ,XP
69
70
71IMPLICIT NONE
72
73
74!     DUMMY INTEGER SCALARS
75INTEGER_M :: KFDIA
76INTEGER_M :: KIDIA
77INTEGER_M :: KLEV
78INTEGER_M :: KLON
79INTEGER_M :: KMODE
80
81
82
83!-----------------------------------------------------------------------
84
85!*       0.1   ARGUMENTS
86!              ---------
87
88REAL_B :: PDT0(KLON),PTAVE(KLON,KLEV),PTL(KLON,KLEV+1)
89
90REAL_B :: PB(KLON,NSIL,KLEV+1)   , PBINT(KLON,KLEV+1)&
91  &,  PBSUR(KLON,NSIL)       ,  PBTOP(KLON,NSIL)   &
92  &,  PDBSL(KLON,NSIL,KLEV*2)&
93  &,  PGA(KLON,NIPD,2,KLEV)  , PGB(KLON,NIPD,2,KLEV)&
94  &,  PGASUR(KLON,NIPD,2)    , PGBSUR(KLON,NIPD,2)&
95  &,  PGATOP(KLON,NIPD,2)    , PGBTOP(KLON,NIPD,2)
96
97!-------------------------------------------------------------------------
98
99!*       0.2   LOCAL ARRAYS
100!              ------------
101INTEGER_M :: INDB(KLON)   , INDS(KLON)
102REAL_B :: ZBLAY(KLON,KLEV), ZBLEV(KLON,KLEV+1)&
103  &,  ZRES(KLON)      , ZRES2(KLON)&
104  &,  ZTI(KLON)       , ZTI2(KLON)
105
106!     LOCAL INTEGER SCALARS
107INTEGER_M :: ILEV2, INDSU, INDT, INDTO, INDTP, INUE, INUS,&
108             &IXTOX, IXTX, JF, JG, JK, JK1, JK2, JL, JNU
109
110!     LOCAL REAL SCALARS
111REAL_B :: ZDST1, ZDSTO1, ZDSTOX, ZDSTX
112
113
114!     ------------------------------------------------------------------
115
116
117!*         1.0     PLANCK FUNCTIONS AND GRADIENTS
118!                  ------------------------------
119
120ILEV2=2*KLEV
121INUS=1
122INUE=NSIL
123IF (KMODE == 2) THEN
124  INUS=3
125  INUE=4
126ENDIF
127
128DO JK = 1 , KLEV+1
129  DO JL = KIDIA,KFDIA
130    PBINT(JL,JK) = _ZERO_
131  ENDDO
132ENDDO
133
134DO JNU=1,NSIL
135  DO JL=KIDIA,KFDIA
136    PBSUR(JL,JNU)=_ZERO_
137    PBTOP(JL,JNU)=_ZERO_
138  ENDDO
139  DO JK=1,KLEV
140    DO JL=KIDIA,KFDIA
141      PB(JL,JNU,JK)=_ZERO_
142    ENDDO
143  ENDDO
144  DO JK=1,ILEV2
145    DO JL=KIDIA,KFDIA
146      PDBSL(JL,JNU,JK)=_ZERO_
147    ENDDO
148  ENDDO
149ENDDO
150
151DO JNU=INUS,INUE
152
153
154!*         1.1   LEVELS FROM SURFACE TO KLEV
155!                ----------------------------
156
157  DO JK = 1 , KLEV
158    DO JL = KIDIA,KFDIA
159      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
160      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)&
161       &+ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)&
162       &)))))
163      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
164      PB(JL,JNU,JK)= ZRES(JL)
165      ZBLEV(JL,JK) = ZRES(JL)
166
167      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
168      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)&
169       &+ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,&
170       &JNU)&
171       &)))))
172      ZBLAY(JL,JK) = ZRES2(JL)
173    ENDDO
174  ENDDO
175
176
177!*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
178!                ---------------------------------
179
180  DO JL = KIDIA,KFDIA
181    ZTI(JL)=(PTL(JL,KLEV+1)-TSTAND)/TSTAND
182    ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
183    ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)&
184     &+ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)&
185     &)))))
186    ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)&
187     &+ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)&
188     &)))))
189    PBINT(JL,KLEV+1) = PBINT(JL,KLEV+1)+ZRES(JL)
190    PB(JL,JNU,KLEV+1)= ZRES(JL)
191    ZBLEV(JL,KLEV+1) = ZRES(JL)
192    PBTOP(JL,JNU) = ZRES(JL)
193    PBSUR(JL,JNU) = ZRES2(JL)
194  ENDDO
195
196
197!*         1.3   GRADIENTS IN SUB-LAYERS
198!                -----------------------
199
200  DO JK = 1 , KLEV
201    JK2 = 2 * JK
202    JK1 = JK2 - 1
203    DO JL = KIDIA,KFDIA
204      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
205      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
206    ENDDO
207  ENDDO
208
209ENDDO
210
211!*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
212!                ---------------------------------------------
213
214DO JL=KIDIA,KFDIA
215  ZDSTO1 = (PTL(JL,KLEV+1)-TINTP(1)) / TSTP
216  IXTOX = MAX( 1, MIN( INT(MXIXT), INT( ZDSTO1 + _ONE_ ) ) )
217  ZDSTOX = (PTL(JL,KLEV+1)-TINTP(IXTOX))/TSTP
218  IF (ZDSTOX < _HALF_) THEN
219    INDTO=IXTOX
220  ELSE
221    INDTO=IXTOX+1
222  ENDIF
223  INDB(JL)=INDTO
224  ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
225  IXTX = MAX( 1, MIN( INT(MXIXT), INT( ZDST1 + _ONE_ ) ) )
226  ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
227  IF (ZDSTX < _HALF_) THEN
228    INDT=IXTX
229  ELSE
230    INDT=IXTX+1
231  ENDIF
232  INDS(JL)=INDT
233ENDDO
234
235DO JF=1,2
236  DO JG=1,NIPD
237    DO JL=KIDIA,KFDIA
238      INDSU=INDS(JL)
239      PGASUR(JL,JG,JF)=PDGA(INDSU,2*JG-1,JF)
240      PGBSUR(JL,JG,JF)=PDGB(INDSU,2*JG-1,JF)
241      INDTP=INDB(JL)
242      PGATOP(JL,JG,JF)=PDGA(INDTP,2*JG-1,JF)
243      PGBTOP(JL,JG,JF)=PDGB(INDTP,2*JG-1,JF)
244    ENDDO
245  ENDDO
246ENDDO
247
248
249DO JK=1,KLEV
250  DO JL=KIDIA,KFDIA
251    ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
252    IXTX = MAX( 1, MIN( INT(MXIXT), INT( ZDST1 + _ONE_ ) ) )
253    ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
254    IF (ZDSTX < _HALF_) THEN
255      INDT=IXTX
256    ELSE
257      INDT=IXTX+1
258    ENDIF
259    INDB(JL)=INDT
260  ENDDO
261
262  DO JF=1,2
263    DO JL=KIDIA,KFDIA
264      INDT=INDB(JL)
265      DO JG=1,NIPD
266        PGA(JL,JG,JF,JK)=PDGA(INDT,2*JG,JF)
267        PGB(JL,JG,JF,JK)=PDGB(INDT,2*JG,JF)
268      ENDDO
269    ENDDO
270  ENDDO
271
272
273ENDDO
274
275!     ------------------------------------------------------------------
276
277RETURN
278END SUBROUTINE LWB
Note: See TracBrowser for help on using the repository browser.