-
Notifications
You must be signed in to change notification settings - Fork 0
/
rrtmg_sw_vrtqdr.f90.optimize
173 lines (151 loc) · 7.59 KB
/
rrtmg_sw_vrtqdr.f90.optimize
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
! KGEN-generated Fortran source file
!
! Filename : rrtmg_sw_vrtqdr.f90
! Generated at: 2015-07-31 21:01:00
! KGEN version: 0.4.13
MODULE rrtmg_sw_vrtqdr
USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
! --------------------------------------------------------------------------
! | |
! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). |
! | This software may be used, copied, or redistributed as long as it is |
! | not sold and this copyright notice is reproduced on each copy made. |
! | This model is provided as is without any express or implied warranties. |
! | (http://www.rtweb.aer.com/) |
! | |
! --------------------------------------------------------------------------
! ------- Modules -------
USE shr_kind_mod, ONLY: r8 => shr_kind_r8
! use parkind, only: jpim, jprb
! use parrrsw, only: ngptsw
IMPLICIT NONE
CONTAINS
! write subroutines
! No subroutines
! No module extern variables
! --------------------------------------------------------------------------
subroutine vrtqdr_sw(asap_start_col,asap_end_col,ncol, klev, kw, &
pref, prefd, ptra, ptrad, &
pdbt, prdnd, prup, prupd, ptdbt, &
pfd, pfu)
! --------------------------------------------------------------------------
! Purpose: This routine performs the vertical quadrature integration
!
! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
!
! Modifications.
!
! Original: H. Barker
! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
!
!-----------------------------------------------------------------------
! ------- Declarations -------
! Input
integer, intent (in) :: ncol,asap_start_col,asap_end_col
integer, intent (in) :: klev ! number of model layers
integer, intent (in) :: kw(ncol) ! g-point index
real(kind=r8), intent(in) :: pref(:,:) ! direct beam reflectivity
! Dimensions: (nlayers+1)
real(kind=r8), intent(in) :: prefd(:,:) ! diffuse beam reflectivity
! Dimensions: (nlayers+1)
real(kind=r8), intent(in) :: ptra(:,:) ! direct beam transmissivity
! Dimensions: (nlayers+1)
real(kind=r8), intent(in) :: ptrad(:,:) ! diffuse beam transmissivity
! Dimensions: (nlayers+1)
real(kind=r8), intent(in) :: pdbt(:,:)
! Dimensions: (nlayers+1)
real(kind=r8), intent(in) :: ptdbt(:,:)
! Dimensions: (nlayers+1)
real(kind=r8), intent(inout) :: prdnd(:,:)
! Dimensions: (nlayers+1)
real(kind=r8), intent(inout) :: prup(:,:)
! Dimensions: (nlayers+1)
real(kind=r8), intent(inout) :: prupd(:,:)
! Dimensions: (nlayers+1)
! Output
real(kind=r8), intent(out) :: pfd(:,:,:) ! downwelling flux (W/m2)
! Dimensions: (nlayers+1,ngptsw)
! unadjusted for earth/sun distance or zenith angle
real(kind=r8), intent(out) :: pfu(:,:,:) ! upwelling flux (W/m2)
! Dimensions: (nlayers+1,ngptsw)
! unadjusted for earth/sun distance or zenith angle
! Local
integer :: ikp, ikx, jk
integer :: icol
real(kind=r8) :: zreflect
real(kind=r8) :: ztdn(ncol,klev+1)
! Definitions
!
! pref(jk) direct reflectance
! prefd(jk) diffuse reflectance
! ptra(jk) direct transmittance
! ptrad(jk) diffuse transmittance
!
! pdbt(jk) layer mean direct beam transmittance
! ptdbt(jk) total direct beam transmittance at levels
!
!-----------------------------------------------------------------------------
! Link lowest layer with surface
!dir$ VECTOR ALIGNED
!dir$ SIMD
do icol=asap_start_col,asap_end_col
zreflect = 1._r8 / (1._r8 - prefd(icol,klev+1) * prefd(icol,klev))
prup(icol,klev) = pref(icol,klev) + (ptrad(icol,klev) * &
((ptra(icol,klev) - pdbt(icol,klev)) * prefd(icol,klev+1) + &
pdbt(icol,klev) * pref(icol,klev+1))) * zreflect
prupd(icol,klev) = prefd(icol,klev) + ptrad(icol,klev) * ptrad(icol,klev) * &
prefd(icol,klev+1) * zreflect
! Pass from bottom to top
end do
do jk = 1,klev-1
!dir$ vector aligned
!dir$ SIMD
do icol=asap_start_col,asap_end_col
ikp = klev+1-jk
ikx = ikp-1
zreflect = 1._r8 / (1._r8 -prupd(icol,ikp) * prefd(icol,ikx))
prup(icol,ikx) = pref(icol,ikx) + (ptrad(icol,ikx) * &
((ptra(icol,ikx) - pdbt(icol,ikx)) * prupd(icol,ikp) + &
pdbt(icol,ikx) * prup(icol,ikp))) * zreflect
prupd(icol,ikx) = prefd(icol,ikx) + ptrad(icol,ikx) * ptrad(icol,ikx) * &
prupd(icol,ikp) * zreflect
enddo
enddo
! Upper boundary conditions
!dir$ vector aligned
!dir$ SIMD
do icol=asap_start_col,asap_end_col
ztdn(icol,1) = 1._r8
prdnd(icol,1) = 0._r8
ztdn(icol,2) = ptra(icol,1)
prdnd(icol,2) = prefd(icol,1)
! Pass from top to bottom
end do
do jk = 2,klev
!dir$ vector aligned
!dir$ SIMD
do icol=asap_start_col,asap_end_col
ikp = jk+1
zreflect = 1._r8 / (1._r8 - prefd(icol,jk) * prdnd(icol,jk))
ztdn(icol,ikp) = ptdbt(icol,jk) * ptra(icol,jk) + &
(ptrad(icol,jk) * ((ztdn(icol,jk) - ptdbt(icol,jk)) + &
ptdbt(icol,jk) * pref(icol,jk) * prdnd(icol,jk))) * zreflect
prdnd(icol,ikp) = prefd(icol,jk) + ptrad(icol,jk) * ptrad(icol,jk) * &
prdnd(icol,jk) * zreflect
enddo
end do
! Up and down-welling fluxes at levels
do jk = 1,klev+1
!dir$ vector aligned
!dir$ SIMD
do icol=asap_start_col,asap_end_col
zreflect = 1._r8 / (1._r8 - prdnd(icol,jk) * prupd(icol,jk))
pfu(icol,jk,kw(icol)) = (ptdbt(icol,jk) * prup(icol,jk) + &
(ztdn(icol,jk) - ptdbt(icol,jk)) * prupd(icol,jk)) * zreflect
pfd(icol,jk,kw(icol)) = ptdbt(icol,jk) + (ztdn(icol,jk) - ptdbt(icol,jk)+ &
ptdbt(icol,jk) * prup(icol,jk) * prdnd(icol,jk)) * zreflect
enddo
end do
end subroutine vrtqdr_sw
end module rrtmg_sw_vrtqdr