source: LMDZ6/branches/IPSLCM6.0.15/libf/phylmd/rrtm/srtm_vrtqdr.F90 @ 5234

Last change on this file since 5234 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: 5.2 KB
Line 
1#ifdef RS6K
2@PROCESS HOT NOSTRICT
3#endif
4SUBROUTINE SRTM_VRTQDR &
5 & ( KLEV , KW,&
6 & PREF , PREFD, PTRA , PTRAD,&
7 & PDBT , PRDND, PRUP , PRUPD , PTDBT,&
8 & PFD  , PFU  &
9 & ) 
10 
11!**** *SRTM_VRTQDR* - VERTICAL QUADRATURE
12
13!     PURPOSE.
14!     --------
15
16!          THIS ROUTINE PERFORMS THE VERTICAL INTEGRATION
17
18!**   INTERFACE.
19!     ----------
20
21!          *SRTM_VRTQDR* IS CALLED FROM *SRTM_SPCVRT*
22
23!        IMPLICIT ARGUMENTS :
24!        --------------------
25
26!     ==== INPUTS ===
27!     ==== OUTPUTS ===
28
29!     METHOD.
30!     -------
31
32!     EXTERNALS.
33!     ----------
34!          NONE
35
36!     REFERENCE.
37!     ----------
38
39!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
40!        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
41
42!     AUTHOR.
43!     -------
44!        from Howard Barker
45!        JEAN-JACQUES MORCRETTE  *ECMWF*
46
47!     MODIFICATIONS.
48!     --------------
49!        ORIGINAL : 02-10-04
50!        M.Hamrud      01-Oct-2003 CY28 Cleaning
51!     ------------------------------------------------------------------
52
53USE PARKIND1  ,ONLY : JPIM     ,JPRB
54USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
55
56USE PARSRTM  , ONLY : JPLAY, JPGPT
57
58!USE YOESWN   , ONLY : NDBUG
59
60IMPLICIT NONE
61
62!     ------------------------------------------------------------------
63
64!*       0.1   ARGUMENTS
65!              ---------
66
67INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
68INTEGER(KIND=JPIM),INTENT(IN)    :: KW
69REAL(KIND=JPRB)   ,INTENT(IN)    :: PREF(JPLAY+1)
70REAL(KIND=JPRB)   ,INTENT(IN)    :: PREFD(JPLAY+1)
71REAL(KIND=JPRB)   ,INTENT(IN)    :: PTRA(JPLAY+1)
72REAL(KIND=JPRB)   ,INTENT(IN)    :: PTRAD(JPLAY+1)
73REAL(KIND=JPRB)   ,INTENT(IN)    :: PDBT(JPLAY+1)
74REAL(KIND=JPRB)   ,INTENT(OUT)   :: PRDND(JPLAY+1)
75REAL(KIND=JPRB)   ,INTENT(INOUT) :: PRUP(JPLAY+1)
76REAL(KIND=JPRB)   ,INTENT(INOUT) :: PRUPD(JPLAY+1)
77REAL(KIND=JPRB)   ,INTENT(IN)    :: PTDBT(JPLAY+1)
78REAL(KIND=JPRB)   ,INTENT(INOUT)   :: PFD(JPLAY+1,JPGPT)
79REAL(KIND=JPRB)   ,INTENT(INOUT)   :: PFU(JPLAY+1,JPGPT)
80!     ------------------------------------------------------------------
81
82!              ------------
83
84REAL(KIND=JPRB) :: ZTDN(JPLAY+1) 
85
86INTEGER(KIND=JPIM) :: IKP, IKX, JK, I_NDBUG
87
88REAL(KIND=JPRB) :: ZREFLECT
89REAL(KIND=JPRB) :: ZHOOK_HANDLE
90
91!     ------------------------------------------------------------------
92
93! PREF(JK)   direct reflectance
94! PREFD(JK)  diffuse reflectance
95! PTRA(JK)   direct transmittance
96! PTRAD(JK)  diffuse transmittance
97
98! PDBT(JK)   layer mean direct beam transmittance
99! PTDBT(JK)  total direct beam transmittance at levels
100                   
101IF (LHOOK) CALL DR_HOOK('SRTM_VRTQDR',0,ZHOOK_HANDLE)
102I_NDBUG=3
103   
104!-- link lowest layer with surface
105             
106ZREFLECT=1.0_JPRB / (1.0_JPRB -PREFD(KLEV+1)*PREFD(KLEV))
107PRUP(KLEV)=PREF(KLEV)+(PTRAD(KLEV)* &
108 & ((PTRA(KLEV)-PDBT(KLEV))*PREFD(KLEV+1)+ &
109 & PDBT(KLEV)*PREF(KLEV+1)))*ZREFLECT 
110PRUPD(KLEV)=PREFD(KLEV)+PTRAD(KLEV)* &
111 & PTRAD(KLEV)*PREFD(KLEV+1)*ZREFLECT 
112
113!IF (NDBUG.LE.1) THEN
114!  print 9201,PRUP(KLEV),PRUPD(KLEV)
1159201 format(1x,'link surf:',6E13.6)
116!  print *,'SRTM_VRTQDR after linking with surface layer'
117!END IF
118   
119!-- pass from bottom to top
120
121DO JK=1,KLEV-1
122  IKP=KLEV+1-JK                       
123  IKX=IKP-1
124!  print 9202,JK,IKP,IKX
125  9202  format(1x,'Pass from bottom to top:',3I3)     
126  ZREFLECT=1.0_JPRB / (1.0_JPRB -PRUPD(IKP)*PREFD(IKX))
127  PRUP(IKX)=PREF(IKX)+(PTRAD(IKX)* &
128   & ((PTRA(IKX)-PDBT(IKX))*PRUPD(IKP)+ &
129   & PDBT(IKX)*PRUP(IKP)))*ZREFLECT 
130  PRUPD(IKX)=PREFD(IKX)+PTRAD(IKX)* &
131   & PTRAD(IKX)*PRUPD(IKP)*ZREFLECT 
132
133!  print 9203,PRUP(IKX),PRUPD(IKX)
134  9203 format(1x,'bot2top:',6E13.6)
135ENDDO
136!print *,'SRTM_VRTQDR after passing from bottom to top'
137   
138!-- upper boundary conditions
139
140ZTDN(1)=1.0_JPRB
141PRDND(1)=0.0_JPRB
142ZTDN(2)=PTRA(1)
143PRDND(2)=PREFD(1)
144
145!IF (NDBUG.LE.1) THEN
146!  print 9204,ZTDN(1),PRDND(1),ZTDN(2),PRDND(2)
1479204 format(1x,'link upper bound:',6E13.6)
148!  print *,'SRTM_VRTQDR after upper boundary conditions'
149!END IF
150   
151!-- pass from top to bottom
152
153DO JK=2,KLEV
154  IKP=JK+1
155  ZREFLECT=1.0_JPRB / (1.0_JPRB -PREFD(JK)*PRDND(JK))
156  ZTDN(IKP)=PTDBT(JK)*PTRA(JK)+ &
157   & (PTRAD(JK)*((ZTDN(JK)-PTDBT(JK))+ &
158   & PTDBT(JK)*PREF(JK)*PRDND(JK))) * ZREFLECT 
159  PRDND(IKP)=PREFD(JK)+PTRAD(JK)*PTRAD(JK) &
160   & *PRDND(JK)*ZREFLECT 
161
162!  IF (NDBUG.LE.1) THEN
163!    print 9205,ZTDN(IKP),PRDND(IKP)
164  9205 format(1x,'top2bot2:',6E13.6)
165!  END IF
166
167ENDDO
168!print *,'SRTM_VRTQDR after passing from top to bottom'
169                                             
170!-- up and down-welling fluxes at levels
171
172DO JK=1,KLEV+1
173!  IF (NDBUG.LE.1) THEN
174!    print 9207,JK,PRDND(JK),PRUPD(JK)
175!    print 9208,JK,PTDBT(JK),PRUP(JK),ZTDN(JK)
176  9207 format(1x,'A',I3,4E13.6)     
177  9208 format(1x,'B',I3,4E13.6)     
178!  END IF
179
180  ZREFLECT=1.0_JPRB / (1.0_JPRB - PRDND(JK)*PRUPD(JK))
181  PFU(JK,KW)=(PTDBT(JK)*PRUP(JK) + &
182   & (ZTDN(JK)-PTDBT(JK))*PRUPD(JK))*ZREFLECT 
183  PFD(JK,KW)=PTDBT(JK) + (ZTDN(JK)-PTDBT(JK)+ &
184   & PTDBT(JK)*PRUP(JK)*PRDND(JK))*ZREFLECT 
185
186!  IF (NDBUG.LE.2) THEN
187!    print 9206,JK,PFU(JK,KW),PFD(JK,KW)
188  9206 format(1x,'fluxes:',I3,6E13.6)
189!  END IF
190
191ENDDO
192!print *,'SRTM_VRTQDR after up and down flux'
193   
194!print *,'SRTM_VRTQDR about to come out'
195!     ------------------------------------------------------------------
196
197IF (LHOOK) CALL DR_HOOK('SRTM_VRTQDR',1,ZHOOK_HANDLE)
198END SUBROUTINE SRTM_VRTQDR
199
Note: See TracBrowser for help on using the repository browser.