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

Functions/Subroutines

subroutine, public rp_biology (ng, tile)
 
subroutine rp_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 rp_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 rp_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

◆ rp_biology()

subroutine public rp_biology_mod::rp_biology ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 31 of file rp_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(irpm)) THEN
55#else
56 IF (lbiofile(irpm).and.(tile.eq.0)) THEN
57#endif
58 lbiofile(irpm)=.false.
59 bioname(irpm)=myfile
60 END IF
61!
62#ifdef PROFILE
63 CALL wclock_on (ng, irpm, 15, __line__, myfile)
64#endif
65 CALL rp_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, irpm, 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::irpm
integer, parameter irpm
Definition mod_param.F:664
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
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::irpm, mod_param::n, mod_stepping::nnew, mod_stepping::nstp, mod_param::nt, mod_ocean::ocean, rp_npzd_franks_tile(), wclock_off(), and wclock_on().

Referenced by rp_main3d().

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

◆ rp_npzd_franks_tile()

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

Here is the caller graph for this function:

◆ rp_npzd_iron_tile()

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

◆ rp_npzd_powell_tile()

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