ROMS
Loading...
Searching...
No Matches
Functions/Subroutines
tl_biology_mod Module Reference

Functions/Subroutines

subroutine, public tl_biology (ng, tile)
 
subroutine tl_npzd_franks_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, ubt, imins, imaxs, jmins, jmaxs, nstp, nnew, rmask, hz, tl_hz, z_r, tl_z_r, z_w, tl_z_w, t, tl_t)
 
subroutine tl_npzd_iron_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, ubt, imins, imaxs, jmins, jmaxs, nstp, nnew, rmask, h, hz, tl_hz, z_r, tl_z_r, z_w, tl_z_w, srflx, tl_srflx, t, tl_t)
 
subroutine tl_npzd_powell_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, ubt, imins, imaxs, jmins, jmaxs, nstp, nnew, rmask, hz, tl_hz, z_r, tl_z_r, z_w, tl_z_w, srflx, tl_srflx, t, tl_t)
 

Function/Subroutine Documentation

◆ tl_biology()

subroutine public tl_biology_mod::tl_biology ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 31 of file tl_npzd_Franks.h.

32!***********************************************************************
33!
34 USE mod_param
35 USE mod_grid
36 USE mod_ncparam
37 USE mod_ocean
38 USE mod_stepping
39!
40! Imported variable declarations.
41!
42 integer, intent(in) :: ng, tile
43!
44! Local variable declarations.
45!
46 character (len=*), parameter :: MyFile = &
47 & __FILE__
48!
49#include "tile.h"
50!
51! Set header file name.
52!
53#ifdef DISTRIBUTE
54 IF (lbiofile(itlm)) THEN
55#else
56 IF (lbiofile(itlm).and.(tile.eq.0)) THEN
57#endif
58 lbiofile(itlm)=.false.
59 bioname(itlm)=myfile
60 END IF
61!
62#ifdef PROFILE
63 CALL wclock_on (ng, itlm, 15, __line__, myfile)
64#endif
65 CALL tl_npzd_franks_tile (ng, tile, &
66 & lbi, ubi, lbj, ubj, n(ng), nt(ng), &
67 & imins, imaxs, jmins, jmaxs, &
68 & nstp(ng), nnew(ng), &
69#ifdef MASKING
70 & grid(ng) % rmask, &
71#endif
72 & grid(ng) % Hz, &
73 & grid(ng) % tl_Hz, &
74 & grid(ng) % z_r, &
75 & grid(ng) % tl_z_r, &
76 & grid(ng) % z_w, &
77 & grid(ng) % tl_z_w, &
78 & ocean(ng) % t, &
79 & ocean(ng) % tl_t)
80
81#ifdef PROFILE
82 CALL wclock_off (ng, itlm, 15, __line__, myfile)
83#endif
84!
85 RETURN
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_ncparam
Definition mod_ncparam.F:2
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param
Definition mod_param.F:2
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_stepping
Definition mod_stepping.F:2
mod_stepping::nnew
integer, dimension(:), allocatable nnew
Definition mod_stepping.F:69
mod_stepping::nstp
integer, dimension(:), allocatable nstp
Definition mod_stepping.F:71
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References mod_grid::grid, mod_param::itlm, mod_param::n, mod_stepping::nnew, mod_stepping::nstp, mod_param::nt, mod_ocean::ocean, tl_npzd_franks_tile(), wclock_off(), and wclock_on().

Referenced by tl_main3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ tl_npzd_franks_tile()

subroutine tl_biology_mod::tl_npzd_franks_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) ubt,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) tl_hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) tl_z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk), intent(in) z_w,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk), intent(in) tl_z_w,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(in) t,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) tl_t )
private

Definition at line 89 of file tl_npzd_Franks.h.

