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

Functions/Subroutines

subroutine, public ad_biology (ng, tile)
 
subroutine ad_npzd_franks_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, ubt, imins, imaxs, jmins, jmaxs, nstp, nnew, rmask, hz, ad_hz, z_r, ad_z_r, z_w, ad_z_w, t, ad_t)
 
subroutine ad_npzd_iron_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, ubt, imins, imaxs, jmins, jmaxs, nstp, nnew, rmask, h, hz, ad_hz, z_r, ad_z_r, z_w, ad_z_w, srflx, ad_srflx, t, ad_t)
 
subroutine ad_npzd_powell_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, ubt, imins, imaxs, jmins, jmaxs, nstp, nnew, rmask, hz, ad_hz, z_r, ad_z_r, z_w, ad_z_w, srflx, ad_srflx, t, ad_t)
 

Function/Subroutine Documentation

◆ ad_biology()

subroutine public ad_biology_mod::ad_biology ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 31 of file ad_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(iadm)) THEN
55#else
56 IF (lbiofile(iadm).and.(tile.eq.0)) THEN
57#endif
58 lbiofile(iadm)=.false.
59 bioname(iadm)=myfile
60 END IF
61!
62#ifdef PROFILE
63 CALL wclock_on (ng, iadm, 15, __line__, myfile)
64#endif
65 CALL ad_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) % ad_Hz, &
74 & grid(ng) % z_r, &
75 & grid(ng) % ad_z_r, &
76 & grid(ng) % z_w, &
77 & grid(ng) % ad_z_w, &
78 & ocean(ng) % t, &
79 & ocean(ng) % ad_t)
80
81#ifdef PROFILE
82 CALL wclock_off (ng, iadm, 15, __line__, myfile)
83#endif
84 RETURN
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_ncparam
Definition mod_ncparam.F:2
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param
Definition mod_param.F:2
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::iadm
integer, parameter iadm
Definition mod_param.F:665
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 ad_npzd_franks_tile(), mod_grid::grid, mod_param::iadm, mod_param::n, mod_stepping::nnew, mod_stepping::nstp, mod_param::nt, mod_ocean::ocean, wclock_off(), and wclock_on().

Referenced by ad_main3d().

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

◆ ad_npzd_franks_tile()

subroutine ad_biology_mod::ad_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(inout) ad_hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(inout) ad_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(inout) ad_z_w,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) t,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) ad_t )
private

Definition at line 88 of file ad_npzd_Franks.h.

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

Referenced by ad_biology().

Here is the caller graph for this function:

◆ ad_npzd_iron_tile()

subroutine ad_biology_mod::ad_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(inout) ad_hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) ad_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(inout) ad_z_w,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) srflx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_srflx,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) t,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) ad_t )
private

Definition at line 96 of file ad_npzd_iron.h.

