source: LMDZ5/branches/IPSLCM6.0.11.rc1/libf/phymar/olwb.F90 @ 3152

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

Inclusion de la physique de MAR

Integration of MAR physics
File size: 7.0 KB
Line 
1SUBROUTINE OLWB &
2     &  ( KIDIA, KFDIA, KLON  , KLEV  &
3     &  , PDT0 , PT   , PTH &
4     &  , PB   , PBINT, PBSUIN, PBSUR , PBTOP , PDBSL &
5     &  , PGA  , PGB  , PGASUR, PGBSUR, PGATOP, PGBTOP )
6!
7!**** *LWB*   - COMPUTES BLACK-BODY FUNCTIONS FOR LONGWAVE CALCULATIONS
8!
9!     PURPOSE.
10!     --------
11!           COMPUTES PLANCK FUNCTIONS
12!
13!**   INTERFACE.
14!     ----------
15!
16!        EXPLICIT ARGUMENTS :
17!        --------------------
18!     ==== INPUTS ===
19! PDT0   : (KLON)             ; SURFACE TEMPERATURE DISCONTINUITY
20! PT     : (KLON,KLEV)        ; TEMPERATURE
21! PTH    : (KLON,KLEV+1)      ; HALF LEVEL TEMPERATURE
22!     ==== OUTPUTS ===
23! PB     : (KLON,NISP,KLEV+1) ; SPECTRAL HALF LEVEL PLANCK FUNCTION
24! PBINT  : (KLON,KLEV+1)      ; HALF LEVEL PLANCK FUNCTION
25! PBSUIN : (KLON)             ; SURFACE PLANCK FUNCTION
26! PBSUR  : (KLON,NISP)        ; SURFACE SPECTRAL PLANCK FUNCTION
27! PBTOP  : (KLON,NISP)        ; TOP SPECTRAL PLANCK FUNCTION
28! PDBSL  : (KLON,NISP,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!
62!-----------------------------------------------------------------------
63
64#include "tsmbkind.h"
65
66USE YOEOLW   , ONLY : MXIXT    ,NISP     ,NIPD     ,  GA     ,&
67            & GB     ,TINTP    ,TSTAND   ,TSTP     ,XP
68
69IMPLICIT NONE
70
71
72!     DUMMY INTEGER SCALARS
73INTEGER_M :: KFDIA
74INTEGER_M :: KIDIA
75INTEGER_M :: KLEV
76INTEGER_M :: KLON
77
78!-----------------------------------------------------------------------
79!
80!*       0.1   ARGUMENTS
81!              ---------
82!
83REAL_B :: PDT0(KLON), PT(KLON,KLEV), PTH(KLON,KLEV+1)
84!
85REAL_B :: PB(KLON,NISP,KLEV+1), PBINT(KLON,KLEV+1) &
86     &  ,  PBSUIN(KLON)       , PBSUR(KLON,NISP) &
87     &  ,  PBTOP(KLON,NISP)   , PDBSL(KLON,NISP,KLEV*2) &
88     &  ,  PGA(KLON,8,2,KLEV) , PGB(KLON,8,2,KLEV) &
89     &  ,  PGASUR(KLON,8,2)   , PGBSUR(KLON,8,2) &
90     &  ,  PGATOP(KLON,8,2)   , PGBTOP(KLON,8,2)
91!
92!-------------------------------------------------------------------------
93!
94!*       0.2   LOCAL ARRAYS
95!              ------------
96INTEGER_M :: INDB(KLON),INDS(KLON)
97
98REAL_B :: ZBLAY(KLON,KLEV),ZBLEV(KLON,KLEV+1) &
99     &  , ZRES(KLON),ZRES2(KLON),ZTI(KLON),ZTI2(KLON)
100     
101REAL_B :: ZDST1, ZDSTO1, ZDSTX, ZDSTOX
102     
103INTEGER_M :: ILEV2, INDSU, INDT, INDTP, INDTO, INUS, INUE, IXTOX, IXTX &
104     &  , JF, JG, JNU, JK, JK1, JK2, JL, IKL
105!
106!     ------------------------------------------------------------------
107!
108!
109!*         1.0     PLANCK FUNCTIONS AND GRADIENTS
110!                  ------------------------------
111!
112ILEV2=2*KLEV
113INUS=1
114INUE=NISP
115       
116DO JK = 1 , KLEV+1
117  DO JL = KIDIA,KFDIA
118    PBINT(JL,JK) = 0.
119  END DO
120END DO
121DO JNU=1,NISP
122  DO JL=KIDIA,KFDIA
123    PBSUR(JL,JNU)=0.
124    PBTOP(JL,JNU)=0.
125  END DO
126  DO JK=1,KLEV
127    DO JL=KIDIA,KFDIA
128      PB(JL,JNU,JK)=0.
129    END DO
130  END DO
131  DO JK=1,ILEV2
132    DO JL=KIDIA,KFDIA
133      PDBSL(JL,JNU,JK)=0.
134    END DO 
135  END DO
136END DO
137DO JL = KIDIA,KFDIA
138  PBSUIN(JL) = 0.
139END DO
140!
141DO JNU=INUS,INUE
142!
143!
144!*         1.1   LEVELS FROM SURFACE TO KLEV
145!                ----------------------------
146!                TEMPERATURE ENTERED FROM TOP TO BOTTOM
147!
148  DO JK = 1 , KLEV
149    IKL=KLEV+1-JK
150    DO JL = KIDIA,KFDIA
151      ZTI(JL)=(PTH(JL,IKL+1)-TSTAND)/TSTAND
152      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) &
153      &       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) &
154      &       )))))
155      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
156      PB(JL,JNU,JK)= ZRES(JL)
157      ZBLEV(JL,JK) = ZRES(JL)
158     
159      ZTI2(JL)=(PT(JL,IKL)-TSTAND)/TSTAND
160      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) &
161      &     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) &
162      &       )))))
163      ZBLAY(JL,JK) = ZRES2(JL)
164    END DO
165  END DO
166!
167!
168!*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
169!                ---------------------------------
170!                TEMPERATURE ENTERED FROM TOP TO BOTTOM
171!
172  DO JL = KIDIA,KFDIA
173    ZTI(JL)=(PTH(JL,1)-TSTAND)/TSTAND
174    ZTI2(JL) = (PTH(JL,KLEV+1) + PDT0(JL) - TSTAND) / TSTAND
175    ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) &
176    &   +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) &
177    &      )))))
178    ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) &
179    &    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) &
180    &       )))))
181    PBINT(JL,KLEV+1) = PBINT(JL,KLEV+1)+ZRES(JL)
182    PB(JL,JNU,KLEV+1)= ZRES(JL)
183    ZBLEV(JL,KLEV+1) = ZRES(JL)
184    PBTOP(JL,JNU) = ZRES(JL)
185    PBSUR(JL,JNU) = ZRES2(JL)
186    PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
187  END DO
188!
189!
190!*         1.3   GRADIENTS IN SUB-LAYERS
191!                -----------------------
192!
193  DO JK = 1 , KLEV
194    JK2 = 2 * JK
195    JK1 = JK2 - 1
196    DO JL = KIDIA,KFDIA
197      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
198      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
199    END DO
200  END DO
201!
202END DO
203!
204!*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
205!                ---------------------------------------------
206!
207DO JL=KIDIA,KFDIA
208  ZDSTO1 = (PTH(JL,1)-TINTP(1)) / TSTP
209  IXTOX = MAX( 1, MIN( INT(MXIXT), INT( ZDSTO1 + 1. ) ) )
210  ZDSTOX = (PTH(JL,1)-TINTP(IXTOX))/TSTP
211  IF (ZDSTOX.LT.0.5) THEN
212    INDTO=IXTOX
213  ELSE
214    INDTO=IXTOX+1
215  END IF
216  INDB(JL)=INDTO
217 
218  ZDST1 = (PTH(JL,KLEV+1)-TINTP(1)) / TSTP
219  IXTX = MAX( 1, MIN( INT(MXIXT), INT( ZDST1 + 1. ) ) )
220  ZDSTX = (PTH(JL,KLEV+1)-TINTP(IXTX))/TSTP
221  IF (ZDSTX.LT.0.5) THEN
222    INDT=IXTX
223  ELSE
224    INDT=IXTX+1
225  END IF
226  INDS(JL)=INDT
227END DO
228!
229DO JF=1,2
230  DO JG=1, 8
231    DO JL=KIDIA,KFDIA
232      INDSU=INDS(JL)
233      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
234      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
235      INDTP=INDB(JL)
236      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
237      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
238    END DO
239  END DO
240END DO
241!
242DO JK=1,KLEV
243  IKL=KLEV+1-JK
244  DO JL=KIDIA,KFDIA
245    ZDST1 = (PT(JL,IKL)-TINTP(1)) / TSTP
246    IXTX = MAX( 1, MIN( INT(MXIXT), INT( ZDST1 + 1. ) ) )
247    ZDSTX = (PT(JL,IKL)-TINTP(IXTX))/TSTP
248    IF (ZDSTX.LT.0.5) THEN
249      INDT=IXTX
250    ELSE
251      INDT=IXTX+1
252    END IF
253    INDB(JL)=INDT
254  END DO
255!
256  DO JF=1,2
257    DO JG=1, 8
258      DO JL=KIDIA,KFDIA
259        INDT=INDB(JL)
260        PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
261        PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
262      END DO
263    END DO
264  END DO
265END DO
266!
267!     ------------------------------------------------------------------
268!
269RETURN
270END SUBROUTINE OLWB
Note: See TracBrowser for help on using the repository browser.