100!-----------------------------------------------------------------------
101!
102 USE mod_param
103 USE mod_biology
104 USE mod_ncparam
105 USE mod_scalars
106!
107! Imported variable declarations.
108!
109 integer, intent(in) :: ng, tile
110 integer, intent(in) :: LBi, UBi, LBj, UBj, UBk, UBt
111 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
112 integer, intent(in) :: nstp, nnew
113
114#ifdef ASSUMED_SHAPE
115# ifdef MASKING
116 real(r8), intent(in) :: rmask(LBi:,LBj:)
117# endif
118 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
119 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
120 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
121 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
122
123 real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:)
124 real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:)
125 real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:)
126 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
127#else
128# ifdef MASKING
129 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
130# endif
131 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,UBk)
132 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,UBk)
133 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:UBk)
134 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,UBk,3,UBt)
135
136 real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,UBk)
137 real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,UBk)
138 real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:UBk)
139 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,UBk,3,UBt)
140#endif
141!
142! Local variable declarations.
143!
144 integer, parameter :: Nsink = 1
145
146 integer :: Iter, i, ibio, isink, itrc, itrmx, j, k, ks
147 integer :: Iteradj
148
149 integer, dimension(Nsink) :: idsink
150
151 real(r8), parameter :: eps = 1.0e-16_r8
152
153 real(r8) :: cff, cff1, cff2, cff3, dtdays
154 real(r8) :: tl_cff, tl_cff1
155 real(r8) :: cffL, cffR, cu, dltL, dltR
156 real(r8) :: tl_cffL, tl_cffR, tl_cu, tl_dltL, tl_dltR
157
158 real(r8), dimension(Nsink) :: Wbio
159 real(r8), dimension(Nsink) :: tl_Wbio
160
161 integer, dimension(IminS:ImaxS,N(ng)) :: ksource
162
163 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio
164 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio1
165 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio_old
166
167 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: tl_Bio
168 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: tl_Bio_old
169
170 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
171 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FC
172
173 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv
174 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv2
175 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv3
176 real(r8), dimension(IminS:ImaxS,N(ng)) :: WL
177 real(r8), dimension(IminS:ImaxS,N(ng)) :: WR
178 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL
179 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL1
180 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR
181 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR1
182 real(r8), dimension(IminS:ImaxS,N(ng)) :: qc
183
184 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv
185 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv2
186 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv3
187 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_WL
188 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_WR
189 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_bL
190 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_bR
191 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_qc
192
193#include "set_bounds.h"
194!
195!-----------------------------------------------------------------------
196! Add biological Source/Sink terms.
197!-----------------------------------------------------------------------
198!
199! Avoid computing source/sink terms if no biological iterations.
200!
201 IF (bioiter(ng).le.0) RETURN
202!
203! Set time-stepping according to the number of iterations.
204!
205 dtdays=dt(ng)*sec2day/real(bioiter(ng),r8)
206!
207! Set vertical sinking indentification vector.
208!
209 idsink(1)=isdet ! Small detritus
210!
211! Set vertical sinking velocity vector in the same order as the
212! identification vector, IDSINK.
213!
214 wbio(1)=wdet(ng) ! Small detritus
215 tl_wbio(1)=tl_wdet(ng) ! Small detritus
216!
217 j_loop : DO j=jstr,jend
218!
219! Compute inverse thickness to avoid repeated divisions.
220!
221 DO k=1,n(ng)
222 DO i=istr,iend
223 hz_inv(i,k)=1.0_r8/hz(i,j,k)
224 tl_hz_inv(i,k)=-hz_inv(i,k)*hz_inv(i,k)*tl_hz(i,j,k)
225 END DO
226 END DO
227 DO k=1,n(ng)-1
228 DO i=istr,iend
229 hz_inv2(i,k)=1.0_r8/(hz(i,j,k)+hz(i,j,k+1))
230 tl_hz_inv2(i,k)=-hz_inv2(i,k)*hz_inv2(i,k)* &
231 & (tl_hz(i,j,k)+tl_hz(i,j,k+1))
232 END DO
233 END DO
234 DO k=2,n(ng)-1
235 DO i=istr,iend
236 hz_inv3(i,k)=1.0_r8/(hz(i,j,k-1)+hz(i,j,k)+hz(i,j,k+1))
237 tl_hz_inv3(i,k)=-hz_inv3(i,k)*hz_inv3(i,k)* &
238 & (tl_hz(i,j,k-1)+tl_hz(i,j,k)+ &
239 & tl_hz(i,j,k+1))
240 END DO
241 END DO
242!
243! Clear tl_Bio and Bio arrays.
244!
245 DO itrc=1,nbt
246 ibio=idbio(itrc)
247 DO k=1,n(ng)
248 DO i=istr,iend
249 bio(i,k,ibio)=0.0_r8
250 bio1(i,k,ibio)=0.0_r8
251 tl_bio(i,k,ibio)=0.0_r8
252 END DO
253 END DO
254 END DO
255!
256! Extract biological variables from tracer arrays, place them into
257! scratch arrays, and restrict their values to be positive definite.
258! At input, all tracers (index nnew) from predictor step have
259! transport units (m Tunits) since we do not have yet the new
260! values for zeta and Hz. These are known after the 2D barotropic
261! time-stepping. In this routine, this is not a problem because
262! we only use index nstp in the right-hand-side equations.
263!
264 DO itrc=1,nbt
265 ibio=idbio(itrc)
266 DO k=1,n(ng)
267 DO i=istr,iend
268 bio_old(i,k,ibio)=t(i,j,k,nstp,ibio)
269 tl_bio_old(i,k,ibio)=tl_t(i,j,k,nstp,ibio)
270 END DO
271 END DO
272 END DO
273!
274! Determine Correction for negativity.
275!
276 DO k=1,n(ng)
277 DO i=istr,iend
278 cff1=max(0.0_r8,eps-bio_old(i,k,ino3_))+ &
279 & max(0.0_r8,eps-bio_old(i,k,iphyt))+ &
280 & max(0.0_r8,eps-bio_old(i,k,izoop))+ &
281 & max(0.0_r8,eps-bio_old(i,k,isdet))
282 tl_cff1=-(0.5_r8-sign(0.5_r8,bio_old(i,k,ino3_)-eps))* &
283 & tl_bio_old(i,k,ino3_)- &
284 & (0.5_r8-sign(0.5_r8,bio_old(i,k,iphyt)-eps))* &
285 & tl_bio_old(i,k,iphyt)- &
286 & (0.5_r8-sign(0.5_r8,bio_old(i,k,izoop)-eps))* &
287 & tl_bio_old(i,k,izoop)- &
288 & (0.5_r8-sign(0.5_r8,bio_old(i,k,isdet)-eps))* &
289 & tl_bio_old(i,k,isdet)
290!
291! If correction needed, determine the largest pool to debit.
292!
293 IF (cff1.gt.0.0) THEN
294 itrmx=idbio(1)
295 cff=t(i,j,k,nstp,itrmx)
296 DO ibio=idbio(2),idbio(nbt)
297 IF (t(i,j,k,nstp,ibio).gt.cff) THEN
298 itrmx=ibio
299 cff=t(i,j,k,nstp,ibio)
300 END IF
301 END DO
302!
303! Update new values.
304!
305 DO itrc=1,nbt
306 ibio=idbio(itrc)
307 bio(i,k,ibio)=max(eps,bio_old(i,k,ibio))- &
308 & cff1* &
309 & (sign(0.5_r8, real(itrmx-ibio,r8)**2)+ &
310 & sign(0.5_r8,-real(itrmx-ibio,r8)**2))
311 tl_bio(i,k,ibio)=(0.5_r8- &
312 & sign(0.5_r8,eps-bio_old(i,k,ibio)))* &
313 & tl_bio_old(i,k,ibio)- &
314 & tl_cff1* &
315 & (sign(0.5_r8, real(itrmx-ibio,r8)**2)+ &
316 & sign(0.5_r8,-real(itrmx-ibio,r8)**2))
317 END DO
318 ELSE
319 DO itrc=1,nbt
320 ibio=idbio(itrc)
321 bio(i,k,ibio)=bio_old(i,k,ibio)
322 tl_bio(i,k,ibio)=tl_bio_old(i,k,ibio)
323 END DO
324 END IF
325 END DO
326 END DO
327!
328!=======================================================================
329! Start internal iterations to achieve convergence of the nonlinear
330! backward-implicit solution.
331!=======================================================================
332!
333! During the iterative procedure a series of fractional time steps are
334! performed in a chained mode (splitting by different biological
335! conversion processes) in sequence of the main food chain. In all
336! stages the concentration of the component being consumed is treated
337! in a fully implicit manner, so the algorithm guarantees non-negative
338! values, no matter how strong the concentration of active consuming
339! component (Phytoplankton or Zooplankton). The overall algorithm,
340! as well as any stage of it, is formulated in conservative form
341! (except explicit sinking) in sense that the sum of concentration of
342! all components is conserved.
343!
344! In the implicit algorithm, we have for example (N: nutrient,
345! P: phytoplankton),
346!
347! N(new) = N(old) - uptake * P(old) uptake = mu * N / (Kn + N)
348! {Michaelis-Menten}
349! below, we set
350! The N in the numerator of
351! cff = mu * P(old) / (Kn + N(old)) uptake is treated implicitly
352! as N(new)
353!
354! so the time-stepping of the equations becomes:
355!
356! N(new) = N(old) / (1 + cff) (1) when substracting a sink term,
357! consuming, divide by (1 + cff)
358! and
359!
360! P(new) = P(old) + cff * N(new) (2) when adding a source term,
361! growing, add (cff * source)
362!
363! Notice that if you substitute (1) in (2), you will get:
364!
365! P(new) = P(old) + cff * N(old) / (1 + cff) (3)
366!
367! If you add (1) and (3), you get
368!
369! N(new) + P(new) = N(old) + P(old)
370!
371! implying conservation regardless how "cff" is computed. Therefore,
372! this scheme is unconditionally stable regardless of the conversion
373! rate. It does not generate negative values since the constituent
374! to be consumed is always treated implicitly. It is also biased
375! toward damping oscillations.
376!
377! The iterative loop below is to iterate toward an universal Backward-
378! Euler treatment of all terms. So if there are oscillations in the
379! system, they are only physical oscillations. These iterations,
380! however, do not improve the accuaracy of the solution.
381!
382 iter_loop: DO iter=1,bioiter(ng)
383!
384! Compute appropriate basic state arrays I.
385!
386! Determine Correction for negativity.
387!
388 DO k=1,n(ng)
389 DO i=istr,iend
390 cff1=max(0.0_r8,eps-bio_old(i,k,ino3_))+ &
391 & max(0.0_r8,eps-bio_old(i,k,iphyt))+ &
392 & max(0.0_r8,eps-bio_old(i,k,izoop))+ &
393 & max(0.0_r8,eps-bio_old(i,k,isdet))
394!
395! If correction needed, determine the largest pool to debit.
396!
397 IF (cff1.gt.0.0) THEN
398 itrmx=idbio(1)
399 cff=t(i,j,k,nstp,itrmx)
400 DO ibio=idbio(2),idbio(nbt)
401 IF (t(i,j,k,nstp,ibio).gt.cff) THEN
402 itrmx=ibio
403 cff=t(i,j,k,nstp,ibio)
404 END IF
405 END DO
406!
407! Update new values.
408!
409 DO itrc=1,nbt
410 ibio=idbio(itrc)
411 bio(i,k,ibio)=max(eps,bio_old(i,k,ibio))- &
412 & cff1*(sign(0.5_r8, &
413 & real(itrmx-ibio,r8)**2)+ &
414 & sign(0.5_r8, &
415 & -real(itrmx-ibio,r8)**2))
416 END DO
417 ELSE
418 DO itrc=1,nbt
419 ibio=idbio(itrc)
420 bio(i,k,ibio)=bio_old(i,k,ibio)
421 END DO
422 END IF
423 END DO
424 END DO
425!
426!=======================================================================
427! Start internal iterations to achieve convergence of the nonlinear
428! backward-implicit solution.
429!=======================================================================
430!
431 DO iteradj=1,iter
432!
433! Nutrient uptake by phytoplankton.
434!
435 cff1=dtdays*vm_no3(ng)
436 DO k=1,n(ng)
437 DO i=istr,iend
438 cff=bio(i,k,iphyt)* &
439 & cff1*exp(k_ext(ng)*z_r(i,j,k))/ &
440 & (k_no3(ng)+bio(i,k,ino3_))
441 bio1(i,k,ino3_)=bio(i,k,ino3_)
442 bio(i,k,ino3_)=bio(i,k,ino3_)/ &
443 & (1.0_r8+cff)
444 bio1(i,k,iphyt)=bio(i,k,iphyt)
445 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
446 & bio(i,k,ino3_)*cff
447 END DO
448 END DO
449!
450 IF (iteradj.ne.iter) THEN
451!
452! Phytoplankton grazing by Zooplankton and mortality to Detritus
453! (rate: PhyMR).
454!
455 cff1=dtdays*zoogr(ng)
456 cff2=dtdays*phymr(ng)
457 cff3=k_phy(ng)*k_phy(ng)
458 DO k=1,n(ng)
459 DO i=istr,iend
460 cff=bio(i,k,izoop)*bio(i,k,iphyt)*cff1/ &
461 & (cff3+bio(i,k,iphyt)*bio(i,k,iphyt))
462 bio1(i,k,iphyt)=bio(i,k,iphyt)
463 bio(i,k,iphyt)=bio(i,k,iphyt)/ &
464 & (1.0_r8+cff+cff2)
465 bio1(i,k,izoop)=bio(i,k,izoop)
466 bio(i,k,izoop)=bio(i,k,izoop)+ &
467 & bio(i,k,iphyt)*cff*(1.0_r8-zooga(ng))
468 bio(i,k,isdet)=bio(i,k,isdet)+ &
469 & bio(i,k,iphyt)* &
470 & (cff2+cff*(zooga(ng)-zooec(ng)))
471 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
472 & bio(i,k,iphyt)*cff*zooec(ng)
473 END DO
474 END DO
475!
476! Zooplankton excretion to nutrients and mortality to Detritus.
477!
478 cff1=1.0_r8/(1.0_r8+dtdays*(zoomr(ng)+zoomd(ng)))
479 cff2=dtdays*zoomr(ng)
480 cff3=dtdays*zoomd(ng)
481 DO k=1,n(ng)
482 DO i=istr,iend
483 bio(i,k,izoop)=bio(i,k,izoop)*cff1
484 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
485 & bio(i,k,izoop)*cff2
486 bio(i,k,isdet)=bio(i,k,isdet)+ &
487 & bio(i,k,izoop)*cff3
488 END DO
489 END DO
490!
491! Detritus breakdown to nutrients.
492!
493 cff1=dtdays*detrr(ng)
494 cff2=1.0_r8/(1.0_r8+cff1)
495 DO k=1,n(ng)
496 DO i=istr,iend
497 bio(i,k,isdet)=bio(i,k,isdet)*cff2
498 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
499 & bio(i,k,isdet)*cff1
500 END DO
501 END DO
502!
503!-----------------------------------------------------------------------
504! Vertical sinking terms.
505!-----------------------------------------------------------------------
506!
507! Reconstruct vertical profile of selected biological constituents
508! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
509! grid box. Then, compute semi-Lagrangian flux due to sinking.
510!
511 DO isink=1,nsink
512 ibio=idsink(isink)
513!
514! Copy concentration of biological particulates into scratch array
515! "qc" (q-central, restrict it to be positive) which is hereafter
516! interpreted as a set of grid-box averaged values for biogeochemical
517! constituent concentration.
518!
519 DO k=1,n(ng)
520 DO i=istr,iend
521 qc(i,k)=bio(i,k,ibio)
522 END DO
523 END DO
524!
525 DO k=n(ng)-1,1,-1
526 DO i=istr,iend
527 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
528 END DO
529 END DO
530 DO k=2,n(ng)-1
531 DO i=istr,iend
532 dltr=hz(i,j,k)*fc(i,k)
533 dltl=hz(i,j,k)*fc(i,k-1)
534 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
535 cffr=cff*fc(i,k)
536 cffl=cff*fc(i,k-1)
537!
538! Apply PPM monotonicity constraint to prevent oscillations within the
539! grid box.
540!
541 IF ((dltr*dltl).le.0.0_r8) THEN
542 dltr=0.0_r8
543 dltl=0.0_r8
544 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
545 dltr=cffl
546 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
547 dltl=cffr
548 END IF
549!
550! Compute right and left side values (bR,bL) of parabolic segments
551! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
552!
553! NOTE: Although each parabolic segment is monotonic within its grid
554! box, monotonicity of the whole profile is not guaranteed,
555! because bL(k+1)-bR(k) may still have different sign than
556! qc(i,k+1)-qc(i,k). This possibility is excluded,
557! after bL and bR are reconciled using WENO procedure.
558!
559 cff=(dltr-dltl)*hz_inv3(i,k)
560 dltr=dltr-cff*hz(i,j,k+1)
561 dltl=dltl+cff*hz(i,j,k-1)
562 br(i,k)=qc(i,k)+dltr
563 bl(i,k)=qc(i,k)-dltl
564 wr(i,k)=(2.0_r8*dltr-dltl)**2
565 wl(i,k)=(dltr-2.0_r8*dltl)**2
566 END DO
567 END DO
568 cff=1.0e-14_r8
569 DO k=2,n(ng)-2
570 DO i=istr,iend
571 dltl=max(cff,wl(i,k ))
572 dltr=max(cff,wr(i,k+1))
573 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
574 bl(i,k+1)=br(i,k)
575 END DO
576 END DO
577 DO i=istr,iend
578 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
579#if defined LINEAR_CONTINUATION
580 bl(i,n(ng))=br(i,n(ng)-1)
581 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
582#elif defined NEUMANN
583 bl(i,n(ng))=br(i,n(ng)-1)
584 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
585#else
586 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
587 bl(i,n(ng))=qc(i,n(ng)) ! conditions
588 br(i,n(ng)-1)=qc(i,n(ng))
589#endif
590#if defined LINEAR_CONTINUATION
591 br(i,1)=bl(i,2)
592 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
593#elif defined NEUMANN
594 br(i,1)=bl(i,2)
595 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
596#else
597 bl(i,2)=qc(i,1) ! bottom grid boxes are
598 br(i,1)=qc(i,1) ! re-assumed to be
599 bl(i,1)=qc(i,1) ! piecewise constant.
600#endif
601 END DO
602!
603! Apply monotonicity constraint again, since the reconciled interfacial
604! values may cause a non-monotonic behavior of the parabolic segments
605! inside the grid box.
606!
607 DO k=1,n(ng)
608 DO i=istr,iend
609 dltr=br(i,k)-qc(i,k)
610 dltl=qc(i,k)-bl(i,k)
611 cffr=2.0_r8*dltr
612 cffl=2.0_r8*dltl
613 IF ((dltr*dltl).lt.0.0_r8) THEN
614 dltr=0.0_r8
615 dltl=0.0_r8
616 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
617 dltr=cffl
618 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
619 dltl=cffr
620 END IF
621 br(i,k)=qc(i,k)+dltr
622 bl(i,k)=qc(i,k)-dltl
623 END DO
624 END DO
625!
626! After this moment reconstruction is considered complete. The next
627! stage is to compute vertical advective fluxes, FC. It is expected
628! that sinking may occurs relatively fast, the algorithm is designed
629! to be free of CFL criterion, which is achieved by allowing
630! integration bounds for semi-Lagrangian advective flux to use as
631! many grid boxes in upstream direction as necessary.
632!
633! In the two code segments below, WL is the z-coordinate of the
634! departure point for grid box interface z_w with the same indices;
635! FC is the finite volume flux; ksource(:,k) is index of vertical
636! grid box which contains the departure point (restricted by N(ng)).
637! During the search: also add in content of whole grid boxes
638! participating in FC.
639!
640 cff=dtdays*abs(wbio(isink))
641 DO k=1,n(ng)
642 DO i=istr,iend
643 fc(i,k-1)=0.0_r8
644 wl(i,k)=z_w(i,j,k-1)+cff
645 wr(i,k)=hz(i,j,k)*qc(i,k)
646 ksource(i,k)=k
647 END DO
648 END DO
649 DO k=1,n(ng)
650 DO ks=k,n(ng)-1
651 DO i=istr,iend
652 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
653 ksource(i,k)=ks+1
654 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
655 END IF
656 END DO
657 END DO
658 END DO
659!
660! Finalize computation of flux: add fractional part.
661!
662 DO k=1,n(ng)
663 DO i=istr,iend
664 ks=ksource(i,k)
665 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
666 fc(i,k-1)=fc(i,k-1)+ &
667 & hz(i,j,ks)*cu* &
668 & (bl(i,ks)+ &
669 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
670 & (1.5_r8-cu)* &
671 & (br(i,ks)+bl(i,ks)- &
672 & 2.0_r8*qc(i,ks))))
673 END DO
674 END DO
675 DO k=1,n(ng)
676 DO i=istr,iend
677 bio(i,k,ibio)=qc(i,k)+ &
678 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
679 END DO
680 END DO
681 END DO
682 END IF
683 END DO
684!
685! End of compute basic state arrays I.
686!
687! Nutrient uptake by phytoplankton.
688!
689 cff1=dtdays*vm_no3(ng)
690 DO k=1,n(ng)
691 DO i=istr,iend
692 cff=bio1(i,k,iphyt)* &
693 & cff1*exp(k_ext(ng)*z_r(i,j,k))/ &
694 & (k_no3(ng)+bio1(i,k,ino3_))
695 tl_cff=(tl_bio(i,k,iphyt)* &
696 & cff1*exp(k_ext(ng)*z_r(i,j,k))- &
697 & tl_bio(i,k,ino3_)*cff)/ &
698 & (k_no3(ng)+bio1(i,k,ino3_))+ &
699 & k_ext(ng)*tl_z_r(i,j,k)*cff
700!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)/ &
701!^ & (1.0_r8+cff)
702!^
703 tl_bio(i,k,ino3_)=(tl_bio(i,k,ino3_)- &
704 & tl_cff*bio(i,k,ino3_))/ &
705 & (1.0_r8+cff)
706!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)+ &
707!^ & Bio(i,k,iNO3_)*cff
708!^
709 tl_bio(i,k,iphyt)=tl_bio(i,k,iphyt)+ &
710 & tl_bio(i,k,ino3_)*cff+ &
711 & bio(i,k,ino3_)*tl_cff
712 END DO
713 END DO
714!
715! Compute appropriate basic state arrays II.
716!
717! Determine Correction for negativity.
718!
719 DO k=1,n(ng)
720 DO i=istr,iend
721 cff1=max(0.0_r8,eps-bio_old(i,k,ino3_))+ &
722 & max(0.0_r8,eps-bio_old(i,k,iphyt))+ &
723 & max(0.0_r8,eps-bio_old(i,k,izoop))+ &
724 & max(0.0_r8,eps-bio_old(i,k,isdet))
725!
726! If correction needed, determine the largest pool to debit.
727!
728 IF (cff1.gt.0.0) THEN
729 itrmx=idbio(1)
730 cff=t(i,j,k,nstp,itrmx)
731 DO ibio=idbio(2),idbio(nbt)
732 IF (t(i,j,k,nstp,ibio).gt.cff) THEN
733 itrmx=ibio
734 cff=t(i,j,k,nstp,ibio)
735 END IF
736 END DO
737!
738! Update new values.
739!
740 DO itrc=1,nbt
741 ibio=idbio(itrc)
742 bio(i,k,ibio)=max(eps,bio_old(i,k,ibio))- &
743 & cff1*(sign(0.5_r8, &
744 & real(itrmx-ibio,r8)**2)+ &
745 & sign(0.5_r8, &
746 & -real(itrmx-ibio,r8)**2))
747 END DO
748 ELSE
749 DO itrc=1,nbt
750 ibio=idbio(itrc)
751 bio(i,k,ibio)=bio_old(i,k,ibio)
752 END DO
753 END IF
754 END DO
755 END DO
756!
757!=======================================================================
758! Start internal iterations to achieve convergence of the nonlinear
759! backward-implicit solution.
760!=======================================================================
761!
762 DO iteradj=1,iter
763!
764! Nutrient uptake by phytoplankton.
765!
766 cff1=dtdays*vm_no3(ng)
767 DO k=1,n(ng)
768 DO i=istr,iend
769 cff=bio(i,k,iphyt)* &
770 & cff1*exp(k_ext(ng)*z_r(i,j,k))/ &
771 & (k_no3(ng)+bio(i,k,ino3_))
772 bio1(i,k,ino3_)=bio(i,k,ino3_)
773 bio(i,k,ino3_)=bio(i,k,ino3_)/ &
774 & (1.0_r8+cff)
775 bio1(i,k,iphyt)=bio(i,k,iphyt)
776 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
777 & bio(i,k,ino3_)*cff
778 END DO
779 END DO
780!
781! Phytoplankton grazing by Zooplankton and mortality to Detritus
782! (rate: PhyMR).
783!
784 cff1=dtdays*zoogr(ng)
785 cff2=dtdays*phymr(ng)
786 cff3=k_phy(ng)*k_phy(ng)
787 DO k=1,n(ng)
788 DO i=istr,iend
789 cff=bio(i,k,izoop)*bio(i,k,iphyt)*cff1/ &
790 & (cff3+bio(i,k,iphyt)*bio(i,k,iphyt))
791 bio1(i,k,iphyt)=bio(i,k,iphyt)
792 bio(i,k,iphyt)=bio(i,k,iphyt)/ &
793 & (1.0_r8+cff+cff2)
794 bio1(i,k,izoop)=bio(i,k,izoop)
795 bio(i,k,izoop)=bio(i,k,izoop)+ &
796 & bio(i,k,iphyt)*cff*(1.0_r8-zooga(ng))
797 bio(i,k,isdet)=bio(i,k,isdet)+ &
798 & bio(i,k,iphyt)* &
799 & (cff2+cff*(zooga(ng)-zooec(ng)))
800 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
801 & bio(i,k,iphyt)*cff*zooec(ng)
802 END DO
803 END DO
804!
805 IF (iteradj.ne.iter) THEN
806!
807! Zooplankton excretion to nutrients and mortality to Detritus.
808!
809 cff1=1.0_r8/(1.0_r8+dtdays*(zoomr(ng)+zoomd(ng)))
810 cff2=dtdays*zoomr(ng)
811 cff3=dtdays*zoomd(ng)
812 DO k=1,n(ng)
813 DO i=istr,iend
814 bio(i,k,izoop)=bio(i,k,izoop)*cff1
815 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
816 & bio(i,k,izoop)*cff2
817 bio(i,k,isdet)=bio(i,k,isdet)+ &
818 & bio(i,k,izoop)*cff3
819 END DO
820 END DO
821!
822! Detritus breakdown to nutrients.
823!
824 cff1=dtdays*detrr(ng)
825 cff2=1.0_r8/(1.0_r8+cff1)
826 DO k=1,n(ng)
827 DO i=istr,iend
828 bio(i,k,isdet)=bio(i,k,isdet)*cff2
829 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
830 & bio(i,k,isdet)*cff1
831 END DO
832 END DO
833!
834!-----------------------------------------------------------------------
835! Vertical sinking terms.
836!-----------------------------------------------------------------------
837!
838! Reconstruct vertical profile of selected biological constituents
839! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
840! grid box. Then, compute semi-Lagrangian flux due to sinking.
841!
842 DO isink=1,nsink
843 ibio=idsink(isink)
844!
845! Copy concentration of biological particulates into scratch array
846! "qc" (q-central, restrict it to be positive) which is hereafter
847! interpreted as a set of grid-box averaged values for biogeochemical
848! constituent concentration.
849!
850 DO k=1,n(ng)
851 DO i=istr,iend
852 qc(i,k)=bio(i,k,ibio)
853 END DO
854 END DO
855!
856 DO k=n(ng)-1,1,-1
857 DO i=istr,iend
858 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
859 END DO
860 END DO
861 DO k=2,n(ng)-1
862 DO i=istr,iend
863 dltr=hz(i,j,k)*fc(i,k)
864 dltl=hz(i,j,k)*fc(i,k-1)
865 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
866 cffr=cff*fc(i,k)
867 cffl=cff*fc(i,k-1)
868!
869! Apply PPM monotonicity constraint to prevent oscillations within the
870! grid box.
871!
872 IF ((dltr*dltl).le.0.0_r8) THEN
873 dltr=0.0_r8
874 dltl=0.0_r8
875 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
876 dltr=cffl
877 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
878 dltl=cffr
879 END IF
880!
881! Compute right and left side values (bR,bL) of parabolic segments
882! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
883!
884! NOTE: Although each parabolic segment is monotonic within its grid
885! box, monotonicity of the whole profile is not guaranteed,
886! because bL(k+1)-bR(k) may still have different sign than
887! qc(i,k+1)-qc(i,k). This possibility is excluded,
888! after bL and bR are reconciled using WENO procedure.
889!
890 cff=(dltr-dltl)*hz_inv3(i,k)
891 dltr=dltr-cff*hz(i,j,k+1)
892 dltl=dltl+cff*hz(i,j,k-1)
893 br(i,k)=qc(i,k)+dltr
894 bl(i,k)=qc(i,k)-dltl
895 wr(i,k)=(2.0_r8*dltr-dltl)**2
896 wl(i,k)=(dltr-2.0_r8*dltl)**2
897 END DO
898 END DO
899 cff=1.0e-14_r8
900 DO k=2,n(ng)-2
901 DO i=istr,iend
902 dltl=max(cff,wl(i,k ))
903 dltr=max(cff,wr(i,k+1))
904 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
905 bl(i,k+1)=br(i,k)
906 END DO
907 END DO
908 DO i=istr,iend
909 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
910#if defined LINEAR_CONTINUATION
911 bl(i,n(ng))=br(i,n(ng)-1)
912 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
913#elif defined NEUMANN
914 bl(i,n(ng))=br(i,n(ng)-1)
915 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
916#else
917 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
918 bl(i,n(ng))=qc(i,n(ng)) ! conditions
919 br(i,n(ng)-1)=qc(i,n(ng))
920#endif
921#if defined LINEAR_CONTINUATION
922 br(i,1)=bl(i,2)
923 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
924#elif defined NEUMANN
925 br(i,1)=bl(i,2)
926 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
927#else
928 bl(i,2)=qc(i,1) ! bottom grid boxes are
929 br(i,1)=qc(i,1) ! re-assumed to be
930 bl(i,1)=qc(i,1) ! piecewise constant.
931#endif
932 END DO
933!
934! Apply monotonicity constraint again, since the reconciled interfacial
935! values may cause a non-monotonic behavior of the parabolic segments
936! inside the grid box.
937!
938 DO k=1,n(ng)
939 DO i=istr,iend
940 dltr=br(i,k)-qc(i,k)
941 dltl=qc(i,k)-bl(i,k)
942 cffr=2.0_r8*dltr
943 cffl=2.0_r8*dltl
944 IF ((dltr*dltl).lt.0.0_r8) THEN
945 dltr=0.0_r8
946 dltl=0.0_r8
947 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
948 dltr=cffl
949 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
950 dltl=cffr
951 END IF
952 br(i,k)=qc(i,k)+dltr
953 bl(i,k)=qc(i,k)-dltl
954 END DO
955 END DO
956!
957! After this moment reconstruction is considered complete. The next
958! stage is to compute vertical advective fluxes, FC. It is expected
959! that sinking may occurs relatively fast, the algorithm is designed
960! to be free of CFL criterion, which is achieved by allowing
961! integration bounds for semi-Lagrangian advective flux to use as
962! many grid boxes in upstream direction as necessary.
963!
964! In the two code segments below, WL is the z-coordinate of the
965! departure point for grid box interface z_w with the same indices;
966! FC is the finite volume flux; ksource(:,k) is index of vertical
967! grid box which contains the departure point (restricted by N(ng)).
968! During the search: also add in content of whole grid boxes
969! participating in FC.
970!
971 cff=dtdays*abs(wbio(isink))
972 DO k=1,n(ng)
973 DO i=istr,iend
974 fc(i,k-1)=0.0_r8
975 wl(i,k)=z_w(i,j,k-1)+cff
976 wr(i,k)=hz(i,j,k)*qc(i,k)
977 ksource(i,k)=k
978 END DO
979 END DO
980 DO k=1,n(ng)
981 DO ks=k,n(ng)-1
982 DO i=istr,iend
983 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
984 ksource(i,k)=ks+1
985 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
986 END IF
987 END DO
988 END DO
989 END DO
990!
991! Finalize computation of flux: add fractional part.
992!
993 DO k=1,n(ng)
994 DO i=istr,iend
995 ks=ksource(i,k)
996 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
997 fc(i,k-1)=fc(i,k-1)+ &
998 & hz(i,j,ks)*cu* &
999 & (bl(i,ks)+ &
1000 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1001 & (1.5_r8-cu)* &
1002 & (br(i,ks)+bl(i,ks)- &
1003 & 2.0_r8*qc(i,ks))))
1004 END DO
1005 END DO
1006 DO k=1,n(ng)
1007 DO i=istr,iend
1008 bio(i,k,ibio)=qc(i,k)+ &
1009 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1010 END DO
1011 END DO
1012 END DO
1013 END IF
1014 END DO
1015!
1016! End of compute basic state arrays II.
1017!
1018! Phytoplankton grazing by Zooplankton and mortality to Detritus
1019! (rate: PhyMR).
1020!
1021 cff1=dtdays*zoogr(ng)
1022 cff2=dtdays*phymr(ng)
1023 cff3=k_phy(ng)*k_phy(ng)
1024 DO k=1,n(ng)
1025 DO i=istr,iend
1026 cff=bio1(i,k,izoop)*bio1(i,k,iphyt)*cff1/ &
1027 & (cff3+bio1(i,k,iphyt)*bio1(i,k,iphyt))
1028 tl_cff=((tl_bio(i,k,izoop)*bio1(i,k,iphyt)+ &
1029 & bio1(i,k,izoop)*tl_bio(i,k,iphyt))*cff1- &
1030 & 2.0_r8*bio1(i,k,iphyt)*tl_bio(i,k,iphyt)*cff)/ &
1031 & (cff3+bio1(i,k,iphyt)*bio1(i,k,iphyt))
1032!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)/ &
1033!^ & (1.0_r8+cff+cff2)
1034!^
1035 tl_bio(i,k,iphyt)=(tl_bio(i,k,iphyt)- &
1036 & tl_cff*bio(i,k,iphyt))/ &
1037 & (1.0_r8+cff+cff2)
1038!^ Bio(i,k,iZoop)=Bio(i,k,iZoop)+ &
1039!^ & Bio(i,k,iPhyt)*cff*(1.0_r8-ZooGA(ng))
1040!^
1041 tl_bio(i,k,izoop)=tl_bio(i,k,izoop)+ &
1042 & tl_bio(i,k,iphyt)* &
1043 & cff*(1.0_r8-zooga(ng))+ &
1044 & bio(i,k,iphyt)* &
1045 & tl_cff*(1.0_r8-zooga(ng))
1046!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1047!^ & Bio(i,k,iPhyt)* &
1048!^ & (cff2+cff*(ZooGA(ng)-ZooEC(ng)))
1049!^
1050 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1051 & tl_bio(i,k,iphyt)* &
1052 & (cff2+cff*(zooga(ng)-zooec(ng)))+ &
1053 & bio(i,k,iphyt)* &
1054 & tl_cff*(zooga(ng)-zooec(ng))
1055!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1056!^ & Bio(i,k,iPhyt)*cff*ZooEC(ng)
1057!^
1058 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1059 & tl_bio(i,k,iphyt)*cff*zooec(ng)+ &
1060 & bio(i,k,iphyt)*tl_cff*zooec(ng)
1061 END DO
1062 END DO
1063!
1064! Zooplankton excretion to nutrients and mortality to Detritus.
1065!
1066 cff1=1.0_r8/(1.0_r8+dtdays*(zoomr(ng)+zoomd(ng)))
1067 cff2=dtdays*zoomr(ng)
1068 cff3=dtdays*zoomd(ng)
1069 DO k=1,n(ng)
1070 DO i=istr,iend
1071!^ Bio(i,k,iZoop)=Bio(i,k,iZoop)*cff1
1072!^
1073 tl_bio(i,k,izoop)=tl_bio(i,k,izoop)*cff1
1074!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1075!^ & Bio(i,k,iZoop)*cff2
1076!^
1077 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1078 & tl_bio(i,k,izoop)*cff2
1079!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1080!^ & Bio(i,k,iZoop)*cff3
1081!^
1082 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1083 & tl_bio(i,k,izoop)*cff3
1084 END DO
1085 END DO
1086!
1087! Detritus breakdown to nutrients.
1088!
1089 cff1=dtdays*detrr(ng)
1090 cff2=1.0_r8/(1.0_r8+cff1)
1091 DO k=1,n(ng)
1092 DO i=istr,iend
1093!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)*cff2
1094!^
1095 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)*cff2
1096!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1097!^ & Bio(i,k,iSDet)*cff1
1098!^
1099 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1100 & tl_bio(i,k,isdet)*cff1
1101 END DO
1102 END DO
1103!
1104! Compute appropriate basic state arrays III.
1105!
1106! Determine Correction for negativity.
1107!
1108 DO k=1,n(ng)
1109 DO i=istr,iend
1110 cff1=max(0.0_r8,eps-bio_old(i,k,ino3_))+ &
1111 & max(0.0_r8,eps-bio_old(i,k,iphyt))+ &
1112 & max(0.0_r8,eps-bio_old(i,k,izoop))+ &
1113 & max(0.0_r8,eps-bio_old(i,k,isdet))
1114!
1115! If correction needed, determine the largest pool to debit.
1116!
1117 IF (cff1.gt.0.0) THEN
1118 itrmx=idbio(1)
1119 cff=t(i,j,k,nstp,itrmx)
1120 DO ibio=idbio(2),idbio(nbt)
1121 IF (t(i,j,k,nstp,ibio).gt.cff) THEN
1122 itrmx=ibio
1123 cff=t(i,j,k,nstp,ibio)
1124 END IF
1125 END DO
1126!
1127! Update new values.
1128!
1129 DO itrc=1,nbt
1130 ibio=idbio(itrc)
1131 bio(i,k,ibio)=max(eps,bio_old(i,k,ibio))- &
1132 & cff1*(sign(0.5_r8, &
1133 & real(itrmx-ibio,r8)**2)+ &
1134 & sign(0.5_r8, &
1135 & -real(itrmx-ibio,r8)**2))
1136 END DO
1137 ELSE
1138 DO itrc=1,nbt
1139 ibio=idbio(itrc)
1140 bio(i,k,ibio)=bio_old(i,k,ibio)
1141 END DO
1142 END IF
1143 END DO
1144 END DO
1145!
1146!=======================================================================
1147! Start internal iterations to achieve convergence of the nonlinear
1148! backward-implicit solution.
1149!=======================================================================
1150!
1151 DO iteradj=1,iter
1152!
1153! Nutrient uptake by phytoplankton.
1154!
1155 cff1=dtdays*vm_no3(ng)
1156 DO k=1,n(ng)
1157 DO i=istr,iend
1158 cff=bio(i,k,iphyt)* &
1159 & cff1*exp(k_ext(ng)*z_r(i,j,k))/ &
1160 & (k_no3(ng)+bio(i,k,ino3_))
1161 bio1(i,k,ino3_)=bio(i,k,ino3_)
1162 bio(i,k,ino3_)=bio(i,k,ino3_)/ &
1163 & (1.0_r8+cff)
1164 bio1(i,k,iphyt)=bio(i,k,iphyt)
1165 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
1166 & bio(i,k,ino3_)*cff
1167 END DO
1168 END DO
1169!
1170! Phytoplankton grazing by Zooplankton and mortality to Detritus
1171! (rate: PhyMR).
1172!
1173 cff1=dtdays*zoogr(ng)
1174 cff2=dtdays*phymr(ng)
1175 cff3=k_phy(ng)*k_phy(ng)
1176 DO k=1,n(ng)
1177 DO i=istr,iend
1178 cff=bio(i,k,izoop)*bio(i,k,iphyt)*cff1/ &
1179 & (cff3+bio(i,k,iphyt)*bio(i,k,iphyt))
1180 bio1(i,k,iphyt)=bio(i,k,iphyt)
1181 bio(i,k,iphyt)=bio(i,k,iphyt)/ &
1182 & (1.0_r8+cff+cff2)
1183 bio1(i,k,izoop)=bio(i,k,izoop)
1184 bio(i,k,izoop)=bio(i,k,izoop)+ &
1185 & bio(i,k,iphyt)*cff*(1.0_r8-zooga(ng))
1186 bio(i,k,isdet)=bio(i,k,isdet)+ &
1187 & bio(i,k,iphyt)* &
1188 & (cff2+cff*(zooga(ng)-zooec(ng)))
1189 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1190 & bio(i,k,iphyt)*cff*zooec(ng)
1191 END DO
1192 END DO
1193!
1194! Zooplankton excretion to nutrients and mortality to Detritus.
1195!
1196 cff1=1.0_r8/(1.0_r8+dtdays*(zoomr(ng)+zoomd(ng)))
1197 cff2=dtdays*zoomr(ng)
1198 cff3=dtdays*zoomd(ng)
1199 DO k=1,n(ng)
1200 DO i=istr,iend
1201 bio(i,k,izoop)=bio(i,k,izoop)*cff1
1202 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1203 & bio(i,k,izoop)*cff2
1204 bio(i,k,isdet)=bio(i,k,isdet)+ &
1205 & bio(i,k,izoop)*cff3
1206 END DO
1207 END DO
1208!
1209! Detritus breakdown to nutrients.
1210!
1211 cff1=dtdays*detrr(ng)
1212 cff2=1.0_r8/(1.0_r8+cff1)
1213 DO k=1,n(ng)
1214 DO i=istr,iend
1215 bio(i,k,isdet)=bio(i,k,isdet)*cff2
1216 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1217 & bio(i,k,isdet)*cff1
1218 END DO
1219 END DO
1220!
1221 IF (iteradj.ne.iter) THEN
1222!
1223!-----------------------------------------------------------------------
1224! Vertical sinking terms.
1225!-----------------------------------------------------------------------
1226!
1227! Reconstruct vertical profile of selected biological constituents
1228! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1229! grid box. Then, compute semi-Lagrangian flux due to sinking.
1230!
1231 DO isink=1,nsink
1232 ibio=idsink(isink)
1233!
1234! Copy concentration of biological particulates into scratch array
1235! "qc" (q-central, restrict it to be positive) which is hereafter
1236! interpreted as a set of grid-box averaged values for biogeochemical
1237! constituent concentration.
1238!
1239 DO k=1,n(ng)
1240 DO i=istr,iend
1241 qc(i,k)=bio(i,k,ibio)
1242 END DO
1243 END DO
1244!
1245 DO k=n(ng)-1,1,-1
1246 DO i=istr,iend
1247 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1248 END DO
1249 END DO
1250 DO k=2,n(ng)-1
1251 DO i=istr,iend
1252 dltr=hz(i,j,k)*fc(i,k)
1253 dltl=hz(i,j,k)*fc(i,k-1)
1254 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1255 cffr=cff*fc(i,k)
1256 cffl=cff*fc(i,k-1)
1257!
1258! Apply PPM monotonicity constraint to prevent oscillations within the
1259! grid box.
1260!
1261 IF ((dltr*dltl).le.0.0_r8) THEN
1262 dltr=0.0_r8
1263 dltl=0.0_r8
1264 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1265 dltr=cffl
1266 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1267 dltl=cffr
1268 END IF
1269!
1270! Compute right and left side values (bR,bL) of parabolic segments
1271! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1272!
1273! NOTE: Although each parabolic segment is monotonic within its grid
1274! box, monotonicity of the whole profile is not guaranteed,
1275! because bL(k+1)-bR(k) may still have different sign than
1276! qc(i,k+1)-qc(i,k). This possibility is excluded,
1277! after bL and bR are reconciled using WENO procedure.
1278!
1279 cff=(dltr-dltl)*hz_inv3(i,k)
1280 dltr=dltr-cff*hz(i,j,k+1)
1281 dltl=dltl+cff*hz(i,j,k-1)
1282 br(i,k)=qc(i,k)+dltr
1283 bl(i,k)=qc(i,k)-dltl
1284 wr(i,k)=(2.0_r8*dltr-dltl)**2
1285 wl(i,k)=(dltr-2.0_r8*dltl)**2
1286 END DO
1287 END DO
1288 cff=1.0e-14_r8
1289 DO k=2,n(ng)-2
1290 DO i=istr,iend
1291 dltl=max(cff,wl(i,k ))
1292 dltr=max(cff,wr(i,k+1))
1293 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1294 bl(i,k+1)=br(i,k)
1295 END DO
1296 END DO
1297 DO i=istr,iend
1298 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1299#if defined LINEAR_CONTINUATION
1300 bl(i,n(ng))=br(i,n(ng)-1)
1301 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1302#elif defined NEUMANN
1303 bl(i,n(ng))=br(i,n(ng)-1)
1304 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1305#else
1306 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1307 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1308 br(i,n(ng)-1)=qc(i,n(ng))
1309#endif
1310#if defined LINEAR_CONTINUATION
1311 br(i,1)=bl(i,2)
1312 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1313#elif defined NEUMANN
1314 br(i,1)=bl(i,2)
1315 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1316#else
1317 bl(i,2)=qc(i,1) ! bottom grid boxes are
1318 br(i,1)=qc(i,1) ! re-assumed to be
1319 bl(i,1)=qc(i,1) ! piecewise constant.
1320#endif
1321 END DO
1322!
1323! Apply monotonicity constraint again, since the reconciled interfacial
1324! values may cause a non-monotonic behavior of the parabolic segments
1325! inside the grid box.
1326!
1327 DO k=1,n(ng)
1328 DO i=istr,iend
1329 dltr=br(i,k)-qc(i,k)
1330 dltl=qc(i,k)-bl(i,k)
1331 cffr=2.0_r8*dltr
1332 cffl=2.0_r8*dltl
1333 IF ((dltr*dltl).lt.0.0_r8) THEN
1334 dltr=0.0_r8
1335 dltl=0.0_r8
1336 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1337 dltr=cffl
1338 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1339 dltl=cffr
1340 END IF
1341 br(i,k)=qc(i,k)+dltr
1342 bl(i,k)=qc(i,k)-dltl
1343 END DO
1344 END DO
1345!
1346! After this moment reconstruction is considered complete. The next
1347! stage is to compute vertical advective fluxes, FC. It is expected
1348! that sinking may occurs relatively fast, the algorithm is designed
1349! to be free of CFL criterion, which is achieved by allowing
1350! integration bounds for semi-Lagrangian advective flux to use as
1351! many grid boxes in upstream direction as necessary.
1352!
1353! In the two code segments below, WL is the z-coordinate of the
1354! departure point for grid box interface z_w with the same indices;
1355! FC is the finite volume flux; ksource(:,k) is index of vertical
1356! grid box which contains the departure point (restricted by N(ng)).
1357! During the search: also add in content of whole grid boxes
1358! participating in FC.
1359!
1360 cff=dtdays*abs(wbio(isink))
1361 DO k=1,n(ng)
1362 DO i=istr,iend
1363 fc(i,k-1)=0.0_r8
1364 wl(i,k)=z_w(i,j,k-1)+cff
1365 wr(i,k)=hz(i,j,k)*qc(i,k)
1366 ksource(i,k)=k
1367 END DO
1368 END DO
1369 DO k=1,n(ng)
1370 DO ks=k,n(ng)-1
1371 DO i=istr,iend
1372 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1373 ksource(i,k)=ks+1
1374 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1375 END IF
1376 END DO
1377 END DO
1378 END DO
1379!
1380! Finalize computation of flux: add fractional part.
1381!
1382 DO k=1,n(ng)
1383 DO i=istr,iend
1384 ks=ksource(i,k)
1385 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1386 fc(i,k-1)=fc(i,k-1)+ &
1387 & hz(i,j,ks)*cu* &
1388 & (bl(i,ks)+ &
1389 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1390 & (1.5_r8-cu)* &
1391 & (br(i,ks)+bl(i,ks)- &
1392 & 2.0_r8*qc(i,ks))))
1393 END DO
1394 END DO
1395 DO k=1,n(ng)
1396 DO i=istr,iend
1397 bio(i,k,ibio)=qc(i,k)+ &
1398 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1399 END DO
1400 END DO
1401 END DO
1402 END IF
1403 END DO
1404!
1405! End of compute basic state arrays III.
1406!
1407!-----------------------------------------------------------------------
1408! Vertical sinking terms.
1409!-----------------------------------------------------------------------
1410!
1411! Reconstruct vertical profile of selected biological constituents
1412! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1413! grid box. Then, compute semi-Lagrangian flux due to sinking.
1414!
1415 sink_loop: DO isink=1,nsink
1416 ibio=idsink(isink)
1417!
1418! Copy concentration of biological particulates into scratch array
1419! "qc" (q-central, restrict it to be positive) which is hereafter
1420! interpreted as a set of grid-box averaged values for biogeochemical
1421! constituent concentration.
1422!
1423 DO k=1,n(ng)
1424 DO i=istr,iend
1425 qc(i,k)=bio(i,k,ibio)
1426 tl_qc(i,k)=tl_bio(i,k,ibio)
1427 END DO
1428 END DO
1429!
1430 DO k=n(ng)-1,1,-1
1431 DO i=istr,iend
1432 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1433 tl_fc(i,k)=(tl_qc(i,k+1)-tl_qc(i,k))*hz_inv2(i,k)+ &
1434 & (qc(i,k+1)-qc(i,k))*tl_hz_inv2(i,k)
1435 END DO
1436 END DO
1437 DO k=2,n(ng)-1
1438 DO i=istr,iend
1439 dltr=hz(i,j,k)*fc(i,k)
1440 tl_dltr=tl_hz(i,j,k)*fc(i,k)+hz(i,j,k)*tl_fc(i,k)
1441 dltl=hz(i,j,k)*fc(i,k-1)
1442 tl_dltl=tl_hz(i,j,k)*fc(i,k-1)+hz(i,j,k)*tl_fc(i,k-1)
1443 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1444 tl_cff=tl_hz(i,j,k-1)+2.0_r8*tl_hz(i,j,k)+tl_hz(i,j,k+1)
1445 cffr=cff*fc(i,k)
1446 tl_cffr=tl_cff*fc(i,k)+cff*tl_fc(i,k)
1447 cffl=cff*fc(i,k-1)
1448 tl_cffl=tl_cff*fc(i,k-1)+cff*tl_fc(i,k-1)
1449!
1450! Apply PPM monotonicity constraint to prevent oscillations within the
1451! grid box.
1452!
1453 IF ((dltr*dltl).le.0.0_r8) THEN
1454 dltr=0.0_r8
1455 tl_dltr=0.0_r8
1456 dltl=0.0_r8
1457 tl_dltl=0.0_r8
1458 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1459 dltr=cffl
1460 tl_dltr=tl_cffl
1461 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1462 dltl=cffr
1463 tl_dltl=tl_cffr
1464 END IF
1465!
1466! Compute right and left side values (bR,bL) of parabolic segments
1467! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1468!
1469! NOTE: Although each parabolic segment is monotonic within its grid
1470! box, monotonicity of the whole profile is not guaranteed,
1471! because bL(k+1)-bR(k) may still have different sign than
1472! qc(i,k+1)-qc(i,k). This possibility is excluded,
1473! after bL and bR are reconciled using WENO procedure.
1474!
1475 cff=(dltr-dltl)*hz_inv3(i,k)
1476 tl_cff=(tl_dltr-tl_dltl)*hz_inv3(i,k)+ &
1477 & (dltr-dltl)*tl_hz_inv3(i,k)
1478 dltr=dltr-cff*hz(i,j,k+1)
1479 tl_dltr=tl_dltr-tl_cff*hz(i,j,k+1)-cff*tl_hz(i,j,k+1)
1480 dltl=dltl+cff*hz(i,j,k-1)
1481 tl_dltl=tl_dltl+tl_cff*hz(i,j,k-1)+cff*tl_hz(i,j,k-1)
1482 br(i,k)=qc(i,k)+dltr
1483 tl_br(i,k)=tl_qc(i,k)+tl_dltr
1484 bl(i,k)=qc(i,k)-dltl
1485 tl_bl(i,k)=tl_qc(i,k)-tl_dltl
1486 wr(i,k)=(2.0_r8*dltr-dltl)**2
1487 tl_wr(i,k)=2.0_r8*(2.0_r8*dltr-dltl)* &
1488 & (2.0_r8*tl_dltr-tl_dltl)
1489 wl(i,k)=(dltr-2.0_r8*dltl)**2
1490 tl_wl(i,k)=2.0_r8*(dltr-2.0_r8*dltl)* &
1491 & (tl_dltr-2.0_r8*tl_dltl)
1492 END DO
1493 END DO
1494 cff=1.0e-14_r8
1495 DO k=2,n(ng)-2
1496 DO i=istr,iend
1497 dltl=max(cff,wl(i,k ))
1498 tl_dltl=(0.5_r8-sign(0.5_r8,cff-wl(i,k )))* &
1499 & tl_wl(i,k )
1500 dltr=max(cff,wr(i,k+1))
1501 tl_dltr=(0.5_r8-sign(0.5_r8,cff-wr(i,k+1)))* &
1502 & tl_wr(i,k+1)
1503 br1(i,k)=br(i,k)
1504 bl1(i,k+1)=bl(i,k+1)
1505 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1506 tl_br(i,k)=(tl_dltr*br1(i,k )+dltr*tl_br(i,k )+ &
1507 & tl_dltl*bl1(i,k+1)+dltl*tl_bl(i,k+1))/ &
1508 & (dltr+dltl)- &
1509 & (tl_dltr+tl_dltl)*br(i,k)/(dltr+dltl)
1510 bl(i,k+1)=br(i,k)
1511 tl_bl(i,k+1)=tl_br(i,k)
1512 END DO
1513 END DO
1514 DO i=istr,iend
1515 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1516 tl_fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1517#if defined LINEAR_CONTINUATION
1518 bl(i,n(ng))=br(i,n(ng)-1)
1519 tl_bl(i,n(ng))=tl_br(i,n(ng)-1)
1520 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1521 tl_br(i,n(ng))=2.0_r8*tl_qc(i,n(ng))-tl_bl(i,n(ng))
1522#elif defined NEUMANN
1523 bl(i,n(ng))=br(i,n(ng)-1)
1524 tl_bl(i,n(ng))=tl_br(i,n(ng)-1)
1525 br(i,n(ng))=1.5_r8*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1526 tl_br(i,n(ng))=1.5_r8*tl_qc(i,n(ng))-0.5_r8*tl_bl(i,n(ng))
1527#else
1528 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1529 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1530 br(i,n(ng)-1)=qc(i,n(ng))
1531 tl_br(i,n(ng))=tl_qc(i,n(ng)) ! default strictly monotonic
1532 tl_bl(i,n(ng))=tl_qc(i,n(ng)) ! conditions
1533 tl_br(i,n(ng)-1)=tl_qc(i,n(ng))
1534#endif
1535#if defined LINEAR_CONTINUATION
1536 br(i,1)=bl(i,2)
1537 tl_br(i,1)=tl_bl(i,2)
1538 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1539 tl_bl(i,1)=2.0_r8*tl_qc(i,1)-tl_br(i,1)
1540#elif defined NEUMANN
1541 br(i,1)=bl(i,2)
1542 tl_br(i,1)=tl_bl(i,2)
1543 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1544 tl_bl(i,1)=1.5_r8*tl_qc(i,1)-0.5_r8*tl_br(i,1)
1545#else
1546 bl(i,2)=qc(i,1) ! bottom grid boxes are
1547 br(i,1)=qc(i,1) ! re-assumed to be
1548 bl(i,1)=qc(i,1) ! piecewise constant.
1549 tl_bl(i,2)=tl_qc(i,1) ! bottom grid boxes are
1550 tl_br(i,1)=tl_qc(i,1) ! re-assumed to be
1551 tl_bl(i,1)=tl_qc(i,1) ! piecewise constant.
1552#endif
1553 END DO
1554!
1555! Apply monotonicity constraint again, since the reconciled interfacial
1556! values may cause a non-monotonic behavior of the parabolic segments
1557! inside the grid box.
1558!
1559 DO k=1,n(ng)
1560 DO i=istr,iend
1561 dltr=br(i,k)-qc(i,k)
1562 tl_dltr=tl_br(i,k)-tl_qc(i,k)
1563 dltl=qc(i,k)-bl(i,k)
1564 tl_dltl=tl_qc(i,k)-tl_bl(i,k)
1565 cffr=2.0_r8*dltr
1566 tl_cffr=2.0_r8*tl_dltr
1567 cffl=2.0_r8*dltl
1568 tl_cffl=2.0_r8*tl_dltl
1569 IF ((dltr*dltl).lt.0.0_r8) THEN
1570 dltr=0.0_r8
1571 tl_dltr=0.0_r8
1572 dltl=0.0_r8
1573 tl_dltl=0.0_r8
1574 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1575 dltr=cffl
1576 tl_dltr=tl_cffl
1577 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1578 dltl=cffr
1579 tl_dltl=tl_cffr
1580 END IF
1581 br(i,k)=qc(i,k)+dltr
1582 tl_br(i,k)=tl_qc(i,k)+tl_dltr
1583 bl(i,k)=qc(i,k)-dltl
1584 tl_bl(i,k)=tl_qc(i,k)-tl_dltl
1585 END DO
1586 END DO
1587!
1588! After this moment reconstruction is considered complete. The next
1589! stage is to compute vertical advective fluxes, FC. It is expected
1590! that sinking may occurs relatively fast, the algorithm is designed
1591! to be free of CFL criterion, which is achieved by allowing
1592! integration bounds for semi-Lagrangian advective flux to use as
1593! many grid boxes in upstream direction as necessary.
1594!
1595! In the two code segments below, WL is the z-coordinate of the
1596! departure point for grid box interface z_w with the same indices;
1597! FC is the finite volume flux; ksource(:,k) is index of vertical
1598! grid box which contains the departure point (restricted by N(ng)).
1599! During the search: also add in content of whole grid boxes
1600! participating in FC.
1601!
1602 cff=dtdays*abs(wbio(isink))
1603 tl_cff=dtdays*sign(1.0_r8,wbio(isink))*tl_wbio(isink)
1604 DO k=1,n(ng)
1605 DO i=istr,iend
1606 fc(i,k-1)=0.0_r8
1607 tl_fc(i,k-1)=0.0_r8
1608 wl(i,k)=z_w(i,j,k-1)+cff
1609 tl_wl(i,k)=tl_z_w(i,j,k-1)+tl_cff
1610 wr(i,k)=hz(i,j,k)*qc(i,k)
1611 tl_wr(i,k)=tl_hz(i,j,k)*qc(i,k)+hz(i,j,k)*tl_qc(i,k)
1612 ksource(i,k)=k
1613 END DO
1614 END DO
1615 DO k=1,n(ng)
1616 DO ks=k,n(ng)-1
1617 DO i=istr,iend
1618 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1619 ksource(i,k)=ks+1
1620 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1621 tl_fc(i,k-1)=tl_fc(i,k-1)+tl_wr(i,ks)
1622 END IF
1623 END DO
1624 END DO
1625 END DO
1626!
1627! Finalize computation of flux: add fractional part.
1628!
1629 DO k=1,n(ng)
1630 DO i=istr,iend
1631 ks=ksource(i,k)
1632 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1633 tl_cu=(0.5_r8+sign(0.5_r8, &
1634 & (1.0_r8-(wl(i,k)-z_w(i,j,ks-1))* &
1635 & hz_inv(i,ks))))* &
1636 & ((tl_wl(i,k)-tl_z_w(i,j,ks-1))*hz_inv(i,ks)+ &
1637 & (wl(i,k)-z_w(i,j,ks-1))*tl_hz_inv(i,ks))
1638 fc(i,k-1)=fc(i,k-1)+ &
1639 & hz(i,j,ks)*cu* &
1640 & (bl(i,ks)+ &
1641 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1642 & (1.5_r8-cu)* &
1643 & (br(i,ks)+bl(i,ks)- &
1644 & 2.0_r8*qc(i,ks))))
1645 tl_fc(i,k-1)=tl_fc(i,k-1)+ &
1646 & (tl_hz(i,j,ks)*cu+hz(i,j,ks)*tl_cu)* &
1647 & (bl(i,ks)+ &
1648 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1649 & (1.5_r8-cu)* &
1650 & (br(i,ks)+bl(i,ks)- &
1651 & 2.0_r8*qc(i,ks))))+ &
1652 & hz(i,j,ks)*cu* &
1653 & (tl_bl(i,ks)+ &
1654 & tl_cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1655 & (1.5_r8-cu)* &
1656 & (br(i,ks)+bl(i,ks)- &
1657 & 2.0_r8*qc(i,ks)))+ &
1658 & cu*(0.5_r8*(tl_br(i,ks)-tl_bl(i,ks))+ &
1659 & tl_cu* &
1660 & (br(i,ks)+bl(i,ks)-2.0_r8*qc(i,ks))- &
1661 & (1.5_r8-cu)* &
1662 & (tl_br(i,ks)+tl_bl(i,ks)- &
1663 & 2.0_r8*tl_qc(i,ks))))
1664 END DO
1665 END DO
1666 DO k=1,n(ng)
1667 DO i=istr,iend
1668 bio(i,k,ibio)=qc(i,k)+(fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1669 tl_bio(i,k,ibio)=tl_qc(i,k)+ &
1670 & (tl_fc(i,k)-tl_fc(i,k-1))*hz_inv(i,k)+ &
1671 & (fc(i,k)-fc(i,k-1))*tl_hz_inv(i,k)
1672 END DO
1673 END DO
1674
1675 END DO sink_loop
1676 END DO iter_loop
1677!
1678!-----------------------------------------------------------------------
1679! Update global tracer variables: Add increment due to BGC processes
1680! to tracer array in time index "nnew". Index "nnew" is solution after
1681! advection and mixing and has transport units (m Tunits) hence the
1682! increment is multiplied by Hz. Notice that we need to subtract
1683! original values "Bio_old" at the top of the routine to just account
1684! for the concentractions affected by BGC processes. This also takes
1685! into account any constraints (non-negative concentrations, carbon
1686! concentration range) specified before entering BGC kernel. If "Bio"
1687! were unchanged by BGC processes, the increment would be exactly
1688! zero. Notice that final tracer values, t(:,:,:,nnew,:) are not
1689! bounded >=0 so that we can preserve total inventory of nutrients
1690! when advection causes tracer concentration to go negative.
1691!-----------------------------------------------------------------------
1692!
1693 DO itrc=1,nbt
1694 ibio=idbio(itrc)
1695 DO k=1,n(ng)
1696 DO i=istr,iend
1697 cff=bio(i,k,ibio)-bio_old(i,k,ibio)
1698 tl_cff=tl_bio(i,k,ibio)-tl_bio_old(i,k,ibio)
1699!^ t(i,j,k,nnew,ibio)=t(i,j,k,nnew,ibio)+cff*Hz(i,j,k)
1700!^
1701 tl_t(i,j,k,nnew,ibio)=tl_t(i,j,k,nnew,ibio)+ &
1702 & tl_cff*hz(i,j,k)+cff*tl_hz(i,j,k)
1703 END DO
1704 END DO
1705 END DO
1706
1707 END DO j_loop
1708!
1709 RETURN
mod_biology
Definition ecosim_mod.h:1
mod_biology::zooga
real(r8), dimension(:), allocatable zooga
Definition npzd_Franks_mod.h:67
mod_biology::tl_wdet
real(r8), dimension(:), allocatable tl_wdet
Definition npzd_Franks_mod.h:59
mod_biology::zoomr
real(r8), dimension(:), allocatable zoomr
Definition fennel_mod.h:162
mod_biology::k_phy
real(r8), dimension(:), allocatable k_phy
Definition fennel_mod.h:135
mod_biology::detrr
real(r8), dimension(:), allocatable detrr
Definition npzd_Franks_mod.h:51
mod_biology::wdet
real(r8), dimension(:), allocatable wdet
Definition npzd_Franks_mod.h:57
mod_biology::isdet
integer isdet
Definition npzd_Franks_mod.h:42
mod_biology::zoomd
real(r8), dimension(:), allocatable zoomd
Definition npzd_Franks_mod.h:66
mod_biology::bioiter
integer, dimension(:), allocatable bioiter
Definition ecosim_mod.h:343
mod_biology::ino3_
integer ino3_
Definition ecosim_mod.h:277
mod_biology::zoogr
real(r8), dimension(:), allocatable zoogr
Definition fennel_mod.h:160
mod_biology::k_no3
real(r8), dimension(:), allocatable k_no3
Definition fennel_mod.h:133
mod_biology::phymr
real(r8), dimension(:), allocatable phymr
Definition fennel_mod.h:145
mod_biology::iphyt
integer iphyt
Definition fennel_mod.h:81
mod_biology::zooec
real(r8), dimension(:), allocatable zooec
Definition npzd_Franks_mod.h:68
mod_biology::idbio
integer, dimension(:), allocatable idbio
Definition ecosim_mod.h:256
mod_biology::vm_no3
real(r8), dimension(:), allocatable vm_no3
Definition npzd_Franks_mod.h:56
mod_biology::izoop
integer izoop
Definition fennel_mod.h:82
mod_biology::k_ext
real(r8), dimension(:), allocatable k_ext
Definition npzd_Franks_mod.h:52
mod_param::nbt
integer nbt
Definition mod_param.F:509
mod_scalars
Definition mod_scalars.F:2
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::sec2day
real(dp), parameter sec2day
Definition mod_scalars.F:817

References mod_biology::bioiter, mod_biology::detrr, mod_scalars::dt, mod_biology::idbio, mod_biology::ino3_, mod_biology::iphyt, mod_biology::isdet, mod_biology::izoop, mod_biology::k_ext, mod_biology::k_no3, mod_biology::k_phy, mod_param::n, mod_param::nbt, mod_biology::phymr, mod_scalars::sec2day, mod_biology::tl_wdet, mod_biology::vm_no3, mod_biology::wdet, mod_biology::zooec, mod_biology::zooga, mod_biology::zoogr, mod_biology::zoomd, and mod_biology::zoomr.

Referenced by tl_biology().

Here is the caller graph for this function:

◆ tl_npzd_iron_tile()

subroutine tl_biology_mod::tl_npzd_iron_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) ubt,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) tl_hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) tl_z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk), intent(in) z_w,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk), intent(in) tl_z_w,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) srflx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_srflx,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(in) t,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) tl_t )
private