110!-----------------------------------------------------------------------
111!
112 USE mod_param
113 USE mod_biology
114 USE mod_ncparam
115 USE mod_scalars
116!
117! Imported variable declarations.
118!
119 integer, intent(in) :: ng, tile
120 integer, intent(in) :: LBi, UBi, LBj, UBj, UBk, UBt
121 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
122 integer, intent(in) :: nstp, nnew
123
124#ifdef ASSUMED_SHAPE
125# ifdef MASKING
126 real(r8), intent(in) :: rmask(LBi:,LBj:)
127# endif
128#if defined IRON_LIMIT && defined IRON_RELAX
129 real(r8), intent(in) :: h(LBi:,LBj:)
130# endif
131 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
132 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
133 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
134 real(r8), intent(in) :: srflx(LBi:,LBj:)
135 real(r8), intent(inout) :: t(LBi:,LBj:,:,:,:)
136
137 real(r8), intent(inout) :: ad_Hz(LBi:,LBj:,:)
138 real(r8), intent(in) :: ad_z_r(LBi:,LBj:,:)
139 real(r8), intent(inout) :: ad_z_w(LBi:,LBj:,0:)
140 real(r8), intent(inout) :: ad_srflx(LBi:,LBj:)
141 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
142#else
143# ifdef MASKING
144 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
145# endif
146#if defined IRON_LIMIT && defined IRON_RELAX
147 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
148# endif
149 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,UBk)
150 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,UBk)
151 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:UBk)
152 real(r8), intent(in) :: srflx(LBi:UBi,LBj:UBj)
153 real(r8), intent(inout) :: t(LBi:UBi,LBj:UBj,UBk,3,UBt)
154
155 real(r8), intent(inout) :: ad_Hz(LBi:UBi,LBj:UBj,UBk)
156 real(r8), intent(in) :: ad_z_r(LBi:UBi,LBj:UBj,UBk)
157 real(r8), intent(inout) :: ad_z_w(LBi:UBi,LBj:UBj,0:UBk)
158 real(r8), intent(inout) :: ad_srflx(LBi:UBi,LBj:UBj)
159 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,UBk,3,UBt)
160#endif
161!
162! Local variable declarations.
163!
164 integer, parameter :: Nsink = 2
165
166 integer :: Iter, i, ibio, isink, itime, itrc, iTrcMax, j, k, ks
167 integer :: Iteradj, kk
168
169 integer, dimension(Nsink) :: idsink
170
171 real(r8), parameter :: MinVal = 1.0e-6_r8
172
173 real(r8) :: Att, ExpAtt, Itop, PAR, PAR1
174 real(r8) :: ad_Att, ad_ExpAtt, ad_Itop, ad_PAR
175 real(r8) :: cff, cff1, cff2, cff3, cff4, cff5, cff6, dtdays
176 real(r8) :: ad_cff, ad_cff1, ad_cff4, ad_cff5, ad_cff6
177 real(r8) :: cffL, cffR, cu, dltL, dltR
178 real(r8) :: ad_cffL, ad_cffR, ad_cu, ad_dltL, ad_dltR
179 real(r8) :: fac, fac1, fac2
180 real(r8) :: ad_fac, ad_fac1, ad_fac2
181 real(r8) :: adfac, adfac1, adfac2, adfac3
182#ifdef IRON_LIMIT
183 real(r8) :: Nlimit, FNlim
184 real(r8) :: ad_Nlimit, ad_FNlim
185 real(r8) :: FNratio, FCratio, FCratioE, Flimit
186 real(r8) :: ad_FNratio, ad_FCratio, ad_FCratioE, ad_Flimit
187 real(r8) :: FeC2FeN, FeN2FeC
188# ifdef IRON_RELAX
189 real(r8) :: FeNudgCoef
190# endif
191#endif
192 real(r8), dimension(Nsink) :: Wbio
193 real(r8), dimension(Nsink) :: ad_Wbio
194
195 integer, dimension(IminS:ImaxS,N(ng)) :: ksource
196
197 real(r8), dimension(IminS:ImaxS) :: PARsur
198 real(r8), dimension(IminS:ImaxS) :: ad_PARsur
199
200 real(r8), dimension(NT(ng),2) :: BioTrc
201 real(r8), dimension(NT(ng),2) :: BioTrc1
202 real(r8), dimension(NT(ng),2) :: ad_BioTrc
203 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio
204 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio1
205 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio2
206 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio_old
207
208 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: ad_Bio
209 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: ad_Bio_old
210
211 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
212 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: ad_FC
213
214 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv
215 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv2
216 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv3
217 real(r8), dimension(IminS:ImaxS,N(ng)) :: Light
218 real(r8), dimension(IminS:ImaxS,N(ng)) :: WL
219 real(r8), dimension(IminS:ImaxS,N(ng)) :: WR
220 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL
221 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL1
222 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR
223 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR1
224 real(r8), dimension(IminS:ImaxS,N(ng)) :: qc
225
226 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Hz_inv
227 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Hz_inv2
228 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Hz_inv3
229 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Light
230 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_WL
231 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_WR
232 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_bL
233 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_bR
234 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_qc
235
236#include "set_bounds.h"
237!
238!-----------------------------------------------------------------------
239! Add biological Source/Sink terms.
240!-----------------------------------------------------------------------
241!
242! Avoid computing source/sink terms if no biological iterations.
243!
244 IF (bioiter(ng).le.0) RETURN
245!
246! Set time-stepping size (days) according to the number of iterations.
247!
248 dtdays=dt(ng)*sec2day/real(bioiter(ng),r8)
249
250#if defined IRON_LIMIT && defined IRON_RELAX
251!
252! Set nudging coefficient for dissolved iron over the shelf.
253!
254 fenudgcoef=dt(ng)/(fenudgtime(ng)*86400.0_r8)
255#endif
256#ifdef IRON_LIMIT
257!
258! Set Fe:N and Fe:C conversion ratio and its inverse.
259!
260 fen2fec=(16.0_r8/106.0_r8)*1.0e3_r8
261 fec2fen=(106.0_r8/16.0_r8)*1.0e-3_r8
262#endif
263!
264! Set vertical sinking indentification vector.
265!
266 idsink(1)=iphyt ! Phytoplankton
267 idsink(2)=isdet ! Small detritus
268!
269! Set vertical sinking velocity vector in the same order as the
270! identification vector, IDSINK.
271!
272 wbio(1)=wphy(ng) ! Phytoplankton
273 wbio(2)=wdet(ng) ! Small detritus
274!
275 ad_wbio(1)=0.0_r8
276 ad_wbio(2)=0.0_r8
277!
278 j_loop : DO j=jstr,jend
279!
280!-----------------------------------------------------------------------
281! Initialize adjoint private variables.
282!-----------------------------------------------------------------------
283!
284 ad_par=0.0_r8
285 ad_att=0.0_r8
286 ad_expatt=0.0_r8
287 ad_itop=0.0_r8
288 ad_dltl=0.0_r8
289 ad_dltr=0.0_r8
290 ad_cu=0.0_r8
291 ad_cff=0.0_r8
292 ad_cff1=0.0_r8
293 ad_cff4=0.0_r8
294 ad_cff5=0.0_r8
295 ad_cff6=0.0_r8
296 ad_fac=0.0_r8
297 ad_fac1=0.0_r8
298 ad_fac2=0.0_r8
299 ad_cffl=0.0_r8
300 ad_cffr=0.0_r8
301 adfac=0.0_r8
302 adfac1=0.0_r8
303 adfac2=0.0_r8
304 adfac3=0.0_r8
305#ifdef IRON_LIMIT
306 ad_fnratio=0.0_r8
307 ad_fcratio=0.0_r8
308 ad_fcratioe=0.0_r8
309 ad_flimit=0.0_r8
310 ad_fnlim=0.0_r8
311 ad_nlimit=0.0_r8
312#endif
313!
314 DO k=1,n(ng)
315 DO i=imins,imaxs
316 ad_hz_inv(i,k)=0.0_r8
317 ad_hz_inv2(i,k)=0.0_r8
318 ad_hz_inv3(i,k)=0.0_r8
319 ad_wl(i,k)=0.0_r8
320 ad_wr(i,k)=0.0_r8
321 ad_bl(i,k)=0.0_r8
322 ad_br(i,k)=0.0_r8
323 ad_qc(i,k)=0.0_r8
324 ad_light(i,k)=0.0_r8
325 END DO
326 END DO
327 DO itrc=1,nbt
328 ibio=idbio(itrc)
329 ad_biotrc(ibio,1)=0.0_r8
330 ad_biotrc(ibio,2)=0.0_r8
331 END DO
332 DO i=imins,imaxs
333 ad_parsur(i)=0.0_r8
334 END DO
335 DO k=0,n(ng)
336 DO i=imins,imaxs
337 ad_fc(i,k)=0.0_r8
338 END DO
339 END DO
340!
341! Clear ad_Bio and Bio arrays.
342!
343 DO itrc=1,nbt
344 ibio=idbio(itrc)
345 DO k=1,n(ng)
346 DO i=istr,iend
347 bio(i,k,ibio)=0.0_r8
348 bio1(i,k,ibio)=0.0_r8
349 bio2(i,k,ibio)=0.0_r8
350 ad_bio(i,k,ibio)=0.0_r8
351 ad_bio_old(i,k,ibio)=0.0_r8
352 END DO
353 END DO
354 END DO
355!
356! Compute inverse thickness to avoid repeated divisions.
357!
358 DO k=1,n(ng)
359 DO i=istr,iend
360 hz_inv(i,k)=1.0_r8/hz(i,j,k)
361 END DO
362 END DO
363 DO k=1,n(ng)-1
364 DO i=istr,iend
365 hz_inv2(i,k)=1.0_r8/(hz(i,j,k)+hz(i,j,k+1))
366 END DO
367 END DO
368 DO k=2,n(ng)-1
369 DO i=istr,iend
370 hz_inv3(i,k)=1.0_r8/(hz(i,j,k-1)+hz(i,j,k)+hz(i,j,k+1))
371 END DO
372 END DO
373!
374! Compute the required basic state arrays.
375!
376! Restrict biological tracer to be positive definite. If a negative
377! concentration is detected, nitrogen is drawn from the most abundant
378! pool to supplement the negative pools to a lower limit of MinVal
379! which is set to 1E-6 above.
380!
381 DO k=1,n(ng)
382 DO i=istr,iend
383!
384! At input, all tracers (index nnew) from predictor step have
385! transport units (m Tunits) since we do not have yet the new
386! values for zeta and Hz. These are known after the 2D barotropic
387! time-stepping.
388!
389! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
390! tracer times depth. However the basic state (nstp and nnew
391! indices) that is read from the forward file is in units of
392! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
393! use t instead of t*Hz_inv.
394!
395 DO itrc=1,nbt
396 ibio=idbio(itrc)
397!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
398!^
399 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
400!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
401!^
402 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
403 END DO
404!
405! Impose positive definite concentrations.
406!
407 cff2=0.0_r8
408 DO itime=1,2
409 cff1=0.0_r8
410 itrcmax=idbio(1)
411#ifdef IRON_LIMIT
412 DO itrc=1,nbt-2
413#else
414 DO itrc=1,nbt
415#endif
416 ibio=idbio(itrc)
417 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
418 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
419 itrcmax=ibio
420 END IF
421 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
422 END DO
423 IF (biotrc(itrcmax,itime).gt.cff1) THEN
424 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
425 END IF
426#ifdef IRON_LIMIT
427 DO itrc=nbt-1,nbt
428 ibio=idbio(itrc)
429 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
430 END DO
431#endif
432 END DO
433!
434! Load biological tracers into local arrays.
435!
436 DO itrc=1,nbt
437 ibio=idbio(itrc)
438 bio_old(i,k,ibio)=biotrc(ibio,nstp)
439 bio(i,k,ibio)=biotrc(ibio,nstp)
440 END DO
441
442#if defined IRON_LIMIT && defined IRON_RELAX
443!
444! Relax dissolved iron at coast (h <= FeHim) to a constant value
445! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
446! at the shelf.
447!
448 IF (h(i,j).le.fehmin(ng)) THEN
449 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
450 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
451 END IF
452#endif
453 END DO
454 END DO
455!
456! Calculate surface Photosynthetically Available Radiation (PAR). The
457! net shortwave radiation is scaled back to Watts/m2 and multiplied by
458! the fraction that is photosynthetically available, PARfrac.
459!
460 DO i=istr,iend
461#ifdef CONST_PAR
462!
463! Specify constant surface irradiance a la Powell and Spitz.
464!
465 parsur(i)=158.075_r8
466#else
467 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
468#endif
469 END DO
470!
471!=======================================================================
472! Start internal iterations to achieve convergence of the nonlinear
473! backward-implicit solution.
474!=======================================================================
475!
476! During the iterative procedure a series of fractional time steps are
477! performed in a chained mode (splitting by different biological
478! conversion processes) in sequence of the main food chain. In all
479! stages the concentration of the component being consumed is treated
480! in a fully implicit manner, so the algorithm guarantees non-negative
481! values, no matter how strong the concentration of active consuming
482! component (Phytoplankton or Zooplankton). The overall algorithm,
483! as well as any stage of it, is formulated in conservative form
484! (except explicit sinking) in sense that the sum of concentration of
485! all components is conserved.
486!
487! In the implicit algorithm, we have for example (N: nutrient,
488! P: phytoplankton),
489!
490! N(new) = N(old) - uptake * P(old) uptake = mu * N / (Kn + N)
491! {Michaelis-Menten}
492! below, we set
493! The N in the numerator of
494! cff = mu * P(old) / (Kn + N(old)) uptake is treated implicitly
495! as N(new)
496!
497! so the time-stepping of the equations becomes:
498!
499! N(new) = N(old) / (1 + cff) (1) when substracting a sink term,
500! consuming, divide by (1 + cff)
501! and
502!
503! P(new) = P(old) + cff * N(new) (2) when adding a source term,
504! growing, add (cff * source)
505!
506! Notice that if you substitute (1) in (2), you will get:
507!
508! P(new) = P(old) + cff * N(old) / (1 + cff) (3)
509!
510! If you add (1) and (3), you get
511!
512! N(new) + P(new) = N(old) + P(old)
513!
514! implying conservation regardless how "cff" is computed. Therefore,
515! this scheme is unconditionally stable regardless of the conversion
516! rate. It does not generate negative values since the constituent
517! to be consumed is always treated implicitly. It is also biased
518! toward damping oscillations.
519!
520! The iterative loop below is to iterate toward an universal Backward-
521! Euler treatment of all terms. So if there are oscillations in the
522! system, they are only physical oscillations. These iterations,
523! however, do not improve the accuaracy of the solution.
524!
525 iter_loop: DO iter=1,bioiter(ng)
526!
527! Compute light attenuation as function of depth.
528!
529 DO i=istr,iend
530 par=parsur(i)
531 IF (parsur(i).gt.0.0_r8) THEN ! day time
532 DO k=n(ng),1,-1
533!
534! Compute average light attenuation for each grid cell. Here, AttSW is
535! the light attenuation due to seawater and AttPhy is the attenuation
536! due to phytoplankton (self-shading coefficient).
537!
538 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
539 & (z_w(i,j,k)-z_w(i,j,k-1))
540 expatt=exp(-att)
541 itop=par
542 par=itop*(1.0_r8-expatt)/att ! average at cell center
543 light(i,k)=par
544!
545! Light attenuation at the bottom of the grid cell. It is the starting
546! PAR value for the next (deeper) vertical grid cell.
547!
548 par=itop*expatt
549 END DO
550 ELSE ! night time
551 DO k=1,n(ng)
552 light(i,k)=0.0_r8
553 END DO
554 END IF
555 END DO
556!
557! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
558! The Michaelis-Menten curve is used to describe the change in uptake
559! rate as a function of nitrate concentration. Here, PhyIS is the
560! initial slope of the P-I curve and K_NO3 is the half saturation of
561! phytoplankton nitrate uptake.
562#ifdef IRON_LIMIT
563!
564! Growth reduction factors due to iron limitation:
565!
566! FNratio current Fe:N ratio [umol-Fe/mmol-N]
567! FCratio current Fe:C ratio [umol-Fe/mol-C]
568! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
569! FCratioE empirical Fe:C ratio
570! Flimit Phytoplankton growth reduction factor due to Fe
571! limitation based on Fe:C ratio
572!
573#endif
574!
575 cff1=dtdays*vm_no3(ng)*phyis(ng)
576 cff2=vm_no3(ng)*vm_no3(ng)
577 cff3=phyis(ng)*phyis(ng)
578 DO k=1,n(ng)
579 DO i=istr,iend
580#ifdef IRON_LIMIT
581 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
582 fcratio=fnratio*fen2fec
583 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
584 flimit=fcratio*fcratio/ &
585 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
586
587 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
588 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
589#endif
590 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
591 cff=bio(i,k,iphyt)* &
592#ifdef IRON_LIMIT
593 & cff1*cff4*light(i,k)*fnlim*nlimit
594#else
595
596 & cff1*cff4*light(i,k)/ &
597 & (k_no3(ng)+bio(i,k,ino3_))
598#endif
599
600 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
601 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
602 & bio(i,k,ino3_)*cff
603#ifdef IRON_LIMIT
604!
605! Iron uptake proportional to growth.
606!
607 fac=cff*bio(i,k,ino3_)*fnratio/ &
608 & max(minval,bio(i,k,ifdis))
609 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
610 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
611 & bio(i,k,ifdis)*fac
612!
613! Iron uptake to reach appropriate Fe:C ratio.
614!
615 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
616 cff6=bio(i,k,iphyt)*cff5*fec2fen
617 IF (cff6.ge.0.0_r8) THEN
618 cff=cff6/max(minval,bio(i,k,ifdis))
619 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
620 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
621 & bio(i,k,ifdis)*cff
622 ELSE
623 cff=-cff6/max(minval,bio(i,k,ifphy))
624 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
625 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
626 & bio(i,k,ifphy)*cff
627 END IF
628#endif
629 END DO
630 END DO
631!
632! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
633! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
634! pool as function of "sloppy feeding" and metabolic processes
635! (ZooEEN and ZooEED fractions).
636#ifdef IRON_LIMIT
637! The lost of phytoplankton to the dissolve iron pool is scale by the
638! remineralization rate (FeRR).
639#endif
640!
641 cff1=dtdays*zoogr(ng)
642 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
643 DO k=1,n(ng)
644 DO i=istr,iend
645 cff=bio(i,k,izoop)* &
646 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
647 & bio(i,k,iphyt)
648 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
649 bio(i,k,izoop)=bio(i,k,izoop)+ &
650 & bio(i,k,iphyt)*cff2*cff
651 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
652 & bio(i,k,iphyt)*zooeen(ng)*cff
653 bio(i,k,isdet)=bio(i,k,isdet)+ &
654 & bio(i,k,iphyt)*zooeed(ng)*cff
655#ifdef IRON_LIMIT
656 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
657 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
658 & bio(i,k,ifphy)*cff*ferr(ng)
659#endif
660 END DO
661 END DO
662!
663! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
664! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
665!
666 cff3=dtdays*phymrd(ng)
667 cff2=dtdays*phymrn(ng)
668 cff1=1.0_r8/(1.0_r8+cff2+cff3)
669 DO k=1,n(ng)
670 DO i=istr,iend
671 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
672 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
673 & bio(i,k,iphyt)*cff2
674 bio(i,k,isdet)=bio(i,k,isdet)+ &
675 & bio(i,k,iphyt)*cff3
676#ifdef IRON_LIMIT
677 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
678 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
679 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
680#endif
681 END DO
682 END DO
683!
684! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
685! (ZooMRD rate).
686!
687 cff3=dtdays*zoomrd(ng)
688 cff2=dtdays*zoomrn(ng)
689 cff1=1.0_r8/(1.0_r8+cff2+cff3)
690 DO k=1,n(ng)
691 DO i=istr,iend
692 bio(i,k,izoop)=bio(i,k,izoop)*cff1
693 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
694 & bio(i,k,izoop)*cff2
695 bio(i,k,isdet)=bio(i,k,isdet)+ &
696 & bio(i,k,izoop)*cff3
697 END DO
698 END DO
699!
700! Detritus breakdown to nutrients: remineralization (DetRR rate).
701!
702 cff2=dtdays*detrr(ng)
703 cff1=1.0_r8/(1.0_r8+cff2)
704 DO k=1,n(ng)
705 DO i=istr,iend
706 bio(i,k,isdet)=bio(i,k,isdet)*cff1
707 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
708 & bio(i,k,isdet)*cff2
709 END DO
710 END DO
711!
712!-----------------------------------------------------------------------
713! Vertical sinking terms: Phytoplankton and Detritus
714!-----------------------------------------------------------------------
715!
716! Reconstruct vertical profile of selected biological constituents
717! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
718! grid box. Then, compute semi-Lagrangian flux due to sinking.
719!
720 sink_loop: DO isink=1,nsink
721 ibio=idsink(isink)
722!
723! Copy concentration of biological particulates into scratch array
724! "qc" (q-central, restrict it to be positive) which is hereafter
725! interpreted as a set of grid-box averaged values for biogeochemical
726! constituent concentration.
727!
728 DO k=1,n(ng)
729 DO i=istr,iend
730 qc(i,k)=bio(i,k,ibio)
731 END DO
732 END DO
733!
734 DO k=n(ng)-1,1,-1
735 DO i=istr,iend
736 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
737 END DO
738 END DO
739 DO k=2,n(ng)-1
740 DO i=istr,iend
741 dltr=hz(i,j,k)*fc(i,k)
742 dltl=hz(i,j,k)*fc(i,k-1)
743 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
744 cffr=cff*fc(i,k)
745 cffl=cff*fc(i,k-1)
746!
747! Apply PPM monotonicity constraint to prevent oscillations within the
748! grid box.
749!
750 IF ((dltr*dltl).le.0.0_r8) THEN
751 dltr=0.0_r8
752 dltl=0.0_r8
753 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
754 dltr=cffl
755 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
756 dltl=cffr
757 END IF
758!
759! Compute right and left side values (bR,bL) of parabolic segments
760! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
761!
762! NOTE: Although each parabolic segment is monotonic within its grid
763! box, monotonicity of the whole profile is not guaranteed,
764! because bL(k+1)-bR(k) may still have different sign than
765! qc(i,k+1)-qc(i,k). This possibility is excluded,
766! after bL and bR are reconciled using WENO procedure.
767!
768 cff=(dltr-dltl)*hz_inv3(i,k)
769 dltr=dltr-cff*hz(i,j,k+1)
770 dltl=dltl+cff*hz(i,j,k-1)
771 br(i,k)=qc(i,k)+dltr
772 bl(i,k)=qc(i,k)-dltl
773 wr(i,k)=(2.0_r8*dltr-dltl)**2
774 wl(i,k)=(dltr-2.0_r8*dltl)**2
775 END DO
776 END DO
777 cff=1.0e-14_r8
778 DO k=2,n(ng)-2
779 DO i=istr,iend
780 dltl=max(cff,wl(i,k ))
781 dltr=max(cff,wr(i,k+1))
782 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
783 bl(i,k+1)=br(i,k)
784 END DO
785 END DO
786 DO i=istr,iend
787 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
788#if defined LINEAR_CONTINUATION
789 bl(i,n(ng))=br(i,n(ng)-1)
790 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
791#elif defined NEUMANN
792 bl(i,n(ng))=br(i,n(ng)-1)
793 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
794#else
795 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
796 bl(i,n(ng))=qc(i,n(ng)) ! conditions
797 br(i,n(ng)-1)=qc(i,n(ng))
798#endif
799#if defined LINEAR_CONTINUATION
800 br(i,1)=bl(i,2)
801 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
802#elif defined NEUMANN
803 br(i,1)=bl(i,2)
804 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
805#else
806 bl(i,2)=qc(i,1) ! bottom grid boxes are
807 br(i,1)=qc(i,1) ! re-assumed to be
808 bl(i,1)=qc(i,1) ! piecewise constant.
809#endif
810 END DO
811!
812! Apply monotonicity constraint again, since the reconciled interfacial
813! values may cause a non-monotonic behavior of the parabolic segments
814! inside the grid box.
815!
816 DO k=1,n(ng)
817 DO i=istr,iend
818 dltr=br(i,k)-qc(i,k)
819 dltl=qc(i,k)-bl(i,k)
820 cffr=2.0_r8*dltr
821 cffl=2.0_r8*dltl
822 IF ((dltr*dltl).lt.0.0_r8) THEN
823 dltr=0.0_r8
824 dltl=0.0_r8
825 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
826 dltr=cffl
827 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
828 dltl=cffr
829 END IF
830 br(i,k)=qc(i,k)+dltr
831 bl(i,k)=qc(i,k)-dltl
832 END DO
833 END DO
834!
835! After this moment reconstruction is considered complete. The next
836! stage is to compute vertical advective fluxes, FC. It is expected
837! that sinking may occurs relatively fast, the algorithm is designed
838! to be free of CFL criterion, which is achieved by allowing
839! integration bounds for semi-Lagrangian advective flux to use as
840! many grid boxes in upstream direction as necessary.
841!
842! In the two code segments below, WL is the z-coordinate of the
843! departure point for grid box interface z_w with the same indices;
844! FC is the finite volume flux; ksource(:,k) is index of vertical
845! grid box which contains the departure point (restricted by N(ng)).
846! During the search: also add in content of whole grid boxes
847! participating in FC.
848!
849 cff=dtdays*abs(wbio(isink))
850 DO k=1,n(ng)
851 DO i=istr,iend
852 fc(i,k-1)=0.0_r8
853 wl(i,k)=z_w(i,j,k-1)+cff
854 wr(i,k)=hz(i,j,k)*qc(i,k)
855 ksource(i,k)=k
856 END DO
857 END DO
858 DO k=1,n(ng)
859 DO ks=k,n(ng)-1
860 DO i=istr,iend
861 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
862 ksource(i,k)=ks+1
863 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
864 END IF
865 END DO
866 END DO
867 END DO
868!
869! Finalize computation of flux: add fractional part.
870!
871 DO k=1,n(ng)
872 DO i=istr,iend
873 ks=ksource(i,k)
874 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
875 fc(i,k-1)=fc(i,k-1)+ &
876 & hz(i,j,ks)*cu* &
877 & (bl(i,ks)+ &
878 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
879 & (1.5_r8-cu)* &
880 & (br(i,ks)+bl(i,ks)- &
881 & 2.0_r8*qc(i,ks))))
882 END DO
883 END DO
884 DO k=1,n(ng)
885 DO i=istr,iend
886 bio(i,k,ibio)=qc(i,k)+(fc(i,k)-fc(i,k-1))*hz_inv(i,k)
887 END DO
888 END DO
889
890 END DO sink_loop
891 END DO iter_loop
892!
893!-----------------------------------------------------------------------
894! Update global tracer variables: Add increment due to BGC processes
895! to tracer array in time index "nnew". Index "nnew" is solution after
896! advection and mixing and has transport units (m Tunits) hence the
897! increment is multiplied by Hz. Notice that we need to subtract
898! original values "Bio_old" at the top of the routine to just account
899! for the concentractions affected by BGC processes. This also takes
900! into account any constraints (non-negative concentrations, carbon
901! concentration range) specified before entering BGC kernel. If "Bio"
902! were unchanged by BGC processes, the increment would be exactly
903! zero. Notice that final tracer values, t(:,:,:,nnew,:) are not
904! bounded >=0 so that we can preserve total inventory of nutrients
905! when advection causes tracer concentration to go negative.
906!-----------------------------------------------------------------------
907!
908 DO itrc=1,nbt
909 ibio=idbio(itrc)
910 DO k=1,n(ng)
911 DO i=istr,iend
912 cff=bio(i,k,ibio)-bio_old(i,k,ibio)
913!^ tl_t(i,j,k,nnew,ibio)=tl_t(i,j,k,nnew,ibio)+ &
914!^ & tl_cff*Hz(i,j,k)+cff*tl_Hz(i,j,k)
915!^
916 ad_hz(i,j,k)=ad_hz(i,j,k)+cff*ad_t(i,j,k,nnew,ibio)
917 ad_cff=ad_cff+hz(i,j,k)*ad_t(i,j,k,nnew,ibio)
918!^ tl_cff=tl_Bio(i,k,ibio)-tl_Bio_old(i,k,ibio)
919!^
920 ad_bio_old(i,k,ibio)=ad_bio_old(i,k,ibio)-ad_cff
921 ad_bio(i,k,ibio)=ad_bio(i,k,ibio)+ad_cff
922 ad_cff=0.0_r8
923 END DO
924 END DO
925 END DO
926!
927!=======================================================================
928! Start internal iterations to achieve convergence of the nonlinear
929! backward-implicit solution.
930!=======================================================================
931!
932 iter_loop1: DO iter=bioiter(ng),1,-1
933!
934!-----------------------------------------------------------------------
935! Adjoint vertical sinking terms.
936!-----------------------------------------------------------------------
937!
938! Reconstruct vertical profile of selected biological constituents
939! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
940! grid box. Then, compute semi-Lagrangian flux due to sinking.
941!
942! Compute appropriate basic state arrays III.
943!
944 DO k=1,n(ng)
945 DO i=istr,iend
946!
947! At input, all tracers (index nnew) from predictor step have
948! transport units (m Tunits) since we do not have yet the new
949! values for zeta and Hz. These are known after the 2D barotropic
950! time-stepping.
951!
952! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
953! tracer times depth. However the basic state (nstp and nnew
954! indices) that is read from the forward file is in units of
955! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
956! use t instead of t*Hz_inv.
957!
958 DO itrc=1,nbt
959 ibio=idbio(itrc)
960!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
961!^
962 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
963!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
964!^
965 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
966 END DO
967!
968! Impose positive definite concentrations.
969!
970 cff2=0.0_r8
971 DO itime=1,2
972 cff1=0.0_r8
973 itrcmax=idbio(1)
974#ifdef IRON_LIMIT
975 DO itrc=1,nbt-2
976#else
977 DO itrc=1,nbt
978#endif
979 ibio=idbio(itrc)
980 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
981 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
982 itrcmax=ibio
983 END IF
984 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
985 END DO
986 IF (biotrc(itrcmax,itime).gt.cff1) THEN
987 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
988 END IF
989#ifdef IRON_LIMIT
990 DO itrc=nbt-1,nbt
991 ibio=idbio(itrc)
992 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
993 END DO
994#endif
995 END DO
996!
997! Load biological tracers into local arrays.
998!
999 DO itrc=1,nbt
1000 ibio=idbio(itrc)
1001 bio_old(i,k,ibio)=biotrc(ibio,nstp)
1002 bio(i,k,ibio)=biotrc(ibio,nstp)
1003 END DO
1004
1005#if defined IRON_LIMIT && defined IRON_RELAX
1006!
1007! Relax dissolved iron at coast (h <= FeHim) to a constant value
1008! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
1009! at the shelf.
1010!
1011 IF (h(i,j).le.fehmin(ng)) THEN
1012 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1013 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
1014 END IF
1015#endif
1016 END DO
1017 END DO
1018!
1019! Calculate surface Photosynthetically Available Radiation (PAR). The
1020! net shortwave radiation is scaled back to Watts/m2 and multiplied by
1021! the fraction that is photosynthetically available, PARfrac.
1022!
1023 DO i=istr,iend
1024#ifdef CONST_PAR
1025!
1026! Specify constant surface irradiance a la Powell and Spitz.
1027!
1028 parsur(i)=158.075_r8
1029#else
1030 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
1031#endif
1032 END DO
1033!
1034!=======================================================================
1035! Start internal iterations to achieve convergence of the nonlinear
1036! backward-implicit solution.
1037!=======================================================================
1038!
1039 DO iteradj=1,iter
1040!
1041! Compute light attenuation as function of depth.
1042!
1043 DO i=istr,iend
1044 par=parsur(i)
1045 IF (parsur(i).gt.0.0_r8) THEN ! day time
1046 DO k=n(ng),1,-1
1047!
1048! Compute average light attenuation for each grid cell. Here, AttSW is
1049! the light attenuation due to seawater and AttPhy is the attenuation
1050! due to phytoplankton (self-shading coefficient).
1051!
1052 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
1053 & (z_w(i,j,k)-z_w(i,j,k-1))
1054 expatt=exp(-att)
1055 itop=par
1056 par=itop*(1.0_r8-expatt)/att ! average at cell center
1057 light(i,k)=par
1058!
1059! Light attenuation at the bottom of the grid cell. It is the starting
1060! PAR value for the next (deeper) vertical grid cell.
1061!
1062 par=itop*expatt
1063 END DO
1064 ELSE ! night time
1065 DO k=1,n(ng)
1066 light(i,k)=0.0_r8
1067 END DO
1068 END IF
1069 END DO
1070!
1071! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
1072! The Michaelis-Menten curve is used to describe the change in uptake
1073! rate as a function of nitrate concentration. Here, PhyIS is the
1074! initial slope of the P-I curve and K_NO3 is the half saturation of
1075! phytoplankton nitrate uptake.
1076#ifdef IRON_LIMIT
1077!
1078! Growth reduction factors due to iron limitation:
1079!
1080! FNratio current Fe:N ratio [umol-Fe/mmol-N]
1081! FCratio current Fe:C ratio [umol-Fe/mol-C]
1082! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
1083! FCratioE empirical Fe:C ratio
1084! Flimit Phytoplankton growth reduction factor due to Fe
1085! limitation based on Fe:C ratio
1086!
1087#endif
1088!
1089 cff1=dtdays*vm_no3(ng)*phyis(ng)
1090 cff2=vm_no3(ng)*vm_no3(ng)
1091 cff3=phyis(ng)*phyis(ng)
1092 DO k=1,n(ng)
1093 DO i=istr,iend
1094#ifdef IRON_LIMIT
1095!
1096! Calculate growth reduction factor due to iron limitation.
1097!
1098 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
1099 fcratio=fnratio*fen2fec
1100 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
1101 flimit=fcratio*fcratio/ &
1102 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
1103
1104 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
1105 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
1106#endif
1107 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
1108 cff=bio(i,k,iphyt)* &
1109#ifdef IRON_LIMIT
1110 & cff1*cff4*light(i,k)*fnlim*nlimit
1111#else
1112 & cff1*cff4*light(i,k)/ &
1113 & (k_no3(ng)+bio(i,k,ino3_))
1114#endif
1115 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
1116 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
1117 & bio(i,k,ino3_)*cff
1118#ifdef IRON_LIMIT
1119!
1120! Iron uptake proportional to growth.
1121!
1122 fac=cff*bio(i,k,ino3_)*fnratio/ &
1123 & max(minval,bio(i,k,ifdis))
1124 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
1125 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
1126 & bio(i,k,ifdis)*fac
1127
1128
1129! Iron Uptake proportional to growth
1130 cff=cff*bio(i,k,ino3_)* &
1131 & fnratio/max(minval,bio(i,k,ifdis))
1132 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
1133 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
1134 & bio(i,k,ifdis)*cff
1135!
1136! Iron uptake to reach appropriate Fe:C ratio.
1137!
1138 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
1139 cff6=bio(i,k,iphyt)*cff5*fec2fen
1140 IF (cff6.ge.0.0_r8) THEN
1141 cff=cff6/max(minval,bio(i,k,ifdis))
1142 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
1143 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
1144 & bio(i,k,ifdis)*cff
1145 ELSE
1146 cff=-cff6/max(minval,bio(i,k,ifphy))
1147 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
1148 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1149 & bio(i,k,ifphy)*cff
1150 END IF
1151#endif
1152 END DO
1153 END DO
1154!
1155! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
1156! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
1157! pool as function of "sloppy feeding" and metabolic processes
1158! (ZooEEN and ZooEED fractions).
1159#ifdef IRON_LIMIT
1160! The lost of phytoplankton to the dissolve iron pool is scale by the
1161! remineralization rate (FeRR).
1162#endif
1163!
1164 cff1=dtdays*zoogr(ng)
1165 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
1166 DO k=1,n(ng)
1167 DO i=istr,iend
1168 cff=bio(i,k,izoop)* &
1169 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
1170 & bio(i,k,iphyt)
1171 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
1172 bio(i,k,izoop)=bio(i,k,izoop)+ &
1173 & bio(i,k,iphyt)*cff2*cff
1174 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1175 & bio(i,k,iphyt)*zooeen(ng)*cff
1176 bio(i,k,isdet)=bio(i,k,isdet)+ &
1177 & bio(i,k,iphyt)*zooeed(ng)*cff
1178#ifdef IRON_LIMIT
1179 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
1180 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1181 & bio(i,k,ifphy)*cff*ferr(ng)
1182#endif
1183 END DO
1184 END DO
1185!
1186! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
1187! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
1188!
1189 cff3=dtdays*phymrd(ng)
1190 cff2=dtdays*phymrn(ng)
1191 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1192 DO k=1,n(ng)
1193 DO i=istr,iend
1194 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
1195 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1196 & bio(i,k,iphyt)*cff2
1197 bio(i,k,isdet)=bio(i,k,isdet)+ &
1198 & bio(i,k,iphyt)*cff3
1199#ifdef IRON_LIMIT
1200 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
1201 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
1202 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
1203#endif
1204 END DO
1205 END DO
1206!
1207! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
1208! (ZooMRD rate).
1209!
1210 cff3=dtdays*zoomrd(ng)
1211 cff2=dtdays*zoomrn(ng)
1212 cff1=1.0_r8/(1.0_r8+cff2+cff3)
1213 DO k=1,n(ng)
1214 DO i=istr,iend
1215 bio(i,k,izoop)=bio(i,k,izoop)*cff1
1216 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1217 & bio(i,k,izoop)*cff2
1218 bio(i,k,isdet)=bio(i,k,isdet)+ &
1219 & bio(i,k,izoop)*cff3
1220 END DO
1221 END DO
1222!
1223! Detritus breakdown to nutrients: remineralization (DetRR rate).
1224!
1225 cff2=dtdays*detrr(ng)
1226 cff1=1.0_r8/(1.0_r8+cff2)
1227 DO k=1,n(ng)
1228 DO i=istr,iend
1229 bio(i,k,isdet)=bio(i,k,isdet)*cff1
1230 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
1231 & bio(i,k,isdet)*cff2
1232 END DO
1233 END DO
1234!
1235 IF (iteradj.ne.iter) THEN
1236!
1237!-----------------------------------------------------------------------
1238! Vertical sinking terms: Phytoplankton and Detritus
1239!-----------------------------------------------------------------------
1240!
1241! Reconstruct vertical profile of selected biological constituents
1242! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1243! grid box. Then, compute semi-Lagrangian flux due to sinking.
1244!
1245 DO isink=1,nsink
1246 ibio=idsink(isink)
1247!
1248! Copy concentration of biological particulates into scratch array
1249! "qc" (q-central, restrict it to be positive) which is hereafter
1250! interpreted as a set of grid-box averaged values for biogeochemical
1251! constituent concentration.
1252!
1253 DO k=1,n(ng)
1254 DO i=istr,iend
1255 qc(i,k)=bio(i,k,ibio)
1256 END DO
1257 END DO
1258!
1259 DO k=n(ng)-1,1,-1
1260 DO i=istr,iend
1261 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1262 END DO
1263 END DO
1264 DO k=2,n(ng)-1
1265 DO i=istr,iend
1266 dltr=hz(i,j,k)*fc(i,k)
1267 dltl=hz(i,j,k)*fc(i,k-1)
1268 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1269 cffr=cff*fc(i,k)
1270 cffl=cff*fc(i,k-1)
1271!
1272! Apply PPM monotonicity constraint to prevent oscillations within the
1273! grid box.
1274!
1275 IF ((dltr*dltl).le.0.0_r8) THEN
1276 dltr=0.0_r8
1277 dltl=0.0_r8
1278 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1279 dltr=cffl
1280 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1281 dltl=cffr
1282 END IF
1283!
1284! Compute right and left side values (bR,bL) of parabolic segments
1285! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1286!
1287! NOTE: Although each parabolic segment is monotonic within its grid
1288! box, monotonicity of the whole profile is not guaranteed,
1289! because bL(k+1)-bR(k) may still have different sign than
1290! qc(i,k+1)-qc(i,k). This possibility is excluded,
1291! after bL and bR are reconciled using WENO procedure.
1292!
1293 cff=(dltr-dltl)*hz_inv3(i,k)
1294 dltr=dltr-cff*hz(i,j,k+1)
1295 dltl=dltl+cff*hz(i,j,k-1)
1296 br(i,k)=qc(i,k)+dltr
1297 bl(i,k)=qc(i,k)-dltl
1298 wr(i,k)=(2.0_r8*dltr-dltl)**2
1299 wl(i,k)=(dltr-2.0_r8*dltl)**2
1300 END DO
1301 END DO
1302 cff=1.0e-14_r8
1303 DO k=2,n(ng)-2
1304 DO i=istr,iend
1305 dltl=max(cff,wl(i,k ))
1306 dltr=max(cff,wr(i,k+1))
1307 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1308 bl(i,k+1)=br(i,k)
1309 END DO
1310 END DO
1311 DO i=istr,iend
1312 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1313#if defined LINEAR_CONTINUATION
1314 bl(i,n(ng))=br(i,n(ng)-1)
1315 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1316#elif defined NEUMANN
1317 bl(i,n(ng))=br(i,n(ng)-1)
1318 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1319#else
1320 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1321 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1322 br(i,n(ng)-1)=qc(i,n(ng))
1323#endif
1324#if defined LINEAR_CONTINUATION
1325 br(i,1)=bl(i,2)
1326 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1327#elif defined NEUMANN
1328 br(i,1)=bl(i,2)
1329 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1330#else
1331 bl(i,2)=qc(i,1) ! bottom grid boxes are
1332 br(i,1)=qc(i,1) ! re-assumed to be
1333 bl(i,1)=qc(i,1) ! piecewise constant.
1334#endif
1335 END DO
1336!
1337! Apply monotonicity constraint again, since the reconciled interfacial
1338! values may cause a non-monotonic behavior of the parabolic segments
1339! inside the grid box.
1340!
1341 DO k=1,n(ng)
1342 DO i=istr,iend
1343 dltr=br(i,k)-qc(i,k)
1344 dltl=qc(i,k)-bl(i,k)
1345 cffr=2.0_r8*dltr
1346 cffl=2.0_r8*dltl
1347 IF ((dltr*dltl).lt.0.0_r8) THEN
1348 dltr=0.0_r8
1349 dltl=0.0_r8
1350 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1351 dltr=cffl
1352 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1353 dltl=cffr
1354 END IF
1355 br(i,k)=qc(i,k)+dltr
1356 bl(i,k)=qc(i,k)-dltl
1357 END DO
1358 END DO
1359!
1360! After this moment reconstruction is considered complete. The next
1361! stage is to compute vertical advective fluxes, FC. It is expected
1362! that sinking may occurs relatively fast, the algorithm is designed
1363! to be free of CFL criterion, which is achieved by allowing
1364! integration bounds for semi-Lagrangian advective flux to use as
1365! many grid boxes in upstream direction as necessary.
1366!
1367! In the two code segments below, WL is the z-coordinate of the
1368! departure point for grid box interface z_w with the same indices;
1369! FC is the finite volume flux; ksource(:,k) is index of vertical
1370! grid box which contains the departure point (restricted by N(ng)).
1371! During the search: also add in content of whole grid boxes
1372! participating in FC.
1373!
1374 cff=dtdays*abs(wbio(isink))
1375 DO k=1,n(ng)
1376 DO i=istr,iend
1377 fc(i,k-1)=0.0_r8
1378 wl(i,k)=z_w(i,j,k-1)+cff
1379 wr(i,k)=hz(i,j,k)*qc(i,k)
1380 ksource(i,k)=k
1381 END DO
1382 END DO
1383 DO k=1,n(ng)
1384 DO ks=k,n(ng)-1
1385 DO i=istr,iend
1386 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1387 ksource(i,k)=ks+1
1388 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1389 END IF
1390 END DO
1391 END DO
1392 END DO
1393!
1394! Finalize computation of flux: add fractional part.
1395!
1396 DO k=1,n(ng)
1397 DO i=istr,iend
1398 ks=ksource(i,k)
1399 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1400 fc(i,k-1)=fc(i,k-1)+ &
1401 & hz(i,j,ks)*cu* &
1402 & (bl(i,ks)+ &
1403 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1404 & (1.5_r8-cu)* &
1405 & (br(i,ks)+bl(i,ks)- &
1406 & 2.0_r8*qc(i,ks))))
1407 END DO
1408 END DO
1409 DO k=1,n(ng)
1410 DO i=istr,iend
1411 bio(i,k,ibio)=qc(i,k)+ &
1412 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1413 END DO
1414 END DO
1415 END DO
1416 END IF
1417 END DO
1418!
1419! End of compute basic state arrays III.
1420!
1421 sink_loop1: DO isink=1,nsink
1422 ibio=idsink(isink)
1423
1424!
1425! Compute required flux arrays.
1426!
1427! Copy concentration of biological particulates into scratch array
1428! "qc" (q-central, restrict it to be positive) which is hereafter
1429! interpreted as a set of grid-box averaged values for biogeochemical
1430! constituent concentration.
1431!
1432 DO k=1,n(ng)
1433 DO i=istr,iend
1434 qc(i,k)=bio(i,k,ibio)
1435 END DO
1436 END DO
1437!
1438 DO k=n(ng)-1,1,-1
1439 DO i=istr,iend
1440 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1441 END DO
1442 END DO
1443 DO k=2,n(ng)-1
1444 DO i=istr,iend
1445 dltr=hz(i,j,k)*fc(i,k)
1446 dltl=hz(i,j,k)*fc(i,k-1)
1447 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1448 cffr=cff*fc(i,k)
1449 cffl=cff*fc(i,k-1)
1450!
1451! Apply PPM monotonicity constraint to prevent oscillations within the
1452! grid box.
1453!
1454 IF ((dltr*dltl).le.0.0_r8) THEN
1455 dltr=0.0_r8
1456 dltl=0.0_r8
1457 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1458 dltr=cffl
1459 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1460 dltl=cffr
1461 END IF
1462!
1463! Compute right and left side values (bR,bL) of parabolic segments
1464! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1465!
1466! NOTE: Although each parabolic segment is monotonic within its grid
1467! box, monotonicity of the whole profile is not guaranteed,
1468! because bL(k+1)-bR(k) may still have different sign than
1469! qc(i,k+1)-qc(i,k). This possibility is excluded,
1470! after bL and bR are reconciled using WENO procedure.
1471!
1472 cff=(dltr-dltl)*hz_inv3(i,k)
1473 dltr=dltr-cff*hz(i,j,k+1)
1474 dltl=dltl+cff*hz(i,j,k-1)
1475 br(i,k)=qc(i,k)+dltr
1476 bl(i,k)=qc(i,k)-dltl
1477 wr(i,k)=(2.0_r8*dltr-dltl)**2
1478 wl(i,k)=(dltr-2.0_r8*dltl)**2
1479 END DO
1480 END DO
1481 cff=1.0e-14_r8
1482 DO k=2,n(ng)-2
1483 DO i=istr,iend
1484 dltl=max(cff,wl(i,k ))
1485 dltr=max(cff,wr(i,k+1))
1486 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1487 bl(i,k+1)=br(i,k)
1488 END DO
1489 END DO
1490 DO i=istr,iend
1491 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1492#if defined LINEAR_CONTINUATION
1493 bl(i,n(ng))=br(i,n(ng)-1)
1494 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1495#elif defined NEUMANN
1496 bl(i,n(ng))=br(i,n(ng)-1)
1497 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1498#else
1499 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1500 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1501 br(i,n(ng)-1)=qc(i,n(ng))
1502#endif
1503#if defined LINEAR_CONTINUATION
1504 br(i,1)=bl(i,2)
1505 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1506#elif defined NEUMANN
1507 br(i,1)=bl(i,2)
1508 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1509#else
1510 bl(i,2)=qc(i,1) ! bottom grid boxes are
1511 br(i,1)=qc(i,1) ! re-assumed to be
1512 bl(i,1)=qc(i,1) ! piecewise constant.
1513#endif
1514 END DO
1515!
1516! Apply monotonicity constraint again, since the reconciled interfacial
1517! values may cause a non-monotonic behavior of the parabolic segments
1518! inside the grid box.
1519!
1520 DO k=1,n(ng)
1521 DO i=istr,iend
1522 dltr=br(i,k)-qc(i,k)
1523 dltl=qc(i,k)-bl(i,k)
1524 cffr=2.0_r8*dltr
1525 cffl=2.0_r8*dltl
1526 IF ((dltr*dltl).lt.0.0_r8) THEN
1527 dltr=0.0_r8
1528 dltl=0.0_r8
1529 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1530 dltr=cffl
1531 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1532 dltl=cffr
1533 END IF
1534 br(i,k)=qc(i,k)+dltr
1535 bl(i,k)=qc(i,k)-dltl
1536 END DO
1537 END DO
1538!
1539! After this moment reconstruction is considered complete. The next
1540! stage is to compute vertical advective fluxes, FC. It is expected
1541! that sinking may occurs relatively fast, the algorithm is designed
1542! to be free of CFL criterion, which is achieved by allowing
1543! integration bounds for semi-Lagrangian advective flux to use as
1544! many grid boxes in upstream direction as necessary.
1545!
1546! In the two code segments below, WL is the z-coordinate of the
1547! departure point for grid box interface z_w with the same indices;
1548! FC is the finite volume flux; ksource(:,k) is index of vertical
1549! grid box which contains the departure point (restricted by N(ng)).
1550! During the search: also add in content of whole grid boxes
1551! participating in FC.
1552!
1553 cff=dtdays*abs(wbio(isink))
1554 DO k=1,n(ng)
1555 DO i=istr,iend
1556 fc(i,k-1)=0.0_r8
1557 wl(i,k)=z_w(i,j,k-1)+cff
1558 wr(i,k)=hz(i,j,k)*qc(i,k)
1559 ksource(i,k)=k
1560 END DO
1561 END DO
1562 DO k=1,n(ng)
1563 DO ks=k,n(ng)-1
1564 DO i=istr,iend
1565 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1566 ksource(i,k)=ks+1
1567 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1568 END IF
1569 END DO
1570 END DO
1571 END DO
1572!
1573! Finalize computation of flux: add fractional part.
1574!
1575 DO k=1,n(ng)
1576 DO i=istr,iend
1577 ks=ksource(i,k)
1578 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1579 fc(i,k-1)=fc(i,k-1)+ &
1580 & hz(i,j,ks)*cu* &
1581 & (bl(i,ks)+ &
1582 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1583 & (1.5_r8-cu)* &
1584 & (br(i,ks)+bl(i,ks)- &
1585 & 2.0_r8*qc(i,ks))))
1586 END DO
1587 END DO
1588 DO k=1,n(ng)
1589 DO i=istr,iend
1590!^ tl_Bio(i,k,ibio)=tl_qc(i,k)+ &
1591!^ & (tl_FC(i,k)-tl_FC(i,k-1))*Hz_inv(i,k)+ &
1592!^ & (FC(i,k)-FC(i,k-1))*tl_Hz_inv(i,k)
1593!^
1594 ad_qc(i,k)=ad_qc(i,k)+ad_bio(i,k,ibio)
1595 ad_fc(i,k)=ad_fc(i,k)+hz_inv(i,k)*ad_bio(i,k,ibio)
1596 ad_fc(i,k-1)=ad_fc(i,k-1)-hz_inv(i,k)*ad_bio(i,k,ibio)
1597 ad_hz_inv(i,k)=ad_hz_inv(i,k)+ &
1598 & (fc(i,k)-fc(i,k-1))*ad_bio(i,k,ibio)
1599 ad_bio(i,k,ibio)=0.0_r8
1600 END DO
1601 END DO
1602!
1603! Adjoint of final computation of flux: add fractional part.
1604!
1605 DO k=1,n(ng)
1606 DO i=istr,iend
1607 ks=ksource(i,k)
1608 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1609!^ tl_FC(i,k-1)=tl_FC(i,k-1)+ &
1610!^ & (tl_Hz(i,j,ks)*cu+Hz(i,j,ks)*tl_cu)* &
1611!^ & (bL(i,ks)+ &
1612!^ & cu*(0.5_r8*(bR(i,ks)-bL(i,ks))- &
1613!^ & (1.5_r8-cu)* &
1614!^ & (bR(i,ks)+bL(i,ks)- &
1615!^ & 2.0_r8*qc(i,ks))))+ &
1616!^ & Hz(i,j,ks)*cu* &
1617!^ & (tl_bL(i,ks)+ &
1618!^ & tl_cu*(0.5_r8*(bR(i,ks)-bL(i,ks))- &
1619!^ & (1.5_r8-cu)* &
1620!^ & (bR(i,ks)+bL(i,ks)- &
1621!^ & 2.0_r8*qc(i,ks)))+ &
1622!^ & cu*(0.5_r8*(tl_bR(i,ks)-tl_bL(i,ks))+ &
1623!^ & tl_cu* &
1624!^ & (bR(i,ks)+bL(i,ks)-2.0_r8*qc(i,ks))- &
1625!^ & (1.5_r8-cu)* &
1626!^ & (tl_bR(i,ks)+tl_bL(i,ks)- &
1627!^ & 2.0_r8*tl_qc(i,ks))))
1628!^
1629 adfac=(bl(i,ks)+ &
1630 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1631 & (1.5_r8-cu)* &
1632 & (br(i,ks)+bl(i,ks)- &
1633 & 2.0_r8*qc(i,ks))))*ad_fc(i,k-1)
1634 adfac1=hz(i,j,ks)*cu*ad_fc(i,k-1)
1635 adfac2=adfac1*cu
1636 adfac3=adfac2*(1.5_r8-cu)
1637 ad_hz(i,j,ks)=ad_hz(i,j,ks)+cu*adfac
1638 ad_cu=ad_cu+hz(i,j,ks)*adfac
1639 ad_bl(i,ks)=ad_bl(i,ks)+adfac1
1640 ad_cu=ad_cu+ &
1641 & adfac1*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1642 & (1.5_r8-cu)* &
1643 & (br(i,ks)+bl(i,ks)- &
1644 & 2.0_r8*qc(i,ks)))+ &
1645 & adfac2*(br(i,ks)+bl(i,ks)-2.0_r8*qc(i,ks))
1646 ad_br(i,ks)=ad_br(i,ks)+0.5_r8*adfac2-adfac3
1647 ad_bl(i,ks)=ad_bl(i,ks)-0.5_r8*adfac2-adfac3
1648 ad_qc(i,ks)=ad_qc(i,ks)+2.0_r8*adfac3
1649!^ tl_cu=(0.5_r8+SIGN(0.5_r8, &
1650!^ & (1.0_r8-(WL(i,k)-z_w(i,j,ks-1))* &
1651!^ & Hz_inv(i,ks))))* &
1652!^ & ((tl_WL(i,k)-tl_z_w(i,j,ks-1))*Hz_inv(i,ks)+ &
1653!^ & (WL(i,k)-z_w(i,j,ks-1))*tl_Hz_inv(i,ks))
1654!^
1655 adfac=(0.5_r8+sign(0.5_r8, &
1656 & (1.0_r8-(wl(i,k)-z_w(i,j,ks-1))* &
1657 & hz_inv(i,ks))))*ad_cu
1658 adfac1=adfac*hz_inv(i,ks)
1659 ad_wl(i,k)=ad_wl(i,k)+adfac1
1660 ad_z_w(i,j,ks-1)=ad_z_w(i,j,ks-1)-adfac1
1661 ad_hz_inv(i,ks)=ad_hz_inv(i,ks)+ &
1662 & (wl(i,k)-z_w(i,j,ks-1))*adfac
1663 ad_cu=0.0_r8
1664 END DO
1665 END DO
1666!
1667! After this moment reconstruction is considered complete. The next
1668! stage is to compute vertical advective fluxes, FC. It is expected
1669! that sinking may occurs relatively fast, the algorithm is designed
1670! to be free of CFL criterion, which is achieved by allowing
1671! integration bounds for semi-Lagrangian advective flux to use as
1672! many grid boxes in upstream direction as necessary.
1673!
1674! In the two code segments below, WL is the z-coordinate of the
1675! departure point for grid box interface z_w with the same indices;
1676! FC is the finite volume flux; ksource(:,k) is index of vertical
1677! grid box which contains the departure point (restricted by N(ng)).
1678! During the search: also add in content of whole grid boxes
1679! participating in FC.
1680!
1681 cff=dtdays*abs(wbio(isink))
1682 DO k=1,n(ng)
1683 DO ks=k,n(ng)-1
1684 DO i=istr,iend
1685 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1686!^ tl_FC(i,k-1)=tl_FC(i,k-1)+tl_WR(i,ks)
1687!^
1688 ad_wr(i,ks)=ad_wr(i,ks)+ad_fc(i,k-1)
1689 END IF
1690 END DO
1691 END DO
1692 END DO
1693 DO k=1,n(ng)
1694 DO i=istr,iend
1695!^ tl_WR(i,k)=tl_Hz(i,j,k)*qc(i,k)+Hz(i,j,k)*tl_qc(i,k)
1696!^
1697 ad_hz(i,j,k)=ad_hz(i,j,k)+qc(i,k)*ad_wr(i,k)
1698 ad_qc(i,k)=ad_qc(i,k)+hz(i,j,k)*ad_wr(i,k)
1699 ad_wr(i,k)=0.0_r8
1700!^ tl_WL(i,k)=tl_z_w(i,j,k-1)+tl_cff
1701!^
1702 ad_z_w(i,j,k-1)=ad_z_w(i,j,k-1)+ad_wl(i,k)
1703 ad_cff=ad_cff+ad_wl(i,k)
1704 ad_wl(i,k)=0.0_r8
1705!^ tl_FC(i,k-1)=0.0_r8
1706!^
1707 ad_fc(i,k-1)=0.0_r8
1708 END DO
1709 END DO
1710!^ tl_cff=dtdays*SIGN(1.0_r8,Wbio(isink))*tl_Wbio(isink)
1711!^
1712 ad_wbio(isink)=ad_wbio(isink)+ &
1713 & dtdays*sign(1.0_r8,wbio(isink))*ad_cff
1714 ad_cff=0.0_r8
1715!
1716! Compute appropriate values of bR and bL.
1717!
1718! Copy concentration of biological particulates into scratch array
1719! "qc" (q-central, restrict it to be positive) which is hereafter
1720! interpreted as a set of grid-box averaged values for biogeochemical
1721! constituent concentration.
1722!
1723 DO k=1,n(ng)
1724 DO i=istr,iend
1725 qc(i,k)=bio(i,k,ibio)
1726 END DO
1727 END DO
1728!
1729 DO k=n(ng)-1,1,-1
1730 DO i=istr,iend
1731 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1732 END DO
1733 END DO
1734 DO k=2,n(ng)-1
1735 DO i=istr,iend
1736 dltr=hz(i,j,k)*fc(i,k)
1737 dltl=hz(i,j,k)*fc(i,k-1)
1738 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1739 cffr=cff*fc(i,k)
1740 cffl=cff*fc(i,k-1)
1741!
1742! Apply PPM monotonicity constraint to prevent oscillations within the
1743! grid box.
1744!
1745 IF ((dltr*dltl).le.0.0_r8) THEN
1746 dltr=0.0_r8
1747 dltl=0.0_r8
1748 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1749 dltr=cffl
1750 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1751 dltl=cffr
1752 END IF
1753!
1754! Compute right and left side values (bR,bL) of parabolic segments
1755! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1756!
1757! NOTE: Although each parabolic segment is monotonic within its grid
1758! box, monotonicity of the whole profile is not guaranteed,
1759! because bL(k+1)-bR(k) may still have different sign than
1760! qc(i,k+1)-qc(i,k). This possibility is excluded,
1761! after bL and bR are reconciled using WENO procedure.
1762!
1763 cff=(dltr-dltl)*hz_inv3(i,k)
1764 dltr=dltr-cff*hz(i,j,k+1)
1765 dltl=dltl+cff*hz(i,j,k-1)
1766 br(i,k)=qc(i,k)+dltr
1767 bl(i,k)=qc(i,k)-dltl
1768 wr(i,k)=(2.0_r8*dltr-dltl)**2
1769 wl(i,k)=(dltr-2.0_r8*dltl)**2
1770 END DO
1771 END DO
1772 cff=1.0e-14_r8
1773 DO k=2,n(ng)-2
1774 DO i=istr,iend
1775 dltl=max(cff,wl(i,k ))
1776 dltr=max(cff,wr(i,k+1))
1777 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1778 bl(i,k+1)=br(i,k)
1779 END DO
1780 END DO
1781 DO i=istr,iend
1782 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1783#if defined LINEAR_CONTINUATION
1784 bl(i,n(ng))=br(i,n(ng)-1)
1785 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1786#elif defined NEUMANN
1787 bl(i,n(ng))=br(i,n(ng)-1)
1788 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1789#else
1790 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1791 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1792 br(i,n(ng)-1)=qc(i,n(ng))
1793#endif
1794#if defined LINEAR_CONTINUATION
1795 br(i,1)=bl(i,2)
1796 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1797#elif defined NEUMANN
1798 br(i,1)=bl(i,2)
1799 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1800#else
1801 bl(i,2)=qc(i,1) ! bottom grid boxes are
1802 br(i,1)=qc(i,1) ! re-assumed to be
1803 bl(i,1)=qc(i,1) ! piecewise constant.
1804#endif
1805 END DO
1806!
1807! Apply monotonicity constraint again, since the reconciled interfacial
1808! values may cause a non-monotonic behavior of the parabolic segments
1809! inside the grid box.
1810!
1811 DO k=1,n(ng)
1812 DO i=istr,iend
1813 dltr=br(i,k)-qc(i,k)
1814 dltl=qc(i,k)-bl(i,k)
1815 cffr=2.0_r8*dltr
1816 cffl=2.0_r8*dltl
1817!^ tl_bL(i,k)=tl_qc(i,k)-tl_dltL
1818!^
1819 ad_qc(i,k)=ad_qc(i,k)+ad_bl(i,k)
1820 ad_dltl=ad_dltl-ad_bl(i,k)
1821 ad_bl(i,k)=0.0_r8
1822!^ tl_bR(i,k)=tl_qc(i,k)+tl_dltR
1823!^
1824 ad_qc(i,k)=ad_qc(i,k)+ad_br(i,k)
1825 ad_dltr=ad_dltr+ad_br(i,k)
1826 ad_br(i,k)=0.0_r8
1827 IF ((dltr*dltl).lt.0.0_r8) THEN
1828!^ tl_dltR=0.0_r8
1829!^
1830 ad_dltr=0.0_r8
1831!^ tl_dltL=0.0_r8
1832!^
1833 ad_dltl=0.0_r8
1834 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1835!^ tl_dltR=tl_cffL
1836!^
1837 ad_cffl=ad_cffl+ad_dltr
1838 ad_dltr=0.0_r8
1839 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1840!^ tl_dltL=tl_cffR
1841!^
1842 ad_cffr=ad_cffr+ad_dltl
1843 ad_dltl=0.0_r8
1844 END IF
1845!^ tl_cffL=2.0_r8*tl_dltL
1846!^
1847 ad_dltl=ad_dltl+2.0_r8*ad_cffl
1848 ad_cffl=0.0_r8
1849!^ tl_cffR=2.0_r8*tl_dltR
1850!^
1851 ad_dltr=ad_dltr+2.0_r8*ad_cffr
1852 ad_cffr=0.0_r8
1853!^ tl_dltL=tl_qc(i,k)-tl_bL(i,k)
1854!^
1855 ad_qc(i,k)=ad_qc(i,k)+ad_dltl
1856 ad_bl(i,k)=ad_bl(i,k)-ad_dltl
1857 ad_dltl=0.0_r8
1858!^ tl_dltR=tl_bR(i,k)-tl_qc(i,k)
1859!^
1860 ad_br(i,k)=ad_br(i,k)+ad_dltr
1861 ad_qc(i,k)=ad_qc(i,k)-ad_dltr
1862 ad_dltr=0.0_r8
1863 END DO
1864 END DO
1865 DO i=istr,iend
1866#if defined LINEAR_CONTINUATION
1867!^ tl_bR(i,1)=tl_bL(i,2)
1868!^
1869 ad_bl(i,2)=ad_bl(i,2)+ad_br(i,1)
1870 ad_br(i,1)=0.0_r8
1871!^ tl_bL(i,1)=2.0_r8*tl_qc(i,1)-tl_bR(i,1)
1872!^
1873 ad_qc(i,1)=ad_qc(i,1)+2.0_r8*ad_bl(i,1)
1874 ad_br(i,1)=ad_br(i,1)-ad_bl(i,1)
1875 ad_bl(i,1)=0.0_r8
1876#elif defined NEUMANN
1877!^ tl_bR(i,1)=tl_bL(i,2)
1878!^
1879 ad_bl(i,2)=ad_bl(i,2)+ad_br(i,1)
1880 ad_br(i,1)=0.0_r8
1881!^ tl_bL(i,1)=1.5_r8*tl_qc(i,1)-0.5_r8*tl_bR(i,1)
1882!^
1883 ad_qc(i,1)=ad_qc(i,1)+1.5_r8*ad_bl(i,1)
1884 ad_br(i,1)=ad_br(i,1)-0.5_r8*ad_bl(i,1)
1885 ad_bl(i,1)=0.0_r8
1886#else
1887!^ tl_bL(i,2)=tl_qc(i,1) ! bottom grid boxes are
1888!^ tl_bR(i,1)=tl_qc(i,1) ! re-assumed to be
1889!^ tl_bL(i,1)=tl_qc(i,1) ! piecewise constant.
1890!^
1891 ad_qc(i,1)=ad_qc(i,1)+ad_bl(i,1)+ &
1892 & ad_br(i,1)+ &
1893 & ad_bl(i,2)
1894 ad_bl(i,1)=0.0_r8
1895 ad_br(i,1)=0.0_r8
1896 ad_bl(i,2)=0.0_r8
1897#endif
1898#if defined LINEAR_CONTINUATION
1899!^ tl_bL(i,N(ng))=tl_bR(i,N(ng)-1)
1900!^
1901 ad_br(i,n(ng)-1)=ad_br(i,n(ng)-1)+ad_bl(i,n(ng))
1902 ad_bl(i,n(ng))=0.0_r8
1903!^ tl_bR(i,N(ng))=2.0_r8*tl_qc(i,N(ng))-tl_bL(i,N(ng))
1904!^
1905 ad_qc(i,n(ng))=ad_qc(i,n(ng))+2.0_r8*ad_br(i,n(ng))
1906 ad_bl(i,n(ng))=ad_bl(i,n(ng))-ad_br(i,n(ng))
1907 ad_br(i,n(ng))=0.0_r8
1908#elif defined NEUMANN
1909!^ tl_bL(i,N(ng))=tl_bR(i,N(ng)-1)
1910!^
1911 ad_br(i,n(ng)-1)=ad_br(i,n(ng)-1)+ad_bl(i,n(ng))
1912 ad_bl(i,n(ng))=0.0_r8
1913!^ tl_bR(i,N(ng))=1.5_r8*tl_qc(i,N(ng))-0.5_r8*tl_bL(i,N(ng))
1914!^
1915 ad_qc(i,n(ng))=ad_qc(i,n(ng))+1.5_r8*ad_br(i,n(ng))
1916 ad_bl(i,n(ng))=ad_bl(i,n(ng))-0.5_r8*ad_br(i,n(ng))
1917 ad_br(i,n(ng))=0.0_r8
1918#else
1919!^ tl_bR(i,N(ng))=tl_qc(i,N(ng)) ! default strictly monotonic
1920!^ tl_bL(i,N(ng))=tl_qc(i,N(ng)) ! conditions
1921!^ tl_bR(i,N(ng)-1)=tl_qc(i,N(ng))
1922!^
1923 ad_qc(i,n(ng))=ad_qc(i,n(ng))+ad_br(i,n(ng)-1)+ &
1924 & ad_bl(i,n(ng))+ &
1925 & ad_br(i,n(ng))
1926 ad_br(i,n(ng)-1)=0.0_r8
1927 ad_bl(i,n(ng))=0.0_r8
1928 ad_br(i,n(ng))=0.0_r8
1929#endif
1930 END DO
1931!
1932! Compute WR and WL arrays appropriate for this part of the code.
1933!
1934! Copy concentration of biological particulates into scratch array
1935! "qc" (q-central, restrict it to be positive) which is hereafter
1936! interpreted as a set of grid-box averaged values for biogeochemical
1937! constituent concentration.
1938!
1939 DO k=1,n(ng)
1940 DO i=istr,iend
1941 qc(i,k)=bio(i,k,ibio)
1942 END DO
1943 END DO
1944!
1945 DO k=n(ng)-1,1,-1
1946 DO i=istr,iend
1947 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1948 END DO
1949 END DO
1950 DO k=2,n(ng)-1
1951 DO i=istr,iend
1952 dltr=hz(i,j,k)*fc(i,k)
1953 dltl=hz(i,j,k)*fc(i,k-1)
1954 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1955 cffr=cff*fc(i,k)
1956 cffl=cff*fc(i,k-1)
1957!
1958! Apply PPM monotonicity constraint to prevent oscillations within the
1959! grid box.
1960!
1961 IF ((dltr*dltl).le.0.0_r8) THEN
1962 dltr=0.0_r8
1963 dltl=0.0_r8
1964 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1965 dltr=cffl
1966 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1967 dltl=cffr
1968 END IF
1969!
1970! Compute right and left side values (bR,bL) of parabolic segments
1971! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1972!
1973! NOTE: Although each parabolic segment is monotonic within its grid
1974! box, monotonicity of the whole profile is not guaranteed,
1975! because bL(k+1)-bR(k) may still have different sign than
1976! qc(i,k+1)-qc(i,k). This possibility is excluded,
1977! after bL and bR are reconciled using WENO procedure.
1978!
1979 cff=(dltr-dltl)*hz_inv3(i,k)
1980 dltr=dltr-cff*hz(i,j,k+1)
1981 dltl=dltl+cff*hz(i,j,k-1)
1982 br(i,k)=qc(i,k)+dltr
1983 bl(i,k)=qc(i,k)-dltl
1984 wr(i,k)=(2.0_r8*dltr-dltl)**2
1985 wl(i,k)=(dltr-2.0_r8*dltl)**2
1986 END DO
1987 END DO
1988
1989 cff=1.0e-14_r8
1990 DO k=2,n(ng)-2
1991 DO i=istr,iend
1992 dltl=max(cff,wl(i,k ))
1993 dltr=max(cff,wr(i,k+1))
1994 br1(i,k)=br(i,k)
1995 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1996 bl1(i,k+1)=bl(i,k+1)
1997 bl(i,k+1)=br(i,k)
1998!^ tl_bL(i,k+1)=tl_bR(i,k)
1999!^
2000 ad_br(i,k)=ad_br(i,k)+ad_bl(i,k+1)
2001 ad_bl(i,k+1)=0.0_r8
2002!^ tl_bR(i,k)=(tl_dltR*bR1(i,k)+dltR*tl_bR(i,k)+ &
2003!^ & tl_dltL*bL1(i,k+1)+dltL*tl_bL(i,k+1))/ &
2004!^ & (dltR+dltL)- &
2005!^ & (tl_dltR+tl_dltL)*bR(i,k)/(dltR+dltL)
2006!^
2007 adfac=ad_br(i,k)/(dltr+dltl)
2008 adfac1=ad_br(i,k)*br(i,k)/(dltr+dltl)
2009 ad_dltr=ad_dltr+adfac*br1(i,k)
2010 ad_dltl=ad_dltl+adfac*bl1(i,k+1)
2011 ad_bl(i,k+1)=ad_bl(i,k+1)+dltl*adfac
2012 ad_dltr=ad_dltr-adfac1
2013 ad_dltl=ad_dltl-adfac1
2014 ad_br(i,k)=dltr*adfac
2015!^ tl_dltR=(0.5_r8-SIGN(0.5_r8,cff-WR(i,k+1)))* &
2016!^ & tl_WR(i,k+1)
2017!^
2018 ad_wr(i,k+1)=ad_wr(i,k+1)+ &
2019 & (0.5_r8-sign(0.5_r8,cff-wr(i,k+1)))* &
2020 & ad_dltr
2021 ad_dltr=0.0_r8
2022!^ tl_dltL=(0.5_r8-SIGN(0.5_r8,cff-WL(i,k )))* &
2023!^ & tl_WL(i,k )
2024!^
2025 ad_wl(i,k )=ad_wl(i,k )+ &
2026 & (0.5_r8-sign(0.5_r8,cff-wl(i,k )))* &
2027 & ad_dltl
2028 ad_dltl=0.0_r8
2029 END DO
2030 END DO
2031
2032 DO k=2,n(ng)-1
2033 DO i=istr,iend
2034!
2035! Compute appropriate dltL and dltr.
2036!
2037 dltr=hz(i,j,k)*fc(i,k)
2038 dltl=hz(i,j,k)*fc(i,k-1)
2039 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2040 cffr=cff*fc(i,k)
2041 cffl=cff*fc(i,k-1)
2042!
2043! Apply PPM monotonicity constraint to prevent oscillations within the
2044! grid box.
2045!
2046 IF ((dltr*dltl).le.0.0_r8) THEN
2047 dltr=0.0_r8
2048 dltl=0.0_r8
2049 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2050 dltr=cffl
2051 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2052 dltl=cffr
2053 END IF
2054!
2055! Compute right and left side values (bR,bL) of parabolic segments
2056! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
2057!
2058! NOTE: Although each parabolic segment is monotonic within its grid
2059! box, monotonicity of the whole profile is not guaranteed,
2060! because bL(k+1)-bR(k) may still have different sign than
2061! qc(i,k+1)-qc(i,k). This possibility is excluded,
2062! after bL and bR are reconciled using WENO procedure.
2063!
2064 cff=(dltr-dltl)*hz_inv3(i,k)
2065 dltr=dltr-cff*hz(i,j,k+1)
2066 dltl=dltl+cff*hz(i,j,k-1)
2067!^ tl_WL(i,k)=2.0_r8*(dltR-2.0_r8*dltL)* &
2068!^ & (tl_dltR-2.0_r8*tl_dltL)
2069!^
2070 adfac=ad_wl(i,k)*2.0_r8*(dltr-2.0_r8*dltl)
2071 ad_dltr=ad_dltr+adfac
2072 ad_dltl=ad_dltl-2.0_r8*adfac
2073 ad_wl(i,k)=0.0_r8
2074
2075!^ tl_WR(i,k)=2.0_r8*(2.0_r8*dltR-dltL)* &
2076!^ & (2.0_r8*tl_dltR-tl_dltL)
2077!^
2078 adfac=ad_wr(i,k)*2.0_r8*(2.0_r8*dltr-dltl)
2079 ad_dltr=ad_dltr+2.0_r8*adfac
2080 ad_dltl=ad_dltl-adfac
2081 ad_wr(i,k)=0.0_r8
2082!^ tl_bL(i,k)=tl_qc(i,k)-tl_dltL
2083!^
2084 ad_qc(i,k)=ad_qc(i,k)+ad_bl(i,k)
2085 ad_dltl=ad_dltl-ad_bl(i,k)
2086 ad_bl(i,k)=0.0_r8
2087!^ tl_bR(i,k)=tl_qc(i,k)+tl_dltR
2088!^
2089 ad_qc(i,k)=ad_qc(i,k)+ad_br(i,k)
2090 ad_dltr=ad_dltr+ad_br(i,k)
2091 ad_br(i,k)=0.0_r8
2092
2093!
2094! Compute appropriate dltL and dltr.
2095!
2096 dltr=hz(i,j,k)*fc(i,k)
2097 dltl=hz(i,j,k)*fc(i,k-1)
2098 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2099 cffr=cff*fc(i,k)
2100 cffl=cff*fc(i,k-1)
2101!
2102! Apply PPM monotonicity constraint to prevent oscillations within the
2103! grid box.
2104!
2105 IF ((dltr*dltl).le.0.0_r8) THEN
2106 dltr=0.0_r8
2107 dltl=0.0_r8
2108 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2109 dltr=cffl
2110 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2111 dltl=cffr
2112 END IF
2113
2114 cff=(dltr-dltl)*hz_inv3(i,k)
2115!^ tl_dltL=tl_dltL+tl_cff*Hz(i,j,k-1)+cff*tl_Hz(i,j,k-1)
2116!^
2117 ad_cff=ad_cff+ad_dltl*hz(i,j,k-1)
2118 ad_hz(i,j,k-1)=ad_hz(i,j,k-1)+cff*ad_dltl
2119!^ tl_dltR=tl_dltR-tl_cff*Hz(i,j,k+1)-cff*tl_Hz(i,j,k+1)
2120!^
2121 ad_cff=ad_cff-ad_dltr*hz(i,j,k+1)
2122 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)-cff*ad_dltr
2123!^ tl_cff=(tl_dltR-tl_dltL)*Hz_inv3(i,k)+ &
2124!^ & (dltR-dltL)*tl_Hz_inv3(i,k)
2125!^
2126 adfac=ad_cff*hz_inv3(i,k)
2127 ad_dltr=ad_dltr+adfac
2128 ad_dltl=ad_dltl-adfac
2129 ad_hz_inv3(i,k)=ad_hz_inv3(i,k)+(dltr-dltl)*ad_cff
2130 ad_cff=0.0_r8
2131!
2132! Compute appropriate dltL and dltr.
2133!
2134 dltr=hz(i,j,k)*fc(i,k)
2135 dltl=hz(i,j,k)*fc(i,k-1)
2136 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2137 cffr=cff*fc(i,k)
2138 cffl=cff*fc(i,k-1)
2139
2140 IF ((dltr*dltl).le.0.0_r8) THEN
2141!^ tl_dltR=0.0_r8
2142!^
2143 ad_dltr=0.0_r8
2144!^ tl_dltL=0.0_r8
2145!^
2146 ad_dltl=0.0_r8
2147 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2148!^ tl_dltR=tl_cffL
2149!^
2150 ad_cffl=ad_cffl+ad_dltr
2151 ad_dltr=0.0_r8
2152 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2153!^ tl_dltL=tl_cffR
2154!^
2155 ad_cffr=ad_cffr+ad_dltl
2156 ad_dltl=0.0_r8
2157 END IF
2158!^ tl_cffL=tl_cff*FC(i,k-1)+cff*tl_FC(i,k-1)
2159!^
2160 ad_cff=ad_cff+ad_cffl*fc(i,k-1)
2161 ad_fc(i,k-1)=ad_fc(i,k-1)+cff*ad_cffl
2162 ad_cffl=0.0_r8
2163!^ tl_cffR=tl_cff*FC(i,k)+cff*tl_FC(i,k)
2164!^
2165 ad_cff=ad_cff+ad_cffr*fc(i,k)
2166 ad_fc(i,k)=ad_fc(i,k)+cff*ad_cffr
2167 ad_cffr=0.0_r8
2168!^ tl_cff=tl_Hz(i,j,k-1)+2.0_r8*tl_Hz(i,j,k)+tl_Hz(i,j,k+1)
2169!^
2170 ad_hz(i,j,k-1)=ad_hz(i,j,k-1)+ad_cff
2171 ad_hz(i,j,k)=ad_hz(i,j,k)+2.0_r8*ad_cff
2172 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)+ad_cff
2173 ad_cff=0.0_r8
2174!^ tl_dltL=tl_Hz(i,j,k)*FC(i,k-1)+Hz(i,j,k)*tl_FC(i,k-1)
2175!^
2176 ad_hz(i,j,k)=ad_hz(i,j,k)+ad_dltl*fc(i,k-1)
2177 ad_fc(i,k-1)=ad_fc(i,k-1)+ad_dltl*hz(i,j,k)
2178 ad_dltl=0.0_r8
2179!^ tl_dltR=tl_Hz(i,j,k)*FC(i,k)+Hz(i,j,k)*tl_FC(i,k)
2180!^
2181 ad_hz(i,j,k)=ad_hz(i,j,k)+ad_dltr*fc(i,k)
2182 ad_fc(i,k)=ad_fc(i,k)+ad_dltr*hz(i,j,k)
2183 ad_dltr=0.0_r8
2184 END DO
2185 END DO
2186 DO k=n(ng)-1,1,-1
2187 DO i=istr,iend
2188!^ tl_FC(i,k)=(tl_qc(i,k+1)-tl_qc(i,k))*Hz_inv2(i,k)+ &
2189!^ & (qc(i,k+1)-qc(i,k))*tl_Hz_inv2(i,k)
2190!^
2191 adfac=ad_fc(i,k)*hz_inv2(i,k)
2192 ad_qc(i,k+1)=ad_qc(i,k+1)+adfac
2193 ad_qc(i,k)=ad_qc(i,k)-adfac
2194 ad_hz_inv2(i,k)=ad_hz_inv2(i,k)+(qc(i,k+1)-qc(i,k))* &
2195 & ad_fc(i,k)
2196 ad_fc(i,k)=0.0_r8
2197 END DO
2198 END DO
2199 DO k=1,n(ng)
2200 DO i=istr,iend
2201!^ tl_qc(i,k)=tl_Bio(i,k,ibio)
2202!^
2203 ad_bio(i,k,ibio)=ad_bio(i,k,ibio)+ad_qc(i,k)
2204 ad_qc(i,k)=0.0_r8
2205 END DO
2206 END DO
2207
2208 END DO sink_loop1
2209!
2210! Compute appropriate basic state arrays II.
2211!
2212 DO k=1,n(ng)
2213 DO i=istr,iend
2214!
2215! At input, all tracers (index nnew) from predictor step have
2216! transport units (m Tunits) since we do not have yet the new
2217! values for zeta and Hz. These are known after the 2D barotropic
2218! time-stepping.
2219!
2220! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
2221! tracer times depth. However the basic state (nstp and nnew
2222! indices) that is read from the forward file is in units of
2223! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
2224! use t instead of t*Hz_inv.
2225!
2226 DO itrc=1,nbt
2227 ibio=idbio(itrc)
2228!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
2229!^
2230 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
2231!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
2232!^
2233 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
2234 END DO
2235!
2236! Impose positive definite concentrations.
2237!
2238 cff2=0.0_r8
2239 DO itime=1,2
2240 cff1=0.0_r8
2241 itrcmax=idbio(1)
2242#ifdef IRON_LIMIT
2243 DO itrc=1,nbt-2
2244#else
2245 DO itrc=1,nbt
2246#endif
2247 ibio=idbio(itrc)
2248 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
2249 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
2250 itrcmax=ibio
2251 END IF
2252 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
2253 END DO
2254 IF (biotrc(itrcmax,itime).gt.cff1) THEN
2255 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
2256 END IF
2257#ifdef IRON_LIMIT
2258 DO itrc=nbt-1,nbt
2259 ibio=idbio(itrc)
2260 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
2261 END DO
2262#endif
2263 END DO
2264!
2265! Load biological tracers into local arrays.
2266!
2267 DO itrc=1,nbt
2268 ibio=idbio(itrc)
2269 bio_old(i,k,ibio)=biotrc(ibio,nstp)
2270 bio(i,k,ibio)=biotrc(ibio,nstp)
2271 END DO
2272
2273#if defined IRON_LIMIT && defined IRON_RELAX
2274!
2275! Relax dissolved iron at coast (h <= FeHim) to a constant value
2276! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
2277! at the shelf.
2278!
2279 IF (h(i,j).le.fehmin(ng)) THEN
2280 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2281 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
2282 END IF
2283#endif
2284 END DO
2285 END DO
2286!
2287! Calculate surface Photosynthetically Available Radiation (PAR). The
2288! net shortwave radiation is scaled back to Watts/m2 and multiplied by
2289! the fraction that is photosynthetically available, PARfrac.
2290!
2291 DO i=istr,iend
2292#ifdef CONST_PAR
2293!
2294! Specify constant surface irradiance a la Powell and Spitz.
2295!
2296 parsur(i)=158.075_r8
2297#else
2298 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
2299#endif
2300 END DO
2301!
2302!=======================================================================
2303! Start internal iterations to achieve convergence of the nonlinear
2304! backward-implicit solution.
2305!=======================================================================
2306!
2307 DO iteradj=1,iter
2308!
2309! Compute light attenuation as function of depth.
2310!
2311 DO i=istr,iend
2312 par=parsur(i)
2313 IF (parsur(i).gt.0.0_r8) THEN ! day time
2314 DO k=n(ng),1,-1
2315!
2316! Compute average light attenuation for each grid cell. Here, AttSW is
2317! the light attenuation due to seawater and AttPhy is the attenuation
2318! due to phytoplankton (self-shading coefficient).
2319!
2320 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
2321 & (z_w(i,j,k)-z_w(i,j,k-1))
2322 expatt=exp(-att)
2323 itop=par
2324 par=itop*(1.0_r8-expatt)/att ! average at cell center
2325 light(i,k)=par
2326!
2327! Light attenuation at the bottom of the grid cell. It is the starting
2328! PAR value for the next (deeper) vertical grid cell.
2329!
2330 par=itop*expatt
2331 END DO
2332 ELSE ! night time
2333 DO k=1,n(ng)
2334 light(i,k)=0.0_r8
2335 END DO
2336 END IF
2337 END DO
2338!
2339! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
2340! The Michaelis-Menten curve is used to describe the change in uptake
2341! rate as a function of nitrate concentration. Here, PhyIS is the
2342! initial slope of the P-I curve and K_NO3 is the half saturation of
2343! phytoplankton nitrate uptake.
2344#ifdef IRON_LIMIT
2345!
2346! Growth reduction factors due to iron limitation:
2347!
2348! FNratio current Fe:N ratio [umol-Fe/mmol-N]
2349! FCratio current Fe:C ratio [umol-Fe/mol-C]
2350! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
2351! FCratioE empirical Fe:C ratio
2352! Flimit Phytoplankton growth reduction factor due to Fe
2353! limitation based on Fe:C ratio
2354!
2355#endif
2356!
2357 cff1=dtdays*vm_no3(ng)*phyis(ng)
2358 cff2=vm_no3(ng)*vm_no3(ng)
2359 cff3=phyis(ng)*phyis(ng)
2360 DO k=1,n(ng)
2361 DO i=istr,iend
2362#ifdef IRON_LIMIT
2363 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
2364 fcratio=fnratio*fen2fec
2365 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
2366 flimit=fcratio*fcratio/ &
2367 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
2368
2369 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
2370 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
2371#endif
2372!
2373 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
2374 cff=bio(i,k,iphyt)* &
2375#ifdef IRON_LIMIT
2376 & cff1*cff4*light(i,k)*fnlim*nlimit
2377#else
2378 & cff1*cff4*light(i,k)/ &
2379 & (k_no3(ng)+bio(i,k,ino3_))
2380#endif
2381 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
2382 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
2383 & bio(i,k,ino3_)*cff
2384
2385#ifdef IRON_LIMIT
2386!
2387! Iron uptake proportional to growth.
2388!
2389 fac=cff*bio(i,k,ino3_)*fnratio/ &
2390 & max(minval,bio(i,k,ifdis))
2391 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
2392 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
2393 & bio(i,k,ifdis)*fac
2394!
2395! Iron uptake to reach appropriate Fe:C ratio.
2396!
2397 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
2398 cff6=bio(i,k,iphyt)*cff5*fec2fen
2399 IF (cff6.ge.0.0_r8) THEN
2400 cff=cff6/max(minval,bio(i,k,ifdis))
2401 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
2402 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
2403 & bio(i,k,ifdis)*cff
2404 ELSE
2405 cff=-cff6/max(minval,bio(i,k,ifphy))
2406 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
2407 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2408 & bio(i,k,ifphy)*cff
2409 END IF
2410#endif
2411 END DO
2412 END DO
2413!
2414! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
2415! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
2416! pool as function of "sloppy feeding" and metabolic processes
2417! (ZooEEN and ZooEED fractions).
2418#ifdef IRON_LIMIT
2419! The lost of phytoplankton to the dissolve iron pool is scale by the
2420! remineralization rate (FeRR).
2421#endif
2422!
2423 cff1=dtdays*zoogr(ng)
2424 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
2425 DO k=1,n(ng)
2426 DO i=istr,iend
2427 cff=bio(i,k,izoop)* &
2428 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
2429 & bio(i,k,iphyt)
2430 bio1(i,k,iphyt)=bio(i,k,iphyt)
2431 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
2432 bio1(i,k,izoop)=bio(i,k,izoop)
2433 bio(i,k,izoop)=bio(i,k,izoop)+ &
2434 & bio(i,k,iphyt)*cff2*cff
2435 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2436 & bio(i,k,iphyt)*zooeen(ng)*cff
2437 bio(i,k,isdet)=bio(i,k,isdet)+ &
2438 & bio(i,k,iphyt)*zooeed(ng)*cff
2439#ifdef IRON_LIMIT
2440 bio1(i,k,ifphy)=bio(i,k,ifphy)
2441 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
2442 bio2(i,k,ifphy)=bio(i,k,ifphy)
2443 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2444 & bio(i,k,ifphy)*cff*ferr(ng)
2445#endif
2446 END DO
2447 END DO
2448!
2449! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
2450! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
2451!
2452 cff3=dtdays*phymrd(ng)
2453 cff2=dtdays*phymrn(ng)
2454 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2455 DO k=1,n(ng)
2456 DO i=istr,iend
2457 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
2458 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2459 & bio(i,k,iphyt)*cff2
2460 bio(i,k,isdet)=bio(i,k,isdet)+ &
2461 & bio(i,k,iphyt)*cff3
2462#ifdef IRON_LIMIT
2463 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
2464 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2465 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
2466#endif
2467 END DO
2468 END DO
2469!
2470 IF (iteradj.ne.iter) THEN
2471!
2472! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
2473! (ZooMRD rate).
2474!
2475 cff3=dtdays*zoomrd(ng)
2476 cff2=dtdays*zoomrn(ng)
2477 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2478 DO k=1,n(ng)
2479 DO i=istr,iend
2480 bio(i,k,izoop)=bio(i,k,izoop)*cff1
2481 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2482 & bio(i,k,izoop)*cff2
2483 bio(i,k,isdet)=bio(i,k,isdet)+ &
2484 & bio(i,k,izoop)*cff3
2485 END DO
2486 END DO
2487!
2488! Detritus breakdown to nutrients: remineralization (DetRR rate).
2489!
2490 cff2=dtdays*detrr(ng)
2491 cff1=1.0_r8/(1.0_r8+cff2)
2492 DO k=1,n(ng)
2493 DO i=istr,iend
2494 bio(i,k,isdet)=bio(i,k,isdet)*cff1
2495 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2496 & bio(i,k,isdet)*cff2
2497 END DO
2498 END DO
2499!
2500!-----------------------------------------------------------------------
2501! Vertical sinking terms: Phytoplankton and Detritus
2502!-----------------------------------------------------------------------
2503!
2504! Reconstruct vertical profile of selected biological constituents
2505! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
2506! grid box. Then, compute semi-Lagrangian flux due to sinking.
2507!
2508 DO isink=1,nsink
2509 ibio=idsink(isink)
2510!
2511! Copy concentration of biological particulates into scratch array
2512! "qc" (q-central, restrict it to be positive) which is hereafter
2513! interpreted as a set of grid-box averaged values for biogeochemical
2514! constituent concentration.
2515!
2516 DO k=1,n(ng)
2517 DO i=istr,iend
2518 qc(i,k)=bio(i,k,ibio)
2519 END DO
2520 END DO
2521!
2522 DO k=n(ng)-1,1,-1
2523 DO i=istr,iend
2524 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
2525 END DO
2526 END DO
2527 DO k=2,n(ng)-1
2528 DO i=istr,iend
2529 dltr=hz(i,j,k)*fc(i,k)
2530 dltl=hz(i,j,k)*fc(i,k-1)
2531 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2532 cffr=cff*fc(i,k)
2533 cffl=cff*fc(i,k-1)
2534!
2535! Apply PPM monotonicity constraint to prevent oscillations within the
2536! grid box.
2537!
2538 IF ((dltr*dltl).le.0.0_r8) THEN
2539 dltr=0.0_r8
2540 dltl=0.0_r8
2541 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2542 dltr=cffl
2543 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2544 dltl=cffr
2545 END IF
2546!
2547! Compute right and left side values (bR,bL) of parabolic segments
2548! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
2549!
2550! NOTE: Although each parabolic segment is monotonic within its grid
2551! box, monotonicity of the whole profile is not guaranteed,
2552! because bL(k+1)-bR(k) may still have different sign than
2553! qc(i,k+1)-qc(i,k). This possibility is excluded,
2554! after bL and bR are reconciled using WENO procedure.
2555!
2556 cff=(dltr-dltl)*hz_inv3(i,k)
2557 dltr=dltr-cff*hz(i,j,k+1)
2558 dltl=dltl+cff*hz(i,j,k-1)
2559 br(i,k)=qc(i,k)+dltr
2560 bl(i,k)=qc(i,k)-dltl
2561 wr(i,k)=(2.0_r8*dltr-dltl)**2
2562 wl(i,k)=(dltr-2.0_r8*dltl)**2
2563 END DO
2564 END DO
2565 cff=1.0e-14_r8
2566 DO k=2,n(ng)-2
2567 DO i=istr,iend
2568 dltl=max(cff,wl(i,k ))
2569 dltr=max(cff,wr(i,k+1))
2570 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
2571 bl(i,k+1)=br(i,k)
2572 END DO
2573 END DO
2574 DO i=istr,iend
2575 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
2576#if defined LINEAR_CONTINUATION
2577 bl(i,n(ng))=br(i,n(ng)-1)
2578 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
2579#elif defined NEUMANN
2580 bl(i,n(ng))=br(i,n(ng)-1)
2581 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
2582#else
2583 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
2584 bl(i,n(ng))=qc(i,n(ng)) ! conditions
2585 br(i,n(ng)-1)=qc(i,n(ng))
2586#endif
2587#if defined LINEAR_CONTINUATION
2588 br(i,1)=bl(i,2)
2589 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
2590#elif defined NEUMANN
2591 br(i,1)=bl(i,2)
2592 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
2593#else
2594 bl(i,2)=qc(i,1) ! bottom grid boxes are
2595 br(i,1)=qc(i,1) ! re-assumed to be
2596 bl(i,1)=qc(i,1) ! piecewise constant.
2597#endif
2598 END DO
2599!
2600! Apply monotonicity constraint again, since the reconciled interfacial
2601! values may cause a non-monotonic behavior of the parabolic segments
2602! inside the grid box.
2603!
2604 DO k=1,n(ng)
2605 DO i=istr,iend
2606 dltr=br(i,k)-qc(i,k)
2607 dltl=qc(i,k)-bl(i,k)
2608 cffr=2.0_r8*dltr
2609 cffl=2.0_r8*dltl
2610 IF ((dltr*dltl).lt.0.0_r8) THEN
2611 dltr=0.0_r8
2612 dltl=0.0_r8
2613 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2614 dltr=cffl
2615 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2616 dltl=cffr
2617 END IF
2618 br(i,k)=qc(i,k)+dltr
2619 bl(i,k)=qc(i,k)-dltl
2620 END DO
2621 END DO
2622!
2623! After this moment reconstruction is considered complete. The next
2624! stage is to compute vertical advective fluxes, FC. It is expected
2625! that sinking may occurs relatively fast, the algorithm is designed
2626! to be free of CFL criterion, which is achieved by allowing
2627! integration bounds for semi-Lagrangian advective flux to use as
2628! many grid boxes in upstream direction as necessary.
2629!
2630! In the two code segments below, WL is the z-coordinate of the
2631! departure point for grid box interface z_w with the same indices;
2632! FC is the finite volume flux; ksource(:,k) is index of vertical
2633! grid box which contains the departure point (restricted by N(ng)).
2634! During the search: also add in content of whole grid boxes
2635! participating in FC.
2636!
2637 cff=dtdays*abs(wbio(isink))
2638 DO k=1,n(ng)
2639 DO i=istr,iend
2640 fc(i,k-1)=0.0_r8
2641 wl(i,k)=z_w(i,j,k-1)+cff
2642 wr(i,k)=hz(i,j,k)*qc(i,k)
2643 ksource(i,k)=k
2644 END DO
2645 END DO
2646 DO k=1,n(ng)
2647 DO ks=k,n(ng)-1
2648 DO i=istr,iend
2649 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
2650 ksource(i,k)=ks+1
2651 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
2652 END IF
2653 END DO
2654 END DO
2655 END DO
2656!
2657! Finalize computation of flux: add fractional part.
2658!
2659 DO k=1,n(ng)
2660 DO i=istr,iend
2661 ks=ksource(i,k)
2662 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
2663 fc(i,k-1)=fc(i,k-1)+ &
2664 & hz(i,j,ks)*cu* &
2665 & (bl(i,ks)+ &
2666 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2667 & (1.5_r8-cu)* &
2668 & (br(i,ks)+bl(i,ks)- &
2669 & 2.0_r8*qc(i,ks))))
2670 END DO
2671 END DO
2672 DO k=1,n(ng)
2673 DO i=istr,iend
2674 bio(i,k,ibio)=qc(i,k)+ &
2675 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
2676 END DO
2677 END DO
2678 END DO
2679 END IF
2680 END DO
2681!
2682! End of compute basic state arrays II.
2683!
2684! Adjoint detritus breakdown to nutrients: remineralization
2685! (DetRR rate).
2686!
2687 cff2=dtdays*detrr(ng)
2688 cff1=1.0_r8/(1.0_r8+cff2)
2689 DO k=1,n(ng)
2690 DO i=istr,iend
2691!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2692!^ & tl_Bio(i,k,iSDet)*cff2
2693!^
2694 ad_bio(i,k,isdet)=ad_bio(i,k,isdet)+ &
2695 & cff2*ad_bio(i,k,ino3_)
2696!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)*cff1
2697!^
2698 ad_bio(i,k,isdet)=ad_bio(i,k,isdet)*cff1
2699 END DO
2700 END DO
2701!
2702! Adjoint Zooplankton mortality to nutrients (ZooMRN rate) and
2703! Detritus (ZooMRD rate).
2704!
2705 cff3=dtdays*zoomrd(ng)
2706 cff2=dtdays*zoomrn(ng)
2707 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2708 DO k=1,n(ng)
2709 DO i=istr,iend
2710!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)+ &
2711!^ & tl_Bio(i,k,iZoop)*cff3
2712!^
2713 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)+ &
2714 & cff3*ad_bio(i,k,isdet)
2715!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2716!^ & tl_Bio(i,k,iZoop)*cff2
2717!^
2718 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)+ &
2719 & cff2*ad_bio(i,k,ino3_)
2720!^ tl_Bio(i,k,iZoop)=tl_Bio(i,k,iZoop)*cff1
2721!^
2722 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)*cff1
2723 END DO
2724 END DO
2725!
2726! Adjoint Phytoplankton mortality to nutrients (PhyMRN rate) and
2727! detritus (PhyMRD rate), and if applicable dissolved iron
2728! (FeRR rate).
2729!
2730 cff3=dtdays*phymrd(ng)
2731 cff2=dtdays*phymrn(ng)
2732 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2733 DO k=1,n(ng)
2734 DO i=istr,iend
2735#ifdef IRON_LIMIT
2736!^ tl_Bio(i,k,iFdis)=tl_Bio(i,k,iFdis)+ &
2737!^ & tl_Bio(i,k,iFphy)*(cff2+cff3)*FeRR(ng)
2738!^
2739 ad_bio(i,k,ifphy)=ad_bio(i,k,ifphy)+ &
2740 & (cff2+cff3)*ferr(ng)*ad_bio(i,k,ifdis)
2741!^ tl_Bio(i,k,iFphy)=tl_Bio(i,k,iFphy)*cff1
2742!^
2743 ad_bio(i,k,ifphy)=ad_bio(i,k,ifphy)*cff1
2744#endif
2745!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)+ &
2746!^ & tl_Bio(i,k,iPhyt)*cff3
2747!^
2748 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2749 & cff3*ad_bio(i,k,isdet)
2750!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2751!^ & tl_Bio(i,k,iPhyt)*cff2
2752!^
2753 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2754 & cff2*ad_bio(i,k,ino3_)
2755!^ tl_Bio(i,k,iPhyt)=tl_Bio(i,k,iPhyt)*cff1
2756!^
2757 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)*cff1
2758 END DO
2759 END DO
2760!
2761! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
2762! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
2763! pool as function of "sloppy feeding" and metabolic processes
2764! (ZooEEN and ZooEED fractions).
2765#ifdef IRON_LIMIT
2766! The lost of phytoplankton to the dissolve iron pool is scale by the
2767! remineralization rate (FeRR).
2768#endif
2769!
2770 cff1=dtdays*zoogr(ng)
2771 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
2772 DO k=1,n(ng)
2773 DO i=istr,iend
2774 cff=bio1(i,k,izoop)* &
2775 & cff1*(1.0_r8-exp(-ivlev(ng)*bio1(i,k,iphyt)))/ &
2776 & bio1(i,k,iphyt)
2777#ifdef IRON_LIMIT
2778!^ tl_Bio(i,k,iFdis)=tl_Bio(i,k,iFdis)+ &
2779!^ & (tl_Bio(i,k,iFphy)*cff+ &
2780!^ & Bio2(i,k,iFphy)*tl_cff)*FeRR(ng)
2781!^
2782 ad_bio(i,k,ifphy)=ad_bio(i,k,ifphy)+cff*ferr(ng)* &
2783 & ad_bio(i,k,ifdis)
2784 ad_cff=ad_cff+bio2(i,k,ifphy)*ferr(ng)*ad_bio(i,k,ifdis)
2785!^ tl_Bio(i,k,iFphy)=(tl_Bio(i,k,iFphy)- &
2786!^ & tl_cff*Bio2(i,k,iFphy))/ &
2787!^ & (1.0_r8+cff)
2788!^
2789 adfac=ad_bio(i,k,ifphy)/(1.0_r8+cff)
2790 ad_cff=ad_cff-bio2(i,k,ifphy)*adfac
2791 ad_bio(i,k,ifphy)=adfac
2792#endif
2793!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)+ &
2794!^ & ZooEED(ng)*(tl_Bio(i,k,iPhyt)*cff+ &
2795!^ & Bio(i,k,iPhyt)*tl_cff)
2796!^
2797 ad_cff=ad_cff+zooeed(ng)*bio(i,k,iphyt)*ad_bio(i,k,isdet)
2798 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2799 & zooeed(ng)*cff*ad_bio(i,k,isdet)
2800!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2801!^ & ZooEEN(ng)*(tl_Bio(i,k,iPhyt)*cff+ &
2802!^ & Bio(i,k,iPhyt)*tl_cff)
2803!^
2804 ad_cff=ad_cff+ &
2805 & zooeen(ng)*bio(i,k,iphyt)*ad_bio(i,k,ino3_)
2806 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2807 & zooeen(ng)*cff*ad_bio(i,k,ino3_)
2808!^ tl_Bio(i,k,iZoop)=tl_Bio(i,k,iZoop)+ &
2809!^ & cff2*(tl_Bio(i,k,iPhyt)*cff+ &
2810!^ & Bio(i,k,iPhyt)*tl_cff)
2811!^
2812 ad_cff=ad_cff+ &
2813 & cff2*bio(i,k,iphyt)*ad_bio(i,k,izoop)
2814 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2815 & cff2*cff*ad_bio(i,k,izoop)
2816!^ tl_Bio(i,k,iPhyt)=(tl_Bio(i,k,iPhyt)- &
2817!^ & tl_cff*Bio(i,k,iPhyt))/ &
2818!^ & (1.0_r8+cff)
2819!^
2820 adfac=ad_bio(i,k,iphyt)/(1.0_r8+cff)
2821 ad_cff=ad_cff-bio(i,k,iphyt)*adfac
2822 ad_bio(i,k,iphyt)=adfac
2823!^ tl_cff=(tl_Bio(i,k,iZoop)* &
2824!^ & cff1*(1.0_r8-EXP(-Ivlev(ng)*Bio1(i,k,iPhyt)))+ &
2825!^ & Bio1(i,k,iZoop)*Ivlev(ng)*tl_Bio(i,k,iPhyt)*cff1* &
2826!^ & EXP(-Ivlev(ng)*Bio1(i,k,iPhyt))- &
2827!^ & tl_Bio(i,k,iPhyt)*cff)/ &
2828!^ & Bio1(i,k,iPhyt)
2829!^
2830 fac=exp(-ivlev(ng)*bio1(i,k,iphyt))
2831 adfac=ad_cff/bio1(i,k,iphyt)
2832 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)-adfac*cff
2833 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2834 & bio1(i,k,izoop)*ivlev(ng)* &
2835 & adfac*cff1*fac
2836 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)+ &
2837 & adfac*cff1*(1.0_r8-fac)
2838 ad_cff=0.0_r8
2839 END DO
2840 END DO
2841!
2842! Compute appropriate basic state arrays I.
2843!
2844 DO k=1,n(ng)
2845 DO i=istr,iend
2846!
2847! At input, all tracers (index nnew) from predictor step have
2848! transport units (m Tunits) since we do not have yet the new
2849! values for zeta and Hz. These are known after the 2D barotropic
2850! time-stepping.
2851!
2852! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
2853! tracer times depth. However the basic state (nstp and nnew
2854! indices) that is read from the forward file is in units of
2855! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
2856! use t instead of t*Hz_inv.
2857!
2858 DO itrc=1,nbt
2859 ibio=idbio(itrc)
2860!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
2861!^
2862 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
2863!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
2864!^
2865 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
2866 END DO
2867!
2868! Impose positive definite concentrations.
2869!
2870 cff2=0.0_r8
2871 DO itime=1,2
2872 cff1=0.0_r8
2873 itrcmax=idbio(1)
2874#ifdef IRON_LIMIT
2875 DO itrc=1,nbt-2
2876#else
2877 DO itrc=1,nbt
2878#endif
2879 ibio=idbio(itrc)
2880 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
2881 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
2882 itrcmax=ibio
2883 END IF
2884 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
2885 END DO
2886 IF (biotrc(itrcmax,itime).gt.cff1) THEN
2887 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
2888 END IF
2889#ifdef IRON_LIMIT
2890 DO itrc=nbt-1,nbt
2891 ibio=idbio(itrc)
2892 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
2893 END DO
2894#endif
2895 END DO
2896!
2897! Load biological tracers into local arrays.
2898!
2899 DO itrc=1,nbt
2900 ibio=idbio(itrc)
2901 bio_old(i,k,ibio)=biotrc(ibio,nstp)
2902 bio(i,k,ibio)=biotrc(ibio,nstp)
2903 END DO
2904
2905#if defined IRON_LIMIT && defined IRON_RELAX
2906!
2907! Relax dissolved iron at coast (h <= FeHim) to a constant value
2908! (FeMax) over a time scale (FeNudgTime; days) to simulate sources
2909! at the shelf.
2910!
2911 IF (h(i,j).le.fehmin(ng)) THEN
2912 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
2913 & fenudgcoef*(femax(ng)-bio(i,k,ifdis))
2914 END IF
2915#endif
2916 END DO
2917 END DO
2918!
2919! Calculate surface Photosynthetically Available Radiation (PAR). The
2920! net shortwave radiation is scaled back to Watts/m2 and multiplied by
2921! the fraction that is photosynthetically available, PARfrac.
2922!
2923 DO i=istr,iend
2924#ifdef CONST_PAR
2925!
2926! Specify constant surface irradiance a la Powell and Spitz.
2927!
2928 parsur(i)=158.075_r8
2929#else
2930 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
2931#endif
2932 END DO
2933!
2934!=======================================================================
2935! Start internal iterations to achieve convergence of the nonlinear
2936! backward-implicit solution.
2937!=======================================================================
2938!
2939 DO iteradj=1,iter
2940!
2941! Compute light attenuation as function of depth.
2942!
2943 DO i=istr,iend
2944 par=parsur(i)
2945 IF (parsur(i).gt.0.0_r8) THEN ! day time
2946 DO k=n(ng),1,-1
2947!
2948! Compute average light attenuation for each grid cell. Here, AttSW is
2949! the light attenuation due to seawater and AttPhy is the attenuation
2950! due to phytoplankton (self-shading coefficient).
2951!
2952 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
2953 & (z_w(i,j,k)-z_w(i,j,k-1))
2954 expatt=exp(-att)
2955 itop=par
2956 par=itop*(1.0_r8-expatt)/att ! average at cell center
2957 light(i,k)=par
2958!
2959! Light attenuation at the bottom of the grid cell. It is the starting
2960! PAR value for the next (deeper) vertical grid cell.
2961!
2962 par=itop*expatt
2963 END DO
2964 ELSE ! night time
2965 DO k=1,n(ng)
2966 light(i,k)=0.0_r8
2967 END DO
2968 END IF
2969 END DO
2970!
2971! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
2972! The Michaelis-Menten curve is used to describe the change in uptake
2973! rate as a function of nitrate concentration. Here, PhyIS is the
2974! initial slope of the P-I curve and K_NO3 is the half saturation of
2975! phytoplankton nitrate uptake.
2976#ifdef IRON_LIMIT
2977!
2978! Growth reduction factors due to iron limitation:
2979!
2980! FNratio current Fe:N ratio [umol-Fe/mmol-N]
2981! FCratio current Fe:C ratio [umol-Fe/mol-C]
2982! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
2983! FCratioE empirical Fe:C ratio
2984! Flimit Phytoplankton growth reduction factor due to Fe
2985! limitation based on Fe:C ratio
2986!
2987#endif
2988!
2989 cff1=dtdays*vm_no3(ng)*phyis(ng)
2990 cff2=vm_no3(ng)*vm_no3(ng)
2991 cff3=phyis(ng)*phyis(ng)
2992 DO k=1,n(ng)
2993 DO i=istr,iend
2994#ifdef IRON_LIMIT
2995!
2996! Calculate growth reduction factor due to iron limitation.
2997!
2998 fnratio=bio(i,k,ifphy)/max(minval,bio(i,k,iphyt))
2999 fcratio=fnratio*fen2fec
3000 fcratioe=b_fe(ng)*bio(i,k,ifdis)**a_fe(ng)
3001 flimit=fcratio*fcratio/ &
3002 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
3003
3004 nlimit=1.0_r8/(k_no3(ng)+bio(i,k,ino3_))
3005 fnlim=min(1.0_r8,flimit/(bio(i,k,ino3_)*nlimit))
3006#endif
3007 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
3008 cff=bio(i,k,iphyt)* &
3009#ifdef IRON_LIMIT
3010 & cff1*cff4*light(i,k)*fnlim*nlimit
3011#else
3012 & cff1*cff4*light(i,k)/ &
3013 & (k_no3(ng)+bio(i,k,ino3_))
3014#endif
3015 bio1(i,k,ino3_)=bio(i,k,ino3_)
3016 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
3017 bio1(i,k,iphyt)=bio(i,k,iphyt)
3018 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
3019 & bio(i,k,ino3_)*cff
3020
3021#ifdef IRON_LIMIT
3022!
3023! Iron uptake proportional to growth.
3024!
3025 fac=cff*bio(i,k,ino3_)*fnratio/ &
3026 & max(minval,bio(i,k,ifdis))
3027 bio1(i,k,ifdis)=bio(i,k,ifdis)
3028 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+fac)
3029 bio2(i,k,ifdis)=bio(i,k,ifdis)
3030 bio1(i,k,ifphy)=bio(i,k,ifphy)
3031 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
3032 & bio(i,k,ifdis)*fac
3033 bio2(i,k,ifphy)=bio(i,k,ifphy)
3034!
3035! Iron uptake to reach appropriate Fe:C ratio.
3036!
3037 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
3038 cff6=bio(i,k,iphyt)*cff5*fec2fen
3039 IF (cff6.ge.0.0_r8) then
3040 cff=cff6/max(minval,bio(i,k,ifdis))
3041 bio(i,k,ifdis)=bio(i,k,ifdis)/(1.0_r8+cff)
3042 bio(i,k,ifphy)=bio(i,k,ifphy)+ &
3043 & bio(i,k,ifdis)*cff
3044 ELSE
3045 cff=-cff6/max(minval,bio(i,k,ifphy))
3046 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
3047 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
3048 & bio(i,k,ifphy)*cff
3049 END IF
3050#endif
3051 END DO
3052 END DO
3053!
3054 IF (iteradj.ne.iter) THEN
3055!
3056! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
3057! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
3058! pool as function of "sloppy feeding" and metabolic processes
3059! (ZooEEN and ZooEED fractions).
3060#ifdef IRON_LIMIT
3061! The lost of phytoplankton to the dissolve iron pool is scale by the
3062! remineralization rate (FeRR).
3063#endif
3064!
3065 cff1=dtdays*zoogr(ng)
3066 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
3067 DO k=1,n(ng)
3068 DO i=istr,iend
3069 cff=bio(i,k,izoop)* &
3070 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
3071 & bio(i,k,iphyt)
3072 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
3073 bio(i,k,izoop)=bio(i,k,izoop)+ &
3074 & bio(i,k,iphyt)*cff2*cff
3075 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
3076 & bio(i,k,iphyt)*zooeen(ng)*cff
3077 bio(i,k,isdet)=bio(i,k,isdet)+ &
3078 & bio(i,k,iphyt)*zooeed(ng)*cff
3079#ifdef IRON_LIMIT
3080 bio(i,k,ifphy)=bio(i,k,ifphy)/(1.0_r8+cff)
3081 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
3082 & bio(i,k,ifphy)*cff*ferr(ng)
3083#endif
3084 END DO
3085 END DO
3086!
3087! Phytoplankton mortality to nutrients (PhyMRNro rate), detritus
3088! (PhyMRD rate), and if applicable dissolved iron (FeRR rate).
3089!
3090 cff3=dtdays*phymrd(ng)
3091 cff2=dtdays*phymrn(ng)
3092 cff1=1.0_r8/(1.0_r8+cff2+cff3)
3093 DO k=1,n(ng)
3094 DO i=istr,iend
3095 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
3096 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
3097 & bio(i,k,iphyt)*cff2
3098 bio(i,k,isdet)=bio(i,k,isdet)+ &
3099 & bio(i,k,iphyt)*cff3
3100#ifdef IRON_LIMIT
3101 bio(i,k,ifphy)=bio(i,k,ifphy)*cff1
3102 bio(i,k,ifdis)=bio(i,k,ifdis)+ &
3103 & bio(i,k,ifphy)*(cff2+cff3)*ferr(ng)
3104#endif
3105 END DO
3106 END DO
3107!
3108! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
3109! (ZooMRD rate).
3110!
3111 cff3=dtdays*zoomrd(ng)
3112 cff2=dtdays*zoomrn(ng)
3113 cff1=1.0_r8/(1.0_r8+cff2+cff3)
3114 DO k=1,n(ng)
3115 DO i=istr,iend
3116 bio(i,k,izoop)=bio(i,k,izoop)*cff1
3117 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
3118 & bio(i,k,izoop)*cff2
3119 bio(i,k,isdet)=bio(i,k,isdet)+ &
3120 & bio(i,k,izoop)*cff3
3121 END DO
3122 END DO
3123!
3124! Detritus breakdown to nutrients: remineralization (DetRR rate).
3125!
3126 cff2=dtdays*detrr(ng)
3127 cff1=1.0_r8/(1.0_r8+cff2)
3128 DO k=1,n(ng)
3129 DO i=istr,iend
3130 bio(i,k,isdet)=bio(i,k,isdet)*cff1
3131 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
3132 & bio(i,k,isdet)*cff2
3133 END DO
3134 END DO
3135!
3136!-----------------------------------------------------------------------
3137! Vertical sinking terms: Phytoplankton and Detritus
3138!-----------------------------------------------------------------------
3139!
3140! Reconstruct vertical profile of selected biological constituents
3141! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
3142! grid box. Then, compute semi-Lagrangian flux due to sinking.
3143!
3144 DO isink=1,nsink
3145 ibio=idsink(isink)
3146!
3147! Copy concentration of biological particulates into scratch array
3148! "qc" (q-central, restrict it to be positive) which is hereafter
3149! interpreted as a set of grid-box averaged values for biogeochemical
3150! constituent concentration.
3151!
3152 DO k=1,n(ng)
3153 DO i=istr,iend
3154 qc(i,k)=bio(i,k,ibio)
3155 END DO
3156 END DO
3157!
3158 DO k=n(ng)-1,1,-1
3159 DO i=istr,iend
3160 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
3161 END DO
3162 END DO
3163 DO k=2,n(ng)-1
3164 DO i=istr,iend
3165 dltr=hz(i,j,k)*fc(i,k)
3166 dltl=hz(i,j,k)*fc(i,k-1)
3167 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
3168 cffr=cff*fc(i,k)
3169 cffl=cff*fc(i,k-1)
3170!
3171! Apply PPM monotonicity constraint to prevent oscillations within the
3172! grid box.
3173!
3174 IF ((dltr*dltl).le.0.0_r8) THEN
3175 dltr=0.0_r8
3176 dltl=0.0_r8
3177 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
3178 dltr=cffl
3179 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
3180 dltl=cffr
3181 END IF
3182!
3183! Compute right and left side values (bR,bL) of parabolic segments
3184! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
3185!
3186! NOTE: Although each parabolic segment is monotonic within its grid
3187! box, monotonicity of the whole profile is not guaranteed,
3188! because bL(k+1)-bR(k) may still have different sign than
3189! qc(i,k+1)-qc(i,k). This possibility is excluded,
3190! after bL and bR are reconciled using WENO procedure.
3191!
3192 cff=(dltr-dltl)*hz_inv3(i,k)
3193 dltr=dltr-cff*hz(i,j,k+1)
3194 dltl=dltl+cff*hz(i,j,k-1)
3195 br(i,k)=qc(i,k)+dltr
3196 bl(i,k)=qc(i,k)-dltl
3197 wr(i,k)=(2.0_r8*dltr-dltl)**2
3198 wl(i,k)=(dltr-2.0_r8*dltl)**2
3199 END DO
3200 END DO
3201 cff=1.0e-14_r8
3202 DO k=2,n(ng)-2
3203 DO i=istr,iend
3204 dltl=max(cff,wl(i,k ))
3205 dltr=max(cff,wr(i,k+1))
3206 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
3207 bl(i,k+1)=br(i,k)
3208 END DO
3209 END DO
3210 DO i=istr,iend
3211 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
3212#if defined LINEAR_CONTINUATION
3213 bl(i,n(ng))=br(i,n(ng)-1)
3214 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
3215#elif defined NEUMANN
3216 bl(i,n(ng))=br(i,n(ng)-1)
3217 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
3218#else
3219 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
3220 bl(i,n(ng))=qc(i,n(ng)) ! conditions
3221 br(i,n(ng)-1)=qc(i,n(ng))
3222#endif
3223#if defined LINEAR_CONTINUATION
3224 br(i,1)=bl(i,2)
3225 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
3226#elif defined NEUMANN
3227 br(i,1)=bl(i,2)
3228 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
3229#else
3230 bl(i,2)=qc(i,1) ! bottom grid boxes are
3231 br(i,1)=qc(i,1) ! re-assumed to be
3232 bl(i,1)=qc(i,1) ! piecewise constant.
3233#endif
3234 END DO
3235!
3236! Apply monotonicity constraint again, since the reconciled interfacial
3237! values may cause a non-monotonic behavior of the parabolic segments
3238! inside the grid box.
3239!
3240 DO k=1,n(ng)
3241 DO i=istr,iend
3242 dltr=br(i,k)-qc(i,k)
3243 dltl=qc(i,k)-bl(i,k)
3244 cffr=2.0_r8*dltr
3245 cffl=2.0_r8*dltl
3246 IF ((dltr*dltl).lt.0.0_r8) THEN
3247 dltr=0.0_r8
3248 dltl=0.0_r8
3249 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
3250 dltr=cffl
3251 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
3252 dltl=cffr
3253 END IF
3254 br(i,k)=qc(i,k)+dltr
3255 bl(i,k)=qc(i,k)-dltl
3256 END DO
3257 END DO
3258!
3259! After this moment reconstruction is considered complete. The next
3260! stage is to compute vertical advective fluxes, FC. It is expected
3261! that sinking may occurs relatively fast, the algorithm is designed
3262! to be free of CFL criterion, which is achieved by allowing
3263! integration bounds for semi-Lagrangian advective flux to use as
3264! many grid boxes in upstream direction as necessary.
3265!
3266! In the two code segments below, WL is the z-coordinate of the
3267! departure point for grid box interface z_w with the same indices;
3268! FC is the finite volume flux; ksource(:,k) is index of vertical
3269! grid box which contains the departure point (restricted by N(ng)).
3270! During the search: also add in content of whole grid boxes
3271! participating in FC.
3272!
3273 cff=dtdays*abs(wbio(isink))
3274 DO k=1,n(ng)
3275 DO i=istr,iend
3276 fc(i,k-1)=0.0_r8
3277 wl(i,k)=z_w(i,j,k-1)+cff
3278 wr(i,k)=hz(i,j,k)*qc(i,k)
3279 ksource(i,k)=k
3280 END DO
3281 END DO
3282 DO k=1,n(ng)
3283 DO ks=k,n(ng)-1
3284 DO i=istr,iend
3285 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
3286 ksource(i,k)=ks+1
3287 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
3288 END IF
3289 END DO
3290 END DO
3291 END DO
3292!
3293! Finalize computation of flux: add fractional part.
3294!
3295 DO k=1,n(ng)
3296 DO i=istr,iend
3297 ks=ksource(i,k)
3298 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
3299 fc(i,k-1)=fc(i,k-1)+ &
3300 & hz(i,j,ks)*cu* &
3301 & (bl(i,ks)+ &
3302 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
3303 & (1.5_r8-cu)* &
3304 & (br(i,ks)+bl(i,ks)- &
3305 & 2.0_r8*qc(i,ks))))
3306 END DO
3307 END DO
3308 DO k=1,n(ng)
3309 DO i=istr,iend
3310 bio(i,k,ibio)=qc(i,k)+ &
3311 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
3312 END DO
3313 END DO
3314 END DO
3315 END IF
3316 END DO
3317!
3318! End of compute basic state arrays I.
3319!
3320! Adjoint Phytoplankton photosynthetic growth and nitrate uptake
3321! (Vm_NO3 rate). The Michaelis-Menten curve is used to describe the
3322! change in uptake rate as a function of nitrate concentration.
3323! Here, PhyIS is the initial slope of the P-I curve and K_NO3 is the
3324! half saturation of phytoplankton nitrate uptake.
3325#ifdef IRON_LIMIT
3326!
3327! Growth reduction factors due to iron limitation:
3328!
3329! FNratio current Fe:N ratio [umol-Fe/mmol-N]
3330! FCratio current Fe:C ratio [umol-Fe/mol-C]
3331! (umol-Fe/mmol-N)*(16 M-N/106 M-C)*(1E3 mmol-C/mol-C)
3332! FCratioE empirical Fe:C ratio
3333! Flimit Phytoplankton growth reduction factor due to Fe
3334! limitation based on Fe:C ratio
3335!
3336#endif
3337!
3338 cff1=dtdays*vm_no3(ng)*phyis(ng)
3339 cff2=vm_no3(ng)*vm_no3(ng)
3340 cff3=phyis(ng)*phyis(ng)
3341 DO k=1,n(ng)
3342 DO i=istr,iend
3343#ifdef IRON_LIMIT
3344!
3345! Adjoint of iron uptake to reach appropriate Fe:C ratio.
3346!
3347 fnratio=bio1(i,k,ifphy)/max(minval,bio1(i,k,iphyt))
3348 fcratio=fnratio*fen2fec
3349 fcratioe=b_fe(ng)*bio1(i,k,ifdis)**a_fe(ng)
3350 flimit=fcratio*fcratio/ &
3351 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
3352
3353 nlimit=1.0_r8/(k_no3(ng)+bio1(i,k,ino3_))
3354 fnlim=min(1.0_r8,flimit/(bio1(i,k,ino3_)*nlimit))
3355
3356 cff5=dtdays*(fcratioe-fcratio)/t_fe(ng)
3357 cff6=bio(i,k,iphyt)*cff5*fec2fen
3358 IF (cff6.ge.0.0_r8) THEN
3359 fac1=max(minval,bio2(i,k,ifdis))
3360 cff=cff6/fac1
3361!^ tl_Bio(i,k,iFphy)=tl_Bio(i,k,iFphy)+ &
3362!^ & tl_Bio(i,k,iFdis)*cff+ &
3363!^ & Bio(i,k,iFdis)*tl_cff
3364!^
3365 ad_bio(i,k,ifdis)=ad_bio(i,k,ifdis)+ &
3366 & cff*ad_bio(i,k,ifphy)
3367 ad_cff=ad_cff+bio(i,k,ifdis)*ad_bio(i,k,ifphy)
3368!^ tl_Bio(i,k,iFdis)=(tl_Bio(i,k,iFdis)- &
3369!^ & tl_cff*Bio(i,k,iFdis))/ &
3370!^ & (1.0_r8+cff)
3371!^
3372 adfac=ad_bio(i,k,ifdis)/(1.0_r8+cff)
3373 ad_cff=ad_cff-bio(i,k,ifdis)*adfac
3374 ad_bio(i,k,ifdis)=adfac
3375!^ tl_cff=(tl_cff6-tl_fac1*cff)/fac1
3376!^
3377 adfac=ad_cff/fac1
3378 ad_cff6=ad_cff6+adfac
3379 ad_fac1=ad_fac1-cff*adfac
3380 ad_cff=0.0_r8
3381!^ tl_fac1=(0.5_r8-SIGN(0.5_r8,MinVal-Bio2(i,k,iFdis)))* &
3382!^ & tl_Bio(i,k,iFdis)
3383!^
3384 ad_bio(i,k,ifdis)=ad_bio(i,k,ifdis)+ &
3385 & (0.5_r8- &
3386 & sign(0.5_r8, &
3387 & minval-bio2(i,k,ifdis)))*ad_fac1
3388 ad_fac1=0.0_r8
3389 ELSE
3390 fac1=-max(minval,bio2(i,k,ifphy))
3391 cff=cff6/fac1
3392!^ tl_Bio(i,k,iFdis)=tl_Bio(i,k,iFdis)+ &
3393!^ & tl_Bio(i,k,iFphy)*cff+ &
3394!^ & Bio(i,k,iFphy)*tl_cff
3395!^
3396 ad_bio(i,k,ifphy)=ad_bio(i,k,ifphy)+ &
3397 & cff*ad_bio(i,k,ifdis)
3398 ad_cff=ad_cff+bio(i,k,ifphy)*ad_bio(i,k,ifdis)
3399!^ tl_Bio(i,k,iFphy)=(tl_Bio(i,k,iFphy)- &
3400!^ & tl_cff*Bio(i,k,iFphy))/ &
3401!^ & (1.0_r8+cff)
3402!^
3403 adfac=ad_bio(i,k,ifphy)/(1.0_r8+cff)
3404 ad_cff=ad_cff-bio(i,k,ifphy)*adfac
3405 ad_bio(i,k,ifphy)=adfac
3406!^ tl_cff=(tl_cff6-tl_fac1*cff)/fac1
3407!^
3408 adfac=ad_cff/fac1
3409 ad_cff6=ad_cff6+adfac
3410 ad_fac1=ad_fac1-cff*adfac
3411 ad_cff=0.0_r8
3412!^ tl_fac1=-(0.5_r8-SIGN(0.5_r8,MinVal-Bio2(i,k,iFphy)))* &
3413!^ & tl_Bio(i,k,iFphy)
3414!^
3415 ad_bio(i,k,ifphy)=ad_bio(i,k,ifphy)- &
3416 & (0.5_r8- &
3417 & sign(0.5_r8, &
3418 & minval-bio2(i,k,ifphy)))*ad_fac1
3419 ad_fac1=0.0_r8
3420 END IF
3421!^ tl_cff6=(tl_Bio(i,k,iPhyt)*cff5+ &
3422!^ & Bio(i,k,iPhyt)*tl_cff5)*FeC2FeN
3423!^
3424 adfac=ad_cff6*fec2fen
3425 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+cff5*adfac
3426 ad_cff5=ad_cff5+bio(i,k,iphyt)*adfac
3427 ad_cff6=0.0_r8
3428!^ tl_cff5=dtdays*(tl_FCratioE-tl_FCratio)/T_Fe(ng)
3429!^
3430 adfac=dtdays*ad_cff5/t_fe(ng)
3431 ad_fcratioe=ad_fcratioe+adfac
3432 ad_fcratio=ad_fcratio-adfac
3433 ad_cff5=0.0_r8
3434#endif
3435 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
3436 cff=bio1(i,k,iphyt)* &
3437#ifdef IRON_LIMIT
3438 & cff1*cff4*light(i,k)*fnlim*nlimit
3439#else
3440 & cff1*cff4*light(i,k)/ &
3441 & (k_no3(ng)+bio1(i,k,ino3_))
3442#endif
3443#ifdef IRON_LIMIT
3444!
3445! Iron uptake proportional to growth.
3446!
3447 fac1=max(minval,bio1(i,k,ifdis))
3448 fac2=1.0_r8/fac1
3449 fac=cff*bio(i,k,ino3_)*fnratio*fac2
3450!^ tl_Bio(i,k,iFphy)=tl_Bio(i,k,iFphy)+ &
3451!^ & tl_Bio(i,k,iFdis)*fac+ &
3452!^ & Bio2(i,k,iFdis)*tl_fac
3453!^
3454 ad_fac=ad_fac+bio2(i,k,ifdis)*ad_bio(i,k,ifphy)
3455 ad_bio(i,k,ifdis)=ad_bio(i,k,ifdis)+ &
3456 & fac*ad_bio(i,k,ifphy)
3457!^ tl_Bio(i,k,iFdis)=(tl_Bio(i,k,iFdis)- &
3458!^ & tl_fac*Bio2(i,k,iFdis))/ &
3459!^ & (1.0_r8+fac)
3460!^
3461 adfac=ad_bio(i,k,ifdis)/(1.0_r8+fac)
3462 ad_fac=ad_fac-bio2(i,k,ifdis)*adfac
3463 ad_bio(i,k,ifdis)=adfac
3464!^ tl_fac=FNratio*fac2*(tl_cff*Bio(i,k,iNO3_)+ &
3465!^ & cff*ad_Bio(i,k,iNO3_))+ &
3466!^ & cff*Bio(i,k,iNO3_)*(tl_FNratio*fac2+ &
3467!^ & FNratio*tl_fac2)
3468!^
3469 adfac1=fnratio*fac2*ad_fac
3470 adfac2=cff*bio(i,k,ino3_)*ad_fac
3471 ad_cff=ad_cff+bio(i,k,ino3_)*adfac1
3472 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)+cff*adfac1
3473 ad_fnratio=ad_fnratio+fac2*adfac2
3474 ad_fac2=ad_fac2+fnratio*adfac2
3475 ad_fac=0.0_r8
3476!^ tl_fac2=-fac2*fac2*tl_fac1
3477!^
3478 ad_fac1=ad_fac1-fac2*fac2*ad_fac2
3479 ad_fac2=0.0_r8
3480!^ tl_fac1=(0.5_r8-SIGN(0.5_r8,MinVal-Bio1(i,k,iFdis)))* &
3481!^ & tl_Bio(i,k,iFdis)
3482!^
3483 ad_bio(i,k,ifdis)=ad_bio(i,k,ifdis)+ &
3484 & (0.5_r8- &
3485 & sign(0.5_r8,minval-bio1(i,k,ifdis)))* &
3486 & ad_fac1
3487 ad_fac1=0.0_r8
3488#endif
3489!
3490! Adjoint of phytoplankton photosynthetic growth and nitrate uptake.
3491!
3492!^ tl_Bio(i,k,iPhyt)=tl_Bio(i,k,iPhyt)+ &
3493!^ & tl_Bio(i,k,iNO3_)*cff+ &
3494!^ & Bio(i,k,iNO3_)*tl_cff
3495!^
3496 ad_cff=ad_cff+bio(i,k,ino3_)*ad_bio(i,k,iphyt)
3497 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)+ &
3498 & cff*ad_bio(i,k,iphyt)
3499!^ tl_Bio(i,k,iNO3_)=(tl_Bio(i,k,iNO3_)- &
3500!^ & tl_cff*Bio(i,k,iNO3_))/ &
3501!^ & (1.0_r8+cff)
3502!^
3503 adfac=ad_bio(i,k,ino3_)/(1.0_r8+cff)
3504 ad_cff=ad_cff-bio(i,k,ino3_)*adfac
3505 ad_bio(i,k,ino3_)=adfac
3506
3507#ifdef IRON_LIMIT
3508!^ tl_cff=tl_Bio(i,k,iPhyt)* &
3509!^ & cff1*cff4*Light(i,k)*FNlim*Nlimit+ &
3510!^ & Bio1(i,k,iPhyt)*cff1*cff4* &
3511!^ & (tl_Light(i,k)*FNlim*Nlimit+ &
3512!^ & Light(i,k)*tl_FNlim*Nlimit+ &
3513!^ & Light(i,k)*FNlim*tl_Nlimit)+ &
3514!^ & Bio1(i,k,iPhyt)*cff1*tl_cff4* &
3515!^ & Light(i,k)*FNlim*Nlimit
3516!^
3517 adfac1=cff1*cff4*ad_cff
3518 adfac2=adfac1*bio1(i,k,iphyt)
3519 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
3520 & light(i,k)*fnlim*nlimit*adfac1
3521 ad_light(i,k)=ad_light(i,k)+ &
3522 & fnlim*nlimit*adfac2
3523 ad_fnlim=ad_fnlim+ &
3524 & light(i,k)*nlimit*adfac2
3525 ad_nlimit=ad_nlimit+ &
3526 & light(i,k)*fnlim*adfac2
3527 ad_cff4=ad_cff4+ &
3528 & bio1(i,k,iphyt)*cff1*light(i,k)*fnlim*nlimit* &
3529 & ad_cff
3530 ad_cff=0.0_r8
3531#else
3532!^ tl_cff=(tl_Bio(i,k,iPhyt)*cff1*cff4*Light(i,k)+ &
3533!^ & Bio1(i,k,iPhyt)*cff1* &
3534!^ & (tl_cff4*Light(i,k)+cff4*tl_Light(i,k))- &
3535!^ & tl_Bio(i,k,iNO3_)*cff)/ &
3536!^ & (K_NO3(ng)+Bio1(i,k,iNO3_))
3537!^
3538 adfac=ad_cff/(k_no3(ng)+bio1(i,k,ino3_))
3539 adfac1=adfac*bio1(i,k,iphyt)*cff1
3540 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
3541 & cff1*cff4*light(i,k)*adfac
3542 ad_cff4=adfac1*light(i,k)
3543 ad_light(i,k)=ad_light(i,k)+ &
3544 & adfac1*cff4
3545 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)- &
3546 & adfac*cff
3547 ad_cff=0.0_r8
3548#endif
3549!^ tl_cff4=-cff3*tl_Light(i,k)*Light(i,k)*cff4*cff4*cff4
3550!^
3551 ad_light(i,k)=ad_light(i,k)- &
3552 & cff3*light(i,k)* &
3553 & cff4*cff4*cff4*ad_cff4
3554 ad_cff4=0.0_r8
3555
3556#ifdef IRON_LIMIT
3557!
3558! Adjoint of calculate growth reduction factor due to iron limitation.
3559!
3560 nlimit=1.0_r8/(k_no3(ng)+bio1(i,k,ino3_))
3561 fac1=flimit/(bio1(i,k,ino3_)*nlimit)
3562!^ tl_FNlim=(0.5_r8+SIGN(0.5_r8,1.0_r8-fac1))*tl_fac1
3563!^
3564 ad_fac1=(0.5_r8+sign(0.5_r8,1.0_r8-fac1))*ad_fnlim
3565 ad_fnlim=0.0_r8
3566!^ tl_fac1=tl_Flimit/(Bio1(i,k,iNO3_)*Nlimit)- &
3567!^ & (tl_Bio(i,k,iNO3_)*Nlimit+ &
3568!^ & Bio1(i,k,iNO3_)*tl_Nlimit)*fac1/ &
3569!^ & (Bio1(i,k,iNO3_)*Nlimit)
3570!^
3571 adfac1=ad_fac1/(bio1(i,k,ino3_)*nlimit)
3572 adfac2=adfac1*fac1
3573 ad_flimit=ad_flimit+adfac1
3574 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)-nlimit*adfac2
3575 ad_nlimit=ad_nlimit-bio1(i,k,ino3_)*adfac2
3576 ad_fac1=0.0_r8
3577!^ tl_Nlimit=-tl_Bio(i,k,iNO3_)*Nlimit*Nlimit
3578!^
3579 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)- &
3580 & ad_nlimit*nlimit*nlimit
3581 ad_nlimit=0.0_r8
3582!^ tl_Flimit=2.0_r8*(tl_FCratio*FCratio- &
3583!^ & tl_FCratio*FCratio*Flimit)/ &
3584!^ & (FCratio*FCratio+K_FeC(ng)*K_FeC(ng))
3585!^
3586 adfac=2.0_r8*ad_flimit/ &
3587 & (fcratio*fcratio+k_fec(ng)*k_fec(ng))
3588 ad_fcratio=ad_fcratio+ &
3589 & fcratio*adfac- &
3590 & fcratio*flimit*adfac
3591 ad_flimit=0.0_r8
3592!^ tl_FCratioE=A_Fe(ng)*B_Fe(ng)* &
3593!^ & Bio1(i,k,iFdis)**(A_Fe(ng)-1.0_r8)* &
3594!^ & tl_Bio(i,k,iFdis)
3595!^
3596 ad_bio(i,k,ifdis)=ad_bio(i,k,ifdis)+ &
3597 & a_fe(ng)*b_fe(ng)* &
3598 & bio1(i,k,ifdis)**(a_fe(ng)-1.0_r8)* &
3599 & ad_fcratioe
3600 ad_fcratioe=0.0_r8
3601!^ tl_FCratio=tl_FNratio*FeN2FeC
3602!^
3603 ad_fnratio=ad_fnratio+fen2fec*ad_fcratio
3604 ad_fcratio=0.0_r8
3605
3606 fac1=max(minval,bio1(i,k,iphyt))
3607!^ tl_FNratio=(tl_Bio(i,k,iFphy)-tl_fac1*FNratio)/fac1
3608!^
3609 adfac=ad_fnratio/fac1
3610 ad_bio(i,k,ifphy)=ad_bio(i,k,ifphy)+adfac
3611 ad_fac1=ad_fac1-ad_fnratio*fnratio/fac1
3612 ad_fnratio=0.0_r8
3613!^ tl_fac1=(0.5_r8-SIGN(0.5_r8,MinVal-Bio1(i,k,iPhyt)))* &
3614!^ & tl_Bio(i,k,iPhyt)
3615!^
3616 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
3617 & (0.5_r8- &
3618 & sign(0.5_r8,minval-bio1(i,k,iphyt)))* &
3619 & ad_fac1
3620 ad_fac1=0.0_r8
3621#endif
3622 END DO
3623 END DO
3624!
3625! Compute adjoint light attenuation as function of depth.
3626!
3627 DO i=istr,iend
3628 par=parsur(i)
3629 IF (parsur(i).gt.0.0_r8) THEN ! day time
3630 DO k=1,n(ng)
3631!
3632! Compute the basic state PAR appropriate for each level.
3633!
3634 par=parsur(i)
3635 DO kk=n(ng),k,-1
3636!
3637! Compute average light attenuation for each grid cell. Here, AttSW is
3638! the light attenuation due to seawater and AttPhy is the attenuation
3639! due to phytoplankton (self-shading coefficient).
3640!
3641 att=(attsw(ng)+attphy(ng)*bio1(i,kk,iphyt))* &
3642 & (z_w(i,j,kk)-z_w(i,j,kk-1))
3643 expatt=exp(-att)
3644 itop=par
3645 par=itop*(1.0_r8-expatt)/att ! average at cell center
3646 par1=par
3647!
3648! Light attenuation at the bottom of the grid cell. It is the starting
3649! PAR value for the next (deeper) vertical grid cell.
3650!
3651 par=itop*expatt
3652 END DO
3653!
3654! Adjoint of light attenuation at the bottom of the grid cell. It is
3655! the starting PAR value for the next (deeper) vertical grid cell.
3656!
3657!^ tl_PAR=tl_Itop*ExpAtt+Itop*tl_ExpAtt
3658!^
3659 ad_expatt=ad_expatt+itop*ad_par
3660 ad_itop=ad_itop+expatt*ad_par
3661 ad_par=0.0_r8
3662!
3663! Adjoint of compute average light attenuation for each grid cell.
3664! Here, AttSW is the light attenuation due to seawater and AttPhy is
3665! the attenuation due to phytoplankton (self-shading coefficient).
3666!
3667!^ tl_Light(i,k)=tl_PAR
3668!^
3669 ad_par=ad_par+ad_light(i,k)
3670 ad_light(i,k)=0.0_r8
3671!^ tl_PAR=(-tl_Att*PAR1+tl_Itop*(1.0_r8-ExpAtt)- &
3672!^ & Itop*tl_ExpAtt)/Att
3673!^
3674 adfac=ad_par/att
3675 ad_att=ad_att-par1*adfac
3676 ad_expatt=ad_expatt-itop*adfac
3677 ad_itop=ad_itop+(1.0_r8-expatt)*adfac
3678 ad_par=0.0_r8
3679!^ tl_Itop=tl_PAR
3680!^
3681 ad_par=ad_par+ad_itop
3682 ad_itop=0.0_r8
3683!^ tl_ExpAtt=-ExpAtt*tl_Att
3684!^
3685 ad_att=ad_att-expatt*ad_expatt
3686 ad_expatt=0.0_r8
3687!^ tl_Att=AttPhy(ng)*tl_Bio(i,k,iPhyt)* &
3688!^ & (z_w(i,j,k)-z_w(i,j,k-1))+ &
3689!^ & (AttSW(ng)+AttPhy(ng)*Bio1(i,k,iPhyt))* &
3690!^ & (tl_z_w(i,j,k)-tl_z_w(i,j,k-1))
3691!^
3692 adfac=(attsw(ng)+attphy(ng)*bio1(i,k,iphyt))*ad_att
3693 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
3694 & attphy(ng)*(z_w(i,j,k)-z_w(i,j,k-1))* &
3695 & ad_att
3696 ad_z_w(i,j,k-1)=ad_z_w(i,j,k-1)-adfac
3697 ad_z_w(i,j,k )=ad_z_w(i,j,k )+adfac
3698 ad_att=0.0_r8
3699 END DO
3700 ELSE ! night time
3701 DO k=1,n(ng)
3702!^ tl_Light(i,k)=0.0_r8
3703!^
3704 ad_light(i,k)=0.0_r8
3705 END DO
3706 END IF
3707!^ tl_PAR=tl_PARsur(i)
3708!^
3709 ad_parsur(i)=ad_parsur(i)+ad_par
3710 ad_par=0.0_r8
3711 END DO
3712
3713 END DO iter_loop1
3714!
3715! Calculate adjoint surface Photosynthetically Available Radiation
3716! (PAR). The net shortwave radiation is scaled back to Watts/m2
3717! and multiplied by the fraction that is photosynthetically
3718! available, PARfrac.
3719!
3720 DO i=istr,iend
3721#ifdef CONST_PAR
3722!
3723! Specify constant surface irradiance a la Powell and Spitz.
3724!
3725!^ tl_PARsur(i)=0.0_r8
3726!^
3727!! ad_PARsur(i)=0.0_r8
3728#else
3729!^ tl_PARsur(i)=(tl_PARfrac(ng)*srflx(i,j)+ &
3730!^ & PARfrac(ng)*tl_srflx(i,j))*rho0*Cp
3731!^
3732 adfac=rho0*cp*ad_parsur(i)
3733 ad_srflx(i,j)=ad_srflx(i,j)+parfrac(ng)*adfac
3734 ad_parfrac(ng)=ad_parfrac(ng)+srflx(i,j)*adfac
3735!! ad_PARsur(i)=0.0_r8
3736#endif
3737 END DO
3738!
3739! Restrict biological tracer to be positive definite. If a negative
3740! concentration is detected, nitrogen is drawn from the most abundant
3741! pool to supplement the negative pools to a lower limit of MinVal
3742! which is set to 1E-6 above.
3743!
3744 DO k=1,n(ng)
3745 DO i=istr,iend
3746
3747#if defined IRON_LIMIT && defined IRON_RELAX
3748!
3749! Adjoint of relax dissolved iron at coast (h <= FeHim) to a constant
3750! value (FeMax) over a time scale (FeNudgTime; days) to simulate
3751! sources at the shelf.
3752!
3753 IF (h(i,j).le.fehmin(ng)) THEN
3754!^ tl_Bio(i,k,iFdis)=tl_Bio(i,k,iFdis)- &
3755!^ & FeNudgCoef*tl_Bio(i,k,iFdis)
3756!^
3757 ad_bio(i,k,ifdis)=ad_bio(i,k,ifdis)- &
3758 & fenudgcoef*ad_bio(i,k,ifdis)
3759 END IF
3760#endif
3761!
3762! Adjoint load biological tracers into local arrays.
3763!
3764 DO itrc=1,nbt
3765 ibio=idbio(itrc)
3766!^ tl_Bio(i,k,ibio)=tl_BioTrc(ibio,nstp)
3767!^
3768 ad_biotrc(ibio,nstp)=ad_biotrc(ibio,nstp)+ &
3769 & ad_bio(i,k,ibio)
3770 ad_bio(i,k,ibio)=0.0_r8
3771!^ tl_Bio_old(i,k,ibio)=tl_BioTrc(ibio,nstp)
3772!^
3773 ad_biotrc(ibio,nstp)=ad_biotrc(ibio,nstp)+ &
3774 & ad_bio_old(i,k,ibio)
3775 ad_bio_old(i,k,ibio)=0.0_r8
3776 END DO
3777!
3778! Adjoint positive definite concentrations.
3779!
3780 DO itime=1,2
3781 DO itrc=1,nbt
3782 ibio=idbio(itrc)
3783!
3784! The basic state (nstp and nnew indices) that is read from the
3785! forward file is in units of tracer. Since BioTrc(ibio,:) is in
3786! tracer units, we simply use t instead of t*Hz_inv.
3787!
3788 biotrc(ibio,itime)=t(i,j,k,itime,ibio)
3789 biotrc1(ibio,itime)=biotrc(ibio,itime)
3790 END DO
3791 END DO
3792!
3793 cff2=0.0_r8
3794 DO itime=1,2
3795 cff1=0.0_r8
3796 itrcmax=idbio(1)
3797#ifdef IRON_LIMIT
3798 DO itrc=1,nbt-2
3799#else
3800 DO itrc=1,nbt
3801#endif
3802 ibio=idbio(itrc)
3803 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
3804 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
3805 itrcmax=ibio
3806 END IF
3807 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
3808 END DO
3809 IF (biotrc(itrcmax,itime).gt.cff1) THEN
3810 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
3811 END IF
3812
3813#ifdef IRON_LIMIT
3814 DO itrc=nbt-1,nbt
3815 ibio=idbio(itrc)
3816 biotrc(ibio,itime)=max(minval,biotrc1(ibio,itime))
3817!^ tl_BioTrc(ibio,itime)=(0.5_r8- &
3818!^ & SIGN(0.5_r8, &
3819!^ & MinVal- &
3820!^ & BioTrc1(ibio,itime)))* &
3821!^ & tl_BioTrc(ibio,itime)
3822!^
3823 ad_biotrc(ibio,itime)=(0.5_r8- &
3824 & sign(0.5_r8, &
3825 & minval- &
3826 & biotrc1(ibio,itime)))* &
3827 & ad_biotrc(ibio,itime)
3828 END DO
3829#endif
3830!
3831! Recompute BioTrc again because iTrcMax has changed.
3832!
3833 cff1=0.0_r8
3834 itrcmax=idbio(1)
3835#ifdef IRON_LIMIT
3836 DO itrc=1,nbt-2
3837#else
3838 DO itrc=1,nbt
3839#endif
3840 ibio=idbio(itrc)
3841!
3842! The basic state (nstp and nnew indices) that is read from the
3843! forward file is in units of tracer. Since BioTrc(ibio,:) is in
3844! tracer units, we simply use t instead of t*Hz_inv.
3845!
3846 biotrc(ibio,itime)=t(i,j,k,itime,ibio)
3847 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
3848 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
3849 itrcmax=ibio
3850 END IF
3851 biotrc1(ibio,itime)=biotrc(ibio,itime)
3852 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
3853 END DO
3854 IF (biotrc(itrcmax,itime).gt.cff1) THEN
3855!^ tl_BioTrc(iTrcMax,itime)=tl_BioTrc(iTrcMax,itime)- &
3856!^ & tl_cff1
3857!^
3858 ad_cff1=-ad_biotrc(itrcmax,itime)
3859 END IF
3860
3861 cff1=0.0_r8
3862#ifdef IRON_LIMIT
3863 DO itrc=1,nbt-2
3864#else
3865 DO itrc=1,nbt
3866#endif
3867 ibio=idbio(itrc)
3868!
3869! The basic state (nstp and nnew indices) that is read from the
3870! forward file is in units of tracer. Since BioTrc(ibio,:) is in
3871! tracer units, we simply use t instead of t*Hz_inv.
3872!
3873 biotrc(ibio,itime)=t(i,j,k,itime,ibio)
3874 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
3875!^ tl_BioTrc(ibio,itime)=(0.5_r8- &
3876!^ & SIGN(0.5_r8, &
3877!^ & MinVal- &
3878!^ & BioTrc1(ibio,itime)))* &
3879!^ & tl_BioTrc(ibio,itime)
3880!^
3881 ad_biotrc(ibio,itime)=(0.5_r8- &
3882 & sign(0.5_r8, &
3883 & minval- &
3884 & biotrc1(ibio,itime)))* &
3885 & ad_biotrc(ibio,itime)
3886!^ tl_cff1=tl_cff1- &
3887!^ & (0.5_r8-SIGN(0.5_r8, &
3888!^ & BioTrc(ibio,itime)-MinVal))* &
3889!^ & tl_BioTrc(ibio,itime)
3890!^
3891 ad_biotrc(ibio,itime)=ad_biotrc(ibio,itime)- &
3892 & (0.5_r8-sign(0.5_r8, &
3893 & biotrc(ibio,itime)- &
3894 & minval))*ad_cff1
3895 END DO
3896 ad_cff1=0.0_r8
3897 END DO
3898!
3899! At input, all tracers (index nnew) from predictor step have
3900! transport units (m Tunits) since we do not have yet the new
3901! values for zeta and Hz. These are known after the 2D barotropic
3902! time-stepping.
3903!
3904! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
3905! tracer times depth. However the basic state (nstp and nnew
3906! indices) that is read from the forward file is in units of
3907! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
3908! use t instead of t*Hz_inv.
3909!
3910 DO itrc=1,nbt
3911 ibio=idbio(itrc)
3912!^ tl_BioTrc(ibio,nnew)=tl_t(i,j,k,nnew,ibio)* &
3913!^ & Hz_inv(i,k)+ &
3914!^ & t(i,j,k,nnew,ibio)*Hz(i,j,k)* &
3915!^ & tl_Hz_inv(i,k)
3916!^
3917 ad_hz_inv(i,k)=ad_hz_inv(i,k)+ &
3918 & t(i,j,k,nnew,ibio)*hz(i,j,k)* &
3919 & ad_biotrc(ibio,nnew)
3920 ad_t(i,j,k,nnew,ibio)=ad_t(i,j,k,nnew,ibio)+ &
3921 & hz_inv(i,k)*ad_biotrc(ibio,nnew)
3922 ad_biotrc(ibio,nnew)=0.0_r8
3923!^ tl_BioTrc(ibio,nstp)=tl_t(i,j,k,nstp,ibio)
3924!^
3925 ad_t(i,j,k,nstp,ibio)=ad_t(i,j,k,nstp,ibio)+ &
3926 & ad_biotrc(ibio,nstp)
3927 ad_biotrc(ibio,nstp)=0.0_r8
3928 END DO
3929 END DO
3930 END DO
3931!
3932! Adjoint inverse thickness to avoid repeated divisions.
3933!
3934 DO k=2,n(ng)-1
3935 DO i=istr,iend
3936!^ tl_Hz_inv3(i,k)=-Hz_inv3(i,k)*Hz_inv3(i,k)* &
3937!^ & (tl_Hz(i,j,k-1)+tl_Hz(i,j,k)+ &
3938!^ & tl_Hz(i,j,k+1))
3939!^
3940 adfac=hz_inv3(i,k)*hz_inv3(i,k)*ad_hz_inv3(i,k)
3941 ad_hz(i,j,k-1)=ad_hz(i,j,k-1)-adfac
3942 ad_hz(i,j,k )=ad_hz(i,j,k )-adfac
3943 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)-adfac
3944 ad_hz_inv3(i,k)=0.0_r8
3945 END DO
3946 END DO
3947 DO k=1,n(ng)-1
3948 DO i=istr,iend
3949!^ tl_Hz_inv2(i,k)=-Hz_inv2(i,k)*Hz_inv2(i,k)* &
3950!^ & (tl_Hz(i,j,k)+tl_Hz(i,j,k+1))
3951!^
3952 adfac=hz_inv2(i,k)*hz_inv2(i,k)*ad_hz_inv2(i,k)
3953 ad_hz(i,j,k )=ad_hz(i,j,k )-adfac
3954 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)-adfac
3955 ad_hz_inv2(i,k)=0.0_r8
3956 END DO
3957 END DO
3958 DO k=1,n(ng)
3959 DO i=istr,iend
3960!^ tl_Hz_inv(i,k)=-Hz_inv(i,k)*Hz_inv(i,k)*tl_Hz(i,j,k)
3961!^
3962 ad_hz(i,j,k)=ad_hz(i,j,k)- &
3963 & hz_inv(i,k)*hz_inv(i,k)*ad_hz_inv(i,k)
3964 ad_hz_inv(i,k)=0.0_r8
3965 END DO
3966 END DO
3967
3968 END DO j_loop
3969!
3970! Set adjoint vertical sinking velocity vector in the same order as the
3971! identification vector, IDSINK.
3972!
3973!^ tl_Wbio(2)=tl_wDet(ng) ! Small detritus
3974!^
3975 ad_wdet(ng)=ad_wdet(ng)+ad_wbio(2)
3976 ad_wbio(2)=0.0_r8
3977!^ tl_Wbio(1)=tl_wPhy(ng) ! Phytoplankton
3978!^
3979 ad_wphy(ng)=ad_wphy(ng)+ad_wbio(1)
3980 ad_wbio(1)=0.0_r8
3981
3982 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::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::ad_parfrac
real(r8), dimension(:), allocatable ad_parfrac
Definition npzd_iron_mod.h:99
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_biology::ad_wphy
real(r8), dimension(:), allocatable ad_wphy
Definition npzd_iron_mod.h:117
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::ad_parfrac, mod_biology::ad_wdet, mod_biology::ad_wphy, 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::vm_no3, mod_biology::wdet, mod_biology::wphy, mod_biology::zooeed, mod_biology::zooeen, mod_biology::zoogr, mod_biology::zoomrd, and mod_biology::zoomrn.

