CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
GFS_surface_generic_post.F90
1
3
5
6 use machine, only: kind_phys
7
8 implicit none
9
10 private
11
13
14 real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys
15
16 contains
17
24 subroutine gfs_surface_generic_post_init (vtype, stype,scolor, slope, vtype_save, stype_save,scolor_save, slope_save, errmsg, errflg)
25
26 integer, dimension(:), intent(in) :: vtype_save, stype_save,scolor_save, slope_save
27 integer, dimension(:), intent(out) :: vtype, stype, scolor,slope
28
29 ! CCPP error handling
30 character(len=*), intent(out) :: errmsg
31 integer, intent(out) :: errflg
32
33 ! Initialize CCPP error handling variables
34 errmsg = ''
35 errflg = 0
36
37 ! Restore vegetation, soil and slope type
38 vtype(:) = vtype_save(:)
39 stype(:) = stype_save(:)
40 scolor(:) = scolor_save(:)
41 slope(:) = slope_save(:)
42
44
48 subroutine gfs_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpllnd, lssav, dry, icy, wet, &
49 lsm, lsm_noahmp, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, &
50 adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, &
51 adjvisbmu, adjvisdfu, t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, pah, pahi, &
52 epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, &
53 dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, &
54 v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, &
55 nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, paha, ep, ecan, etran, edir, waxy, &
56 runoff, srunoff, runof, drain, tecan, tetran, tedir, twa, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, &
57 isot, ivegsrc, islmsk, vtype, stype,scolor, slope, vtype_save, stype_save,scolor_save, slope_save, errmsg, errflg)
58
59 implicit none
60
61 integer, intent(in) :: im
62 logical, intent(in) :: cplflx, cplaqm, cplchm, cplwav, cpllnd, lssav
63 logical, dimension(:), intent(in) :: dry, icy, wet
64 integer, intent(in) :: lsm, lsm_noahmp
65 real(kind=kind_phys), intent(in) :: dtf
66
67 real(kind=kind_phys), dimension(:), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, &
68 adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, &
69 t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, pah, ecan, etran, edir
70 real(kind=kind_phys), dimension(:), intent(in), optional :: &
71 waxy
72
73 real(kind=kind_phys), dimension(:), intent(inout) :: epi, gfluxi, t1, q1, u1, v1,gflux, evbsa, &
74 evcwa, transa, sbsnoa, snowca, snohfa, ep, tecan, tetran, tedir
75 real(kind=kind_phys), dimension(:), intent(inout), optional :: pahi, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, &
76 dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, &
77 nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, &
78 nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, paha, twa
79
80 real(kind=kind_phys), dimension(:), intent(inout) :: runoff, srunoff
81 real(kind=kind_phys), dimension(:), intent(in) :: drain, runof
82
83 ! For canopy heat storage
84 logical, intent(in) :: lheatstrg
85 real(kind=kind_phys), intent(in) :: h0facu, h0facs
86 real(kind=kind_phys), dimension(:), intent(in) :: zvfun
87 real(kind=kind_phys), dimension(:), intent(in) :: hflx, evap
88 real(kind=kind_phys), dimension(:), intent(out) :: hflxq
89 real(kind=kind_phys), dimension(:), intent(out) :: hffac
90
91 integer, intent(in) :: isot, ivegsrc, islmsk(:), vtype_save(:), stype_save(:),scolor_save(:), slope_save(:)
92 integer, intent(out) :: vtype(:), stype(:),scolor(:), slope(:)
93
94 ! CCPP error handling variables
95 character(len=*), intent(out) :: errmsg
96 integer, intent(out) :: errflg
97
98 ! Local variables
99 real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys
100
101 integer :: i
102 real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl
103
104 ! Initialize CCPP error handling variables
105 errmsg = ''
106 errflg = 0
107
108 do i=1,im
109 epi(i) = ep1d(i)
110 gfluxi(i) = gflx(i)
111 if (lsm == lsm_noahmp) then
112 pahi(i) = pah(i)
113 endif
114 t1(i) = tgrs_1(i)
115 q1(i) = qgrs_1(i)
116 u1(i) = ugrs_1(i)
117 v1(i) = vgrs_1(i)
118 enddo
119
120 if (cplflx .or. cplchm .or. cplwav) then
121 do i=1,im
122 u10mi_cpl(i) = u10m(i)
123 v10mi_cpl(i) = v10m(i)
124 enddo
125 endif
126
127 if (cplflx .or. cplchm .or. cpllnd) then
128 do i=1,im
129 tsfci_cpl(i) = tsfc(i)
130 enddo
131 endif
132
133 if (cplflx .or. cpllnd) then
134 do i=1,im
135 dlwsfci_cpl(i) = adjsfcdlw(i)
136 dswsfci_cpl(i) = adjsfcdsw(i)
137 dlwsfc_cpl(i) = dlwsfc_cpl(i) + adjsfcdlw(i)*dtf
138 dswsfc_cpl(i) = dswsfc_cpl(i) + adjsfcdsw(i)*dtf
139 psurfi_cpl(i) = pgr(i)
140 enddo
141 endif
142
143 if (cplflx) then
144 do i=1,im
145 dnirbmi_cpl(i) = adjnirbmd(i)
146 dnirdfi_cpl(i) = adjnirdfd(i)
147 dvisbmi_cpl(i) = adjvisbmd(i)
148 dvisdfi_cpl(i) = adjvisdfd(i)
149 dnirbm_cpl(i) = dnirbm_cpl(i) + adjnirbmd(i)*dtf
150 dnirdf_cpl(i) = dnirdf_cpl(i) + adjnirdfd(i)*dtf
151 dvisbm_cpl(i) = dvisbm_cpl(i) + adjvisbmd(i)*dtf
152 dvisdf_cpl(i) = dvisdf_cpl(i) + adjvisdfd(i)*dtf
153 nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw(i)
154 if (wet(i)) then
155 nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw_wat(i)
156 endif
157 nlwsfc_cpl(i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf
158 t2mi_cpl(i) = t2m(i)
159 q2mi_cpl(i) = q2m(i)
160 enddo
161 endif
162
163! --- estimate mean albedo for ocean point without ice cover and apply
164! them to net SW heat fluxes
165
166 if (cplflx .or. cpllnd) then
167 do i=1,im
168! if (Sfcprop%landfrac(i) < one) then ! Not 100% land
169 if (wet(i)) then ! some open water
170! --- compute open water albedo
171 xcosz_loc = max( zero, min( one, xcosz(i) ))
172 ocalnirdf_cpl = 0.06_kind_phys
173 ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) &
174 & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) &
175 & * (xcosz_loc-one))
176 ocalvisdf_cpl = 0.06_kind_phys
177 ocalvisbm_cpl = ocalnirbm_cpl
178
179 nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl)
180 nnirdfi_cpl(i) = adjnirdfd(i) * (one-ocalnirdf_cpl)
181 nvisbmi_cpl(i) = adjvisbmd(i) * (one-ocalvisbm_cpl)
182 nvisdfi_cpl(i) = adjvisdfd(i) * (one-ocalvisdf_cpl)
183 else
184 nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i)
185 nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i)
186 nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i)
187 nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i)
188 endif
189 nswsfci_cpl(i) = nnirbmi_cpl(i) + nnirdfi_cpl(i) &
190 + nvisbmi_cpl(i) + nvisdfi_cpl(i)
191 nswsfc_cpl(i) = nswsfc_cpl(i) + nswsfci_cpl(i)*dtf
192 nnirbm_cpl(i) = nnirbm_cpl(i) + nnirbmi_cpl(i)*dtf
193 nnirdf_cpl(i) = nnirdf_cpl(i) + nnirdfi_cpl(i)*dtf
194 nvisbm_cpl(i) = nvisbm_cpl(i) + nvisbmi_cpl(i)*dtf
195 nvisdf_cpl(i) = nvisdf_cpl(i) + nvisdfi_cpl(i)*dtf
196 enddo
197 endif
198
199 if (cplaqm .and. .not.cplflx) then
200 do i=1,im
201 t2mi_cpl(i) = t2m(i)
202 q2mi_cpl(i) = q2m(i)
203 psurfi_cpl(i) = pgr(i)
204 if (wet(i)) then ! some open water
205! --- compute open water albedo
206 xcosz_loc = max( zero, min( one, xcosz(i) ))
207 ocalnirdf_cpl = 0.06_kind_phys
208 ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) &
209 & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) &
210 & * (xcosz_loc-one))
211 ocalvisdf_cpl = 0.06_kind_phys
212 ocalvisbm_cpl = ocalnirbm_cpl
213
214 nswsfci_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) + &
215 adjnirdfd(i) * (one-ocalnirdf_cpl) + &
216 adjvisbmd(i) * (one-ocalvisbm_cpl) + &
217 adjvisdfd(i) * (one-ocalvisdf_cpl)
218 else
219 nswsfci_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + &
220 adjnirdfd(i) - adjnirdfu(i) + &
221 adjvisbmd(i) - adjvisbmu(i) + &
222 adjvisdfd(i) - adjvisdfu(i)
223 endif
224 enddo
225 endif
226
227 if (lssav) then
228 do i=1,im
229 gflux(i) = gflux(i) + gflx(i) * dtf
230 evbsa(i) = evbsa(i) + evbs(i) * dtf
231 evcwa(i) = evcwa(i) + evcw(i) * dtf
232 transa(i) = transa(i) + trans(i) * dtf
233 sbsnoa(i) = sbsnoa(i) + sbsno(i) * dtf
234 snowca(i) = snowca(i) + snowc(i) * dtf
235 snohfa(i) = snohfa(i) + snohf(i) * dtf
236 ep(i) = ep(i) + ep1d(i) * dtf
237
238! --- ... total runoff is composed of drainage into water table and
239! runoff at the surface and is accumulated in unit of meters
240 runoff(i) = runoff(i) + (drain(i)+runof(i)) * dtf
241 srunoff(i) = srunoff(i) + runof(i) * dtf
242 tecan(i) = tecan(i) + ecan(i) * dtf
243 tetran(i) = tetran(i) + etran(i) * dtf
244 tedir(i) = tedir(i) + edir(i) * dtf
245 if (lsm == lsm_noahmp) then
246 paha(i) = paha(i) + pah(i) * dtf
247 twa(i) = waxy(i)
248 endif
249 enddo
250 endif
251
252!
253! in order to achieve heat storage within canopy layer, in the canopy
254! heat torage parameterization the kinematic sensible heat flux
255! (hflx) as surface boundary forcing to the pbl scheme is
256! reduced in a factor of hffac given as a function of surface roughness &
257! green vegetation fraction (zvfun)
258!
259 do i=1,im
260 hflxq(i) = hflx(i)
261 hffac(i) = 1.0
262 enddo
263 if (lheatstrg) then
264 do i=1,im
265 if (dry(i)) then
266 if(hflx(i) > 0.) then
267 hffac(i) = h0facu * zvfun(i)
268 else
269 hffac(i) = h0facs * zvfun(i)
270 endif
271 hffac(i) = 1. + hffac(i)
272 hflxq(i) = hflx(i) / hffac(i)
273 endif
274 enddo
275 endif
276
277 ! Restore vegetation, soil and slope type
278 vtype(:) = vtype_save(:)
279 stype(:) = stype_save(:)
280 scolor(:) = scolor_save(:)
281 slope(:) = slope_save(:)
282
283 end subroutine gfs_surface_generic_post_run
285 end module gfs_surface_generic_post
subroutine, public gfs_surface_generic_post_run(im, cplflx, cplaqm, cplchm, cplwav, cpllnd, lssav, dry, icy, wet, lsm, lsm_noahmp, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, pah, pahi, epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, paha, ep, ecan, etran, edir, waxy, runoff, srunoff, runof, drain, tecan, tetran, tedir, twa, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, isot, ivegsrc, islmsk, vtype, stype, scolor, slope, vtype_save, stype_save, scolor_save, slope_save, errmsg, errflg)
subroutine, public gfs_surface_generic_post_init(vtype, stype, scolor, slope, vtype_save, stype_save, scolor_save, slope_save, errmsg, errflg)