Definition at line 97 of file tl_npzd_iron.h.

112!-----------------------------------------------------------------------
113!
114 USE mod_param
115 USE mod_biology
116 USE mod_ncparam
117 USE mod_scalars
118!
119! Imported variable declarations.
120!
121 integer, intent(in) :: ng, tile
122 integer, intent(in) :: LBi, UBi, LBj, UBj, UBk, UBt
123 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
124 integer, intent(in) :: nstp, nnew
125
126#ifdef ASSUMED_SHAPE
127# ifdef MASKING
128 real(r8), intent(in) :: rmask(LBi:,LBj:)
129# endif
130# if defined IRON_LIMIT && defined IRON_RELAX
131 real(r8), intent(in) :: h(LBi:,LBj:)
132# endif
133 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
134 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
135 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
136 real(r8), intent(in) :: srflx(LBi:,LBj:)
137 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
138
139 real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:)
140 real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:)
141 real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:)
142 real(r8), intent(in) :: tl_srflx(LBi:,LBj:)
143 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
144#else
145# ifdef MASKING
146 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
147# endif
148# if defined IRON_LIMIT && defined IRON_RELAX
149 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
150# endif
151 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,UBk)
152 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,UBk)
153 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:UBk)
154 real(r8), intent(in) :: srflx(LBi:UBi,LBj:UBj)
155 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,UBk,3,UBt)
156
157 real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,UBk)
158 real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,UBk)
159 real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:UBk)
160 real(r8), intent(in) :: tl_srflx(LBi:UBi,LBj:UBj)
161 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,UBk,3,UBt)
162#endif
163!
164! Local variable declarations.
165!
166 integer, parameter :: Nsink = 2
167
168 integer :: Iter, i, ibio, isink, itime, itrc, iTrcMax, j, k, ks
169 integer :: Iteradj
170
171 integer, dimension(Nsink) :: idsink
172
173 real(r8), parameter :: MinVal = 1.0e-6_r8
174
175 real(r8) :: Att, ExpAtt, Itop, PAR
176 real(r8) :: tl_Att, tl_ExpAtt, tl_Itop, tl_PAR
177 real(r8) :: cff, cff1, cff2, cff3, cff4, cff5, cff6, dtdays
178 real(r8) :: tl_cff, tl_cff1, tl_cff4, tl_cff5, tl_cff6
179 real(r8) :: cffL, cffR, cu, dltL, dltR
180 real(r8) :: tl_cffL, tl_cffR, tl_cu, tl_dltL, tl_dltR
181 real(r8) :: fac, fac1, fac2
182 real(r8) :: tl_fac, tl_fac1, tl_fac2
183#ifdef IRON_LIMIT
184 real(r8) :: Nlimit, FNlim
185 real(r8) :: tl_Nlimit, tl_FNlim
186 real(r8) :: FNratio, FCratio, FCratioE, Flimit
187 real(r8) :: tl_FNratio, tl_FCratio, tl_FCratioE, tl_Flimit
188 real(r8) :: FeC2FeN, FeN2FeC
189# ifdef IRON_RELAX
190 real(r8) :: FeNudgCoef
191# endif
192#endif
193 real(r8), dimension(Nsink) :: Wbio
194 real(r8), dimension(Nsink) :: tl_Wbio
195
196 integer, dimension(IminS:ImaxS,N(ng)) :: ksource
197
198 real(r8), dimension(IminS:ImaxS) :: PARsur
199 real(r8), dimension(IminS:ImaxS) :: tl_PARsur
200
201 real(r8), dimension(NT(ng),2) :: BioTrc
202 real(r8), dimension(NT(ng),2) :: BioTrc1
203 real(r8), dimension(NT(ng),2) :: tl_BioTrc
204 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio
205 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio1
206 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio2
207 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio_old
208
209 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: tl_Bio
210 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: tl_Bio_old
211
212 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
213 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FC
214
215 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv
216 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv2
217 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv3
218 real(r8), dimension(IminS:ImaxS,N(ng)) :: Light
219 real(r8), dimension(IminS:ImaxS,N(ng)) :: WL
220 real(r8), dimension(IminS:ImaxS,N(ng)) :: WR
221 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL
222 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL1
223 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR
224 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR1
225 real(r8), dimension(IminS:ImaxS,N(ng)) :: qc
226
227 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv
228 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv2
229 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv3
230 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Light
231 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_WL
232 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_WR
233 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_bL
234 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_bR
235 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_qc
236
237#include "set_bounds.h"
238!
239!-----------------------------------------------------------------------
240! Add biological Source/Sink terms.
241!-----------------------------------------------------------------------
242!
243! Avoid computing source/sink terms if no biological iterations.
244!
245 IF (bioiter(ng).le.0) RETURN
246!
247! Set time-stepping size (days) according to the number of iterations.
248!
249 dtdays=dt(ng)*sec2day/real(bioiter(ng),r8)
250
251#if defined IRON_LIMIT && defined IRON_RELAX
252!
253! Set nudging coefficient for dissolved iron over the shelf.
254!
255 fenudgcoef=dt(ng)/(fenudgtime(ng)*86400.0_r8)
256#endif
257#ifdef IRON_LIMIT
258!
259! Set Fe:N and Fe:C conversion ratio and its inverse.
260!
261 fen2fec=(16.0_r8/106.0_r8)*1.0e3_r8
262 fec2fen=(106.0_r8/16.0_r8)*1.0e-3_r8
263#endif
264!
265! Set vertical sinking indentification vector.
266!
267 idsink(1)=iphyt ! Phytoplankton
268 idsink(2)=isdet ! Small detritus
269!
270! Set vertical sinking velocity vector in the same order as the
271! identification vector, IDSINK.
272!
273 wbio(1)=wphy(ng) ! Phytoplankton
274 tl_wbio(1)=tl_wphy(ng) ! Phytoplankton
275 wbio(2)=wdet(ng) ! Small detritus
276 tl_wbio(2)=tl_wdet(ng) ! Small detritus
277!
278 j_loop : DO j=jstr,jend
279!
280! Compute inverse thickness to avoid repeated divisions.
281!
282 DO k=1,n(ng)
283 DO i=istr,iend
284 hz_inv(i,k)=1.0_r8/hz(i,j,k)
285 tl_hz_inv(i,k)=-hz_inv(i,k)*hz_inv(i,k)*tl_hz(i,j,k)
286 END DO
287 END DO
288 DO k=1,n(ng)-1
289 DO i=istr,iend
290 hz_inv2(i,k)=1.0_r8/(hz(i,j,k)+hz(i,j,k+1))
291 tl_hz_inv2(i,k)=-hz_inv2(i,k)*hz_inv2(i,k)* &
292 & (tl_hz(i,j,k)+tl_hz(i,j,k+1))
293 END DO
294 END DO
295 DO k=2,n(ng)-1
296 DO i=istr,iend
297 hz_inv3(i,k)=1.0_r8/(hz(i,j,k-1)+hz(i,j,k)+hz(i,j,k+1))
298 tl_hz_inv3(i,k)=-hz_inv3(i,k)*hz_inv3(i,k)* &
299 & (tl_hz(i,j,k-1)+tl_hz(i,j,k)+ &
300 & tl_hz(i,j,k+1))
301 END DO
302 END DO
303!
304! Clear tl_Bio and Bio arrays.
305!
306 DO itrc=1,nbt
307 ibio=idbio(itrc)
308 DO k=1,n(ng)
309 DO i=istr,iend
310 bio(i,k,ibio)=0.0_r8
311 bio1(i,k,ibio)=0.0_r8
312 bio2(i,k,ibio)=0.0_r8
313 tl_bio(i,k,ibio)=0.0_r8
314 END DO
315 END DO
316 END DO
317!
318! Restrict biological tracer to be positive definite. If a negative
319! concentration is detected, nitrogen is drawn from the most abundant
320! pool to supplement the negative pools to a lower limit of MinVal
321! which is set to 1E-6 above.
322!
323 DO k=1,n(ng)
324 DO i=istr,iend
325!
326! At input, all tracers (index nnew) from predictor step have
327! transport units (m Tunits) since we do not have yet the new
328! values for zeta and Hz. These are known after the 2D barotropic
329! time-stepping.
330!
331! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
332! tracer times depth. However the basic state (nstp and nnew
333! indices) that is read from the forward file is in units of
334! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
335! use t instead of t*Hz_inv.
336!
337 DO itrc=1,nbt
338 ibio=idbio(itrc)
339!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
340!^
341 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
342 tl_biotrc(ibio,nstp)=tl_t(i,j,k,nstp,ibio)
343!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
344!^
345 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
346 tl_biotrc(ibio,nnew)=tl_t(i,j,k,nnew,ibio)* &
347 & hz_inv(i,k)+ &
348 & t(i,j,k,nnew,ibio)*hz(i,j,k)* &
349 & tl_hz_inv(i,k)
350 END DO
351!
352! Impose positive definite concentrations.
353!
354 cff2=0.0_r8
355 DO itime=1,2
356 cff1=0.0_r8
357 tl_cff1=0.0_r8
358 itrcmax=idbio(1)
359#ifdef IRON_LIMIT
360 DO itrc=1,nbt-2
361#else
362 DO itrc=1,nbt
363#endif
364 ibio=idbio(itrc)
365 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
366 tl_cff1=tl_cff1- &
367 & (0.5_r8-sign(0.5_r8, &
368 & biotrc(ibio,itime)-minval))* &
369 & tl_biotrc(ibio,itime)
370 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
371 itrcmax=ibio
372 END IF
373 biotrc1(ibio,itime)=biotrc(ibio,itime)
374 biotrc(ibio,itime)=max(minval,biotrc1(ibio,itime))
375 tl_biotrc(ibio,itime)=(0.5_r8- &
376 & sign(0.5_r8, &
377 & minval- &
378 & biotrc1(ibio,itime)))* &
379 & tl_biotrc(ibio,itime)
380 END DO
381 IF (biotrc(itrcmax,itime).gt.cff1) THEN
382 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
383 tl_biotrc(itrcmax,itime)=tl_biotrc(itrcmax,itime)- &
384 & tl_cff1
385 END IF
386#ifdef IRON_LIMIT
387 DO itrc=nbt-1,nbt
388 ibio=idbio(itrc)
389 biotrc1(ibio,itime)=biotrc(ibio,itime)
390 biotrc(ibio,itime)=max(minval,biotrc1(ibio,itime))
391 tl_biotrc(ibio,itime)=(0.5_r8- &
392 & sign(0.5_r8, &
393 & minval- &
394 & biotrc1(ibio,itime)))* &
395 & tl_biotrc(ibio,itime)
396 END DO
397#endif
398 END DO
399!
400! Load biological tracers into local arrays.
401!
402 DO itrc=1,nbt
403 ibio=idbio(itrc)
404 bio_old(i,k,ibio)=biotrc(ibio,nstp)
405 tl_bio_old(i,k,ibio)=tl_biotrc(ibio,nstp)
406 bio(i,k,ibio)=biotrc(ibio,nstp)
407 tl_bio(i,k,ibio)=tl_biotrc(ibio,nstp)
408 END DO
409
410#if defined IRON_LIMIT && defined IRON_RELAX
411!
412! Relax dissolved iron at coast (h <= FeHim) to a constant value
413! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
414! at the shelf.
415!
416 IF (h(i,j).le.fehmin(ng)) THEN
417!^ Bio(i,k,iFdis)=Bio(i,k,iFdis)+ &
418!^ & FeNudgCoef*(FeMax(ng)-Bio(i,k,iFdis))
419!^
420 tl_bio(i,k,ifdis)=tl_bio(i,k,ifdis)- &
421 & fenudgcoef*tl_bio(i,k,ifdis)
422 END IF
423#endif
424 END DO
425 END DO
426!
427! Calculate surface Photosynthetically Available Radiation (PAR). The
428! net shortwave radiation is scaled back to Watts/m2 and multiplied by
429! the fraction that is photosynthetically available, PARfrac.
430!
431 DO i=istr,iend
432#ifdef CONST_PAR
433!
434! Specify constant surface irradiance a la Powell and Spitz.
435!
436 parsur(i)=158.075_r8
437 tl_parsur(i)=0.0_r8
438#else
439 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
440 tl_parsur(i)=(tl_parfrac(ng)*srflx(i,j)+ &
441 & parfrac(ng)*tl_srflx(i,j))*rho0*cp
442#endif
443 END DO
444!
445!=======================================================================
446! Start internal iterations to achieve convergence of the nonlinear
447! backward-implicit solution.
448!=======================================================================
449!
450! During the iterative procedure a series of fractional time steps are
451! performed in a chained mode (splitting by different biological
452! conversion processes) in sequence of the main food chain. In all
453! stages the concentration of the component being consumed is treated
454! in a fully implicit manner, so the algorithm guarantees non-negative
455! values, no matter how strong the concentration of active consuming
456! component (Phytoplankton or Zooplankton). The overall algorithm,
457! as well as any stage of it, is formulated in conservative form
458! (except explicit sinking) in sense that the sum of concentration of
459! all components is conserved.
460!
461! In the implicit algorithm, we have for example (N: nutrient,
462! P: phytoplankton),
463!
464! N(new) = N(old) - uptake * P(old) uptake = mu * N / (Kn + N)
465! {Michaelis-Menten}
466! below, we set
467! The N in the numerator of
468! cff = mu * P(old) / (Kn + N(old)) uptake is treated implicitly
469! as N(new)
470!
471! so the time-stepping of the equations becomes:
472!
473! N(new) = N(old) / (1 + cff) (1) when substracting a sink term,
474! consuming, divide by (1 + cff)
475! and
476!
477! P(new) = P(old) + cff * N(new) (2) when adding a source term,
478! growing, add (cff * source)
479!
480! Notice that if you substitute (1) in (2), you will get:
481!
482! P(new) = P(old) + cff * N(old) / (1 + cff) (3)
483!
484! If you add (1) and (3), you get
485!
486! N(new) + P(new) = N(old) + P(old)
487!
488! implying conservation regardless how "cff" is computed. Therefore,
489! this scheme is unconditionally stable regardless of the conversion
490! rate. It does not generate negative values since the constituent
491! to be consumed is always treated implicitly. It is also biased
492! toward damping oscillations.
493!
494! The iterative loop below is to iterate toward an universal Backward-
495! Euler treatment of all terms. So if there are oscillations in the
496! system, they are only physical oscillations. These iterations,
497! however, do not improve the accuaracy of the solution.
498!
499 iter_loop: DO iter=1,bioiter(ng)
500!
501! Compute appropriate basic state arrays I.
502!
503 DO k=1,n(ng)
504 DO i=istr,iend
505!
506! At input, all tracers (index nnew) from predictor step have
507! transport units (m Tunits) since we do not have yet the new
508! values for zeta and Hz. These are known after the 2D barotropic
509! time-stepping.
510!
511! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
512! tracer times depth. However the basic state (nstp and nnew
513! indices) that is read from the forward file is in units of
514! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
515! use t instead of t*Hz_inv.
516!
517 DO itrc=1,nbt
518 ibio=idbio(itrc)
519!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
520!^
521 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
522!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
523!^
524 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
525 END DO
526!
527! Impose positive definite concentrations.
528!
529 cff2=0.0_r8
530 DO itime=1,2
531 cff1=0.0_r8
532 itrcmax=idbio(1)
533#ifdef IRON_LIMIT
534 DO itrc=1,nbt-2
535#else
536 DO itrc=1,nbt
537#endif
538 ibio=idbio(itrc)
539 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
540 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
541 itrcmax=ibio
542 END IF
543 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
544 END DO
545 IF (biotrc(itrcmax,itime).gt.cff1) THEN
546 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
547 END IF
548#ifdef IRON_LIMIT
549 DO itrc=nbt-1,nbt
550 ibio=idbio(itrc)
551 biotrc1(ibio,itime)=biotrc(ibio,itime)
552 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
553 END DO
554#endif
555 END DO
556!
557! Load biological tracers into local arrays.
558!
559 DO itrc=1,nbt
560 ibio=idbio(itrc)
561 bio_old(i,k,ibio)=biotrc(ibio,nstp)
562 bio(i,k,ibio)=biotrc(ibio,nstp)
563 END DO
564
565#if defined IRON_LIMIT && defined IRON_RELAX
566!
567! Relax dissolved iron at coast (h <= FeHim) to a constant value
568! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
569! at the shelf.
570!
571 IF (h(i,j).le.fehmin(ng)) THEN
572 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
573 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
574 END IF
575#endif
576 END DO
577 END DO
578!
579! Calculate surface Photosynthetically Available Radiation (PAR). The
580! net shortwave radiation is scaled back to Watts/m2 and multiplied by
581! the fraction that is photosynthetically available, PARfrac.
582!
583 DO i=istr,iend
584#ifdef CONST_PAR
585!
586! Specify constant surface irradiance a la Powell and Spitz.
587!
588 parsur(i)=158.075_r8
589#else
590 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
591#endif
592 END DO
593!
594!=======================================================================
595! Start internal iterations to achieve convergence of the nonlinear
596! backward-implicit solution.
597!=======================================================================
598!
599 DO iteradj=1,iter
600!
601! Compute light attenuation as function of depth.
602!
603 DO i=istr,iend
604 par=parsur(i)
605 IF (parsur(i).gt.0.0_r8) THEN ! day time
606 DO k=n(ng),1,-1
607!
608! Compute average light attenuation for each grid cell. Here, AttSW is
609! the light attenuation due to seawater and AttPhy is the attenuation
610! due to phytoplankton (self-shading coefficient).
611!
612 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
613 & (z_w(i,j,k)-z_w(i,j,k-1))
614 expatt=exp(-att)
615 itop=par
616 par=itop*(1.0_r8-expatt)/att ! average at cell center
617 light(i,k)=par
618!
619! Light attenuation at the bottom of the grid cell. It is the starting
620! PAR value for the next (deeper) vertical grid cell.
621!
622 par=itop*expatt
623 END DO
624 ELSE ! night time
625 DO k=1,n(ng)
626 light(i,k)=0.0_r8
627 END DO
628 END IF
629 END DO
630!
631! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
632! The Michaelis-Menten curve is used to describe the change in uptake
633! rate as a function of nitrate concentration. Here, PhyIS is the
634! initial slope of the P-I curve and K_NO3 is the half saturation of
635! phytoplankton nitrate uptake.
636#ifdef IRON_LIMIT
637!
638! Growth reduction factors due to iron limitation:
639!
640! FNratio current Fe:N ratio [umol-Fe/mmol-N]
641! FCratio current Fe:C ratio [umol-Fe/mol-C]
642! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
643! FCratioE empirical Fe:C ratio
644! Flimit Phytoplankton growth reduction factor due to Fe
645! limitation based on Fe:C ratio
646!
647#endif
648!
649 cff1=dtdays*vm_no3(ng)*phyis(ng)
650 cff2=vm_no3(ng)*vm_no3(ng)
651 cff3=phyis(ng)*phyis(ng)
652 DO k=1,n(ng)
653 DO i=istr,iend
654#ifdef IRON_LIMIT
655!
656! Calculate growth reduction factor due to iron limitation.
657!
658 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
659 fcratio=fnratio*fen2fec
660 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
661 flimit=fcratio*fcratio/ &
662 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
663
664 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
665 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
666#endif
667 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
668 cff=bio(i,k,iphyt)* &
669#ifdef IRON_LIMIT
670 & cff1*cff4*light(i,k)*fnlim*nlimit
671#else
672 & cff1*cff4*light(i,k)/ &
673 & (k_no3(ng)+bio(i,k,ino3_))
674#endif
675 bio1(i,k,ino3_)=bio(i,k,ino3_)
676 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
677 bio1(i,k,iphyt)=bio(i,k,iphyt)
678 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
679 & bio(i,k,ino3_)*cff
680
681#ifdef IRON_LIMIT
682!
683! Iron uptake proportional to growth.
684!
685 fac=cff*bio(i,k,ino3_)*fnratio/ &
686 & max(minval,bio(i,k,ifdis))
687 bio1(i,k,ifdis)=bio(i,k,ifdis)
688 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
689 bio2(i,k,ifdis)=bio(i,k,ifdis)
690 bio1(i,k,ifphy)=bio(i,k,ifphy)
691 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
692 & bio(i,k,ifdis)*fac
693 bio2(i,k,ifphy)=bio(i,k,ifphy)
694!
695! Iron uptake to reach appropriate Fe:C ratio.
696!
697 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
698 cff6=bio(i,k,iphyt)*cff5*fec2fen
699 IF (cff6.ge.0.0_r8) THEN
700 cff=cff6/max(minval,bio(i,k,ifdis))
701 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
702 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
703 & bio(i,k,ifdis)*cff
704 ELSE
705 cff=-cff6/max(minval,bio(i,k,ifphy))
706 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
707 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
708 & bio(i,k,ifphy)*cff
709 END IF
710#endif
711 END DO
712 END DO
713!
714 IF (iteradj.ne.iter) THEN
715!
716! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
717! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
718! pool as function of "sloppy feeding" and metabolic processes
719! (ZooEEN and ZooEED fractions).
720#ifdef IRON_LIMIT
721! The lost of phytoplankton to the dissolve iron pool is scale by the
722! remineralization rate (FeRR).
723#endif
724!
725 cff1=dtdays*zoogr(ng)
726 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
727 DO k=1,n(ng)
728 DO i=istr,iend
729 cff=bio(i,k,izoop)* &
730 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
731 & bio(i,k,iphyt)
732 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
733 bio(i,k,izoop)=bio(i,k,izoop)+ &
734 & bio(i,k,iphyt)*cff2*cff
735 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
736 & bio(i,k,iphyt)*zooeen(ng)*cff
737 bio(i,k,isdet)=bio(i,k,isdet)+ &
738 & bio(i,k,iphyt)*zooeed(ng)*cff
739#ifdef IRON_LIMIT
740 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
741 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
742 & bio(i,k,ifphy)*cff*ferr(ng)
743#endif
744 END DO
745 END DO
746!
747! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
748! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
749!
750 cff3=dtdays*phymrd(ng)
751 cff2=dtdays*phymrn(ng)
752 cff1=1.0_r8/(1.0_r8+cff2+cff3)
753 DO k=1,n(ng)
754 DO i=istr,iend
755 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
756 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
757 & bio(i,k,iphyt)*cff2
758 bio(i,k,isdet)=bio(i,k,isdet)+ &
759 & bio(i,k,iphyt)*cff3
760#ifdef IRON_LIMIT
761 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
762 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
763 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
764#endif
765 END DO
766 END DO
767!
768! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
769! (ZooMRD rate).
770!
771 cff3=dtdays*zoomrd(ng)
772 cff2=dtdays*zoomrn(ng)
773 cff1=1.0_r8/(1.0_r8+cff2+cff3)
774 DO k=1,n(ng)
775 DO i=istr,iend
776 bio(i,k,izoop)=bio(i,k,izoop)*cff1
777 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
778 & bio(i,k,izoop)*cff2
779 bio(i,k,isdet)=bio(i,k,isdet)+ &
780 & bio(i,k,izoop)*cff3
781 END DO
782 END DO
783!
784! Detritus breakdown to nutrients: remineralization (DetRR rate).
785!
786 cff2=dtdays*detrr(ng)
787 cff1=1.0_r8/(1.0_r8+cff2)
788 DO k=1,n(ng)
789 DO i=istr,iend
790 bio(i,k,isdet)=bio(i,k,isdet)*cff1
791 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
792 & bio(i,k,isdet)*cff2
793 END DO
794 END DO
795!
796!-----------------------------------------------------------------------
797! Vertical sinking terms: Phytoplankton and Detritus
798!-----------------------------------------------------------------------
799!
800! Reconstruct vertical profile of selected biological constituents
801! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
802! grid box. Then, compute semi-Lagrangian flux due to sinking.
803!
804 DO isink=1,nsink
805 ibio=idsink(isink)
806!
807! Copy concentration of biological particulates into scratch array
808! "qc" (q-central, restrict it to be positive) which is hereafter
809! interpreted as a set of grid-box averaged values for biogeochemical
810! constituent concentration.
811!
812 DO k=1,n(ng)
813 DO i=istr,iend
814 qc(i,k)=bio(i,k,ibio)
815 END DO
816 END DO
817!
818 DO k=n(ng)-1,1,-1
819 DO i=istr,iend
820 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
821 END DO
822 END DO
823 DO k=2,n(ng)-1
824 DO i=istr,iend
825 dltr=hz(i,j,k)*fc(i,k)
826 dltl=hz(i,j,k)*fc(i,k-1)
827 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
828 cffr=cff*fc(i,k)
829 cffl=cff*fc(i,k-1)
830!
831! Apply PPM monotonicity constraint to prevent oscillations within the
832! grid box.
833!
834 IF ((dltr*dltl).le.0.0_r8) THEN
835 dltr=0.0_r8
836 dltl=0.0_r8
837 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
838 dltr=cffl
839 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
840 dltl=cffr
841 END IF
842!
843! Compute right and left side values (bR,bL) of parabolic segments
844! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
845!
846! NOTE: Although each parabolic segment is monotonic within its grid
847! box, monotonicity of the whole profile is not guaranteed,
848! because bL(k+1)-bR(k) may still have different sign than
849! qc(i,k+1)-qc(i,k). This possibility is excluded,
850! after bL and bR are reconciled using WENO procedure.
851!
852 cff=(dltr-dltl)*hz_inv3(i,k)
853 dltr=dltr-cff*hz(i,j,k+1)
854 dltl=dltl+cff*hz(i,j,k-1)
855 br(i,k)=qc(i,k)+dltr
856 bl(i,k)=qc(i,k)-dltl
857 wr(i,k)=(2.0_r8*dltr-dltl)**2
858 wl(i,k)=(dltr-2.0_r8*dltl)**2
859 END DO
860 END DO
861 cff=1.0e-14_r8
862 DO k=2,n(ng)-2
863 DO i=istr,iend
864 dltl=max(cff,wl(i,k ))
865 dltr=max(cff,wr(i,k+1))
866 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
867 bl(i,k+1)=br(i,k)
868 END DO
869 END DO
870 DO i=istr,iend
871 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
872#if defined LINEAR_CONTINUATION
873 bl(i,n(ng))=br(i,n(ng)-1)
874 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
875#elif defined NEUMANN
876 bl(i,n(ng))=br(i,n(ng)-1)
877 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
878#else
879 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
880 bl(i,n(ng))=qc(i,n(ng)) ! conditions
881 br(i,n(ng)-1)=qc(i,n(ng))
882#endif
883#if defined LINEAR_CONTINUATION
884 br(i,1)=bl(i,2)
885 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
886#elif defined NEUMANN
887 br(i,1)=bl(i,2)
888 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
889#else
890 bl(i,2)=qc(i,1) ! bottom grid boxes are
891 br(i,1)=qc(i,1) ! re-assumed to be
892 bl(i,1)=qc(i,1) ! piecewise constant.
893#endif
894 END DO
895!
896! Apply monotonicity constraint again, since the reconciled interfacial
897! values may cause a non-monotonic behavior of the parabolic segments
898! inside the grid box.
899!
900 DO k=1,n(ng)
901 DO i=istr,iend
902 dltr=br(i,k)-qc(i,k)
903 dltl=qc(i,k)-bl(i,k)
904 cffr=2.0_r8*dltr
905 cffl=2.0_r8*dltl
906 IF ((dltr*dltl).lt.0.0_r8) THEN
907 dltr=0.0_r8
908 dltl=0.0_r8
909 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
910 dltr=cffl
911 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
912 dltl=cffr
913 END IF
914 br(i,k)=qc(i,k)+dltr
915 bl(i,k)=qc(i,k)-dltl
916 END DO
917 END DO
918!
919! After this moment reconstruction is considered complete. The next
920! stage is to compute vertical advective fluxes, FC. It is expected
921! that sinking may occurs relatively fast, the algorithm is designed
922! to be free of CFL criterion, which is achieved by allowing
923! integration bounds for semi-Lagrangian advective flux to use as
924! many grid boxes in upstream direction as necessary.
925!
926! In the two code segments below, WL is the z-coordinate of the
927! departure point for grid box interface z_w with the same indices;
928! FC is the finite volume flux; ksource(:,k) is index of vertical
929! grid box which contains the departure point (restricted by N(ng)).
930! During the search: also add in content of whole grid boxes
931! participating in FC.
932!
933 cff=dtdays*abs(wbio(isink))
934 DO k=1,n(ng)
935 DO i=istr,iend
936 fc(i,k-1)=0.0_r8
937 wl(i,k)=z_w(i,j,k-1)+cff
938 wr(i,k)=hz(i,j,k)*qc(i,k)
939 ksource(i,k)=k
940 END DO
941 END DO
942 DO k=1,n(ng)
943 DO ks=k,n(ng)-1
944 DO i=istr,iend
945 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
946 ksource(i,k)=ks+1
947 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
948 END IF
949 END DO
950 END DO
951 END DO
952!
953! Finalize computation of flux: add fractional part.
954!
955 DO k=1,n(ng)
956 DO i=istr,iend
957 ks=ksource(i,k)
958 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
959 fc(i,k-1)=fc(i,k-1)+ &
960 & hz(i,j,ks)*cu* &
961 & (bl(i,ks)+ &
962 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
963 & (1.5_r8-cu)* &
964 & (br(i,ks)+bl(i,ks)- &
965 & 2.0_r8*qc(i,ks))))
966 END DO
967 END DO
968 DO k=1,n(ng)
969 DO i=istr,iend
970 bio(i,k,ibio)=qc(i,k)+ &
971 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
972 END DO
973 END DO
974 END DO
975 END IF
976 END DO
977!
978! End of compute basic state arrays I.
979!
980! Compute light attenuation as function of depth.
981!
982 DO i=istr,iend
983 par=parsur(i)
984 tl_par=tl_parsur(i)
985 IF (parsur(i).gt.0.0_r8) THEN ! day time
986 DO k=n(ng),1,-1
987!
988! Compute average light attenuation for each grid cell. Here, AttSW is
989! the light attenuation due to seawater and AttPhy is the attenuation
990! due to phytoplankton (self-shading coefficient).
991!
992 att=(attsw(ng)+attphy(ng)*bio1(i,k,iphyt))* &
993 & (z_w(i,j,k)-z_w(i,j,k-1))
994 tl_att=attphy(ng)*tl_bio(i,k,iphyt)* &
995 & (z_w(i,j,k)-z_w(i,j,k-1))+ &
996 & (attsw(ng)+attphy(ng)*bio1(i,k,iphyt))* &
997 & (tl_z_w(i,j,k)-tl_z_w(i,j,k-1))
998 expatt=exp(-att)
999 tl_expatt=-expatt*tl_att
1000 itop=par
1001 tl_itop=tl_par
1002 par=itop*(1.0_r8-expatt)/att ! average at cell center
1003 tl_par=(-tl_att*par+tl_itop*(1.0_r8-expatt)- &
1004 & itop*tl_expatt)/att
1005!^ Light(i,k)=PAR
1006!^
1007 tl_light(i,k)=tl_par
1008!
1009! Light attenuation at the bottom of the grid cell. It is the starting
1010! PAR value for the next (deeper) vertical grid cell.
1011!
1012 par=itop*expatt
1013 tl_par=tl_itop*expatt+itop*tl_expatt
1014 END DO
1015 ELSE ! night time
1016 DO k=1,n(ng)
1017!^ Light(i,k)=0.0_r8
1018!^
1019 tl_light(i,k)=0.0_r8
1020 END DO
1021 END IF
1022 END DO
1023!
1024! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
1025! The Michaelis-Menten curve is used to describe the change in uptake
1026! rate as a function of nitrate concentration. Here, PhyIS is the
1027! initial slope of the P-I curve and K_NO3 is the half saturation of
1028! phytoplankton nitrate uptake.
1029#ifdef IRON_LIMIT
1030!
1031! Growth reduction factors due to iron limitation:
1032!
1033! FNratio current Fe:N ratio [umol-Fe/mmol-N]
1034! FCratio current Fe:C ratio [umol-Fe/mol-C]
1035! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
1036! FCratioE empirical Fe:C ratio
1037! Flimit Phytoplankton growth reduction factor due to Fe
1038! limitation based on Fe:C ratio
1039!
1040#endif
1041!
1042 cff1=dtdays*vm_no3(ng)*phyis(ng)
1043 cff2=vm_no3(ng)*vm_no3(ng)
1044 cff3=phyis(ng)*phyis(ng)
1045 DO k=1,n(ng)
1046 DO i=istr,iend
1047#ifdef IRON_LIMIT
1048!
1049! Calculate growth reduction factor due to iron limitation.
1050!
1051!^ FNratio=Bio(i,k,iFphy)/MAX(MinVal,Bio(i,k,iPhyt))
1052!^
1053 fac1=max(minval,bio1(i,k,iphyt))
1054 tl_fac1=(0.5_r8-sign(0.5_r8,minval-bio1(i,k,iphyt)))* &
1055 & tl_bio(i,k,iphyt)
1056 fnratio=bio1(i,k,ifphy)/fac1
1057 tl_fnratio=(tl_bio(i,k,ifphy)-tl_fac1*fnratio)/fac1
1058 fcratio=fnratio*fen2fec
1059 tl_fcratio=tl_fnratio*fen2fec
1060 fcratioe=b_fe(ng)*bio1(i,k,ifdis)**a_fe(ng)
1061 tl_fcratioe=a_fe(ng)*b_fe(ng)* &
1062 & bio1(i,k,ifdis)**(a_fe(ng)-1.0_r8)* &
1063 & tl_bio(i,k,ifdis)
1064 flimit=fcratio*fcratio/ &
1065 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
1066 tl_flimit=2.0_r8*(tl_fcratio*fcratio- &
1067 & tl_fcratio*fcratio*flimit)/ &
1068 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
1069 nlimit=1.0_r8/(k_no3(ng)+bio1(i,k,ino3_))
1070 tl_nlimit=-tl_bio(i,k,ino3_)*nlimit*nlimit
1071!^ FNlim=MIN(1.0_r8,Flimit/(Bio1(i,k,iNO3_)*Nlimit))
1072!^
1073 fac1=flimit/(bio1(i,k,ino3_)*nlimit)
1074 tl_fac1=tl_flimit/(bio1(i,k,ino3_)*nlimit)- &
1075 & (tl_bio(i,k,ino3_)*nlimit+ &
1076 & bio1(i,k,ino3_)*tl_nlimit)*fac1/ &
1077 & (bio1(i,k,ino3_)*nlimit)
1078 fnlim=min(1.0_r8,fac1)
1079 tl_fnlim=(0.5_r8+sign(0.5_r8,1.0_r8-fac1))*tl_fac1
1080#endif
1081 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
1082 tl_cff4=-cff3*tl_light(i,k)*light(i,k)*cff4*cff4*cff4
1083 cff=bio1(i,k,iphyt)* &
1084#ifdef IRON_LIMIT
1085 & cff1*cff4*light(i,k)*fnlim*nlimit
1086#else
1087 & cff1*cff4*light(i,k)/ &
1088 & (k_no3(ng)+bio1(i,k,ino3_))
1089#endif
1090#ifdef IRON_LIMIT
1091 tl_cff=tl_bio(i,k,iphyt)* &
1092 & cff1*cff4*light(i,k)*fnlim*nlimit+ &
1093 & bio1(i,k,iphyt)*cff1*cff4* &
1094 & (tl_light(i,k)*fnlim*nlimit+ &
1095 & light(i,k)*tl_fnlim*nlimit+ &
1096 & light(i,k)*fnlim*tl_nlimit)+ &
1097 & bio1(i,k,iphyt)*cff1*tl_cff4* &
1098 & light(i,k)*fnlim*nlimit
1099#else
1100 tl_cff=(tl_bio(i,k,iphyt)*cff1*cff4*light(i,k)+ &
1101 & bio1(i,k,iphyt)*cff1* &
1102 & (tl_cff4*light(i,k)+cff4*tl_light(i,k))- &
1103 & tl_bio(i,k,ino3_)*cff)/ &
1104 & (k_no3(ng)+bio1(i,k,ino3_))
1105#endif
1106!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)/(1.0_r8+cff)
1107!^
1108 tl_bio(i,k,ino3_)=(tl_bio(i,k,ino3_)- &
1109 & tl_cff*bio(i,k,ino3_))/ &
1110 & (1.0_r8+cff)
1111!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)+ &
1112!^ & Bio(i,k,iNO3_)*cff
1113!^
1114 tl_bio(i,k,iphyt)=tl_bio(i,k,iphyt)+ &
1115 & tl_bio(i,k,ino3_)*cff+ &
1116 & bio(i,k,ino3_)*tl_cff
1117
1118#ifdef IRON_LIMIT
1119!
1120! Iron uptake proportional to growth.
1121!
1122!^ fac=cff*Bio(i,k,iNO3_)*FNratio/MAX(MinVal,Bio1(i,k,iFdis))
1123!^
1124 fac1=max(minval,bio1(i,k,ifdis))
1125 tl_fac1=(0.5_r8-sign(0.5_r8,minval-bio1(i,k,ifdis)))* &
1126 & tl_bio(i,k,ifdis)
1127 fac2=1.0_r8/fac1
1128 tl_fac2=-fac2*fac2*tl_fac1
1129 fac=cff*bio(i,k,ino3_)*fnratio*fac2
1130 tl_fac=fnratio*fac2*(tl_cff*bio(i,k,ino3_)+ &
1131 & cff*tl_bio(i,k,ino3_))+ &
1132 & cff*bio(i,k,ino3_)*(tl_fnratio*fac2+ &
1133 & fnratio*tl_fac2)
1134!^ Bio(i,k,iFdis)=Bio(i,k,iFdis)/(1.0_r8+fac)
1135!^
1136 tl_bio(i,k,ifdis)=(tl_bio(i,k,ifdis)- &
1137 & tl_fac*bio2(i,k,ifdis))/ &
1138 & (1.0_r8+fac)
1139!^ Bio(i,k,iFphy)=Bio(i,k,iFphy)+ &
1140!^ & Bio(i,k,iFdis)*fac
1141!^
1142 tl_bio(i,k,ifphy)=tl_bio(i,k,ifphy)+ &
1143 & tl_bio(i,k,ifdis)*fac+ &
1144 & bio2(i,k,ifdis)*tl_fac
1145!
1146! Iron uptake to reach appropriate Fe:C ratio.
1147!
1148 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
1149 tl_cff5=dtdays*(tl_fcratioe-tl_fcratio)/t_fe(ng)
1150 cff6=bio(i,k,iphyt)*cff5*fec2fen
1151 tl_cff6=(tl_bio(i,k,iphyt)*cff5+ &
1152 & bio(i,k,iphyt)*tl_cff5)*fec2fen
1153 IF (cff6.ge.0.0_r8) THEN
1154!^ cff=cff6/MAX(MinVal,Bio2(i,k,iFdis))
1155!^
1156 fac1=max(minval,bio2(i,k,ifdis))
1157 tl_fac1=(0.5_r8-sign(0.5_r8,minval-bio2(i,k,ifdis)))* &
1158 & tl_bio(i,k,ifdis)
1159 cff=cff6/fac1
1160 tl_cff=(tl_cff6-tl_fac1*cff)/fac1
1161!^ Bio(i,k,iFdis)=Bio(i,k,iFdis)/(1.0_r8+cff)
1162!^
1163 tl_bio(i,k,ifdis)=(tl_bio(i,k,ifdis)- &
1164 & tl_cff*bio(i,k,ifdis))/ &
1165 & (1.0_r8+cff)
1166!^ Bio(i,k,iFphy)=Bio(i,k,iFphy)+ &
1167!^ & Bio(i,k,iFdis)*cff
1168!^
1169 tl_bio(i,k,ifphy)=tl_bio(i,k,ifphy)+ &
1170 & tl_bio(i,k,ifdis)*cff+ &
1171 & bio(i,k,ifdis)*tl_cff
1172 ELSE
1173!^ cff=-cff6/MAX(MinVal,Bio2(i,k,iFphy))
1174!^
1175 fac1=-max(minval,bio2(i,k,ifphy))
1176 tl_fac1=-(0.5_r8-sign(0.5_r8,minval-bio2(i,k,ifphy)))* &
1177 & tl_bio(i,k,ifphy)
1178 cff=cff6/fac1
1179 tl_cff=(tl_cff6-tl_fac1*cff)/fac1
1180!^ Bio(i,k,iFphy)=Bio(i,k,iFphy)/(1.0_r8+cff)
1181!^
1182 tl_bio(i,k,ifphy)=(tl_bio(i,k,ifphy)- &
1183 & tl_cff*bio(i,k,ifphy))/ &
1184 & (1.0_r8+cff)
1185!^ Bio(i,k,iFdis)=Bio(i,k,iFdis)+ &
1186!^ & Bio(i,k,iFphy)*cff
1187!^
1188 tl_bio(i,k,ifdis)=tl_bio(i,k,ifdis)+ &
1189 & tl_bio(i,k,ifphy)*cff+ &
1190 & bio(i,k,ifphy)*tl_cff
1191 END IF
1192#endif
1193 END DO
1194 END DO
1195!
1196! Compute appropriate basic state arrays II.
1197!
1198 DO k=1,n(ng)
1199 DO i=istr,iend
1200!
1201! At input, all tracers (index nnew) from predictor step have
1202! transport units (m Tunits) since we do not have yet the new
1203! values for zeta and Hz. These are known after the 2D barotropic
1204! time-stepping.
1205!
1206! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
1207! tracer times depth. However the basic state (nstp and nnew
1208! indices) that is read from the forward file is in units of
1209! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
1210! use t instead of t*Hz_inv.
1211!
1212 DO itrc=1,nbt
1213 ibio=idbio(itrc)
1214!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1215!^
1216 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1217!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
1218!^
1219 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
1220 END DO
1221!
1222! Impose positive definite concentrations.
1223!
1224 cff2=0.0_r8
1225 DO itime=1,2
1226 cff1=0.0_r8
1227 itrcmax=idbio(1)
1228#ifdef IRON_LIMIT
1229 DO itrc=1,nbt-2
1230#else
1231 DO itrc=1,nbt
1232#endif
1233 ibio=idbio(itrc)
1234 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
1235 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
1236 itrcmax=ibio
1237 END IF
1238 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
1239 END DO
1240 IF (biotrc(itrcmax,itime).gt.cff1) THEN
1241 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
1242 END IF
1243#ifdef IRON_LIMIT
1244 DO itrc=nbt-1,nbt
1245 ibio=idbio(itrc)
1246 biotrc1(ibio,itime)=biotrc(ibio,itime)
1247 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
1248 END DO
1249#endif
1250 END DO
1251!
1252! Load biological tracers into local arrays.
1253!
1254 DO itrc=1,nbt
1255 ibio=idbio(itrc)
1256 bio_old(i,k,ibio)=biotrc(ibio,nstp)
1257 bio(i,k,ibio)=biotrc(ibio,nstp)
1258 END DO
1259
1260#if defined IRON_LIMIT && defined IRON_RELAX
1261!
1262! Relax dissolved iron at coast (h <= FeHim) to a constant value
1263! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
1264! at the shelf.
1265!
1266 IF (h(i,j).le.fehmin(ng)) THEN
1267 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1268 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
1269 END IF
1270#endif
1271 END DO
1272 END DO
1273!
1274! Calculate surface Photosynthetically Available Radiation (PAR). The
1275! net shortwave radiation is scaled back to Watts/m2 and multiplied by
1276! the fraction that is photosynthetically available, PARfrac.
1277!
1278 DO i=istr,iend
1279#ifdef CONST_PAR
1280!
1281! Specify constant surface irradiance a la Powell and Spitz.
1282!
1283 parsur(i)=158.075_r8
1284#else
1285 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
1286#endif
1287 END DO
1288!
1289!=======================================================================
1290! Start internal iterations to achieve convergence of the nonlinear
1291! backward-implicit solution.
1292!=======================================================================
1293!
1294 DO iteradj=1,iter
1295!
1296! Compute light attenuation as function of depth.
1297!
1298 DO i=istr,iend
1299 par=parsur(i)
1300 IF (parsur(i).gt.0.0_r8) THEN ! day time
1301 DO k=n(ng),1,-1
1302!
1303! Compute average light attenuation for each grid cell. Here, AttSW is
1304! the light attenuation due to seawater and AttPhy is the attenuation
1305! due to phytoplankton (self-shading coefficient).
1306!
1307 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
1308 & (z_w(i,j,k)-z_w(i,j,k-1))
1309 expatt=exp(-att)
1310 itop=par
1311 par=itop*(1.0_r8-expatt)/att ! average at cell center
1312 light(i,k)=par
1313!
1314! Light attenuation at the bottom of the grid cell. It is the starting
1315! PAR value for the next (deeper) vertical grid cell.
1316!
1317 par=itop*expatt
1318 END DO
1319 ELSE ! night time
1320 DO k=1,n(ng)
1321 light(i,k)=0.0_r8
1322 END DO
1323 END IF
1324 END DO
1325!
1326! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
1327! The Michaelis-Menten curve is used to describe the change in uptake
1328! rate as a function of nitrate concentration. Here, PhyIS is the
1329! initial slope of the P-I curve and K_NO3 is the half saturation of
1330! phytoplankton nitrate uptake.
1331#ifdef IRON_LIMIT
1332!
1333! Growth reduction factors due to iron limitation:
1334!
1335! FNratio current Fe:N ratio [umol-Fe/mmol-N]
1336! FCratio current Fe:C ratio [umol-Fe/mol-C]
1337! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
1338! FCratioE empirical Fe:C ratio
1339! Flimit Phytoplankton growth reduction factor due to Fe
1340! limitation based on Fe:C ratio
1341!
1342#endif
1343!
1344 cff1=dtdays*vm_no3(ng)*phyis(ng)
1345 cff2=vm_no3(ng)*vm_no3(ng)
1346 cff3=phyis(ng)*phyis(ng)
1347 DO k=1,n(ng)
1348 DO i=istr,iend
1349#ifdef IRON_LIMIT
1350!
1351! Calculate growth reduction factor due to iron limitation.
1352!
1353 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
1354 fcratio=fnratio*fen2fec
1355 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
1356 flimit=fcratio*fcratio/ &
1357 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
1358
1359 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
1360 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
1361#endif
1362 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
1363 cff=bio(i,k,iphyt)* &
1364#ifdef IRON_LIMIT
1365 & cff1*cff4*light(i,k)*fnlim*nlimit
1366#else
1367 & cff1*cff4*light(i,k)/ &
1368 & (k_no3(ng)+bio(i,k,ino3_))
1369#endif
1370 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
1371 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
1372 & bio(i,k,ino3_)*cff
1373
1374#ifdef IRON_LIMIT
1375!
1376! Iron uptake proportional to growth.
1377!
1378 fac=cff*bio(i,k,ino3_)*fnratio/ &
1379 & max(minval,bio(i,k,ifdis))
1380 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
1381 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
1382 & bio(i,k,ifdis)*fac
1383!
1384! Iron uptake to reach appropriate Fe:C ratio.
1385!
1386 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
1387 cff6=bio(i,k,iphyt)*cff5*fec2fen
1388 IF (cff6.ge.0.0_r8) THEN
1389 cff=cff6/max(minval,bio(i,k,ifdis))
1390 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
1391 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
1392 & bio(i,k,ifdis)*cff
1393 ELSE
1394 cff=-cff6/max(minval,bio(i,k,ifphy))
1395 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
1396 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1397 & bio(i,k,ifphy)*cff
1398 END IF
1399#endif
1400 END DO
1401 END DO
1402!
1403! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
1404! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
1405! pool as function of "sloppy feeding" and metabolic processes
1406! (ZooEEN and ZooEED fractions).
1407#ifdef IRON_LIMIT
1408! The lost of phytoplankton to the dissolve iron pool is scale by the
1409! remineralization rate (FeRR).
1410#endif
1411!
1412 cff1=dtdays*zoogr(ng)
1413 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
1414 DO k=1,n(ng)
1415 DO i=istr,iend
1416 cff=bio(i,k,izoop)* &
1417 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
1418 & bio(i,k,iphyt)
1419 bio1(i,k,iphyt)=bio(i,k,iphyt)
1420 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
1421 bio1(i,k,izoop)=bio(i,k,izoop)
1422 bio(i,k,izoop)=bio(i,k,izoop)+ &
1423 & bio(i,k,iphyt)*cff2*cff
1424 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1425 & bio(i,k,iphyt)*zooeen(ng)*cff
1426 bio(i,k,isdet)=bio(i,k,isdet)+ &
1427 & bio(i,k,iphyt)*zooeed(ng)*cff
1428#ifdef IRON_LIMIT
1429 bio1(i,k,ifphy)=bio(i,k,ifphy)
1430 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
1431 bio2(i,k,ifphy)=bio(i,k,ifphy)
1432 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1433 & bio(i,k,ifphy)*cff*ferr(ng)
1434#endif
1435 END DO
1436 END DO
1437!
1438! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
1439! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
1440!
1441 cff3=dtdays*phymrd(ng)
1442 cff2=dtdays*phymrn(ng)
1443 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1444 DO k=1,n(ng)
1445 DO i=istr,iend
1446 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
1447 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1448 & bio(i,k,iphyt)*cff2
1449 bio(i,k,isdet)=bio(i,k,isdet)+ &
1450 & bio(i,k,iphyt)*cff3
1451#ifdef IRON_LIMIT
1452 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
1453 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1454 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
1455#endif
1456 END DO
1457 END DO
1458!
1459 IF (iteradj.ne.iter) THEN
1460!
1461! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
1462! (ZooMRD rate).
1463!
1464 cff3=dtdays*zoomrd(ng)
1465 cff2=dtdays*zoomrn(ng)
1466 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1467 DO k=1,n(ng)
1468 DO i=istr,iend
1469 bio(i,k,izoop)=bio(i,k,izoop)*cff1
1470 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1471 & bio(i,k,izoop)*cff2
1472 bio(i,k,isdet)=bio(i,k,isdet)+ &
1473 & bio(i,k,izoop)*cff3
1474 END DO
1475 END DO
1476!
1477! Detritus breakdown to nutrients: remineralization (DetRR rate).
1478!
1479 cff2=dtdays*detrr(ng)
1480 cff1=1.0_r8/(1.0_r8+cff2)
1481 DO k=1,n(ng)
1482 DO i=istr,iend
1483 bio(i,k,isdet)=bio(i,k,isdet)*cff1
1484 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1485 & bio(i,k,isdet)*cff2
1486 END DO
1487 END DO
1488!
1489!-----------------------------------------------------------------------
1490! Vertical sinking terms: Phytoplankton and Detritus
1491!-----------------------------------------------------------------------
1492!
1493! Reconstruct vertical profile of selected biological constituents
1494! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1495! grid box. Then, compute semi-Lagrangian flux due to sinking.
1496!
1497 DO isink=1,nsink
1498 ibio=idsink(isink)
1499!
1500! Copy concentration of biological particulates into scratch array
1501! "qc" (q-central, restrict it to be positive) which is hereafter
1502! interpreted as a set of grid-box averaged values for biogeochemical
1503! constituent concentration.
1504!
1505 DO k=1,n(ng)
1506 DO i=istr,iend
1507 qc(i,k)=bio(i,k,ibio)
1508 END DO
1509 END DO
1510!
1511 DO k=n(ng)-1,1,-1
1512 DO i=istr,iend
1513 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1514 END DO
1515 END DO
1516 DO k=2,n(ng)-1
1517 DO i=istr,iend
1518 dltr=hz(i,j,k)*fc(i,k)
1519 dltl=hz(i,j,k)*fc(i,k-1)
1520 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1521 cffr=cff*fc(i,k)
1522 cffl=cff*fc(i,k-1)
1523!
1524! Apply PPM monotonicity constraint to prevent oscillations within the
1525! grid box.
1526!
1527 IF ((dltr*dltl).le.0.0_r8) THEN
1528 dltr=0.0_r8
1529 dltl=0.0_r8
1530 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1531 dltr=cffl
1532 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1533 dltl=cffr
1534 END IF
1535!
1536! Compute right and left side values (bR,bL) of parabolic segments
1537! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1538!
1539! NOTE: Although each parabolic segment is monotonic within its grid
1540! box, monotonicity of the whole profile is not guaranteed,
1541! because bL(k+1)-bR(k) may still have different sign than
1542! qc(i,k+1)-qc(i,k). This possibility is excluded,
1543! after bL and bR are reconciled using WENO procedure.
1544!
1545 cff=(dltr-dltl)*hz_inv3(i,k)
1546 dltr=dltr-cff*hz(i,j,k+1)
1547 dltl=dltl+cff*hz(i,j,k-1)
1548 br(i,k)=qc(i,k)+dltr
1549 bl(i,k)=qc(i,k)-dltl
1550 wr(i,k)=(2.0_r8*dltr-dltl)**2
1551 wl(i,k)=(dltr-2.0_r8*dltl)**2
1552 END DO
1553 END DO
1554 cff=1.0e-14_r8
1555 DO k=2,n(ng)-2
1556 DO i=istr,iend
1557 dltl=max(cff,wl(i,k ))
1558 dltr=max(cff,wr(i,k+1))
1559 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1560 bl(i,k+1)=br(i,k)
1561 END DO
1562 END DO
1563 DO i=istr,iend
1564 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1565#if defined LINEAR_CONTINUATION
1566 bl(i,n(ng))=br(i,n(ng)-1)
1567 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1568#elif defined NEUMANN
1569 bl(i,n(ng))=br(i,n(ng)-1)
1570 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1571#else
1572 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1573 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1574 br(i,n(ng)-1)=qc(i,n(ng))
1575#endif
1576#if defined LINEAR_CONTINUATION
1577 br(i,1)=bl(i,2)
1578 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1579#elif defined NEUMANN
1580 br(i,1)=bl(i,2)
1581 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1582#else
1583 bl(i,2)=qc(i,1) ! bottom grid boxes are
1584 br(i,1)=qc(i,1) ! re-assumed to be
1585 bl(i,1)=qc(i,1) ! piecewise constant.
1586#endif
1587 END DO
1588!
1589! Apply monotonicity constraint again, since the reconciled interfacial
1590! values may cause a non-monotonic behavior of the parabolic segments
1591! inside the grid box.
1592!
1593 DO k=1,n(ng)
1594 DO i=istr,iend
1595 dltr=br(i,k)-qc(i,k)
1596 dltl=qc(i,k)-bl(i,k)
1597 cffr=2.0_r8*dltr
1598 cffl=2.0_r8*dltl
1599 IF ((dltr*dltl).lt.0.0_r8) THEN
1600 dltr=0.0_r8
1601 dltl=0.0_r8
1602 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1603 dltr=cffl
1604 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1605 dltl=cffr
1606 END IF
1607 br(i,k)=qc(i,k)+dltr
1608 bl(i,k)=qc(i,k)-dltl
1609 END DO
1610 END DO
1611!
1612! After this moment reconstruction is considered complete. The next
1613! stage is to compute vertical advective fluxes, FC. It is expected
1614! that sinking may occurs relatively fast, the algorithm is designed
1615! to be free of CFL criterion, which is achieved by allowing
1616! integration bounds for semi-Lagrangian advective flux to use as
1617! many grid boxes in upstream direction as necessary.
1618!
1619! In the two code segments below, WL is the z-coordinate of the
1620! departure point for grid box interface z_w with the same indices;
1621! FC is the finite volume flux; ksource(:,k) is index of vertical
1622! grid box which contains the departure point (restricted by N(ng)).
1623! During the search: also add in content of whole grid boxes
1624! participating in FC.
1625!
1626 cff=dtdays*abs(wbio(isink))
1627 DO k=1,n(ng)
1628 DO i=istr,iend
1629 fc(i,k-1)=0.0_r8
1630 wl(i,k)=z_w(i,j,k-1)+cff
1631 wr(i,k)=hz(i,j,k)*qc(i,k)
1632 ksource(i,k)=k
1633 END DO
1634 END DO
1635 DO k=1,n(ng)
1636 DO ks=k,n(ng)-1
1637 DO i=istr,iend
1638 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1639 ksource(i,k)=ks+1
1640 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1641 END IF
1642 END DO
1643 END DO
1644 END DO
1645!
1646! Finalize computation of flux: add fractional part.
1647!
1648 DO k=1,n(ng)
1649 DO i=istr,iend
1650 ks=ksource(i,k)
1651 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1652 fc(i,k-1)=fc(i,k-1)+ &
1653 & hz(i,j,ks)*cu* &
1654 & (bl(i,ks)+ &
1655 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1656 & (1.5_r8-cu)* &
1657 & (br(i,ks)+bl(i,ks)- &
1658 & 2.0_r8*qc(i,ks))))
1659 END DO
1660 END DO
1661 DO k=1,n(ng)
1662 DO i=istr,iend
1663 bio(i,k,ibio)=qc(i,k)+ &
1664 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1665 END DO
1666 END DO
1667 END DO
1668 END IF
1669 END DO
1670!
1671! End of compute basic state arrays II.
1672!
1673! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
1674! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
1675! pool as function of "sloppy feeding" and metabolic processes
1676! (ZooEEN and ZooEED fractions).
1677#ifdef IRON_LIMIT
1678! The lost of phytoplankton to the dissolve iron pool is scale by the
1679! remineralization rate (FeRR).
1680#endif
1681!
1682 cff1=dtdays*zoogr(ng)
1683 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
1684 DO k=1,n(ng)
1685 DO i=istr,iend
1686 cff=bio1(i,k,izoop)* &
1687 & cff1*(1.0_r8-exp(-ivlev(ng)*bio1(i,k,iphyt)))/ &
1688 & bio1(i,k,iphyt)
1689 tl_cff=(tl_bio(i,k,izoop)* &
1690 & cff1*(1.0_r8-exp(-ivlev(ng)*bio1(i,k,iphyt)))+ &
1691 & bio1(i,k,izoop)*ivlev(ng)*tl_bio(i,k,iphyt)*cff1* &
1692 & exp(-ivlev(ng)*bio1(i,k,iphyt))- &
1693 & tl_bio(i,k,iphyt)*cff)/ &
1694 & bio1(i,k,iphyt)
1695!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)/(1.0_r8+cff)
1696!^
1697 tl_bio(i,k,iphyt)=(tl_bio(i,k,iphyt)- &
1698 & tl_cff*bio(i,k,iphyt))/ &
1699 & (1.0_r8+cff)
1700!^ Bio(i,k,iZoop)=Bio(i,k,iZoop)+ &
1701!^ & Bio(i,k,iPhyt)*cff2*cff
1702!^
1703 tl_bio(i,k,izoop)=tl_bio(i,k,izoop)+ &
1704 & cff2*(tl_bio(i,k,iphyt)*cff+ &
1705 & bio(i,k,iphyt)*tl_cff)
1706!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1707!^ & Bio(i,k,iPhyt)*ZooEEN(ng)*cff
1708!^
1709 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1710 & zooeen(ng)*(tl_bio(i,k,iphyt)*cff+ &
1711 & bio(i,k,iphyt)*tl_cff)
1712!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1713!^ & Bio(i,k,iPhyt)*ZooEED(ng)*cff
1714!^
1715 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1716 & zooeed(ng)*(tl_bio(i,k,iphyt)*cff+ &
1717 & bio(i,k,iphyt)*tl_cff)
1718
1719#ifdef IRON_LIMIT
1720!^ Bio(i,k,iFphy)=Bio(i,k,iFphy)/(1.0_r8+cff)
1721!^
1722 tl_bio(i,k,ifphy)=(tl_bio(i,k,ifphy)- &
1723 & tl_cff*bio2(i,k,ifphy))/ &
1724 & (1.0_r8+cff)
1725!^ Bio(i,k,iFdis)=Bio(i,k,iFdis)+ &
1726!^ & Bio(i,k,iFphy)*cff*FeRR(ng)
1727!^
1728 tl_bio(i,k,ifdis)=tl_bio(i,k,ifdis)+ &
1729 & (tl_bio(i,k,ifphy)*cff+ &
1730 & bio2(i,k,ifphy)*tl_cff)*ferr(ng)
1731#endif
1732 END DO
1733 END DO
1734!
1735! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
1736! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
1737!
1738 cff3=dtdays*phymrd(ng)
1739 cff2=dtdays*phymrn(ng)
1740 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1741 DO k=1,n(ng)
1742 DO i=istr,iend
1743!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)*cff1
1744!^
1745 tl_bio(i,k,iphyt)=tl_bio(i,k,iphyt)*cff1
1746!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1747!^ & Bio(i,k,iPhyt)*cff2
1748!^
1749 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1750 & tl_bio(i,k,iphyt)*cff2
1751!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1752!^ & Bio(i,k,iPhyt)*cff3
1753!^
1754 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1755 & tl_bio(i,k,iphyt)*cff3
1756
1757#ifdef IRON_LIMIT
1758!^ Bio(i,k,iFphy)=Bio(i,k,iFphy)*cff1
1759!^
1760 tl_bio(i,k,ifphy)=tl_bio(i,k,ifphy)*cff1
1761!^ Bio(i,k,iFdis)=Bio(i,k,iFdis)+ &
1762!^ & Bio(i,k,iFphy)*(cff2+cff3)*FeRR(ng)
1763!^
1764 tl_bio(i,k,ifdis)=tl_bio(i,k,ifdis)+ &
1765 & tl_bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
1766#endif
1767 END DO
1768 END DO
1769!
1770! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
1771! (ZooMRD rate).
1772!
1773 cff3=dtdays*zoomrd(ng)
1774 cff2=dtdays*zoomrn(ng)
1775 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1776 DO k=1,n(ng)
1777 DO i=istr,iend
1778!^ Bio(i,k,iZoop)=Bio(i,k,iZoop)*cff1
1779!^
1780 tl_bio(i,k,izoop)=tl_bio(i,k,izoop)*cff1
1781!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1782!^ & Bio(i,k,iZoop)*cff2
1783!^
1784 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1785 & tl_bio(i,k,izoop)*cff2
1786!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1787!^ & Bio(i,k,iZoop)*cff3
1788!^
1789 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1790 & tl_bio(i,k,izoop)*cff3
1791 END DO
1792 END DO
1793!
1794! Detritus breakdown to nutrients: remineralization (DetRR rate).
1795!
1796 cff2=dtdays*detrr(ng)
1797 cff1=1.0_r8/(1.0_r8+cff2)
1798 DO k=1,n(ng)
1799 DO i=istr,iend
1800!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)*cff1
1801!^
1802 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)*cff1
1803!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1804!^ & Bio(i,k,iSDet)*cff2
1805!^
1806 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1807 & tl_bio(i,k,isdet)*cff2
1808 END DO
1809 END DO
1810!
1811! Compute appropriate basic state arrays III.
1812!
1813 DO k=1,n(ng)
1814 DO i=istr,iend
1815!
1816! At input, all tracers (index nnew) from predictor step have
1817! transport units (m Tunits) since we do not have yet the new
1818! values for zeta and Hz. These are known after the 2D barotropic
1819! time-stepping.
1820!
1821! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
1822! tracer times depth. However the basic state (nstp and nnew
1823! indices) that is read from the forward file is in units of
1824! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
1825! use t instead of t*Hz_inv.
1826!
1827 DO itrc=1,nbt
1828 ibio=idbio(itrc)
1829!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1830!^
1831 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1832!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
1833!^
1834 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
1835 END DO
1836!
1837! Impose positive definite concentrations.
1838!
1839 cff2=0.0_r8
1840 DO itime=1,2
1841 cff1=0.0_r8
1842 itrcmax=idbio(1)
1843#ifdef IRON_LIMIT
1844 DO itrc=1,nbt-2
1845#else
1846 DO itrc=1,nbt
1847#endif
1848 ibio=idbio(itrc)
1849 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
1850 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
1851 itrcmax=ibio
1852 END IF
1853 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
1854 END DO
1855 IF (biotrc(itrcmax,itime).gt.cff1) THEN
1856 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
1857 END IF
1858#ifdef IRON_LIMIT
1859 DO itrc=nbt-1,nbt
1860 ibio=idbio(itrc)
1861 biotrc1(ibio,itime)=biotrc(ibio,itime)
1862 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
1863 END DO
1864#endif
1865 END DO
1866!
1867! Load biological tracers into local arrays.
1868!
1869 DO itrc=1,nbt
1870 ibio=idbio(itrc)
1871 bio_old(i,k,ibio)=biotrc(ibio,nstp)
1872 bio(i,k,ibio)=biotrc(ibio,nstp)
1873 END DO
1874
1875#if defined IRON_LIMIT && defined IRON_RELAX
1876!
1877! Relax dissolved iron at coast (h <= FeHim) to a constant value
1878! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
1879! at the shelf.
1880!
1881 IF (h(i,j).le.fehmin(ng)) THEN
1882 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1883 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
1884 END IF
1885#endif
1886 END DO
1887 END DO
1888!
1889! Calculate surface Photosynthetically Available Radiation (PAR). The
1890! net shortwave radiation is scaled back to Watts/m2 and multiplied by
1891! the fraction that is photosynthetically available, PARfrac.
1892!
1893 DO i=istr,iend
1894#ifdef CONST_PAR
1895!
1896! Specify constant surface irradiance a la Powell and Spitz.
1897!
1898 parsur(i)=158.075_r8
1899#else
1900 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
1901#endif
1902 END DO
1903!
1904!=======================================================================
1905! Start internal iterations to achieve convergence of the nonlinear
1906! backward-implicit solution.
1907!=======================================================================
1908!
1909 DO iteradj=1,iter
1910!
1911! Compute light attenuation as function of depth.
1912!
1913 DO i=istr,iend
1914 par=parsur(i)
1915 IF (parsur(i).gt.0.0_r8) THEN ! day time
1916 DO k=n(ng),1,-1
1917!
1918! Compute average light attenuation for each grid cell. Here, AttSW is
1919! the light attenuation due to seawater and AttPhy is the attenuation
1920! due to phytoplankton (self-shading coefficient).
1921!
1922 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
1923 & (z_w(i,j,k)-z_w(i,j,k-1))
1924 expatt=exp(-att)
1925 itop=par
1926 par=itop*(1.0_r8-expatt)/att ! average at cell center
1927 light(i,k)=par
1928!
1929! Light attenuation at the bottom of the grid cell. It is the starting
1930! PAR value for the next (deeper) vertical grid cell.
1931!
1932 par=itop*expatt
1933 END DO
1934 ELSE ! night time
1935 DO k=1,n(ng)
1936 light(i,k)=0.0_r8
1937 END DO
1938 END IF
1939 END DO
1940!
1941! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
1942! The Michaelis-Menten curve is used to describe the change in uptake
1943! rate as a function of nitrate concentration. Here, PhyIS is the
1944! initial slope of the P-I curve and K_NO3 is the half saturation of
1945! phytoplankton nitrate uptake.
1946#ifdef IRON_LIMIT
1947!
1948! Growth reduction factors due to iron limitation:
1949!
1950! FNratio current Fe:N ratio [umol-Fe/mmol-N]
1951! FCratio current Fe:C ratio [umol-Fe/mol-C]
1952! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
1953! FCratioE empirical Fe:C ratio
1954! Flimit Phytoplankton growth reduction factor due to Fe
1955! limitation based on Fe:C ratio
1956!
1957#endif
1958!
1959 cff1=dtdays*vm_no3(ng)*phyis(ng)
1960 cff2=vm_no3(ng)*vm_no3(ng)
1961 cff3=phyis(ng)*phyis(ng)
1962 DO k=1,n(ng)
1963 DO i=istr,iend
1964#ifdef IRON_LIMIT
1965 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
1966 fcratio=fnratio*fen2fec
1967 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
1968 flimit=fcratio*fcratio/ &
1969 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
1970
1971 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
1972 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
1973#endif
1974 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
1975 cff=bio(i,k,iphyt)* &
1976#ifdef IRON_LIMIT
1977 & cff1*cff4*light(i,k)*fnlim*nlimit
1978#else
1979 & cff1*cff4*light(i,k)/ &
1980 & (k_no3(ng)+bio(i,k,ino3_))
1981#endif
1982 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
1983 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
1984 & bio(i,k,ino3_)*cff
1985
1986#ifdef IRON_LIMIT
1987!
1988! Iron uptake proportional to growth.
1989!
1990 fac=cff*bio(i,k,ino3_)*fnratio/ &
1991 & max(minval,bio(i,k,ifdis))
1992 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
1993 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
1994 & bio(i,k,ifdis)*fac
1995!
1996! Iron uptake to reach appropriate Fe:C ratio.
1997!
1998 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
1999 cff6=bio(i,k,iphyt)*cff5*fec2fen
2000 IF (cff6.ge.0.0_r8) THEN
2001 cff=cff6/max(minval,bio(i,k,ifdis))
2002 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
2003 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
2004 & bio(i,k,ifdis)*cff
2005 ELSE
2006 cff=-cff6/max(minval,bio(i,k,ifphy))
2007 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
2008 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2009 & bio(i,k,ifphy)*cff
2010 END IF
2011#endif
2012 END DO
2013 END DO
2014!
2015! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
2016! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
2017! pool as function of "sloppy feeding" and metabolic processes
2018! (ZooEEN and ZooEED fractions).
2019#ifdef IRON_LIMIT
2020! The lost of phytoplankton to the dissolve iron pool is scale by the
2021! remineralization rate (FeRR).
2022#endif
2023!
2024 cff1=dtdays*zoogr(ng)
2025 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
2026 DO k=1,n(ng)
2027 DO i=istr,iend
2028 cff=bio(i,k,izoop)* &
2029 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
2030 & bio(i,k,iphyt)
2031 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
2032 bio(i,k,izoop)=bio(i,k,izoop)+ &
2033 & bio(i,k,iphyt)*cff2*cff
2034 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2035 & bio(i,k,iphyt)*zooeen(ng)*cff
2036 bio(i,k,isdet)=bio(i,k,isdet)+ &
2037 & bio(i,k,iphyt)*zooeed(ng)*cff
2038#ifdef IRON_LIMIT
2039 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
2040 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2041 & bio(i,k,ifphy)*cff*ferr(ng)
2042#endif
2043 END DO
2044 END DO
2045!
2046! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
2047! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
2048!
2049 cff3=dtdays*phymrd(ng)
2050 cff2=dtdays*phymrn(ng)
2051 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2052 DO k=1,n(ng)
2053 DO i=istr,iend
2054 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
2055 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2056 & bio(i,k,iphyt)*cff2
2057 bio(i,k,isdet)=bio(i,k,isdet)+ &
2058 & bio(i,k,iphyt)*cff3
2059#ifdef IRON_LIMIT
2060 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
2061 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2062 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
2063#endif
2064 END DO
2065 END DO
2066!
2067! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
2068! (ZooMRD rate).
2069!
2070 cff3=dtdays*zoomrd(ng)
2071 cff2=dtdays*zoomrn(ng)
2072 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2073 DO k=1,n(ng)
2074 DO i=istr,iend
2075 bio(i,k,izoop)=bio(i,k,izoop)*cff1
2076 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2077 & bio(i,k,izoop)*cff2
2078 bio(i,k,isdet)=bio(i,k,isdet)+ &
2079 & bio(i,k,izoop)*cff3
2080 END DO
2081 END DO
2082!
2083! Detritus breakdown to nutrients: remineralization (DetRR rate).
2084!
2085 cff2=dtdays*detrr(ng)
2086 cff1=1.0_r8/(1.0_r8+cff2)
2087 DO k=1,n(ng)
2088 DO i=istr,iend
2089 bio(i,k,isdet)=bio(i,k,isdet)*cff1
2090 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2091 & bio(i,k,isdet)*cff2
2092 END DO
2093 END DO
2094!
2095 IF (iteradj.ne.iter) THEN
2096!
2097!-----------------------------------------------------------------------
2098! Vertical sinking terms: Phytoplankton and Detritus
2099!-----------------------------------------------------------------------
2100!
2101! Reconstruct vertical profile of selected biological constituents
2102! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
2103! grid box. Then, compute semi-Lagrangian flux due to sinking.
2104!
2105 DO isink=1,nsink
2106 ibio=idsink(isink)
2107!
2108! Copy concentration of biological particulates into scratch array
2109! "qc" (q-central, restrict it to be positive) which is hereafter
2110! interpreted as a set of grid-box averaged values for biogeochemical
2111! constituent concentration.
2112!
2113 DO k=1,n(ng)
2114 DO i=istr,iend
2115 qc(i,k)=bio(i,k,ibio)
2116 END DO
2117 END DO
2118!
2119 DO k=n(ng)-1,1,-1
2120 DO i=istr,iend
2121 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
2122 END DO
2123 END DO
2124 DO k=2,n(ng)-1
2125 DO i=istr,iend
2126 dltr=hz(i,j,k)*fc(i,k)
2127 dltl=hz(i,j,k)*fc(i,k-1)
2128 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2129 cffr=cff*fc(i,k)
2130 cffl=cff*fc(i,k-1)
2131!
2132! Apply PPM monotonicity constraint to prevent oscillations within the
2133! grid box.
2134!
2135 IF ((dltr*dltl).le.0.0_r8) THEN
2136 dltr=0.0_r8
2137 dltl=0.0_r8
2138 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2139 dltr=cffl
2140 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2141 dltl=cffr
2142 END IF
2143!
2144! Compute right and left side values (bR,bL) of parabolic segments
2145! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
2146!
2147! NOTE: Although each parabolic segment is monotonic within its grid
2148! box, monotonicity of the whole profile is not guaranteed,
2149! because bL(k+1)-bR(k) may still have different sign than
2150! qc(i,k+1)-qc(i,k). This possibility is excluded,
2151! after bL and bR are reconciled using WENO procedure.
2152!
2153 cff=(dltr-dltl)*hz_inv3(i,k)
2154 dltr=dltr-cff*hz(i,j,k+1)
2155 dltl=dltl+cff*hz(i,j,k-1)
2156 br(i,k)=qc(i,k)+dltr
2157 bl(i,k)=qc(i,k)-dltl
2158 wr(i,k)=(2.0_r8*dltr-dltl)**2
2159 wl(i,k)=(dltr-2.0_r8*dltl)**2
2160 END DO
2161 END DO
2162 cff=1.0e-14_r8
2163 DO k=2,n(ng)-2
2164 DO i=istr,iend
2165 dltl=max(cff,wl(i,k ))
2166 dltr=max(cff,wr(i,k+1))
2167 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
2168 bl(i,k+1)=br(i,k)
2169 END DO
2170 END DO
2171 DO i=istr,iend
2172 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
2173#if defined LINEAR_CONTINUATION
2174 bl(i,n(ng))=br(i,n(ng)-1)
2175 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
2176#elif defined NEUMANN
2177 bl(i,n(ng))=br(i,n(ng)-1)
2178 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
2179#else
2180 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
2181 bl(i,n(ng))=qc(i,n(ng)) ! conditions
2182 br(i,n(ng)-1)=qc(i,n(ng))
2183#endif
2184#if defined LINEAR_CONTINUATION
2185 br(i,1)=bl(i,2)
2186 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
2187#elif defined NEUMANN
2188 br(i,1)=bl(i,2)
2189 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
2190#else
2191 bl(i,2)=qc(i,1) ! bottom grid boxes are
2192 br(i,1)=qc(i,1) ! re-assumed to be
2193 bl(i,1)=qc(i,1) ! piecewise constant.
2194#endif
2195 END DO
2196!
2197! Apply monotonicity constraint again, since the reconciled interfacial
2198! values may cause a non-monotonic behavior of the parabolic segments
2199! inside the grid box.
2200!
2201 DO k=1,n(ng)
2202 DO i=istr,iend
2203 dltr=br(i,k)-qc(i,k)
2204 dltl=qc(i,k)-bl(i,k)
2205 cffr=2.0_r8*dltr
2206 cffl=2.0_r8*dltl
2207 IF ((dltr*dltl).lt.0.0_r8) THEN
2208 dltr=0.0_r8
2209 dltl=0.0_r8
2210 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2211 dltr=cffl
2212 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2213 dltl=cffr
2214 END IF
2215 br(i,k)=qc(i,k)+dltr
2216 bl(i,k)=qc(i,k)-dltl
2217 END DO
2218 END DO
2219!
2220! After this moment reconstruction is considered complete. The next
2221! stage is to compute vertical advective fluxes, FC. It is expected
2222! that sinking may occurs relatively fast, the algorithm is designed
2223! to be free of CFL criterion, which is achieved by allowing
2224! integration bounds for semi-Lagrangian advective flux to use as
2225! many grid boxes in upstream direction as necessary.
2226!
2227! In the two code segments below, WL is the z-coordinate of the
2228! departure point for grid box interface z_w with the same indices;
2229! FC is the finite volume flux; ksource(:,k) is index of vertical
2230! grid box which contains the departure point (restricted by N(ng)).
2231! During the search: also add in content of whole grid boxes
2232! participating in FC.
2233!
2234 cff=dtdays*abs(wbio(isink))
2235 DO k=1,n(ng)
2236 DO i=istr,iend
2237 fc(i,k-1)=0.0_r8
2238 wl(i,k)=z_w(i,j,k-1)+cff
2239 wr(i,k)=hz(i,j,k)*qc(i,k)
2240 ksource(i,k)=k
2241 END DO
2242 END DO
2243 DO k=1,n(ng)
2244 DO ks=k,n(ng)-1
2245 DO i=istr,iend
2246 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
2247 ksource(i,k)=ks+1
2248 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
2249 END IF
2250 END DO
2251 END DO
2252 END DO
2253!
2254! Finalize computation of flux: add fractional part.
2255!
2256 DO k=1,n(ng)
2257 DO i=istr,iend
2258 ks=ksource(i,k)
2259 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
2260 fc(i,k-1)=fc(i,k-1)+ &
2261 & hz(i,j,ks)*cu* &
2262 & (bl(i,ks)+ &
2263 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2264 & (1.5_r8-cu)* &
2265 & (br(i,ks)+bl(i,ks)- &
2266 & 2.0_r8*qc(i,ks))))
2267 END DO
2268 END DO
2269 DO k=1,n(ng)
2270 DO i=istr,iend
2271 bio(i,k,ibio)=qc(i,k)+ &
2272 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
2273 END DO
2274 END DO
2275 END DO
2276 END IF
2277 END DO
2278!
2279! End of compute basic state arrays III.
2280!
2281!-----------------------------------------------------------------------
2282! Tangent linear vertical sinking terms.
2283!-----------------------------------------------------------------------
2284!
2285! Reconstruct vertical profile of selected biological constituents
2286! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
2287! grid box. Then, compute semi-Lagrangian flux due to sinking.
2288!
2289 sink_loop: DO isink=1,nsink
2290 ibio=idsink(isink)
2291!
2292! Copy concentration of biological particulates into scratch array
2293! "qc" (q-central, restrict it to be positive) which is hereafter
2294! interpreted as a set of grid-box averaged values for biogeochemical
2295! constituent concentration.
2296!
2297 DO k=1,n(ng)
2298 DO i=istr,iend
2299 qc(i,k)=bio(i,k,ibio)
2300 tl_qc(i,k)=tl_bio(i,k,ibio)
2301 END DO
2302 END DO
2303!
2304 DO k=n(ng)-1,1,-1
2305 DO i=istr,iend
2306 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
2307 tl_fc(i,k)=(tl_qc(i,k+1)-tl_qc(i,k))*hz_inv2(i,k)+ &
2308 & (qc(i,k+1)-qc(i,k))*tl_hz_inv2(i,k)
2309 END DO
2310 END DO
2311 DO k=2,n(ng)-1
2312 DO i=istr,iend
2313 dltr=hz(i,j,k)*fc(i,k)
2314 tl_dltr=tl_hz(i,j,k)*fc(i,k)+hz(i,j,k)*tl_fc(i,k)
2315 dltl=hz(i,j,k)*fc(i,k-1)
2316 tl_dltl=tl_hz(i,j,k)*fc(i,k-1)+hz(i,j,k)*tl_fc(i,k-1)
2317 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2318 tl_cff=tl_hz(i,j,k-1)+2.0_r8*tl_hz(i,j,k)+tl_hz(i,j,k+1)
2319 cffr=cff*fc(i,k)
2320 tl_cffr=tl_cff*fc(i,k)+cff*tl_fc(i,k)
2321 cffl=cff*fc(i,k-1)
2322 tl_cffl=tl_cff*fc(i,k-1)+cff*tl_fc(i,k-1)
2323!
2324! Apply PPM monotonicity constraint to prevent oscillations within the
2325! grid box.
2326!
2327 IF ((dltr*dltl).le.0.0_r8) THEN
2328 dltr=0.0_r8
2329 tl_dltr=0.0_r8
2330 dltl=0.0_r8
2331 tl_dltl=0.0_r8
2332 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2333 dltr=cffl
2334 tl_dltr=tl_cffl
2335 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2336 dltl=cffr
2337 tl_dltl=tl_cffr
2338 END IF
2339!
2340! Compute right and left side values (bR,bL) of parabolic segments
2341! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
2342!
2343! NOTE: Although each parabolic segment is monotonic within its grid
2344! box, monotonicity of the whole profile is not guaranteed,
2345! because bL(k+1)-bR(k) may still have different sign than
2346! qc(i,k+1)-qc(i,k). This possibility is excluded,
2347! after bL and bR are reconciled using WENO procedure.
2348!
2349 cff=(dltr-dltl)*hz_inv3(i,k)
2350 tl_cff=(tl_dltr-tl_dltl)*hz_inv3(i,k)+ &
2351 & (dltr-dltl)*tl_hz_inv3(i,k)
2352 dltr=dltr-cff*hz(i,j,k+1)
2353 tl_dltr=tl_dltr-tl_cff*hz(i,j,k+1)-cff*tl_hz(i,j,k+1)
2354 dltl=dltl+cff*hz(i,j,k-1)
2355 tl_dltl=tl_dltl+tl_cff*hz(i,j,k-1)+cff*tl_hz(i,j,k-1)
2356 br(i,k)=qc(i,k)+dltr
2357 tl_br(i,k)=tl_qc(i,k)+tl_dltr
2358 bl(i,k)=qc(i,k)-dltl
2359 tl_bl(i,k)=tl_qc(i,k)-tl_dltl
2360 wr(i,k)=(2.0_r8*dltr-dltl)**2
2361 tl_wr(i,k)=2.0_r8*(2.0_r8*dltr-dltl)* &
2362 & (2.0_r8*tl_dltr-tl_dltl)
2363 wl(i,k)=(dltr-2.0_r8*dltl)**2
2364 tl_wl(i,k)=2.0_r8*(dltr-2.0_r8*dltl)* &
2365 & (tl_dltr-2.0_r8*tl_dltl)
2366 END DO
2367 END DO
2368 cff=1.0e-14_r8
2369 DO k=2,n(ng)-2
2370 DO i=istr,iend
2371 dltl=max(cff,wl(i,k ))
2372 tl_dltl=(0.5_r8-sign(0.5_r8,cff-wl(i,k )))* &
2373 & tl_wl(i,k )
2374 dltr=max(cff,wr(i,k+1))
2375 tl_dltr=(0.5_r8-sign(0.5_r8,cff-wr(i,k+1)))* &
2376 & tl_wr(i,k+1)
2377 br1(i,k)=br(i,k)
2378 bl1(i,k+1)=bl(i,k+1)
2379 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
2380 tl_br(i,k)=(tl_dltr*br1(i,k )+dltr*tl_br(i,k )+ &
2381 & tl_dltl*bl1(i,k+1)+dltl*tl_bl(i,k+1))/ &
2382 & (dltr+dltl)- &
2383 & (tl_dltr+tl_dltl)*br(i,k)/(dltr+dltl)
2384 bl(i,k+1)=br(i,k)
2385 tl_bl(i,k+1)=tl_br(i,k)
2386 END DO
2387 END DO
2388 DO i=istr,iend
2389 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
2390 tl_fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
2391#if defined LINEAR_CONTINUATION
2392 bl(i,n(ng))=br(i,n(ng)-1)
2393 tl_bl(i,n(ng))=tl_br(i,n(ng)-1)
2394 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
2395 tl_br(i,n(ng))=2.0_r8*tl_qc(i,n(ng))-tl_bl(i,n(ng))
2396#elif defined NEUMANN
2397 bl(i,n(ng))=br(i,n(ng)-1)
2398 tl_bl(i,n(ng))=tl_br(i,n(ng)-1)
2399 br(i,n(ng))=1.5_r8*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
2400 tl_br(i,n(ng))=1.5_r8*tl_qc(i,n(ng))-0.5_r8*tl_bl(i,n(ng))
2401#else
2402 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
2403 bl(i,n(ng))=qc(i,n(ng)) ! conditions
2404 br(i,n(ng)-1)=qc(i,n(ng))
2405 tl_br(i,n(ng))=tl_qc(i,n(ng)) ! default strictly monotonic
2406 tl_bl(i,n(ng))=tl_qc(i,n(ng)) ! conditions
2407 tl_br(i,n(ng)-1)=tl_qc(i,n(ng))
2408#endif
2409#if defined LINEAR_CONTINUATION
2410 br(i,1)=bl(i,2)
2411 tl_br(i,1)=tl_bl(i,2)
2412 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
2413 tl_bl(i,1)=2.0_r8*tl_qc(i,1)-tl_br(i,1)
2414#elif defined NEUMANN
2415 br(i,1)=bl(i,2)
2416 tl_br(i,1)=tl_bl(i,2)
2417 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
2418 tl_bl(i,1)=1.5_r8*tl_qc(i,1)-0.5_r8*tl_br(i,1)
2419#else
2420 bl(i,2)=qc(i,1) ! bottom grid boxes are
2421 br(i,1)=qc(i,1) ! re-assumed to be
2422 bl(i,1)=qc(i,1) ! piecewise constant.
2423 tl_bl(i,2)=tl_qc(i,1) ! bottom grid boxes are
2424 tl_br(i,1)=tl_qc(i,1) ! re-assumed to be
2425 tl_bl(i,1)=tl_qc(i,1) ! piecewise constant.
2426#endif
2427 END DO
2428!
2429! Apply monotonicity constraint again, since the reconciled interfacial
2430! values may cause a non-monotonic behavior of the parabolic segments
2431! inside the grid box.
2432!
2433 DO k=1,n(ng)
2434 DO i=istr,iend
2435 dltr=br(i,k)-qc(i,k)
2436 tl_dltr=tl_br(i,k)-tl_qc(i,k)
2437 dltl=qc(i,k)-bl(i,k)
2438 tl_dltl=tl_qc(i,k)-tl_bl(i,k)
2439 cffr=2.0_r8*dltr
2440 tl_cffr=2.0_r8*tl_dltr
2441 cffl=2.0_r8*dltl
2442 tl_cffl=2.0_r8*tl_dltl
2443 IF ((dltr*dltl).lt.0.0_r8) THEN
2444 dltr=0.0_r8
2445 tl_dltr=0.0_r8
2446 dltl=0.0_r8
2447 tl_dltl=0.0_r8
2448 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2449 dltr=cffl
2450 tl_dltr=tl_cffl
2451 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2452 dltl=cffr
2453 tl_dltl=tl_cffr
2454 END IF
2455 br(i,k)=qc(i,k)+dltr
2456 tl_br(i,k)=tl_qc(i,k)+tl_dltr
2457 bl(i,k)=qc(i,k)-dltl
2458 tl_bl(i,k)=tl_qc(i,k)-tl_dltl
2459 END DO
2460 END DO
2461!
2462! After this moment reconstruction is considered complete. The next
2463! stage is to compute vertical advective fluxes, FC. It is expected
2464! that sinking may occurs relatively fast, the algorithm is designed
2465! to be free of CFL criterion, which is achieved by allowing
2466! integration bounds for semi-Lagrangian advective flux to use as
2467! many grid boxes in upstream direction as necessary.
2468!
2469! In the two code segments below, WL is the z-coordinate of the
2470! departure point for grid box interface z_w with the same indices;
2471! FC is the finite volume flux; ksource(:,k) is index of vertical
2472! grid box which contains the departure point (restricted by N(ng)).
2473! During the search: also add in content of whole grid boxes
2474! participating in FC.
2475!
2476 cff=dtdays*abs(wbio(isink))
2477 tl_cff=dtdays*sign(1.0_r8,wbio(isink))*tl_wbio(isink)
2478 DO k=1,n(ng)
2479 DO i=istr,iend
2480 fc(i,k-1)=0.0_r8
2481 tl_fc(i,k-1)=0.0_r8
2482 wl(i,k)=z_w(i,j,k-1)+cff
2483 tl_wl(i,k)=tl_z_w(i,j,k-1)+tl_cff
2484 wr(i,k)=hz(i,j,k)*qc(i,k)
2485 tl_wr(i,k)=tl_hz(i,j,k)*qc(i,k)+hz(i,j,k)*tl_qc(i,k)
2486 ksource(i,k)=k
2487 END DO
2488 END DO
2489 DO k=1,n(ng)
2490 DO ks=k,n(ng)-1
2491 DO i=istr,iend
2492 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
2493 ksource(i,k)=ks+1
2494 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
2495 tl_fc(i,k-1)=tl_fc(i,k-1)+tl_wr(i,ks)
2496 END IF
2497 END DO
2498 END DO
2499 END DO
2500!
2501! Finalize computation of flux: add fractional part.
2502!
2503 DO k=1,n(ng)
2504 DO i=istr,iend
2505 ks=ksource(i,k)
2506 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
2507 tl_cu=(0.5_r8+sign(0.5_r8, &
2508 & (1.0_r8-(wl(i,k)-z_w(i,j,ks-1))* &
2509 & hz_inv(i,ks))))* &
2510 & ((tl_wl(i,k)-tl_z_w(i,j,ks-1))*hz_inv(i,ks)+ &
2511 & (wl(i,k)-z_w(i,j,ks-1))*tl_hz_inv(i,ks))
2512 fc(i,k-1)=fc(i,k-1)+ &
2513 & hz(i,j,ks)*cu* &
2514 & (bl(i,ks)+ &
2515 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2516 & (1.5_r8-cu)* &
2517 & (br(i,ks)+bl(i,ks)- &
2518 & 2.0_r8*qc(i,ks))))
2519 tl_fc(i,k-1)=tl_fc(i,k-1)+ &
2520 & (tl_hz(i,j,ks)*cu+hz(i,j,ks)*tl_cu)* &
2521 & (bl(i,ks)+ &
2522 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2523 & (1.5_r8-cu)* &
2524 & (br(i,ks)+bl(i,ks)- &
2525 & 2.0_r8*qc(i,ks))))+ &
2526 & hz(i,j,ks)*cu* &
2527 & (tl_bl(i,ks)+ &
2528 & tl_cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2529 & (1.5_r8-cu)* &
2530 & (br(i,ks)+bl(i,ks)- &
2531 & 2.0_r8*qc(i,ks)))+ &
2532 & cu*(0.5_r8*(tl_br(i,ks)-tl_bl(i,ks))+ &
2533 & tl_cu* &
2534 & (br(i,ks)+bl(i,ks)-2.0_r8*qc(i,ks))- &
2535 & (1.5_r8-cu)* &
2536 & (tl_br(i,ks)+tl_bl(i,ks)- &
2537 & 2.0_r8*tl_qc(i,ks))))
2538 END DO
2539 END DO
2540 DO k=1,n(ng)
2541 DO i=istr,iend
2542 bio(i,k,ibio)=qc(i,k)+(fc(i,k)-fc(i,k-1))*hz_inv(i,k)
2543 tl_bio(i,k,ibio)=tl_qc(i,k)+ &
2544 & (tl_fc(i,k)-tl_fc(i,k-1))*hz_inv(i,k)+ &
2545 & (fc(i,k)-fc(i,k-1))*tl_hz_inv(i,k)
2546 END DO
2547 END DO
2548
2549 END DO sink_loop
2550 END DO iter_loop
2551!
2552!-----------------------------------------------------------------------
2553! Update global tracer variables: Add increment due to BGC processes
2554! to tracer array in time index "nnew". Index "nnew" is solution after
2555! advection and mixing and has transport units (m Tunits) hence the
2556! increment is multiplied by Hz. Notice that we need to subtract
2557! original values "Bio_old" at the top of the routine to just account
2558! for the concentractions affected by BGC processes. This also takes
2559! into account any constraints (non-negative concentrations, carbon
2560! concentration range) specified before entering BGC kernel. If "Bio"
2561! were unchanged by BGC processes, the increment would be exactly
2562! zero. Notice that final tracer values, t(:,:,:,nnew,:) are not
2563! bounded >=0 so that we can preserve total inventory of nutrients
2564! when advection causes tracer concentration to go negative.
2565!-----------------------------------------------------------------------
2566!
2567 DO itrc=1,nbt
2568 ibio=idbio(itrc)
2569 DO k=1,n(ng)
2570 DO i=istr,iend
2571 cff=bio(i,k,ibio)-bio_old(i,k,ibio)
2572 tl_cff=tl_bio(i,k,ibio)-tl_bio_old(i,k,ibio)
2573!^ t(i,j,k,nnew,ibio)=t(i,j,k,nnew,ibio)+cff*Hz(i,j,k)
2574!^
2575 tl_t(i,j,k,nnew,ibio)=tl_t(i,j,k,nnew,ibio)+ &
2576 & tl_cff*hz(i,j,k)+cff*tl_hz(i,j,k)
2577 END DO
2578 END DO
2579 END DO
2580
2581 END DO j_loop
2582!
2583 RETURN
mod_biology::parfrac
real(r8), dimension(:), allocatable parfrac
Definition fennel_mod.h:139
mod_biology::phymrd
real(r8), dimension(:), allocatable phymrd
Definition npzd_iron_mod.h:102
mod_biology::zooeed
real(r8), dimension(:), allocatable zooeed
Definition npzd_iron_mod.h:119
mod_biology::ifphy
integer ifphy
Definition npzd_iron_mod.h:68
mod_biology::ferr
real(r8), dimension(:), allocatable ferr
Definition npzd_iron_mod.h:86
mod_biology::phyis
real(r8), dimension(:), allocatable phyis
Definition fennel_mod.h:143
mod_biology::attsw
real(r8), dimension(:), allocatable attsw
Definition fennel_mod.h:125
mod_biology::a_fe
real(r8), dimension(:), allocatable a_fe
Definition npzd_iron_mod.h:84
mod_biology::ifdis
integer ifdis
Definition npzd_iron_mod.h:69
mod_biology::tl_parfrac
real(r8), dimension(:), allocatable tl_parfrac
Definition npzd_iron_mod.h:96
mod_biology::tl_wphy
real(r8), dimension(:), allocatable tl_wphy
Definition npzd_iron_mod.h:114
mod_biology::fenudgtime
real(r8), dimension(:), allocatable fenudgtime
Definition npzd_iron_mod.h:90
mod_biology::ivlev
real(r8), dimension(:), allocatable ivlev
Definition npzd_iron_mod.h:81
mod_biology::attphy
real(r8), dimension(:), allocatable attphy
Definition npzd_iron_mod.h:77
mod_biology::b_fe
real(r8), dimension(:), allocatable b_fe
Definition npzd_iron_mod.h:85
mod_biology::wphy
real(r8), dimension(:), allocatable wphy
Definition fennel_mod.h:154
mod_biology::fehmin
real(r8), dimension(:), allocatable fehmin
Definition npzd_iron_mod.h:88
mod_biology::k_fec
real(r8), dimension(:), allocatable k_fec
Definition npzd_iron_mod.h:92
mod_biology::t_fe
real(r8), dimension(:), allocatable t_fe
Definition npzd_iron_mod.h:93
mod_biology::zoomrn
real(r8), dimension(:), allocatable zoomrn
Definition npzd_iron_mod.h:123
mod_biology::femax
real(r8), dimension(:), allocatable femax
Definition npzd_iron_mod.h:89
mod_biology::phymrn
real(r8), dimension(:), allocatable phymrn
Definition npzd_iron_mod.h:103
mod_biology::zoomrd
real(r8), dimension(:), allocatable zoomrd
Definition npzd_iron_mod.h:122
mod_biology::zooeen
real(r8), dimension(:), allocatable zooeen
Definition npzd_iron_mod.h:120
mod_scalars::cp
real(dp) cp
Definition mod_scalars.F:456
mod_scalars::rho0
real(dp) rho0
Definition mod_scalars.F:787