◆ ad_npzd_powell_tile()

subroutine ad_biology_mod::ad_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(inout) ad_hz,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) z_r,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk), intent(in) ad_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(inout) ad_z_w,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) srflx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_srflx,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) t,
real(r8), dimension(lbi:ubi,lbj:ubj,ubk,3,ubt), intent(inout) ad_t )
private

Definition at line 93 of file ad_npzd_Powell.h.

104!-----------------------------------------------------------------------
105!
106 USE mod_param
107 USE mod_biology
108 USE mod_ncparam
109 USE mod_scalars
110!
111! Imported variable declarations.
112!
113 integer, intent(in) :: ng, tile
114 integer, intent(in) :: LBi, UBi, LBj, UBj, UBk, UBt
115 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
116 integer, intent(in) :: nstp, nnew
117
118#ifdef ASSUMED_SHAPE
119# ifdef MASKING
120 real(r8), intent(in) :: rmask(LBi:,LBj:)
121# endif
122 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
123 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
124 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
125 real(r8), intent(in) :: srflx(LBi:,LBj:)
126 real(r8), intent(inout) :: t(LBi:,LBj:,:,:,:)
127
128 real(r8), intent(inout) :: ad_Hz(LBi:,LBj:,:)
129 real(r8), intent(in) :: ad_z_r(LBi:,LBj:,:)
130 real(r8), intent(inout) :: ad_z_w(LBi:,LBj:,0:)
131 real(r8), intent(inout) :: ad_srflx(LBi:,LBj:)
132 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
133#else
134# ifdef MASKING
135 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
136# endif
137 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,UBk)
138 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,UBk)
139 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:UBk)
140 real(r8), intent(in) :: srflx(LBi:UBi,LBj:UBj)
141 real(r8), intent(inout) :: t(LBi:UBi,LBj:UBj,UBk,3,UBt)
142
143 real(r8), intent(inout) :: ad_Hz(LBi:UBi,LBj:UBj,UBk)
144 real(r8), intent(in) :: ad_z_r(LBi:UBi,LBj:UBj,UBk)
145 real(r8), intent(inout) :: ad_z_w(LBi:UBi,LBj:UBj,0:UBk)
146 real(r8), intent(inout) :: ad_srflx(LBi:UBi,LBj:UBj)
147 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,UBk,3,UBt)
148#endif
149!
150! Local variable declarations.
151!
152 integer, parameter :: Nsink = 2
153
154 integer :: Iter, i, ibio, isink, itime, itrc, iTrcMax, j, k, ks
155 integer :: Iteradj, kk
156
157 integer, dimension(Nsink) :: idsink
158
159 real(r8), parameter :: MinVal = 1.0e-6_r8
160
161 real(r8) :: Att, ExpAtt, Itop, PAR, PAR1
162 real(r8) :: ad_Att, ad_ExpAtt, ad_Itop, ad_PAR
163 real(r8) :: cff, cff1, cff2, cff3, cff4, dtdays
164 real(r8) :: ad_cff, ad_cff1, ad_cff4
165 real(r8) :: cffL, cffR, cu, dltL, dltR
166 real(r8) :: ad_cffL, ad_cffR, ad_cu, ad_dltL, ad_dltR
167 real(r8) :: fac, adfac, adfac1, adfac2, adfac3
168
169 real(r8), dimension(Nsink) :: Wbio
170 real(r8), dimension(Nsink) :: ad_Wbio
171
172 integer, dimension(IminS:ImaxS,N(ng)) :: ksource
173
174 real(r8), dimension(IminS:ImaxS) :: PARsur
175 real(r8), dimension(IminS:ImaxS) :: ad_PARsur
176
177 real(r8), dimension(NT(ng),2) :: BioTrc
178 real(r8), dimension(NT(ng),2) :: BioTrc1
179 real(r8), dimension(NT(ng),2) :: ad_BioTrc
180 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio
181 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio1
182 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: Bio_old
183
184 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: ad_Bio
185 real(r8), dimension(IminS:ImaxS,N(ng),NT(ng)) :: ad_Bio_old
186
187 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
188 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: ad_FC
189
190 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv
191 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv2
192 real(r8), dimension(IminS:ImaxS,N(ng)) :: Hz_inv3
193 real(r8), dimension(IminS:ImaxS,N(ng)) :: Light
194 real(r8), dimension(IminS:ImaxS,N(ng)) :: WL
195 real(r8), dimension(IminS:ImaxS,N(ng)) :: WR
196 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL
197 real(r8), dimension(IminS:ImaxS,N(ng)) :: bL1
198 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR
199 real(r8), dimension(IminS:ImaxS,N(ng)) :: bR1
200 real(r8), dimension(IminS:ImaxS,N(ng)) :: qc
201
202 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Hz_inv
203 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Hz_inv2
204 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Hz_inv3
205 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_Light
206 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_WL
207 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_WR
208 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_bL
209 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_bR
210 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_qc
211
212#include "set_bounds.h"
213!
214!-----------------------------------------------------------------------
215! Add biological Source/Sink terms.
216!-----------------------------------------------------------------------
217!
218! Avoid computing source/sink terms if no biological iterations.
219!
220 IF (bioiter(ng).le.0) RETURN
221!
222! Set time-stepping size (days) according to the number of iterations.
223!
224 dtdays=dt(ng)*sec2day/real(bioiter(ng),r8)
225!
226! Set vertical sinking indentification vector.
227!
228 idsink(1)=iphyt ! Phytoplankton
229 idsink(2)=isdet ! Small detritus
230!
231! Set vertical sinking velocity vector in the same order as the
232! identification vector, IDSINK.
233!
234 wbio(1)=wphy(ng) ! Phytoplankton
235 wbio(2)=wdet(ng) ! Small detritus
236!
237 ad_wbio(1)=0.0_r8
238 ad_wbio(2)=0.0_r8
239!
240 j_loop : DO j=jstr,jend
241!
242!-----------------------------------------------------------------------
243! Initialize adjoint private variables.
244!-----------------------------------------------------------------------
245!
246 ad_att=0.0_r8
247 ad_expatt=0.0_r8
248 ad_itop=0.0_r8
249 ad_par=0.0_r8
250 ad_dltl=0.0_r8
251 ad_dltr=0.0_r8
252 ad_cu=0.0_r8
253 ad_cff=0.0_r8
254 ad_cff1=0.0_r8
255 ad_cff4=0.0_r8
256 ad_cffl=0.0_r8
257 ad_cffr=0.0_r8
258 adfac=0.0_r8
259 adfac1=0.0_r8
260 adfac2=0.0_r8
261 adfac3=0.0_r8
262!
263 DO k=1,n(ng)
264 DO i=imins,imaxs
265 ad_hz_inv(i,k)=0.0_r8
266 ad_hz_inv2(i,k)=0.0_r8
267 ad_hz_inv3(i,k)=0.0_r8
268 ad_wl(i,k)=0.0_r8
269 ad_wr(i,k)=0.0_r8
270 ad_bl(i,k)=0.0_r8
271 ad_br(i,k)=0.0_r8
272 ad_qc(i,k)=0.0_r8
273 ad_light(i,k)=0.0_r8
274 END DO
275 END DO
276 DO itrc=1,nbt
277 ibio=idbio(itrc)
278 ad_biotrc(ibio,1)=0.0_r8
279 ad_biotrc(ibio,2)=0.0_r8
280 END DO
281 DO i=imins,imaxs
282 ad_parsur(i)=0.0_r8
283 END DO
284 DO k=0,n(ng)
285 DO i=imins,imaxs
286 ad_fc(i,k)=0.0_r8
287 END DO
288 END DO
289!
290! Clear ad_Bio and Bio arrays.
291!
292 DO itrc=1,nbt
293 ibio=idbio(itrc)
294 DO k=1,n(ng)
295 DO i=istr,iend
296 bio(i,k,ibio)=0.0_r8
297 bio1(i,k,ibio)=0.0_r8
298 ad_bio(i,k,ibio)=0.0_r8
299 ad_bio_old(i,k,ibio)=0.0_r8
300 END DO
301 END DO
302 END DO
303!
304! Compute inverse thickness to avoid repeated divisions.
305!
306 DO k=1,n(ng)
307 DO i=istr,iend
308 hz_inv(i,k)=1.0_r8/hz(i,j,k)
309 END DO
310 END DO
311 DO k=1,n(ng)-1
312 DO i=istr,iend
313 hz_inv2(i,k)=1.0_r8/(hz(i,j,k)+hz(i,j,k+1))
314 END DO
315 END DO
316 DO k=2,n(ng)-1
317 DO i=istr,iend
318 hz_inv3(i,k)=1.0_r8/(hz(i,j,k-1)+hz(i,j,k)+hz(i,j,k+1))
319 END DO
320 END DO
321!
322! Compute the required basic state arrays.
323!
324! Restrict biological tracer to be positive definite. If a negative
325! concentration is detected, nitrogen is drawn from the most abundant
326! pool to supplement the negative pools to a lower limit of MinVal
327! which is set to 1E-6 above.
328!
329 DO k=1,n(ng)
330 DO i=istr,iend
331!
332! At input, all tracers (index nnew) from predictor step have
333! transport units (m Tunits) since we do not have yet the new
334! values for zeta and Hz. These are known after the 2D barotropic
335! time-stepping.
336!
337! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
338! tracer times depth. However the basic state (nstp and nnew
339! indices) that is read from the forward file is in units of
340! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
341! use t instead of t*Hz_inv.
342!
343 DO itrc=1,nbt
344 ibio=idbio(itrc)
345!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
346!^
347 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
348!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
349!^
350 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
351 END DO
352!
353! Impose positive definite concentrations.
354!
355 cff2=0.0_r8
356 DO itime=1,2
357 cff1=0.0_r8
358 itrcmax=idbio(1)
359 DO itrc=1,nbt
360 ibio=idbio(itrc)
361 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
362 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
363 itrcmax=ibio
364 END IF
365 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
366 END DO
367 IF (biotrc(itrcmax,itime).gt.cff1) THEN
368 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
369 END IF
370 END DO
371!
372! Load biological tracers into local arrays.
373!
374 DO itrc=1,nbt
375 ibio=idbio(itrc)
376 bio_old(i,k,ibio)=biotrc(ibio,nstp)
377 bio(i,k,ibio)=biotrc(ibio,nstp)
378 END DO
379 END DO
380 END DO
381!
382! Calculate surface Photosynthetically Available Radiation (PAR). The
383! net shortwave radiation is scaled back to Watts/m2 and multiplied by
384! the fraction that is photosynthetically available, PARfrac.
385!
386 DO i=istr,iend
387#ifdef CONST_PAR
388!
389! Specify constant surface irradiance a la Powell and Spitz.
390!
391 parsur(i)=158.075_r8
392#else
393 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
394#endif
395 END DO
396!
397!=======================================================================
398! Start internal iterations to achieve convergence of the nonlinear
399! backward-implicit solution.
400!=======================================================================
401!
402! During the iterative procedure a series of fractional time steps are
403! performed in a chained mode (splitting by different biological
404! conversion processes) in sequence of the main food chain. In all
405! stages the concentration of the component being consumed is treated
406! in a fully implicit manner, so the algorithm guarantees non-negative
407! values, no matter how strong the concentration of active consuming
408! component (Phytoplankton or Zooplankton). The overall algorithm,
409! as well as any stage of it, is formulated in conservative form
410! (except explicit sinking) in sense that the sum of concentration of
411! all components is conserved.
412!
413! In the implicit algorithm, we have for example (N: nutrient,
414! P: phytoplankton),
415!
416! N(new) = N(old) - uptake * P(old) uptake = mu * N / (Kn + N)
417! {Michaelis-Menten}
418! below, we set
419! The N in the numerator of
420! cff = mu * P(old) / (Kn + N(old)) uptake is treated implicitly
421! as N(new)
422!
423! so the time-stepping of the equations becomes:
424!
425! N(new) = N(old) / (1 + cff) (1) when substracting a sink term,
426! consuming, divide by (1 + cff)
427! and
428!
429! P(new) = P(old) + cff * N(new) (2) when adding a source term,
430! growing, add (cff * source)
431!
432! Notice that if you substitute (1) in (2), you will get:
433!
434! P(new) = P(old) + cff * N(old) / (1 + cff) (3)
435!
436! If you add (1) and (3), you get
437!
438! N(new) + P(new) = N(old) + P(old)
439!
440! implying conservation regardless how "cff" is computed. Therefore,
441! this scheme is unconditionally stable regardless of the conversion
442! rate. It does not generate negative values since the constituent
443! to be consumed is always treated implicitly. It is also biased
444! toward damping oscillations.
445!
446! The iterative loop below is to iterate toward an universal Backward-
447! Euler treatment of all terms. So if there are oscillations in the
448! system, they are only physical oscillations. These iterations,
449! however, do not improve the accuaracy of the solution.
450!
451 iter_loop: DO iter=1,bioiter(ng)
452!
453! Compute light attenuation as function of depth.
454!
455 DO i=istr,iend
456 par=parsur(i)
457 IF (parsur(i).gt.0.0_r8) THEN ! day time
458 DO k=n(ng),1,-1
459!
460! Compute average light attenuation for each grid cell. Here, AttSW is
461! the light attenuation due to seawater and AttPhy is the attenuation
462! due to phytoplankton (self-shading coefficient).
463!
464 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
465 & (z_w(i,j,k)-z_w(i,j,k-1))
466 expatt=exp(-att)
467 itop=par
468 par=itop*(1.0_r8-expatt)/att ! average at cell center
469 light(i,k)=par
470!
471! Light attenuation at the bottom of the grid cell. It is the starting
472! PAR value for the next (deeper) vertical grid cell.
473!
474 par=itop*expatt
475 END DO
476 ELSE ! night time
477 DO k=1,n(ng)
478 light(i,k)=0.0_r8
479 END DO
480 END IF
481 END DO
482!
483! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
484! The Michaelis-Menten curve is used to describe the change in uptake
485! rate as a function of nitrate concentration. Here, PhyIS is the
486! initial slope of the P-I curve and K_NO3 is the half saturation of
487! phytoplankton nitrate uptake.
488!
489 cff1=dtdays*vm_no3(ng)*phyis(ng)
490 cff2=vm_no3(ng)*vm_no3(ng)
491 cff3=phyis(ng)*phyis(ng)
492 DO k=1,n(ng)
493 DO i=istr,iend
494 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
495 cff=bio(i,k,iphyt)* &
496 & cff1*cff4*light(i,k)/ &
497 & (k_no3(ng)+bio(i,k,ino3_))
498 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
499 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
500 & bio(i,k,ino3_)*cff
501 END DO
502 END DO
503!
504! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
505! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
506! pool as function of "sloppy feeding" and metabolic processes
507! (ZooEEN and ZooEED fractions).
508!
509 cff1=dtdays*zoogr(ng)
510 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
511 DO k=1,n(ng)
512 DO i=istr,iend
513 cff=bio(i,k,izoop)* &
514 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
515 & bio(i,k,iphyt)
516 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
517 bio(i,k,izoop)=bio(i,k,izoop)+ &
518 & bio(i,k,iphyt)*cff2*cff
519 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
520 & bio(i,k,iphyt)*zooeen(ng)*cff
521 bio(i,k,isdet)=bio(i,k,isdet)+ &
522 & bio(i,k,iphyt)*zooeed(ng)*cff
523 END DO
524 END DO
525!
526! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
527! (PhyMRD rate).
528!
529 cff3=dtdays*phymrd(ng)
530 cff2=dtdays*phymrn(ng)
531 cff1=1.0_r8/(1.0_r8+cff2+cff3)
532 DO k=1,n(ng)
533 DO i=istr,iend
534 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
535 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
536 & bio(i,k,iphyt)*cff2
537 bio(i,k,isdet)=bio(i,k,isdet)+ &
538 & bio(i,k,iphyt)*cff3
539 END DO
540 END DO
541!
542! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
543! (ZooMRD rate).
544!
545 cff3=dtdays*zoomrd(ng)
546 cff2=dtdays*zoomrn(ng)
547 cff1=1.0_r8/(1.0_r8+cff2+cff3)
548 DO k=1,n(ng)
549 DO i=istr,iend
550 bio(i,k,izoop)=bio(i,k,izoop)*cff1
551 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
552 & bio(i,k,izoop)*cff2
553 bio(i,k,isdet)=bio(i,k,isdet)+ &
554 & bio(i,k,izoop)*cff3
555 END DO
556 END DO
557!
558! Detritus breakdown to nutrients: remineralization (DetRR rate).
559!
560 cff2=dtdays*detrr(ng)
561 cff1=1.0_r8/(1.0_r8+cff2)
562 DO k=1,n(ng)
563 DO i=istr,iend
564 bio(i,k,isdet)=bio(i,k,isdet)*cff1
565 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
566 & bio(i,k,isdet)*cff2
567 END DO
568 END DO
569!
570!-----------------------------------------------------------------------
571! Vertical sinking terms: Phytoplankton and Detritus
572!-----------------------------------------------------------------------
573!
574! Reconstruct vertical profile of selected biological constituents
575! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
576! grid box. Then, compute semi-Lagrangian flux due to sinking.
577!
578 sink_loop: DO isink=1,nsink
579 ibio=idsink(isink)
580!
581! Copy concentration of biological particulates into scratch array
582! "qc" (q-central, restrict it to be positive) which is hereafter
583! interpreted as a set of grid-box averaged values for biogeochemical
584! constituent concentration.
585!
586 DO k=1,n(ng)
587 DO i=istr,iend
588 qc(i,k)=bio(i,k,ibio)
589 END DO
590 END DO
591!
592 DO k=n(ng)-1,1,-1
593 DO i=istr,iend
594 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
595 END DO
596 END DO
597 DO k=2,n(ng)-1
598 DO i=istr,iend
599 dltr=hz(i,j,k)*fc(i,k)
600 dltl=hz(i,j,k)*fc(i,k-1)
601 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
602 cffr=cff*fc(i,k)
603 cffl=cff*fc(i,k-1)
604!
605! Apply PPM monotonicity constraint to prevent oscillations within the
606! grid box.
607!
608 IF ((dltr*dltl).le.0.0_r8) THEN
609 dltr=0.0_r8
610 dltl=0.0_r8
611 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
612 dltr=cffl
613 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
614 dltl=cffr
615 END IF
616!
617! Compute right and left side values (bR,bL) of parabolic segments
618! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
619!
620! NOTE: Although each parabolic segment is monotonic within its grid
621! box, monotonicity of the whole profile is not guaranteed,
622! because bL(k+1)-bR(k) may still have different sign than
623! qc(i,k+1)-qc(i,k). This possibility is excluded,
624! after bL and bR are reconciled using WENO procedure.
625!
626 cff=(dltr-dltl)*hz_inv3(i,k)
627 dltr=dltr-cff*hz(i,j,k+1)
628 dltl=dltl+cff*hz(i,j,k-1)
629 br(i,k)=qc(i,k)+dltr
630 bl(i,k)=qc(i,k)-dltl
631 wr(i,k)=(2.0_r8*dltr-dltl)**2
632 wl(i,k)=(dltr-2.0_r8*dltl)**2
633 END DO
634 END DO
635 cff=1.0e-14_r8
636 DO k=2,n(ng)-2
637 DO i=istr,iend
638 dltl=max(cff,wl(i,k ))
639 dltr=max(cff,wr(i,k+1))
640 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
641 bl(i,k+1)=br(i,k)
642 END DO
643 END DO
644 DO i=istr,iend
645 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
646#if defined LINEAR_CONTINUATION
647 bl(i,n(ng))=br(i,n(ng)-1)
648 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
649#elif defined NEUMANN
650 bl(i,n(ng))=br(i,n(ng)-1)
651 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
652#else
653 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
654 bl(i,n(ng))=qc(i,n(ng)) ! conditions
655 br(i,n(ng)-1)=qc(i,n(ng))
656#endif
657#if defined LINEAR_CONTINUATION
658 br(i,1)=bl(i,2)
659 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
660#elif defined NEUMANN
661 br(i,1)=bl(i,2)
662 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
663#else
664 bl(i,2)=qc(i,1) ! bottom grid boxes are
665 br(i,1)=qc(i,1) ! re-assumed to be
666 bl(i,1)=qc(i,1) ! piecewise constant.
667#endif
668 END DO
669!
670! Apply monotonicity constraint again, since the reconciled interfacial
671! values may cause a non-monotonic behavior of the parabolic segments
672! inside the grid box.
673!
674 DO k=1,n(ng)
675 DO i=istr,iend
676 dltr=br(i,k)-qc(i,k)
677 dltl=qc(i,k)-bl(i,k)
678 cffr=2.0_r8*dltr
679 cffl=2.0_r8*dltl
680 IF ((dltr*dltl).lt.0.0_r8) THEN
681 dltr=0.0_r8
682 dltl=0.0_r8
683 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
684 dltr=cffl
685 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
686 dltl=cffr
687 END IF
688 br(i,k)=qc(i,k)+dltr
689 bl(i,k)=qc(i,k)-dltl
690 END DO
691 END DO
692!
693! After this moment reconstruction is considered complete. The next
694! stage is to compute vertical advective fluxes, FC. It is expected
695! that sinking may occurs relatively fast, the algorithm is designed
696! to be free of CFL criterion, which is achieved by allowing
697! integration bounds for semi-Lagrangian advective flux to use as
698! many grid boxes in upstream direction as necessary.
699!
700! In the two code segments below, WL is the z-coordinate of the
701! departure point for grid box interface z_w with the same indices;
702! FC is the finite volume flux; ksource(:,k) is index of vertical
703! grid box which contains the departure point (restricted by N(ng)).
704! During the search: also add in content of whole grid boxes
705! participating in FC.
706!
707 cff=dtdays*abs(wbio(isink))
708 DO k=1,n(ng)
709 DO i=istr,iend
710 fc(i,k-1)=0.0_r8
711 wl(i,k)=z_w(i,j,k-1)+cff
712 wr(i,k)=hz(i,j,k)*qc(i,k)
713 ksource(i,k)=k
714 END DO
715 END DO
716 DO k=1,n(ng)
717 DO ks=k,n(ng)-1
718 DO i=istr,iend
719 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
720 ksource(i,k)=ks+1
721 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
722 END IF
723 END DO
724 END DO
725 END DO
726!
727! Finalize computation of flux: add fractional part.
728!
729 DO k=1,n(ng)
730 DO i=istr,iend
731 ks=ksource(i,k)
732 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
733 fc(i,k-1)=fc(i,k-1)+ &
734 & hz(i,j,ks)*cu* &
735 & (bl(i,ks)+ &
736 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
737 & (1.5_r8-cu)* &
738 & (br(i,ks)+bl(i,ks)- &
739 & 2.0_r8*qc(i,ks))))
740 END DO
741 END DO
742 DO k=1,n(ng)
743 DO i=istr,iend
744 bio(i,k,ibio)=qc(i,k)+(fc(i,k)-fc(i,k-1))*hz_inv(i,k)
745 END DO
746 END DO
747
748 END DO sink_loop
749 END DO iter_loop
750!
751!-----------------------------------------------------------------------
752! Update global tracer variables: Add increment due to BGC processes
753! to tracer array in time index "nnew". Index "nnew" is solution after
754! advection and mixing and has transport units (m Tunits) hence the
755! increment is multiplied by Hz. Notice that we need to subtract
756! original values "Bio_old" at the top of the routine to just account
757! for the concentractions affected by BGC processes. This also takes
758! into account any constraints (non-negative concentrations, carbon
759! concentration range) specified before entering BGC kernel. If "Bio"
760! were unchanged by BGC processes, the increment would be exactly
761! zero. Notice that final tracer values, t(:,:,:,nnew,:) are not
762! bounded >=0 so that we can preserve total inventory of nutrients
763! when advection causes tracer concentration to go negative.
764!-----------------------------------------------------------------------
765!
766 DO itrc=1,nbt
767 ibio=idbio(itrc)
768 DO k=1,n(ng)
769 DO i=istr,iend
770 cff=bio(i,k,ibio)-bio_old(i,k,ibio)
771!^ tl_t(i,j,k,nnew,ibio)=tl_t(i,j,k,nnew,ibio)+ &
772!^ & tl_cff*Hz(i,j,k)+cff*tl_Hz(i,j,k)
773!^
774 ad_hz(i,j,k)=ad_hz(i,j,k)+cff*ad_t(i,j,k,nnew,ibio)
775 ad_cff=ad_cff+hz(i,j,k)*ad_t(i,j,k,nnew,ibio)
776!^ tl_cff=tl_Bio(i,k,ibio)-tl_Bio_old(i,k,ibio)
777!^
778 ad_bio_old(i,k,ibio)=ad_bio_old(i,k,ibio)-ad_cff
779 ad_bio(i,k,ibio)=ad_bio(i,k,ibio)+ad_cff
780 END DO
781 END DO
782 END DO
783!
784!=======================================================================
785! Start internal iterations to achieve convergence of the nonlinear
786! backward-implicit solution.
787!=======================================================================
788!
789 iter_loop1: DO iter=bioiter(ng),1,-1
790!
791!-----------------------------------------------------------------------
792! Adjoint vertical sinking terms.
793!-----------------------------------------------------------------------
794!
795! Reconstruct vertical profile of selected biological constituents
796! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
797! grid box. Then, compute semi-Lagrangian flux due to sinking.
798!
799! Compute appropriate basic state arrays III.
800!
801 DO k=1,n(ng)
802 DO i=istr,iend
803!
804! At input, all tracers (index nnew) from predictor step have
805! transport units (m Tunits) since we do not have yet the new
806! values for zeta and Hz. These are known after the 2D barotropic
807! time-stepping.
808!
809! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
810! tracer times depth. However the basic state (nstp and nnew
811! indices) that is read from the forward file is in units of
812! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
813! use t instead of t*Hz_inv.
814!
815 DO itrc=1,nbt
816 ibio=idbio(itrc)
817!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
818!^
819 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
820!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
821!^
822 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
823 END DO
824!
825! Impose positive definite concentrations.
826!
827 cff2=0.0_r8
828 DO itime=1,2
829 cff1=0.0_r8
830 itrcmax=idbio(1)
831 DO itrc=1,nbt
832 ibio=idbio(itrc)
833 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
834 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
835 itrcmax=ibio
836 END IF
837 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
838 END DO
839 IF (biotrc(itrcmax,itime).gt.cff1) THEN
840 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
841 END IF
842 END DO
843!
844! Load biological tracers into local arrays.
845!
846 DO itrc=1,nbt
847 ibio=idbio(itrc)
848 bio_old(i,k,ibio)=biotrc(ibio,nstp)
849 bio(i,k,ibio)=biotrc(ibio,nstp)
850 END DO
851 END DO
852 END DO
853!
854! Calculate surface Photosynthetically Available Radiation (PAR). The
855! net shortwave radiation is scaled back to Watts/m2 and multiplied by
856! the fraction that is photosynthetically available, PARfrac.
857!
858 DO i=istr,iend
859#ifdef CONST_PAR
860!
861! Specify constant surface irradiance a la Powell and Spitz.
862!
863 parsur(i)=158.075_r8
864#else
865 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
866#endif
867 END DO
868!
869!=======================================================================
870! Start internal iterations to achieve convergence of the nonlinear
871! backward-implicit solution.
872!=======================================================================
873!
874 DO iteradj=1,iter
875!
876! Compute light attenuation as function of depth.
877!
878 DO i=istr,iend
879 par=parsur(i)
880 IF (parsur(i).gt.0.0_r8) THEN ! day time
881 DO k=n(ng),1,-1
882!
883! Compute average light attenuation for each grid cell. Here, AttSW is
884! the light attenuation due to seawater and AttPhy is the attenuation
885! due to phytoplankton (self-shading coefficient).
886!
887 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
888 & (z_w(i,j,k)-z_w(i,j,k-1))
889 expatt=exp(-att)
890 itop=par
891 par=itop*(1.0_r8-expatt)/att ! average at cell center
892 light(i,k)=par
893!
894! Light attenuation at the bottom of the grid cell. It is the starting
895! PAR value for the next (deeper) vertical grid cell.
896!
897 par=itop*expatt
898 END DO
899 ELSE ! night time
900 DO k=1,n(ng)
901 light(i,k)=0.0_r8
902 END DO
903 END IF
904 END DO
905!
906! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
907! The Michaelis-Menten curve is used to describe the change in uptake
908! rate as a function of nitrate concentration. Here, PhyIS is the
909! initial slope of the P-I curve and K_NO3 is the half saturation of
910! phytoplankton nitrate uptake.
911!
912 cff1=dtdays*vm_no3(ng)*phyis(ng)
913 cff2=vm_no3(ng)*vm_no3(ng)
914 cff3=phyis(ng)*phyis(ng)
915 DO k=1,n(ng)
916 DO i=istr,iend
917 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
918 cff=bio(i,k,iphyt)* &
919 & cff1*cff4*light(i,k)/ &
920 & (k_no3(ng)+bio(i,k,ino3_))
921 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
922 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
923 & bio(i,k,ino3_)*cff
924 END DO
925 END DO
926!
927! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
928! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
929! pool as function of "sloppy feeding" and metabolic processes
930! (ZooEEN and ZooEED fractions).
931!
932 cff1=dtdays*zoogr(ng)
933 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
934 DO k=1,n(ng)
935 DO i=istr,iend
936 cff=bio(i,k,izoop)* &
937 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
938 & bio(i,k,iphyt)
939 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
940 bio(i,k,izoop)=bio(i,k,izoop)+ &
941 & bio(i,k,iphyt)*cff2*cff
942 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
943 & bio(i,k,iphyt)*zooeen(ng)*cff
944 bio(i,k,isdet)=bio(i,k,isdet)+ &
945 & bio(i,k,iphyt)*zooeed(ng)*cff
946 END DO
947 END DO
948!
949! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
950! (PhyMRD rate).
951!
952 cff3=dtdays*phymrd(ng)
953 cff2=dtdays*phymrn(ng)
954 cff1=1.0_r8/(1.0_r8+cff2+cff3)
955 DO k=1,n(ng)
956 DO i=istr,iend
957 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
958 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
959 & bio(i,k,iphyt)*cff2
960 bio(i,k,isdet)=bio(i,k,isdet)+ &
961 & bio(i,k,iphyt)*cff3
962 END DO
963 END DO
964!
965! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
966! (ZooMRD rate).
967!
968 cff3=dtdays*zoomrd(ng)
969 cff2=dtdays*zoomrn(ng)
970 cff1=1.0_r8/(1.0_r8+cff2+cff3)
971 DO k=1,n(ng)
972 DO i=istr,iend
973 bio(i,k,izoop)=bio(i,k,izoop)*cff1
974 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
975 & bio(i,k,izoop)*cff2
976 bio(i,k,isdet)=bio(i,k,isdet)+ &
977 & bio(i,k,izoop)*cff3
978 END DO
979 END DO
980!
981! Detritus breakdown to nutrients: remineralization (DetRR rate).
982!
983 cff2=dtdays*detrr(ng)
984 cff1=1.0_r8/(1.0_r8+cff2)
985 DO k=1,n(ng)
986 DO i=istr,iend
987 bio(i,k,isdet)=bio(i,k,isdet)*cff1
988 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
989 & bio(i,k,isdet)*cff2
990 END DO
991 END DO
992!
993 IF (iteradj.ne.iter) THEN
994!
995!-----------------------------------------------------------------------
996! Vertical sinking terms: Phytoplankton and Detritus
997!-----------------------------------------------------------------------
998!
999! Reconstruct vertical profile of selected biological constituents
1000! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
1001! grid box. Then, compute semi-Lagrangian flux due to sinking.
1002!
1003 DO isink=1,nsink
1004 ibio=idsink(isink)
1005!
1006! Copy concentration of biological particulates into scratch array
1007! "qc" (q-central, restrict it to be positive) which is hereafter
1008! interpreted as a set of grid-box averaged values for biogeochemical
1009! constituent concentration.
1010!
1011 DO k=1,n(ng)
1012 DO i=istr,iend
1013 qc(i,k)=bio(i,k,ibio)
1014 END DO
1015 END DO
1016!
1017 DO k=n(ng)-1,1,-1
1018 DO i=istr,iend
1019 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1020 END DO
1021 END DO
1022 DO k=2,n(ng)-1
1023 DO i=istr,iend
1024 dltr=hz(i,j,k)*fc(i,k)
1025 dltl=hz(i,j,k)*fc(i,k-1)
1026 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1027 cffr=cff*fc(i,k)
1028 cffl=cff*fc(i,k-1)
1029!
1030! Apply PPM monotonicity constraint to prevent oscillations within the
1031! grid box.
1032!
1033 IF ((dltr*dltl).le.0.0_r8) THEN
1034 dltr=0.0_r8
1035 dltl=0.0_r8
1036 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1037 dltr=cffl
1038 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1039 dltl=cffr
1040 END IF
1041!
1042! Compute right and left side values (bR,bL) of parabolic segments
1043! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1044!
1045! NOTE: Although each parabolic segment is monotonic within its grid
1046! box, monotonicity of the whole profile is not guaranteed,
1047! because bL(k+1)-bR(k) may still have different sign than
1048! qc(i,k+1)-qc(i,k). This possibility is excluded,
1049! after bL and bR are reconciled using WENO procedure.
1050!
1051 cff=(dltr-dltl)*hz_inv3(i,k)
1052 dltr=dltr-cff*hz(i,j,k+1)
1053 dltl=dltl+cff*hz(i,j,k-1)
1054 br(i,k)=qc(i,k)+dltr
1055 bl(i,k)=qc(i,k)-dltl
1056 wr(i,k)=(2.0_r8*dltr-dltl)**2
1057 wl(i,k)=(dltr-2.0_r8*dltl)**2
1058 END DO
1059 END DO
1060 cff=1.0e-14_r8
1061 DO k=2,n(ng)-2
1062 DO i=istr,iend
1063 dltl=max(cff,wl(i,k ))
1064 dltr=max(cff,wr(i,k+1))
1065 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1066 bl(i,k+1)=br(i,k)
1067 END DO
1068 END DO
1069 DO i=istr,iend
1070 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1071#if defined LINEAR_CONTINUATION
1072 bl(i,n(ng))=br(i,n(ng)-1)
1073 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1074#elif defined NEUMANN
1075 bl(i,n(ng))=br(i,n(ng)-1)
1076 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1077#else
1078 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1079 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1080 br(i,n(ng)-1)=qc(i,n(ng))
1081#endif
1082#if defined LINEAR_CONTINUATION
1083 br(i,1)=bl(i,2)
1084 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1085#elif defined NEUMANN
1086 br(i,1)=bl(i,2)
1087 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1088#else
1089 bl(i,2)=qc(i,1) ! bottom grid boxes are
1090 br(i,1)=qc(i,1) ! re-assumed to be
1091 bl(i,1)=qc(i,1) ! piecewise constant.
1092#endif
1093 END DO
1094!
1095! Apply monotonicity constraint again, since the reconciled interfacial
1096! values may cause a non-monotonic behavior of the parabolic segments
1097! inside the grid box.
1098!
1099 DO k=1,n(ng)
1100 DO i=istr,iend
1101 dltr=br(i,k)-qc(i,k)
1102 dltl=qc(i,k)-bl(i,k)
1103 cffr=2.0_r8*dltr
1104 cffl=2.0_r8*dltl
1105 IF ((dltr*dltl).lt.0.0_r8) THEN
1106 dltr=0.0_r8
1107 dltl=0.0_r8
1108 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1109 dltr=cffl
1110 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1111 dltl=cffr
1112 END IF
1113 br(i,k)=qc(i,k)+dltr
1114 bl(i,k)=qc(i,k)-dltl
1115 END DO
1116 END DO
1117!
1118! After this moment reconstruction is considered complete. The next
1119! stage is to compute vertical advective fluxes, FC. It is expected
1120! that sinking may occurs relatively fast, the algorithm is designed
1121! to be free of CFL criterion, which is achieved by allowing
1122! integration bounds for semi-Lagrangian advective flux to use as
1123! many grid boxes in upstream direction as necessary.
1124!
1125! In the two code segments below, WL is the z-coordinate of the
1126! departure point for grid box interface z_w with the same indices;
1127! FC is the finite volume flux; ksource(:,k) is index of vertical
1128! grid box which contains the departure point (restricted by N(ng)).
1129! During the search: also add in content of whole grid boxes
1130! participating in FC.
1131!
1132 cff=dtdays*abs(wbio(isink))
1133 DO k=1,n(ng)
1134 DO i=istr,iend
1135 fc(i,k-1)=0.0_r8
1136 wl(i,k)=z_w(i,j,k-1)+cff
1137 wr(i,k)=hz(i,j,k)*qc(i,k)
1138 ksource(i,k)=k
1139 END DO
1140 END DO
1141 DO k=1,n(ng)
1142 DO ks=k,n(ng)-1
1143 DO i=istr,iend
1144 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1145 ksource(i,k)=ks+1
1146 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1147 END IF
1148 END DO
1149 END DO
1150 END DO
1151!
1152! Finalize computation of flux: add fractional part.
1153!
1154 DO k=1,n(ng)
1155 DO i=istr,iend
1156 ks=ksource(i,k)
1157 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1158 fc(i,k-1)=fc(i,k-1)+ &
1159 & hz(i,j,ks)*cu* &
1160 & (bl(i,ks)+ &
1161 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1162 & (1.5_r8-cu)* &
1163 & (br(i,ks)+bl(i,ks)- &
1164 & 2.0_r8*qc(i,ks))))
1165 END DO
1166 END DO
1167 DO k=1,n(ng)
1168 DO i=istr,iend
1169 bio(i,k,ibio)=qc(i,k)+ &
1170 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
1171 END DO
1172 END DO
1173 END DO
1174 END IF
1175 END DO
1176!
1177! End of compute basic state arrays III.
1178!
1179 sink_loop1: DO isink=1,nsink
1180 ibio=idsink(isink)
1181
1182!
1183! Compute required flux arrays.
1184!
1185! Copy concentration of biological particulates into scratch array
1186! "qc" (q-central, restrict it to be positive) which is hereafter
1187! interpreted as a set of grid-box averaged values for biogeochemical
1188! constituent concentration.
1189!
1190 DO k=1,n(ng)
1191 DO i=istr,iend
1192 qc(i,k)=bio(i,k,ibio)
1193 END DO
1194 END DO
1195!
1196 DO k=n(ng)-1,1,-1
1197 DO i=istr,iend
1198 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1199 END DO
1200 END DO
1201 DO k=2,n(ng)-1
1202 DO i=istr,iend
1203 dltr=hz(i,j,k)*fc(i,k)
1204 dltl=hz(i,j,k)*fc(i,k-1)
1205 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1206 cffr=cff*fc(i,k)
1207 cffl=cff*fc(i,k-1)
1208!
1209! Apply PPM monotonicity constraint to prevent oscillations within the
1210! grid box.
1211!
1212 IF ((dltr*dltl).le.0.0_r8) THEN
1213 dltr=0.0_r8
1214 dltl=0.0_r8
1215 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1216 dltr=cffl
1217 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1218 dltl=cffr
1219 END IF
1220!
1221! Compute right and left side values (bR,bL) of parabolic segments
1222! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1223!
1224! NOTE: Although each parabolic segment is monotonic within its grid
1225! box, monotonicity of the whole profile is not guaranteed,
1226! because bL(k+1)-bR(k) may still have different sign than
1227! qc(i,k+1)-qc(i,k). This possibility is excluded,
1228! after bL and bR are reconciled using WENO procedure.
1229!
1230 cff=(dltr-dltl)*hz_inv3(i,k)
1231 dltr=dltr-cff*hz(i,j,k+1)
1232 dltl=dltl+cff*hz(i,j,k-1)
1233 br(i,k)=qc(i,k)+dltr
1234 bl(i,k)=qc(i,k)-dltl
1235 wr(i,k)=(2.0_r8*dltr-dltl)**2
1236 wl(i,k)=(dltr-2.0_r8*dltl)**2
1237 END DO
1238 END DO
1239 cff=1.0e-14_r8
1240 DO k=2,n(ng)-2
1241 DO i=istr,iend
1242 dltl=max(cff,wl(i,k ))
1243 dltr=max(cff,wr(i,k+1))
1244 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1245 bl(i,k+1)=br(i,k)
1246 END DO
1247 END DO
1248 DO i=istr,iend
1249 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1250#if defined LINEAR_CONTINUATION
1251 bl(i,n(ng))=br(i,n(ng)-1)
1252 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1253#elif defined NEUMANN
1254 bl(i,n(ng))=br(i,n(ng)-1)
1255 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1256#else
1257 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1258 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1259 br(i,n(ng)-1)=qc(i,n(ng))
1260#endif
1261#if defined LINEAR_CONTINUATION
1262 br(i,1)=bl(i,2)
1263 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1264#elif defined NEUMANN
1265 br(i,1)=bl(i,2)
1266 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1267#else
1268 bl(i,2)=qc(i,1) ! bottom grid boxes are
1269 br(i,1)=qc(i,1) ! re-assumed to be
1270 bl(i,1)=qc(i,1) ! piecewise constant.
1271#endif
1272 END DO
1273!
1274! Apply monotonicity constraint again, since the reconciled interfacial
1275! values may cause a non-monotonic behavior of the parabolic segments
1276! inside the grid box.
1277!
1278 DO k=1,n(ng)
1279 DO i=istr,iend
1280 dltr=br(i,k)-qc(i,k)
1281 dltl=qc(i,k)-bl(i,k)
1282 cffr=2.0_r8*dltr
1283 cffl=2.0_r8*dltl
1284 IF ((dltr*dltl).lt.0.0_r8) THEN
1285 dltr=0.0_r8
1286 dltl=0.0_r8
1287 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1288 dltr=cffl
1289 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1290 dltl=cffr
1291 END IF
1292 br(i,k)=qc(i,k)+dltr
1293 bl(i,k)=qc(i,k)-dltl
1294 END DO
1295 END DO
1296!
1297! After this moment reconstruction is considered complete. The next
1298! stage is to compute vertical advective fluxes, FC. It is expected
1299! that sinking may occurs relatively fast, the algorithm is designed
1300! to be free of CFL criterion, which is achieved by allowing
1301! integration bounds for semi-Lagrangian advective flux to use as
1302! many grid boxes in upstream direction as necessary.
1303!
1304! In the two code segments below, WL is the z-coordinate of the
1305! departure point for grid box interface z_w with the same indices;
1306! FC is the finite volume flux; ksource(:,k) is index of vertical
1307! grid box which contains the departure point (restricted by N(ng)).
1308! During the search: also add in content of whole grid boxes
1309! participating in FC.
1310!
1311 cff=dtdays*abs(wbio(isink))
1312 DO k=1,n(ng)
1313 DO i=istr,iend
1314 fc(i,k-1)=0.0_r8
1315 wl(i,k)=z_w(i,j,k-1)+cff
1316 wr(i,k)=hz(i,j,k)*qc(i,k)
1317 ksource(i,k)=k
1318 END DO
1319 END DO
1320 DO k=1,n(ng)
1321 DO ks=k,n(ng)-1
1322 DO i=istr,iend
1323 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1324 ksource(i,k)=ks+1
1325 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
1326 END IF
1327 END DO
1328 END DO
1329 END DO
1330!
1331! Finalize computation of flux: add fractional part.
1332!
1333 DO k=1,n(ng)
1334 DO i=istr,iend
1335 ks=ksource(i,k)
1336 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1337 fc(i,k-1)=fc(i,k-1)+ &
1338 & hz(i,j,ks)*cu* &
1339 & (bl(i,ks)+ &
1340 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1341 & (1.5_r8-cu)* &
1342 & (br(i,ks)+bl(i,ks)- &
1343 & 2.0_r8*qc(i,ks))))
1344 END DO
1345 END DO
1346 DO k=1,n(ng)
1347 DO i=istr,iend
1348!^ tl_Bio(i,k,ibio)=tl_qc(i,k)+ &
1349!^ & (tl_FC(i,k)-tl_FC(i,k-1))*Hz_inv(i,k)+ &
1350!^ & (FC(i,k)-FC(i,k-1))*tl_Hz_inv(i,k)
1351!^
1352 ad_qc(i,k)=ad_qc(i,k)+ad_bio(i,k,ibio)
1353 ad_fc(i,k)=ad_fc(i,k)+hz_inv(i,k)*ad_bio(i,k,ibio)
1354 ad_fc(i,k-1)=ad_fc(i,k-1)-hz_inv(i,k)*ad_bio(i,k,ibio)
1355 ad_hz_inv(i,k)=ad_hz_inv(i,k)+ &
1356 & (fc(i,k)-fc(i,k-1))*ad_bio(i,k,ibio)
1357 ad_bio(i,k,ibio)=0.0_r8
1358 END DO
1359 END DO
1360!
1361! Adjoint of final computation of flux: add fractional part.
1362!
1363 DO k=1,n(ng)
1364 DO i=istr,iend
1365 ks=ksource(i,k)
1366 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
1367!^ tl_FC(i,k-1)=tl_FC(i,k-1)+ &
1368!^ & (tl_Hz(i,j,ks)*cu+Hz(i,j,ks)*tl_cu)* &
1369!^ & (bL(i,ks)+ &
1370!^ & cu*(0.5_r8*(bR(i,ks)-bL(i,ks))- &
1371!^ & (1.5_r8-cu)* &
1372!^ & (bR(i,ks)+bL(i,ks)- &
1373!^ & 2.0_r8*qc(i,ks))))+ &
1374!^ & Hz(i,j,ks)*cu* &
1375!^ & (tl_bL(i,ks)+ &
1376!^ & tl_cu*(0.5_r8*(bR(i,ks)-bL(i,ks))- &
1377!^ & (1.5_r8-cu)* &
1378!^ & (bR(i,ks)+bL(i,ks)- &
1379!^ & 2.0_r8*qc(i,ks)))+ &
1380!^ & cu*(0.5_r8*(tl_bR(i,ks)-tl_bL(i,ks))+ &
1381!^ & tl_cu* &
1382!^ & (bR(i,ks)+bL(i,ks)-2.0_r8*qc(i,ks))- &
1383!^ & (1.5_r8-cu)* &
1384!^ & (tl_bR(i,ks)+tl_bL(i,ks)- &
1385!^ & 2.0_r8*tl_qc(i,ks))))
1386!^
1387 adfac=(bl(i,ks)+ &
1388 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1389 & (1.5_r8-cu)* &
1390 & (br(i,ks)+bl(i,ks)- &
1391 & 2.0_r8*qc(i,ks))))*ad_fc(i,k-1)
1392 adfac1=hz(i,j,ks)*cu*ad_fc(i,k-1)
1393 adfac2=adfac1*cu
1394 adfac3=adfac2*(1.5_r8-cu)
1395 ad_hz(i,j,ks)=ad_hz(i,j,ks)+cu*adfac
1396 ad_cu=ad_cu+hz(i,j,ks)*adfac
1397 ad_bl(i,ks)=ad_bl(i,ks)+adfac1
1398 ad_cu=ad_cu+ &
1399 & adfac1*(0.5_r8*(br(i,ks)-bl(i,ks))- &
1400 & (1.5_r8-cu)* &
1401 & (br(i,ks)+bl(i,ks)- &
1402 & 2.0_r8*qc(i,ks)))+ &
1403 & adfac2*(br(i,ks)+bl(i,ks)-2.0_r8*qc(i,ks))
1404 ad_br(i,ks)=ad_br(i,ks)+0.5_r8*adfac2-adfac3
1405 ad_bl(i,ks)=ad_bl(i,ks)-0.5_r8*adfac2-adfac3
1406 ad_qc(i,ks)=ad_qc(i,ks)+2.0_r8*adfac3
1407!^ tl_cu=(0.5_r8+SIGN(0.5_r8, &
1408!^ & (1.0_r8-(WL(i,k)-z_w(i,j,ks-1))* &
1409!^ & Hz_inv(i,ks))))* &
1410!^ & ((tl_WL(i,k)-tl_z_w(i,j,ks-1))*Hz_inv(i,ks)+ &
1411!^ & (WL(i,k)-z_w(i,j,ks-1))*tl_Hz_inv(i,ks))
1412!^
1413 adfac=(0.5_r8+sign(0.5_r8, &
1414 & (1.0_r8-(wl(i,k)-z_w(i,j,ks-1))* &
1415 & hz_inv(i,ks))))*ad_cu
1416 adfac1=adfac*hz_inv(i,ks)
1417 ad_wl(i,k)=ad_wl(i,k)+adfac1
1418 ad_z_w(i,j,ks-1)=ad_z_w(i,j,ks-1)-adfac1
1419 ad_hz_inv(i,ks)=ad_hz_inv(i,ks)+ &
1420 & (wl(i,k)-z_w(i,j,ks-1))*adfac
1421 ad_cu=0.0_r8
1422 END DO
1423 END DO
1424!
1425! After this moment reconstruction is considered complete. The next
1426! stage is to compute vertical advective fluxes, FC. It is expected
1427! that sinking may occurs relatively fast, the algorithm is designed
1428! to be free of CFL criterion, which is achieved by allowing
1429! integration bounds for semi-Lagrangian advective flux to use as
1430! many grid boxes in upstream direction as necessary.
1431!
1432! In the two code segments below, WL is the z-coordinate of the
1433! departure point for grid box interface z_w with the same indices;
1434! FC is the finite volume flux; ksource(:,k) is index of vertical
1435! grid box which contains the departure point (restricted by N(ng)).
1436! During the search: also add in content of whole grid boxes
1437! participating in FC.
1438!
1439 cff=dtdays*abs(wbio(isink))
1440 DO k=1,n(ng)
1441 DO ks=k,n(ng)-1
1442 DO i=istr,iend
1443 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
1444!^ tl_FC(i,k-1)=tl_FC(i,k-1)+tl_WR(i,ks)
1445!^
1446 ad_wr(i,ks)=ad_wr(i,ks)+ad_fc(i,k-1)
1447 END IF
1448 END DO
1449 END DO
1450 END DO
1451 DO k=1,n(ng)
1452 DO i=istr,iend
1453!^ tl_WR(i,k)=tl_Hz(i,j,k)*qc(i,k)+Hz(i,j,k)*tl_qc(i,k)
1454!^
1455 ad_hz(i,j,k)=ad_hz(i,j,k)+qc(i,k)*ad_wr(i,k)
1456 ad_qc(i,k)=ad_qc(i,k)+hz(i,j,k)*ad_wr(i,k)
1457 ad_wr(i,k)=0.0_r8
1458!^ tl_WL(i,k)=tl_z_w(i,j,k-1)+tl_cff
1459!^
1460 ad_z_w(i,j,k-1)=ad_z_w(i,j,k-1)+ad_wl(i,k)
1461 ad_cff=ad_cff+ad_wl(i,k)
1462 ad_wl(i,k)=0.0_r8
1463!^ tl_FC(i,k-1)=0.0_r8
1464!^
1465 ad_fc(i,k-1)=0.0_r8
1466 END DO
1467 END DO
1468!^ tl_cff=dtdays*SIGN(1.0_r8,Wbio(isink))*tl_Wbio(isink)
1469!^
1470 ad_wbio(isink)=ad_wbio(isink)+ &
1471 & dtdays*sign(1.0_r8,wbio(isink))*ad_cff
1472 ad_cff=0.0_r8
1473!
1474! Compute appropriate values of bR and bL.
1475!
1476! Copy concentration of biological particulates into scratch array
1477! "qc" (q-central, restrict it to be positive) which is hereafter
1478! interpreted as a set of grid-box averaged values for biogeochemical
1479! constituent concentration.
1480!
1481 DO k=1,n(ng)
1482 DO i=istr,iend
1483 qc(i,k)=bio(i,k,ibio)
1484 END DO
1485 END DO
1486!
1487 DO k=n(ng)-1,1,-1
1488 DO i=istr,iend
1489 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1490 END DO
1491 END DO
1492 DO k=2,n(ng)-1
1493 DO i=istr,iend
1494 dltr=hz(i,j,k)*fc(i,k)
1495 dltl=hz(i,j,k)*fc(i,k-1)
1496 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1497 cffr=cff*fc(i,k)
1498 cffl=cff*fc(i,k-1)
1499!
1500! Apply PPM monotonicity constraint to prevent oscillations within the
1501! grid box.
1502!
1503 IF ((dltr*dltl).le.0.0_r8) THEN
1504 dltr=0.0_r8
1505 dltl=0.0_r8
1506 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1507 dltr=cffl
1508 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1509 dltl=cffr
1510 END IF
1511!
1512! Compute right and left side values (bR,bL) of parabolic segments
1513! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1514!
1515! NOTE: Although each parabolic segment is monotonic within its grid
1516! box, monotonicity of the whole profile is not guaranteed,
1517! because bL(k+1)-bR(k) may still have different sign than
1518! qc(i,k+1)-qc(i,k). This possibility is excluded,
1519! after bL and bR are reconciled using WENO procedure.
1520!
1521 cff=(dltr-dltl)*hz_inv3(i,k)
1522 dltr=dltr-cff*hz(i,j,k+1)
1523 dltl=dltl+cff*hz(i,j,k-1)
1524 br(i,k)=qc(i,k)+dltr
1525 bl(i,k)=qc(i,k)-dltl
1526 wr(i,k)=(2.0_r8*dltr-dltl)**2
1527 wl(i,k)=(dltr-2.0_r8*dltl)**2
1528 END DO
1529 END DO
1530 cff=1.0e-14_r8
1531 DO k=2,n(ng)-2
1532 DO i=istr,iend
1533 dltl=max(cff,wl(i,k ))
1534 dltr=max(cff,wr(i,k+1))
1535 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1536 bl(i,k+1)=br(i,k)
1537 END DO
1538 END DO
1539 DO i=istr,iend
1540 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
1541#if defined LINEAR_CONTINUATION
1542 bl(i,n(ng))=br(i,n(ng)-1)
1543 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
1544#elif defined NEUMANN
1545 bl(i,n(ng))=br(i,n(ng)-1)
1546 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
1547#else
1548 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
1549 bl(i,n(ng))=qc(i,n(ng)) ! conditions
1550 br(i,n(ng)-1)=qc(i,n(ng))
1551#endif
1552#if defined LINEAR_CONTINUATION
1553 br(i,1)=bl(i,2)
1554 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
1555#elif defined NEUMANN
1556 br(i,1)=bl(i,2)
1557 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
1558#else
1559 bl(i,2)=qc(i,1) ! bottom grid boxes are
1560 br(i,1)=qc(i,1) ! re-assumed to be
1561 bl(i,1)=qc(i,1) ! piecewise constant.
1562#endif
1563 END DO
1564!
1565! Apply monotonicity constraint again, since the reconciled interfacial
1566! values may cause a non-monotonic behavior of the parabolic segments
1567! inside the grid box.
1568!
1569 DO k=1,n(ng)
1570 DO i=istr,iend
1571 dltr=br(i,k)-qc(i,k)
1572 dltl=qc(i,k)-bl(i,k)
1573 cffr=2.0_r8*dltr
1574 cffl=2.0_r8*dltl
1575!^ tl_bL(i,k)=tl_qc(i,k)-tl_dltL
1576!^
1577 ad_qc(i,k)=ad_qc(i,k)+ad_bl(i,k)
1578 ad_dltl=ad_dltl-ad_bl(i,k)
1579 ad_bl(i,k)=0.0_r8
1580!^ tl_bR(i,k)=tl_qc(i,k)+tl_dltR
1581!^
1582 ad_qc(i,k)=ad_qc(i,k)+ad_br(i,k)
1583 ad_dltr=ad_dltr+ad_br(i,k)
1584 ad_br(i,k)=0.0_r8
1585 IF ((dltr*dltl).lt.0.0_r8) THEN
1586!^ tl_dltR=0.0_r8
1587!^
1588 ad_dltr=0.0_r8
1589!^ tl_dltL=0.0_r8
1590!^
1591 ad_dltl=0.0_r8
1592 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1593!^ tl_dltR=tl_cffL
1594!^
1595 ad_cffl=ad_cffl+ad_dltr
1596 ad_dltr=0.0_r8
1597 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1598!^ tl_dltL=tl_cffR
1599!^
1600 ad_cffr=ad_cffr+ad_dltl
1601 ad_dltl=0.0_r8
1602 END IF
1603!^ tl_cffL=2.0_r8*tl_dltL
1604!^
1605 ad_dltl=ad_dltl+2.0_r8*ad_cffl
1606 ad_cffl=0.0_r8
1607!^ tl_cffR=2.0_r8*tl_dltR
1608!^
1609 ad_dltr=ad_dltr+2.0_r8*ad_cffr
1610 ad_cffr=0.0_r8
1611!^ tl_dltL=tl_qc(i,k)-tl_bL(i,k)
1612!^
1613 ad_qc(i,k)=ad_qc(i,k)+ad_dltl
1614 ad_bl(i,k)=ad_bl(i,k)-ad_dltl
1615 ad_dltl=0.0_r8
1616!^ tl_dltR=tl_bR(i,k)-tl_qc(i,k)
1617!^
1618 ad_br(i,k)=ad_br(i,k)+ad_dltr
1619 ad_qc(i,k)=ad_qc(i,k)-ad_dltr
1620 ad_dltr=0.0_r8
1621 END DO
1622 END DO
1623 DO i=istr,iend
1624#if defined LINEAR_CONTINUATION
1625!^ tl_bR(i,1)=tl_bL(i,2)
1626!^
1627 ad_bl(i,2)=ad_bl(i,2)+ad_br(i,1)
1628 ad_br(i,1)=0.0_r8
1629!^ tl_bL(i,1)=2.0_r8*tl_qc(i,1)-tl_bR(i,1)
1630!^
1631 ad_qc(i,1)=ad_qc(i,1)+2.0_r8*ad_bl(i,1)
1632 ad_br(i,1)=ad_br(i,1)-ad_bl(i,1)
1633 ad_bl(i,1)=0.0_r8
1634#elif defined NEUMANN
1635!^ tl_bR(i,1)=tl_bL(i,2)
1636!^
1637 ad_bl(i,2)=ad_bl(i,2)+ad_br(i,1)
1638 ad_br(i,1)=0.0_r8
1639!^ tl_bL(i,1)=1.5_r8*tl_qc(i,1)-0.5_r8*tl_bR(i,1)
1640!^
1641 ad_qc(i,1)=ad_qc(i,1)+1.5_r8*ad_bl(i,1)
1642 ad_br(i,1)=ad_br(i,1)-0.5_r8*ad_bl(i,1)
1643 ad_bl(i,1)=0.0_r8
1644#else
1645!^ tl_bL(i,2)=tl_qc(i,1) ! bottom grid boxes are
1646!^ tl_bR(i,1)=tl_qc(i,1) ! re-assumed to be
1647!^ tl_bL(i,1)=tl_qc(i,1) ! piecewise constant.
1648!^
1649 ad_qc(i,1)=ad_qc(i,1)+ad_bl(i,1)+ &
1650 & ad_br(i,1)+ &
1651 & ad_bl(i,2)
1652 ad_bl(i,1)=0.0_r8
1653 ad_br(i,1)=0.0_r8
1654 ad_bl(i,2)=0.0_r8
1655#endif
1656#if defined LINEAR_CONTINUATION
1657!^ tl_bL(i,N(ng))=tl_bR(i,N(ng)-1)
1658!^
1659 ad_br(i,n(ng)-1)=ad_br(i,n(ng)-1)+ad_bl(i,n(ng))
1660 ad_bl(i,n(ng))=0.0_r8
1661!^ tl_bR(i,N(ng))=2.0_r8*tl_qc(i,N(ng))-tl_bL(i,N(ng))
1662!^
1663 ad_qc(i,n(ng))=ad_qc(i,n(ng))+2.0_r8*ad_br(i,n(ng))
1664 ad_bl(i,n(ng))=ad_bl(i,n(ng))-ad_br(i,n(ng))
1665 ad_br(i,n(ng))=0.0_r8
1666#elif defined NEUMANN
1667!^ tl_bL(i,N(ng))=tl_bR(i,N(ng)-1)
1668!^
1669 ad_br(i,n(ng)-1)=ad_br(i,n(ng)-1)+ad_bl(i,n(ng))
1670 ad_bl(i,n(ng))=0.0_r8
1671!^ tl_bR(i,N(ng))=1.5_r8*tl_qc(i,N(ng))-0.5_r8*tl_bL(i,N(ng))
1672!^
1673 ad_qc(i,n(ng))=ad_qc(i,n(ng))+1.5_r8*ad_br(i,n(ng))
1674 ad_bl(i,n(ng))=ad_bl(i,n(ng))-0.5_r8*ad_br(i,n(ng))
1675 ad_br(i,n(ng))=0.0_r8
1676#else
1677!^ tl_bR(i,N(ng))=tl_qc(i,N(ng)) ! default strictly monotonic
1678!^ tl_bL(i,N(ng))=tl_qc(i,N(ng)) ! conditions
1679!^ tl_bR(i,N(ng)-1)=tl_qc(i,N(ng))
1680!^
1681 ad_qc(i,n(ng))=ad_qc(i,n(ng))+ad_br(i,n(ng)-1)+ &
1682 & ad_bl(i,n(ng))+ &
1683 & ad_br(i,n(ng))
1684 ad_br(i,n(ng)-1)=0.0_r8
1685 ad_bl(i,n(ng))=0.0_r8
1686 ad_br(i,n(ng))=0.0_r8
1687#endif
1688 END DO
1689!
1690! Compute WR and WL arrays appropriate for this part of the code.
1691!
1692! Copy concentration of biological particulates into scratch array
1693! "qc" (q-central, restrict it to be positive) which is hereafter
1694! interpreted as a set of grid-box averaged values for biogeochemical
1695! constituent concentration.
1696!
1697 DO k=1,n(ng)
1698 DO i=istr,iend
1699 qc(i,k)=bio(i,k,ibio)
1700 END DO
1701 END DO
1702!
1703 DO k=n(ng)-1,1,-1
1704 DO i=istr,iend
1705 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
1706 END DO
1707 END DO
1708 DO k=2,n(ng)-1
1709 DO i=istr,iend
1710 dltr=hz(i,j,k)*fc(i,k)
1711 dltl=hz(i,j,k)*fc(i,k-1)
1712 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1713 cffr=cff*fc(i,k)
1714 cffl=cff*fc(i,k-1)
1715!
1716! Apply PPM monotonicity constraint to prevent oscillations within the
1717! grid box.
1718!
1719 IF ((dltr*dltl).le.0.0_r8) THEN
1720 dltr=0.0_r8
1721 dltl=0.0_r8
1722 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1723 dltr=cffl
1724 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1725 dltl=cffr
1726 END IF
1727!
1728! Compute right and left side values (bR,bL) of parabolic segments
1729! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1730!
1731! NOTE: Although each parabolic segment is monotonic within its grid
1732! box, monotonicity of the whole profile is not guaranteed,
1733! because bL(k+1)-bR(k) may still have different sign than
1734! qc(i,k+1)-qc(i,k). This possibility is excluded,
1735! after bL and bR are reconciled using WENO procedure.
1736!
1737 cff=(dltr-dltl)*hz_inv3(i,k)
1738 dltr=dltr-cff*hz(i,j,k+1)
1739 dltl=dltl+cff*hz(i,j,k-1)
1740 br(i,k)=qc(i,k)+dltr
1741 bl(i,k)=qc(i,k)-dltl
1742 wr(i,k)=(2.0_r8*dltr-dltl)**2
1743 wl(i,k)=(dltr-2.0_r8*dltl)**2
1744 END DO
1745 END DO
1746
1747 cff=1.0e-14_r8
1748 DO k=2,n(ng)-2
1749 DO i=istr,iend
1750 dltl=max(cff,wl(i,k ))
1751 dltr=max(cff,wr(i,k+1))
1752 br1(i,k)=br(i,k)
1753 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
1754 bl1(i,k+1)=bl(i,k+1)
1755 bl(i,k+1)=br(i,k)
1756!^ tl_bL(i,k+1)=tl_bR(i,k)
1757!^
1758 ad_br(i,k)=ad_br(i,k)+ad_bl(i,k+1)
1759 ad_bl(i,k+1)=0.0_r8
1760!^ tl_bR(i,k)=(tl_dltR*bR1(i,k)+dltR*tl_bR(i,k)+ &
1761!^ & tl_dltL*bL1(i,k+1)+dltL*tl_bL(i,k+1))/ &
1762!^ & (dltR+dltL)- &
1763!^ & (tl_dltR+tl_dltL)*bR(i,k)/(dltR+dltL)
1764!^
1765 adfac=ad_br(i,k)/(dltr+dltl)
1766 adfac1=ad_br(i,k)*br(i,k)/(dltr+dltl)
1767 ad_dltr=ad_dltr+adfac*br1(i,k)
1768 ad_dltl=ad_dltl+adfac*bl1(i,k+1)
1769 ad_bl(i,k+1)=ad_bl(i,k+1)+dltl*adfac
1770 ad_dltr=ad_dltr-adfac1
1771 ad_dltl=ad_dltl-adfac1
1772 ad_br(i,k)=dltr*adfac
1773!^ tl_dltR=(0.5_r8-SIGN(0.5_r8,cff-WR(i,k+1)))* &
1774!^ & tl_WR(i,k+1)
1775!^
1776 ad_wr(i,k+1)=ad_wr(i,k+1)+ &
1777 & (0.5_r8-sign(0.5_r8,cff-wr(i,k+1)))* &
1778 & ad_dltr
1779 ad_dltr=0.0_r8
1780!^ tl_dltL=(0.5_r8-SIGN(0.5_r8,cff-WL(i,k )))* &
1781!^ & tl_WL(i,k )
1782!^
1783 ad_wl(i,k )=ad_wl(i,k )+ &
1784 & (0.5_r8-sign(0.5_r8,cff-wl(i,k )))* &
1785 & ad_dltl
1786 ad_dltl=0.0_r8
1787 END DO
1788 END DO
1789
1790 DO k=2,n(ng)-1
1791 DO i=istr,iend
1792!
1793! Compute appropriate dltL and dltr.
1794!
1795 dltr=hz(i,j,k)*fc(i,k)
1796 dltl=hz(i,j,k)*fc(i,k-1)
1797 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1798 cffr=cff*fc(i,k)
1799 cffl=cff*fc(i,k-1)
1800!
1801! Apply PPM monotonicity constraint to prevent oscillations within the
1802! grid box.
1803!
1804 IF ((dltr*dltl).le.0.0_r8) THEN
1805 dltr=0.0_r8
1806 dltl=0.0_r8
1807 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1808 dltr=cffl
1809 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1810 dltl=cffr
1811 END IF
1812!
1813! Compute right and left side values (bR,bL) of parabolic segments
1814! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
1815!
1816! NOTE: Although each parabolic segment is monotonic within its grid
1817! box, monotonicity of the whole profile is not guaranteed,
1818! because bL(k+1)-bR(k) may still have different sign than
1819! qc(i,k+1)-qc(i,k). This possibility is excluded,
1820! after bL and bR are reconciled using WENO procedure.
1821!
1822 cff=(dltr-dltl)*hz_inv3(i,k)
1823 dltr=dltr-cff*hz(i,j,k+1)
1824 dltl=dltl+cff*hz(i,j,k-1)
1825!^ tl_WL(i,k)=2.0_r8*(dltR-2.0_r8*dltL)* &
1826!^ & (tl_dltR-2.0_r8*tl_dltL)
1827!^
1828 adfac=ad_wl(i,k)*2.0_r8*(dltr-2.0_r8*dltl)
1829 ad_dltr=ad_dltr+adfac
1830 ad_dltl=ad_dltl-2.0_r8*adfac
1831 ad_wl(i,k)=0.0_r8
1832
1833!^ tl_WR(i,k)=2.0_r8*(2.0_r8*dltR-dltL)* &
1834!^ & (2.0_r8*tl_dltR-tl_dltL)
1835!^
1836 adfac=ad_wr(i,k)*2.0_r8*(2.0_r8*dltr-dltl)
1837 ad_dltr=ad_dltr+2.0_r8*adfac
1838 ad_dltl=ad_dltl-adfac
1839 ad_wr(i,k)=0.0_r8
1840!^ tl_bL(i,k)=tl_qc(i,k)-tl_dltL
1841!^
1842 ad_qc(i,k)=ad_qc(i,k)+ad_bl(i,k)
1843 ad_dltl=ad_dltl-ad_bl(i,k)
1844 ad_bl(i,k)=0.0_r8
1845!^ tl_bR(i,k)=tl_qc(i,k)+tl_dltR
1846!^
1847 ad_qc(i,k)=ad_qc(i,k)+ad_br(i,k)
1848 ad_dltr=ad_dltr+ad_br(i,k)
1849 ad_br(i,k)=0.0_r8
1850
1851!
1852! Compute appropriate dltL and dltr.
1853!
1854 dltr=hz(i,j,k)*fc(i,k)
1855 dltl=hz(i,j,k)*fc(i,k-1)
1856 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1857 cffr=cff*fc(i,k)
1858 cffl=cff*fc(i,k-1)
1859!
1860! Apply PPM monotonicity constraint to prevent oscillations within the
1861! grid box.
1862!
1863 IF ((dltr*dltl).le.0.0_r8) THEN
1864 dltr=0.0_r8
1865 dltl=0.0_r8
1866 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1867 dltr=cffl
1868 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1869 dltl=cffr
1870 END IF
1871
1872 cff=(dltr-dltl)*hz_inv3(i,k)
1873!^ tl_dltL=tl_dltL+tl_cff*Hz(i,j,k-1)+cff*tl_Hz(i,j,k-1)
1874!^
1875 ad_cff=ad_cff+ad_dltl*hz(i,j,k-1)
1876 ad_hz(i,j,k-1)=ad_hz(i,j,k-1)+cff*ad_dltl
1877!^ tl_dltR=tl_dltR-tl_cff*Hz(i,j,k+1)-cff*tl_Hz(i,j,k+1)
1878!^
1879 ad_cff=ad_cff-ad_dltr*hz(i,j,k+1)
1880 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)-cff*ad_dltr
1881!^ tl_cff=(tl_dltR-tl_dltL)*Hz_inv3(i,k)+ &
1882!^ & (dltR-dltL)*tl_Hz_inv3(i,k)
1883!^
1884 adfac=ad_cff*hz_inv3(i,k)
1885 ad_dltr=ad_dltr+adfac
1886 ad_dltl=ad_dltl-adfac
1887 ad_hz_inv3(i,k)=ad_hz_inv3(i,k)+(dltr-dltl)*ad_cff
1888 ad_cff=0.0_r8
1889!
1890! Compute appropriate dltL and dltr.
1891!
1892 dltr=hz(i,j,k)*fc(i,k)
1893 dltl=hz(i,j,k)*fc(i,k-1)
1894 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
1895 cffr=cff*fc(i,k)
1896 cffl=cff*fc(i,k-1)
1897
1898 IF ((dltr*dltl).le.0.0_r8) THEN
1899!^ tl_dltR=0.0_r8
1900!^
1901 ad_dltr=0.0_r8
1902!^ tl_dltL=0.0_r8
1903!^
1904 ad_dltl=0.0_r8
1905 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
1906!^ tl_dltR=tl_cffL
1907!^
1908 ad_cffl=ad_cffl+ad_dltr
1909 ad_dltr=0.0_r8
1910 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
1911!^ tl_dltL=tl_cffR
1912!^
1913 ad_cffr=ad_cffr+ad_dltl
1914 ad_dltl=0.0_r8
1915 END IF
1916!^ tl_cffL=tl_cff*FC(i,k-1)+cff*tl_FC(i,k-1)
1917!^
1918 ad_cff=ad_cff+ad_cffl*fc(i,k-1)
1919 ad_fc(i,k-1)=ad_fc(i,k-1)+cff*ad_cffl
1920 ad_cffl=0.0_r8
1921!^ tl_cffR=tl_cff*FC(i,k)+cff*tl_FC(i,k)
1922!^
1923 ad_cff=ad_cff+ad_cffr*fc(i,k)
1924 ad_fc(i,k)=ad_fc(i,k)+cff*ad_cffr
1925 ad_cffr=0.0_r8
1926!^ tl_cff=tl_Hz(i,j,k-1)+2.0_r8*tl_Hz(i,j,k)+tl_Hz(i,j,k+1)
1927!^
1928 ad_hz(i,j,k-1)=ad_hz(i,j,k-1)+ad_cff
1929 ad_hz(i,j,k)=ad_hz(i,j,k)+2.0_r8*ad_cff
1930 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)+ad_cff
1931 ad_cff=0.0_r8
1932!^ tl_dltL=tl_Hz(i,j,k)*FC(i,k-1)+Hz(i,j,k)*tl_FC(i,k-1)
1933!^
1934 ad_hz(i,j,k)=ad_hz(i,j,k)+ad_dltl*fc(i,k-1)
1935 ad_fc(i,k-1)=ad_fc(i,k-1)+ad_dltl*hz(i,j,k)
1936 ad_dltl=0.0_r8
1937!^ tl_dltR=tl_Hz(i,j,k)*FC(i,k)+Hz(i,j,k)*tl_FC(i,k)
1938!^
1939 ad_hz(i,j,k)=ad_hz(i,j,k)+ad_dltr*fc(i,k)
1940 ad_fc(i,k)=ad_fc(i,k)+ad_dltr*hz(i,j,k)
1941 ad_dltr=0.0_r8
1942 END DO
1943 END DO
1944 DO k=n(ng)-1,1,-1
1945 DO i=istr,iend
1946!^ tl_FC(i,k)=(tl_qc(i,k+1)-tl_qc(i,k))*Hz_inv2(i,k)+ &
1947!^ & (qc(i,k+1)-qc(i,k))*tl_Hz_inv2(i,k)
1948!^
1949 adfac=ad_fc(i,k)*hz_inv2(i,k)
1950 ad_qc(i,k+1)=ad_qc(i,k+1)+adfac
1951 ad_qc(i,k)=ad_qc(i,k)-adfac
1952 ad_hz_inv2(i,k)=ad_hz_inv2(i,k)+(qc(i,k+1)-qc(i,k))* &
1953 & ad_fc(i,k)
1954 ad_fc(i,k)=0.0_r8
1955 END DO
1956 END DO
1957 DO k=1,n(ng)
1958 DO i=istr,iend
1959!^ tl_qc(i,k)=tl_Bio(i,k,ibio)
1960!^
1961 ad_bio(i,k,ibio)=ad_bio(i,k,ibio)+ad_qc(i,k)
1962 ad_qc(i,k)=0.0_r8
1963 END DO
1964 END DO
1965
1966 END DO sink_loop1
1967
1968!
1969! Compute appropriate basic state arrays II.
1970!
1971 DO k=1,n(ng)
1972 DO i=istr,iend
1973!
1974! At input, all tracers (index nnew) from predictor step have
1975! transport units (m Tunits) since we do not have yet the new
1976! values for zeta and Hz. These are known after the 2D barotropic
1977! time-stepping.
1978!
1979! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
1980! tracer times depth. However the basic state (nstp and nnew
1981! indices) that is read from the forward file is in units of
1982! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
1983! use t instead of t*Hz_inv.
1984!
1985 DO itrc=1,nbt
1986 ibio=idbio(itrc)
1987!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1988!^
1989 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
1990!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
1991!^
1992 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
1993 END DO
1994!
1995! Impose positive definite concentrations.
1996!
1997 cff2=0.0_r8
1998 DO itime=1,2
1999 cff1=0.0_r8
2000 itrcmax=idbio(1)
2001 DO itrc=1,nbt
2002 ibio=idbio(itrc)
2003 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
2004 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
2005 itrcmax=ibio
2006 END IF
2007 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
2008 END DO
2009 IF (biotrc(itrcmax,itime).gt.cff1) THEN
2010 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
2011 END IF
2012 END DO
2013!
2014! Load biological tracers into local arrays.
2015!
2016 DO itrc=1,nbt
2017 ibio=idbio(itrc)
2018 bio_old(i,k,ibio)=biotrc(ibio,nstp)
2019 bio(i,k,ibio)=biotrc(ibio,nstp)
2020 END DO
2021 END DO
2022 END DO
2023!
2024! Calculate surface Photosynthetically Available Radiation (PAR). The
2025! net shortwave radiation is scaled back to Watts/m2 and multiplied by
2026! the fraction that is photosynthetically available, PARfrac.
2027!
2028 DO i=istr,iend
2029#ifdef CONST_PAR
2030!
2031! Specify constant surface irradiance a la Powell and Spitz.
2032!
2033 parsur(i)=158.075_r8
2034#else
2035 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
2036#endif
2037 END DO
2038!
2039!=======================================================================
2040! Start internal iterations to achieve convergence of the nonlinear
2041! backward-implicit solution.
2042!=======================================================================
2043!
2044 DO iteradj=1,iter
2045!
2046! Compute light attenuation as function of depth.
2047!
2048 DO i=istr,iend
2049 par=parsur(i)
2050 IF (parsur(i).gt.0.0_r8) THEN ! day time
2051 DO k=n(ng),1,-1
2052!
2053! Compute average light attenuation for each grid cell. Here, AttSW is
2054! the light attenuation due to seawater and AttPhy is the attenuation
2055! due to phytoplankton (self-shading coefficient).
2056!
2057 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
2058 & (z_w(i,j,k)-z_w(i,j,k-1))
2059 expatt=exp(-att)
2060 itop=par
2061 par=itop*(1.0_r8-expatt)/att ! average at cell center
2062 light(i,k)=par
2063!
2064! Light attenuation at the bottom of the grid cell. It is the starting
2065! PAR value for the next (deeper) vertical grid cell.
2066!
2067 par=itop*expatt
2068 END DO
2069 ELSE ! night time
2070 DO k=1,n(ng)
2071 light(i,k)=0.0_r8
2072 END DO
2073 END IF
2074 END DO
2075!
2076! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
2077! The Michaelis-Menten curve is used to describe the change in uptake
2078! rate as a function of nitrate concentration. Here, PhyIS is the
2079! initial slope of the P-I curve and K_NO3 is the half saturation of
2080! phytoplankton nitrate uptake.
2081!
2082 cff1=dtdays*vm_no3(ng)*phyis(ng)
2083 cff2=vm_no3(ng)*vm_no3(ng)
2084 cff3=phyis(ng)*phyis(ng)
2085 DO k=1,n(ng)
2086 DO i=istr,iend
2087 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
2088 cff=bio(i,k,iphyt)* &
2089 & cff1*cff4*light(i,k)/ &
2090 & (k_no3(ng)+bio(i,k,ino3_))
2091 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
2092 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
2093 & bio(i,k,ino3_)*cff
2094 END DO
2095 END DO
2096!
2097! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
2098! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
2099! pool as function of "sloppy feeding" and metabolic processes
2100! (ZooEEN and ZooEED fractions).
2101!
2102 cff1=dtdays*zoogr(ng)
2103 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
2104 DO k=1,n(ng)
2105 DO i=istr,iend
2106 cff=bio(i,k,izoop)* &
2107 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
2108 & bio(i,k,iphyt)
2109 bio1(i,k,iphyt)=bio(i,k,iphyt)
2110 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
2111 bio1(i,k,izoop)=bio(i,k,izoop)
2112 bio(i,k,izoop)=bio(i,k,izoop)+ &
2113 & bio(i,k,iphyt)*cff2*cff
2114 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2115 & bio(i,k,iphyt)*zooeen(ng)*cff
2116 bio(i,k,isdet)=bio(i,k,isdet)+ &
2117 & bio(i,k,iphyt)*zooeed(ng)*cff
2118 END DO
2119 END DO
2120!
2121 IF (iteradj.ne.iter) THEN
2122!
2123! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
2124! (PhyMRD rate).
2125!
2126 cff3=dtdays*phymrd(ng)
2127 cff2=dtdays*phymrn(ng)
2128 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2129 DO k=1,n(ng)
2130 DO i=istr,iend
2131 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
2132 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2133 & bio(i,k,iphyt)*cff2
2134 bio(i,k,isdet)=bio(i,k,isdet)+ &
2135 & bio(i,k,iphyt)*cff3
2136 END DO
2137 END DO
2138!
2139! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
2140! (ZooMRD rate).
2141!
2142 cff3=dtdays*zoomrd(ng)
2143 cff2=dtdays*zoomrn(ng)
2144 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2145 DO k=1,n(ng)
2146 DO i=istr,iend
2147 bio(i,k,izoop)=bio(i,k,izoop)*cff1
2148 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2149 & bio(i,k,izoop)*cff2
2150 bio(i,k,isdet)=bio(i,k,isdet)+ &
2151 & bio(i,k,izoop)*cff3
2152 END DO
2153 END DO
2154!
2155! Detritus breakdown to nutrients: remineralization (DetRR rate).
2156!
2157 cff2=dtdays*detrr(ng)
2158 cff1=1.0_r8/(1.0_r8+cff2)
2159 DO k=1,n(ng)
2160 DO i=istr,iend
2161 bio(i,k,isdet)=bio(i,k,isdet)*cff1
2162 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2163 & bio(i,k,isdet)*cff2
2164 END DO
2165 END DO
2166!
2167!-----------------------------------------------------------------------
2168! Vertical sinking terms: Phytoplankton and Detritus
2169!-----------------------------------------------------------------------
2170!
2171! Reconstruct vertical profile of selected biological constituents
2172! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
2173! grid box. Then, compute semi-Lagrangian flux due to sinking.
2174!
2175 DO isink=1,nsink
2176 ibio=idsink(isink)
2177!
2178! Copy concentration of biological particulates into scratch array
2179! "qc" (q-central, restrict it to be positive) which is hereafter
2180! interpreted as a set of grid-box averaged values for biogeochemical
2181! constituent concentration.
2182!
2183 DO k=1,n(ng)
2184 DO i=istr,iend
2185 qc(i,k)=bio(i,k,ibio)
2186 END DO
2187 END DO
2188!
2189 DO k=n(ng)-1,1,-1
2190 DO i=istr,iend
2191 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
2192 END DO
2193 END DO
2194 DO k=2,n(ng)-1
2195 DO i=istr,iend
2196 dltr=hz(i,j,k)*fc(i,k)
2197 dltl=hz(i,j,k)*fc(i,k-1)
2198 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2199 cffr=cff*fc(i,k)
2200 cffl=cff*fc(i,k-1)
2201!
2202! Apply PPM monotonicity constraint to prevent oscillations within the
2203! grid box.
2204!
2205 IF ((dltr*dltl).le.0.0_r8) THEN
2206 dltr=0.0_r8
2207 dltl=0.0_r8
2208 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2209 dltr=cffl
2210 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2211 dltl=cffr
2212 END IF
2213!
2214! Compute right and left side values (bR,bL) of parabolic segments
2215! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
2216!
2217! NOTE: Although each parabolic segment is monotonic within its grid
2218! box, monotonicity of the whole profile is not guaranteed,
2219! because bL(k+1)-bR(k) may still have different sign than
2220! qc(i,k+1)-qc(i,k). This possibility is excluded,
2221! after bL and bR are reconciled using WENO procedure.
2222!
2223 cff=(dltr-dltl)*hz_inv3(i,k)
2224 dltr=dltr-cff*hz(i,j,k+1)
2225 dltl=dltl+cff*hz(i,j,k-1)
2226 br(i,k)=qc(i,k)+dltr
2227 bl(i,k)=qc(i,k)-dltl
2228 wr(i,k)=(2.0_r8*dltr-dltl)**2
2229 wl(i,k)=(dltr-2.0_r8*dltl)**2
2230 END DO
2231 END DO
2232 cff=1.0e-14_r8
2233 DO k=2,n(ng)-2
2234 DO i=istr,iend
2235 dltl=max(cff,wl(i,k ))
2236 dltr=max(cff,wr(i,k+1))
2237 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
2238 bl(i,k+1)=br(i,k)
2239 END DO
2240 END DO
2241 DO i=istr,iend
2242 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
2243#if defined LINEAR_CONTINUATION
2244 bl(i,n(ng))=br(i,n(ng)-1)
2245 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
2246#elif defined NEUMANN
2247 bl(i,n(ng))=br(i,n(ng)-1)
2248 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
2249#else
2250 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
2251 bl(i,n(ng))=qc(i,n(ng)) ! conditions
2252 br(i,n(ng)-1)=qc(i,n(ng))
2253#endif
2254#if defined LINEAR_CONTINUATION
2255 br(i,1)=bl(i,2)
2256 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
2257#elif defined NEUMANN
2258 br(i,1)=bl(i,2)
2259 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
2260#else
2261 bl(i,2)=qc(i,1) ! bottom grid boxes are
2262 br(i,1)=qc(i,1) ! re-assumed to be
2263 bl(i,1)=qc(i,1) ! piecewise constant.
2264#endif
2265 END DO
2266!
2267! Apply monotonicity constraint again, since the reconciled interfacial
2268! values may cause a non-monotonic behavior of the parabolic segments
2269! inside the grid box.
2270!
2271 DO k=1,n(ng)
2272 DO i=istr,iend
2273 dltr=br(i,k)-qc(i,k)
2274 dltl=qc(i,k)-bl(i,k)
2275 cffr=2.0_r8*dltr
2276 cffl=2.0_r8*dltl
2277 IF ((dltr*dltl).lt.0.0_r8) THEN
2278 dltr=0.0_r8
2279 dltl=0.0_r8
2280 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2281 dltr=cffl
2282 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2283 dltl=cffr
2284 END IF
2285 br(i,k)=qc(i,k)+dltr
2286 bl(i,k)=qc(i,k)-dltl
2287 END DO
2288 END DO
2289!
2290! After this moment reconstruction is considered complete. The next
2291! stage is to compute vertical advective fluxes, FC. It is expected
2292! that sinking may occurs relatively fast, the algorithm is designed
2293! to be free of CFL criterion, which is achieved by allowing
2294! integration bounds for semi-Lagrangian advective flux to use as
2295! many grid boxes in upstream direction as necessary.
2296!
2297! In the two code segments below, WL is the z-coordinate of the
2298! departure point for grid box interface z_w with the same indices;
2299! FC is the finite volume flux; ksource(:,k) is index of vertical
2300! grid box which contains the departure point (restricted by N(ng)).
2301! During the search: also add in content of whole grid boxes
2302! participating in FC.
2303!
2304 cff=dtdays*abs(wbio(isink))
2305 DO k=1,n(ng)
2306 DO i=istr,iend
2307 fc(i,k-1)=0.0_r8
2308 wl(i,k)=z_w(i,j,k-1)+cff
2309 wr(i,k)=hz(i,j,k)*qc(i,k)
2310 ksource(i,k)=k
2311 END DO
2312 END DO
2313 DO k=1,n(ng)
2314 DO ks=k,n(ng)-1
2315 DO i=istr,iend
2316 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
2317 ksource(i,k)=ks+1
2318 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
2319 END IF
2320 END DO
2321 END DO
2322 END DO
2323!
2324! Finalize computation of flux: add fractional part.
2325!
2326 DO k=1,n(ng)
2327 DO i=istr,iend
2328 ks=ksource(i,k)
2329 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
2330 fc(i,k-1)=fc(i,k-1)+ &
2331 & hz(i,j,ks)*cu* &
2332 & (bl(i,ks)+ &
2333 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2334 & (1.5_r8-cu)* &
2335 & (br(i,ks)+bl(i,ks)- &
2336 & 2.0_r8*qc(i,ks))))
2337 END DO
2338 END DO
2339 DO k=1,n(ng)
2340 DO i=istr,iend
2341 bio(i,k,ibio)=qc(i,k)+ &
2342 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
2343 END DO
2344 END DO
2345 END DO
2346 END IF
2347 END DO
2348!
2349! End of compute basic state arrays II.
2350!
2351! Adjoint detritus breakdown to nutrients: remineralization
2352! (DetRR rate).
2353!
2354 cff2=dtdays*detrr(ng)
2355 cff1=1.0_r8/(1.0_r8+cff2)
2356 DO k=1,n(ng)
2357 DO i=istr,iend
2358!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2359!^ & tl_Bio(i,k,iSDet)*cff2
2360!^
2361 ad_bio(i,k,isdet)=ad_bio(i,k,isdet)+ &
2362 & cff2*ad_bio(i,k,ino3_)
2363!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)*cff1
2364!^
2365 ad_bio(i,k,isdet)=ad_bio(i,k,isdet)*cff1
2366 END DO
2367 END DO
2368!
2369! Adjoint Zooplankton mortality to nutrients (ZooMRN rate) and
2370! Detritus (ZooMRD rate).
2371!
2372 cff3=dtdays*zoomrd(ng)
2373 cff2=dtdays*zoomrn(ng)
2374 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2375 DO k=1,n(ng)
2376 DO i=istr,iend
2377!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)+ &
2378!^ & tl_Bio(i,k,iZoop)*cff3
2379!^
2380 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)+ &
2381 & cff3*ad_bio(i,k,isdet)
2382!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2383!^ & tl_Bio(i,k,iZoop)*cff2
2384!^
2385 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)+ &
2386 & cff2*ad_bio(i,k,ino3_)
2387!^ tl_Bio(i,k,iZoop)=tl_Bio(i,k,iZoop)*cff1
2388!^
2389 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)*cff1
2390 END DO
2391 END DO
2392!
2393! Adjoint Phytoplankton mortality to nutrients (PhyMRN rate) and
2394! detritus (PhyMRD rate).
2395!
2396 cff3=dtdays*phymrd(ng)
2397 cff2=dtdays*phymrn(ng)
2398 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2399 DO k=1,n(ng)
2400 DO i=istr,iend
2401!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)+ &
2402!^ & tl_Bio(i,k,iPhyt)*cff3
2403!^
2404 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2405 & cff3*ad_bio(i,k,isdet)
2406!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2407!^ & tl_Bio(i,k,iPhyt)*cff2
2408!^
2409 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2410 & cff2*ad_bio(i,k,ino3_)
2411!^ tl_Bio(i,k,iPhyt)=tl_Bio(i,k,iPhyt)*cff1
2412!^
2413 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)*cff1
2414 END DO
2415 END DO
2416!
2417! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
2418! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
2419! pool as function of "sloppy feeding" and metabolic processes
2420! (ZooEEN and ZooEED fractions).
2421!
2422 cff1=dtdays*zoogr(ng)
2423 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
2424 DO k=1,n(ng)
2425 DO i=istr,iend
2426 cff=bio1(i,k,izoop)* &
2427 & cff1*(1.0_r8-exp(-ivlev(ng)*bio1(i,k,iphyt)))/ &
2428 & bio1(i,k,iphyt)
2429!^ tl_Bio(i,k,iSDet)=tl_Bio(i,k,iSDet)+ &
2430!^ & ZooEED(ng)*(tl_Bio(i,k,iPhyt)*cff+ &
2431!^ & Bio(i,k,iPhyt)*tl_cff)
2432!^
2433 ad_cff=ad_cff+zooeed(ng)*bio(i,k,iphyt)*ad_bio(i,k,isdet)
2434 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2435 & zooeed(ng)*cff*ad_bio(i,k,isdet)
2436!^ tl_Bio(i,k,iNO3_)=tl_Bio(i,k,iNO3_)+ &
2437!^ & ZooEEN(ng)*(tl_Bio(i,k,iPhyt)*cff+ &
2438!^ & Bio(i,k,iPhyt)*tl_cff)
2439!^
2440 ad_cff=ad_cff+ &
2441 & zooeen(ng)*bio(i,k,iphyt)*ad_bio(i,k,ino3_)
2442 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2443 & zooeen(ng)*cff*ad_bio(i,k,ino3_)
2444!^ tl_Bio(i,k,iZoop)=tl_Bio(i,k,iZoop)+ &
2445!^ & cff2*(tl_Bio(i,k,iPhyt)*cff+ &
2446!^ & Bio(i,k,iPhyt)*tl_cff)
2447!^
2448 ad_cff=ad_cff+ &
2449 & cff2*bio(i,k,iphyt)*ad_bio(i,k,izoop)
2450 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2451 & cff2*cff*ad_bio(i,k,izoop)
2452!^ tl_Bio(i,k,iPhyt)=(tl_Bio(i,k,iPhyt)- &
2453!^ & tl_cff*Bio(i,k,iPhyt))/ &
2454!^ & (1.0_r8+cff)
2455!^
2456 adfac=ad_bio(i,k,iphyt)/(1.0_r8+cff)
2457 ad_cff=ad_cff-bio(i,k,iphyt)*adfac
2458 ad_bio(i,k,iphyt)=adfac
2459!^ tl_cff=(tl_Bio(i,k,iZoop)* &
2460!^ & cff1*(1.0_r8-EXP(-Ivlev(ng)*Bio1(i,k,iPhyt)))+ &
2461!^ & Bio1(i,k,iZoop)*Ivlev(ng)*tl_Bio(i,k,iPhyt)*cff1* &
2462!^ & EXP(-Ivlev(ng)*Bio1(i,k,iPhyt))- &
2463!^ & tl_Bio(i,k,iPhyt)*cff)/ &
2464!^ & Bio1(i,k,iPhyt)
2465!^
2466 fac=exp(-ivlev(ng)*bio1(i,k,iphyt))
2467 adfac=ad_cff/bio1(i,k,iphyt)
2468 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)-adfac*cff
2469 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2470 & bio1(i,k,izoop)*ivlev(ng)* &
2471 & adfac*cff1*fac
2472 ad_bio(i,k,izoop)=ad_bio(i,k,izoop)+ &
2473 & adfac*cff1*(1.0_r8-fac)
2474 ad_cff=0.0_r8
2475 END DO
2476 END DO
2477!
2478! Compute appropriate basic state arrays I.
2479!
2480 DO k=1,n(ng)
2481 DO i=istr,iend
2482!
2483! At input, all tracers (index nnew) from predictor step have
2484! transport units (m Tunits) since we do not have yet the new
2485! values for zeta and Hz. These are known after the 2D barotropic
2486! time-stepping.
2487!
2488! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
2489! tracer times depth. However the basic state (nstp and nnew
2490! indices) that is read from the forward file is in units of
2491! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
2492! use t instead of t*Hz_inv.
2493!
2494 DO itrc=1,nbt
2495 ibio=idbio(itrc)
2496!^ BioTrc(ibio,nstp)=t(i,j,k,nstp,ibio)
2497!^
2498 biotrc(ibio,nstp)=t(i,j,k,nstp,ibio)
2499!^ BioTrc(ibio,nnew)=t(i,j,k,nnew,ibio)*Hz_inv(i,k)
2500!^
2501 biotrc(ibio,nnew)=t(i,j,k,nnew,ibio)
2502 END DO
2503!
2504! Impose positive definite concentrations.
2505!
2506 cff2=0.0_r8
2507 DO itime=1,2
2508 cff1=0.0_r8
2509 itrcmax=idbio(1)
2510 DO itrc=1,nbt
2511 ibio=idbio(itrc)
2512 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
2513 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
2514 itrcmax=ibio
2515 END IF
2516 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
2517 END DO
2518 IF (biotrc(itrcmax,itime).gt.cff1) THEN
2519 biotrc(itrcmax,itime)=biotrc(itrcmax,itime)-cff1
2520 END IF
2521 END DO
2522!
2523! Load biological tracers into local arrays.
2524!
2525 DO itrc=1,nbt
2526 ibio=idbio(itrc)
2527 bio_old(i,k,ibio)=biotrc(ibio,nstp)
2528 bio(i,k,ibio)=biotrc(ibio,nstp)
2529 END DO
2530 END DO
2531 END DO
2532!
2533! Calculate surface Photosynthetically Available Radiation (PAR). The
2534! net shortwave radiation is scaled back to Watts/m2 and multiplied by
2535! the fraction that is photosynthetically available, PARfrac.
2536!
2537 DO i=istr,iend
2538#ifdef CONST_PAR
2539!
2540! Specify constant surface irradiance a la Powell and Spitz.
2541!
2542 parsur(i)=158.075_r8
2543#else
2544 parsur(i)=parfrac(ng)*srflx(i,j)*rho0*cp
2545#endif
2546 END DO
2547!
2548!=======================================================================
2549! Start internal iterations to achieve convergence of the nonlinear
2550! backward-implicit solution.
2551!=======================================================================
2552!
2553 DO iteradj=1,iter
2554!
2555! Compute light attenuation as function of depth.
2556!
2557 DO i=istr,iend
2558 par=parsur(i)
2559 IF (parsur(i).gt.0.0_r8) THEN ! day time
2560 DO k=n(ng),1,-1
2561!
2562! Compute average light attenuation for each grid cell. Here, AttSW is
2563! the light attenuation due to seawater and AttPhy is the attenuation
2564! due to phytoplankton (self-shading coefficient).
2565!
2566 att=(attsw(ng)+attphy(ng)*bio(i,k,iphyt))* &
2567 & (z_w(i,j,k)-z_w(i,j,k-1))
2568 expatt=exp(-att)
2569 itop=par
2570 par=itop*(1.0_r8-expatt)/att ! average at cell center
2571 light(i,k)=par
2572!
2573! Light attenuation at the bottom of the grid cell. It is the starting
2574! PAR value for the next (deeper) vertical grid cell.
2575!
2576 par=itop*expatt
2577 END DO
2578 ELSE ! night time
2579 DO k=1,n(ng)
2580 light(i,k)=0.0_r8
2581 END DO
2582 END IF
2583 END DO
2584!
2585! Phytoplankton photosynthetic growth and nitrate uptake (Vm_NO3 rate).
2586! The Michaelis-Menten curve is used to describe the change in uptake
2587! rate as a function of nitrate concentration. Here, PhyIS is the
2588! initial slope of the P-I curve and K_NO3 is the half saturation of
2589! phytoplankton nitrate uptake.
2590!
2591 cff1=dtdays*vm_no3(ng)*phyis(ng)
2592 cff2=vm_no3(ng)*vm_no3(ng)
2593 cff3=phyis(ng)*phyis(ng)
2594 DO k=1,n(ng)
2595 DO i=istr,iend
2596 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
2597 cff=bio(i,k,iphyt)* &
2598 & cff1*cff4*light(i,k)/ &
2599 & (k_no3(ng)+bio(i,k,ino3_))
2600 bio1(i,k,ino3_)=bio(i,k,ino3_)
2601 bio(i,k,ino3_)=bio(i,k,ino3_)/(1.0_r8+cff)
2602 bio1(i,k,iphyt)=bio(i,k,iphyt)
2603 bio(i,k,iphyt)=bio(i,k,iphyt)+ &
2604 & bio(i,k,ino3_)*cff
2605 END DO
2606 END DO
2607!
2608 IF (iteradj.ne.iter) THEN
2609!
2610! Grazing on phytoplankton by zooplankton (ZooGR rate) using the Ivlev
2611! formulation (Ivlev, 1955) and lost of phytoplankton to the nitrate
2612! pool as function of "sloppy feeding" and metabolic processes
2613! (ZooEEN and ZooEED fractions).
2614!
2615 cff1=dtdays*zoogr(ng)
2616 cff2=1.0_r8-zooeen(ng)-zooeed(ng)
2617 DO k=1,n(ng)
2618 DO i=istr,iend
2619 cff=bio(i,k,izoop)* &
2620 & cff1*(1.0_r8-exp(-ivlev(ng)*bio(i,k,iphyt)))/ &
2621 & bio(i,k,iphyt)
2622 bio(i,k,iphyt)=bio(i,k,iphyt)/(1.0_r8+cff)
2623 bio(i,k,izoop)=bio(i,k,izoop)+ &
2624 & bio(i,k,iphyt)*cff2*cff
2625 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2626 & bio(i,k,iphyt)*zooeen(ng)*cff
2627 bio(i,k,isdet)=bio(i,k,isdet)+ &
2628 & bio(i,k,iphyt)*zooeed(ng)*cff
2629 END DO
2630 END DO
2631!
2632! Phytoplankton mortality to nutrients (PhyMRN rate) and detritus
2633! (PhyMRD rate).
2634!
2635 cff3=dtdays*phymrd(ng)
2636 cff2=dtdays*phymrn(ng)
2637 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2638 DO k=1,n(ng)
2639 DO i=istr,iend
2640 bio(i,k,iphyt)=bio(i,k,iphyt)*cff1
2641 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2642 & bio(i,k,iphyt)*cff2
2643 bio(i,k,isdet)=bio(i,k,isdet)+ &
2644 & bio(i,k,iphyt)*cff3
2645 END DO
2646 END DO
2647!
2648! Zooplankton mortality to nutrients (ZooMRN rate) and Detritus
2649! (ZooMRD rate).
2650!
2651 cff3=dtdays*zoomrd(ng)
2652 cff2=dtdays*zoomrn(ng)
2653 cff1=1.0_r8/(1.0_r8+cff2+cff3)
2654 DO k=1,n(ng)
2655 DO i=istr,iend
2656 bio(i,k,izoop)=bio(i,k,izoop)*cff1
2657 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2658 & bio(i,k,izoop)*cff2
2659 bio(i,k,isdet)=bio(i,k,isdet)+ &
2660 & bio(i,k,izoop)*cff3
2661 END DO
2662 END DO
2663!
2664! Detritus breakdown to nutrients: remineralization (DetRR rate).
2665!
2666 cff2=dtdays*detrr(ng)
2667 cff1=1.0_r8/(1.0_r8+cff2)
2668 DO k=1,n(ng)
2669 DO i=istr,iend
2670 bio(i,k,isdet)=bio(i,k,isdet)*cff1
2671 bio(i,k,ino3_)=bio(i,k,ino3_)+ &
2672 & bio(i,k,isdet)*cff2
2673 END DO
2674 END DO
2675!
2676!-----------------------------------------------------------------------
2677! Vertical sinking terms: Phytoplankton and Detritus
2678!-----------------------------------------------------------------------
2679!
2680! Reconstruct vertical profile of selected biological constituents
2681! "Bio(:,:,isink)" in terms of a set of parabolic segments within each
2682! grid box. Then, compute semi-Lagrangian flux due to sinking.
2683!
2684 DO isink=1,nsink
2685 ibio=idsink(isink)
2686!
2687! Copy concentration of biological particulates into scratch array
2688! "qc" (q-central, restrict it to be positive) which is hereafter
2689! interpreted as a set of grid-box averaged values for biogeochemical
2690! constituent concentration.
2691!
2692 DO k=1,n(ng)
2693 DO i=istr,iend
2694 qc(i,k)=bio(i,k,ibio)
2695 END DO
2696 END DO
2697!
2698 DO k=n(ng)-1,1,-1
2699 DO i=istr,iend
2700 fc(i,k)=(qc(i,k+1)-qc(i,k))*hz_inv2(i,k)
2701 END DO
2702 END DO
2703 DO k=2,n(ng)-1
2704 DO i=istr,iend
2705 dltr=hz(i,j,k)*fc(i,k)
2706 dltl=hz(i,j,k)*fc(i,k-1)
2707 cff=hz(i,j,k-1)+2.0_r8*hz(i,j,k)+hz(i,j,k+1)
2708 cffr=cff*fc(i,k)
2709 cffl=cff*fc(i,k-1)
2710!
2711! Apply PPM monotonicity constraint to prevent oscillations within the
2712! grid box.
2713!
2714 IF ((dltr*dltl).le.0.0_r8) THEN
2715 dltr=0.0_r8
2716 dltl=0.0_r8
2717 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2718 dltr=cffl
2719 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2720 dltl=cffr
2721 END IF
2722!
2723! Compute right and left side values (bR,bL) of parabolic segments
2724! within grid box Hz(k); (WR,WL) are measures of quadratic variations.
2725!
2726! NOTE: Although each parabolic segment is monotonic within its grid
2727! box, monotonicity of the whole profile is not guaranteed,
2728! because bL(k+1)-bR(k) may still have different sign than
2729! qc(i,k+1)-qc(i,k). This possibility is excluded,
2730! after bL and bR are reconciled using WENO procedure.
2731!
2732 cff=(dltr-dltl)*hz_inv3(i,k)
2733 dltr=dltr-cff*hz(i,j,k+1)
2734 dltl=dltl+cff*hz(i,j,k-1)
2735 br(i,k)=qc(i,k)+dltr
2736 bl(i,k)=qc(i,k)-dltl
2737 wr(i,k)=(2.0_r8*dltr-dltl)**2
2738 wl(i,k)=(dltr-2.0_r8*dltl)**2
2739 END DO
2740 END DO
2741 cff=1.0e-14_r8
2742 DO k=2,n(ng)-2
2743 DO i=istr,iend
2744 dltl=max(cff,wl(i,k ))
2745 dltr=max(cff,wr(i,k+1))
2746 br(i,k)=(dltr*br(i,k)+dltl*bl(i,k+1))/(dltr+dltl)
2747 bl(i,k+1)=br(i,k)
2748 END DO
2749 END DO
2750 DO i=istr,iend
2751 fc(i,n(ng))=0.0_r8 ! NO-flux boundary condition
2752#if defined LINEAR_CONTINUATION
2753 bl(i,n(ng))=br(i,n(ng)-1)
2754 br(i,n(ng))=2.0_r8*qc(i,n(ng))-bl(i,n(ng))
2755#elif defined NEUMANN
2756 bl(i,n(ng))=br(i,n(ng)-1)
2757 br(i,n(ng))=1.5*qc(i,n(ng))-0.5_r8*bl(i,n(ng))
2758#else
2759 br(i,n(ng))=qc(i,n(ng)) ! default strictly monotonic
2760 bl(i,n(ng))=qc(i,n(ng)) ! conditions
2761 br(i,n(ng)-1)=qc(i,n(ng))
2762#endif
2763#if defined LINEAR_CONTINUATION
2764 br(i,1)=bl(i,2)
2765 bl(i,1)=2.0_r8*qc(i,1)-br(i,1)
2766#elif defined NEUMANN
2767 br(i,1)=bl(i,2)
2768 bl(i,1)=1.5_r8*qc(i,1)-0.5_r8*br(i,1)
2769#else
2770 bl(i,2)=qc(i,1) ! bottom grid boxes are
2771 br(i,1)=qc(i,1) ! re-assumed to be
2772 bl(i,1)=qc(i,1) ! piecewise constant.
2773#endif
2774 END DO
2775!
2776! Apply monotonicity constraint again, since the reconciled interfacial
2777! values may cause a non-monotonic behavior of the parabolic segments
2778! inside the grid box.
2779!
2780 DO k=1,n(ng)
2781 DO i=istr,iend
2782 dltr=br(i,k)-qc(i,k)
2783 dltl=qc(i,k)-bl(i,k)
2784 cffr=2.0_r8*dltr
2785 cffl=2.0_r8*dltl
2786 IF ((dltr*dltl).lt.0.0_r8) THEN
2787 dltr=0.0_r8
2788 dltl=0.0_r8
2789 ELSE IF (abs(dltr).gt.abs(cffl)) THEN
2790 dltr=cffl
2791 ELSE IF (abs(dltl).gt.abs(cffr)) THEN
2792 dltl=cffr
2793 END IF
2794 br(i,k)=qc(i,k)+dltr
2795 bl(i,k)=qc(i,k)-dltl
2796 END DO
2797 END DO
2798!
2799! After this moment reconstruction is considered complete. The next
2800! stage is to compute vertical advective fluxes, FC. It is expected
2801! that sinking may occurs relatively fast, the algorithm is designed
2802! to be free of CFL criterion, which is achieved by allowing
2803! integration bounds for semi-Lagrangian advective flux to use as
2804! many grid boxes in upstream direction as necessary.
2805!
2806! In the two code segments below, WL is the z-coordinate of the
2807! departure point for grid box interface z_w with the same indices;
2808! FC is the finite volume flux; ksource(:,k) is index of vertical
2809! grid box which contains the departure point (restricted by N(ng)).
2810! During the search: also add in content of whole grid boxes
2811! participating in FC.
2812!
2813 cff=dtdays*abs(wbio(isink))
2814 DO k=1,n(ng)
2815 DO i=istr,iend
2816 fc(i,k-1)=0.0_r8
2817 wl(i,k)=z_w(i,j,k-1)+cff
2818 wr(i,k)=hz(i,j,k)*qc(i,k)
2819 ksource(i,k)=k
2820 END DO
2821 END DO
2822 DO k=1,n(ng)
2823 DO ks=k,n(ng)-1
2824 DO i=istr,iend
2825 IF (wl(i,k).gt.z_w(i,j,ks)) THEN
2826 ksource(i,k)=ks+1
2827 fc(i,k-1)=fc(i,k-1)+wr(i,ks)
2828 END IF
2829 END DO
2830 END DO
2831 END DO
2832!
2833! Finalize computation of flux: add fractional part.
2834!
2835 DO k=1,n(ng)
2836 DO i=istr,iend
2837 ks=ksource(i,k)
2838 cu=min(1.0_r8,(wl(i,k)-z_w(i,j,ks-1))*hz_inv(i,ks))
2839 fc(i,k-1)=fc(i,k-1)+ &
2840 & hz(i,j,ks)*cu* &
2841 & (bl(i,ks)+ &
2842 & cu*(0.5_r8*(br(i,ks)-bl(i,ks))- &
2843 & (1.5_r8-cu)* &
2844 & (br(i,ks)+bl(i,ks)- &
2845 & 2.0_r8*qc(i,ks))))
2846 END DO
2847 END DO
2848 DO k=1,n(ng)
2849 DO i=istr,iend
2850 bio(i,k,ibio)=qc(i,k)+ &
2851 & (fc(i,k)-fc(i,k-1))*hz_inv(i,k)
2852 END DO
2853 END DO
2854 END DO
2855 END IF
2856 END DO
2857!
2858! End of compute basic state arrays I.
2859!
2860! Adjoint Phytoplankton photosynthetic growth and nitrate uptake
2861! (Vm_NO3 rate). The Michaelis-Menten curve is used to describe the
2862! change in uptake rate as a function of nitrate concentration.
2863! Here, PhyIS is the initial slope of the P-I curve and K_NO3 is the
2864! half saturation of phytoplankton nitrate uptake.
2865!
2866 cff1=dtdays*vm_no3(ng)*phyis(ng)
2867 cff2=vm_no3(ng)*vm_no3(ng)
2868 cff3=phyis(ng)*phyis(ng)
2869 DO k=1,n(ng)
2870 DO i=istr,iend
2871 cff4=1.0_r8/sqrt(cff2+cff3*light(i,k)*light(i,k))
2872 cff=bio1(i,k,iphyt)* &
2873 & cff1*cff4*light(i,k)/ &
2874 & (k_no3(ng)+bio1(i,k,ino3_))
2875!^ tl_Bio(i,k,iPhyt)=tl_Bio(i,k,iPhyt)+ &
2876!^ & tl_Bio(i,k,iNO3_)*cff+ &
2877!^ & Bio(i,k,iNO3_)*tl_cff
2878!^
2879 ad_cff=ad_cff+bio(i,k,ino3_)*ad_bio(i,k,iphyt)
2880 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)+ &
2881 & cff*ad_bio(i,k,iphyt)
2882!^ tl_Bio(i,k,iNO3_)=(tl_Bio(i,k,iNO3_)- &
2883!^ & tl_cff*Bio(i,k,iNO3_))/ &
2884!^ & (1.0_r8+cff)
2885!^
2886 adfac=ad_bio(i,k,ino3_)/(1.0_r8+cff)
2887 ad_cff=ad_cff-bio(i,k,ino3_)*adfac
2888 ad_bio(i,k,ino3_)=adfac
2889!^ tl_cff=(tl_Bio(i,k,iPhyt)*cff1*cff4*Light(i,k)+ &
2890!^ & Bio1(i,k,iPhyt)*cff1* &
2891!^ & (tl_cff4*Light(i,k)+cff4*tl_Light(i,k))- &
2892!^ & tl_Bio(i,k,iNO3_)*cff)/ &
2893!^ & (K_NO3(ng)+Bio1(i,k,iNO3_))
2894!^
2895 adfac=ad_cff/(k_no3(ng)+bio1(i,k,ino3_))
2896 adfac1=adfac*bio1(i,k,iphyt)*cff1
2897 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2898 & cff1*cff4*light(i,k)*adfac
2899 ad_cff4=adfac1*light(i,k)
2900 ad_light(i,k)=ad_light(i,k)+ &
2901 & adfac1*cff4
2902 ad_bio(i,k,ino3_)=ad_bio(i,k,ino3_)- &
2903 & adfac*cff
2904 ad_cff=0.0_r8
2905!^ tl_cff4=-cff3*tl_Light(i,k)*Light(i,k)*cff4*cff4*cff4
2906!^
2907 ad_light(i,k)=ad_light(i,k)- &
2908 & cff3*light(i,k)* &
2909 & cff4*cff4*cff4*ad_cff4
2910 ad_cff4=0.0_r8
2911 END DO
2912 END DO
2913!
2914! Compute adjoint light attenuation as function of depth.
2915!
2916 DO i=istr,iend
2917 par=parsur(i)
2918 IF (parsur(i).gt.0.0_r8) THEN ! day time
2919 DO k=1,n(ng)
2920!
2921! Compute the basic state PAR appropriate for each level.
2922!
2923 par=parsur(i)
2924 DO kk=n(ng),k,-1
2925!
2926! Compute average light attenuation for each grid cell. Here, AttSW is
2927! the light attenuation due to seawater and AttPhy is the attenuation
2928! due to phytoplankton (self-shading coefficient).
2929!
2930 att=(attsw(ng)+attphy(ng)*bio1(i,kk,iphyt))* &
2931 & (z_w(i,j,kk)-z_w(i,j,kk-1))
2932 expatt=exp(-att)
2933 itop=par
2934 par=itop*(1.0_r8-expatt)/att ! average at cell center
2935 par1=par
2936!
2937! Light attenuation at the bottom of the grid cell. It is the starting
2938! PAR value for the next (deeper) vertical grid cell.
2939!
2940 par=itop*expatt
2941 END DO
2942!
2943! Adjoint of light attenuation at the bottom of the grid cell. It is
2944! the starting PAR value for the next (deeper) vertical grid cell.
2945!
2946!^ tl_PAR=tl_Itop*ExpAtt+Itop*tl_ExpAtt
2947!^
2948 ad_expatt=ad_expatt+itop*ad_par
2949 ad_itop=ad_itop+expatt*ad_par
2950 ad_par=0.0_r8
2951!
2952! Adjoint of compute average light attenuation for each grid cell.
2953! Here, AttSW is the light attenuation due to seawater and AttPhy is
2954! the attenuation due to phytoplankton (self-shading coefficient).
2955!
2956!^ tl_Light(i,k)=tl_PAR
2957!^
2958 ad_par=ad_par+ad_light(i,k)
2959 ad_light(i,k)=0.0_r8
2960!^ tl_PAR=(-tl_Att*PAR1+tl_Itop*(1.0_r8-ExpAtt)- &
2961!^ & Itop*tl_ExpAtt)/Att
2962!^
2963 adfac=ad_par/att
2964 ad_att=ad_att-par1*adfac
2965 ad_expatt=ad_expatt-itop*adfac
2966 ad_itop=ad_itop+(1.0_r8-expatt)*adfac
2967 ad_par=0.0_r8
2968!^ tl_Itop=tl_PAR
2969!^
2970 ad_par=ad_par+ad_itop
2971 ad_itop=0.0_r8
2972!^ tl_ExpAtt=-ExpAtt*tl_Att
2973!^
2974 ad_att=ad_att-expatt*ad_expatt
2975 ad_expatt=0.0_r8
2976!^ tl_Att=AttPhy(ng)*tl_Bio(i,k,iPhyt)* &
2977!^ & (z_w(i,j,k)-z_w(i,j,k-1))+ &
2978!^ & (AttSW(ng)+AttPhy(ng)*Bio1(i,k,iPhyt))* &
2979!^ & (tl_z_w(i,j,k)-tl_z_w(i,j,k-1))
2980!^
2981 adfac=(attsw(ng)+attphy(ng)*bio1(i,k,iphyt))*ad_att
2982 ad_bio(i,k,iphyt)=ad_bio(i,k,iphyt)+ &
2983 & attphy(ng)*(z_w(i,j,k)-z_w(i,j,k-1))* &
2984 & ad_att
2985 ad_z_w(i,j,k-1)=ad_z_w(i,j,k-1)-adfac
2986 ad_z_w(i,j,k )=ad_z_w(i,j,k )+adfac
2987 ad_att=0.0_r8
2988 END DO
2989 ELSE ! night time
2990 DO k=1,n(ng)
2991!^ tl_Light(i,k)=0.0_r8
2992!^
2993 ad_light(i,k)=0.0_r8
2994 END DO
2995 END IF
2996!^ tl_PAR=tl_PARsur(i)
2997!^
2998 ad_parsur(i)=ad_parsur(i)+ad_par
2999 ad_par=0.0_r8
3000 END DO
3001
3002 END DO iter_loop1
3003!
3004! Calculate adjoint surface Photosynthetically Available Radiation
3005! (PAR). The net shortwave radiation is scaled back to Watts/m2
3006! and multiplied by the fraction that is photosynthetically
3007! available, PARfrac.
3008!
3009 DO i=istr,iend
3010#ifdef CONST_PAR
3011!
3012! Specify constant surface irradiance a la Powell and Spitz.
3013!
3014!^ tl_PARsur(i)=0.0_r8
3015!^
3016!! ad_PARsur(i)=0.0_r8
3017#else
3018!^ tl_PARsur(i)=(tl_PARfrac(ng)*srflx(i,j)+ &
3019!^ & PARfrac(ng)*tl_srflx(i,j))*rho0*Cp
3020!^
3021 adfac=rho0*cp*ad_parsur(i)
3022 ad_srflx(i,j)=ad_srflx(i,j)+parfrac(ng)*adfac
3023 ad_parfrac(ng)=ad_parfrac(ng)+srflx(i,j)*adfac
3024!! ad_PARsur(i)=0.0_r8
3025#endif
3026 END DO
3027!
3028! Restrict biological tracer to be positive definite. If a negative
3029! concentration is detected, nitrogen is drawn from the most abundant
3030! pool to supplement the negative pools to a lower limit of MinVal
3031! which is set to 1E-6 above.
3032!
3033 DO k=1,n(ng)
3034 DO i=istr,iend
3035!
3036! Adjoint load biological tracers into local arrays.
3037!
3038 DO itrc=1,nbt
3039 ibio=idbio(itrc)
3040!^ tl_Bio(i,k,ibio)=tl_BioTrc(ibio,nstp)
3041!^
3042 ad_biotrc(ibio,nstp)=ad_biotrc(ibio,nstp)+ &
3043 & ad_bio(i,k,ibio)
3044 ad_bio(i,k,ibio)=0.0_r8
3045!^ tl_Bio_old(i,k,ibio)=tl_BioTrc(ibio,nstp)
3046!^
3047 ad_biotrc(ibio,nstp)=ad_biotrc(ibio,nstp)+ &
3048 & ad_bio_old(i,k,ibio)
3049 ad_bio_old(i,k,ibio)=0.0_r8
3050 END DO
3051!
3052! Adjoint positive definite concentrations.
3053!
3054 cff2=0.0_r8
3055 DO itime=1,2
3056 cff1=0.0_r8
3057 itrcmax=idbio(1)
3058 DO itrc=1,nbt
3059 ibio=idbio(itrc)
3060!
3061! The basic state (nstp and nnew indices) that is read from the
3062! forward file is in units of tracer. Since BioTrc(ibio,:) is in
3063! tracer units, we simply use t instead of t*Hz_inv.
3064!
3065 biotrc(ibio,itime)=t(i,j,k,itime,ibio)
3066 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
3067 IF (biotrc(ibio,itime).gt.biotrc(itrcmax,itime)) THEN
3068 itrcmax=ibio
3069 END IF
3070 biotrc1(ibio,itime)=biotrc(ibio,itime)
3071 biotrc(ibio,itime)=max(minval,biotrc(ibio,itime))
3072 END DO
3073 IF (biotrc(itrcmax,itime).gt.cff1) THEN
3074!^ tl_BioTrc(iTrcMax,itime)=tl_BioTrc(iTrcMax,itime)- &
3075!^ & tl_cff1
3076!^
3077 ad_cff1=-ad_biotrc(itrcmax,itime)
3078 END IF
3079
3080 cff1=0.0_r8
3081 DO itrc=1,nbt
3082 ibio=idbio(itrc)
3083!
3084! The basic state (nstp and nnew indices) that is read from the
3085! forward file is in units of tracer. Since BioTrc(ibio,:) is in
3086! tracer units, we simply use t instead of t*Hz_inv.
3087!
3088 biotrc(ibio,itime)=t(i,j,k,itime,ibio)
3089 cff1=cff1+max(0.0_r8,minval-biotrc(ibio,itime))
3090!^ tl_BioTrc(ibio,itime)=(0.5_r8- &
3091!^ & SIGN(0.5_r8, &
3092!^ & MinVal- &
3093!^ & BioTrc1(ibio,itime)))* &
3094!^ & tl_BioTrc(ibio,itime)
3095!^
3096 ad_biotrc(ibio,itime)=(0.5_r8- &
3097 & sign(0.5_r8, &
3098 & minval- &
3099 & biotrc1(ibio,itime)))* &
3100 & ad_biotrc(ibio,itime)
3101!^ tl_cff1=tl_cff1- &
3102!^ & (0.5_r8-SIGN(0.5_r8, &
3103!^ & BioTrc(ibio,itime)-MinVal))* &
3104!^ & tl_BioTrc(ibio,itime)
3105!^
3106 ad_biotrc(ibio,itime)=ad_biotrc(ibio,itime)- &
3107 & (0.5_r8-sign(0.5_r8, &
3108 & biotrc(ibio,itime)- &
3109 & minval))*ad_cff1
3110 END DO
3111 ad_cff1=0.0_r8
3112 END DO
3113!
3114! At input, all tracers (index nnew) from predictor step have
3115! transport units (m Tunits) since we do not have yet the new
3116! values for zeta and Hz. These are known after the 2D barotropic
3117! time-stepping.
3118!
3119! NOTE: In the following code, t(:,:,:,nnew,:) should be in units of
3120! tracer times depth. However the basic state (nstp and nnew
3121! indices) that is read from the forward file is in units of
3122! tracer. Since BioTrc(ibio,nnew) is in tracer units, we simply
3123! use t instead of t*Hz_inv.
3124!
3125 DO itrc=1,nbt
3126 ibio=idbio(itrc)
3127!^ tl_BioTrc(ibio,nnew)=tl_t(i,j,k,nnew,ibio)* &
3128!^ & Hz_inv(i,k)+ &
3129!^ & t(i,j,k,nnew,ibio)*Hz(i,j,k)* &
3130!^ & tl_Hz_inv(i,k)
3131!^
3132 ad_hz_inv(i,k)=ad_hz_inv(i,k)+ &
3133 & t(i,j,k,nnew,ibio)*hz(i,j,k)* &
3134 & ad_biotrc(ibio,nnew)
3135 ad_t(i,j,k,nnew,ibio)=ad_t(i,j,k,nnew,ibio)+ &
3136 & hz_inv(i,k)*ad_biotrc(ibio,nnew)
3137 ad_biotrc(ibio,nnew)=0.0_r8
3138!^ tl_BioTrc(ibio,nstp)=tl_t(i,j,k,nstp,ibio)
3139!^
3140 ad_t(i,j,k,nstp,ibio)=ad_t(i,j,k,nstp,ibio)+ &
3141 & ad_biotrc(ibio,nstp)
3142 ad_biotrc(ibio,nstp)=0.0_r8
3143 END DO
3144 END DO
3145 END DO
3146!
3147! Adjoint inverse thickness to avoid repeated divisions.
3148!
3149 DO k=2,n(ng)-1
3150 DO i=istr,iend
3151!^ tl_Hz_inv3(i,k)=-Hz_inv3(i,k)*Hz_inv3(i,k)* &
3152!^ & (tl_Hz(i,j,k-1)+tl_Hz(i,j,k)+ &
3153!^ & tl_Hz(i,j,k+1))
3154!^
3155 adfac=hz_inv3(i,k)*hz_inv3(i,k)*ad_hz_inv3(i,k)
3156 ad_hz(i,j,k-1)=ad_hz(i,j,k-1)-adfac
3157 ad_hz(i,j,k )=ad_hz(i,j,k )-adfac
3158 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)-adfac
3159 ad_hz_inv3(i,k)=0.0_r8
3160 END DO
3161 END DO
3162 DO k=1,n(ng)-1
3163 DO i=istr,iend
3164!^ tl_Hz_inv2(i,k)=-Hz_inv2(i,k)*Hz_inv2(i,k)* &
3165!^ & (tl_Hz(i,j,k)+tl_Hz(i,j,k+1))
3166!^
3167 adfac=hz_inv2(i,k)*hz_inv2(i,k)*ad_hz_inv2(i,k)
3168 ad_hz(i,j,k )=ad_hz(i,j,k )-adfac
3169 ad_hz(i,j,k+1)=ad_hz(i,j,k+1)-adfac
3170 ad_hz_inv2(i,k)=0.0_r8
3171 END DO
3172 END DO
3173 DO k=1,n(ng)
3174 DO i=istr,iend
3175!^ tl_Hz_inv(i,k)=-Hz_inv(i,k)*Hz_inv(i,k)*tl_Hz(i,j,k)
3176!^
3177 ad_hz(i,j,k)=ad_hz(i,j,k)- &
3178 & hz_inv(i,k)*hz_inv(i,k)*ad_hz_inv(i,k)
3179 ad_hz_inv(i,k)=0.0_r8
3180 END DO
3181 END DO
3182
3183 END DO j_loop
3184!
3185! Set adjoint vertical sinking velocity vector in the same order as the
3186! identification vector, IDSINK.
3187!
3188!^ tl_Wbio(2)=tl_wDet(ng) ! Small detritus
3189!^
3190 ad_wdet(ng)=ad_wdet(ng)+ad_wbio(2)
3191 ad_wbio(2)=0.0_r8
3192!^ tl_Wbio(1)=tl_wPhy(ng) ! Phytoplankton
3193!^
3194 ad_wphy(ng)=ad_wphy(ng)+ad_wbio(1)
3195 ad_wbio(1)=0.0_r8
3196
3197 RETURN

References mod_biology::ad_parfrac, mod_biology::ad_wdet, mod_biology::ad_wphy, 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::vm_no3, mod_biology::wdet, mod_biology::wphy, mod_biology::zooeed, mod_biology::zooeen, mod_biology::zoogr, mod_biology::zoomrd, and mod_biology::zoomrn.