source: LMDZ5/trunk/libf/phymar/swu.F90 @ 5154

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

Inclusion de la physique de MAR


Integration of MAR physics

File size: 6.0 KB
Line 
1!OPTIONS XOPT(HSFUN)
2SUBROUTINE SWU &
3  &( KIDIA, KFDIA , KLON  , KLEV &
4  &, PSCT , PCARDI, PCLDSW, PPMB , PPSOL, PRMU0, PTAVE, PWV &
5  &, PAKI , PCLD  , PCLEAR, PDSIG, PFACT, PRMU , PSEC , PUD &
6  &)
7
8!**** *SWU* - SHORTWAVE RADIATION, ABSORBER AMOUNTS
9
10!     PURPOSE.
11!     --------
12!           COMPUTES THE ABSORBER AMOUNTS USED IN SHORTWAVE RADIATION
13!     CALCULATIONS
14
15!**   INTERFACE.
16!     ----------
17!          *SWU* IS CALLED BY *SW*
18
19
20!        IMPLICIT ARGUMENTS :
21!        --------------------
22
23!     ==== INPUTS ===
24!     ==== OUTPUTS ===
25
26!     METHOD.
27!     -------
28
29!          1. COMPUTES ABSORBER AMOUNTS WITH TEMPERATURE AND PRESSURE
30!     SCALING.
31
32!     EXTERNALS.
33!     ----------
34
35!          *SWTT*
36
37!     REFERENCE.
38!     ----------
39
40!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
41!        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
42
43!     AUTHOR.
44!     -------
45!        JEAN-JACQUES MORCRETTE  *ECMWF*
46
47!     MODIFICATIONS.
48!     --------------
49!        ORIGINAL : 89-07-14
50
51!     ------------------------------------------------------------------
52
53
54#include "tsmbkind.h"
55
56USE YOECLD   , ONLY : REPSEC
57USE YOERAD   , ONLY : NOVLP    ,NSW
58USE YOERDU   , ONLY : REPSCQ
59USE YOESW    , ONLY : RPDH1    ,RPDU1    ,RPNH     ,RPNU     ,&
60            &RTDH2O   ,RTDUMG   ,RTH2O    ,RTUMG
61USE YOEOVLP  , ONLY : RA1OVLP
62
63
64IMPLICIT NONE
65
66
67!     DUMMY INTEGER SCALARS
68INTEGER_M :: KFDIA
69INTEGER_M :: KIDIA
70INTEGER_M :: KKIND
71INTEGER_M :: KLEV
72INTEGER_M :: KLON
73
74!     DUMMY REAL SCALARS
75REAL_B :: PCARDI
76REAL_B :: PSCT
77
78
79
80!     ------------------------------------------------------------------
81
82!*       0.1   ARGUMENTS
83!              ---------
84
85REAL_B :: PCLDSW(KLON,KLEV), PPMB(KLON,KLEV+1), PPSOL(KLON)&
86  &,  PRMU0(KLON)      , PTAVE(KLON,KLEV) , PWV(KLON,KLEV)
87
88REAL_B :: PAKI(KLON,2,NSW)&
89  &,  PCLD(KLON,KLEV)  , PCLEAR(KLON)&
90  &,  PDSIG(KLON,KLEV) , PFACT(KLON)      , PRMU(KLON)&
91  &,  PSEC(KLON)       , PUD(KLON,5,KLEV+1)
92 
93INTEGER_M :: INUIR 
94
95!     ------------------------------------------------------------------
96
97!*       0.2   LOCAL ARRAYS
98!              ------------
99
100INTEGER_M :: IIND(2)
101REAL_B :: ZC1J(KLON,KLEV+1),ZCLEAR(KLON),ZCLOUD(KLON)&
102  &,  ZN175(KLON), ZN190(KLON), ZO175(KLON)&
103  &,  ZO190(KLON), ZSIGN(KLON)&
104  &,  ZR(KLON,2) , ZSIGO(KLON), ZUD(KLON,2)
105
106!     LOCAL INTEGER SCALARS
107INTEGER_M :: JA, JK, JKL, JKLP1, JKP1, JL, JNU
108
109!     LOCAL REAL SCALARS
110REAL_B :: ZDSCO2, ZDSH2O, ZFPPW, ZRTH, ZRTU, ZWH2O, ZALPHA1
111
112
113!     ------------------------------------------------------------------
114
115!*         1.     COMPUTES AMOUNTS OF ABSORBERS
116!                 -----------------------------
117
118
119IIND(1)=1
120IIND(2)=2
121
122
123!*         1.1    INITIALIZES QUANTITIES
124!                 ----------------------
125
126
127DO JL = KIDIA,KFDIA
128  PUD(JL,1,KLEV+1)=_ZERO_
129  PUD(JL,2,KLEV+1)=_ZERO_
130  PUD(JL,3,KLEV+1)=_ZERO_
131  PUD(JL,4,KLEV+1)=_ZERO_
132  PUD(JL,5,KLEV+1)=_ZERO_
133  PFACT(JL)= PRMU0(JL) * PSCT
134!- already accounted for in RADINT     
135!      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
136  PRMU(JL)=PRMU0(JL)
137! Martin control
138!  PRINT*,'PRMU(',JL,')=',PRMU(JL)
139! Martin modif to avoid cos(sza)=0 for LMDZ:
140  IF (PRMU(JL) .LE. 1E-3) PRMU(JL) = 1E-3
141  PSEC(JL)=_ONE_/PRMU(JL)
142  ZC1J(JL,KLEV+1)=_ZERO_
143ENDDO
144
145!*          1.3    AMOUNTS OF ABSORBERS
146!                  --------------------
147
148
149DO JL= KIDIA,KFDIA
150  ZUD(JL,1) = _ZERO_
151  ZUD(JL,2) = _ZERO_
152  ZO175(JL) = PPSOL(JL)** RPDU1
153  ZO190(JL) = PPSOL(JL)** RPDH1
154  ZSIGO(JL) = PPSOL(JL)
155  ZCLEAR(JL)=_ONE_
156  ZCLOUD(JL)=_ZERO_
157ENDDO
158
159DO JK = 1 , KLEV
160  JKP1 = JK + 1
161  JKL = KLEV+1 - JK
162  JKLP1 = JKL+1
163  DO JL = KIDIA,KFDIA
164    ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
165    ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
166    ZWH2O = MAX (PWV(JL,JKL) , REPSCQ )
167    ZSIGN(JL) = 100._JPRB * PPMB(JL,JKP1)
168    PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
169    ZN175(JL) = ZSIGN(JL) ** RPDU1
170    ZN190(JL) = ZSIGN(JL) ** RPDH1
171    ZDSCO2 = ZO175(JL) - ZN175(JL)
172    ZDSH2O = ZO190(JL) - ZN190(JL)
173    PUD(JL,1,JK) = RPNH * ZDSH2O * ZWH2O  * ZRTH
174    PUD(JL,2,JK) = RPNU * ZDSCO2 * PCARDI * ZRTU
175    ZFPPW=1.6078_JPRB*ZWH2O/(_ONE_+0.608_JPRB*ZWH2O)
176    PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
177    PUD(JL,5,JK)=PUD(JL,1,JK)*(_ONE_-ZFPPW)
178    ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
179    ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
180    ZSIGO(JL) = ZSIGN(JL)
181    ZO175(JL) = ZN175(JL)
182    ZO190(JL) = ZN190(JL)
183
184    IF (NOVLP == 1) THEN
185      ZCLEAR(JL)=ZCLEAR(JL)&
186       &*(_ONE_-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))&
187       &/(_ONE_-MIN(ZCLOUD(JL),_ONE_-REPSEC))
188      ZC1J(JL,JKL)= _ONE_ - ZCLEAR(JL)
189      ZCLOUD(JL) = PCLDSW(JL,JKL)
190    ELSEIF (NOVLP == 2) THEN
191      ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
192      ZC1J(JL,JKL) = ZCLOUD(JL)
193    ELSEIF (NOVLP == 3) THEN
194      ZCLEAR(JL) = ZCLEAR(JL)*(_ONE_-PCLDSW(JL,JKL))
195      ZCLOUD(JL) = _ONE_ - ZCLEAR(JL)
196      ZC1J(JL,JKL) = ZCLOUD(JL)
197    ELSEIF (NOVLP == 4) THEN
198!** Hogan & Illingworth (2001)     
199      ZALPHA1=RA1OVLP(KLEV+1-JK)
200      ZCLEAR(JL)=ZCLEAR(JL)*( &
201        & ZALPHA1*(_ONE_-MAX(PCLDSW(JL,JKL),ZCLOUD(JL))) &
202        &        /(_ONE_-MIN(ZCLOUD(JL),_ONE_-REPSEC)) &
203        & +(_ONE_-ZALPHA1)*(_ONE_-PCLDSW(JL,JKL)) )
204      ZC1J(JL,JKL) = _ONE_ - ZCLEAR(JL)
205      ZCLOUD(JL) = PCLDSW(JL,JKL)
206    ENDIF
207  ENDDO
208ENDDO
209DO JL=KIDIA,KFDIA
210  PCLEAR(JL)=_ONE_-ZC1J(JL,1)
211ENDDO
212DO JK=1,KLEV
213  DO JL=KIDIA,KFDIA
214    IF (PCLEAR(JL) < _ONE_) THEN
215      PCLD(JL,JK)=PCLDSW(JL,JK)/(_ONE_-PCLEAR(JL))
216    ELSE
217      PCLD(JL,JK)=_ZERO_
218    ENDIF
219  ENDDO
220ENDDO
221
222
223!*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
224!                 -----------------------------------------------
225
226
227DO JA = 1,2
228  DO JL = KIDIA,KFDIA
229    ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
230  ENDDO
231ENDDO
232
233IF (NSW.LE.4) THEN
234  INUIR=2
235ELSE IF (NSW.EQ.6) THEN
236  INUIR=4
237END IF     
238
239
240DO JNU= INUIR,NSW
241
242  KKIND=2
243  CALL SWTT1 ( KIDIA,KFDIA,KLON, JNU, KKIND, IIND &
244   &, ZUD &
245   &, ZR                            )
246
247  DO JA = 1,2
248    DO JL = KIDIA,KFDIA
249      PAKI(JL,JA,JNU) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
250    ENDDO
251  ENDDO
252ENDDO
253
254
255!     ------------------------------------------------------------------
256
257RETURN
258END SUBROUTINE SWU
Note: See TracBrowser for help on using the repository browser.