! source file: /nfs/tape_cache/smomw258/latin_hypercube_nobio/template/updates/tracer.F subroutine tracer (joff, js, je, is, ie) !#if defined 1 !======================================================================= ! compute tracers at "tau+1" for rows js through je in the MW. ! input: ! joff = offset relating "j" in the MW to latitude "jrow" ! js = starting row in the MW ! je = ending row in the MW ! is = starting longitude index in the MW ! ie = ending longitude index in the MW !======================================================================= implicit none character(120) :: fname, new_file_name integer istrt, iend, i, k, j, ip, kr, jq, n, jp, jrow, iou, js integer je, limit, joff, is, ie, kmx, m, kb, idiag, index integer it(10), iu(10), ib(10), ic(10), nfnpzd, mfnpzd, mxfnpzd integer id_time, id_xt, id_yt, id_zt, fe_jlo, fe_m, fe_k, fe_n parameter (fe_n = 14) logical inqvardef, exists real rctheta, declin, gl, impo, expo, npp, time real remi, excr, graz, morp, morpt, morz, temp, swr, dayfrac real graz_Det, graz_Z, avej, avej_D, gmax, no3P, po4P, po4_D real phin_loc, dz, prca, dprca, nud, bct, tap, fo2, so2, ai real hi, hs real npp_D, graz_D, morp_D, no3flag, deni, nfix, felimit real t_i, t_j, dz_t2r, dz_tr, dz_wtr, dx_t2r, dx_tr, dy_t2r real dy_tr, adv_tx, adv_ty, adv_tz, adv_txiso, adv_tyiso real adv_tziso, diff_tx, diff_ty, diff_tz, zmax, cont, drho real drhom1, wt, ahbi_cstr, ahbi_csu_dyur, gamma, rrstd, fy, fyz real fe_dy, fe_conc, fe_x(fe_n), fe_y(fe_n), bctz, felimit_D real Paulmier_a, Paulmier_z, Paulmier_R0 real expofe, impofe, feorgads, remife, thetamax, deffe, fecol real thetachl, chl, chl_D, feprime, fesed, bfe, sgb real sil_in, feorgads_ca real remi_B,expo_B, impo_B, graz_Det_B real npp_C, graz_C, morp_C, morpt_C,felimit_C real temp_in, d_in,alk_in, sal_in, expocaco3,old_diss real dissl,calpro,impocaco3,calatt real expo_out, impo_out, caco3in_loc, dissk1 real atmpres1, pHlo1, pHhi1, pH1, p_in real co2star1, dco2star1, pCO21, dpco21, CO31 real omegaca, omegaar, c_in,depth1 include "cembm.h" include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "accel.h" include "coord.h" include "cregin.h" include "csbc.h" include "emode.h" include "grdvar.h" include "hmixc.h" include "levind.h" include "mw.h" include "scalar.h" include "switch.h" include "timeavgs.h" include "tmngr.h" include "vmixc.h" include "diaga.h" include "ice.h" include "atm.h" include "npzd.h" parameter (istrt=2, iend=imt-1) real twodt(km) real snpzd(ntnpzd), tnpzd(ntnpzd), gbio real src(imt,km,jsmw:jemw,nsrc) include "isopyc.h" include "fdift.h" real zoop1_r, phyt_s, zoop1_s, agg_upt, agg_rel, zoop_rel real phyt_r, zoop_r, agg_con, expomp, impomp, zoop_upt real poo_con, expomp_a, impomp_a, expomp_p, impomp_p real remiz, expoz, impoz !----------------------------------------------------------------------- ! bail out if starting row exceeds ending row !----------------------------------------------------------------------- if (js .gt. je) return !----------------------------------------------------------------------- ! limit the longitude indices based on those from the argument list ! Note: this is currently bypassed. istrt and iend are set as ! parameters to optimize performance !----------------------------------------------------------------------- ! istrt = max(2,is) ! iend = min(imt-1,ie) !----------------------------------------------------------------------- ! build coefficients to minimize advection and diffusion computation !----------------------------------------------------------------------- limit = min(je+1+joff,jmt) - joff do j=js,limit jrow = j + joff do i=istrt-1,iend cstdxtr(i,j) = cstr(jrow)*dxtr(i) cstdxt2r(i,j) = cstr(jrow)*dxtr(i)*p5 cstdxur(i,j) = cstr(jrow)*dxur(i) ah_cstdxur(i,j) = diff_cet*cstr(jrow)*dxur(i) enddo enddo !----------------------------------------------------------------------- ! calculation of biological interactions !----------------------------------------------------------------------- declin = sin((mod(relyr,1.) - 0.22)*2.*pi)*0.4 ! declination do k=1,km twodt(k) = c2dtts*dtxcel(k) nbio(k) = twodt(k)/dtnpzd dtbio(k) = twodt(k)/nbio(k) rdtts(k) = 1./twodt(k) rnbio(k) = 1./nbio(k) enddo tap = 2.*par ! alpha is added in npzd_src do j=js,je jrow = j + joff do i=is,ie if (kmt(i,jrow) .gt. 0) then ai = aice(i,jrow,2) hi = hice(i,jrow,2) hs = hsno(i,jrow,2) ! calculate day fraction and incoming solar ! angle of incidence = lat - declin, refraction index = 1.33 rctheta = max(-1.5, min(1.5, tlat(i,jrow)/radian - declin)) rctheta = kw/sqrt(1. - (1. - cos(rctheta)**2.)/1.33**2.) dayfrac = min( 1., -tan(tlat(i,jrow)/radian)*tan(declin)) dayfrac = max(1e-12, acos(max(-1., dayfrac))/pi) swr = dnswr(i,jrow)*1e-3*(1. + ai*(exp(-ki*(hi + hs)) - 1.)) expo = 0.0 impo = 0.0 expo_B = 0.0 ! detritus from coccs and zoop impo_B = 0.0 ! detritus from coccs and zoop remi_B = 0.0 ! detritus shifting ballasted and free pools caco3in_loc = 0.0 old_diss = 0.0 calpro = 0.0 calatt = 0.0 dissl = 0.0 impocaco3 = 0.0 expocaco3 = 0.0 expo_out = 0.0 impo_out = 0.0 dissk1 = 0.0 phin_loc = 0.0 ! integrated phytoplankton prca = 0.0 ! integrated production of calcite impoz = 0.0 expoz = 0.0 impomp_a = 0.0 expomp_a = 0.0 impomp_p = 0.0 expomp_p = 0.0 phyt_r = 0.0 zoop_r = 0.0 zoop1_r = 0.0 phyt_s = 0.0 zoop1_s = 0.0 agg_upt = 0.0 zoop_upt = 0.0 agg_rel = 0.0 zoop_rel = 0.0 !convert a portion of detritus to marine snow mmolN=>aggs ! 12gC/molC x 6.6molC/mmolN x 1e6 ugC/gC x 1 agg/8.8ugC agg_con = 12.011*redctn*1e6/8.8*pagg ! particles/cm^3 <=> mmol N/m^3 (equivalent to nmol N/cm^3) !236000*1e6/51.2e12/588g food *16 mol*1e3=> mmol N poo_con = 73.75/588.0*ping!523416.0 !convert plastic to poo ! this value is produced from 355.4e8 g MP=485e10 particles from Eriksen et al 2014. or Van Sebille 236000 tons MP = 51.2e12 particles ! It is assumed that 1 g MP is going to replace 1 G of FOOD in the zooplankton's diet, and so ! MP particles/cm^3 are converted to an equivalent mmol N/m3 (redfield ratio) kmx = min(kmt(i,jrow), kpzd) do k=1,kmx !----------------------------------------------------------------------- ! Initialize tracers. !----------------------------------------------------------------------- src(i,k,j,:)=0.0 tnpzd(ibion) = t(i,k,j,ipo4,taum1) tnpzd(ibiop) = t(i,k,j,iphyt,taum1) tnpzd(ibioz) = t(i,k,j,izoop,taum1) tnpzd(ibiod) = t(i,k,j,idetr,taum1) tnpzd(ibiomp) = t(i,k,j,imp,taum1) tnpzd(ibiompa) = t(i,k,j,impa,taum1) tnpzd(ibiompp) = t(i,k,j,impp,taum1) tnpzd(ibiodz) = t(i,k,j,idetrz,taum1) tnpzd(ibiono3) = t(i,k,j,ino3,taum1) tnpzd(ibiodiaz) = t(i,k,j,idiaz,taum1) tnpzd(ibioc) = t(i,k,j,icocc,taum1) tnpzd(ibiocaco3) = t(i,k,j,icaco3,taum1) ! mmol/m3 tnpzd(ibiod_B) = t(i,k,j,idetr_B,taum1) swr = swr*exp(-(kc*phin_loc+kc_c*caco3in_loc)) ! phin_loc has been removed from the following code to fix a bug phin_loc = (max(tnpzd(ibiop),trcmin) & + max(tnpzd(ibiodiaz),trcmin) & + max(tnpzd(ibioc),trcmin) & )*dzt(k) caco3in_loc = max(tnpzd(ibiocaco3),trcmin)*dzt(k) impocaco3 = expocaco3*dztr(k) impo_B = expo_B*dztr(k) !ballasted detritus gl = tap*swr*exp(ztt(k)*rctheta) impo = expo*dztr(k) impomp_a = expomp_a*dztr(k) impomp_p = expomp_p*dztr(k) impoz = expoz*dztr(k) bct = bbio**(cbio*t(i,k,j,itemp,taum1)) if (t(i,k,j,itemp,taum1).gt.20) then bctz = (0.5*(tanh(t(i,k,j,io2,taum1)*1000. - 8.)+1)) & *bbio**(cbio*20) else bctz = (0.5*(tanh(t(i,k,j,io2,taum1)*1000. - 8.)+1)) & *bct endif if (k.le.kmfe) then ! create x (time) and y (data) arrays for fe interpolation ! first zero them out just in case fe_y(:) = 0 fe_x(:) = 0 ! write in values for days 0 and 365 for interp. bounds fe_y(1) = fe_dissolved(i,j,k,1) fe_x(1) = 0 fe_y(14) = fe_dissolved(i,j,k,12) fe_x(14) = 365 ! now create the rest of the array based on the BLING ! data which is from day 16 of each month do m=2,13 fe_y(m) = fe_dissolved(i,j,k,m-1) if (m.eq.2) then fe_x(2) = 16 else if (m.eq.3) then fe_x(3) = 47 else if (m.eq.4) then fe_x(4) = 75 else if (m.eq.5) then fe_x(5) = 106 else if (m.eq.6) then fe_x(6) = 136 else if (m.eq.7) then fe_x(7) = 167 else if (m.eq.8) then fe_x(8) = 197 else if (m.eq.9) then fe_x(9) = 228 else if (m.eq.10) then fe_x(10) = 259 else if (m.eq.11) then fe_x(11) = 289 else if (m.eq.12) then fe_x(12) = 320 else if (m.eq.13) then fe_x(13) = 350 endif enddo fe_jlo = 2 fe_m = 4 ! find fe data day index call hunt (fe_x,fe_n,dayoyr,fe_jlo) ! initialize the fe data array at the right day fe_k = min(max(fe_jlo-(fe_m-1)/2,1),fe_n+1-fe_m) ! interpolate the fe data, note this does not use the whole array call polint (fe_x(fe_k),fe_y(fe_k) &, fe_m,dayoyr,fe_conc,fe_dy) ! calculate the fe limitation term felimit = fe_conc/(kfe + fe_conc) felimit_D = fe_conc/(kfe_D + fe_conc) felimit_C = fe_conc/(kfe_C + fe_conc) else felimit = 1 felimit_D = 1 felimit_C = 1 endif ! Decrease remineralisation rate in oxygen minimum zone and when there is no ! nitrate. if (t(i,k,j,ino3,taum1).le.0.) then nud = 0 else nud = nud0*(0.65+0.35*tanh(t(i,k,j,io2,taum1) & *1000.-6.)) endif !----------------------------------------------------------------------- ! set co2 concentration or emissions by tracking average co2 !----------------------------------------------------------------------- call co2ccndata !----------------------------------------------------------------------- ! calculate delCO3 !----------------------------------------------------------------------- sal_in = 1000.0*t(i,k,j,isalt,taum1) + 35.0 sal_in = min(45.,max(sal_in,0.)) temp_in = t(i,k,j,itemp,taum1) temp_in = min(35.,max(temp_in,-2.)) d_in = max(t(i,k,j,idic,taum1),trcmin) alk_in = max(t(i,k,j,ialk,taum1),trcmin) pHlo1 = 6. pHhi1 = 10. sil_in = 7.6875e-03 !mol/m^3 p_in = 0.5125e-3 !phos mol/m^3 atmpres1 = 1.0 !atm depth1 = dzt(k)/100 !depth in meters c_in = co2ccn call co2calc_SWS (temp_in, sal_in,d_in,alk_in,c_in, p_in &, sil_in, atmpres1, depth1, pHlo1, pHhi1,pH1 &, co2star1, dco2star1, pCO21, dpco21, CO31 &, omegaca, omegaar) romca(i,k,j) = omegaca ! assume KK that Ca ion is constant (S&G 2006 pg 366) rco3(i,k,j) = CO31 !mol/m3 rco3_sat(i,k,j) = CO31/omegaca rdel_sat(i,k,j) = rco3(i,k,j)- rco3_sat(i,k,j) !mol/m3 dissk0 = (1-(CO31-CO31/omegaca))/(kcal+(CO31-CO31/omegaca)) ! dissk0 and dissk1 dimensionless if(dissk0.ge.0) then dissk1 = min(c1,dissk0) else dissk1 = 0.0 endif ! if(omegaca-1.lt.0) then ! dissk1 = dissk0*(1-omegaca) !Andreas S. 11 d^-1 from Gehlen 2006 ! else ! dissk1 = 0. ! endif if(k.eq.1) then ! calculate a plastic inventory from atmospheric CO2 concentration ! plastic emissions forecast to increase linearly with increasing CO2 emission ! Borelle et al 2017 !*(co2ccn/338.3) ! plastic concentrations in world ocean forecast to triple by 2100 Koelmans et al 2015 ! huge uncertainties here- Isobe et al 2019 forecast 2x by 2030 for NPac ! tied to CO2 concentrations may be conservative (< 3x in 2100 wrt 2010) ! now calculate the number of organic aggregates that fill up with plastic ! check what proportion the number of affected particles is in relation to the total detritus ! convert plastic affected aggregates to detritus units ! conversion of 30e4 aggs per 0.285 g POC taken from Shanks and Trent 1980 ! is probably conservative. ! find the ratio of total detritus holding plastic in that grid cell phyt_r = min(1. & ,max(trcmin,t(i,k,j,imp,taum1)*agg_con) & /max(trcmin,t(i,k,j,idetr,taum1))) !proportion of full detritus ! now do the same for poo, which are bigger ! let 1 mm^3 fecal pellet = 3.4 ug N as unpublished estimate from Hofmann et al., 1981 ! assume an average fecal pellet volume of 1.13 um^3 from Cole et al., 2016 ! this converts to 1 fecal pellet containing 2.74e-10 mol N ! No averaged data available- 3 photos of poo in Cole et al 2016 show at least 20 plastic ! particles per poo pellet zoop1_r = min(1.,max(trcmin,t(i,k,j,imp,taum1)*poo_con) & /max(trcmin,t(i,k,j,idetrz,taum1))) zoop_r = max(trcmin,t(i,k,j,imp,taum1)*11.58*0.094/14) & /max(trcmin,t(i,k,j,izoop,taum1)) ! now scale the effect on detrial sinking rates phyt_s = wd0 + wd0*0.72*phyt_r !Moehlenkamp et al 2018 ! phyt_s = wd0 - wd0*0.65*phyt_r !Long et al 2015 ! phyt_s = wd0 + wd0*0.28*phyt_r !Porter et al 2018 zoop1_s = wdz0 - wdz0*0.56*zoop1_r !Cole et al 2016 endif !end k condition !scale parameters based on plastic concentrations ! gbio = gbio0 - gbio0*0.4*zoop_r ! if(gbio.lt.0) gbio = 0. ! linear increase wd0-200m with depth ! wd(k) = (phyt_s+4.0e-2*zt(k))/86400.0/dzt(k) ! [s-1] ! wdz(k) = (zoop1_s+4.0e-2*zt(k))/86400.0/dzt(k) ! [s-1] !KK causing mass loss in microplastic!!!VVVVV ! wd(k) = (wd0+4.0e-2*zt(k))/86400.0/dzt(k) ! [s-1] ! wdz(k) = (wdz0+4.0e-2*zt(k))/86400.0/dzt(k) ! [s-1] gbio = gbio0 !----------------------------------------------------------------------- ! call the npzd model !----------------------------------------------------------------------- call npzd_src (tnpzd, nbio(k), dtbio(k), gl, bct, impo &, dzt(k), dayfrac, wd(k), gbio &, agg_con, poo_con, expomp_a, impomp_a &, expomp_p, impomp_p,agg_upt,zoop_upt &, agg_rel, zoop_rel &, wdz(k), remiz, expoz, impoz &, rkwz(k), nud &, snpzd, expo, graz, morp, morz, graz_Det &, graz_Z &, npp, morpt, remi, excr &, impo_B, expo_B, remi_B, graz_Det_B &, npp_D, graz_D, morp_D, nfix &, npp_C, morpt_C, graz_C, morp_C &, felimit_C &, impocaco3,wc(k),expocaco3,dissl &, calpro &, calatt,dissk1 &, avej, avej_D, gmax, no3P, po4P, po4_D &, felimit, felimit_D &, bctz & ) ! These are source/sink terms snpzd(ibion) = snpzd(ibion)*rdtts(k) snpzd(ibiop) = snpzd(ibiop)*rdtts(k) snpzd(ibioz) = snpzd(ibioz)*rdtts(k) snpzd(ibiod) = snpzd(ibiod)*rdtts(k) snpzd(ibiomp) = snpzd(ibiomp)*rdtts(k) snpzd(ibiompa) = snpzd(ibiompa)*rdtts(k) snpzd(ibiompp) = snpzd(ibiompp)*rdtts(k) snpzd(ibiodz) = snpzd(ibiodz)*rdtts(k) snpzd(ibiono3) = snpzd(ibiono3)*rdtts(k) snpzd(ibiodiaz) = snpzd(ibiodiaz)*rdtts(k) snpzd(ibioc) = snpzd(ibioc)*rdtts(k) expocaco3 = expocaco3*rnbio(k) snpzd(ibiocaco3) = snpzd(ibiocaco3)*rdtts(k) snpzd(ibiod_B) = snpzd(ibiod_B)*rdtts(k) expo_B = expo_B*rnbio(k) !ballast detritus expo = expo*rnbio(k) expomp_a = expomp_a*rnbio(k) expomp_p = expomp_p*rnbio(k) rexpomp_a(i,k,j) = expomp_a rexpomp_p(i,k,j) = expomp_p ragg_upt(i,k,j) = agg_upt*rnbio(k) rzoop_upt(i,k,j) = zoop_upt*rnbio(k) ragg_rel(i,k,j) = agg_rel*rnbio(k) rzoop_rel(i,k,j) = zoop_rel*rnbio(k) expoz = expoz*rnbio(k) rgraz(i,k,j) = graz*rnbio(k) rgraz_Det(i,k,j) = graz_Det*rnbio(k) rgraz_Z(i,k,j) = graz_Z*rnbio(k) rmorp(i,k,j) = morp*rnbio(k) rmorz(i,k,j) = morz*rnbio(k) rnpp(i,k,j) = npp*rnbio(k) rmorpt(i,k,j) = morpt*rnbio(k) rremi(i,k,j) = remi*rnbio(k) rexcr(i,k,j) = excr*rnbio(k) rgraz_Det_B(i,k,j) = graz_Det_B*rnbio(k) rremi_B(i,k,j) = remi_B*rdtts(k) rnpp_D(i,k,j) = npp_D*rnbio(k) rgraz_D(i,k,j) = graz_D*rnbio(k) rmorp_D(i,k,j) = morp_D*rnbio(k) rnfix(i,k,j) = nfix*rnbio(k) rcalpro(i,k,j) = calpro*rnbio(k) rcalatt(i,k,j) = calatt*rnbio(k) rdissl(i,k,j) = dissl*rdtts(k) rnpp_C(i,k,j) = npp_C*rnbio(k) rgraz_C(i,k,j) = graz_C*rnbio(k) rmorp_C(i,k,j) = morp_C*rnbio(k) rmorpt_C(i,k,j) = morpt_C*rnbio(k) rremiz(i,k,j) = remiz*rnbio(k) ravej(i,k,j) = avej*rnbio(k) ravej_D(i,k,j) = avej_D*rnbio(k) rgmax(i,k,j) = gmax*rnbio(k) rno3P(i,k,j) = no3P*rnbio(k) rpo4P(i,k,j) = po4P*rnbio(k) rpo4_D(i,k,j) = po4_D*rnbio(k) !----------------------------------------------------------------------- ! calculate detritus at the bottom and remineralize !----------------------------------------------------------------------- sgb = sg_bathy(i,j,k) if (sgb .gt. 0) then rremi(i,k,j) = rremi(i,k,j) + (expo+expo_B)*sgb rremiz(i,k,j) = rremiz(i,k,j) + expoz*sgb ! ragg_rel(i,k,j) = ragg_rel(i,k,j) + expomp_a*pbc*sgb ! rzoop_rel(i,k,j) = rzoop_rel(i,k,j) + expomp_p*pbc*sgb snpzd(ibion) = snpzd(ibion) + redptn*(expo+expo_B & + expoz & )*sgb snpzd(ibiono3) = snpzd(ibiono3) + (expo+expo_B & + expoz & )*sgb src(i,k,j,isdic) = src(i,k,j,isdic)+expocaco3*1.e-3*sgb src(i,k,j,isalk) = src(i,k,j,isalk) & + 2.*expocaco3*1.e-3*sgb !---------------------------- ! sediment transfer function for iron !---------------------------- expo = expo - sgb * expo expoz = expoz - sgb * expoz expo_B = expo_B - sgb * expo_B !---------------------------------------------------------------------- ! calculate calcite at the bottom and dissolve !--------------------------------------------------------------------- expocaco3 = expocaco3 - sgb*expocaco3 endif !end of bathy condition rexpo(i,k,j) = expo rexpoz(i,k,j) = expoz rexpo_B(i,k,j) = expo_B rexpocaco3(i,k,j) = expocaco3 if (k .eq. kmt(i,jrow)) then rremi(i,k,j) = rremi(i,k,j) + expo + expo_B rremiz(i,k,j) = rremiz(i,k,j) + expoz ragg_rel(i,k,j) = ragg_rel(i,k,j) + expomp_a*pbc rzoop_rel(i,k,j) = rzoop_rel(i,k,j) + expomp_p*pbc snpzd(ibion) = snpzd(ibion) + redptn*(expo+expo_B) !nitrogen snpzd(ibion) = snpzd(ibion) + redptn*expoz snpzd(ibiono3) = snpzd(ibiono3) + (expo+expo_B) snpzd(ibiono3) = snpzd(ibiono3) + expoz snpzd(ibiomp) = snpzd(ibiomp) & + (expomp_a & +expomp_p & )*pbc !---------------------------------------------------------------------- ! calculate calcite at the bottom and dissolve !--------------------------------------------------------------------- endif !end of bottom box loop !----------------------------------------------------------------------- ! set source/sink terms !----------------------------------------------------------------------- src(i,k,j,ispo4) = snpzd(ibion) src(i,k,j,isphyt) = snpzd(ibiop) src(i,k,j,iszoop) = snpzd(ibioz) src(i,k,j,isdetr) = snpzd(ibiod) src(i,k,j,ismp) = snpzd(ibiomp) src(i,k,j,ismpa) = snpzd(ibiompa) src(i,k,j,ismpp) = snpzd(ibiompp) src(i,k,j,isdetrz) = snpzd(ibiodz) src(i,k,j,isno3) = snpzd(ibiono3) src(i,k,j,isdiaz) = snpzd(ibiodiaz) src(i,k,j,iscocc) = snpzd(ibioc) src(i,k,j,iscaco3) = snpzd(ibiocaco3) src(i,k,j,isdetr_B) = snpzd(ibiod_B) !----------------------------------------------------------------------- ! production, export, and dissolution of opal !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! production of calcite !----------------------------------------------------------------------- ! Still calculated but now only used if kk_caco3tr is not implemented! dprca = (capr*morp_C+capr*morz & +(capr*graz_C+capr*graz_Z)*(1.-gamma1)) & *redctn*rnbio(k) prca = prca + dprca*dzt(k) !mol C/m3/s ! These are sources and sinks of DIC (i.e. remin - pp) ! all are based on po4 uptake and remineralization ! dprca is a correction term ! calculated below ! calculated below ! print*,'KK3 tr', src(i,k,j,:) !----------------------------------------------------------------------- ! accumulate time averages !----------------------------------------------------------------------- if (timavgperts .and. .not. euler2) then ta_rnpp(i,k,jrow) = ta_rnpp(i,k,jrow) + rnpp(i,k,j) ta_rgraz(i,k,jrow) = ta_rgraz(i,k,jrow) + rgraz(i,k,j) ta_rgraz_Z(i,k,jrow) = ta_rgraz_Z(i,k,jrow) & + rgraz_Z(i,k,j) ta_rgraz_Det(i,k,jrow) = ta_rgraz_Det(i,k,jrow) & + rgraz_Det(i,k,j) ta_rmorp(i,k,jrow) = ta_rmorp(i,k,jrow) + rmorp(i,k,j) ta_rmorpt(i,k,jrow)= ta_rmorpt(i,k,jrow) + rmorpt(i,k,j) ta_rmorz(i,k,jrow) = ta_rmorz(i,k,jrow) + rmorz(i,k,j) ta_rexcr(i,k,jrow) = ta_rexcr(i,k,jrow) + rexcr(i,k,j) ta_rremiz(i,k,jrow) = ta_rremiz(i,k,jrow) +rremiz(i,k,j) ta_rexpoz(i,k,jrow) = ta_rexpoz(i,k,jrow) + rexpoz(i,k,j) !detrz ta_rnpp_C(i,k,jrow) = ta_rnpp_C(i,k,jrow) & + rnpp_C(i,k,j) ta_rgraz_C(i,k,jrow) = ta_rgraz_C(i,k,jrow) & + rgraz_C(i,k,j) ta_rmorp_C(i,k,jrow) = ta_rmorp_C(i,k,jrow) & + rmorp_C(i,k,j) ta_rmorpt_C(i,k,jrow)= ta_rmorpt_C(i,k,jrow) & + rmorpt_C(i,k,j) ta_romca(i,k,jrow) = ta_romca(i,k,jrow) + romca(i,k,j) ta_rco3(i,k,jrow) = ta_rco3(i,k,jrow) + rco3(i,k,j) ta_rco3_sat(i,k,jrow) = ta_rco3_sat(i,k,jrow) & + rco3_sat(i,k,j) ta_rdel_sat(i,k,jrow) = ta_rdel_sat(i,k,jrow) & + rdel_sat(i,k,j) ta_rcalatt(i,k,jrow) = ta_rcalatt(i,k,jrow) & + rcalatt(i,k,j) ta_rprocal(i,k,jrow) = ta_rprocal(i,k,jrow) & + rcalpro(i,k,j) ta_rgraz_Det_B(i,k,jrow) = ta_rgraz_Det_B(i,k,jrow) & + rgraz_Det_B(i,k,j) ta_rnpp_D(i,k,jrow) = ta_rnpp_D(i,k,jrow) & + rnpp_D(i,k,j) ta_rgraz_D(i,k,jrow) = ta_rgraz_D(i,k,jrow) & + rgraz_D(i,k,j) ta_rmorp_D(i,k,jrow) = ta_rmorp_D(i,k,jrow) & + rmorp_D(i,k,j) ta_rnfix(i,k,jrow) = ta_rnfix(i,k,jrow) + rnfix(i,k,j) ta_ravej(i,k,jrow) = ta_ravej(i,k,jrow) & + ravej(i,k,j) ta_ravej_D(i,k,jrow) = ta_ravej_D(i,k,jrow) & + ravej_D(i,k,j) ta_rgmax(i,k,jrow) = ta_rgmax(i,k,jrow) & + rgmax(i,k,j) ta_rno3P(i,k,jrow) = ta_rno3P(i,k,jrow) & + rno3P(i,k,j) ta_rpo4P(i,k,jrow) = ta_rpo4P(i,k,jrow) & + rpo4P(i,k,j) ta_rpo4_D(i,k,jrow) = ta_rpo4_D(i,k,jrow) & + rpo4_D(i,k,j) endif ! calculate total export to get total import for next layer expo = expo*dzt(k) expomp_a = expomp_a*dzt(k) expomp_p = expomp_p*dzt(k) ta_rexpomp_a(i,k,jrow) = ta_rexpomp_a(i,k,jrow) & + rexpomp_a(i,k,j) ta_rexpomp_p(i,k,jrow) = ta_rexpomp_p(i,k,jrow) & + rexpomp_p(i,k,j) ta_ragg_upt(i,k,jrow) = ta_ragg_upt(i,k,jrow) & + ragg_upt(i,k,j) ta_rzoop_upt(i,k,jrow) = ta_rzoop_upt(i,k,jrow) & + rzoop_upt(i,k,j) ta_ragg_rel(i,k,jrow) = ta_ragg_rel(i,k,jrow) & + ragg_rel(i,k,j) ta_rzoop_rel(i,k,jrow) = ta_rzoop_rel(i,k,jrow) & + rzoop_rel(i,k,j) expoz = expoz*dzt(k) expo_B = expo_B*dzt(k) !ballast detritus expocaco3 = expocaco3*dzt(k) enddo kmx = kmt(i,jrow) do k=1,kmx ! limit oxygen consumption below concentrations of ! 5umol/kg as recommended in OCMIP ! KK try optimising this fo2 = 0.5*tanh(t(i,k,j,io2,taum1)*1000. - o2t) ! sink of oxygen ! O2 is needed to generate the equivalent of NO3 from N2 during N2 fixation ! 0.5 H2O + 0.5 N2+1.25O2 -> HNO3 ! note that so2 is -dO2/dt so2 = src(i,k,j,ispo4)*redotp & + rnfix(i,k,j)*1.25e-3 src(i,k,j,iso2) = -so2*(0.5 + fo2) ! add denitrification as source term for NO3 no3flag = 0.5+sign(0.5,t(i,k,j,ino3,taum1)-trcmin) ! 800 = 0.8*1000 = (elec/mol O2)/(elec/mol NO3)*(mmol/mol) !KK switch to namelist parameter for sensitivity testing deni = max(0., ro2n*no3flag*so2*(0.5 - fo2)) src(i,k,j,isno3) = src(i,k,j,isno3) - deni ! Correct the ALK stoichiometry to account for N2 fixation ! New stoichiometric model parameters formulated as in Paulmier et al. 2009 BG Paulmier_a = 1.e3*redctn Paulmier_z = 4*1.e3*redotp - 4.*Paulmier_a - 8.*redntp Paulmier_R0 = Paulmier_a + 0.25*Paulmier_z ! src(i,k,j,isalk) = src(i,k,j,isalk) ! & + no3flag*src(i,k,j,ispo4)*(0.5-fo2) ! & *(4./5.*Paulmier_R0 + (3./5. +1.)*redntp) * 1.e-3 ! Now account for N2 fixation (ALK production is tied to PO4 change and ! thus in the case of N2 fixation was not correct without this fix). src(i,k,j,isalk) = src(i,k,j,isalk) & - rnfix(i,k,j)*1.e-3 + deni*1.e-3 rdeni(i,k,jrow) = deni enddo !----------------------------------------------------------------------- ! remineralize implicit calcite and opal !----------------------------------------------------------------------- kmx = kmt(i,jrow) do k=1,kmx-1 src(i,k,j,isdic) = src(i,k,j,isdic) & + src(i,k,j,ispo4)*redctp !mmol/m3/s & + rdissl(i,k,j)*1.e-3 & - rcalpro(i,k,j)*1.e-3 & - rcalatt(i,k,j)*1.e-3 old_diss = prca*rcak(k) src(i,k,j,isalk) = src(i,k,j,isalk) & - src(i,k,j,ispo4)*redntp*1.e-3 & + 2.*rdissl(i,k,j)*1.e-3 & - 2.*rcalpro(i,k,j)*1.e-3 & - 2.*rcalatt(i,k,j)*1.e-3 enddo src(i,kmx,j,isdic) = src(i,kmx,j,isdic) & + src(i,kmx,j,ispo4)*redctp & + rdissl(i,kmx,j)*1.e-3 & - rcalpro(i,kmx,j)*1.e-3 & - rcalatt(i,kmx,j)*1.e-3 & + rexpocaco3(i,kmx,j)*1.e-3 old_diss = prca*rcab(kmx) src(i,kmx,j,isalk) = src(i,kmx,j,isalk) & - src(i,kmx,j,ispo4)*redntp*1.e-3 & + 2.*rdissl(i,kmx,j)*1.e-3 & - 2.*rcalpro(i,kmx,j)*1.e-3 & - 2.*rcalatt(i,kmx,j)*1.e-3 & + 2.*rexpocaco3(i,kmx,j)*1.e-3 ! Reverse k loop for rising free plastic particles expomp = 0. impomp = 0. kmx = min(kmt(i,jrow), kpzd) do k = kmx,1,-1 impomp = expomp*dztr(k) !conc ! assume 30% rises expomp = wmp(k)*max(0.,t(i,k,j,imp,taum1)*prise) !conc/s if (k.gt.1) then src(i,k,j,ismp) = src(i,k,j,ismp) + impomp - expomp else src(i,1,j,ismp) = src(i,1,j,ismp) + impomp endif expomp = expomp*dzt(k) !flux enddo !----------------------------------------------------------------------- ! accumulate time averages for full depth variables !----------------------------------------------------------------------- if (timavgperts .and. .not. euler2) then kmx = kmt(i,jrow) expo = prca do k=1,kmx expo = expo*dztr(k) old_diss = old_diss*dztr(k) ta_rold_diss(i,k,jrow) = ta_rold_diss(i,k,jrow) & + old_diss old_diss = old_diss*dzt(k) ta_rremi_B(i,k,jrow) = ta_rremi_B(i,k,jrow) & + rremi_B(i,k,j) ta_rexpo_B(i,k,jrow) = ta_rexpo_B(i,k,jrow) & + rexpo_B(i,k,j) !ballast detritus ta_rremi(i,k,jrow) = ta_rremi(i,k,jrow) + rremi(i,k,j) ta_rexpo(i,k,jrow) = ta_rexpo(i,k,jrow) + rexpo(i,k,j) expo = expo - prca*rcak(k) ta_rexpocal(i,k,jrow) = ta_rexpocal(i,k,jrow) + expo expo = expo*dzt(k) ta_rdissl(i,k,jrow) = ta_rdissl(i,k,jrow) & + rdissl(i,k,j) ta_rexpocaco3(i,k,jrow) = & ta_rexpocaco3(i,k,jrow) + rexpocaco3(i,k,j) ta_rdeni(i,k,jrow) = ta_rdeni(i,k,jrow) + rdeni(i,k,j) enddo endif endif enddo enddo !----------------------------------------------------------------------- ! set source for c14 !----------------------------------------------------------------------- do j=js,je jrow = j + joff do i=is,ie if (kmt(i,jrow) .gt. 0) then do k=1,kmt(i,jrow) src(i,k,j,isc14) = src(i,k,j,isdic)*rstd & - 3.836e-12*t(i,k,j,ic14,taum1) enddo endif enddo enddo !----------------------------------------------------------------------- ! solve for one tracer at a time ! n = 1 => temperature ! n = 2 => salinity ! n > 2 => other tracers (if applicable) !----------------------------------------------------------------------- do n=1,nt !----------------------------------------------------------------------- ! calculate advective tracer flux !----------------------------------------------------------------------- call adv_flux (joff, js, je, is, ie, n) !----------------------------------------------------------------------- ! calculate diffusive flux across eastern and northern faces ! of "T" cells due to various parameterizations for diffusion. !----------------------------------------------------------------------- ! diffusive flux on eastern face of "T" cells do j=js,je do k=1,km do i=istrt-1,iend diff_fe(i,k,j) = & ah_cstdxur(i,j)* & (t(i+1,k,j,n,taum1) - t(i,k,j,n,taum1)) enddo enddo enddo ! diffusive flux on northern face of "T" cells ! (background for isopycnal mixing) do j=js-1,je jrow = j + joff do k=1,km do i=istrt,iend diff_fn(i,k,j) = & diff_cnt* & csu_dyur(jrow)*(t(i,k,j+1,n,taum1) - t(i,k,j,n,taum1)) enddo enddo enddo !----------------------------------------------------------------------- ! calculate diffusive flux across bottom face of "T" cells !----------------------------------------------------------------------- do j=js,je do k=1,km-1 do i=istrt,iend diff_fb(i,k,j) = diff_cbt(i,k,j)*dzwr(k)* & (t(i,k,j,n,taum1) - t(i,k+1,j,n,taum1)) enddo enddo enddo !----------------------------------------------------------------------- ! compute isopycnal diffusive flux through east, north, ! and bottom faces of T cells. !----------------------------------------------------------------------- call isoflux (joff, js, je, is, ie, n) !----------------------------------------------------------------------- ! set surface and bottom vert b.c. on "T" cells for diffusion ! and advection. for isopycnal diffusion, set adiabatic boundary ! conditions. ! note: the b.c. at adv_fb(i,k=bottom,j) is set by the above code. ! However, it is not set when k=km so it is set below. ! adv_fb(i,km,j) is always zero (to within roundoff). !----------------------------------------------------------------------- do j=js,je jrow = j + joff do i=istrt,iend kb = kmt(i,jrow) diff_fb(i,0,j) = stf(i,j,n) diff_fb(i,kb,j) = btf(i,j,n) adv_fb(i,0,j) = adv_vbt(i,0,j)*(t(i,1,j,n,tau) + & t(i,1,j,n,tau)) adv_fb(i,km,j) = adv_vbt(i,km,j)*t(i,km,j,n,tau) enddo enddo !----------------------------------------------------------------------- ! set source term for "T" cells !----------------------------------------------------------------------- source(:,:,:) = c0 if (itrc(n) .ne. 0) then do j=js,je do k=1,km do i=istrt,iend source(i,k,j) = src(i,k,j,itrc(n)) enddo enddo enddo endif !----------------------------------------------------------------------- ! solve for "tau+1" tracer using statement functions to represent ! each component of the calculation !----------------------------------------------------------------------- ! 1st: solve using all components which are treated explicitly do j=js,je jrow = j + joff do k=1,km twodt(k) = c2dtts*dtxcel(k) do i=istrt,iend t(i,k,j,n,taup1) = t(i,k,j,n,taum1) + twodt(k)*( & DIFF_Tx(i,k,j) + DIFF_Ty(i,k,j,jrow,n) + DIFF_Tz(i,k,j) & - ADV_Tx(i,k,j) - ADV_Ty(i,k,j,jrow,n) - ADV_Tz(i,k,j) & + source(i,k,j) & )*tmask(i,k,j) enddo enddo enddo ! 2nd: add in portion of vertical diffusion handled implicitly call ivdift (joff, js, je, istrt, iend, n, twodt) do j=js,je call setbcx (t(1,1,j,n,taup1), imt, km) enddo !----------------------------------------------------------------------- ! construct diagnostics associated with tracer "n" !----------------------------------------------------------------------- call diagt1 (joff, js, je, istrt, iend, n, twodt) !----------------------------------------------------------------------- ! end of tracer component "n" loop !----------------------------------------------------------------------- enddo !----------------------------------------------------------------------- ! explicit convection: adjust column if gravitationally unstable !----------------------------------------------------------------------- call convct2 (t(1,1,1,1,taup1), joff, js, je, is, ie, kmt) do j=js,je do n=1,nt call setbcx (t(1,1,j,n,taup1), imt, km) enddo enddo if (timavgperts .and. eots) then if (joff .eq. 0) nta_conv = nta_conv + 1 do j=js,je jrow = j + joff do i=istrt,iend ta_totalk(i,jrow) = ta_totalk(i,jrow) + totalk(i,j) ta_vdepth(i,jrow) = ta_vdepth(i,jrow) + vdepth(i,j) ta_pe(i,jrow) = ta_pe(i,jrow) + pe(i,j) enddo enddo endif !----------------------------------------------------------------------- ! construct diagnostics after convection !----------------------------------------------------------------------- idiag = 10 call diagt2 (joff, js, je, istrt, iend, idiag) !----------------------------------------------------------------------- ! filter tracers at high latitudes !----------------------------------------------------------------------- if (istrt .eq. 2 .and. iend .eq. imt-1) then call filt (joff, js, je) else write (stdout,'(a)') & 'Error: filtering requires is=2 and ie=imt-1 in tracer' stop '=>tracer' endif do n=1,nt do j=js,je call setbcx (t(1,1,j,n,taup1), imt, km) enddo enddo !----------------------------------------------------------------------- ! construct diagnostics after filtering (for total dT/dt) !----------------------------------------------------------------------- idiag = 1 call diagt2 (joff, js, je, istrt, iend, idiag) !----------------------------------------------------------------------- ! if needed, construct the Atmos S.B.C.(surface boundary conditions) ! averaged over this segment ! eg: SST and possibly SSS !----------------------------------------------------------------------- call asbct (joff, js, je, istrt, iend, isst, itemp) call asbct (joff, js, je, istrt, iend, isss, isalt) call asbct (joff, js, je, istrt, iend, issdic, idic) call asbct (joff, js, je, istrt, iend, issc14, ic14) call asbct (joff, js, je, istrt, iend, issmp, imp) call asbct (joff, js, je, istrt, iend, issmpa, impa) call asbct (joff, js, je, istrt, iend, issmpp, impp) call asbct (joff, js, je, istrt, iend, issalk, ialk) call asbct (joff, js, je, istrt, iend, isso2, io2) call asbct (joff, js, je, istrt, iend, isspo4, ipo4) call asbct (joff, js, je, istrt, iend, issno3, ino3) !----------------------------------------------------------------------- ! calculate diagnostic delta carbon 14 !----------------------------------------------------------------------- if (tsiperts .or. timavgperts) then rrstd = 1000./rstd do j=js,je jrow = j + joff do k=1,km do i=istrt,iend dc14(i,k,j) = (rrstd*t(i,k,j,ic14,taup1) & /(t(i,k,j,idic,taup1) + epsln) - 1000.) & *tmask(i,k,j) enddo enddo enddo endif if (tsiperts .and. eots) then if (js+joff .eq. 2) dc14bar = 0. do j=js,je jrow = j + joff fy = cst(jrow)*dyt(jrow) do k=1,km fyz = fy*dzt(k) do i=istrt,iend dc14bar = dc14bar + dc14(i,k,j)*dxt(i)*fyz*tmask(i,k,j) enddo enddo enddo endif if (timavgperts .and. .not. euler2) then do j=js,je jrow = j + joff do k=1,km do i=istrt,iend ta_dc14(i,k,jrow) = ta_dc14(i,k,jrow) + dc14(i,k,j) enddo enddo enddo endif return end subroutine diagt1 (joff, js, je, is, ie, n, twodt) !----------------------------------------------------------------------- ! construct diagnostics associated with tracer component "n" ! input: ! joff = offset relating "j" in the MW to latitude "jrow" ! js = starting row in the MW ! je = ending row in the MW ! is = starting longitude index in the MW ! ie = ending longitude index in the MW ! n = (1,2) = (u,v) velocity component ! twodt = (2*dtts,dtts) on (leapfrog,mixing) time steps !----------------------------------------------------------------------- implicit none integer i, k, j, ip, kr, jq, n, jp, jrow, js, je, joff, is, ie integer mask, m real t_i, t_j, dz_t2r, dz_tr, dz_wtr, dx_t2r, dx_tr, dy_t2r real dy_tr, adv_tx, adv_ty, adv_tz, adv_txiso, adv_tyiso real adv_tziso, diff_tx, diff_ty, diff_tz, dtdx, dtdy, dtdz real r2dt, cosdyt, fx, darea, boxar, rtwodt, sumdx, delx real sumdxr, dxdy, dxdydz include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "accel.h" include "coord.h" include "cregin.h" include "csbc.h" include "ctavg.h" include "npzd.h" include "diag.h" include "diaga.h" include "emode.h" include "grdvar.h" include "hmixc.h" include "levind.h" include "mw.h" include "scalar.h" include "switch.h" include "vmixc.h" real temp1(imt,km), temp2(imt,km), temp3(imt,km) real twodt(km) include "isopyc.h" include "fdift.h" !----------------------------------------------------------------------- ! diagnostic: integrate |d(tracer)/dt| and tracer variance on "tau" ! globally !----------------------------------------------------------------------- if (tsiperts .and. eots) then do j=js,je jrow = j + joff r2dt = c1/c2dtts cosdyt = cst(jrow)*dyt(jrow) do k=1,km fx = r2dt/dtxcel(k) do i=is,ie darea = dzt(k)*dxt(i)*cosdyt*tmask(i,k,j) temp3(i,k) = t(i,k,j,n,tau)*darea temp1(i,k) = t(i,k,j,n,tau)**2*darea temp2(i,k) = abs(t(i,k,j,n,taup1)-t(i,k,j,n,taum1))* & darea*fx enddo do i=is,ie tbar(k,n,jrow) = tbar(k,n,jrow) + temp3(i,k) travar(k,n,jrow) = travar(k,n,jrow) + temp1(i,k) dtabs(k,n,jrow) = dtabs(k,n,jrow) + temp2(i,k) enddo enddo enddo endif !----------------------------------------------------------------------- ! diagnostic: accumulate tracers for averages under horizontal ! regions (use units of meters, rather than cm) !----------------------------------------------------------------------- if (tavgts .and. eots) then do j=js,je jrow = j + joff do i=is,ie mask = mskhr(i,jrow) if (mask .ne. 0) then boxar = cst(jrow)*dxt(i)*dyt(jrow)*tmask(i,1,j)*0.0001 sumbf(mask,n) = sumbf(mask,n) + stf(i,j,n)*boxar do k=1,km sumbk(mask,k,n) = sumbk(mask,k,n) + t(i,k,j,n,tau) & *boxar*dzt(k)*tmask(i,k,j)*0.01 enddo endif enddo enddo endif !----------------------------------------------------------------------- ! diagnostic: compute the northward transport components of ! each tracer !----------------------------------------------------------------------- if (gyrets .and. eots) call gyre (joff, js, je, is, ie, n) !----------------------------------------------------------------------- ! diagnostic: integrate r.h.s. terms in the tracer equations ! over specified regional volumes. !----------------------------------------------------------------------- if (trmbts .and. eots) call ttb1 (joff, js, je, is, ie, n) return end subroutine diagt2 (joff, js, je, is, ie, idiag) !----------------------------------------------------------------------- ! construct d(tracer)/dt diagnostics ! input: ! joff = offset relating "j" in the MW to latitude "jrow" ! js = starting row in the MW ! je = ending row in the MW ! is = starting longitude index in the MW ! ie = ending longitude index in the MW ! idiag = 1 => total tracer change ! idiag = 10 => change of tracer due to filtering(also convection) !----------------------------------------------------------------------- implicit none integer idiag, j, js, je, k, i, joff, iocv, jrow, is, ie real rdt, reltim, period include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "coord.h" include "diaga.h" include "iounit.h" include "mw.h" include "scalar.h" include "switch.h" include "tmngr.h" include "timeavgs.h" !----------------------------------------------------------------------- ! diagnostic: integrate d/dt(tracer) over specified regional volumes ! after convection and filtering !----------------------------------------------------------------------- if (trmbts .and. eots) call ttb2 (joff, js, je, is, ie, idiag) return end subroutine asbct (joff, js, je, is, ie, isbc, itr) !----------------------------------------------------------------------- ! construct the Atmos S.B.C. (surface boundary conditions) ! input: ! joff = offset relating "j" in the MW to latitude "jrow" ! js = starting row in the MW ! je = ending row in the MW ! is = starting longitude index in the MW ! ie = ending longitude index in the MW ! isbc = index for sbc ! itr = index for tracer !----------------------------------------------------------------------- implicit none integer isbc, itr, j, js, je, jrow, joff, i, is, ie real rts include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "csbc.h" include "levind.h" include "mw.h" include "scalar.h" include "switch.h" ! initialize the Atmos S.B.C. at the start of each ocean segment ! (do not alter values in land) if (isbc .le. 0 .or. itr .le. 0) return if (eots .and. osegs) then do j=js,je jrow = j + joff do i=is,ie if (kmt(i,jrow) .ne. 0) sbc(i,jrow,isbc) = c0 enddo enddo endif ! accumulate surface tracers for the Atmos S.B.C. every time step if (eots) then do j=js,je jrow = j + joff do i=is,ie sbc(i,jrow,isbc) = sbc(i,jrow,isbc)+t(i,1,j,itr,taup1) enddo enddo endif ! average the surface tracers for the Atmos S.B.C. at the end of ! each ocean segment. (do not alter values in land) if (eots .and. osege) then rts = c1/ntspos do j=js,je jrow = j + joff do i=is,ie if (kmt(i,jrow) .ne. 0) & sbc(i,jrow,isbc) = rts*sbc(i,jrow,isbc) enddo enddo endif return end subroutine ivdift (joff, js, je, is, ie, n, twodt) !----------------------------------------------------------------------- ! solve vertical diffusion of tracers implicitly ! input: ! joff = offset relating "j" in the MW to latitude "jrow" ! js = starting row in the MW ! je = ending row in the MW ! is = starting longitude index in the MW ! ie = ending longitude index in the MW ! n = tracer component ! twodt = (2*dtts, dtts) on (leapfrog, mixing) time steps !----------------------------------------------------------------------- implicit none integer j, js, je, k, i, is, ie, n, joff real rc2dt include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "levind.h" include "mw.h" include "switch.h" include "vmixc.h" real twodt(km) ! store terms to compute implicit vertical mixing on ! diagnostic time steps if (trmbts .and. eots) then do j=js,je do k=1,km do i=is,ie zzi(i,k,j) = t(i,k,j,n,taup1) enddo enddo enddo endif call invtri (t(1,1,1,n,taup1), stf(1,1,n), btf(1,1,n) &, diff_cbt(1,1,jsmw), twodt, kmt, tmask(1,1,1), is, ie &, joff, js, je) ! compute residual implicit vertical mixing if (trmbts .and. eots) then do j=js,je do k=1,km rc2dt = c1/twodt(k) do i=is,ie zzi(i,k,j) = rc2dt*(t(i,k,j,n,taup1) - zzi(i,k,j)) enddo enddo enddo endif return end subroutine swflux0 (joff, js, je, is, ie, source) return end ! subroutine polint (xa,ya,n,x,y,dy) ! implicit none ! integer n,i,m,ns, nmax parameter (nmax = 10) ! largest anticipated value of n real dy,x,y,xa(n),ya(n) real den,dif,dift,ho,hp,w,c(nmax),d(nmax) ! ! Given arrays xa and ya, each of length n, and a given value x, this routine ! returns a value y, and an error estimate dy. If P(x) is the polynomial of ! degree N-1 such that P(xai) = yai, i=1,....,n then the returned value y=P(x) ! ! ns=1 dif=abs(x-xa(1)) ! do i=1,n dift = abs(x-xa(i)) IF (dift.lt.dif) THEN ns = i dif = dift END IF ! c(i) = ya(i) d(i) = ya(i) ! enddo ! y = ya (ns) ! this is the initial approximation to y ns = ns-1 ! do m=1,n-1 do i=1,n-m ho = xa(i) - x hp = xa (i+m) -x w = c(i+1) - d(i) den = ho - hp IF (den.eq.0.) PAUSE 'failure in polint' den = w/den d(i) = hp*den c(i) = ho*den enddo IF (2*ns.lt.n-m) THEN dy = c(ns+1) ELSE dy = d(ns) ns = ns - 1 END IF y = y + dy enddo return end ! subroutine hunt (xa,n,x,jlo) ! integer jlo,n,inc,jhi,jm real x, xa(n) logical ascnd ! ! Given an array xa(1:n), and given a value x, returns a value jlo ! such that x is between xa(jlo) and xa(jlo +1). xa(1:n) must be ! monotonic, either increasing or decreasing. jlo=0 or jlo=n is ! returned to indicate that x is out of range. jlo on input is taken ! as the initial guess for jlo on output ! ascnd = xa(n).ge.xa(1) ! True if ascending order of table, false otherwise IF (jlo.le.0.or.jlo.gt.n) THEN ! Input guess not useful. Go to bisection jlo = 0 jhi = n+1 goto 3 END IF inc = 1 ! Set the hunting increment IF (x.ge.xa(jlo).eqv.ascnd) THEN ! Hunting up: 1 jhi = jlo + inc IF (jhi.gt.n) THEN ! Done hunting, since off end of table jhi = n + 1 ELSE IF (x.ge.xa(jhi).eqv.ascnd) THEN ! Not done hunting jlo = jhi inc = inc + inc ! so double the increment goto 1 ! and try again END IF ! Done hunting, value bracketed. ELSE ! Hunt down: jhi = jlo 2 jlo = jhi-inc IF (jlo.lt.1) THEN !Done hunting, since off end of table jlo = 0 ELSE IF (x.lt.xa(jlo).eqv.ascnd) THEN ! Not done hunting jhi = jlo inc = inc + inc ! so double the increment goto 2 ! and try again END IF ! Done hunting, value bracketed END IF ! Hunt is done, so begin the final bisection phase: ! 3 IF (jhi-jlo.eq.1) THEN IF (x.eq.xa(n)) jlo = n-1 IF (x.eq.xa(1)) jlo = 1 RETURN END IF jm = (jhi + jlo)/2 IF (x.ge.xa(jm).eqv.ascnd) THEN jlo = jm ELSE jhi = jm END IF ! GOTO 3 ! end