References mod_biology::a_fe, mod_biology::attphy, mod_biology::attsw, mod_biology::b_fe, mod_biology::bioiter, mod_scalars::cp, mod_biology::detrr, mod_scalars::dt, mod_biology::fehmin, mod_biology::femax, mod_biology::fenudgtime, mod_biology::ferr, mod_biology::idbio, mod_biology::ifdis, mod_biology::ifphy, mod_biology::ino3_, mod_biology::iphyt, mod_biology::isdet, mod_biology::ivlev, mod_biology::izoop, mod_biology::k_fec, mod_biology::k_no3, mod_param::n, mod_param::nbt, mod_biology::parfrac, mod_biology::phyis, mod_biology::phymrd, mod_biology::phymrn, mod_scalars::rho0, mod_scalars::sec2day, mod_biology::t_fe, mod_biology::tl_parfrac, mod_biology::tl_wdet, mod_biology::tl_wphy, mod_biology::vm_no3, mod_biology::wdet, mod_biology::wphy, mod_biology::zooeed, mod_biology::zooeen, mod_biology::zoogr, mod_biology::zoomrd, and mod_biology::zoomrn.

◆ tl_npzd_powell_tile()

subroutine tl_biology_mod::tl_npzd_powell_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) ubt,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) tl_hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) tl_z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk), intent(in) z_w,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk), intent(in) tl_z_w,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) srflx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_srflx,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(in) t,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) tl_t )
private

