GCC Code Coverage Report

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