Definition at line 94 of file tl_npzd_Powell.h.

106!-----------------------------------------------------------------------
107!
108 USE mod_param
109 USE mod_biology
110 USE mod_ncparam
111 USE mod_scalars
112!
113! Imported variable declarations.
114!
115 integer, intent(in) :: ng, tile
116 integer, intent(in) :: LBi, UBi, LBj, UBj, UBk, UBt
117 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
118 integer, intent(in) :: nstp, nnew
119
120#ifdef ASSUMED_SHAPE
121# ifdef MASKING
122 real(r8), intent(in) :: rmask(LBi:,LBj:)
123# endif
124 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
125 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
126 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
127 real(r8), intent(in) :: srflx(LBi:,LBj:)
128 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
129
130 real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:)
131 real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:)
132 real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:)
133 real(r8), intent(in) :: tl_srflx(LBi:,LBj:)
134 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
135#else
136# ifdef MASKING
137 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
138# endif
139 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,UBk)
140 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,UBk)
141 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:UBk)
142 real(r8), intent(in) :: srflx(LBi:UBi,LBj:UBj)
143 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,UBk,3,UBt)
144
145 real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,UBk)
146 real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,UBk)
147 real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:UBk)
148 real(r8), intent(in) :: tl_srflx(LBi:UBi,LBj:UBj)
149 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,UBk,3,UBt)
150#endif
151!
152! Local variable declarations.
153!
154 integer, parameter :: Nsink = 2
155
156 integer :: Iter, i, ibio, isink, itime, itrc, iTrcMax, j, k, ks
157 integer :: Iteradj
158
159 integer, dimension(Nsink) :: idsink
160
161 real(r8), parameter :: MinVal = 1.0e-6_r8
162
163 real(r8) :: Att, ExpAtt, Itop, PAR
164 real(r8) :: tl_Att, tl_ExpAtt, tl_Itop, tl_PAR
165 real(r8) :: cff, cff1, cff2, cff3, cff4, dtdays
166 real(r8) :: tl_cff, tl_cff1, tl_cff4
167 real(r8) :: cffL, cffR, cu, dltL, dltR
168 real(r8) :: tl_cffL, tl_cffR, tl_cu, tl_dltL, tl_dltR
169
170 real(r8), dimension(Nsink) :: Wbio
171 real(r8), dimension(Nsink) :: tl_Wbio
172
173 integer, dimension(IminS:ImaxS,N(ng)) :: ksource
174
175 real(r8), dimension(IminS:ImaxS) :: PARsur
176 real(r8), dimension(IminS:ImaxS) :: tl_PARsur
177
178 real(r8), dimension(NT(ng),2) :: BioTrc
179 real(r8), dimension(NT(ng),2) :: BioTrc1
180 real(r8), dimension(NT(ng),2) :: tl_BioTrc
181 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio
182 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio1
183 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio_old
184
185 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: tl_Bio
186 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: tl_Bio_old
187
188 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
189 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FC
190
191 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv
192 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv2
193 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv3
194 real(r8), dimension(IminS:ImaxS,N(ng)) :: Light
195 real(r8), dimension(IminS:ImaxS,N(ng)) :: WL
196 real(r8), dimension(IminS:ImaxS,N(ng)) :: WR
197 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL
198 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL1
199 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR
200 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR1
201 real(r8), dimension(IminS:ImaxS,N(ng)) :: qc
202
203 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv
204 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv2
205 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Hz_inv3
206 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_Light
207 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_WL
208 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_WR
209 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_bL
210 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_bR
211 real(r8), dimension(IminS:ImaxS,N(ng)) :: tl_qc
212
213#include "set_bounds.h"
214!
215!-----------------------------------------------------------------------
216! Add biological Source/Sink terms.
217!-----------------------------------------------------------------------
218!
219! Avoid computing source/sink terms if no biological iterations.
220!
221 IF (bioiter(ng).le.0) RETURN
222!
223! Set time-stepping size (days) according to the number of iterations.
224!
225 dtdays=dt(ng)*sec2day/real(bioiter(ng),r8)
226!
227! Set vertical sinking indentification vector.
228!
229 idsink(1)=iphyt ! Phytoplankton
230 idsink(2)=isdet ! Small detritus
231!
232! Set vertical sinking velocity vector in the same order as the
233! identification vector, IDSINK.
234!
235 wbio(1)=wphy(ng) ! Phytoplankton
236 tl_wbio(1)=tl_wphy(ng) ! Phytoplankton
237 wbio(2)=wdet(ng) ! Small detritus
238 tl_wbio(2)=tl_wdet(ng) ! Small detritus
239!
240 j_loop : DO j=jstr,jend
241!
242! Compute inverse thickness to avoid repeated divisions.
243!
244 DO k=1,n(ng)
245 DO i=istr,iend
246 hz_inv(i,k)=1.0_r8/hz(i,j,k)
247 tl_hz_inv(i,k)=-hz_inv(i,k)*hz_inv(i,k)*tl_hz(i,j,k)
248 END DO
249 END DO
250 DO k=1,n(ng)-1
251 DO i=istr,iend
252 hz_inv2(i,k)=1.0_r8/(hz(i,j,k)+hz(i,j,k+1))
253 tl_hz_inv2(i,k)=-hz_inv2(i,k)*hz_inv2(i,k)* &
254 & (tl_hz(i,j,k)+tl_hz(i,j,k+1))
255 END DO
256 END DO
257 DO k=2,n(ng)-1
258 DO i=istr,iend
259 hz_inv3(i,k)=1.0_r8/(hz(i,j,k-1)+hz(i,j,k)+hz(i,j,k+1))
260 tl_hz_inv3(i,k)=-hz_inv3(i,k)*hz_inv3(i,k)* &
261 & (tl_hz(i,j,k-1)+tl_hz(i,j,k)+ &
262 & tl_hz(i,j,k+1))
263 END DO
264 END DO
265!
266! Clear tl_Bio and Bio arrays.
267!
268 DO itrc=1,nbt
269 ibio=idbio(itrc)
270 DO k=1,n(ng)
271 DO i=istr,iend
272 bio(i,k,ibio)=0.0_r8
273 bio1(i,k,ibio)=0.0_r8
274 tl_bio(i,k,ibio)=0.0_r8
275 END DO
276 END DO
277 END DO
278!
279! Restrict biological tracer to be positive definite. If a negative
280! concentration is detected, nitrogen is drawn from the most abundant
281! pool to supplement the negative pools to a lower limit of MinVal
282! which is set to 1E-6 above.
283!
284 DO k=1,n(ng)
285 DO i=istr,iend
286!
287! At input, all tracers (index nnew) from predictor step have
288! transport units (m Tunits) since we do not have yet the new
289! values for zeta and Hz. These are known after the 2D barotropic
290! time-stepping.
291!
292! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
293! tracer times depth. However the basic state (nstp and nnew
294! indices) that is read from the forward file is in units of
295! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
296! use t instead of t*Hz_inv.
297!
298 DO itrc=1,nbt
299 ibio=idbio(itrc)
300!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
301!^
302 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
303 tl_biotrc(ibio,nstp)=tl_t(i,j,k,nstp,ibio)
304!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
305!^
306 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
307 tl_biotrc(ibio,nnew)=tl_t(i,j,k,nnew,ibio)* &
308 & hz_inv(i,k)+ &
309 & t(i,j,k,nnew,ibio)*hz(i,j,k)* &
310 & tl_hz_inv(i,k)
311 END DO
312!
313! Impose positive definite concentrations.
314!
315 cff2=0.0_r8
316 DO itime=1,2
317 cff1=0.0_r8
318 tl_cff1=0.0_r8
319 itrcmax=idbio(1)
320 DO itrc=1,nbt
321 ibio=idbio(itrc)
322 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
323 tl_cff1=tl_cff1- &
324 & (0.5_r8-sign(0.5_r8, &
325 & biotrc(ibio,itime)-minval))* &
326 & tl_biotrc(ibio,itime)
327 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
328 itrcmax=ibio
329 END IF
330 biotrc1(ibio,itime)=biotrc(ibio,itime)
331 biotrc(ibio,itime)=max(minval,biotrc1(ibio,itime))
332 tl_biotrc(ibio,itime)=(0.5_r8- &
333 & sign(0.5_r8, &
334 & minval- &
335 & biotrc1(ibio,itime)))* &
336 & tl_biotrc(ibio,itime)
337 END DO
338 IF (biotrc(itrcmax,itime).gt.cff1) THEN
339 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
340 tl_biotrc(itrcmax,itime)=tl_biotrc(itrcmax,itime)- &
341 & tl_cff1
342 END IF
343 END DO
344!
345! Load biological tracers into local arrays.
346!
347 DO itrc=1,nbt
348 ibio=idbio(itrc)
349 bio_old(i,k,ibio)=biotrc(ibio,nstp)
350 tl_bio_old(i,k,ibio)=tl_biotrc(ibio,nstp)
351 bio(i,k,ibio)=biotrc(ibio,nstp)
352 tl_bio(i,k,ibio)=tl_biotrc(ibio,nstp)
353 END DO
354 END DO
355 END DO
356!
357! Calculate surface Photosynthetically Available Radiation (PAR). The
358! net shortwave radiation is scaled back to Watts/m2 and multiplied by
359! the fraction that is photosynthetically available, PARfrac.
360!
361 DO i=istr,iend
362#ifdef CONST_PAR
363!
364! Specify constant surface irradiance a la Powell and Spitz.
365!
366 parsur(i)=158.075_r8
367 tl_parsur(i)=0.0_r8
368#else
369 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
370 tl_parsur(i)=(tl_parfrac(ng)*srflx(i,j)+ &
371 & parfrac(ng)*tl_srflx(i,j))*rho0*cp
372#endif
373 END DO
374!
375!=======================================================================
376! Start internal iterations to achieve convergence of the nonlinear
377! backward-implicit solution.
378!=======================================================================
379!
380! During the iterative procedure a series of fractional time steps are
381! performed in a chained mode (splitting by different biological
382! conversion processes) in sequence of the main food chain. In all
383! stages the concentration of the component being consumed is treated
384! in a fully implicit manner, so the algorithm guarantees non-negative
385! values, no matter how strong the concentration of active consuming
386! component (Phytoplankton or Zooplankton). The overall algorithm,
387! as well as any stage of it, is formulated in conservative form
388! (except explicit sinking) in sense that the sum of concentration of
389! all components is conserved.
390!
391! In the implicit algorithm, we have for example (N: nutrient,
392! P: phytoplankton),
393!
394! N(new) = N(old) - uptake * P(old) uptake = mu * N / (Kn + N)
395! {Michaelis-Menten}
396! below, we set
397! The N in the numerator of
398! cff = mu * P(old) / (Kn + N(old)) uptake is treated implicitly
399! as N(new)
400!
401! so the time-stepping of the equations becomes:
402!
403! N(new) = N(old) / (1 + cff) (1) when substracting a sink term,
404! consuming, divide by (1 + cff)
405! and
406!
407! P(new) = P(old) + cff * N(new) (2) when adding a source term,
408! growing, add (cff * source)
409!
410! Notice that if you substitute (1) in (2), you will get:
411!
412! P(new) = P(old) + cff * N(old) / (1 + cff) (3)
413!
414! If you add (1) and (3), you get
415!
416! N(new) + P(new) = N(old) + P(old)
417!
418! implying conservation regardless how "cff" is computed. Therefore,
419! this scheme is unconditionally stable regardless of the conversion
420! rate. It does not generate negative values since the constituent
421! to be consumed is always treated implicitly. It is also biased
422! toward damping oscillations.
423!
424! The iterative loop below is to iterate toward an universal Backward-
425! Euler treatment of all terms. So if there are oscillations in the
426! system, they are only physical oscillations. These iterations,
427! however, do not improve the accuaracy of the solution.
428!
429 iter_loop: DO iter=1,bioiter(ng)
430!
431! Compute appropriate basic state arrays I.
432!
433 DO k=1,n(ng)
434 DO i=istr,iend
435!
436! At input, all tracers (index nnew) from predictor step have
437! transport units (m Tunits) since we do not have yet the new
438! values for zeta and Hz. These are known after the 2D barotropic
439! time-stepping.
440!
441! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
442! tracer times depth. However the basic state (nstp and nnew
443! indices) that is read from the forward file is in units of
444! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
445! use t instead of t*Hz_inv.
446!
447 DO itrc=1,nbt
448 ibio=idbio(itrc)
449!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
450!^
451 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
452!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
453!^
454 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
455 END DO
456!
457! Impose positive definite concentrations.
458!
459 cff2=0.0_r8
460 DO itime=1,2
461 cff1=0.0_r8
462 itrcmax=idbio(1)
463 DO itrc=1,nbt
464 ibio=idbio(itrc)
465 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
466 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
467 itrcmax=ibio
468 END IF
469 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
470 END DO
471 IF (biotrc(itrcmax,itime).gt.cff1) THEN
472 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
473 END IF
474 END DO
475!
476! Load biological tracers into local arrays.
477!
478 DO itrc=1,nbt
479 ibio=idbio(itrc)
480 bio_old(i,k,ibio)=biotrc(ibio,nnew)
481 bio(i,k,ibio)=biotrc(ibio,nnew)
482 END DO
483 END DO
484 END DO
485!
486! Calculate surface Photosynthetically Available Radiation (PAR). The
487! net shortwave radiation is scaled back to Watts/m2 and multiplied by
488! the fraction that is photosynthetically available, PARfrac.
489!
490 DO i=istr,iend
491#ifdef CONST_PAR
492!
493! Specify constant surface irradiance a la Powell and Spitz.
494!
495 parsur(i)=158.075_r8
496#else
497 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
498#endif
499 END DO
500!
501!=======================================================================
502! Start internal iterations to achieve convergence of the nonlinear
503! backward-implicit solution.
504!=======================================================================
505!
506 DO iteradj=1,iter
507!
508! Compute light attenuation as function of depth.
509!
510 DO i=istr,iend
511 par=parsur(i)
512 IF (parsur(i).gt.0.0_r8) THEN ! day time
513 DO k=n(ng),1,-1
514!
515! Compute average light attenuation for each grid cell. Here, AttSW is
516! the light attenuation due to seawater and AttPhy is the attenuation
517! due to phytoplankton (self-shading coefficient).
518!
519 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
520 & (z_w(i,j,k)-z_w(i,j,k-1))
521 expatt=exp(-att)
522 itop=par
523 par=itop*(1.0_r8-expatt)/att ! average at cell center
524 light(i,k)=par
525!
526! Light attenuation at the bottom of the grid cell. It is the starting
527! PAR value for the next (deeper) vertical grid cell.
528!
529 par=itop*expatt
530 END DO
531 ELSE ! night time
532 DO k=1,n(ng)
533 light(i,k)=0.0_r8
534 END DO
535 END IF
536 END DO
537!
538! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
539! The Michaelis-Menten curve is used to describe the change in uptake
540! rate as a function of nitrate concentration. Here, PhyIS is the
541! initial slope of the P-I curve and K_NO3 is the half saturation of
542! phytoplankton nitrate uptake.
543!
544 cff1=dtdays*vm_no3(ng)*phyis(ng)
545 cff2=vm_no3(ng)*vm_no3(ng)
546 cff3=phyis(ng)*phyis(ng)
547 DO k=1,n(ng)
548 DO i=istr,iend
549 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
550 cff=bio(i,k,iphyt)* &
551 & cff1*cff4*light(i,k)/ &
552 & (k_no3(ng)+bio(i,k,ino3_))
553 bio1(i,k,ino3_)=bio(i,k,ino3_)
554 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
555 bio1(i,k,iphyt)=bio(i,k,iphyt)
556 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
557 & bio(i,k,ino3_)*cff
558 END DO
559 END DO
560!
561 IF (iteradj.ne.iter) THEN
562!
563! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
564! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
565! pool as function of "sloppy feeding" and metabolic processes
566! (ZooEEN and ZooEED fractions).
567!
568 cff1=dtdays*zoogr(ng)
569 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
570 DO k=1,n(ng)
571 DO i=istr,iend
572 cff=bio(i,k,izoop)* &
573 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
574 & bio(i,k,iphyt)
575 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
576 bio(i,k,izoop)=bio(i,k,izoop)+ &
577 & bio(i,k,iphyt)*cff2*cff
578 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
579 & bio(i,k,iphyt)*zooeen(ng)*cff
580 bio(i,k,isdet)=bio(i,k,isdet)+ &
581 & bio(i,k,iphyt)*zooeed(ng)*cff
582 END DO
583 END DO
584!
585! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
586! (PhyMRD rate).
587!
588 cff3=dtdays*phymrd(ng)
589 cff2=dtdays*phymrn(ng)
590 cff1=1.0_r8/(1.0_r8+cff2+cff3)
591 DO k=1,n(ng)
592 DO i=istr,iend
593 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
594 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
595 & bio(i,k,iphyt)*cff2
596 bio(i,k,isdet)=bio(i,k,isdet)+ &
597 & bio(i,k,iphyt)*cff3
598 END DO
599 END DO
600!
601! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
602! (ZooMRD rate).
603!
604 cff3=dtdays*zoomrd(ng)
605 cff2=dtdays*zoomrn(ng)
606 cff1=1.0_r8/(1.0_r8+cff2+cff3)
607 DO k=1,n(ng)
608 DO i=istr,iend
609 bio(i,k,izoop)=bio(i,k,izoop)*cff1
610 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
611 & bio(i,k,izoop)*cff2
612 bio(i,k,isdet)=bio(i,k,isdet)+ &
613 & bio(i,k,izoop)*cff3
614 END DO
615 END DO
616!
617! Detritus breakdown to nutrients: remineralization (DetRR rate).
618!
619 cff2=dtdays*detrr(ng)
620 cff1=1.0_r8/(1.0_r8+cff2)
621 DO k=1,n(ng)
622 DO i=istr,iend
623 bio(i,k,isdet)=bio(i,k,isdet)*cff1
624 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
625 & bio(i,k,isdet)*cff2
626 END DO
627 END DO
628!
629!-----------------------------------------------------------------------
630! Vertical sinking terms: Phytoplankton and Detritus
631!-----------------------------------------------------------------------
632!
633! Reconstruct vertical profile of selected biological constituents
634! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
635! grid box. Then, compute semi-Lagrangian flux due to sinking.
636!
637 DO isink=1,nsink
638 ibio=idsink(isink)
639!
640! Copy concentration of biological particulates into scratch array
641! "qc" (q-central, restrict it to be positive) which is hereafter
642! interpreted as a set of grid-box averaged values for biogeochemical
643! constituent concentration.
644!
645 DO k=1,n(ng)
646 DO i=istr,iend
647 qc(i,k)=bio(i,k,ibio)
648 END DO
649 END DO
650!
651 DO k=n(ng)-1,1,-1
652 DO i=istr,iend
653 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
654 END DO
655 END DO
656 DO k=2,n(ng)-1
657 DO i=istr,iend
658 dltr=hz(i,j,k)*fc(i,k)
659 dltl=hz(i,j,k)*fc(i,k-1)
660 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
661 cffr=cff*fc(i,k)
662 cffl=cff*fc(i,k-1)
663!
664! Apply PPM monotonicity constraint to prevent oscillations within the
665! grid box.
666!
667 IF ((dltr*dltl).le.0.0_r8) THEN
668 dltr=0.0_r8
669 dltl=0.0_r8
670 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
671 dltr=cffl
672 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
673 dltl=cffr
674 END IF
675!
676! Compute right and left side values (bR,bL) of parabolic segments
677! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
678!
679! NOTE: Although each parabolic segment is monotonic within its grid
680! box, monotonicity of the whole profile is not guaranteed,
681! because bL(k+1)-bR(k) may still have different sign than
682! qc(i,k+1)-qc(i,k). This possibility is excluded,
683! after bL and bR are reconciled using WENO procedure.
684!
685 cff=(dltr-dltl)*hz_inv3(i,k)
686 dltr=dltr-cff*hz(i,j,k+1)
687 dltl=dltl+cff*hz(i,j,k-1)
688 br(i,k)=qc(i,k)+dltr
689 bl(i,k)=qc(i,k)-dltl
690 wr(i,k)=(2.0_r8*dltr-dltl)**2
691 wl(i,k)=(dltr-2.0_r8*dltl)**2
692 END DO
693 END DO
694 cff=1.0e-14_r8
695 DO k=2,n(ng)-2
696 DO i=istr,iend
697 dltl=max(cff,wl(i,k ))
698 dltr=max(cff,wr(i,k+1))
699 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
700 bl(i,k+1)=br(i,k)
701 END DO
702 END DO
703 DO i=istr,iend
704 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
705#if defined LINEAR_CONTINUATION
706 bl(i,n(ng))=br(i,n(ng)-1)
707 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
708#elif defined NEUMANN
709 bl(i,n(ng))=br(i,n(ng)-1)
710 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
711#else
712 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
713 bl(i,n(ng))=qc(i,n(ng)) ! conditions
714 br(i,n(ng)-1)=qc(i,n(ng))
715#endif
716#if defined LINEAR_CONTINUATION
717 br(i,1)=bl(i,2)
718 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
719#elif defined NEUMANN
720 br(i,1)=bl(i,2)
721 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
722#else
723 bl(i,2)=qc(i,1) ! bottom grid boxes are
724 br(i,1)=qc(i,1) ! re-assumed to be
725 bl(i,1)=qc(i,1) ! piecewise constant.
726#endif
727 END DO
728!
729! Apply monotonicity constraint again, since the reconciled interfacial
730! values may cause a non-monotonic behavior of the parabolic segments
731! inside the grid box.
732!
733 DO k=1,n(ng)
734 DO i=istr,iend
735 dltr=br(i,k)-qc(i,k)
736 dltl=qc(i,k)-bl(i,k)
737 cffr=2.0_r8*dltr
738 cffl=2.0_r8*dltl
739 IF ((dltr*dltl).lt.0.0_r8) THEN
740 dltr=0.0_r8
741 dltl=0.0_r8
742 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
743 dltr=cffl
744 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
745 dltl=cffr
746 END IF
747 br(i,k)=qc(i,k)+dltr
748 bl(i,k)=qc(i,k)-dltl
749 END DO
750 END DO
751!
752! After this moment reconstruction is considered complete. The next
753! stage is to compute vertical advective fluxes, FC. It is expected
754! that sinking may occurs relatively fast, the algorithm is designed
755! to be free of CFL criterion, which is achieved by allowing
756! integration bounds for semi-Lagrangian advective flux to use as
757! many grid boxes in upstream direction as necessary.
758!
759! In the two code segments below, WL is the z-coordinate of the
760! departure point for grid box interface z_w with the same indices;
761! FC is the finite volume flux; ksource(:,k) is index of vertical
762! grid box which contains the departure point (restricted by N(ng)).
763! During the search: also add in content of whole grid boxes
764! participating in FC.
765!
766 cff=dtdays*abs(wbio(isink))
767 DO k=1,n(ng)
768 DO i=istr,iend
769 fc(i,k-1)=0.0_r8
770 wl(i,k)=z_w(i,j,k-1)+cff
771 wr(i,k)=hz(i,j,k)*qc(i,k)
772 ksource(i,k)=k
773 END DO
774 END DO
775 DO k=1,n(ng)
776 DO ks=k,n(ng)-1
777 DO i=istr,iend
778 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
779 ksource(i,k)=ks+1
780 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
781 END IF
782 END DO
783 END DO
784 END DO
785!
786! Finalize computation of flux: add fractional part.
787!
788 DO k=1,n(ng)
789 DO i=istr,iend
790 ks=ksource(i,k)
791 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
792 fc(i,k-1)=fc(i,k-1)+ &
793 & hz(i,j,ks)*cu* &
794 & (bl(i,ks)+ &
795 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
796 & (1.5_r8-cu)* &
797 & (br(i,ks)+bl(i,ks)- &
798 & 2.0_r8*qc(i,ks))))
799 END DO
800 END DO
801 DO k=1,n(ng)
802 DO i=istr,iend
803 bio(i,k,ibio)=qc(i,k)+ &
804 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
805 END DO
806 END DO
807 END DO
808 END IF
809 END DO
810!
811! End of compute basic state arrays I.
812!
813! Compute light attenuation as function of depth.
814!
815 DO i=istr,iend
816 par=parsur(i)
817 tl_par=tl_parsur(i)
818 IF (parsur(i).gt.0.0_r8) THEN ! day time
819 DO k=n(ng),1,-1
820!
821! Compute average light attenuation for each grid cell. Here, AttSW is
822! the light attenuation due to seawater and AttPhy is the attenuation
823! due to phytoplankton (self-shading coefficient).
824!
825 att=(attsw(ng)+attphy(ng)*bio1(i,k,iphyt))* &
826 & (z_w(i,j,k)-z_w(i,j,k-1))
827 tl_att=attphy(ng)*tl_bio(i,k,iphyt)* &
828 & (z_w(i,j,k)-z_w(i,j,k-1))+ &
829 & (attsw(ng)+attphy(ng)*bio1(i,k,iphyt))* &
830 & (tl_z_w(i,j,k)-tl_z_w(i,j,k-1))
831 expatt=exp(-att)
832 tl_expatt=-expatt*tl_att
833 itop=par
834 tl_itop=tl_par
835 par=itop*(1.0_r8-expatt)/att ! average at cell center
836 tl_par=(-tl_att*par+tl_itop*(1.0_r8-expatt)- &
837 & itop*tl_expatt)/att
838!^ Light(i,k)=PAR
839!^
840 tl_light(i,k)=tl_par
841!
842! Light attenuation at the bottom of the grid cell. It is the starting
843! PAR value for the next (deeper) vertical grid cell.
844!
845 par=itop*expatt
846 tl_par=tl_itop*expatt+itop*tl_expatt
847 END DO
848 ELSE ! night time
849 DO k=1,n(ng)
850!^ Light(i,k)=0.0_r8
851!^
852 tl_light(i,k)=0.0_r8
853 END DO
854 END IF
855 END DO
856!
857! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
858! The Michaelis-Menten curve is used to describe the change in uptake
859! rate as a function of nitrate concentration. Here, PhyIS is the
860! initial slope of the P-I curve and K_NO3 is the half saturation of
861! phytoplankton nitrate uptake.
862!
863 cff1=dtdays*vm_no3(ng)*phyis(ng)
864 cff2=vm_no3(ng)*vm_no3(ng)
865 cff3=phyis(ng)*phyis(ng)
866 DO k=1,n(ng)
867 DO i=istr,iend
868 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
869 tl_cff4=-cff3*tl_light(i,k)*light(i,k)*cff4*cff4*cff4
870 cff=bio1(i,k,iphyt)* &
871 & cff1*cff4*light(i,k)/ &
872 & (k_no3(ng)+bio1(i,k,ino3_))
873 tl_cff=(tl_bio(i,k,iphyt)*cff1*cff4*light(i,k)+ &
874 & bio1(i,k,iphyt)*cff1* &
875 & (tl_cff4*light(i,k)+cff4*tl_light(i,k))- &
876 & tl_bio(i,k,ino3_)*cff)/ &
877 & (k_no3(ng)+bio1(i,k,ino3_))
878!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)/(1.0_r8+cff)
879!^
880 tl_bio(i,k,ino3_)=(tl_bio(i,k,ino3_)- &
881 & tl_cff*bio(i,k,ino3_))/ &
882 & (1.0_r8+cff)
883!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)+ &
884!^ & Bio(i,k,iNO3_)*cff
885!^
886 tl_bio(i,k,iphyt)=tl_bio(i,k,iphyt)+ &
887 & tl_bio(i,k,ino3_)*cff+ &
888 & bio(i,k,ino3_)*tl_cff
889 END DO
890 END DO
891!
892! Compute appropriate basic state arrays II.
893!
894 DO k=1,n(ng)
895 DO i=istr,iend
896!
897! At input, all tracers (index nnew) from predictor step have
898! transport units (m Tunits) since we do not have yet the new
899! values for zeta and Hz. These are known after the 2D barotropic
900! time-stepping.
901!
902! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
903! tracer times depth. However the basic state (nstp and nnew
904! indices) that is read from the forward file is in units of
905! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
906! use t instead of t*Hz_inv.
907!
908 DO itrc=1,nbt
909 ibio=idbio(itrc)
910!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
911!^
912 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
913!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
914!^
915 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
916 END DO
917!
918! Impose positive definite concentrations.
919!
920 cff2=0.0_r8
921 DO itime=1,2
922 cff1=0.0_r8
923 itrcmax=idbio(1)
924 DO itrc=1,nbt
925 ibio=idbio(itrc)
926 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
927 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
928 itrcmax=ibio
929 END IF
930 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
931 END DO
932 IF (biotrc(itrcmax,itime).gt.cff1) THEN
933 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
934 END IF
935 END DO
936!
937! Load biological tracers into local arrays.
938!
939 DO itrc=1,nbt
940 ibio=idbio(itrc)
941 bio_old(i,k,ibio)=biotrc(ibio,nnew)
942 bio(i,k,ibio)=biotrc(ibio,nnew)
943 END DO
944 END DO
945 END DO
946!
947! Calculate surface Photosynthetically Available Radiation (PAR). The
948! net shortwave radiation is scaled back to Watts/m2 and multiplied by
949! the fraction that is photosynthetically available, PARfrac.
950!
951 DO i=istr,iend
952#ifdef CONST_PAR
953!
954! Specify constant surface irradiance a la Powell and Spitz.
955!
956 parsur(i)=158.075_r8
957#else
958 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
959#endif
960 END DO
961!
962!=======================================================================
963! Start internal iterations to achieve convergence of the nonlinear
964! backward-implicit solution.
965!=======================================================================
966!
967 DO iteradj=1,iter
968!
969! Compute light attenuation as function of depth.
970!
971 DO i=istr,iend
972 par=parsur(i)
973 IF (parsur(i).gt.0.0_r8) THEN ! day time
974 DO k=n(ng),1,-1
975!
976! Compute average light attenuation for each grid cell. Here, AttSW is
977! the light attenuation due to seawater and AttPhy is the attenuation
978! due to phytoplankton (self-shading coefficient).
979!
980 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
981 & (z_w(i,j,k)-z_w(i,j,k-1))
982 expatt=exp(-att)
983 itop=par
984 par=itop*(1.0_r8-expatt)/att ! average at cell center
985 light(i,k)=par
986!
987! Light attenuation at the bottom of the grid cell. It is the starting
988! PAR value for the next (deeper) vertical grid cell.
989!
990 par=itop*expatt
991 END DO
992 ELSE ! night time
993 DO k=1,n(ng)
994 light(i,k)=0.0_r8
995 END DO
996 END IF
997 END DO
998!
999! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
1000! The Michaelis-Menten curve is used to describe the change in uptake
1001! rate as a function of nitrate concentration. Here, PhyIS is the
1002! initial slope of the P-I curve and K_NO3 is the half saturation of
1003! phytoplankton nitrate uptake.
1004!
1005 cff1=dtdays*vm_no3(ng)*phyis(ng)
1006 cff2=vm_no3(ng)*vm_no3(ng)
1007 cff3=phyis(ng)*phyis(ng)
1008 DO k=1,n(ng)
1009 DO i=istr,iend
1010 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
1011 cff=bio(i,k,iphyt)* &
1012 & cff1*cff4*light(i,k)/ &
1013 & (k_no3(ng)+bio(i,k,ino3_))
1014 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
1015 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
1016 & bio(i,k,ino3_)*cff
1017 END DO
1018 END DO
1019!
1020! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
1021! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
1022! pool as function of "sloppy feeding" and metabolic processes
1023! (ZooEEN and ZooEED fractions).
1024!
1025 cff1=dtdays*zoogr(ng)
1026 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
1027 DO k=1,n(ng)
1028 DO i=istr,iend
1029 cff=bio(i,k,izoop)* &
1030 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
1031 & bio(i,k,iphyt)
1032 bio1(i,k,iphyt)=bio(i,k,iphyt)
1033 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
1034 bio1(i,k,izoop)=bio(i,k,izoop)
1035 bio(i,k,izoop)=bio(i,k,izoop)+ &
1036 & bio(i,k,iphyt)*cff2*cff
1037 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1038 & bio(i,k,iphyt)*zooeen(ng)*cff
1039 bio(i,k,isdet)=bio(i,k,isdet)+ &
1040 & bio(i,k,iphyt)*zooeed(ng)*cff
1041 END DO
1042 END DO
1043!
1044 IF (iteradj.ne.iter) THEN
1045!
1046! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
1047! (PhyMRD rate).
1048!
1049 cff3=dtdays*phymrd(ng)
1050 cff2=dtdays*phymrn(ng)
1051 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1052 DO k=1,n(ng)
1053 DO i=istr,iend
1054 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
1055 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1056 & bio(i,k,iphyt)*cff2
1057 bio(i,k,isdet)=bio(i,k,isdet)+ &
1058 & bio(i,k,iphyt)*cff3
1059 END DO
1060 END DO
1061!
1062! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
1063! (ZooMRD rate).
1064!
1065 cff3=dtdays*zoomrd(ng)
1066 cff2=dtdays*zoomrn(ng)
1067 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1068 DO k=1,n(ng)
1069 DO i=istr,iend
1070 bio(i,k,izoop)=bio(i,k,izoop)*cff1
1071 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1072 & bio(i,k,izoop)*cff2
1073 bio(i,k,isdet)=bio(i,k,isdet)+ &
1074 & bio(i,k,izoop)*cff3
1075 END DO
1076 END DO
1077!
1078! Detritus breakdown to nutrients: remineralization (DetRR rate).
1079!
1080 cff2=dtdays*detrr(ng)
1081 cff1=1.0_r8/(1.0_r8+cff2)
1082 DO k=1,n(ng)
1083 DO i=istr,iend
1084 bio(i,k,isdet)=bio(i,k,isdet)*cff1
1085 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1086 & bio(i,k,isdet)*cff2
1087 END DO
1088 END DO
1089!
1090!-----------------------------------------------------------------------
1091! Vertical sinking terms: Phytoplankton and Detritus
1092!-----------------------------------------------------------------------
1093!
1094! Reconstruct vertical profile of selected biological constituents
1095! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1096! grid box. Then, compute semi-Lagrangian flux due to sinking.
1097!
1098 DO isink=1,nsink
1099 ibio=idsink(isink)
1100!
1101! Copy concentration of biological particulates into scratch array
1102! "qc" (q-central, restrict it to be positive) which is hereafter
1103! interpreted as a set of grid-box averaged values for biogeochemical
1104! constituent concentration.
1105!
1106 DO k=1,n(ng)
1107 DO i=istr,iend
1108 qc(i,k)=bio(i,k,ibio)
1109 END DO
1110 END DO
1111!
1112 DO k=n(ng)-1,1,-1
1113 DO i=istr,iend
1114 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1115 END DO
1116 END DO
1117 DO k=2,n(ng)-1
1118 DO i=istr,iend
1119 dltr=hz(i,j,k)*fc(i,k)
1120 dltl=hz(i,j,k)*fc(i,k-1)
1121 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1122 cffr=cff*fc(i,k)
1123 cffl=cff*fc(i,k-1)
1124!
1125! Apply PPM monotonicity constraint to prevent oscillations within the
1126! grid box.
1127!
1128 IF ((dltr*dltl).le.0.0_r8) THEN
1129 dltr=0.0_r8
1130 dltl=0.0_r8
1131 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1132 dltr=cffl
1133 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1134 dltl=cffr
1135 END IF
1136!
1137! Compute right and left side values (bR,bL) of parabolic segments
1138! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1139!
1140! NOTE: Although each parabolic segment is monotonic within its grid
1141! box, monotonicity of the whole profile is not guaranteed,
1142! because bL(k+1)-bR(k) may still have different sign than
1143! qc(i,k+1)-qc(i,k). This possibility is excluded,
1144! after bL and bR are reconciled using WENO procedure.
1145!
1146 cff=(dltr-dltl)*hz_inv3(i,k)
1147 dltr=dltr-cff*hz(i,j,k+1)
1148 dltl=dltl+cff*hz(i,j,k-1)
1149 br(i,k)=qc(i,k)+dltr
1150 bl(i,k)=qc(i,k)-dltl
1151 wr(i,k)=(2.0_r8*dltr-dltl)**2
1152 wl(i,k)=(dltr-2.0_r8*dltl)**2
1153 END DO
1154 END DO
1155 cff=1.0e-14_r8
1156 DO k=2,n(ng)-2
1157 DO i=istr,iend
1158 dltl=max(cff,wl(i,k ))
1159 dltr=max(cff,wr(i,k+1))
1160 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1161 bl(i,k+1)=br(i,k)
1162 END DO
1163 END DO
1164 DO i=istr,iend
1165 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1166#if defined LINEAR_CONTINUATION
1167 bl(i,n(ng))=br(i,n(ng)-1)
1168 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1169#elif defined NEUMANN
1170 bl(i,n(ng))=br(i,n(ng)-1)
1171 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1172#else
1173 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1174 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1175 br(i,n(ng)-1)=qc(i,n(ng))
1176#endif
1177#if defined LINEAR_CONTINUATION
1178 br(i,1)=bl(i,2)
1179 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1180#elif defined NEUMANN
1181 br(i,1)=bl(i,2)
1182 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1183#else
1184 bl(i,2)=qc(i,1) ! bottom grid boxes are
1185 br(i,1)=qc(i,1) ! re-assumed to be
1186 bl(i,1)=qc(i,1) ! piecewise constant.
1187#endif
1188 END DO
1189!
1190! Apply monotonicity constraint again, since the reconciled interfacial
1191! values may cause a non-monotonic behavior of the parabolic segments
1192! inside the grid box.
1193!
1194 DO k=1,n(ng)
1195 DO i=istr,iend
1196 dltr=br(i,k)-qc(i,k)
1197 dltl=qc(i,k)-bl(i,k)
1198 cffr=2.0_r8*dltr
1199 cffl=2.0_r8*dltl
1200 IF ((dltr*dltl).lt.0.0_r8) THEN
1201 dltr=0.0_r8
1202 dltl=0.0_r8
1203 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1204 dltr=cffl
1205 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1206 dltl=cffr
1207 END IF
1208 br(i,k)=qc(i,k)+dltr
1209 bl(i,k)=qc(i,k)-dltl
1210 END DO
1211 END DO
1212!
1213! After this moment reconstruction is considered complete. The next
1214! stage is to compute vertical advective fluxes, FC. It is expected
1215! that sinking may occurs relatively fast, the algorithm is designed
1216! to be free of CFL criterion, which is achieved by allowing
1217! integration bounds for semi-Lagrangian advective flux to use as
1218! many grid boxes in upstream direction as necessary.
1219!
1220! In the two code segments below, WL is the z-coordinate of the
1221! departure point for grid box interface z_w with the same indices;
1222! FC is the finite volume flux; ksource(:,k) is index of vertical
1223! grid box which contains the departure point (restricted by N(ng)).
1224! During the search: also add in content of whole grid boxes
1225! participating in FC.
1226!
1227 cff=dtdays*abs(wbio(isink))
1228 DO k=1,n(ng)
1229 DO i=istr,iend
1230 fc(i,k-1)=0.0_r8
1231 wl(i,k)=z_w(i,j,k-1)+cff
1232 wr(i,k)=hz(i,j,k)*qc(i,k)
1233 ksource(i,k)=k
1234 END DO
1235 END DO
1236 DO k=1,n(ng)
1237 DO ks=k,n(ng)-1
1238 DO i=istr,iend
1239 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1240 ksource(i,k)=ks+1
1241 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1242 END IF
1243 END DO
1244 END DO
1245 END DO
1246!
1247! Finalize computation of flux: add fractional part.
1248!
1249 DO k=1,n(ng)
1250 DO i=istr,iend
1251 ks=ksource(i,k)
1252 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1253 fc(i,k-1)=fc(i,k-1)+ &
1254 & hz(i,j,ks)*cu* &
1255 & (bl(i,ks)+ &
1256 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1257 & (1.5_r8-cu)* &
1258 & (br(i,ks)+bl(i,ks)- &
1259 & 2.0_r8*qc(i,ks))))
1260 END DO
1261 END DO
1262 DO k=1,n(ng)
1263 DO i=istr,iend
1264 bio(i,k,ibio)=qc(i,k)+ &
1265 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1266 END DO
1267 END DO
1268 END DO
1269 END IF
1270 END DO
1271!
1272! End of compute basic state arrays II.
1273!
1274! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
1275! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
1276! pool as function of "sloppy feeding" and metabolic processes
1277! (ZooEEN and ZooEED fractions).
1278!
1279 cff1=dtdays*zoogr(ng)
1280 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
1281 DO k=1,n(ng)
1282 DO i=istr,iend
1283 cff=bio1(i,k,izoop)* &
1284 & cff1*(1.0_r8-exp(-ivlev(ng)*bio1(i,k,iphyt)))/ &
1285 & bio1(i,k,iphyt)
1286 tl_cff=(tl_bio(i,k,izoop)* &
1287 & cff1*(1.0_r8-exp(-ivlev(ng)*bio1(i,k,iphyt)))+ &
1288 & bio1(i,k,izoop)*ivlev(ng)*tl_bio(i,k,iphyt)*cff1* &
1289 & exp(-ivlev(ng)*bio1(i,k,iphyt))- &
1290 & tl_bio(i,k,iphyt)*cff)/ &
1291 & bio1(i,k,iphyt)
1292!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)/(1.0_r8+cff)
1293!^
1294 tl_bio(i,k,iphyt)=(tl_bio(i,k,iphyt)- &
1295 & tl_cff*bio(i,k,iphyt))/ &
1296 & (1.0_r8+cff)
1297!^ Bio(i,k,iZoop)=Bio(i,k,iZoop)+ &
1298!^ & Bio(i,k,iPhyt)*cff2*cff
1299!^
1300 tl_bio(i,k,izoop)=tl_bio(i,k,izoop)+ &
1301 & cff2*(tl_bio(i,k,iphyt)*cff+ &
1302 & bio(i,k,iphyt)*tl_cff)
1303!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1304!^ & Bio(i,k,iPhyt)*ZooEEN(ng)*cff
1305!^
1306 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1307 & zooeen(ng)*(tl_bio(i,k,iphyt)*cff+ &
1308 & bio(i,k,iphyt)*tl_cff)
1309!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1310!^ & Bio(i,k,iPhyt)*ZooEED(ng)*cff
1311!^
1312 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1313 & zooeed(ng)*(tl_bio(i,k,iphyt)*cff+ &
1314 & bio(i,k,iphyt)*tl_cff)
1315 END DO
1316 END DO
1317!
1318! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
1319! (PhyMRD rate).
1320!
1321 cff3=dtdays*phymrd(ng)
1322 cff2=dtdays*phymrn(ng)
1323 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1324 DO k=1,n(ng)
1325 DO i=istr,iend
1326!^ Bio(i,k,iPhyt)=Bio(i,k,iPhyt)*cff1
1327!^
1328 tl_bio(i,k,iphyt)=tl_bio(i,k,iphyt)*cff1
1329!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1330!^ & Bio(i,k,iPhyt)*cff2
1331!^
1332 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1333 & tl_bio(i,k,iphyt)*cff2
1334!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1335!^ & Bio(i,k,iPhyt)*cff3
1336!^
1337 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1338 & tl_bio(i,k,iphyt)*cff3
1339 END DO
1340 END DO
1341!
1342! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
1343! (ZooMRD rate).
1344!
1345 cff3=dtdays*zoomrd(ng)
1346 cff2=dtdays*zoomrn(ng)
1347 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1348 DO k=1,n(ng)
1349 DO i=istr,iend
1350!^ Bio(i,k,iZoop)=Bio(i,k,iZoop)*cff1
1351!^
1352 tl_bio(i,k,izoop)=tl_bio(i,k,izoop)*cff1
1353!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1354!^ & Bio(i,k,iZoop)*cff2
1355!^
1356 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1357 & tl_bio(i,k,izoop)*cff2
1358!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)+ &
1359!^ & Bio(i,k,iZoop)*cff3
1360!^
1361 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)+ &
1362 & tl_bio(i,k,izoop)*cff3
1363 END DO
1364 END DO
1365!
1366! Detritus breakdown to nutrients: remineralization (DetRR rate).
1367!
1368 cff2=dtdays*detrr(ng)
1369 cff1=1.0_r8/(1.0_r8+cff2)
1370 DO k=1,n(ng)
1371 DO i=istr,iend
1372!^ Bio(i,k,iSDet)=Bio(i,k,iSDet)*cff1
1373!^
1374 tl_bio(i,k,isdet)=tl_bio(i,k,isdet)*cff1
1375!^ Bio(i,k,iNO3_)=Bio(i,k,iNO3_)+ &
1376!^ & Bio(i,k,iSDet)*cff2
1377!^
1378 tl_bio(i,k,ino3_)=tl_bio(i,k,ino3_)+ &
1379 & tl_bio(i,k,isdet)*cff2
1380 END DO
1381 END DO
1382!
1383! Compute appropriate basic state arrays III.
1384!
1385 DO k=1,n(ng)
1386 DO i=istr,iend
1387!
1388! At input, all tracers (index nnew) from predictor step have
1389! transport units (m Tunits) since we do not have yet the new
1390! values for zeta and Hz. These are known after the 2D barotropic
1391! time-stepping.
1392!
1393! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
1394! tracer times depth. However the basic state (nstp and nnew
1395! indices) that is read from the forward file is in units of
1396! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
1397! use t instead of t*Hz_inv.
1398!
1399 DO itrc=1,nbt
1400 ibio=idbio(itrc)
1401!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1402!^
1403 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1404!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
1405!^
1406 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
1407 END DO
1408!
1409! Impose positive definite concentrations.
1410!
1411 cff2=0.0_r8
1412 DO itime=1,2
1413 cff1=0.0_r8
1414 itrcmax=idbio(1)
1415 DO itrc=1,nbt
1416 ibio=idbio(itrc)
1417 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
1418 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
1419 itrcmax=ibio
1420 END IF
1421 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
1422 END DO
1423 IF (biotrc(itrcmax,itime).gt.cff1) THEN
1424 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
1425 END IF
1426 END DO
1427!
1428! Load biological tracers into local arrays.
1429!
1430 DO itrc=1,nbt
1431 ibio=idbio(itrc)
1432 bio_old(i,k,ibio)=biotrc(ibio,nstp)
1433 bio(i,k,ibio)=biotrc(ibio,nstp)
1434 END DO
1435 END DO
1436 END DO
1437!
1438! Calculate surface Photosynthetically Available Radiation (PAR). The
1439! net shortwave radiation is scaled back to Watts/m2 and multiplied by
1440! the fraction that is photosynthetically available, PARfrac.
1441!
1442 DO i=istr,iend
1443#ifdef CONST_PAR
1444!
1445! Specify constant surface irradiance a la Powell and Spitz.
1446!
1447 parsur(i)=158.075_r8
1448#else
1449 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
1450#endif
1451 END DO
1452!
1453!=======================================================================
1454! Start internal iterations to achieve convergence of the nonlinear
1455! backward-implicit solution.
1456!=======================================================================
1457!
1458 DO iteradj=1,iter
1459!
1460! Compute light attenuation as function of depth.
1461!
1462 DO i=istr,iend
1463 par=parsur(i)
1464 IF (parsur(i).gt.0.0_r8) THEN ! day time
1465 DO k=n(ng),1,-1
1466!
1467! Compute average light attenuation for each grid cell. Here, AttSW is
1468! the light attenuation due to seawater and AttPhy is the attenuation
1469! due to phytoplankton (self-shading coefficient).
1470!
1471 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
1472 & (z_w(i,j,k)-z_w(i,j,k-1))
1473 expatt=exp(-att)
1474 itop=par
1475 par=itop*(1.0_r8-expatt)/att ! average at cell center
1476 light(i,k)=par
1477!
1478! Light attenuation at the bottom of the grid cell. It is the starting
1479! PAR value for the next (deeper) vertical grid cell.
1480!
1481 par=itop*expatt
1482 END DO
1483 ELSE ! night time
1484 DO k=1,n(ng)
1485 light(i,k)=0.0_r8
1486 END DO
1487 END IF
1488 END DO
1489!
1490! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
1491! The Michaelis-Menten curve is used to describe the change in uptake
1492! rate as a function of nitrate concentration. Here, PhyIS is the
1493! initial slope of the P-I curve and K_NO3 is the half saturation of
1494! phytoplankton nitrate uptake.
1495!
1496 cff1=dtdays*vm_no3(ng)*phyis(ng)
1497 cff2=vm_no3(ng)*vm_no3(ng)
1498 cff3=phyis(ng)*phyis(ng)
1499 DO k=1,n(ng)
1500 DO i=istr,iend
1501 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
1502 cff=bio(i,k,iphyt)* &
1503 & cff1*cff4*light(i,k)/ &
1504 & (k_no3(ng)+bio(i,k,ino3_))
1505 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
1506 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
1507 & bio(i,k,ino3_)*cff
1508 END DO
1509 END DO
1510!
1511! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
1512! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
1513! pool as function of "sloppy feeding" and metabolic processes
1514! (ZooEEN and ZooEED fractions).
1515!
1516 cff1=dtdays*zoogr(ng)
1517 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
1518 DO k=1,n(ng)
1519 DO i=istr,iend
1520 cff=bio(i,k,izoop)* &
1521 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
1522 & bio(i,k,iphyt)
1523 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
1524 bio(i,k,izoop)=bio(i,k,izoop)+ &
1525 & bio(i,k,iphyt)*cff2*cff
1526 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1527 & bio(i,k,iphyt)*zooeen(ng)*cff
1528 bio(i,k,isdet)=bio(i,k,isdet)+ &
1529 & bio(i,k,iphyt)*zooeed(ng)*cff
1530 END DO
1531 END DO
1532!
1533! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
1534! (PhyMRD rate).
1535!
1536 cff3=dtdays*phymrd(ng)
1537 cff2=dtdays*phymrn(ng)
1538 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1539 DO k=1,n(ng)
1540 DO i=istr,iend
1541 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
1542 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1543 & bio(i,k,iphyt)*cff2
1544 bio(i,k,isdet)=bio(i,k,isdet)+ &
1545 & bio(i,k,iphyt)*cff3
1546 END DO
1547 END DO
1548!
1549! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
1550! (ZooMRD rate).
1551!
1552 cff3=dtdays*zoomrd(ng)
1553 cff2=dtdays*zoomrn(ng)
1554 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1555 DO k=1,n(ng)
1556 DO i=istr,iend
1557 bio(i,k,izoop)=bio(i,k,izoop)*cff1
1558 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1559 & bio(i,k,izoop)*cff2
1560 bio(i,k,isdet)=bio(i,k,isdet)+ &
1561 & bio(i,k,izoop)*cff3
1562 END DO
1563 END DO
1564!
1565! Detritus breakdown to nutrients: remineralization (DetRR rate).
1566!
1567 cff2=dtdays*detrr(ng)
1568 cff1=1.0_r8/(1.0_r8+cff2)
1569 DO k=1,n(ng)
1570 DO i=istr,iend
1571 bio(i,k,isdet)=bio(i,k,isdet)*cff1
1572 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1573 & bio(i,k,isdet)*cff2
1574 END DO
1575 END DO
1576!
1577 IF (iteradj.ne.iter) THEN
1578!
1579!-----------------------------------------------------------------------
1580! Vertical sinking terms: Phytoplankton and Detritus
1581!-----------------------------------------------------------------------
1582!
1583! Reconstruct vertical profile of selected biological constituents
1584! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1585! grid box. Then, compute semi-Lagrangian flux due to sinking.
1586!
1587 DO isink=1,nsink
1588 ibio=idsink(isink)
1589!
1590! Copy concentration of biological particulates into scratch array
1591! "qc" (q-central, restrict it to be positive) which is hereafter
1592! interpreted as a set of grid-box averaged values for biogeochemical
1593! constituent concentration.
1594!
1595 DO k=1,n(ng)
1596 DO i=istr,iend
1597 qc(i,k)=bio(i,k,ibio)
1598 END DO
1599 END DO
1600!
1601 DO k=n(ng)-1,1,-1
1602 DO i=istr,iend
1603 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1604 END DO
1605 END DO
1606 DO k=2,n(ng)-1
1607 DO i=istr,iend
1608 dltr=hz(i,j,k)*fc(i,k)
1609 dltl=hz(i,j,k)*fc(i,k-1)
1610 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1611 cffr=cff*fc(i,k)
1612 cffl=cff*fc(i,k-1)
1613!
1614! Apply PPM monotonicity constraint to prevent oscillations within the
1615! grid box.
1616!
1617 IF ((dltr*dltl).le.0.0_r8) THEN
1618 dltr=0.0_r8
1619 dltl=0.0_r8
1620 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1621 dltr=cffl
1622 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1623 dltl=cffr
1624 END IF
1625!
1626! Compute right and left side values (bR,bL) of parabolic segments
1627! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1628!
1629! NOTE: Although each parabolic segment is monotonic within its grid
1630! box, monotonicity of the whole profile is not guaranteed,
1631! because bL(k+1)-bR(k) may still have different sign than
1632! qc(i,k+1)-qc(i,k). This possibility is excluded,
1633! after bL and bR are reconciled using WENO procedure.
1634!
1635 cff=(dltr-dltl)*hz_inv3(i,k)
1636 dltr=dltr-cff*hz(i,j,k+1)
1637 dltl=dltl+cff*hz(i,j,k-1)
1638 br(i,k)=qc(i,k)+dltr
1639 bl(i,k)=qc(i,k)-dltl
1640 wr(i,k)=(2.0_r8*dltr-dltl)**2
1641 wl(i,k)=(dltr-2.0_r8*dltl)**2
1642 END DO
1643 END DO
1644 cff=1.0e-14_r8
1645 DO k=2,n(ng)-2
1646 DO i=istr,iend
1647 dltl=max(cff,wl(i,k ))
1648 dltr=max(cff,wr(i,k+1))
1649 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1650 bl(i,k+1)=br(i,k)
1651 END DO
1652 END DO
1653 DO i=istr,iend
1654 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1655#if defined LINEAR_CONTINUATION
1656 bl(i,n(ng))=br(i,n(ng)-1)
1657 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1658#elif defined NEUMANN
1659 bl(i,n(ng))=br(i,n(ng)-1)
1660 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1661#else
1662 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1663 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1664 br(i,n(ng)-1)=qc(i,n(ng))
1665#endif
1666#if defined LINEAR_CONTINUATION
1667 br(i,1)=bl(i,2)
1668 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1669#elif defined NEUMANN
1670 br(i,1)=bl(i,2)
1671 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1672#else
1673 bl(i,2)=qc(i,1) ! bottom grid boxes are
1674 br(i,1)=qc(i,1) ! re-assumed to be
1675 bl(i,1)=qc(i,1) ! piecewise constant.
1676#endif
1677 END DO
1678!
1679! Apply monotonicity constraint again, since the reconciled interfacial
1680! values may cause a non-monotonic behavior of the parabolic segments
1681! inside the grid box.
1682!
1683 DO k=1,n(ng)
1684 DO i=istr,iend
1685 dltr=br(i,k)-qc(i,k)
1686 dltl=qc(i,k)-bl(i,k)
1687 cffr=2.0_r8*dltr
1688 cffl=2.0_r8*dltl
1689 IF ((dltr*dltl).lt.0.0_r8) THEN
1690 dltr=0.0_r8
1691 dltl=0.0_r8
1692 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1693 dltr=cffl
1694 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1695 dltl=cffr
1696 END IF
1697 br(i,k)=qc(i,k)+dltr
1698 bl(i,k)=qc(i,k)-dltl
1699 END DO
1700 END DO
1701!
1702! After this moment reconstruction is considered complete. The next
1703! stage is to compute vertical advective fluxes, FC. It is expected
1704! that sinking may occurs relatively fast, the algorithm is designed
1705! to be free of CFL criterion, which is achieved by allowing
1706! integration bounds for semi-Lagrangian advective flux to use as
1707! many grid boxes in upstream direction as necessary.
1708!
1709! In the two code segments below, WL is the z-coordinate of the
1710! departure point for grid box interface z_w with the same indices;
1711! FC is the finite volume flux; ksource(:,k) is index of vertical
1712! grid box which contains the departure point (restricted by N(ng)).
1713! During the search: also add in content of whole grid boxes
1714! participating in FC.
1715!
1716 cff=dtdays*abs(wbio(isink))
1717 DO k=1,n(ng)
1718 DO i=istr,iend
1719 fc(i,k-1)=0.0_r8
1720 wl(i,k)=z_w(i,j,k-1)+cff
1721 wr(i,k)=hz(i,j,k)*qc(i,k)
1722 ksource(i,k)=k
1723 END DO
1724 END DO
1725 DO k=1,n(ng)
1726 DO ks=k,n(ng)-1
1727 DO i=istr,iend
1728 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1729 ksource(i,k)=ks+1
1730 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1731 END IF
1732 END DO
1733 END DO
1734 END DO
1735!
1736! Finalize computation of flux: add fractional part.
1737!
1738 DO k=1,n(ng)
1739 DO i=istr,iend
1740 ks=ksource(i,k)
1741 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1742 fc(i,k-1)=fc(i,k-1)+ &
1743 & hz(i,j,ks)*cu* &
1744 & (bl(i,ks)+ &
1745 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1746 & (1.5_r8-cu)* &
1747 & (br(i,ks)+bl(i,ks)- &
1748 & 2.0_r8*qc(i,ks))))
1749 END DO
1750 END DO
1751 DO k=1,n(ng)
1752 DO i=istr,iend
1753 bio(i,k,ibio)=qc(i,k)+ &
1754 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1755 END DO
1756 END DO
1757 END DO
1758 END IF
1759 END DO
1760!
1761! End of compute basic state arrays III.
1762!
1763!-----------------------------------------------------------------------
1764! Tangent linear vertical sinking terms.
1765!-----------------------------------------------------------------------
1766!
1767! Reconstruct vertical profile of selected biological constituents
1768! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1769! grid box. Then, compute semi-Lagrangian flux due to sinking.
1770!
1771 sink_loop: DO isink=1,nsink
1772 ibio=idsink(isink)
1773!
1774! Copy concentration of biological particulates into scratch array
1775! "qc" (q-central, restrict it to be positive) which is hereafter
1776! interpreted as a set of grid-box averaged values for biogeochemical
1777! constituent concentration.
1778!
1779 DO k=1,n(ng)
1780 DO i=istr,iend
1781 qc(i,k)=bio(i,k,ibio)
1782 tl_qc(i,k)=tl_bio(i,k,ibio)
1783 END DO
1784 END DO
1785!
1786 DO k=n(ng)-1,1,-1
1787 DO i=istr,iend
1788 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1789 tl_fc(i,k)=(tl_qc(i,k+1)-tl_qc(i,k))*hz_inv2(i,k)+ &
1790 & (qc(i,k+1)-qc(i,k))*tl_hz_inv2(i,k)
1791 END DO
1792 END DO
1793 DO k=2,n(ng)-1
1794 DO i=istr,iend
1795 dltr=hz(i,j,k)*fc(i,k)
1796 tl_dltr=tl_hz(i,j,k)*fc(i,k)+hz(i,j,k)*tl_fc(i,k)
1797 dltl=hz(i,j,k)*fc(i,k-1)
1798 tl_dltl=tl_hz(i,j,k)*fc(i,k-1)+hz(i,j,k)*tl_fc(i,k-1)
1799 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1800 tl_cff=tl_hz(i,j,k-1)+2.0_r8*tl_hz(i,j,k)+tl_hz(i,j,k+1)
1801 cffr=cff*fc(i,k)
1802 tl_cffr=tl_cff*fc(i,k)+cff*tl_fc(i,k)
1803 cffl=cff*fc(i,k-1)
1804 tl_cffl=tl_cff*fc(i,k-1)+cff*tl_fc(i,k-1)
1805!
1806! Apply PPM monotonicity constraint to prevent oscillations within the
1807! grid box.
1808!
1809 IF ((dltr*dltl).le.0.0_r8) THEN
1810 dltr=0.0_r8
1811 tl_dltr=0.0_r8
1812 dltl=0.0_r8
1813 tl_dltl=0.0_r8
1814 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1815 dltr=cffl
1816 tl_dltr=tl_cffl
1817 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1818 dltl=cffr
1819 tl_dltl=tl_cffr
1820 END IF
1821!
1822! Compute right and left side values (bR,bL) of parabolic segments
1823! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1824!
1825! NOTE: Although each parabolic segment is monotonic within its grid
1826! box, monotonicity of the whole profile is not guaranteed,
1827! because bL(k+1)-bR(k) may still have different sign than
1828! qc(i,k+1)-qc(i,k). This possibility is excluded,
1829! after bL and bR are reconciled using WENO procedure.
1830!
1831 cff=(dltr-dltl)*hz_inv3(i,k)
1832 tl_cff=(tl_dltr-tl_dltl)*hz_inv3(i,k)+ &
1833 & (dltr-dltl)*tl_hz_inv3(i,k)
1834 dltr=dltr-cff*hz(i,j,k+1)
1835 tl_dltr=tl_dltr-tl_cff*hz(i,j,k+1)-cff*tl_hz(i,j,k+1)
1836 dltl=dltl+cff*hz(i,j,k-1)
1837 tl_dltl=tl_dltl+tl_cff*hz(i,j,k-1)+cff*tl_hz(i,j,k-1)
1838 br(i,k)=qc(i,k)+dltr
1839 tl_br(i,k)=tl_qc(i,k)+tl_dltr
1840 bl(i,k)=qc(i,k)-dltl
1841 tl_bl(i,k)=tl_qc(i,k)-tl_dltl
1842 wr(i,k)=(2.0_r8*dltr-dltl)**2
1843 tl_wr(i,k)=2.0_r8*(2.0_r8*dltr-dltl)* &
1844 & (2.0_r8*tl_dltr-tl_dltl)
1845 wl(i,k)=(dltr-2.0_r8*dltl)**2
1846 tl_wl(i,k)=2.0_r8*(dltr-2.0_r8*dltl)* &
1847 & (tl_dltr-2.0_r8*tl_dltl)
1848 END DO
1849 END DO
1850 cff=1.0e-14_r8
1851 DO k=2,n(ng)-2
1852 DO i=istr,iend
1853 dltl=max(cff,wl(i,k ))
1854 tl_dltl=(0.5_r8-sign(0.5_r8,cff-wl(i,k )))* &
1855 & tl_wl(i,k )
1856 dltr=max(cff,wr(i,k+1))
1857 tl_dltr=(0.5_r8-sign(0.5_r8,cff-wr(i,k+1)))* &
1858 & tl_wr(i,k+1)
1859 br1(i,k)=br(i,k)
1860 bl1(i,k+1)=bl(i,k+1)
1861 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1862 tl_br(i,k)=(tl_dltr*br1(i,k )+dltr*tl_br(i,k )+ &
1863 & tl_dltl*bl1(i,k+1)+dltl*tl_bl(i,k+1))/ &
1864 & (dltr+dltl)- &
1865 & (tl_dltr+tl_dltl)*br(i,k)/(dltr+dltl)
1866 bl(i,k+1)=br(i,k)
1867 tl_bl(i,k+1)=tl_br(i,k)
1868 END DO
1869 END DO
1870 DO i=istr,iend
1871 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1872 tl_fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1873#if defined LINEAR_CONTINUATION
1874 bl(i,n(ng))=br(i,n(ng)-1)
1875 tl_bl(i,n(ng))=tl_br(i,n(ng)-1)
1876 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1877 tl_br(i,n(ng))=2.0_r8*tl_qc(i,n(ng))-tl_bl(i,n(ng))
1878#elif defined NEUMANN
1879 bl(i,n(ng))=br(i,n(ng)-1)
1880 tl_bl(i,n(ng))=tl_br(i,n(ng)-1)
1881 br(i,n(ng))=1.5_r8*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1882 tl_br(i,n(ng))=1.5_r8*tl_qc(i,n(ng))-0.5_r8*tl_bl(i,n(ng))
1883#else
1884 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1885 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1886 br(i,n(ng)-1)=qc(i,n(ng))
1887 tl_br(i,n(ng))=tl_qc(i,n(ng)) ! default strictly monotonic
1888 tl_bl(i,n(ng))=tl_qc(i,n(ng)) ! conditions
1889 tl_br(i,n(ng)-1)=tl_qc(i,n(ng))
1890#endif
1891#if defined LINEAR_CONTINUATION
1892 br(i,1)=bl(i,2)
1893 tl_br(i,1)=tl_bl(i,2)
1894 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1895 tl_bl(i,1)=2.0_r8*tl_qc(i,1)-tl_br(i,1)
1896#elif defined NEUMANN
1897 br(i,1)=bl(i,2)
1898 tl_br(i,1)=tl_bl(i,2)
1899 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1900 tl_bl(i,1)=1.5_r8*tl_qc(i,1)-0.5_r8*tl_br(i,1)
1901#else
1902 bl(i,2)=qc(i,1) ! bottom grid boxes are
1903 br(i,1)=qc(i,1) ! re-assumed to be
1904 bl(i,1)=qc(i,1) ! piecewise constant.
1905 tl_bl(i,2)=tl_qc(i,1) ! bottom grid boxes are
1906 tl_br(i,1)=tl_qc(i,1) ! re-assumed to be
1907 tl_bl(i,1)=tl_qc(i,1) ! piecewise constant.
1908#endif
1909 END DO
1910!
1911! Apply monotonicity constraint again, since the reconciled interfacial
1912! values may cause a non-monotonic behavior of the parabolic segments
1913! inside the grid box.
1914!
1915 DO k=1,n(ng)
1916 DO i=istr,iend
1917 dltr=br(i,k)-qc(i,k)
1918 tl_dltr=tl_br(i,k)-tl_qc(i,k)
1919 dltl=qc(i,k)-bl(i,k)
1920 tl_dltl=tl_qc(i,k)-tl_bl(i,k)
1921 cffr=2.0_r8*dltr
1922 tl_cffr=2.0_r8*tl_dltr
1923 cffl=2.0_r8*dltl
1924 tl_cffl=2.0_r8*tl_dltl
1925 IF ((dltr*dltl).lt.0.0_r8) THEN
1926 dltr=0.0_r8
1927 tl_dltr=0.0_r8
1928 dltl=0.0_r8
1929 tl_dltl=0.0_r8
1930 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1931 dltr=cffl
1932 tl_dltr=tl_cffl
1933 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1934 dltl=cffr
1935 tl_dltl=tl_cffr
1936 END IF
1937 br(i,k)=qc(i,k)+dltr
1938 tl_br(i,k)=tl_qc(i,k)+tl_dltr
1939 bl(i,k)=qc(i,k)-dltl
1940 tl_bl(i,k)=tl_qc(i,k)-tl_dltl
1941 END DO
1942 END DO
1943!
1944! After this moment reconstruction is considered complete. The next
1945! stage is to compute vertical advective fluxes, FC. It is expected
1946! that sinking may occurs relatively fast, the algorithm is designed
1947! to be free of CFL criterion, which is achieved by allowing
1948! integration bounds for semi-Lagrangian advective flux to use as
1949! many grid boxes in upstream direction as necessary.
1950!
1951! In the two code segments below, WL is the z-coordinate of the
1952! departure point for grid box interface z_w with the same indices;
1953! FC is the finite volume flux; ksource(:,k) is index of vertical
1954! grid box which contains the departure point (restricted by N(ng)).
1955! During the search: also add in content of whole grid boxes
1956! participating in FC.
1957!
1958 cff=dtdays*abs(wbio(isink))
1959 tl_cff=dtdays*sign(1.0_r8,wbio(isink))*tl_wbio(isink)
1960 DO k=1,n(ng)
1961 DO i=istr,iend
1962 fc(i,k-1)=0.0_r8
1963 tl_fc(i,k-1)=0.0_r8
1964 wl(i,k)=z_w(i,j,k-1)+cff
1965 tl_wl(i,k)=tl_z_w(i,j,k-1)+tl_cff
1966 wr(i,k)=hz(i,j,k)*qc(i,k)
1967 tl_wr(i,k)=tl_hz(i,j,k)*qc(i,k)+hz(i,j,k)*tl_qc(i,k)
1968 ksource(i,k)=k
1969 END DO
1970 END DO
1971 DO k=1,n(ng)
1972 DO ks=k,n(ng)-1
1973 DO i=istr,iend
1974 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1975 ksource(i,k)=ks+1
1976 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1977 tl_fc(i,k-1)=tl_fc(i,k-1)+tl_wr(i,ks)
1978 END IF
1979 END DO
1980 END DO
1981 END DO
1982!
1983! Finalize computation of flux: add fractional part.
1984!
1985 DO k=1,n(ng)
1986 DO i=istr,iend
1987 ks=ksource(i,k)
1988 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1989 tl_cu=(0.5_r8+sign(0.5_r8, &
1990 & (1.0_r8-(wl(i,k)-z_w(i,j,ks-1))* &
1991 & hz_inv(i,ks))))* &
1992 & ((tl_wl(i,k)-tl_z_w(i,j,ks-1))*hz_inv(i,ks)+ &
1993 & (wl(i,k)-z_w(i,j,ks-1))*tl_hz_inv(i,ks))
1994 fc(i,k-1)=fc(i,k-1)+ &
1995 & hz(i,j,ks)*cu* &
1996 & (bl(i,ks)+ &
1997 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1998 & (1.5_r8-cu)* &
1999 & (br(i,ks)+bl(i,ks)- &
2000 & 2.0_r8*qc(i,ks))))
2001 tl_fc(i,k-1)=tl_fc(i,k-1)+ &
2002 & (tl_hz(i,j,ks)*cu+hz(i,j,ks)*tl_cu)* &
2003 & (bl(i,ks)+ &
2004 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2005 & (1.5_r8-cu)* &
2006 & (br(i,ks)+bl(i,ks)- &
2007 & 2.0_r8*qc(i,ks))))+ &
2008 & hz(i,j,ks)*cu* &
2009 & (tl_bl(i,ks)+ &
2010 & tl_cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2011 & (1.5_r8-cu)* &
2012 & (br(i,ks)+bl(i,ks)- &
2013 & 2.0_r8*qc(i,ks)))+ &
2014 & cu*(0.5_r8*(tl_br(i,ks)-tl_bl(i,ks))+ &
2015 & tl_cu* &
2016 & (br(i,ks)+bl(i,ks)-2.0_r8*qc(i,ks))- &
2017 & (1.5_r8-cu)* &
2018 & (tl_br(i,ks)+tl_bl(i,ks)- &
2019 & 2.0_r8*tl_qc(i,ks))))
2020 END DO
2021 END DO
2022 DO k=1,n(ng)
2023 DO i=istr,iend
2024 bio(i,k,ibio)=qc(i,k)+(fc(i,k)-fc(i,k-1))*hz_inv(i,k)
2025 tl_bio(i,k,ibio)=tl_qc(i,k)+ &
2026 & (tl_fc(i,k)-tl_fc(i,k-1))*hz_inv(i,k)+ &
2027 & (fc(i,k)-fc(i,k-1))*tl_hz_inv(i,k)
2028 END DO
2029 END DO
2030
2031 END DO sink_loop
2032 END DO iter_loop
2033!
2034!-----------------------------------------------------------------------
2035! Update global tracer variables: Add increment due to BGC processes
2036! to tracer array in time index "nnew". Index "nnew" is solution after
2037! advection and mixing and has transport units (m Tunits) hence the
2038! increment is multiplied by Hz. Notice that we need to subtract
2039! original values "Bio_old" at the top of the routine to just account
2040! for the concentractions affected by BGC processes. This also takes
2041! into account any constraints (non-negative concentrations, carbon
2042! concentration range) specified before entering BGC kernel. If "Bio"
2043! were unchanged by BGC processes, the increment would be exactly
2044! zero. Notice that final tracer values, t(:,:,:,nnew,:) are not
2045! bounded >=0 so that we can preserve total inventory of nutrients
2046! when advection causes tracer concentration to go negative.
2047!-----------------------------------------------------------------------
2048!
2049 DO itrc=1,nbt
2050 ibio=idbio(itrc)
2051 DO k=1,n(ng)
2052 DO i=istr,iend
2053 cff=bio(i,k,ibio)-bio_old(i,k,ibio)
2054 tl_cff=tl_bio(i,k,ibio)-tl_bio_old(i,k,ibio)
2055!^ t(i,j,k,nnew,ibio)=t(i,j,k,nnew,ibio)+cff*Hz(i,j,k)
2056!^
2057 tl_t(i,j,k,nnew,ibio)=tl_t(i,j,k,nnew,ibio)+ &
2058 & tl_cff*hz(i,j,k)+cff*tl_hz(i,j,k)
2059 END DO
2060 END DO
2061 END DO
2062
2063 END DO j_loop
2064!
2065 RETURN

References mod_biology::attphy, mod_biology::attsw, mod_biology::bioiter, mod_scalars::cp, mod_biology::detrr, mod_scalars::dt, mod_biology::idbio, mod_biology::ino3_, mod_biology::iphyt, mod_biology::isdet, mod_biology::ivlev, mod_biology::izoop, mod_biology::k_no3, mod_param::n, mod_param::nbt, mod_biology::parfrac, mod_biology::phyis, mod_biology::phymrd, mod_biology::phymrn, mod_scalars::rho0, mod_scalars::sec2day, mod_biology::tl_parfrac, mod_biology::tl_wdet, mod_biology::tl_wphy, mod_biology::vm_no3, mod_biology::wdet, mod_biology::wphy, mod_biology::zooeed, mod_biology::zooeen, mod_biology::zoogr, mod_biology::zoomrd, and mod_biology::zoomrn.