array.sizes.h000644 025374 000024 00000001201 10413036311 013750 0ustar00archeruser000000 000000 integer nzmax, nsolidmax, nsolutemax, n_opals, $ nstoicmax, nzlevels, ndt, . nDbs,DBTop,DbBot,DbPlsS,DbMinS,DbPlsT,DbMinT parameter(nzmax=18) #ifdef Bells_Whistles parameter(nsolidmax=15+2*nCaCO3s+10) parameter(nsolutemax=18) #else parameter(nsolidmax=9+nCaCO3s) parameter(nsolutemax=11) #endif parameter(n_opals=1) parameter(nstoicmax=21) parameter(nzlevels=5) parameter(ndt=4) parameter(nDbs=6) parameter(DbTop=1) parameter(DbBot=2) parameter(DbPlsS=3) parameter(DbMinS=4) parameter(DbPlsT=5) parameter(DbMinT=6) nS,DbPlsT,DbMinT parameter(nzmax=18) #ifdef Bells_Whistles parameter(nsolidmax=15+2*nCaCO3s+10) parameter(nsolutemax=18) #else parameter(nsolidmax=9+nCaCO3s) parameter(nsolutemax=11) #endif parameter(n_opals=1) parameter(nstoicmax=21) parameter(nzlevels=5) parameter(ndt=4) parameter(nDbs=6) parameter(DbTop=1) bottomwater.h000644 025374 000024 00000000346 10413036311 014056 0ustar00archeruser000000 000000 integer nBottomWaters parameter (nBottomWaters=10) #define BWO2 1 #define BWNO3 2 #define BWSi 3 #define BWAlk 4 #define BWTCO2 5 #define BWH2S 6 #define BWNH4 7 #define BWDepth 8 #define BWTemp 9 #define BWSal 10 3s+10) parameter(nsolutemax=18) #else parameter(nsolidmax=9+nCaCO3s) parameter(nsolutemax=11) #endif parameter(n_opals=1) parameter(nstoicmax=21) parameter(nzlevels=5) parameter(ndt=4) parameter(nDbs=6) parameter(DbTop=1) calc_co2chem.F000644 025374 000024 00000013273 10413036311 013752 0ustar00archeruser000000 000000 #include subroutine calc_k_csat(temp,sal,z,csat,k1,k2,kb) implicit none #include double precision temp,sal,z,csat(nCaCO3s) double precision k1, k2,kb double precision tk,cp,prat double precision kprime,delv,rr,dk,pres,kpres integer ic tk = temp + 273.15 #ifdef Dickson K1 = 10.0** + (-(6320.18/TK - 126.3405 + 19.568*LOG(TK) + + (19.894 - 840.39/TK $ - 3.0189*LOG(TK))*SQRT(Sal) + 0.00679*Sal)) K2 = 10.0** + (-(5143.69/TK - 90.1833 + 14.613*LOG(TK) + + (17.176 - 690.59/TK $ - 2.6719*LOG(TK))*SQRT(Sal) + 0.02169*Sal)) #else c Mehrbach k1 = 13.7201 - 0.031334 * tk * - 3235.76 / tk * - 1.3E-5 * sal * tk * + 0.1032 * sal**(0.5) k1 = 10**(k1) k2 = - 5371.9645 * - 1.671221 * tk * + 128375.28 / tk * + 2194.3055 * LOG10( tk ) * - 0.22913 * sal * - 18.3802 * LOG10( sal ) * + 8.0944E-4 * sal * tk * + 5617.11 * LOG10( sal ) / tk * - 2.136 * sal / tk k2 = 10**(k2) #endif cp = (z/10.) / 83.143 / tk prat = ( 24.2 - 0.085 * temp ) * * cp prat = exp(prat) k1 = k1 * prat prat = (16.4 - 0.04*temp) * * cp prat = exp(prat) k2 = k2 * prat C lymans kb kb = 2291.9/(temp+273) . + 0.01756 * (temp+273) . - 3.385 . - .32051 * (sal/1.80655)**(1./3.) kb = 10**(-kb) prat = (27.5 - 0.095*temp) * * cp prat = exp(prat) kb = kb * prat c millero KPRIME = 4.75E-7 C mol2 / kg2 DELV = -44 C cm3 / mol RR = 83.14 C cm3 bar / K mol PRES = Z/10 C bar DK = -.0133 C cm3 / bar mol KPRES = LOG(10.0) KPRES = LOG(KPRIME) * - DELV / (RR * (TEMP + 273) ) * (PRES) * + 0.5 * DK / (RR * (TEMP + 273) ) * (PRES)**2 KPRES = EXP(KPRES) do ic=1,nCaCO3s CSAT(ic) = CSAT(ic) * KPRES / 0.01 ! it's read relative values first enddo RETURN END SUBROUTINE calc_co2chem(temp,sal,z,k1,k2,kb,alk,tco2, $ co2, hco3,co3) c expecting concentrations in volumetric units implicit none #include double precision temp,sal,z double precision k1, k2,kb double precision alk,tco2, $ co2,hco3,co3 double precision rho integer ic if (tco2 .LE. 0) then return endif call calc_rho(temp,sal,rho,1) CALL NEWT(ALK/rho,TCO2/rho,SAL,TEMP, $ 0.d0, 0.d0, 1 K1,K2,KB, $ CO2,HCO3,CO3) RETURN END SUBROUTINE NEWT(ALK,TCO2,SAL,TEMP, * TSi,TP, * K1,K2,KB, * CO2,HCO3,CO3) implicit none double precision K1,K2,KB,KSi,KP2,KP3,KW double precision alk, tco2, sal, temp, tsi, tp double precision co2, hco3, co3, tbor, tkt, tk, a,x, $ wm, ah1 double precision fh, c1, c2, c4, aht, bm, sim, pm integer icnt TBOR = 4.106E-4*SAL/35. TKT = TEMP+273 TK = TKT/100. KSi = 1.E-10 KP2 = EXP( -9.039 - 1450./tkt) KP3 = EXP( 4.466 - 7276./tkt) KW = EXP( 148.9802 - 13847.26/tkt * - 23.6521*LOG(tkt) - 0.019813*sal * + sal**0.5 * ( * - 79.2447 + 3298.72/tkt * + 12.0408*LOG(tkt) * ) * ) FH = 1.29 - 0.00204*tkt + 4.6*1.E-4*sal**2 * - 1.48*1.E-6*sal**2*tkt C1 = K1/2.0 C2 = 1.0 - 4.0*K2/K1 C4 = TBOR*KB AHT= 1.E-8 DO 100 ICNT=1,100 BM = TBOR * KB / (AHT + KB) SiM = TSi * 4 * 1E-10 / (AHT + 4 * 1.E-10) PM = TP * (1 / ( * 1 + KP2/AHT + KP2*KP3 / AHT**2 * ) * + 2 / ( * 1 + AHT/KP2 + KP3/AHT * ) * + 3 / ( * 1 + AHT/KP3 + AHT**2 / (KP3*KP2) * ) * ) WM = ( (KW*FH/AHT) - (AHT/FH) ) A = ALK - BM - SiM - PM - WM X = A/TCO2 AH1 = C1/X*(1.0-X+SQRT(1.0+C2*X*(-2.+X))) IF(0.5E-4.GE.ABS(1.-AHT/AH1)) GOTO 200 AHT=AH1 100 CONTINUE 200 CONTINUE CO3 = (A-TCO2)/(1.0-(AH1*AH1)/(K1*K2)) HCO3 = TCO2/(1.+AH1/K1+K2/AH1) CO2 = TCO2/(1.0+K1/AH1+K1*K2/(AH1*AH1)) RETURN END SUBROUTINE calc_rho(t,s,rho,n) double precision t(*), s(*), aa,bb,r_0,rho(*) double precision a(5), b(3), c, r(6) DATA a /0.824493, -.0040899, .000076438, -0.00000082467, * 0.0000000053875/ DATA b /-0.00572466, 0.00010227, -0.0000016546/ DATA c / .0004831 / DATA r / 999.84259, 0.06793952, -0.00909529, 0.0001001685, * -0.000001120083, 0.000000006536332 / DO i = 1, n aa = a(1) * + a(2) * t(i) * + a(3) * t(i)**2 * + a(4) * t(i)**3 * + a(5) * t(i)**4 bb = b(1) * + b(2) * t(i) * + b(3) * t(i)**2 r_0 = r(1) * + r(2) * t(i) * + r(3) * t(i)**2 * + r(4) * t(i)**3 * + r(5) * t(i)**4 * + r(6) * t(i)**5 rho(i) = r_0 * + s(i) * ( * aa * + bb * s(i)**(0.5) * + c * s(i) * ) rho(i) = rho(i) / 1000. c sig(i) = rho(i) - 1000 ENDDO RETURN END 2) * t(i) * + b(3) * t(i)**2 r_0 = r(1) * + r(2) * t(i) * + r(3) * t(i)**2 * + r(4) * t(i)**3 * + r(5) * t(i)**4 * + r(6) * t(i)**5 rho(i) = r_0 * + s(i) * ( * aa * + bco3ss.F000644 025374 000024 00000126351 10413036311 012504 0ustar00archeruser000000 000000 #include c#define StdOut c#define UseINeg c#define ScaleResiduals #define GoalError c#define RMSError SUBROUTINE co3ss_borate(runid,idebug, $ resp_c, . rc, $ difc, irrig_array, $ db_array,omega, $ z,delz,form,pore,kmax, . sl_ml,sl_gg, $ carb, $ ttrtc, diftc, $ ttral, difal, $ sl_react, sl_dreac) implicit none #include #include #include integer kmax, runid, idebug c external variables DOUBLE PRECISION difc(nzmax,2,3), $ rc(nrcmax), $ irrig_array(nzmax), $ db_array(nzmax,nDbs), $ omega(nzmax) DOUBLE PRECISION sl_ml(nzmax,nsolidmax),sl_gg(nzmax,nsolidmax) DOUBLE PRECISION carb(nzmax,3) DOUBLE PRECISION resp_c(nzmax,3), $ sl_react(nzmax,nCaCO3s), sl_dreac(nzmax,nCaCO3s) double precision form(kmax), pore(kmax), delz(kmax), $ z(kmax) double precision ttral, difal, ttrtc, diftc c internal stuff DOUBLE PRECISION cal_c(nzmax) c DOUBLE PRECISION dcpls(nzmax,3),dcmin(nzmax,3) DOUBLE PRECISION dco2(nzmax,3) DOUBLE PRECISION ba(nzmax),dalk(nzmax) DOUBLE PRECISION dbapls(nzmax),dbamin(nzmax) DOUBLE PRECISION dbcpls(nzmax),dbcmin(nzmax) double precision dhppls(nzmax),dhpmin(nzmax) double precision dohpls(nzmax),dohmin(nzmax) double precision ttrcal, ttrorg, rmstc,rmsal,rmsph integer k, l, i, j, kz, isolute,lmax c CALL calcdc(difc,form,pore,delz,kmax, c . dcpls,dcmin,nzmax) c if(idebug .EQ. -999) then c return c endif c do j=2,kmax c do l=1,3 c write(6,*) (difc(j,i,l),i=1,2) c enddo c enddo call calc_pw_diff(5.D-6, $ form,pore,delz,kmax, $ dbapls,dbamin) call calc_pw_diff(5.D-6, $ form,pore,delz,kmax, $ dbcpls,dbcmin) call calc_pw_diff(30.D-6, $ form,pore,delz,kmax, $ dohpls,dohmin) call calc_pw_diff(60.D-6, $ form,pore,delz,kmax, $ dhppls,dhpmin) DO k=2, kmax dalk(k) = 0. ba(k) = 0. enddo c do k=2,kmax c do i=1,3 c resp_c(k,i) = 0. c enddo c enddo do k=2,kmax do i=1,3 carb(k,i) = carb(1,i) !* 2. enddo enddo c carb(2,3) = ( 2 * carb(1,3) + csat ) / 3 c carb(3,3) = ( carb(1,3) + 2 * csat ) / 3 CALL co3(runid,idebug, $ resp_c,nzmax,rc, . difc,irrig_array,nzmax, . form,pore,kmax, . sl_ml(1,iCaCO3),carb,nzmax, $ cal_c, sl_react, sl_dreac, $ rmstc,rmsal,rmsph) CALL diag_co3(ttrtc,ttral,diftc,difal, * ttrcal,ttrorg, * resp_c,nzmax,cal_c,dalk, * carb,nzmax,ba, $ pore,delz, * difc(2,2,1),difc(2,2,2),difc(2,2,3),dbamin(2), $ irrig_array, * kmax) c return lmax = 1000 DO 10 l=1,lmax if (l .EQ. lmax-1) then write(6,*) "failed to converge in co3ss" endif c if(l.EQ.100) then c write(6,*) "debugging" c do kz=2,kmax c do i=1,3 c resp_c(kz,i) = 0. c enddo c enddo c endif do kz=2,kmax dalk(kz) = 0. enddo #ifdef BoronAlkalinity CALL boron(carb,nzmax, $ 4.106D-4, $ rc(JK1),rc(JKB), $ dbapls,dbamin,dbcmin,irrig_array, $ z,delz,form,pore,kmax,ba,dalk) #endif #ifdef ProtonTransport call proton_transport(carb,rc(JK1), $ sl_gg, $ dhppls,dhpmin, $ dohpls,dohmin, $ db_array, $ omega, $ z,delz,form,pore,kmax, $ dalk) #endif do i = 2, kmax do j = 1, 3 dco2(i,j) = resp_c(i,j) enddo dco2(i,2) = dco2(i,2) - dalk(i) dco2(i,3) = dco2(i,3) + dalk(i) enddo CALL co3(runid, idebug, $ dco2,nzmax, ! "altered" resp rates $ rc, . difc,irrig_array,nzmax, . form,pore,kmax, . sl_ml(1,iCaCO3),carb,nzmax, $ cal_c,sl_react,sl_dreac, $ rmstc,rmsal,rmsph) CALL diag_co3(ttrtc,ttral,diftc,difal, * ttrcal,ttrorg, * resp_c,nzmax,cal_c,dalk, * carb,nzmax,ba, $ pore,delz, * difc(2,2,1),difc(2,2,2),difc(2,2,3),dbamin(2), $ irrig_array, * kmax) #ifdef StdOut write(6,'(a6,i4,6g15.5)') "fluxes ", l, $ difal, ttral, $ 1-abs(difal/(ttral+1.e-20)), 1-abs(diftc/(ttrtc+1.e-20)) do i=1,kmax write(6,'(i4,6g15.5)') i, (carb(i,j)*1.e6,j=1,3), $ (resp_c(i,j)*1.e12,j=1,3) enddo #endif #ifdef RMSError if(rmstc .GT. 1.e-15) then goto 10 endif if(rmsal .GT. 1.e-15) then goto 10 endif #endif #ifdef GoalError if(rmstc .GT. 1.e-6) then #ifdef StdOut write(6,*) "goal error", rmstc #endif goto 10 endif #endif IF( $ ( abs(diftc) .GT. 1.d-12 ) $ .AND. $ ( abs(1 - abs(ttrtc / diftc)) .GT. 0.001 ) $ ) then #ifdef StdOut write(6,*) "TC flux error", abs(1 - abs(ttrtc / diftc)) #endif goto 10 elseif( $ ( abs(difal) .GT. 1.d-12 ) $ .AND. $ ( abs(ttral) .GT. 1.d-12 ) $ .AND. $ ( abs(1 - abs(ttral / difal)) .GT. 0.001 ) $ ) then #ifdef StdOut write(6,*) "AL flux error", abs(1 - abs(ttral / difal)) #endif goto 10 else goto 20 endif 10 CONTINUE c stop 20 CONTINUE ! exit the loop #ifdef StdOut CALL diag_co3(ttrtc,ttral,diftc,difal, * ttrcal,ttrorg, * resp_c,nzmax,cal_c,dalk, * carb,nzmax,ba, $ pore,delz, * difc(2,2,1),difc(2,2,2),difc(2,2,3),dbamin(2), $ irrig_array, * kmax) write(6,*) "CO3ss ttral, difal ", ttral*1.e6, difal*1.e6 #endif do kz = 1, kmax do isolute = 1, 3 resp_c(kz,isolute) = 0. enddo enddo RETURN END C routine co3, which calculates a single iteration C of the carbonate system chemistry. must be run C several times because of the non-linearity of C calcite dissolution kinetics. SUBROUTINE co3(runid, idebug, $ resp_c,n_r, . rc, . difc,irrig,n_d, . form,pore,kmax, . calml,carb,n_c, $ cal_c, sl_react, sl_dreac, $ rmstc,rmsal,rmsph) implicit none #include #include #include integer kmax, n_r, n_d, n_c, runid,idebug c external variables DOUBLE PRECISION resp_c(n_r,3) DOUBLE PRECISION difc(n_d,2,3),irrig(n_d) DOUBLE PRECISION form(kmax),pore(kmax) DOUBLE PRECISION calml(nzmax,nCaCO3s) DOUBLE PRECISION carb(n_c,3) double precision rc(nrcmax) double precision cal_c(kmax), $ sl_react(nzmax,nCaCO3s), sl_dreac(nzmax,nCaCO3s) c internal variables DOUBLE PRECISION r(nzmax,3),dr(3,3,3,nzmax) DOUBLE PRECISION a(nzmax*3,nzmax*3), b(nzmax*3,1) double precision pw_dreac(nzmax) double precision weight, trialw, rmstc, rmsal, rmsph integer i, j, k, l, m, o, p,ineg #define RedoBottom #ifdef RedoBottom DO 7 i=1,3 carb(kmax+1, i) = 0. C for the bottom boundary condition, no flux 7 CONTINUE #else DO 7 i=1,3 carb(kmax+1, i) = carb(kmax, i) C for the bottom boundary condition, no flux 7 CONTINUE #endif call co3_react_rates(carb, calml, $ rc,kmax,cal_c,pw_dreac, $ sl_react,sl_dreac) C the residual terms: array (depth; tc, alk, ph) DO 2 k = 2, kmax C total co2 equation r(k,1) = 0. DO 1 i=1,3 r(k,1) = r(k,1) & + ( difc(k,1,i) * (carb(k+1,i)-carb(k,i)) & - difc(k,2,i) * (carb(k,i)-carb(k-1,i)) o ) $ + irrig(k) $ * ( carb(1,i) - carb(k,i) ) C units of moles / l *porewater* sec 1 CONTINUE r(k,1) = r(k,1) + resp_c(k,1) / pore(k) . + resp_c(k,2) / pore(k) . + resp_c(k,3) / pore(k) $ + cal_c(k) / pore(k) C units of moles / l *porewater* sec C alkalinity equation r(k,2) = difc(k,1,3) * (carb(k+1,3)-carb(k,3)) & - difc(k,2,3) * (carb(k,3)-carb(k-1,3)) & + 0.5 * difc(k,1,2) * (carb(k+1,2)-carb(k,2)) & - 0.5 * difc(k,2,2) * (carb(k,2)-carb(k-1,2)) $ + irrig(k) * ( carb(1,3) - carb(k,3) $ + ( carb(1,2) - carb(k,2) )/2. $ ) r(k,2) = r(k,2) + resp_c(k,3) / pore(k) . + 0.5 * resp_c(k,2) / pore(k) $ + cal_c(k) / pore(k) c pH balance r(k,3) = carb(k,1) * carb(k,3) / (carb(k,2))**2 & / rc(JK2) * rc(JK1) - 1. c write(6,*) "pH", carb(k,1), carb(k,2), carb(k,3), c $ rc(JK1), rc(JK2), c $ carb(k,1) * carb(k,3) / (carb(k,2))**2 c & / rc(JK2) * rc(JK1) - 1. c & - rc(JK2) / rc(JK1) c write(6,'(a10,i5,3g12.2)') "resid ", k, r(k,1), r(k,2), r(k,3) 2 CONTINUE c write(6,*) "co3ss r(alk,kmax) = ", r(kmax,2) C the derivitive terms: array (function, variable, C 'k+'= 3 to 'k-' = 1, and depth level k) #ifdef RedoBottom DO 20 k=2,kmax #else DO 20 k=2,kmax-1 #endif dr(1,1,3,k) = difc(k,1,1) dr(1,1,2,k) = -difc(k,1,1) & -difc(k,2,1) $ -irrig(k) dr(1,1,1,k) = difc(k,2,1) dr(1,2,3,k) = difc(k,1,2) dr(1,2,2,k) = -difc(k,1,2) & -difc(k,2,2) $ -irrig(k) dr(1,2,1,k) = difc(k,2,2) dr(1,3,3,k) = difc(k,1,3) dr(1,3,2,k) = - difc(k,1,3) & - difc(k,2,3) $ - irrig(k) $ + pw_dreac(k) / pore(k) dr(1,3,1,k) = difc(k,2,3) dr(2,1,3,k) = 0. dr(2,1,2,k) = 0. dr(2,1,1,k) = 0. dr(2,2,3,k) = (0.5) * difc(k,1,2) dr(2,2,2,k) = -(0.5) * difc(k,1,2) & -(0.5) * difc(k,2,2) $ -(0.5) * irrig(k) dr(2,2,1,k) = (0.5) * difc(k,2,2) dr(2,3,3,k) = difc(k,1,3) dr(2,3,2,k) = -difc(k,1,3) & -difc(k,2,3) $ -irrig(k) $ + pw_dreac(k) / pore(k) dr(2,3,1,k) = difc(k,2,3) dr(3,1,3,k) = 0. dr(3,1,2,k) = carb(k,3) / carb(k,2)**2 & / rc(JK2) * rc(JK1) dr(3,1,1,k) = 0. dr(3,2,3,k) = 0. dr(3,2,2,k) = -2. * carb(k,1) * carb(k,3) ! was 0.5? & / carb(k,2)**3 & / rc(JK2) * rc(JK1) dr(3,2,1,k) = 0. dr(3,3,3,k) = 0. dr(3,3,2,k) = carb(k,1) / carb(k,2)**2 & / rc(JK2) * rc(JK1) dr(3,3,1,k) = 0. 20 CONTINUE C 300 CONTINUE #ifndef RedoBottom C bottom special conditions DO 9 l=1,3 C function DO 30 i=1,3 C variable DO 40 m=1,3 C above, below dr(l,i,m,kmax) = dr(l,i,m,kmax-1) 40 CONTINUE 30 CONTINUE 9 CONTINUE #endif #ifdef ScaleResiduals c scale residuals do k=2,kmax r(k,3) = r(k,3) * 1.e-3 c do i=1,3 c do j=1,3 c dr(3,i,j,k) = dr(3,i,j,k) * 1.e-10 c enddo c enddo enddo #endif C load the big array DO 12 k=1,3*kmax-1 DO 13 l=1,3*kmax-1 a(k,l)=0. 13 CONTINUE 12 CONTINUE DO 50 k=2,kmax C depth level DO 60 l=1,3 C function DO 70 m=1,3 C up, down DO 80 i=1,3 C variable C row number o = (k-2)*3 & + l C column number p = (m+k-4)*3 & + i IF(p .GT. 0) then a(o,p) = dr(l,i,m,k) #ifndef RedoBottom IF(k.EQ.kmax) then IF(m.EQ.2) & a(o,p) = a(o,p)+dr(l,i,m+1,k) ENDIF #endif endif 80 CONTINUE 70 CONTINUE 60 CONTINUE 50 CONTINUE C load the residual array DO 100 k=2,kmax DO 110 l=1,3 b( (k-2)*3+l, 1) = - r(k,l) 110 CONTINUE 100 CONTINUE c open(11,file='junk.out') c do i=1,3 c do l=1,3 c do m=1,3 c do k=2,kmax c write(11,'(4i4,g15.5)') i,l,m,k,dr(i,l,m,k) c enddo c enddo c enddo c enddo c close(11) c stop CALL gaussj(runid,idebug, $ a,(kmax-1)*3,nzmax*3,b,1,1) if(idebug .EQ. -999) then do k=2,kmax do i=1,3 carb(k,i) = carb(1,i) enddo enddo else #ifdef UseINeg ineg = 0 do k=2,kmax do i=1,3 if(carb(k,i)+b((k-2)*3+i,1) .LT. 0.) then ineg = 1 endif enddo enddo #endif #ifdef StdOut do k=2,kmax write(6,'(a6,i4,3g15.5)') "resid", k, $ (r(k,i)*1.e12,i=1,3) enddo do k=2,kmax write(6,'(a6,i4,3g15.5)') "goal", k, $ ((carb(k,i)+b((k-2)*3+i,1))*1.e6,i=1,3) enddo #endif #ifdef UseINeg1 if( ineg .EQ. 1) then do i=1,3 do k=2,kmax-1 carb(k,i) = 0.9 * carb(k,i) $ + 0.05 * carb(k-1,i) $ + 0.05 * carb(k+1,i) enddo enddo else #endif DO k=2,kmax DO i=1,3 if( rc(JCaCO3N) .GT. 1) then weight = 1.0 else weight = 0.4 ! 0.4 endif #ifdef UseINeg if( ineg .EQ. 1 ) then weight = 0.01 endif #endif if(b( (k-2)*3+i,1) .NE. 0) then trialw = - 0.25 * carb(k,i) / b( (k-2)*3+i, 1 ) if ((trialw.GT.0.).AND.(trialw .LT.weight)) $ weight = trialw endif carb(k,i) = carb(k,i) + weight * b( (k-2)*3+i, 1) c write(6,*) "weight ", k,i, carb(k,i), b( (k-2)*3+i, 1), c $ weight enddo enddo endif #ifdef UseINeg1 endif #endif #ifdef GoalError rmstc = 0. do k=2,kmax do i=1,3 rmsal = carb(k,i)+b((k-2)*3+i,1) - carb(k,i) if(ABS(rmsal) .GT. rmstc) then rmstc = ABS(rmsal) endif enddo enddo rmsal = 0. #endif #ifdef RMSError C the error terms, after the iteration call co3_react_rates(carb, calml, $ rc, $ kmax,cal_c,pw_dreac, $ sl_react, sl_dreac) c return DO 112 k=2,kmax-1 r(k,1) = 0. DO 111 i=1,3 r(k,1) = r(k,1) & + difc(k,1,i) * (carb(k+1,i)-carb(k,i)) & - difc(k,2,i) * (carb(k,i)-carb(k-1,i)) 111 CONTINUE r(k,1) = r(k,1) + resp_c(k,1) / pore(k) . + resp_c(k,2) / pore(k) * + resp_c(k,3) / pore(k) $ + cal_c(k) / pore(k) r(k,2) = difc(k,1,3) * (carb(k+1,3)-carb(k,3)) & - difc(k,2,3) * (carb(k,3)-carb(k-1,3)) & + (0.5) * difc(k,1,2) * (carb(k+1,2)-carb(k,2)) & - (0.5) * difc(k,2,2) * (carb(k,2)-carb(k-1,2)) r(k,2) = r(k,2) + 0.5 * resp_c(k,2) / pore(k) * + resp_c(k,3) / pore(k) $ + cal_c(k) / pore(k) r(k,3) = carb(k,1) * carb(k,3) / carb(k,2)**2 & - rc(JK2) / rc(JK1) 112 CONTINUE rmstc = 0. rmsal = 0. rmsph = 0. DO 130 k=2,kmax-1 rmstc = rmstc + r(k,1)**2 rmsal = rmsal + r(k,2)**2 rmsph = rmsph + r(k,3)**2 130 CONTINUE rmstc = rmstc**(0.5) rmsal = rmsal**(0.5) rmsph = rmsph**(0.5) #endif ! RMSError c do k=2,kmax c write(6,*) "r", r(k,3),(dr(3,i,2,k),i=1,3) c enddo #ifdef StdOut write(6,'(a10,6g15.5)') "rms ", $ rmstc, rmsal, rmsph, r(kmax,1), r(kmax,2), r(kmax,3) #endif RETURN END subroutine co3_react_rates(carb,calml, $ rc, $ kmax,cal_c,pw_dreac, $ sl_react, sl_dreac) implicit none integer kmax #include #include #include #include double precision carb(nzmax,3), calml(nzmax,nCaCO3s) double precision cal_c(kmax), pw_dreac(kmax), $ sl_react(nzmax,nCaCO3s), sl_dreac(nzmax,nCaCO3s) double precision rc(nrcmax) integer k,ic, icc, i_target double precision diss_rate, pcp_rate, rate, $ drate, sdrate, seed_area, frag_rate, protons do ic=1,nCaCO3s do k = 2, kmax cal_c(k) = 0. pw_dreac(k) = 0. sl_react(k,ic) = 0. sl_dreac(k,ic) = 0. enddo enddo do ic = 0,nCaCO3s-1 do k = 2, kmax c write(6,*) "starting loop", ic, k rate = 0. drate = 0. sdrate = 0. c------------------------------------------------------------------------ c Dissolution c------------------------------------------------------------------------ if(carb(k,3) .LT. rc(JCaCO3Sat+ic) $ .AND. $ calml(k,1+ic) .GT. 1.d-20) then if(rc(JCaCO3Law+ic) .EQ. 1 $ .OR. $ rc(JCaCO3Law+ic) .EQ. 3 $ ) then ! Keir calcite kinetics diss_rate = rc(JCaCO3K+ic) ! day-1 $ / 86400. ! sec-1 2 * calml(k,1+ic) 1 * ( $ ( 1 $ - ( carb(k,3) $ / rc(JCaCO3Sat+ic) $ ) $ )**rc(JCaCO3N+ic) $ ) ! (1-c/csat)^n rate = diss_rate drate = - rc(JCaCO3K+ic) ! d rate / d pw $ / 86400. $ * rc(JCaCO3N+ic) & * calml(k,1+ic) & / rc(JCaCO3Sat+ic) & * ( $ ( 1 $ - ( carb(k,3) $ / rc(JCaCO3Sat+ic) $ ) $ )**( rc(JCaCO3N+ic)-1. ) $ ) sdrate = rc(JCaCO3K+ic) ! d rate / d solid $ / 86400. 1 * ( $ ( 1 $ - ( carb(k,3) $ / rc(JCaCO3Sat+ic) $ ) $ )**rc(JCaCO3N+ic) $ ) #ifdef CaCO3AcidDissolution protons = rc(JK1) * carb(k,1) / carb(k,2) rate = rate $ + ( rc(JCaCO3K1) * protons ! mol/cm2 s $ + rc(JCaCO3K2) * carb(k,1) ) $ * 50 ! cm2 / g CaCO3 $ * calml(k,1+ic) ! mol CaCO3 / l $ * 100 ! g CaCO3 / mol #endif c write(6,*) "co3ss rate 1-3", k, ic, calml(k,1+ic), c $ rate elseif(rc(JCaCO3Law+ic) .EQ. 2) then ! Acker arag kinetics diss_rate = rc(JCaCO3K+ic) ! day-1 $ / 86400. ! sec-1 $ * calml(k,1+ic) $ * ( 1.e6 ! needs uM? $ * ( rc(JCaCO3Sat+ic) $ - carb(k,3) $ ) $ )**rc(JCaCO3N+ic) ! (csat-c)^n rate = diss_rate drate = - rc(JCaCO3K+ic) $ / 86400. $ * calml(k,1+ic) $ * rc(JCaCO3N+ic) $ * 1.e6 $ * ( 1.e6 $ * ( rc(JCaCO3Sat+ic) $ - carb(k,3) $ ) $ )**( rc(JCaCO3N+ic)-1. ) sdrate = rc(JCaCO3K+ic) $ / 86400. $ * ( 1.e6 $ * ( rc(JCaCO3Sat+ic) $ - carb(k,3) $ ) $ )**rc(JCaCO3N+ic) c write(6,*) "co3ss rate 2", k, ic, calml(k,1+ic), c $ rate else ! other rate law rate = 0. drate = 0. sdrate = 0. endif ! rate law else ! Supersat c------------------------------------------------------------------------ c Precipitation c------------------------------------------------------------------------ if(rc(JCaCO3PcpK+ic) .GT. 0) then seed_area = 0. ! units m2/l if( rc(JCaCO3PcpSeed+ic) .EQ. rc(JCaCO3Phase) ) then do icc = 0, nCaCO3s-1 seed_area = seed_area $ + calml(k,1+icc) ! mol / l tot $ * molwt(iCaCO3+icc) ! g / l tot $ * rc(JCaCO3PcpArea+icc) ! m2 / g CaCO3 -> m2 / l tot enddo endif pcp_rate = - rc(JCaCO3PcpK+ic) ! umol / m2 hr Zhong 93 $ / 1.e6 / 3600. 2 * seed_area ! m2 / l tot 1 * ( $ ( $ ( carb(k,3) $ / rc(JCaCO3Sat+ic) $ ) $ - 1 $ )**rc(JCaCO3N+ic) $ ) rate = rate + pcp_rate drate = - rc(JCaCO3K+ic) $ / 1.e6 / 3600 2 * seed_area ! m2 / l tot $ * rc(JCaCO3N+ic) & / rc(JCaCO3Sat+ic) & * ( $ ( $ ( carb(k,3) $ / rc(JCaCO3Sat+ic) $ ) $ - 1 $ )**( rc(JCaCO3N+ic)-1. ) $ ) c sdrate = - rc(JCaCO3K+ic) * 1.1574d-5 c 1 *(((carb(k)/rc(JCaCO3Sat+ic))-1)**rc(JCaCO3K+ic)) endif ! PcpK > 0. endif ! under or super sat c write(6,*) "co3ss rate", k, ic, rate cal_c(k) = cal_c(k) + rate pw_dreac(k) = pw_dreac(k) + drate sl_react(k,1+ic) = sl_react(k,1+ic) - rate sl_dreac(k,1+ic) = sl_dreac(k,1+ic) - sdrate ! Are these actually used anywhere? c------------------------------------------------------------------------ c Fragmentation c------------------------------------------------------------------------ if( rc(JCaCO3Frag+ic) .GT. 0.) then ! solid -> solid, no pw_react if(diss_rate .GT. 0) then ! then its dissolving frag_rate = diss_rate * rc(JCaCO3Frag+ic) ! strictly proportional to diss_rate i_target = rc(JCaCO3FragDaug+ic) + 0.1 sl_react(k,1+ic) = sl_react(k,1+ic) $ - frag_rate sl_react(k,i_target) = $ sl_react(k,i_target) $ + frag_rate endif endif enddo ! k enddo ! ic c do k=2,kmax c write(6,*) "cal_c", k, cal_c(k) c enddo return end SUBROUTINE gaussj(runid,idebug,a,n,np,b,m,mp) C numerical recipes, pages 28-29 implicit none integer nmax PARAMETER (nmax=500) c external variables integer runid, idebug, n, np, m, mp DOUBLE PRECISION a(np,np), b(np,mp) c internal variables integer ipiv(nmax) integer indxr(nmax), indxc(nmax) double precision big, dum, pivinv integer i, j, k, l, ll, ibomb, jbomb, ibiv, irow, icol c if(idebug .EQ. -999) then c write(6,*) "Previous Abort. Skipping Gaussj" c return c endif c write(6,*) "simulated abort at runid ", runid c runid = -999 c return Do 11 j=1,n ipiv(j)=0 11 CONTINUE DO 22 i=1,n big=0. DO 13 j=1,n IF(ipiv(j).NE.1) then DO 12 k=1,n IF(ipiv(k).EQ.0) then IF(abs(a(j,k)).ge.big) then big=abs(a(j,k)) irow=j icol=k ENDIF ELSE IF(ipiv(k).GT.1) then write(6,*) 'ipiv singular matrix at runid ', runid idebug = -999 do ibomb=1, np do jbomb=1,mp b(ibomb,jbomb) = 0. enddo enddo return ENDIF 12 CONTINUE ENDIF 13 CONTINUE ipiv(icol)=ipiv(icol)+1 IF(irow.NE.icol) then DO 14 l=1,n dum=a(irow,l) a(irow,l)=a(icol,l) a(icol,l)=dum 14 CONTINUE DO 15 l=1,m dum=b(irow,l) b(irow,l)=b(icol,l) b(icol,l)=dum 15 CONTINUE ENDIF indxr(i)=irow indxc(i)=icol IF(a(icol,icol).EQ.0.) then write(6,*) "a(:) singular matrix at runid ", runid idebug = -999 do ibomb=1, np do jbomb=1,mp b(ibomb,jbomb) = 0. enddo enddo return endif pivinv=1./a(icol,icol) a(icol,icol)=1. DO 16 l=1,n a(icol,l)=a(icol,l)*pivinv 16 CONTINUE DO 17 l=1,m b(icol,l)=b(icol,l)*pivinv 17 CONTINUE DO 21 ll=1,n IF(ll.NE.icol) then dum=a(ll,icol) a(ll,icol)=0. DO 18 l=1,n a(ll,l)=a(ll,l)-a(icol,l)*dum 18 CONTINUE DO 19 l=1,m b(ll,l)=b(ll,l)-b(icol,l)*dum 19 CONTINUE ENDIF 21 CONTINUE 22 CONTINUE DO 24 l=n,1,-1 IF(indxr(l).NE.indxc(l)) then DO 23 k=1,n dum=a(k,indxr(l)) a(k,indxr(l))=a(k,indxc(l)) a(k,indxc(l))=dum 23 CONTINUE ENDIF 24 CONTINUE RETURN END SUBROUTINE calc_boron_diff(difba,difbc, * form,pore,delz,kmax, * dbapls,dbamin,dbcpls,dbcmin) implicit none integer kmax DOUBLE PRECISION difba,difbc DOUBLE PRECISION form(kmax),pore(kmax),delz(kmax) DOUBLE PRECISION dbapls(kmax), dbamin(kmax), $ dbcpls(kmax), dbcmin(kmax) integer i DO 30 i=3,kmax-1 dbapls(i)=difba 1 *((form(i+1)+form(i))/2) 2 * 1 / pore(i) 3 * 2 / ( (delz(i+1)+delz(i)) * delz(i) ) dbamin(i)=difba 1 *((form(i-1)+form(i))/2) 2 * 1/pore(i) 3 * 2 / ( (delz(i-1)+delz(i)) * delz(i) ) dbcpls(i)=difbc 1 *((form(i+1)+form(i))/2) 2 * 1 / pore(i) 3 * 2 / ( (delz(i+1)+delz(i)) * delz(i) ) dbcmin(i)=difbc 1 *((form(i-1)+form(i))/2) 2 * 1/pore(i) 3 * 2 / ( (delz(i-1)+delz(i)) * delz(i) ) 30 CONTINUE i=kmax dbapls(i)=0. dbamin(i)=difba 1 *((form(i-1)+form(i))/2) 2 *1/pore(i) 3 * 2 / ( (delz(i-1)+delz(i)) * delz(i) ) dbcpls(i)=0. dbcmin(i)=difbc 1 *((form(i-1)+form(i))/2) 2 *1/pore(i) 3 * 2 / ( (delz(i-1)+delz(i)) * delz(i) ) i=2 dbapls(i)=difba 1 *((form(i+1)+form(i))/2) 2 *1/pore(i) 3 * 2 / ( (delz(i+1)+delz(i)) * delz(i) ) dbamin(i)=difba 1 *(form(i)+1)/2 2 *1/pore(i) 3 *1/delz(i)**2 dbcpls(i)=difbc 1 *((form(i+1)+form(i))/2) 2 *1/pore(i) 3 * 2 / ( (delz(i+1)+delz(i)) * delz(i) ) dbcmin(i)=difbc 1 *(form(i)+1)/2 2 *1/pore(i) 3 *1/delz(i)**2 RETURN END C file 'diag.for', which calculates the diffusive fluxes of C o2, total co2, and alkalinity at the sediment-water C interface, and also the integrated reaction rates of C those quantities. used by co3main to determine when to C stop repeating the co3 subroutine. SUBROUTINE diag_co3(ttrtc,ttral,diftc,difal, * ttrcal,ttrorg, * resp_c,n_r,cal_c,dalk, * carb,n_c,ba, $ pore,delz, * dcco2,dchco3,dcco3,dcbor, $ irrig, * kmax) implicit none integer kmax, n_r, n_c DOUBLE PRECISION resp_c(n_r,3), cal_c(kmax),dalk(kmax) DOUBLE PRECISION carb(n_c,3),ba(kmax) DOUBLE PRECISION pore(kmax),delz(kmax) DOUBLE PRECISION ttreac(3), difflx(4) double precision ttral, difal, ttrtc,diftc, $ ttrcal, ttrorg, extra_difalk double precision irrigflux(4) double precision dcco2,dchco3,dcco3,dcbor, irrig(kmax), $ irral integer j, k C zero the diagnostics variables, ttreac and flux DO 10 j=1,3 ttreac(j) = 0. difflx(j) = 0. irrigflux(j) = 0. 10 CONTINUE irrigflux(4) = 0. ttrcal = 0. ttrorg = 0. extra_difalk = 0. C reaction rates are in units of mol species/cm2 (total) y DO 20 k = 2, kmax ttreac(1) = ttreac(1) . + resp_c(k,1) * delz(k) * * 3.15E7 / 1e3 ttreac(2) = ttreac(2) . + resp_c(k,2) * delz(k) * * 3.15E7 / 1e3 $ - dalk(k) * delz(k) * * 3.15E7 / 1e3 ttreac(3) = ttreac(3) . + resp_c(k,3) * delz(k) * * 3.15E7 / 1e3 * + cal_c(k) * delz(k) * * 3.15E7 / 1e3 $ + dalk(k) * delz(k) * * 3.15E7 / 1e3 ttrcal = ttrcal . + cal_c(k) * delz(k) * * 3.15E7 / 1e3 ttrorg = ttrorg * + ( resp_c(k,1) * + resp_c(k,2) * + resp_c(k,3) * ) * delz(k) * * 3.15e7 / 1e3 extra_difalk = extra_difalk ! column integral, >0 if net alk source $ + dalk(k) * delz(k) * * 3.15E7 / 1e3 do j=1,3 irrigflux(j) = irrigflux(j) $ + irrig(k) ! sec-1 $ * ( carb(1,j) - carb(k,j) ) ! mol/l pw $ * pore(k) ! mol/l tot $ / 1000. * delz(k) * 3.15e7 ! mol/cm2 yr c write(6,*) k,j,irrig(k),carb(1,j)-carb(k,j), c $ irrig(k)*(carb(1,j)-carb(k,j))*1e9, c $ irrigflux(j) c write(6,*) j,irrigflux(j) enddo c irrigflux(4) = irrigflux(4) c $ + irrig(k) ! sec-1 c $ * ( ba(1) - ba(k) ) ! mol/l pw c $ * pore(k) ! mol/l tot c $ / 1000. * delz(k) * 3.15e7 ! mol/cm2 yr 20 CONTINUE C the diffusive fluxes, positive downward difflx(1) = dcco2 1 * ( carb(1,1) - carb(2,1) ) 2 * pore(2) 3 * delz(2) 4 * 3.15e7 / 1e3 difflx(2) = dchco3 1 * ( carb(1,2) - carb(2,2) ) 2 * pore(2) 3 * delz(2) 4 * 3.15e7 / 1e3 difflx(3) = dcco3 1 * ( carb(1,3) - carb(2,3) ) 2 * pore(2) 3 * delz(2) 4 * 3.15e7 / 1e3 c difflx(4) = dcbor c 1 * ( ba(1) - ba(2) ) c 2 * pore(2) c 3 * delz(2) c 4 * 3.15e7 / 1e3 ttral = ttreac(2) + ttreac(3) * 2 ! + ttrbor difal = difflx(2) + difflx(3) * 2. ! + difflx(4) irral = irrigflux(2) + irrigflux(3)*2. ! + irrigflux(4) difal = difal + irral c $ + extra_difalk ttrtc = ttreac(1) + ttreac(2) + ttreac(3) diftc = difflx(1) + difflx(2) + difflx(3) $ + irrigflux(1) + irrigflux(2) + irrigflux(3) RETURN END SUBROUTINE boron(carb,n_c,tbor_bw,u1,ub, $ dbapls,dbamin,dbcmin,irrig, $ z,delz,form,pore,kmax,ba,dalkbor) c takes the pH profile implied by the carbonate system c and calculates the borate profile. c returns the the alkalinity source/sink required to maintain c that profile implicit none #include #include integer kmax, n_c DOUBLE PRECISION carb(n_c,3),z(kmax),delz(kmax), $ form(kmax),pore(kmax) DOUBLE PRECISION dalkbor(kmax) DOUBLE PRECISION tborz(nzmax), Bcfrac(nzmax),ba(nzmax) DOUBLE PRECISION dbapls(kmax), dbamin(kmax),dbcmin(kmax), $ irrig(nzmax) double precision u1, ub double precision dcco2, dchco3, dcco3, dcbor double precision tbor_bw double precision ttrtc, ttral, diftc, difal, $ ttrcal, ttrorg integer iz do iz=1, kmax Bcfrac(iz) = 1 / $ ( 1 + $ ( ub * carb(iz,2) ) $ / ( u1 * carb(iz,1) ) $ ) enddo tborz(1) = tbor_bw do iz=2, kmax tborz(iz) = tborz(iz-1) $ * ( ( 1 - Bcfrac(iz-1) ) * dbamin(iz) $ + Bcfrac(iz-1) * dbcmin(iz) $ ) $ / ( ( 1 - Bcfrac(iz-1) ) * dbamin(iz) $ + Bcfrac(iz-1) * dbcmin(iz) $ ) enddo do iz = 1, kmax ba(iz) = tborz(iz) * ( 1-Bcfrac(iz) ) enddo do iz=2, kmax-1 dalkbor(iz) = dalkbor(iz) $ - ( dbapls(iz) * ( ba(iz+1) - ba(iz) ) ! incoming borate = source of alk $ - dbamin(iz) * ( ba(iz) - ba(iz-1) ) $ ) c units of moles / l *porewater* sec $ * pore(iz) c units of moles / l total sec $ - irrig(iz) * ( ba(1)-ba(iz) ) ! mol/l pw s $ * pore(iz) enddo iz=kmax dalkbor(iz) = dalkbor(iz) $ - ( $ - dbamin(iz) * ( ba(iz) - ba(iz-1) ) $ ) $ * pore(iz) $ - irrig(iz) * (ba(1)-ba(iz)) * pore(iz) return end #ifdef ProtonTransport subroutine proton_transport(carb,ck1, $ sl_gg, $ dhppls,dhpmin, $ dohpls,dohmin, $ db_array, $ omega, $ z,delz,form,pore,kmax, $ dalkproton) implicit none #include #include c external variables double precision carb(nzmax,3), ck1, $ sl_gg(nzmax,nsolidmax), $ dhppls(nzmax), dhpmin(nzmax), $ dohpls(nzmax), dohmin(nzmax), $ db_array(nzmax,nDbs), $ omega(nzmax), $ z(nzmax), delz(nzmax), form(nzmax), pore(nzmax), $ dalkproton(nzmax) integer kz,kmax,iCa c internal variables double precision proton(nzmax), hydroxyl(nzmax), $ k_carbonates, k_clay, k_feooh, $ carbonate_sites(nzmax), clay_sites(nzmax), $ feooh_sites(nzmax), xads(nzmax) c computes the pH profile and calculates the alkalinity source/sink c from proton transport implied by that profile. do kz=1,kmax proton(kz) = ck1 * carb(kz,1) / carb(kz,2) hydroxyl(kz) = 1.e-14 / proton(kz) enddo c molecular diffusion do kz=2,kmax ! diffusion from above dalkproton(kz) = dalkproton(kz) $ - dhpmin(kz) * (proton(kz) - proton(kz-1)) ! lose protons == gain alk $ + dohmin(kz) * (hydroxyl(kz) - hydroxyl(kz-1)) enddo do kz=2,kmax-1 ! diffusion to below dalkproton(kz) = dalkproton(kz) $ + dhppls(kz) * (proton(kz+1) - proton(kz)) $ - dohpls(kz) * (hydroxyl(kz+1) - hydroxyl(kz)) enddo #ifdef ProtonAdsorption k_carbonates = 10**(8.2) k_clay = 10**(3.5) k_feooh = 10**(6.) do kz=2,kmax carbonate_sites(kz) = 0 do iCa=1,nCaCO3s carbonate_sites(kz) = carbonate_sites(kz) $ + sl_gg(kz,iCaCO3+iCa-1) $ * 2.5 * (1-pore(kz)) * 1000 ! g/l $ * 0.04 / 1000. ! mol/l enddo clay_sites(kz) = sl_gg(kz,IClay) $ * 2.5 * (1-pore(kz)) * 1000 ! g/l $ * 0.1 / 1000. ! mol/l feooh_sites(kz) = sl_gg(kz,IFeOOH) $ * 2.5 * (1-pore(kz)) * 1000 ! g/l $ * 11. / 1000. ! mol/l xads(kz) = $ carbonate_sites(kz) $ * k_carbonates * proton(kz) * carbonate_sites(kz) $ / (k_carbonates * proton(kz) + 1) $ + clay_sites(kz) $ * k_clay * proton(kz) * clay_sites(kz) $ / (k_clay * proton(kz) + 1) $ + feooh_sites(kz) $ * k_feooh * proton(kz) * feooh_sites(kz) $ / (k_feooh * proton(kz) + 1) enddo xads(1) = 0. c bioturbation do kz=2,kmax ! from above dalkproton(kz) = dalkproton(kz) $ + db_array(kz,DbTop) ! sign reversed because +ve proton flux = -ve alk flux c 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) c $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * ( xads(kz) - xads(kz-1) ) enddo do kz=2,kmax-1 ! to below dalkproton(kz) = dalkproton(kz) $ - db_array(kz,DbBot) ! sign reversed because +ve proton flux = -ve alk flux c 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) c $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * ( xads(kz+1) - xads(kz) ) enddo c burial do kz=3,kmax ! incoming from above dalkproton(kz) = dalkproton(kz) $ - xads(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ * pore(kz) / (1-pore(kz)) $ * 2.5 / 3.15e7 enddo do kz=2,kmax ! outgoing to below dalkproton(kz) = dalkproton(kz) $ + xads(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ * pore(kz) / (1-pore(kz)) $ * 2.5 / 3.15e7 enddo #ifdef StdOut #define ProtonTransportStdOut #ifdef ProtonTransportStdOut do kz=2,kmax write(6,'(a6,i4,7g15.5)') "PAds", $ kz, carbonate_sites(kz), 2 clay_sites(kz), 3 feooh_sites(kz), 4 carbonate_sites(kz) $ * k_carbonates * proton(kz) * carbonate_sites(kz) $ / (k_carbonates * proton(kz) + 1), 5 clay_sites(kz) $ * k_clay * proton(kz) * clay_sites(kz) $ / (k_clay * proton(kz) + 1), 6 feooh_sites(kz) $ * k_feooh * proton(kz) * feooh_sites(kz) $ / (k_feooh * proton(kz) + 1), 7 dalkproton(kz) enddo #endif #endif #endif return end #endif SUBROUTINE calcdc(difc,form,pore,delz,kmax, . dcpls,dcmin,ksize) implicit none integer kmax, ksize DOUBLE PRECISION difc(3) DOUBLE PRECISION form(kmax), pore(kmax), delz(kmax) DOUBLE PRECISION dcpls(ksize,3), dcmin(ksize,3) integer i,j DO 30 i=3,kmax-1 DO 40 j=1,3 dcpls(i,j)=difc(j) 1 *(delz(i)*form(i+1)+delz(i+1)*form(i)) * / (delz(i)+delz(i+1)) 2 * 1 / pore(i) 3 *(2/((delz(i+1)+delz(i))*delz(i))) dcmin(i,j)=difc(j) 1 *(delz(i)*form(i-1)+delz(i-1)*form(i)) * / (delz(i)+delz(i-1)) 2 * 1 / pore(i) 3 *(2/((delz(i-1)+delz(i))*delz(i))) 40 CONTINUE 30 CONTINUE DO 50 j=1,3 i=kmax dcpls(i,j)=0 dcmin(i,j)=difc(j) 1 *(delz(i)*form(i-1)+delz(i-1)*form(i)) * / (delz(i)+delz(i-1)) 2 * 1 / pore(i) 3 *(2/((delz(i-1)+delz(i))*delz(i))) i=2 dcpls(i,j)=difc(j) 1 *(delz(i)*form(i+1)+delz(i+1)*form(i)) * / (delz(i)+delz(i+1)) 2 * 1 / pore(i) 3 *(2/((delz(i+1)+delz(i))*delz(i))) dcmin(i,j)=difc(j) 1 *(form(i)+1)/2 2 * 1 / pore(i) 3 *(1/(delz(i)**2)) 50 CONTINUE RETURN END / (delz(i)+delz(i-1)) 2 * 1 / pore(i) 3 *(2/((delz(i-1)+delz(i))*delz(i))) i=2 dcpls(i,j)=difc(j) 1 *(delz(i)*form(i+1)+delz(i+1)*form(i)) * / (delz(i)+delz(i+1)) 2 * 1 / porcompute.cost.mpi.F000644 025374 000024 00000014233 10413036311 014654 0ustar00archeruser000000 000000 #include subroutine compute_cost_mpi(targetfile,tuner,cost,iinit) implicit none #include #include #include #include #include #include #include #include #include character*80 targetfile double precision cost(ntargets+1), $ target(nsites,ntargets),output(nsites,ntargets) character*12 sitename(nsites) double precision rcmaster(nrcmax), rc(nrcmax) double precision rcscale(nrcmax), rcscaled(nrcmax) double precision rain(nsolidmax) double precision porewater_conc(nzmax,nsolutemax,nsites) double precision solid_gg(nzmax,nsolidmax,nsites) double precision pw_react(nsolutemax,nsites), $ pw_diff(nsolutemax,nsites), $ sl_react(nsolidmax,nsites), sl_react_pw(nsolidmax,nsites), $ sl_inv(nsolidmax,nsites), burial(nsolidmax,nsites), $ sl_residual(nsolidmax,nsites), $ pw_residual(nsolidmax,nsites), $ org_consume(norgs,nsolutemax,nsites), $ z_level(nzlevels,nsites), $ storage(Stor_N,nsites) double precision arg_array(1000,nSites) double precision bwchem(nBottomWaters,nsites), $ rainorg(nsites),raincal(nsites), $ rainopal(nsites),rainclay(nsites) integer isite, isite_in(nsites), idebug, iinit, runid, $ itarget, iorgc, iter,ibwchem integer myid,ierr double precision totorgc(nsites) double precision ratio(ntargets) integer nratios(ntargets) save porewater_conc, solid_gg, z_level,storage call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) c write(6,*) "I am ", myid, " within compute_cost_mpi" if(myid .EQ. Master) then do itarget = 1, ntargets cost(itarget) = 0 ratio(itarget) = 0 do isite=1,nsites target(isite,itarget) = 0. enddo enddo open(7,file=targetfile) read(7,*) ! headings do isite=1,nsites READ(7,*,END=100) isite_in(isite), $ (bwchem(ibwchem,isite), ibwchem=1,nBottomWaters), $ rainorg(isite),raincal(isite), $ rainopal(isite),rainclay(isite), $ (target(isite,itarget), itarget=1,ntargets), $ sitename(isite) enddo 100 continue close(7) do isite=1, nsites idebug = 0 call generate_rates(rainorg(isite),raincal(isite), $ rainopal(isite),rainclay(isite), $ bwchem(BWO2,isite),tuner, $ rain,rc) runid = isite call compact_mudsargs( $ runid, iinit,idebug, $ rc, $ porewater_conc(1,1,isite), $ solid_gg(1,1,isite), $ bwchem(1,isite), $ rain, $ pw_react(1,isite), pw_diff(1,isite), $ sl_react_pw(1,isite), $ sl_react(1,isite), sl_inv(1,isite), $ burial(1,isite), $ sl_residual(1,isite), pw_residual(1,isite), $ org_consume(1,1,isite), z_level(1,isite), $ storage(1,isite), $ iter, . arg_array(1,isite),1 $ ) c write(6,*) "Master compacts ", runid, arg_array(1,isite) enddo c write(6,*) "Master is done with compactifying arguments" endif ! myid .EQ. Master call queue_all(arg_array,nsites) if(myid .EQ. Master) then do isite = 1, nsites call compact_mudsargs( $ runid, iinit,idebug, $ rc, $ porewater_conc(1,1,isite), $ solid_gg(1,1,isite), $ bwchem(1,isite), $ rain, $ pw_react(1,isite), pw_diff(1,isite), $ sl_react_pw(1,isite), $ sl_react(1,isite), sl_inv(1,isite), $ burial(1,isite), $ sl_residual(1,isite), pw_residual(1,isite), $ org_consume(1,1,isite), z_level(1,isite), $ storage(1,isite), $ iter, . arg_array(1,isite),-1 $ ) output(isite,1) = porewater_conc(10,IMn2p,isite)*1e6 output(isite,2) = porewater_conc(10,IFe2p,isite)*1e6 output(isite,3) = porewater_conc(10,INH4,isite)*1e6 totorgc(isite) = 0 do iorgc=1,norgs totorgc(isite) = totorgc(isite) $ + solid_gg(10,IORG+iorgc-1,isite) enddo output(isite,4) = totorgc(isite) * 100. #define PlusUnreactiveMnO2 output(isite,5) = ! MnO2 at 12 cm depth $ ( $ solid_gg(10,IMnO2,isite) #ifdef PlusUnreactiveMnO2 $ + solid_gg(10,IClay,isite) $ * 8.5e-4 * ( 1. - 0.5 ) #endif $ ) ! g/g total elemental Mn $ * 1.e6 ! ppm elemental Mn output(isite,6) = ! MnO2 at the surface $ ( $ solid_gg(2,IMnO2,isite) #ifdef PlusUnreactiveMnO2 $ + solid_gg(2,IClay,isite) $ * 8.5e-4 * ( 1. - 0.5 ) #endif $ ) ! g/g total elemental Mn $ * 1.e6 ! ppm elemental Mn output(isite,7) = z_level(2,isite) output(isite,8) = porewater_conc(10,IH2S,isite)*1e6 write(6,10) sitename(isite), iter, $ (output(isite,itarget), $ target(isite,itarget), $ itarget=1,ntargets) call flush(6) 10 format(a6,i4,16f8.1) 15 format(f15.4,6f20.4) 20 format(a15,7a20) enddo ! isite do itarget=1,ntargets call r2(target(1,itarget), $ output(1,itarget), $ nsites,cost(itarget)) c write(6,*) "skipping r2" c cost(itarget) = 0. enddo ! itarget endif ! myid .EQ. Master c one last reality tweak cost(4) = cost(4) * 5. cost(8) = sqrt(cost(8))/100. c cost(8) = 0. return end format(a6,i4,16f8.1) 15 format(f15.4,6f20.4) 20 format(a15,7a20) enddo ! isite do itarget=1,ntargets call r2(target(1,itarget), $ output(1,itarget), $ nsites,cost(itarget)) c write(6,*) "skipping r2" c cost(itarget) = 0. enddo ! itarget endif ! mdefines.h000644 025374 000024 00000003051 10413036311 013120 0ustar00archeruser000000 000000 #define MUDS_NZ 18 c#define Bells_Whistles #define Irrig c#define LowO2IrrigBoost #define IrrigOxidation c#define SimpleForm c#define SimpleOrg c#define CompareSolidSS #define OxicOrgOn cccc#define EqualRespRates #define NO3Resp #define SkipFeMnUpdate 5 #define NSolidIters 25 #define MnReactions #define MnResp #define MnOx #define MnAdsorption #define MnAdsorptionMixing #define MnAdsorptionBurial #define MnCO3Pcp #define MnRedepositIrrig cccccc#define MnRedepositDiffusion #define MnIrrigOxidation #define MnSolidRctExport #define MnPHForcing #define MnPHForcingOx c#define MnPHForcingSimple c#define MnPHForcingSimpleOx ccc#define BoostMnRain ccc#define KillMnRain #define FeResp #define SResp #define FeOx #define HSOx #define FeSOx #define FeSPcp #define FeAdsorptionON #define FeAdsorbMixing #define FeAdsorbBurial #define FeIrrigOxidation #define FeRedepositIrrig ccccccc#define FeRedepositDiffusion #define FeNO3Forcing ccccc#define FePHForcing #define FePHForcingSimple #define FePhForcingOx ccc#define FeCO3 ! disabled #define NH4Ox #define NH4Adsorption #define NH4Irrigation #define URed #define UOx #define URain #define LowBWUranium 9.E-9 #define SlowUranium #define CaCO3Dissolution c#define ReadCalciteKineticsFile cccc#define SlowCalcite #define Dickson #define BoronAlkalinity #define ProtonTransport #define ProtonAdsorption c#define AragoniteDissolution c#define CaCO3AcidDissolution c#define NonlinearCalcite c#define TwoCalcites c#define SevenCalcites c#define CaCO3Precipitation c#define BioturbationBox isabled #define NH4Ox #define NH4Adsorption #define NH4Irrigation #define URed #define UOx #define URain #define LowBWUranium 9.E-9 #define SlowUranium #define CaCO3Dissolution c#define ReadCalciteKineticsFile cccc#define SlowCalcite #define Dickson #define BoronAlkalinity #define ProtonTransport #define ProtonAdsorption c#define AragoniteDissolution c#define CaCO3AcidDissolution c#define NonlinearCalcite c#define TwoCalcites c#define SevenCalcites c#define CaCO3findalk.F000644 025374 000024 00000003362 10413036311 013056 0ustar00archeruser000000 000000 SUBROUTINE findalk(dco3_target,tco2,z,temp,sal,alk) implicit none #include double precision dco3_target, tco2, z, temp, sal, alk, $ alk_low, alk_high, csat(nCaCO3s), $ co2,hco3,co3,dco3 double precision k1,k2,kb integer i,j alk_low = 2000. alk_high = 3000. DO i=1, 25 alk = ( alk_low + alk_high ) / 2 do j=1,nCaCO3s csat(j) = 1.0 enddo call calc_k_csat(temp,sal,z,csat,k1,k2,kb) call calc_co2chem(temp, sal, z, . k1,k2,kb, $ alk/1.d6, tco2/1.d6, $ co2, hco3, co3) dco3 = (co3 - csat(1)) * 1E6 IF( dco3 .GT. dco3_target ) THEN C then alky is too high alk_high = alk ELSE alk_low = alk ENDIF ENDDO RETURN END SUBROUTINE findtco2(dco3_target,alk,z,temp,sal,tco2) implicit none #include double precision dco3_target, tco2, z, temp, sal, alk, $ tco2_low, tco2_high, a_junk1, a_junk2, csat(nCaCO3s), $ co2,hco3,co3,dco3 double precision k1,k2,kb integer i,j tco2_low = 1500. tco2_high = 3000. DO i=1, 25 tco2 = ( tco2_low + tco2_high ) / 2 do j=1,nCaCO3s csat(j) = 1.0 enddo call calc_k_csat(temp,sal,z,csat,k1,k2,kb) call calc_co2chem(temp, sal, z, . k1,k2,kb, $ alk/1.d6, tco2/1.d6, $ co2, hco3, co3) dco3 = (co3 - csat(1)) * 1E6 IF( dco3 .LT. dco3_target ) THEN C then tco2 is too high tco2_high = tco2 ELSE tco2_low = tco2 ENDIF ENDDO RETURN END tco2_low + tco2_high ) / 2 do j=1,nCaCO3s csat(j) = 1.0 enddo call calc_k_csat(temp,sal,z,csat,k1,k2,kb) call calc_co2chem(temp, sal, z, . k1,k2,kb, $ alk/1.d6, tco2/1.d6, $ co2, hco3, co3)full_steady_state.F000644 025374 000024 00000062365 10413036311 015171 0ustar00archeruser000000 000000 #include subroutine full_steady_state( . runid,iinit,iunit,idebug, $ rc, $ pw_conc,sl_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, $ sl_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include #include c externally declared variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision bwchem(nBottomWaters) c internal variables1 c grid stuff double precision z(nzmax), delz(nzmax), $ form(nzmax), pore(nzmax), $ diff_array(nzmax,2,nsolutemax), irrig_array(nzmax), $ db_array(nzmax,nDbs) #include c solid stuff double precision omega(nzmax), ggtot(nzmax) double precision sl_ml(nzmax,nsolidmax), $ rain(nsolidmax), msrain c reaction rates and stoiciometries double precision rc(nrcmax), $ pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), burial(nsolidmax), $ sl_residual(nsolidmax), pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax) double precision pw_react_rates(nzmax,nsolutemax) double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax), z_level(nzlevels) double precision storage(Stor_N) c names and display stuff double precision omega_new(nzmax), fract logical i_bail, i_bail_mn data i_bail / .FALSE. / integer kmax, niter, runid, iinit, idebug, iunit, i_pw_only, $ iter, k, isol, ipw, solids_iter, ifast,iorgc data niter /250/ c data niter /2/ c write(6,*) o2bw, no3bw, alkbw, tco2bw, sibw, c $ rain c begin c initialize sl_gg c if(iinit .GT. 0) then call init_base(pw_conc, sl_gg, $ bwchem, g z,delz,form, pore, kmax, g omega,ggtot, g rc, $ db_array,diff_coeff, c molwt, pw_react_rates, sl_react_rates, c sl_dreac, c sl_ml,rain,msrain,z_level) call init_update(pw_conc,sl_gg,sl_ml, $ bwchem, g z,delz,form, pore, kmax, $ diff_coeff, diff_array, $ irrig_array, $ omega, . rc, $ pw_react_rates,sl_react_rates,sl_dreac, $ db_array, $ molwt, $ rain,msrain) c calculates orgc reaction rates and initializes [orgc] call initorgc(runid,idebug, $ pw_conc, sl_gg, sl_ml, g z,delz, pore, omega, db_array, kmax, c rc, rain, molwt, sl_react_rates, sl_dreac) if(idebug .LT. 0) then write(6,*) "error in initorgc", runid return endif do isol=1,nsolutemax do iorgc = 1,norgs org_consume(iorgc,isol) = 0. enddo enddo if(idebug .GE. 5) then write(iunit,*) c write(iunit,200) "runid", runid, "iteration=", iter, c $ "ggtot=", ggtot(kmax)*100. c call solid_report(iunit,pw_conc, sl_gg, c $ sl_residual, sl_react_tot, c $ burial, c g ggtot, kmax, c c rain, solidname, molwt) c call porewater_report(iunit,pw_conc, sl_gg, c $ pw_react_tot, pw_diff_tot, c $ sl_react_tot, burial,pw_residual, c c solutename, rain, molwt ) call profiles_base(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) endif cc set initial omegas c omega(1) = msrain c DO k=2, kmax c omega(k) = omega(k-1) c do isol = 1, nsolidmax c omega(k) = omega(k) c $ + sl_react_rates(k,isol) cc [ mol / l s ] c c * molwt(isol) * 3.15E7 / 1000. cc [ g / cm3 yr ] c * * delz(k) cc [ g / cm2 yr ] cc or try this one c omega(k) = rain(ICLAY) * molwt(ICLAY) c enddo c enddo c else call init_update(pw_conc,sl_gg,sl_ml, $ bwchem, g z,delz,form, pore, kmax, $ diff_coeff, diff_array, $ irrig_array, $ omega, . rc, $ pw_react_rates,sl_react_rates,sl_dreac, $ db_array, $ molwt, $ rain,msrain) c endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c initial steady state part of the code c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc iter = 0 i_pw_only = 0 call porewater_update(runid,iter,idebug,i_pw_only, $ pw_conc, sl_gg, sl_ml, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, sl_inv, burial, $ org_consume, g z, delz, form, pore, kmax, $ diff_array, irrig_array, c rc, molwt, $ rain, omega,db_array, $ pw_react_rates, sl_react_rates, c sl_dreac, z_level, $ storage) if(idebug .LT. 0) then goto 400 endif c output if(idebug .GE. 5) then write(iunit,*) c write(iunit,200) "runid", runid, "iteration=", iter, c $ "ggtot=", ggtot(kmax)*100. c call solid_report(iunit,pw_conc, sl_gg, c $ sl_residual, sl_react_tot, c $ burial, c g ggtot, kmax, c c rain, solidname, molwt) c call porewater_report(iunit,pw_conc, sl_gg, c $ pw_react_tot, pw_diff_tot, c $ sl_react_tot, burial,pw_residual, c c solutename, rain, molwt ) call profiles_base(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c c c c c MAIN LOOP c c c c c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c#define OnlyOneIter #ifdef OnlyOneIter niter = 1 #endif do 100 iter=1, niter c rc(JCaCO3k+IAragonite) = 0. c rc(JCaCO3k+IAragonite+1) = 0. c if(iter .GE. 10) then c write(6,*) "debugging full_steady_state" c do k=2,kmax c pw_conc(k,iCO3) = pw_conc(k,iCO3) + 10.e-6 c enddo cc rc(JCaCO3k+IAragonite) = 0. cc rc(JCaCO3k+IAragonite+1) = 0. c endif if(iter .LE. 4) then solids_iter = 1 elseif(iter .LE. 10) then solids_iter = 2 else solids_iter = NSolidIters endif if(iter .LT. 4) then ifast = 0 elseif(pw_conc(kmax,ISO4) $ .LT. pw_conc(1,ISO4)*0.9) then ifast = 0 else ifast = 1 endif #define SolidIter #ifdef SolidIter call solid_all_iter(runid,idebug,solids_iter,ifast, $ sl_gg, $ sl_ml, $ sl_react_tot, $ burial, sl_inv, g delz, pore, omega, db_array, ggtot, kmax, c rain, sl_react_rates, sl_dreac, molwt ) if(idebug .LT. 0) then write(6,*) "error in solid_iter", runid return endif #endif c output if(idebug .GE. 5) then write(iunit,*) write(iunit,200) "runid", runid, "iteration=", iter, $ "ggtot=", ggtot(kmax)*100. call profiles_base(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) endif call porewater_update(runid,iter,idebug,i_pw_only, $ pw_conc, sl_gg, sl_ml, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, sl_inv, burial, $ org_consume, g z, delz, form, pore, kmax, $ diff_array, irrig_array, c rc, molwt, $ rain,omega,db_array, $ pw_react_rates, sl_react_rates, c sl_dreac, z_level, $ storage) if (runid .EQ. -999) then write(6,*) "Error detected in gaussj. Aborting" goto 400 endif c set omegas omega_new(1) = msrain DO k=2, kmax omega_new(k) = omega(k-1) do isol = 1, nsolidmax omega_new(k) = omega_new(k) $ + sl_react_rates(k,isol) c [ mol / l s ] c * molwt(isol) * 3.15E7 / 1000. c [ g / cm3 yr ] * * delz(k) c [ g / cm2 yr ] enddo if( c $ ABS((omega_new(k)-omega(k))/omega(k)-1) c $ .LT. 0.1 ! less than 10% change, OK c $ .AND. $ omega_new(k) .GT. rain(ICLAY) * molwt(ICLAY)) then fract = 0.25 omega(k) = (1-fract) * omega(k) $ + fract * omega_new(k) else omega(k) = rain(ICLAY) * molwt(ICLAY) $ / sl_gg(k,ICLAY) endif c if(omega_new(k) .GT. 0) then c fract = 0.25 c else c fract = - omega(k) !! at most 50% decrease c $ / ( (omega_new(k) - omega(k)) * 2) c fract = MIN(0.25,fract) c endif c omega(k) = (1-fract) * omega(k) c $ + fract * omega_new(k) enddo c omega_new(k) = MAX(omega_new(k), c $ 0.5 * rain(ICLAY) * molwt(ICLAY) c $ / sl_gg(k,ICLAY) c $ ) omega(kmax) = MIN(omega(kmax), 2.*omega(kmax-1)) if(ggtot(kmax) .GT. 2) omega(kmax) = omega(kmax)*2 call flux_convergence(omega, sl_gg, $ sl_react_tot, $ rain, burial, molwt, $ pw_diff_tot, pw_react_tot, $ kmax, $ sl_residual, pw_residual) c output if(idebug .GE. 3) then write(iunit,*) write(iunit,200) "runid", runid, "iteration=", iter, $ "ggtot=", ggtot(kmax)*100. 200 format( a6, i8, a10,i4, a10,f6.2) call solid_report(iunit,pw_conc, sl_gg, $ sl_residual, sl_react_tot, $ burial, g ggtot, kmax, c rain, solidname, molwt) call porewater_report(iunit,pw_conc, sl_gg, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, burial,pw_residual, c solutename, rain, molwt ) endif if(idebug .EQ. 4) then call profiles_base(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) endif cc catch low calcite case and bail c if( sl_gg(2,iCaCO3+ICALCITE) .LT. -99. ! 0.05 c $ .AND. -sl_react_tot(iCaCO3+iCalcite) c $ .GT. rain(iCaCO3+iCalcite) * molwt(iCaCO3+iCalcite) c $ .AND. .NOT. i_bail c $ ) then cc disavaw any knowledge c i_bail = .TRUE. c msrain = msrain - rain(iCaCO3+iCalcite) c $ * molwt(iCaCO3+iCalcite) c rain( iCaCO3+iCalcite ) = 0. cc rc( JCaCO3k ) = 0. c do k=1, kmax c sl_gg(k,iCaCO3+iCalcite) = 0. c enddo cc write(6,*) "The Low Calcite Bail" c endif if( sl_gg(2,IMnO2) .LT. 1.e-12 ) then i_bail_mn = .TRUE. msrain = msrain - rain(IMnO2) * molwt(IMnO2) rain(IMnO2) = 0. do k=1,kmax sl_gg(k,IMnO2) = 0. enddo endif c if(sl_gg(kmax,IFEOOH) .LT. 0) then c msrain = msrain - rain(IFEOOH) * molwt(IFEOOH) c rain(IFEOOH) = 0. c sl_gg(1,IFEOOH) = -99. c do k=2,kmax c sl_gg(k,IFEOOH) = 0. c enddo c endif c diagnostics c if(iter .EQ. niter - 10) then c write(6,*) "no convergence" c endif do isol = 1, 5 ! neglecting iron and sulfides for now if( dabs(sl_residual(isol)) .GT. 0.02 ) then goto 100 endif enddo c do ipw=1, 7 ! cheating again c if( dabs(pw_residual(ipw)) .GT. 2*converge ) then c goto 100 c endif c enddo do k=2,kmax if( dabs(ggtot(k) - 1.d0) .GT. 0.02) then c write(6,*) "bombed ggtot test ", ggtot(k), c $ 1.-ggtot(k), dabs(1.d0-ggtot(k)), k goto 100 endif enddo if(iter .LT. 10) goto 100 C gets here if all balance GOTO 301 c end of the main loop 100 continue 301 CONTINUE c do tracers #ifdef Bells_Whistles call uranium( $ runid,idebug, $ pw_conc(1,IUO2CO3), $ sl_ml(1,IUO2), sl_gg(1,IUO2), $ z_level(KNO3), z_level(KNO3), $ rain(IUO2), $ rc(JUOX), rc(JURED), diff_array(1,1,IUO2CO3), molwt(IUO2), $ omega,db_array,irrig_array, $ z, delz, form, pore, kmax, $ pw_diff_tot(IUO2CO3), pw_react_tot(IUO2CO3), $ sl_react_tot(IUO2), burial(IUO2)) c same call for rhenium call uranium( $ runid,idebug, $ pw_conc(1,IRePW), $ sl_ml(1,IReSol), sl_gg(1,IReSol), $ z_level(KOXIC), z_level(KOXIC), $ rain(IReSol), $ rc(JUOX), rc(JURED), diff_array(1,1,IRePW), molwt(IReSol), $ omega,db_array,irrig_array, $ z, delz, form, pore, kmax, $ pw_diff_tot(IRePW), pw_react_tot(IRePW), $ sl_react_tot(IReSol), burial(IReSol)) call molybdenum( $ runid,idebug, $ pw_conc(1,IMoPW), $ sl_ml(1,IMoSol), sl_gg(1,IMoSol), $ pw_conc(1,IH2S), z_level(KOXIC), $ rc(JUOX), rc(JURED), diff_array(1,1,IMoPW), molwt(IMoSol), $ omega,db_array,irrig_array, $ z, delz, form, pore, kmax, $ pw_diff_tot(IMoPW), pw_react_tot(IMoPW), $ sl_react_tot(IMoSol), burial(IMoSol)) #endif ! Bells_Whistles c clean up ggtot do k=2,kmax ggtot(k) = 0. do isol=1,nsolidmax ggtot(k) = ggtot(k) + sl_gg(k,isol) enddo enddo do k=2,kmax do isol=1,nsolidmax sl_gg(k,isol) = sl_gg(k,isol) / ggtot(k) enddo enddo do k=2,kmax ggtot(k) = 0. do isol=1,nsolidmax ggtot(k) = ggtot(k) + sl_gg(k,isol) enddo enddo #ifdef Bells_Whistles if(idebug .GT. 2) then call profiles_bells(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) endif #endif c ta-da! if(idebug .GE. 1) then write(iunit,*) write(iunit,*) "*******************************************" write(iunit,200) "Runid", runid, "iters=", iter, $ "ggtot=", ggtot(kmax)*100. write(iunit,201) "O2","NO3","Alk","TCO2","Si", $ "z","T","S","ROC","RCl","RCa","RAr", $ "RSi", "SSi" write(iunit,202) bwchem(BWO2),bwchem(BWNO3), $ bwchem(BWAlk),bwchem(BWTCO2), $ bwchem(BWSi),bwchem(BWDepth), $ bwchem(BWTemp),bwchem(BWSal), $ (rain(IORG)+rain(IORG+1)) * 1.e6, $ (rain(isol)*1e6,isol=ICLAY,ISiO2), $ rc(JOpal)*1.e6 201 format(15A8) 202 format(7F8.0,8F8.1) endif if(idebug .GE. 2) then c .OR. iter .GE. niter) then call profiles_base(iunit,pw_conc, sl_gg, g z,omega,kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) #ifdef Bells_Whistles call profiles_bells(iunit,pw_conc, sl_gg, g z,omega,kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) #endif endif if(idebug .GE. 1) then call solid_report(iunit,pw_conc, sl_gg, $ sl_residual, sl_react_tot, $ burial, g ggtot, kmax, c rain, solidname, molwt) call porewater_report(iunit,pw_conc, sl_gg, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, burial,pw_residual, c solutename, rain, molwt ) endif return 400 continue ! Gets here if someone aborts write(iunit,201) "O2","NO3","Alk","TCO2","Si", $ "z","T","S","ROC","RCl","RCa","RAr", $ "RSi", "SSi" write(iunit,202) bwchem(BWO2),bwchem(BWNO3), $ bwchem(BWAlk),bwchem(BWTCO2), $ bwchem(BWSi),bwchem(BWDepth), $ bwchem(BWTemp),bwchem(BWSal), $ (rain(IORG)+rain(IORG+1)) * 1.e6, $ (rain(isol)*1e6,isol=ICLAY,ISiO2), $ rc(JOpal)*1.e6 call profiles_base(iunit,pw_conc, sl_gg, g z,omega,kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) return END subroutine all_clay_init( . runid,iinit,iunit,idebug, $ rc, $ pw_conc,sl_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, $ sl_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include #include c externally declared variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision bwchem(nBottomWaters) c internal variables1 c grid stuff double precision z(nzmax), delz(nzmax), $ form(nzmax), pore(nzmax), $ diff_array(nzmax,2,nsolutemax), irrig_array(nzmax), $ db_array(nzmax,nDbs) integer kz #include c solid stuff double precision omega(nzmax), ggtot(nzmax) double precision sl_ml(nzmax,nsolidmax), $ rain(nsolidmax), msrain c reaction rates and stoiciometries double precision rc(nrcmax), $ pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), burial(nsolidmax), $ sl_residual(nsolidmax), pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax) double precision pw_react_rates(nzmax,nsolutemax) double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax), z_level(nzlevels) double precision storage(Stor_N) c names and display stuff double precision omega_new(nzmax), fract logical i_bail, i_bail_mn data i_bail / .FALSE. / integer kmax, niter, runid, iinit, idebug, iunit, $ iter, k, isol, ipw, solids_iter, ifast data niter /250/ c data niter /2/ c write(6,*) o2bw, no3bw, alkbw, tco2bw, sibw, c $ rain c initialize sl_gg c if(iinit .GT. 0) then call init_base(pw_conc, sl_gg, $ bwchem, g z,delz,form, pore, kmax, g omega,ggtot, g rc, $ db_array,diff_coeff, c molwt, pw_react_rates, sl_react_rates, c sl_dreac, c sl_ml,rain,msrain,z_level) do kz=2,kmax do isol=1,nsolidmax sl_gg(kz,isol) = 0. enddo sl_gg(kz,iClay) = 1. enddo call init_update(pw_conc,sl_gg,sl_ml, $ bwchem, g z,delz,form, pore, kmax, $ diff_coeff, diff_array, $ irrig_array, $ omega, . rc, $ pw_react_rates,sl_react_rates,sl_dreac, $ db_array, $ molwt, $ rain,msrain) if(idebug .GE. 2) then c .OR. iter .GE. niter) then write(6,*) write(6,*) "Initial Condition" write(6,*) call profiles_base(iunit,pw_conc, sl_gg, g z,omega,kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) #ifdef Bells_Whistles call profiles_bells(iunit,pw_conc, sl_gg, g z,omega,kmax, c solute_scale, z_level, rc, org_consume, $ solid_scale, solidname, solutename) #endif endif return end subroutine copy_site(porewater1,porewater2, $ solidgg1,solidgg2) #include #include double precision porewater1(nzmax,nsolutemax), $ porewater2(nzmax,nsolutemax) double precision solidgg1(nzmax,nsolidmax), $ solidgg2(nzmax,nsolidmax) integer ipw,isol,iz do iz=1,nzmax do ipw=1,nsolutemax porewater2(iz,ipw) = porewater1(iz,ipw) enddo do isol=1,nsolidmax solidgg2(iz,isol) = solidgg1(iz,isol) enddo enddo return end subroutine list_mudsargs(runid,iinit,iunit,idebug, $ rc, $ porewater_conc,sl_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, $ sl_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include #include #include integer runid, iinit, idebug,iter,iunit double precision delta_t, rc(nrcmax), $ porewater_conc(nzmax,nsolutemax), $ sl_gg(nzmax,nsolidmax), $ bwchem(nBottomWaters), $ rain(nsolidmax), $ pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), omega(nzmax), burial(nsolidmax), $ sl_residual(nsolidmax), pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels), $ storage(Stor_N) double precision runidd, iinitd, iunitd,idebugd, iterd real arg_array(arg_length) integer idir,i integer ix,iy,isp delta_t = 0. runidd = runid iinitd = iinit iunitd = iunit idebugd = idebug iterd = iter do i=1,arg_length arg_array(i) = 0. enddo isp = 0 call array_copy(arg_array,isp,delta_t,1,1) ! 1 call array_copy(arg_array,isp,delta_t,1,1) ! 1 call array_copy(arg_array,isp,runidd,1,1) ! 1 call array_copy(arg_array,isp,iinitd,1,1) ! 1 call array_copy(arg_array,isp,iunitd,1,1) ! 1 call array_copy(arg_array,isp,idebugd,1,1) ! 1 call array_copy(arg_array,isp,rc,nrcmax,1) ! 38 call array_copy(arg_array,isp,bwchem,nbottomwaters,1) ! 10 call array_copy(arg_array,isp,rain,nsolidmax,1) ! 14 if(isp .NE. in_arg_length) then write(6,*) "looking for in_arg_length = ", isp stop endif write(9,'(10e15.7)') (arg_array(i), $ i=1,isp) 10 format(100e15.7) return end subroutine array_copy(arg_array,isp,sep_array,nsep,idir) #include real arg_array(arg_length) double precision sep_array(nsep) integer isp, idir, ix if(idir .GE. 1) then ! condense to a single array do ix=1,nsep arg_array(isp+1) = sep_array(ix) isp = isp + 1 enddo elseif(idir .EQ. 2) then ! initialize to zeros do ix=1,nsep arg_array(isp+1) = 0. isp = isp + 1 enddo elseif(idir .EQ. -1) then ! expand to separate arrays do ix=1,nsep sep_array(ix) = arg_array(isp+1) isp = isp + 1 enddo elseif(idir .EQ. -2) then ! initialize separate array do ix=1,nsep sep_array(ix) = 0. isp = isp + 1 enddo else write(iunit,*) "Mysterious call to array_copy" stop endif return end ray(isp+1) = 0. isp = isp + 1 enddo elseif(idir .EQ. -1) then ! expand to separate arrays do ix=1,nsep sep_array(ix) = arg_array(isp+1) isp = isp + 1 enddo elseif(idir .EQ. -2) thegrid.h000644 025374 000024 00000000521 10413036311 012427 0ustar00archeruser000000 000000 #if MUDS_NZ==18 data z /0, 0.05, 0.3, 0.7, 1.5, 2.5, 4, 6, 8.5, 12, 16, $ 21, 25, 30, 50, 75, 100, 150/ #else if MUDS_NZ==32 data z /0, .005, .01, .05, .1, .2, .3, .4, 0.5, .75, 1., . 1.5, 2., 2.5, 3., 4., . 5., 6., 7., 8., 10., 12, 14, 16, 18, $ 21, 25, 30, 50, 75, 100, 150/ #endif expand to separate arrays do ix=1,nsep sep_array(ix) = arg_array(isp+1) isp = isp + 1 enddo elseif(idir .EQ. -2) theh2s_fe_ss.F000644 025374 000024 00000205644 10413036311 013330 0ustar00archeruser000000 000000 #include #define j0_fe_resp 1 #define j0_s_resp 2 #define j0_fe2p_ox 3 #define j0_h2s_ox 4 #define j1_fes_ox 5 #define j2_fes_pcp 6 #define xads_src 7 #define fe_org 8 #define s_org 10 #define NReacts 11 #define FeReactionsON #define H2S_Fe_ON c #define StdOut subroutine h2s_fe_pwss( $ runid,idebug,i_pw_only, $ pw_conc, $ sl_ml, sl_gg, $ rc, $ z,delz,form,pore,kmax, $ z_level, $ rain_fe2o3_external, $ omega,db_array, $ diff_array, $ irrig_array, $ irrig_oxidation, $ pw_react_tot, pw_diff_tot, $ sl_react_tot,sl_burial_tot, $ fe2p_zoxic, h2s_zoxic, $ rct) implicit none #include #include #include #include #include #include #define L_Fe 1 #define L_SO 2 #define L_HS 3 #define L_FO 4 #define L_FS 5 integer kmax,runid, idebug, i_pw_only c external variables double precision pw_conc(nzmax,nsolutemax) double precision sl_ml(nzmax,nsolidmax), $ sl_gg(nzmax,nsolidmax) double precision rc(nrcmax) double precision z(kmax), delz(kmax), $ form(kmax), pore(kmax) double precision z_level(nzlevels) double precision $ rain_fe2o3_external,rain_fe2o3, $ omega(nzmax),db_array(nzmax,nDbs) double precision diff_array(nzmax,2,nsolutemax), $ irrig_array(nzmax) double precision $ irrig_oxidation(nzmax) double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), sl_burial_tot(nsolidmax) c internal variables double precision dmin(nzmax,5),dpls(nzmax,5) double precision x(nzmax,5) double precision r(nzmax,5),dr(nzmax,5,5,3), $ a(nzmax*5,nzmax*5),b(nzmax*5) double precision rc_scale, $ weight(5) double precision fe2p_scale, h2s_scale, $ fe2p_zoxic, h2s_zoxic, $ fe2p_oxic(nzmax), h2s_oxic(nzmax), $ tot_fe_source, tot_fe_sink, $ tot_hs_source, tot_hs_sink double precision rct(nzmax,NReacts) ! 2x resp, 3x ox, fes pcp, 4x org c double precision gain, dsat(nzmax), offset, ! cutoff, c $ constant_0, constant_1, constant_2(nzmax), double precision drdf(nzmax),drds(nzmax) double precision ztop, zbot, ztops, zbots, z_so4_last #ifdef FeAdsorptionON double precision sites_tot(nzmax), xads(nzmax), dxdfe(nzmax), $ dxdfo(nzmax), diff_enhance, xads_src_tot #endif double precision $ dr2(nzmax),resp_fe_source, resp_s_source, $ fes_sink, irrig_fe_sink, irrig_s_sink, $ diff_oxic_fe_sink, $ diff_oxic_s_sink,ox_fe_sink, diffescape_fe_sink, $ fe_conserve, $ fe_balance, $ burial_fe, $ d_irrig_fe_sink,tot_reducing(nzmax) integer kz, ix, iy, iz, ioc, row_index, col_index, $ zfe2o3_iter, zso4_iter, rain_iter, $ zfe2o3_init_trials, zfe2o3_step_trials, $ n_zfe2o3_iterations, n_zso4_iterations, n_rain_iterations, $ i_oxic_concentration, n_oxic_concentrations, $ n_zfe2o3_kick_interval,negflag(nzmax,5), $ any_negflag,limited_so4 double precision fe_resolve c save fe2p_zoxic, h2s_zoxic, fe2p_scale, h2s_scale #ifdef StdOut c write(6,101) "rain","zfe2o3","rain","diff","%", c $ "zbot","ztop","z_fe2o3","fe2o3z" write(6,*) "Entering H2S_Fe_ss" write(6,101) "izfeo","ife2","zbot","ztop", $ "z_fe2o3","fe_balance","fe2ox", "feooh(z)" 101 format(2a6,10a15) #endif if(idebug .EQ. -999) then return endif zfe2o3_init_trials = 3 zfe2o3_step_trials = 1 n_zfe2o3_iterations = 20 n_zfe2o3_kick_interval = 20 n_zso4_iterations = 10 n_oxic_concentrations = 30 fe_resolve = 1.e-2 #ifdef WaterColumnRecycle n_rain_iterations = 1 #endif pw_react_tot(IFE2P) = 0. pw_react_tot(ISO4) = 0. pw_react_tot(IH2S) = 0. pw_diff_tot(IFE2P) = 0. pw_diff_tot(IH2S) = 0. pw_diff_tot(ISO4) = 0. c z_level(KFE) = z(kmax) c z_level(KFE) = z_level(KFE) + 5. if( rain_fe2o3_external .LT. 1.e-20) then z_level(KFE) = 0. endif ztop = z_level(KNO3) zbot = z(kmax) ztops = z_level(KNO3) zbots = z(kmax) limited_so4 = 0 z_so4_last = z_level(KSO4) z_level(KSO4) = zbots rain_fe2o3 = rain_fe2o3_external #ifdef WaterColumnRecycle c do rain_iter = 1, n_rain_iterations #endif do zso4_iter = 1, n_zso4_iterations fe2p_zoxic = 0. h2s_zoxic = 0. do zfe2o3_iter = 1, n_zfe2o3_iterations fe2p_scale = sqrt(diff_array(1,1,IFE2P) $ /(rc(JFEOX)+1.e-20)) h2s_scale = sqrt(diff_array(1,1,IH2S) $ /(rc(JHSOX)+1.e-20)) do i_oxic_concentration = 1, n_oxic_concentrations do kz=2,kmax rct(kz,j2_fes_pcp) = 0. do ix=1,5 r(kz,ix) = 0 do iy=1,5 do iz=1,3 dr(kz,ix,iy,iz) = 0 enddo enddo enddo enddo ! kz do kz=1,nzmax*5 do iz=1,nzmax*5 a(kz,iz) = 0. enddo b(kz) = 0 enddo do kz=1,kmax x(kz,L_Fe) = pw_conc(kz,IFE2P) x(kz,L_SO) = pw_conc(kz,ISO4) x(kz,L_HS) = pw_conc(kz,IH2S) x(kz,L_FO) = sl_gg(kz,IFeOOH) x(kz,L_FS) = sl_gg(kz,IFES) enddo do kz=1,kmax do ix=1,5 x(kz,ix) = MAX(0.,x(kz,ix)) enddo enddo do kz=1,kmax dpls(kz,L_Fe) = diff_array(kz,1,IFE2P) dmin(kz,L_Fe) = diff_array(kz,2,IFE2P) dpls(kz,L_SO) = diff_array(kz,1,ISO4) dmin(kz,L_SO) = diff_array(kz,2,ISO4) dpls(kz,L_HS) = diff_array(kz,1,IH2S) dmin(kz,L_HS) = diff_array(kz,2,IH2S) do ix=L_FO,L_FS dpls(kz,ix) = db_array(kz,DbPlsS) dmin(kz,ix) = db_array(kz,DbMinS) enddo enddo #ifdef FeReactionsON cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Compute Reaction Rates c-------------------------------------- call fe_rates( $ fe2p_oxic, h2s_oxic, rct, $ drdf,drds, $ fe2p_zoxic, h2s_zoxic, $ fe2p_scale, h2s_scale, $ z_level, rc, $ sl_ml,x, $ z,delz,form,pore,kmax) resp_fe_source = 0. resp_s_source = 0. fes_sink = 0. irrig_fe_sink = 0. do kz=2,kmax resp_fe_source = resp_fe_source $ + rct(kz,j0_fe_resp) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr resp_s_source = resp_s_source $ + rct(kz,j0_s_resp) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr fes_sink = fes_sink $ + rct(kz,j2_fes_pcp) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr enddo call irrig_flux(x(1,L_Fe), $ irrig_array, $ pore,delz,kmax, $ irrig_fe_sink) call irrig_flux(x(1,L_HS), $ irrig_array, $ pore,delz,kmax, $ irrig_s_sink) c weight(1) = 1. c diff_oxic_fe_sink = diff_oxic_fe_sink * (1.-weight(1)) c $ + weight(1) * diff_oxic_fe_sink = $ ( resp_fe_source $ - fes_sink $ - irrig_fe_sink $ ) if(diff_oxic_fe_sink .LT. 0) then c write(6,*) "hello" diff_oxic_fe_sink = 0. endif diff_oxic_s_sink = $ MAX(0., $ resp_s_source $ - fes_sink $ - irrig_s_sink $ ) c write(6,*) "h2s 310", diff_array(1,1,iFe2p), c $ rc(JFEOX), fe2p_scale fe2p_scale = sqrt(diff_array(1,1,IFE2P) $ /(rc(JFEOX)+1.e-20)) h2s_scale = sqrt(diff_array(1,1,IH2S) $ /(rc(JHSOX)+1.e-20)) #ifdef FeOx c write(6,*) "h2s 320", rc(jfeox), fe2p_zoxic, rc fe2p_zoxic = diff_oxic_fe_sink $ / 3.15e7 $ / fe2p_scale $ / rc(JFEOX) $ * 1000. #endif #ifdef HSOx h2s_zoxic = diff_oxic_s_sink $ / 3.15e7 $ / h2s_scale $ / rc(JFEOX) $ * 1000. #endif c new rates, including oxidation rates call fe_rates( $ fe2p_oxic, h2s_oxic, $ rct, $ drdf,drds, $ fe2p_zoxic, h2s_zoxic, $ fe2p_scale, h2s_scale, $ z_level, rc, $ sl_ml,x, $ z,delz,form,pore,kmax) c compute diffusive escape ox_fe_sink = 0. do kz=2,kmax ox_fe_sink = ox_fe_sink $ + rct(kz,j0_fe2p_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo diffescape_fe_sink = $ resp_fe_source $ - ox_fe_sink $ - fes_sink $ - irrig_fe_sink fe_conserve = $ resp_fe_source $ - ox_fe_sink $ - fes_sink $ - diffescape_fe_sink $ - irrig_fe_sink cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Adjust oxidation rates for irrigation and redeposition c oxidation of Fe2+ by irrigated oxidizing capacity #ifdef FeIrrigOxidation c #define FeIrrigOxStdout #ifdef FeIrrigOxStdout write(6,*) "iron conservation befor irrigox", fe_conserve #endif d_irrig_fe_sink = 0. do kz=2,kmax tot_reducing(kz) = $ irrig_array(kz) * x(kz,L_Fe) * 1. $ + irrig_array(kz) * x(kz,L_HS) * 8. #ifdef MnIrrigOxidation $ + irrig_array(kz) * pw_conc(kz,IMn2p) * 2. #endif if(irrig_oxidation(kz) .GT. 0 $ .AND. $ fe2p_oxic(kz) .LT. 0) then if(irrig_oxidation(kz) $ .GT. tot_reducing(kz)) then rct(kz,j0_fe2p_ox) = rct(kz,j0_fe2p_ox) $ + irrig_array(kz) * x(kz,L_Fe) $ * pore(kz) rct(kz,j0_h2s_ox) = rct(kz,j0_h2s_ox) $ + irrig_array(kz) * x(kz,L_HS) $ * pore(kz) d_irrig_fe_sink = d_irrig_fe_sink $ + irrig_array(kz) $ * x(kz,L_Fe) $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr else ! flux of reducing > flux of oxidizing rct(kz,j0_fe2p_ox) = rct(kz,j0_fe2p_ox) $ + irrig_array(kz) * x(kz,L_Fe) $ * pore(kz) $ * irrig_oxidation(kz) / tot_reducing(kz) rct(kz,j0_h2s_ox) = rct(kz,j0_h2s_ox) $ + irrig_array(kz) * x(kz,L_HS) $ * pore(kz) $ * irrig_oxidation(kz) / tot_reducing(kz) d_irrig_fe_sink = d_irrig_fe_sink $ + irrig_array(kz) * x(kz,L_Fe) $ * irrig_oxidation(kz) / tot_reducing(kz) $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr endif endif enddo ! kz irrig_fe_sink = irrig_fe_sink $ - d_irrig_fe_sink #ifdef FeIrrigOxStdout write(6,*) "irrig_fe_sink now", irrig_fe_sink c retotal oxidation rates ox_fe_sink = 0. do kz=2,kmax ox_fe_sink = ox_fe_sink $ + rct(kz,j0_fe2p_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo fe_conserve = $ resp_fe_source $ - ox_fe_sink $ - fes_sink $ - diffescape_fe_sink $ - irrig_fe_sink write(6,*) "iron conservation after irrigox", fe_conserve #endif #endif ! FeIrrigOxidation c redeposition #ifdef FeRedepositIrrig c do kz=2,kmax c j0_fe2p_ox(2) = j0_fe2p_ox(2) c $ + irrig_array(kz) * x(kz,L_Fe) c $ * pore(kz) c $ * delz(kz) / delz(2) c $ * rc(JFeIR) ! units mol/l tot sec c dr2(kz) = c $ irrig_array(kz) c $ * pore(kz) c $ * delz(kz) / delz(2) c $ * 3.15e7 c $ * molwt(IFe2p)/(2.5*(1-pore(2))*1000) c $ * rc(JFeIR) c enddo rct(2,j0_fe2p_ox) = rct(2,j0_fe2p_ox) $ + irrig_fe_sink * rc(JFeIR) $ / 3.15e7 * 1000. $ / delz(2) irrig_fe_sink = irrig_fe_sink $ * (1.-rc(JFeIR)) #endif #ifdef FeRedepositDiffusion j0_fe2p_ox(2) = j0_fe2p_ox(2) $ + diffescape_fe_sink $ * rc(JFeDR) $ / delz(2) * 1000. / 3.15E7 diffescape_fe_sink = diffescape_fe_sink $ * (1.-rc(JFeDR)) #endif c retotal oxidation rates ox_fe_sink = 0. do kz=2,kmax ox_fe_sink = ox_fe_sink $ + rct(kz,j0_fe2p_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo fe_conserve = $ resp_fe_source $ - ox_fe_sink $ - fes_sink $ - diffescape_fe_sink $ - irrig_fe_sink c #define FeRedepositStdOut #ifdef FeRedepositStdOut write(6,*) "iron conservation after redeposit", $ fe_conserve #endif #else ! FeReactionsON diffescape_fe_sink = 0. irrig_fe_sink = 0. #endif ! FeReactionsON c end of reaction rate computation c transport operators -- diffusion do kz=2,kmax ! all cells 2:N get upward diffusion do ix=L_Fe,5 r(kz,ix) = r(kz,ix) $ - dmin(kz,ix) * (x(kz,ix)-x(kz-1,ix)) dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - dmin(kz,ix) dr(kz,ix,ix,1) = dr(kz,ix,ix,1) $ + dmin(kz,ix) enddo enddo do kz=2,kmax-1 ! exclude cell N for downward diffusion do ix=L_Fe,5 r(kz,ix) = r(kz,ix) $ + dpls(kz,ix) * (x(kz+1,ix)-x(kz,ix)) dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - dpls(kz,ix) ! dRi/dxi(n) dr(kz,ix,ix,3) = dr(kz,ix,ix,3) $ + dpls(kz,ix) ! dRi/dxi(n+1) enddo enddo c -- irrigation do kz=2,kmax r(kz,L_Fe) = r(kz,L_Fe) $ - irrig_array(kz) * x(kz,L_Fe) dr(kz,L_Fe,L_Fe,2) = dr(kz,L_Fe,L_Fe,2) $ - irrig_array(kz) r(kz,L_HS) = r(kz,L_HS) $ - irrig_array(kz) * x(kz,L_HS) dr(kz,L_HS,L_HS,2) = dr(kz,L_HS,L_HS,2) $ - irrig_array(kz) r(kz,L_SO) = r(kz,L_SO) $ + irrig_array(kz) $ * ( x(1,L_SO) - x(kz,L_SO) ) dr(kz,L_SO,L_SO,2) = dr(kz,L_SO,L_SO,2) $ - irrig_array(kz) enddo c -- omega (solid advection) do kz=3,kmax do ix=4,5 r(kz,ix) = r(kz,ix) $ + x(kz-1,ix) $ * omega(kz-1) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 $ - x(kz,ix) $ * omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 dr(kz,ix,ix,1) = dr(kz,ix,ix,1) $ + omega(kz-1) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 enddo enddo kz = 2 do ix=4,5 r(kz,ix) = r(kz,ix) $ - x(kz,ix) $ * omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 enddo ix=4 ! solid rain r(kz,ix) = r(kz,ix) $ + rain_fe2o3 * molwt(IFEOOH) . / delz(2) . / ( 1 - pore(2) ) . / 2.5 #ifdef FeAdsorptionON c #define FeAdsorbUniformSites c adsorption for Fe2+ do kz=2,kmax ! setup #ifdef FeAdsorbUniformSites sites_tot(kz) = 0.7 * (1-pore(kz)) #else sites_tot(kz) = ( $ ( x(kz,L_FO) ! g/g $ + sl_gg(kz,IClay) * 4.7E-2 * 0.7 $ ) $ * 11.e-3 ! mol/l sites $ + ( sl_gg(kz,IMnO2) $ + sl_gg(kz,IClay) * 8.5E-4 * 0.5 $ ) $ * 27.e-3 $ ) $ * 2.5 * (1-pore(kz)) * 1000. ! g/l tot Fe3+ #endif xads(kz) = rc(JFeAds) * x(kz,L_Fe) * sites_tot(kz) $ / ( $ 1. $ + rc(JFeAds)*x(kz,L_Fe) $ + rc(JFeAds)*pw_conc(kz,IMn2P) $ ) dxdfe(kz) = sites_tot(kz) * rc(JFeAds) $ * ( 1 + rc(JFeAds)*pw_conc(kz,IMn2P) ) $ / ( $ 1. $ + rc(JFeAds)*x(kz,L_Fe) $ + rc(JFeAds)*pw_conc(kz,IMn2P) $ )**2 #ifdef FeAdsorbUniformSites dxdfo(kz) = 0. #else dxdfo(kz) = rc(JFeAds) * x(kz,L_Fe) $ * 2.5 * (1-pore(kz)) * 1000. $ * 11.e-3 ! mol/l sites $ / ( $ 1. $ + rc(JFeAds)*x(kz,L_Fe) $ + rc(JFeAds)*pw_conc(kz,IMn2P) $ ) #endif dxdfo(kz) = 0. rct(kz,xads_src) = 0. if(fe2p_oxic(kz) .GE. 0.) then diff_enhance = db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ / diff_array(kz,2,IFe2p) ! ratio of diffusivities solid/solute $ * xads(kz) / (x(kz,L_Fe) + 1.e-20) else diff_enhance = 0. endif enddo fe2p_scale = sqrt(diff_array(1,1,IFe2p) c $ * (1.+diff_enhance) $ / (rc(JFeOx)+1.e-20) ) #ifdef StdOut2 write(6,99) "fe2p_scale ", diff_enhance, fe2p_scale, $ fe2p_zoxic 99 format(a10,3g12.2) #endif #ifdef FeAdsorbMixing do kz=3,kmax ! cells 3:N get upward diffusion c if(fe2p_oxic(kz) .LT. 0.) then r(kz,L_Fe) = r(kz,L_Fe) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * ( xads(kz) - xads(kz-1) ) $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * ( xads(kz) - xads(kz-1) ) dr(kz,L_Fe,L_Fe,2) = dr(kz,L_Fe,L_Fe,2) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfe(kz) ) dr(kz,L_Fe,L_Fe,1) = dr(kz,L_Fe,L_Fe,1) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfe(kz-1) ) dr(kz,L_Fe,L_FO,2) = dr(kz,L_Fe,L_FO,2) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfo(kz) ) dr(kz,L_Fe,L_FO,1) = dr(kz,L_Fe,L_FO,1) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfo(kz-1) ) c endif enddo do kz=2,kmax-1 ! diffusion downward c if(fe2p_oxic(kz) .LT. 0.) then r(kz,L_Fe) = r(kz,L_Fe) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( xads(kz+1) - xads(kz) ) rct(kz,xads_src) = rct(kz,xads_src) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * ( xads(kz+1) - xads(kz) ) dr(kz,L_Fe,L_Fe,2) = dr(kz,L_Fe,L_Fe,2) $ - db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfe(kz) ) dr(kz,L_Fe,L_Fe,3) = dr(kz,L_Fe,L_Fe,3) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfe(kz+1) ) dr(kz,L_Fe,L_FO,2) = dr(kz,L_Fe,L_FO,2) $ - db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfo(kz) ) dr(kz,L_Fe,L_FO,1) = dr(kz,L_Fe,L_FO,1) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdfo(kz+1) ) c endif enddo #endif #ifdef FeAdsorbBurial c burial flux of adsorbed Fe2+ do kz=3,kmax if(fe2p_oxic(kz) .LT. 0) then r(kz,L_Fe) = r(kz,L_Fe) ! incoming stuff $ + xads(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) $ + xads(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 dr(kz,L_Fe,L_Fe,1) = dr(kz,L_Fe,L_Fe,1) $ + dxdfe(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) dr(kz,L_Fe,L_FO,1) = dr(kz,L_Fe,L_FO,1) $ + dxdfo(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) endif enddo do kz=2,kmax if(fe2p_oxic(kz) .LT. 0) then r(kz,L_Fe) = r(kz,L_Fe) ! outgoing stuff $ - xads(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) $ - xads(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 dr(kz,L_Fe,L_Fe,2) = dr(kz,L_Fe,L_Fe,2) $ - dxdfe(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) dr(kz,L_Fe,L_FO,2) = dr(kz,L_Fe,L_FO,2) $ - dxdfo(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) endif enddo #endif #endif #ifdef FeReactionsON do kz=2, kmax c respiration r(kz,L_Fe) = r(kz,L_Fe) + rct(kz,j0_fe_resp) $ / pore(kz) r(kz,L_FO) = r(kz,L_FO) - rct(kz,j0_fe_resp) $ * 3.15e7 $ * molwt(IFeOOH)/(2.5*(1-pore(kz))*1000) r(kz,L_HS) = r(kz,L_HS) + rct(kz,j0_s_resp) $ / pore(kz) r(kz,L_SO) = r(kz,L_SO) - rct(kz,j0_s_resp) $ / pore(kz) c fe2+ oxidation c done implicitly by the fe2p_oxic scheme c r(kz,L_Fe) = r(kz,L_Fe) c $ - rct(kz,j0_fe2p_ox) c dr(kz,L_Fe,L_Fe,2) = dr(kz,L_Fe,L_Fe,2) r(kz,L_FO) = r(kz,L_FO) $ + rct(kz,j0_fe2p_ox) $ * 3.15e7 $ * molwt(IFeOOH)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_FO,L_Fe,2) = dr(kz,L_FO,L_Fe,2) c fes oxidation r(kz,L_FO) = r(kz,L_FO) $ + rct(kz,j1_fes_ox) * x(kz,L_FS) $ * 3.15e7 $ * molwt(IFeOOH)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_FO,L_FS,2) = dr(kz,L_FO,L_FS,2) $ + rct(kz,j1_fes_ox) $ * 3.15e7 $ * molwt(IFeOOH)/(2.5*(1-pore(kz))*1000) ! ml to gg r(kz,L_FS) = r(kz,L_FS) - rct(kz,j1_fes_ox) $ * x(kz,L_FS) $ * 3.15e7 $ * molwt(IFeS)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_FS,L_FS,2) = dr(kz,L_FS,L_FS,2) $ - rct(kz,j1_fes_ox) $ * 3.15e7 $ * molwt(IFeS)/(2.5*(1-pore(kz))*1000) ! ml to gg c h2s oxidation implicit in the h2s_oxic() scheme c r(kz,L_HS) = r(kz,L_HS) c $ - rct(kz,j0_h2s_ox) c FeS precipitation c Fe2p r(kz,L_Fe) = r(kz,L_Fe) - rct(kz,j2_fes_pcp) $ / pore(kz) dr(kz,L_Fe,L_Fe,2) = dr(kz,L_Fe,L_Fe,2) - drdf(kz) $ / pore(kz) dr(kz,L_Fe,L_HS,2) = dr(kz,L_Fe,L_HS,2) - drds(kz) $ / pore(kz) c HS- r(kz,L_HS) = r(kz,L_HS) - rct(kz,j2_fes_pcp) $ / pore(kz) dr(kz,L_HS,L_Fe,2) = dr(kz,L_HS,L_Fe,2) - drdf(kz) $ / pore(kz) dr(kz,L_HS,L_HS,2) = dr(kz,L_HS,L_HS,2) - drds(kz) $ / pore(kz) c fes r(kz,L_FS) = r(kz,L_FS) + rct(kz,j2_fes_pcp) $ * 3.15e7 $ * molwt(IFeS)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_FS,L_Fe,2) = dr(kz,L_FS,L_Fe,2) + drdf(kz) $ * 3.15e7 $ * molwt(IFeS)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_FS,L_HS,2) = dr(kz,L_FS,L_HS,2) + drds(kz) $ * 3.15e7 $ * molwt(IFeS)/(2.5*(1-pore(kz))*1000) ! ml to gg enddo c relax to specified exponential concentrations do kz=2,kmax if(fe2p_oxic(kz) .GT. 0.) then c cell center is oxic -- toss lots of complicated stuff out the window c relax to the assumed exponential profile r(kz,L_Fe) = x(kz,L_Fe) - fe2p_oxic(kz) r(kz,L_HS) = x(kz,L_HS) - h2s_oxic(kz) c dont care about other species do ix=1,5 dr(kz,L_Fe,ix,2) = 0. dr(kz,L_HS,ix,2) = 0. enddo c or diffusion up and down dr(kz,L_Fe,L_Fe,1) = 0. dr(kz,L_Fe,L_Fe,3) = 0. dr(kz,L_HS,L_HS,1) = 0. dr(kz,L_HS,L_HS,3) = 0. c d/dconc = 1. dr(kz,L_Fe,L_Fe,2) = 1. dr(kz,L_HS,L_HS,2) = 1. endif enddo #endif if(i_pw_only .EQ. 1) then c load arrays do ix = L_Fe, L_HS do kz = 2, kmax row_index = (kz-1) + (ix-1) * (kmax-1) c residuals b(row_index) = -r(kz,ix) c local derivatives (same box, all species) do iy=L_Fe,L_HS col_index = (kz-1) + (iy-1) * (kmax-1) a(row_index,col_index) = $ a(row_index,col_index) $ + dr(kz,ix,iy,2) enddo enddo c vertical derivates (same species) do kz=3,kmax-1 row_index = (kz-1) + (ix-1) * (kmax-1) do iz=1,3,2 col_index = row_index + iz - 2 a(row_index,col_index) = $ a(row_index,col_index) $ + dr(kz,ix,ix,iz) enddo enddo kz=2 row_index = (kz-1) + (ix-1) * (kmax-1) iz=3 col_index = row_index + iz - 2 a(row_index,col_index) = a(row_index,col_index) $ + dr(kz,ix,ix,iz) kz=kmax row_index = (kz-1) + (ix-1) * (kmax-1) iz=1 col_index = row_index + iz - 2 a(row_index,col_index) = a(row_index,col_index) $ + dr(kz,ix,ix,iz) enddo call gaussj(runid,idebug, $ a,(kmax-1)*3,nzmax*5,b,1,1) if(idebug .EQ. -999) then return endif do ix=1,3 weight(ix) = .1 enddo any_negflag = 0 do kz = 2, kmax do ix = 1, 3 row_index = (ix-1)*(kmax-1)+(kz-1) if(x(kz,ix) + b(row_index) .GE. 0) then x(kz,ix) = x(kz,ix) + b(row_index) $ * weight(ix) negflag(kz,ix) = 0 else x(kz,ix) = 0.1 * x(kz,ix) negflag(kz,ix) = 1 any_negflag = 1 endif c if(ix .EQ. L_Fe .OR. ix .EQ. L_HS c $ .OR. ix .EQ. L_FS) then c x(kz,ix) = c $ MAX( c $ x(kz,ix) + c $ weight(ix) * b(row_index), c $ x(kz,ix) * 0.001 c $ ) c else c x(kz,ix) = x(kz,ix) + b(row_index) c endif enddo enddo kz = 2 do kz=2,kmax pw_conc(kz,IFE2P) = x(kz,1) if(z(kz-1) .LE. z_level(KSO4)) then pw_conc(kz,ISO4) = x(kz,2) else pw_conc(kz,ISO4) = 0. endif pw_conc(kz,IH2S) = x(kz,3) enddo else ! i_pw_only=0 i.e. do solids too c load arrays do ix = L_Fe, L_FS do kz = 2, kmax row_index = (kz-1) + (ix-1) * (kmax-1) c residuals b(row_index) = -r(kz,ix) c local derivatives (same box, all species) do iy=L_Fe,L_FS col_index = (kz-1) + (iy-1) * (kmax-1) a(row_index,col_index) = $ a(row_index,col_index) $ + dr(kz,ix,iy,2) enddo enddo c vertical derivates (same species) do kz=3,kmax-1 row_index = (kz-1) + (ix-1) * (kmax-1) do iz=1,3,2 col_index = row_index + iz - 2 a(row_index,col_index) = $ a(row_index,col_index) $ + dr(kz,ix,ix,iz) enddo enddo kz=2 row_index = (kz-1) + (ix-1) * (kmax-1) iz=3 col_index = row_index + iz - 2 a(row_index,col_index) = a(row_index,col_index) $ + dr(kz,ix,ix,iz) kz=kmax row_index = (kz-1) + (ix-1) * (kmax-1) iz=1 col_index = row_index + iz - 2 a(row_index,col_index) = a(row_index,col_index) $ + dr(kz,ix,ix,iz) enddo #ifdef FeRedepositIrrigDR2 do kz=2,kmax row_index = (2-1) + (L_FO-1) * (kmax-1) col_index = (kz-1) + (L_Fe-1) * (kmax-1) a(row_index,col_index) = a(row_index,col_index) $ + dr2(kz) enddo #endif call gaussj(runid,idebug, $ a,(kmax-1)*5,nzmax*5,b,1,1) if(idebug .EQ. -999) then return endif do ix=1,5 weight(ix) = .1 enddo any_negflag = 0 do kz = 2, kmax do ix = 1, 5 row_index = (ix-1)*(kmax-1)+(kz-1) if(x(kz,ix) + b(row_index) .GE. 0) then x(kz,ix) = x(kz,ix) + b(row_index) $ * weight(ix) negflag(kz,ix) = 0 else x(kz,ix) = 0.1 * x(kz,ix) negflag(kz,ix) = 1 any_negflag = 1 endif c if(ix .EQ. L_Fe .OR. ix .EQ. L_HS c $ .OR. ix .EQ. L_FS) then c x(kz,ix) = c $ MAX( c $ x(kz,ix) + c $ weight(ix) * b(row_index), c $ x(kz,ix) * 0.001 c $ ) c else c x(kz,ix) = x(kz,ix) + b(row_index) c endif enddo enddo kz = 2 do kz=2,kmax pw_conc(kz,IFE2P) = x(kz,1) if(z(kz-1) .LE. z_level(KSO4)) then pw_conc(kz,ISO4) = x(kz,2) else pw_conc(kz,ISO4) = 0. endif pw_conc(kz,IH2S) = x(kz,3) if(z(kz-1) .LE. z_level(KFe)) then sl_gg(kz,IFEOOH) = x(kz,L_FO) else sl_gg(kz,IFEOOH) = 0. endif sl_gg(kz,IFES) = x(kz,5) enddo buriaL_Fe = omega(kmax) $ * x(kmax,L_FS) $ / molwt(IFeS) if(z_level(KFe) .GT. z(kmax) - 1.) then buriaL_Fe = buriaL_Fe $ + omega(kmax) $ * x(kmax,L_FO) $ / molwt(IFeOOH) endif #ifdef FeAdsorptionBurial buriaL_Fe = buriaL_Fe $ + omega(kmax) $ * xads(kmax) $ / 2.5 / (1-pore(kmax)) / 1000. #endif if(rain_fe2o3_external .LT. 1.e-20) then fe_balance = 0 else fe_balance = ( rain_fe2o3_external $ - diffescape_fe_sink $ - irrig_fe_sink $ - buriaL_Fe $ ) / rain_fe2o3_external endif c call irrig_flux(x(1,L_Fe), c $ irrig_array, c $ pore,delz,kmax, c $ irrig_fe_sink c #ifdef FeRedepositIrrig c irrig_fe_sink = irrig_fe_sink c $ * (1.-rc(JFeIR)) c #endif #ifdef StdOut pw_diff_tot(IFe2p) = diffescape_fe_sink write(6,100) zfe2o3_iter, i_oxic_concentration, $ zbot,ztop,z_level(KFE), $ fe_balance, $ fe2p_zoxic * 1.e9, $ buriaL_Fe 100 format(2i6,3f15.5,g15.5,2g15.5) #endif endif ! i_pw_only enddo ! i_oxic_concentration #ifdef StdOut c write(6,*) "done with oxic conc loop" #endif if(i_pw_only .EQ. 1) then goto 10 else c testing for ejection from zfe2o3 iteration cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if( zfe2o3_iter .LT. zfe2o3_init_trials ) then #ifdef StdOut write(6,*) "warming up" #endif goto 20 ! does another loop without changing z_level(KFE) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc elseif( zfe2o3_iter .EQ. zfe2o3_init_trials ) then if(rain_fe2o3_external .LT. 1.e-20) then goto 10 endif if(z_level(KFE) .EQ. z(kmax)) then if(negflag(kmax,L_FO) .EQ. 0 $ .AND. $ ABS(fe_balance) .LT. fe_resolve) then #ifdef StdOut write(6,*) "Fully Ironed. Exiting" #endif goto 10 ! iron unlimited else ! try shallower zbot = z(kmax) ztop = z_level(KNO3) endif else ! z_level(KFE) started out less than z(kmax) if(ABS(fe_balance) .LT. fe_resolve ! same value from before still works $ .AND. negflag(kmax,L_FO) .EQ. 0) then #ifdef StdOut write(6,*) "Last z_level(KFE) OK. Exiting" #endif goto 10 ! exit subroutine elseif( fe_balance .LT. 0) then ! set the limits for the search #ifdef StdOut write(6,*) "initial z_level(KFE) too deep" #endif ztop = z_level(KNO3) zbot = z_level(KFE) #ifdef StdOut write(6,*) "looking between ", ztop, zbot #endif else #ifdef StdOut write(6,*) "initial z_level(KFE) too shallow" #endif ztop = z_level(KFE) zbot = z(kmax) #ifdef StdOut write(6,*) "looking between ", ztop, zbot #endif endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else ! greater than zfe2o3_init_trials if(ABS(fe_balance) .LT. fe_resolve) then #ifdef StdOut write(6,*) "Found OK z_level(KFE)", $ zfe2o3_iter, z_level(KFE) #endif goto 10 ! leaving the building endif if(MOD(zfe2o3_iter,n_zfe2o3_kick_interval) .EQ. 0 $ .AND. zfe2o3_iter .LT. n_zfe2o3_iterations) then #ifdef StdOut write(6,*) "Kick me" #endif if(fe_balance .LT. 0) then ztop = z_level(KNO3) else zbot = z(kmax) endif elseif(zfe2o3_iter .GT. zfe2o3_init_trials .AND. $ MOD( zfe2o3_iter - zfe2o3_init_trials, $ zfe2o3_step_trials $ ) .EQ. 0) then c if(fe2p_zoxic .LT. 1.e-20) then c write(6,*) "fe2p_zoxic conc ", fe2p_zoxic c endif if(fe_balance .LT. 0) then zbot = z_level(KFE) else ztop = z_level(KFE) endif #ifdef StdOut write(6,*) "trying z_level(KFE) = ", z_level(KFE) #endif endif endif z_level(KFE) = ( ztop + zbot ) / 2 do kz=2,kmax x(kz,L_Fe) = 0. enddo 20 continue ! lands here to avoid resetting z_level(KFE) endif enddo ! zfe2o3_iter 10 continue ! lands here to escape the loop #ifdef StdOut write(6,*) "done with zfe2o3 loop" #endif if(limited_so4 .EQ. 0) then if(negflag(kmax,L_SO) .EQ. 1) then limited_so4 = 1 #ifdef StdOut write(6,*) "found a negative so4, boss" #endif else goto 30 endif else if(negflag(kmax,L_SO) .EQ. 1) then zbots = z_level(KSO4) else ztops = z_level(KSO4) endif endif if(zso4_iter .LT. n_zso4_iterations) then z_level(KSO4) = (ztops + zbots) / 2 else ! last time through, impose time-smoothed depth c prevents oscillations with orgc weight(1) = 0.05 write(6,*) "z_so4_last was", z_so4_last, z_level(KSO4) z_level(KSO4) = weight(1) * z_level(KSO4) $ + (1-weight(1)) * z_so4_last endif #ifdef StdOut write(6,*) "next so4 iteration = ", z_level(KSO4) #endif enddo ! zso4_iter 30 continue ! escape zso4_iter call sldcon(sl_gg(1,IFEOOH),sl_ml(1,IFEOOH), $ molwt(IFEOOH),pore,kmax) call sldcon(sl_gg(1,IFES),sl_ml(1,IFES), $ molwt(IFES),pore,kmax) do kz=2,kmax rct(kz,j1_fes_ox) = rct(kz,j1_fes_ox) $ * x(kz,L_FS) #ifdef FeIrrigOxidation if(irrig_oxidation(kz) .GT. 0) then if(irrig_oxidation(kz) .GT. tot_reducing(kz)) then c uses up all of the Fe, HS fluxes, with irrig_oxidation left over irrig_oxidation(kz) = irrig_oxidation(kz) $ - irrig_array(kz) $ * (pw_conc(kz,IFe2p)+pw_conc(kz,IH2S)*8) else ! irrig_oxidation will be all used up by Fe, HS fluxes irrig_oxidation(kz) = irrig_oxidation(kz) $ * ( tot_reducing(kz) $ - irrig_array(kz) $ * (pw_conc(kz,IFe2p)+pw_conc(kz,IH2S)*8) $ ) $ / tot_reducing(kz) c irrig_oxidation(kz) = 0. endif endif if(irrig_oxidation(kz) .LT. 0) then c write(6,*) "irrig_oxidation < 0 in h2s_fe" irrig_oxidation(kz) = 0 endif #endif ! H2S_Fe_ON enddo ! kz call diffusive_flux(pw_conc(1,ISO4), $ diff_array(1,1,ISO4), $ form,pore,delz,kmax, $ pw_diff_tot(ISO4)) call diffusive_flux(pw_conc(1,IH2S), $ diff_array(1,1,IH2S), $ form,pore,delz,kmax, $ pw_diff_tot(IH2S)) sl_burial_tot(IFEOOH) = - omega(kmax) * $ sl_gg(kmax,IFEOOH)/molwt(IFEOOH) sl_burial_tot(IFES) = - omega(kmax) * $ sl_gg(kmax,IFES)/molwt(IFES) sl_burial_tot(IFECO3) = 0. xads_src_tot = 0. do kz=2,kmax xads_src_tot = xads_src_tot $ + rct(kz,xads_src) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr enddo c write(6,*) "Fe xads_src_tot = ", xads_src_tot*1.e6 return end subroutine apply_ferates(rct, $ pw_react,sl_react, $ pw_react_tot,org_consume, $ delz,kmax) implicit none #include #include integer ioc,kz,kmax double precision rct(nzmax,NReacts), $ pw_react(nzmax,nsolutemax), $ sl_react(nzmax,nsolidmax) double precision pw_react_tot(nsolidmax), $ org_consume(norgs,nsolutemax) double precision delz(nzmax) double precision alk_src, fe_src pw_react_tot(IFE2P) = 0. pw_react_tot(IH2S) = 0. pw_react_tot(ISO4) = 0. sl_react(1,IFEOOH) = -99. sl_react(1,IFECO3) = -99. sl_react(1,IFES) = -99. do ioc=1,norgs org_consume(ioc,IFe2P) = 0 org_consume(ioc,ISO4) = 0 enddo alk_src = 0. fe_src = 0. do kz=2,kmax do ioc=1,norgs sl_react(kz,IOrg+ioc-1) = sl_react(kz,IOrg+ioc-1) $ - rct(kz,fe_org+ioc-1) $ - rct(kz,s_org+ioc-1) enddo #ifdef FeSolidRctExport sl_react(kz,IFEOOH) = sl_react(kz,IFEOOH) $ - rct(kz,j0_fe_resp) $ + rct(kz,j0_fe2p_ox) $ + rct(kz,j1_fes_ox) sl_react(kz,IFES) = sl_react(kz,IFES) $ + rct(kz,j2_fes_pcp) $ - rct(kz,j1_fes_ox) #endif pw_react(kz,INH4) = pw_react(kz,INH4) $ + rct(kz,j0_fe_resp) $ / STOIC_FEORGF * STOIC_REDFIELDN $ + rct(kz,j0_s_resp) $ / STOIC_SO4ORGS * STOIC_REDFIELDN #ifdef FeNO3Forcing pw_react(kz,INO3) = pw_react(kz,INO3) $ - rct(kz,j0_fe2p_ox) / STOIC_FEOXF $ - rct(kz,j1_fes_ox) * STOIC_FESOXO2 $ - rct(kz,j0_h2s_ox) * STOIC_HSOXO2 #endif #ifdef FePHForcingSimple pw_react(kz,ICO2) = pw_react(kz,ICO2) $ - rct(kz,j0_fe_resp) * 3/2 $ + rct(kz,j0_s_resp) ! assuming sulfide as HS- $ + rct(kz,j1_fes_ox) #ifdef FePhForcingOx $ + rct(kz,j0_fe2p_ox) * 2 $ + rct(kz,j0_h2s_ox) $ + rct(kz,j1_fes_ox) * 2 #endif #ifdef FeAdsorptionON $ - 2. * rct(kz,xads_src) #endif pw_react(kz,IHCO3) = pw_react(kz,IHCO3) $ + rct(kz,j0_fe_resp) * 2 $ + rct(kz,j0_s_resp) ! * 2 if sulfide as H2S $ - rct(kz,j1_fes_ox) #ifdef FePhForcingOx $ - rct(kz,j0_fe2p_ox) * 2 $ - rct(kz,j0_h2s_ox) $ - rct(kz,j1_fes_ox) * 2 #endif #ifdef FeAdsorptionON $ + 2. * rct(kz,xads_src) #endif alk_src = alk_src $ + ( $ rct(kz,j0_fe_resp) * 2 $ + rct(kz,j0_s_resp) #ifdef FeAdsorptionON $ + 2. * rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr fe_src = fe_src $ + ( $ rct(kz,j0_fe_resp) $ + rct(kz,j0_s_resp) #ifdef FeAdsorptionON $ + rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr #endif ! FePHForcingSimple #ifdef FePHForcing pw_react(kz,ICO2) = pw_react(kz,ICO2) $ - rct(kz,j0_fe_resp) / STOIC_FEORGF $ * ( STOIC_FEORGHP - STOIC_REDFIELDC ) $ + rct(kz,j0_s_resp) / STOIC_SO4ORGS $ * (STOIC_REDFIELDC - STOIC_SO4ORGHP) #ifdef FePhForcingOx $ + rct(kz,j0_fe2p_ox) $ / STOIC_FEOXF * STOIC_FEOXHP $ + rct(kz,j0_h2s_ox) $ * STOIC_HSOXHP $ + rct(kz,j1_fes_ox) $ * STOIC_FESOXHP #endif #ifdef FeAdsorptionON $ - 2. * rct(kz,xads_src) #endif pw_react(kz,IHCO3) = pw_react(kz,IHCO3) $ + rct(kz,j0_fe_resp) / STOIC_FEORGF $ * STOIC_FEORGHP $ + rct(kz,j0_s_resp) / STOIC_SO4ORGS $ * STOIC_SO4ORGHP #ifdef FePhForcingOx $ - rct(kz,j0_fe2p_ox) $ / STOIC_FEOXF* STOIC_FEOXHP $ - rct(kz,j0_h2s_ox) $ * STOIC_HSOXHP $ - rct(kz,j1_fes_ox) $ * STOIC_FESOXHP #endif #ifdef FeAdsorptionON $ + 2. * rct(kz,xads_src) #endif alk_src = alk_src $ + ( $ rct(kz,j0_fe_resp) / STOIC_FEORGF $ * STOIC_FEORGHP $ + rct(kz,j0_s_resp) / STOIC_SO4ORGS $ * STOIC_SO4ORGHP #ifdef FeAdsorptionON $ + 2. * rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr fe_src = fe_src $ + ( $ rct(kz,j0_fe_resp) $ + rct(kz,j0_s_resp) #ifdef FeAdsorptionON $ + rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr #endif ! FePHForcing pw_react_tot(IFE2P) = pw_react_tot(IFE2P) $ + ( rct(kz,j0_fe_resp) $ - rct(kz,j0_fe2p_ox) $ ) $ * delz(kz) / 1000 * 3.15E7 pw_react_tot(IH2S) = pw_react_tot(IH2S) $ + ( rct(kz,j0_s_resp) $ - rct(kz,j0_h2s_ox) $ - rct(kz,j2_fes_pcp) $ ) $ * delz(kz) / 1000 * 3.15E7 pw_react_tot(ISO4) = pw_react_tot(ISO4) $ - rct(kz,j0_s_resp) $ * delz(kz) / 1000 * 3.15E7 enddo c write(6,*) "Fe, alk src", fe_src*1.e6, alk_src*1.e6 c if(fe2p_zoxic .LT. 1.e-20) then c write(6,*) "oxic conc ", fe2p_zoxic c endif return end subroutine fe_rates( $ fe2p_oxic, h2s_oxic, $ rct, $ drdf,drds, $ fe2p_zoxic, h2s_zoxic, $ fe2p_scale, h2s_scale, $ z_level, rc, $ sl_ml,conc, $ z,delz,form,pore,kmax) #include #include #include #include double precision fe2p_oxic(nzmax), h2s_oxic(nzmax), $ rct(nzmax,NReacts), $ drdf(nzmax),drds(nzmax), $ fe2p_zoxic, h2s_zoxic, $ fe2p_scale, h2s_scale, $ z_level(nzlevels), rc(nrcmax), $ sl_ml(nzmax,nsolidmax),conc(nzmax,5), $ z(nzmax), delz(nzmax), form(nzmax), pore(nzmax) integer kmax, kz do kz=2,kmax do irct=1, NReacts rct(kz,irct) = 0. enddo rc_scale = exp(-z(kz)/rc(JRespScale)) rct(kz,j2_fes_pcp) = rc(JFESPCP) $ * conc(kz,L_Fe) * conc(kz,L_HS) drdf(kz) = rc(JFESPCP) * conc(kz,L_HS) drds(kz) = rc(JFESPCP) * conc(kz,L_Fe) fe2p_oxic(kz) = -99. h2s_oxic(kz) = -99. c rc_scale = 1 c z(kz-1) is the top of the box, z(kz) is bottom if(z(kz) .LT. z_level(KNO3)) then ! fully oxic fe2p_oxic(kz) = fe2p_zoxic . * exp( $ - ( $ z_level(KNO3) $ - z(kz) $ + delz(kz)/2 $ ) . / fe2p_scale . ) h2s_oxic(kz) = h2s_zoxic . * exp( $ - ( $ z_level(KNO3) $ - z(kz) $ + delz(kz)/2 $ ) . / h2s_scale . ) c rct(kz,j0_fe2p_ox) = rc_fe_pcip * fe2p_oxic(kz) c this next step integrates the assumed exponential shape of the c fe2p concentration between box top and bottom. otherwise the c rates dont add up (conc@zoxic as fn(integrated rate)) #ifdef FeOx rct(kz,j0_fe2p_ox) = rc(JFEOX) * fe2p_zoxic $ * fe2p_scale / delz(kz) . * ( exp( $ - ( $ z_level(KNO3) $ - z(kz) $ ) . / fe2p_scale . ) . - exp( $ - ( $ z_level(KNO3) $ - z(kz-1) $ ) . / fe2p_scale . ) $ ) #endif #ifdef HSOx rct(kz,j0_h2s_ox) = rc(JFEOX) * h2s_zoxic $ * h2s_scale / delz(kz) . * ( exp( $ - ( $ z_level(KNO3) $ - z(kz) $ ) . / h2s_scale . ) . - exp( $ - ( $ z_level(KNO3) $ - z(kz-1) $ ) . / h2s_scale . ) $ ) #endif #ifdef FeSOx rct(kz,j1_fes_ox) = rc(JFESOX) #endif elseif(z(kz-1) .LT. z_level(KNO3)) then ! partly oxic #ifdef FeOx rct(kz,j0_fe2p_ox) = rc(JFEOX) * fe2p_zoxic $ * fe2p_scale $ / ( z_level(KNO3) - z(kz-1) ) . * ( 1. . - exp( $ - ( $ z_level(KNO3) $ - z(kz-1) $ ) . / fe2p_scale . ) $ ) . * ( z_level(KNO3) - z(kz-1) ) $ /delz(kz) #endif #ifdef HSOx rct(kz,j0_h2s_ox) = rc(JFEOX) * h2s_zoxic $ * h2s_scale $ / ( z_level(KNO3) - z(kz-1) ) . * ( 1. . - exp( $ - ( $ z_level(KNO3) $ - z(kz-1) $ ) . / h2s_scale . ) $ ) . * ( z_level(KNO3) - z(kz-1) ) $ /delz(kz) #endif #ifdef FeSOx rct(kz,j1_fes_ox) = rc(JFESOX) * * (z_level(KNO3)-z(kz-1))/delz(kz) #endif if(z(kz)-delz(kz)/2 .LT. z_level(KNO3)) then ! center is oxic fe2p_oxic(kz) = fe2p_zoxic . * exp( $ - ( $ z_level(KNO3) $ - z(kz) $ + delz(kz)/2 $ ) . / fe2p_scale . ) h2s_oxic(kz) = h2s_zoxic . * exp( $ - ( $ z_level(KNO3) $ - z(kz) $ + delz(kz)/2 $ ) . / h2s_scale . ) endif elseif(z(kz-1) .GT. z_level(KNO3)) then ! fully anaerobic if(z(kz) .LT. z_level(KFE)) then ! fully with Fe2O3 do ioc=1,norgs rct(kz,j0_fe_resp) = rct(kz,j0_fe_resp) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_FEORGF / STOIC_REDFIELDC rct(kz,fe_org+ioc-1) = rct(kz,fe_org+ioc-1) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) enddo elseif( z(kz-1) .LT. z_level(KFE)) then ! partly in Fe2O3 do ioc=1,norgs rct(kz,j0_fe_resp) = rct(kz,j0_fe_resp) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_FEORGF / STOIC_REDFIELDC $ * (z_level(KFE) - z(kz-1))/delz(kz) rct(kz,fe_org+ioc-1) = rct(kz,fe_org+ioc-1) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * (z_level(KFE) - z(kz-1))/delz(kz) enddo endif if(z(kz) .LT. z_level(KSO4)) then ! fully with SO4 do ioc=1,norgs rct(kz,j0_s_resp) = rct(kz,j0_s_resp) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_SO4ORGS / STOIC_REDFIELDC rct(kz,s_org+ioc-1) = rct(kz,s_org+ioc-1) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) enddo elseif( z(kz-1) .LT. z_level(KSO4)) then ! partly in SO4 do ioc=1,norgs rct(kz,j0_s_resp) = rct(kz,j0_s_resp) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_SO4ORGS / STOIC_REDFIELDC $ * (z_level(KSO4) - z(kz-1))/delz(kz) rct(kz,s_org+ioc-1) = rct(kz,s_org+ioc-1) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * (z_level(KSO4) - z(kz-1))/delz(kz) enddo endif elseif(z(kz) .GT. z_level(KNO3)) then ! partly anaerobic if(z(kz) .LT. z_level(KFE)) then ! fully with Fe2O3 do ioc=1,norgs rct(kz,j0_fe_resp) = rct(kz,j0_fe_resp) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_FEORGF / STOIC_REDFIELDC $ * (z(kz)-z_level(KNO3))/delz(kz) rct(kz,fe_org+ioc-1) = rct(kz,fe_org+ioc-1) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * (z(kz)-z_level(KNO3))/delz(kz) enddo elseif( z(kz-1) .LT. z_level(KFE)) then do ioc=1,norgs rct(kz,j0_fe_resp) = rct(kz,j0_fe_resp) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_FEORGF / STOIC_REDFIELDC $ * (z_level(KFE) - z_level(KNO3)) $ /delz(kz) rct(kz,fe_org+ioc-1) = rct(kz,fe_org+ioc-1) $ + rc(JFEORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * (z_level(KFE) - z_level(KNO3)) $ /delz(kz) enddo endif if(z(kz) .LT. z_level(KSO4)) then ! fully with SO4 do ioc=1,norgs rct(kz,j0_s_resp) = rct(kz,j0_s_resp) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_SO4ORGS / STOIC_REDFIELDC $ * (z(kz)-z_level(KNO3))/delz(kz) rct(kz,s_org+ioc-1) = rct(kz,s_org+ioc-1) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * (z(kz)-z_level(KNO3))/delz(kz) enddo elseif( z(kz-1) .LT. z_level(KSO4)) then do ioc=1,norgs rct(kz,j0_s_resp) = rct(kz,j0_s_resp) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * STOIC_SO4ORGS / STOIC_REDFIELDC $ * (z_level(KSO4) - z_level(KNO3)) $ /delz(kz) rct(kz,s_org+ioc-1) = rct(kz,s_org+ioc-1) $ + rc(JSO4ORG+ioc-1) $ * rc_scale * sl_ml(kz,IORG+ioc-1) $ * (z(kz)-z_level(KNO3))/delz(kz) $ * (z_level(KSO4) - z_level(KNO3)) $ /delz(kz) enddo endif endif enddo ! kz=2,kmax return end #ifdef PurgeMe do ioc = 1, norgs sl_react(kz,IORG+ioc-1) = sl_react(kz,IORG+ioc-1) $ + rc(JFEORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ + rc(JSO4ORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) nh4_react(kz) = nh4_react(kz) $ + rc(JFEORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ / STOIC_REDFIELDC * STOIC_REDFIELDN $ + rc(JSO4ORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ / STOIC_REDFIELDC * STOIC_REDFIELDN co2_react(kz) = co2_react(kz) $ - rc(JFEORG+ioc-1) * rc_scale ! from iron $ * sl_ml(kz,IORG+ioc-1) $ * ( STOIC_FEORGHP - STOIC_REDFIELDC ) $ / STOIC_REDFIELDC $ + rc(JSO4ORG+ioc-1) * rc_scale ! from so4 $ * sl_ml(kz,IORG+ioc-1) $ * (STOIC_REDFIELDC - STOIC_SO4ORGHP) $ / STOIC_REDFIELDC hco3_react(kz) = hco3_react(kz) $ + rc(JFEORG+ioc-1) * rc_scale ! from iron $ * sl_ml(kz,IORG+ioc-1) $ * STOIC_FEORGHP / STOIC_REDFIELDC $ + rc(JSO4ORG+ioc-1) * rc_scale ! from so4 $ * sl_ml(kz,IORG+ioc-1) $ * STOIC_SO4ORGHP $ / STOIC_REDFIELDC enddo #endif * sl_ml(kz,IORG+ioc-1) $ * (STOIC_REDFIELDC - STOIC_SO4ORGHP) $hsio4ss.F000644 025374 000024 00000006075 10413036311 013046 0ustar00archeruser000000 000000 #include SUBROUTINE hsio4ss(runid,idebug, $ si, $ sio2_gg, . rc,opsat,difsi,irrig_array, $ z, delz, form, pore, kmax, $ si_react, $ sio2_react,sio2_dreac, $ react_tot, diff_tot) implicit none #include #include integer kmax, runid,idebug c external variables DOUBLE PRECISION si(kmax),sio2_gg(nzmax,n_opals) DOUBLE PRECISION si_react(kmax), $ sio2_react(nzmax,n_opals),sio2_dreac(nzmax,n_opals) double precision rc(n_opals), opsat(n_opals), difsi(nzmax,2), $ irrig_array(nzmax) double precision form(kmax), pore(kmax), delz(kmax), $ z(kmax) double precision react_tot, diff_tot c internal variables DOUBLE PRECISION a(nzmax,nzmax),b(nzmax,1),r(nzmax) double precision si_dreact(nzmax) integer iIter, kz, iOpal do iIter=1, 20 do kz=2, kmax do iOpal=1,n_opals sio2_react(kz,iOpal) = 0. sio2_dreac(kz,iOpal) = 0. si_dreact(kz) = 0. enddo enddo call si_react_rates(si, $ sio2_gg, $ z,delz,rc,opsat, $ si_react,si_dreact, $ sio2_react,sio2_dreac, $ kmax) call pw_1_ss_d(runid,idebug,si,si_react,si_dreact, $ z,delz,form,pore, $ difsi,irrig_array, $ kmax, $ react_tot,diff_tot) do kz=2, kmax si_react(kz) = 0. si_dreact(kz) = 0. enddo enddo return end subroutine si_react_rates(si, $ sio2_gg, $ z,delz,rc,opsat, $ si_react,si_dreact, $ sio2_react,sio2_dreac, $ kmax) implicit none #include #include integer kmax double precision si(kmax), sio2_gg(nzmax,n_opals) double precision z(kmax),delz(kmax) double precision rc(n_opals),opsat(n_opals) double precision si_react(kmax),si_dreact(kmax), $ sio2_react(nzmax,n_opals),sio2_dreac(nzmax,n_opals) integer iOpal,kz do iOpal = 1, n_opals DO kz = 2, kmax IF( si(kz) .le. opsat(iOpal) ) then si_react(kz) = si_react(kz) . + rc(iOpal) . * (opsat(iOpal) - si(kz)) . * sio2_gg(kz,iOpal) si_dreact(kz) = si_dreact(kz) . - rc(iOpal) . * sio2_gg(kz,iOpal) sio2_react(kz,iOpal) = sio2_react(kz,iOpal) . - rc(iOpal) . * (opsat(iOpal) - si(kz)) . * sio2_gg(kz,iOpal) sio2_dreac(kz,iOpal) = sio2_dreac(kz,iOpal) . - rc(iOpal) . * (opsat(iOpal) - si(kz)) ENDIF enddo enddo return end - rc(iOpal) . * sio2_gg(kz,iOpal) sio2_react(kz,iOpal) = sio2_react(kz,iOpal) . - rc(iOpal) . * (opsat(iOpal) - si(kz)) . * sio2_gg(kz,iOpal) sio2_dreac(kz,iOpal) = sio2_dreac(kz,iOpal) . - rc(iOpal) . * (opsat(iOpal) - si(kz)) ENDinit.F000644 025374 000024 00000060447 10413036311 012420 0ustar00archeruser000000 000000 #include subroutine generate_rates( $ rainorg,raincaco3, $ rainopal,rainclay, $ bwchem, $ tuner_arg, #ifdef ReadCalciteKineticsFile $ ratefilename, #endif $ rain,rc) implicit none #include #include #include #include #include double precision rainorg, raincaco3(nCaCO3s), $ rainopal,rainclay double precision bwchem(NBottomWaters) double precision rain(nsolidmax),rc(nrcmax) double precision tuner_arg(ntuners) c internal variables double precision omega_tt, omega_tt_archer double precision fastrat, slowrat integer irc, irain, iread, ic double precision anoxia_param character*80 ratefilename do irc=1,nrcmax rc(irc) = 0 enddo #ifdef Irrig c units cm3 fluid exch / cm2 surface day rc(JIrrig) = ( atan((rainorg - 400.) / 400. * 5.) $ / 3.14159 + 0.5 $ ) * 11. $ - 0.9 #ifdef TIrrigOffset $ * tuner_arg(TIrrigOffset) #endif #define AnoxicIrrigSquash #ifdef AnoxicIrrigSquash rc(JIrrig) = rc(JIrrig) $ * bwchem(BWO2) / (bwchem(BWO2) + 10.) ! uM O2 half-saturation for Db #endif #ifdef LowO2IrrigBoost rc(JIrrig) = rc(JIrrig) $ + bwchem(BWO2) / (bwchem(BWO2) + 10.) $ * exp( - bwchem(BWO2) / 10. ) $ * 20. $ * rainorg / (rainorg + 30.) #endif rc(JIrrig) = MAX(rc(JIrrig),0.D0) #ifdef TIrrigScale $ * tuner_arg(TIrrigScale) #endif rc(JIrrigZ) = 5.0 #ifdef TIrrigZ $ * tuner_arg(TIrrigZ) #endif #endif ! Irrig cc first calculate tracys sedimentation rate, cm/yr omega_tt_archer = 10**((log10(rainorg/8.3)-2.49)/.85) c omega_tt_archer = omega_tt_archer * 0.2 * 2.5 * 1e6 omega_tt = 48.556 * rainorg**1.1765 ! Morford recalculated ug/cm2 yr omega_tt = omega_tt / 0.2 / 2.5 / 1e6 ! to cm/yr, same as omega_tt_archer c bioturbation rate rc(JDb) = 10**(1.63 + 0.85 * log10(omega_tt)) rc(JDb) = rc(JDb) #ifdef TDb $ * exp((tuner_arg(TDb)-1.)) #endif #ifdef SedssBioturbation rc(JDb) = 0.15 #endif rc(JZMix) = 8. #ifdef TDbz . * tuner_arg(TDbz) #endif rc(JRespScale) = 9. #ifdef TRespScale $ * tuner_arg(TRespScale) #else $ * 0.66 #endif c organic rate constants #ifdef OxicOrgOn rc(JORG) = rc(JDb) / (0.4**2) / 3.15e7 ! e-folding scale of 4 mm rc(JORG+1) = rc(JDb) / (4.**2) / 3.15e7 ! e-folding scale of 4 cm #ifdef SimpleOrg rc(JORG) = 2.d-9 rc(JORG+1) = 2.d-9 rc(JRespScale) = 250. #endif fastrat = rc(JORG) / rc(JORG+1) #else fastrat = 0 #endif #ifdef NO3Resp c rc(JNO3ORG+1) = rc(JDb) / ( c $ ( c $ 10. c . * tuner_arg(1) cc $ * 0.4 c $ )**2) / 3.15e7 ! NO3 rc(JNO3ORG+1) = rc(JORG+1) #ifdef TNO3Resp $ * tuner_arg(TNO3Resp) #else $ * .7 #endif #endif rc(JNO3ORG) = rc(JNO3ORG+1) * fastrat rc(JSO4ORG+1) = 10**(1.75*log10(omega_tt)-1.75)/3.15e7 ! from Tromp ccccc rc(JFEORG+1) = rc(JDb) / (400.**2) / 3.15e7 ! FeOOH ccccc rc(JFEORG+1) = 10**(1.75*log10(omega_tt)-1.75)/3.15e7 ! from Tromp #ifdef FeResp rc(JFEORG+1) = rc(JSO4ORG+1) $ * 4. #ifdef TFeResp $ * tuner_arg(TFeResp) #else $ * 2.6 #endif #endif rc(JFEORG) = rc(JFEORG+1) * fastrat #ifdef MnResp rc(JMNORG+1) = rc(JSO4ORG+1) #ifdef TMnResp $ * 10**(tuner_arg(TMnResp)-1.) if(tuner_arg(TMnResp) .EQ. 0) then rc(JMnOrg+1) = 0. endif #endif #endif rc(JMNORG) = rc(JMNORG+1) * fastrat #ifdef SResp rc(JSO4ORG+1) = rc(JSO4ORG+1) #ifdef TSResp $ * tuner_arg(TSResp) #else $ * 0.62 #endif #else ! not SResp rc(JSO4ORG+1) = 0. #endif rc(JSO4ORG) = rc(JSO4ORG+1) * fastrat cccc#define EqualRespRates #ifdef EqualRespRates rc(JNO3ORG) = rc(JORG) rc(JNO3ORG+1) = rc(JORG+1) rc(JFeORG) = rc(JORG) / 800. rc(JFeORG+1) = rc(JORG+1) / 800. c rc(JMnORG) = rc(JORG) c rc(JMnORG+1) = rc(JORG+1) c rc(JFeORG) = 0. c rc(JFeORG+1) = 0. rc(JSO4ORG) = rc(JORG) / 100. rc(JSO4ORG+1) = rc(JORG+1) /100. #endif c oxidation rate constants #ifdef MnOx rc(JMNOX) = 1.e-3 ! Mn2+ oxidation, was -6 #ifdef TMnOx exponent *= tuner_arg(TMnOx) #endif #else rc(JMNOX) = 10**(-30.) #endif c write(6,*) "init 193", rc(JMNOx) #ifdef FeOx rc(JFEOX) = 1.e-3 #else rc(JFEOX) = 1.e-20 #endif c write(6,*) "init 193", rc(JFeOx) c rc(jFeLeak) = 0.1 #ifdef HSOx rc(JHSOX) = rc(JFEOX) ! H2S oxidation #else rc(JHSOX) = 1.e-20 #endif #ifdef FeSOx rc(JFESOX) = 1.e-12 ! FeS oxidation #endif #ifdef NH4Ox rc(JNH4Ox) = 1.e-8 ! NH4 oxidation #endif #ifdef SlowUranium #ifdef URed rc(JURED) = 1.e-7 !5 ! U6+ reduction #endif #ifdef UOx rc(JUOX) = 3.e-8 !6 ! UO2 oxidation #endif #else ! not SlowUranium #ifdef URed rc(JURED) = 1.e-2 ! U6+ reduction #endif #ifdef UOx rc(JUOX) = 3.e-3 ! UO2 oxidation #endif #endif ! SlowUranium #ifdef FeSPcp rc(JFESPCP) = 1.e-2 ! FeS precipitation (second order) was -2 #endif c CaCO3 c**************************************************** #ifdef ReadCalciteKineticsFile open(11,file=ratefilename) read(11,*) read(11,*) (rc(JCaCO3Phase+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3K+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3N+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3Law+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3PcpK+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3PcpSeed+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3PcpArea+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3Frag+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3FragDaug+irc),irc=0,nCaCO3s-1) read(11,*) (rc(JCaCO3Sat+irc),irc=0,nCaCO3s-1) close(11) c**************************************************** #else ! not ReadCalciteKineticsFile do irc = 0, NCaCO3s-1 rc(JCaCO3Phase) = 0. rc(JCaCO3K+irc) = 0. rc(JCaCO3N+irc) = 1. rc(JCaCO3K1+irc) = 0. rc(JCaCO3K2+irc) = 0. rc(JCaCO3Law+irc) = 0. rc(JCaCO3PcpK+irc) = 0. rc(JCaCO3PcpSeed+irc) = 0. rc(JCaCO3PcpArea+irc) = 1. ! m2 / g CaCO3 Burton rc(JCaCO3Frag+irc) = 0. rc(JCaCO3FragDaug+irc) = 0. rc(jCaCO3Sat+irc) = 1.0 enddo #ifdef CaCO3Dissolution rc(jCaCO3Phase)=1 #ifdef TwoCaCO3s rc(JCaCO3Phase+1)=2 #endif #ifdef SevenCaCO3s do irc=0,2 rc(jCaCO3Phase+irc) = 1 enddo do irc=3,4 rc(jCaCO3Phase+irc) = 2 enddo do irc=5,6 rc(jCaCO3Phase+irc) = 3 enddo #endif c Calcite do irc = 0, nCaCO3s-1 if(rc(JCaCO3Phase+irc) .EQ. 1) then #ifdef NonLinearCalcite rc(JCaCO3K+irc) = 1.e-1 ! units day-1 rc(JCaCO3N+irc) = 4.5 rc(JCaCO3Law+irc) = 1 ! Keir rate law #else rc(JCaCO3K+irc) = 1.e-4 ! Hales rc(JCaCO3N+irc) = 1. rc(JCaCO3Law+irc) = 1 ! Keir rate law #ifdef CaCO3AcidDissolution rc(JCaCO3K1+irc) = 8.9E-5 ! mol/cm2 s $ / 150. ! lab to field offset rc(JCaCO3K2+irc) = 5.0E-8 $ / 150. #endif #endif endif enddo #ifdef AragoniteDissolution c Aragonite if(rc(JCaCO3Phase+irc) .EQ. 2) then #ifdef NonLinearCalcite rc(JCaCO3K+irc) = 1. ! units day-1 rc(JCaCO3N+irc) = 1.87 rc(JCaCO3Law+irc) = 2 ! Acker rate law #else rc(JCaCO3K+irc) = 1.e-4 rc(JCaCO3N+irc) = 1. rc(JCaCO3Law+irc) = 1 ! Keir rate law #endif rc(jCaCO3Sat+irc) = 1.43 endif #endif ! AragoniteDissolution #ifdef CaCO3Precipitation c Calcite irc = ICaCO3+ICalcite+NCalcites-1 rc(JCaCO3PcpK+irc) = 1.62 ! units umol/m2 hr Zhong 93 rc(JCaCO3PcpSeed+irc) = 1 ! calcite c Aragonite irc = ICaCO3+IAragonite+NAragonites-1 rc(JCaCO3PcpK+irc) = 1.62 ! units umol/m2 hr Zhong 93 rc(JCaCO3PcpSeed+irc) = 2 ! aragonite #endif ! CaCO3Precipitation #endif ! CaCO3Dissolution #endif ! not ReadCalciteKineticsFile call calc_k_csat(bwchem(BWTemp),bwchem(BWSal),bwchem(BWDepth), . rc(jCaCO3Sat),rc(jK1),rc(jK2),rc(jKb)) #ifdef StdOut write(6,'(a4, 7g8.1)') "k",(rc(JCaCO3K+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "n",(rc(JCaCO3N+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "l",(rc(JCaCO3Law+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "pk",(rc(JCaCO3PcpK+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "ps", $ (rc(JCaCO3PcpSeed+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "pa", $ (rc(JCaCO3PcpArea+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "f", $ (rc(JCaCO3Frag+irc),irc=0,nCaCO3s-1) write(6,'(a4, 7g8.1)') "fg", $ (rc(JCaCO3FragDaug+irc),irc=0,nCaCO3s-1) #endif #ifdef MnCO3Pcp c MnCO3 rc(JMnCO3k) = 10**( $ -10. #ifdef TMnCO3k $ * tuner_arg(TMnCO3k) #endif $ ) ! MnCO3 pcp rate constant #endif #ifdef TMnCO3k if(tuner_arg(TMnCO3k) .EQ. 0) then rc(JMnCO3k) = 0. endif #endif rc(JMnCO3sat) = 150.e-6 #ifdef TMnCO3Sat $ * tuner_arg(TMnCO3Sat) #endif c 0 -> 0, 1 -> 90% rc(JMnIR) = 1. #ifdef TMnIRedep $ * (1 - 10**( - tuner_arg(TMnIRedep) )) #endif #ifdef TMnDRedep c 0 -> 0, 1 -> 90% rc(JMnDR) = 1. $ * ( 1. - 10**(-tuner_arg(TMnDRedep)) ) #endif rc(JFeIR) = 1. #ifdef TFeIRedep $ * 10**( - tuner_arg(TFeIRedep) ) #endif #ifdef TFeDRedep rc(JFeDR) = 1. $ * ( 1. - 10**(-tuner_arg(TFeDRedep)) ) #endif rc(JFeAds) = 10.**( $ 3.2 #ifdef TFeAds $ * TFeAds #endif $ ) c Opal rc(JOpal) = 5.e-6 ! opal k rc(JOpSat) = 600e-6 ! opal sat c radiotracer c rc(JSTracer) = 0.69314 / 8000. / 3.14e7 ! 8 kyr half life radiotracer rc(JSTracer) = 0.69314 / 10. / 3.14e7 ! 10 Yr half life radiotracer c rain rates, mol/cm2 yr do irain=1,nsolidmax rain(irain) = 0 enddo rain(IOrg) = 0.3 $ * rainorg ! umol/cm2 yr #ifdef TOxFrac $ * tuner_arg(TOxFrac) #endif rain(IOrg+1) = rainorg - rain(IORG) rain(IClay) = rainclay c#ifdef ReadCalciteKineticsFile c read(11,*) (dummy(irc),irc=1,7) c close(11) c rainforam = rainforam + raincocco + rainarag c do irc=1,7 c rain(iCaCO3+irc-1) = rainforam * dummy(irc) c enddo c#else ! not ReadCalciteKineticsFile do ic = 1, nCaCO3s rain(ICaCO3+ic-1) = raincaco3(ic) enddo c#endif rain(ISiO2) = rainopal c the Turekian and Wedepohl numbers for shale are as follows (in c g/gsediment): c Mn 8.5 x 10-4 c Fe 4.7 x 10-2 c Mn c rain(IMNO2) = rainclay * 2.e-5 cc rain(IMNO2) = rainclay * 2.e-6 ! Mn rain(IMNO2) = rainclay * 8.5e-4 ! ug Mn/cm2yr $ / 54.9 ! umol Mn/cm2yr $ * 0.5 ! labile #ifdef BoostMnRain rain(IMnO2) = 10. * rain(IMnO2) #endif cc rain(IFEOOH) = rainclay * 3.5e-4 c rain(IFEOOH) = rainclay * 5.e-5 ! Fe from Shaw c rain(IFEOOH) = rainclay * 5.e-4 ! Fe rain(IFEOOH) = rainclay * 4.7e-2 $ / 55.6 $ * 0.3 ! works out to 8.5e-5 #ifdef Junk if(bwchem(BWO2) .GT. 0.) then anoxia_param = bwchem(BWO2) else anoxia_param = - bwchem(BWH2S) endif anoxia_param = ( atan(anoxia_param) $ + 3.14159 / 2. $ - 0.1 $ ) / ( 3.14159 / 2. ) anoxia_param = MAX(anoxia_param, 0.) rain(IMnO2) = anoxia_param * rain(IMnO2) rain(IFeOOH) = anoxia_param * rain(IFeOOH) #endif #ifdef Bells_Whistles #ifdef URain c rain(IUO2) = rainorg / 10. ! now ug/cm2 kyr, need umol/cm2 yr c $ / 238. / 1000. ! umol/cm2 yr rain(IUO2) = (rainorg * 0.0623 + 1.7458) ! ug/cm2 kyr, from JM Jul30,02 $ / 238. / 1000. ! umol/cm2 yr #endif rain(ISTracer) = 1.e-3 ! tracer #endif do irain=1,nsolidmax rain(irain) = rain(irain) / 1.e6 enddo rc(JDb) = rc(JDb) $ * bwchem(BWO2) / (bwchem(BWO2) + 20.) ! uM O2 half-saturation for Db rain(IMnO2) = rain(IMnO2) $ * bwchem(BWO2) / (bwchem(BWO2) + 4.) rain(IFeOOH) = rain(IFeOOH) $ * bwchem(BWO2) / (bwchem(BWO2) + 4.) return end subroutine init_update(pw_conc,sl_gg,sl_ml, $ bwchem, g z,delz,form, pore, kmax, $ diff_coeff, diff_array, $ irrig_array, $ omega, . rc, $ pw_react_rates,sl_react_rates,sl_dreac, $ db_array, $ molwt, $ rain,msrain) implicit none #include #include #include #include #include c external variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision sl_ml(nzmax,nsolidmax) double precision bwchem(nBottomWaters) double precision form(nzmax), pore(nzmax), delz(nzmax), $ z(nzmax), expb double precision diff_coeff(nsolutemax), $ diff_array(nzmax,2,nsolutemax), irrig_array(nzmax) double precision omega(nzmax) integer kmax double precision rc(nrcmax), db_array(nzmax,4) double precision pw_react_rates(nzmax,nsolutemax) double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax) double precision molwt(nsolidmax) double precision rain(nsolidmax), msrain c internal variables integer kz,ipw,isolid double precision a_junk kmax = nzmax-1 #ifdef CompareSolidSS kmax = 10 #endif c******************************************* c c update overlying water chemistry c c******************************************* c bottom water stuff concentrations to zero do ipw=1, nsolutemax pw_conc(1,ipw) = 0. enddo c set bw carbonate chemistry pw_conc(1,IO2) = bwchem(BWO2)/1.d6 pw_conc(1,INO3) = bwchem(BWNO3)/1.d6 pw_conc(1,ISi) = bwchem(BWSi)/1.d6 call calc_co2chem(bwchem(BWTemp), $ bwchem(BWSal), bwchem(BWDepth), . rc(JK1), rc(JK2), rc(JKb), $ bwchem(BWAlk)/1.d6, bwchem(BWTCO2)/1.d6, $ pw_conc(1,ICO2), pw_conc(1,IHCO3), $ pw_conc(1,ICO3)) pw_conc(1,IH2S) = bwchem(BWH2S)/1.d6 pw_conc(1,INH4) = bwchem(BWNH4)/1.d6 pw_conc(1,ISO4) = 28.E-3 #ifdef Bells_Whistles pw_conc(1,IUO2CO3) = 1.35E-8 #ifdef LowBWUranium pw_conc(1,IUO2CO3) = LowBWUranium #endif pw_conc(1,IRePW) = 4.e-11 pw_conc(1,IMoPW) = 1.05e-7 #endif c******************************************* c c porosity is not saved c c******************************************* do kz = 2, kmax delz(kz) = z(kz) - z(kz-1) enddo expb = 3.0 call pore_expected(pore,form, $ 0.5D0, c $ sl_gg(1,ICALCITE), $ z,kmax) do isolid=1,nsolutemax call calc_pw_diff(diff_coeff(isolid), $ form,pore,delz,kmax, $ diff_array(1,1,isolid), diff_array(1,2,isolid)) enddo call calc_irrig(rc(JIrrig),rc(JIrrigZ), $ z,delz,pore,kmax, $ irrig_array) #ifdef BioturbationBox call calc_db_box(rc(Jdb), $ db_array,z,delz,pore,kmax,rc(JZMix)) #else call calc_db(rc(JDb),db_array,z,delz,pore,kmax,rc(JZMix)) #endif c rain stuff msrain = 0. do isolid = 1, nsolidmax msrain = msrain + rain(isolid) * molwt(isolid) c g / cm2 yr enddo c fake omega using conservation of clay c do kz=2,kmax c omega(kz) = rain(ICLAY) * molwt(ICLAY) c $ / sl_gg(kz,ICLAY) c enddo do isolid = 1, nsolidmax CALL sldcon(sl_gg(1,isolid),sl_ml(1,isolid), $ molwt(isolid),pore,kmax) enddo do kz = 2, kmax delz(kz) = z(kz) - z(kz-1) enddo do kz = 1, kmax do isolid = 1, nsolidmax sl_react_rates(kz,isolid) = 0. sl_dreac(kz,isolid) = 0. enddo do ipw = 1, nsolutemax pw_react_rates(kz,ipw) = 0. enddo enddo return end subroutine init_base(pw_conc, sl_gg, $ bwchem, g z,delz,form, pore, kmax, g omega,ggtot, g rc, $ db_array,diff_coeff, c molwt, pw_react_rates, sl_react_rates, c sl_dreac, c sl_ml,rain,msrain,z_level) implicit none #include #include #include #include #include c external variables c dimensioned as nzmax because kmax is only defined c within this routine double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision bwchem(nBottomWaters) c gridvars stuff double precision form(nzmax), pore(nzmax), delz(nzmax), $ z(nzmax), expb integer kmax c solid advection double precision omega(nzmax), ggtot(nzmax) c mixing and diffusion double precision db, db_array(nzmax,4) double precision diff_coeff(nsolutemax) c chemical variables c porewater concentrations double precision z_level(nzlevels) c solid concentrations double precision sl_ml(nzmax,nsolidmax), $ rain(nsolidmax), msrain c reaction rates and stoiciometries double precision rc(nrcmax), molwt(nsolidmax) double precision pw_react_rates(nzmax,nsolutemax) double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax) c names and display stuff character*4 solidname(nsolidmax), solutename(nsolutemax) double precision solid_scale(nsolidmax), $ solute_scale(nsolutemax) c internal variables integer kz, i, isol, ipw, isolid, iread double precision a_junk double precision dummy(10) data dummy /10*1/ kmax = nzmax-1 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c solid concentrations c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do kz = 2, kmax do isolid = 1, nsolidmax sl_gg(kz,isolid) = 0.001 enddo sl_gg(kz,IMnO2) = 1.e-9 sl_gg(kz,IMnCO3) = 0 sl_gg(kz,IFeS) = 0 #ifdef Bells_Whistles sl_gg(kz,IUO2) = 0 sl_gg(kz,IReSol) = 0 sl_gg(kz,IMoSol) = 0 #endif #ifdef CompareSolidSS sl_gg(kz,ICALCITE) = 0.1 sl_gg(kz,ICALCITE+1) = 0.1 c#else c sl_gg(kz,iCaCO3) = 0.00000001 #endif c sl_gg(kz,ICALCITE) = 0.1 a_junk = 0. do isolid=ICLAY+1, nsolidmax a_junk = a_junk $ + sl_gg(kz,isolid) enddo sl_gg(kz,iClay) = 1. - a_junk enddo kz=1 do isolid=1,nsolidmax sl_gg(kz,isolid) = 0. enddo ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c porewater concentrations c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c bottom water stuff concentrations to zero do i=1, nsolutemax pw_conc(1,i) = 0. enddo c set bw chemistry pw_conc(1,IO2) = bwchem(BWO2)/1.d6 pw_conc(1,INO3) = bwchem(BWNO3)/1.d6 pw_conc(1,ISi) = bwchem(BWSi)/1.d6 call calc_co2chem(bwchem(BWTemp), $ bwchem(BWSal), bwchem(BWDepth), . rc(JK1), rc(JK2), rc(JKb), $ bwchem(BWAlk)/1.d6, bwchem(BWTCO2)/1.d6, $ pw_conc(1,ICO2), pw_conc(1,IHCO3), $ pw_conc(1,ICO3)) pw_conc(1,IH2S) = bwchem(BWH2S)/1.d6 pw_conc(1,INH4) = bwchem(BWNH4)/1.d6 pw_conc(1,ISO4) = 28.E-3 #ifdef Bells_Whistles pw_conc(1,IUO2CO3) = 1.35E-8 pw_conc(1,IRePW) = 4.e-11 pw_conc(1,IMoPW) = 1.05e-7 #endif c more bw initializations do kz = 2, kmax do ipw = 1, nsolutemax pw_conc(kz, ipw) = $ pw_conc(1, ipw) enddo enddo c solid physical stuff C exponent relating porosity to form factor expb = 3.0 call pore_expected(pore,form, $ sl_gg(1,iCaCO3),z,kmax) c initialize downcore stuff do kz = 2, kmax delz(kz) = z(kz) - z(kz-1) do isolid = 1, nsolidmax sl_react_rates(kz,isolid) = 0. sl_dreac(kz,isolid) = 0. enddo do i = 1, nsolutemax pw_react_rates(kz,i) = 0. enddo enddo call calc_db(rc(JDb),db_array, $ z,delz,pore,kmax,rc(JZMix)) c rain stuff msrain = 0. do isolid = 1, nsolidmax msrain = msrain + rain(isolid) * molwt(isolid) c g / cm2 yr enddo do kz=1, kmax omega(kz) = msrain enddo c critical cutoff depth initialized do i=1,nzlevels z_level(i)=z(kmax) enddo do isolid = 1, nsolidmax CALL sldcon(sl_gg(1,isolid),sl_ml(1,isolid), $ molwt(isolid),pore,kmax) enddo return end subroutine init_kinetics(filename, rc, nrc, db, z_mix) implicit none #include #include #include #include integer nrc character*(*) filename double precision rc(nrc), db, z_mix integer iread c read kinetics stuff open(unit=13, file=filename) do iread = 1, nrc read(13,*) rc(iread) enddo rc(JSTracer) = 0.69314 / rc(JSTracer) ! yr-1 $ / 3.14e7 ! s-1 close(13) return end subroutine setup_pw(pw_conc,nzmax, nsolutemax,kmax) double precision pw_conc(nzmax, nsolutemax) do kz = 2, kmax do ipw = 1, nsolutemax pw_conc(kz, ipw) = $ pw_conc(1, ipw) enddo enddo return end subroutine setup_sl(sl_gg, kmax) #include #include double precision sl_gg(nzmax, nsolidmax) c initialize downcore concentrations do kz = 2, kmax do isolid = 1, nsolidmax sl_gg(kz,isolid) = 0.001 enddo sl_gg(kz,IUO2) = 0 sl_gg(kz,iCaCO3) = 0.00000001 sl_gg(kz,ICLAY) = 1. $ - sl_gg(kz,IORG) $ - sl_gg(kz,IORG+1) do isolid=ICLAY+1, nsolidmax sl_gg(kz,ICLAY) = sl_gg(kz,ICLAY) $ - sl_gg(kz,isolid) enddo enddo kz=1 do isolid=1,nsolidmax sl_gg(kz,isolid) = 0. enddo return end subroutine calc_irrig(irrig_rate,z_irrig, $ z,delz,pore,kmax, $ irrig_array) implicit none #include #include double precision irrig_rate,z_irrig, $ z(nzmax),delz(nzmax),pore(nzmax), $ irrig_array(nzmax) double precision irrig_tot integer kz, kmax irrig_tot = 0. do kz = 2, kmax irrig_array(kz) = 0. if( c $ z(kz) .LT. 10 c $ .AND. $ z_irrig .GT. 0) then #ifdef Irrig irrig_array(kz) = irrig_rate ! cm3 pw / cm2 tot day $ / 86400. $ * exp( -( $ (z(kz)+z(kz-1))/2. $ /z_irrig $ )**2 $ ) $ / pore(kz) ! 1/s #endif endif irrig_tot = irrig_tot + irrig_array(kz) $ * pore(kz) * delz(kz) * 86400. enddo do kz=2, kmax irrig_array(kz) = irrig_array(kz) $ * irrig_rate / (irrig_tot + 1.e-20) enddo #ifdef Debug irrig_tot = 0. do kz=2, kmax irrig_tot = irrig_tot + irrig_array(kz) $ * pore(kz) * delz(kz) * 86400. enddo write(6,*) "irrigation totals ", irrig_rate, irrig_tot #endif return end ndif endif irrig_tot = irrig_tot + irrig_array(kz) $ * pore(kz) * delz(kz) * 86400. enddo do kz=2, kmax irrig_array(kz) = irrig_array(kz) $ * irrig_rateinitorgc.F000644 025374 000024 00000006650 10413036311 013267 0ustar00archeruser000000 000000 #include SUBROUTINE initorgc(runid,idebug,pw_conc, solid_gg, sl_ml, g z, delz, pore, omega, db_array, kmax, c rc, rain, molwt, sl_react_rates, sl_dreac) implicit none #include #include #include integer iter, k, kmax, isol, ioc, irc,runid,idebug c external variables double precision pw_conc(nzmax,nsolutemax) double precision solid_gg(nzmax,nsolidmax), $ sl_ml(nzmax, nsolidmax) c gridvars double precision z(kmax), delz(kmax), pore(kmax), omega(kmax), $ db_array(4,kmax) c chemvars double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax),rc(nrcmax), $ rain(nsolidmax), molwt(nsolidmax), $ fast_react,slow_react, fast_inv, slow_inv c internal variables double precision scale_depth, rc_scale,weight,omega_new, $ clay_gg_tmp(nzmax) scale_depth = 30 do k=2,kmax clay_gg_tmp(k) = solid_gg(k,ICLAY) enddo do iter = 1, 200 do k = 2, kmax rc_scale = exp(-z(k)/scale_depth) c rc_scale = 1 if(pw_conc(1,IO2) .GT. 10.E-6) then irc = JORG else irc = JSO4Org endif do isol = 0,1 ! IORG, IORG+NORGS-1 sl_react_rates(k,isol+IOrg) = $ - 0.5*rc(isol+irc) * rc_scale $ * solid_gg(k,isol+IOrg) * 3.15e7 sl_dreac(k,isol+IOrg) = $ - rc(isol+irc) * rc_scale * 3.15e7 enddo enddo do ioc = IORG,IORG+NORGS-1 do k = 1, 25 weight=0.1 call solid_iter(runid,idebug,rain(ioc)*molwt(ioc), $ sl_react_rates(1,ioc),sl_dreac(1,ioc), $ solid_gg(1,ioc), molwt(ioc), g delz, pore, omega, db_array, kmax, $ sl_ml(1,ioc), $ weight) enddo call sl_react_tot_slrates(sl_react_rates(1,ioc), $ pore, delz, kmax, fast_react) enddo do k=2,kmax weight = 0.001 if((1.-solid_gg(k,IORG)-solid_gg(k,IORG+1)) $ .GT. 0.) then clay_gg_tmp(k) = weight $ * (1.-solid_gg(k,IORG)-solid_gg(k,IORG+1)) $ + (1-weight) * clay_gg_tmp(k) else clay_gg_tmp(k) = 0.9 * clay_gg_tmp(k) endif omega_new = rain(ICLAY) * molwt(ICLAY) $ / clay_gg_tmp(k) weight = 0.1 omega(k) = weight * omega_new $ + (1-weight) * omega(k) enddo c write(6,'(a10,i4,3g15.5)') "initorgc", iter, c $ clay_gg_tmp(3), omega(3), solid_gg(3,IORG) c call calc_sl_inv(sl_ml, c $ delz, molwt, kmax, c $ fast_inv) enddo DO k=2, kmax solid_gg(k,ICLAY) = clay_gg_tmp(k) do ioc=IORG,IORG+NORGS-1 sl_react_rates(k,ioc) = 0. sl_dreac(k,ioc) = 0. enddo enddo c if we were to initialize them, then should be in the c porewater units of mol / l total sec c sl_react_rates(k,IFASTORG) = c $ - rc(IFASTORG) * sl_ml(k,IFASTORG) c sl_react_rates(k,ISLOWORG) = c $ - rc(ISLOWORG) * sl_ml(k,ISLOWORG) RETURN END O k=2, kmax solid_gg(k,ICLAY) = clay_gg_tmp(k) do ioc=IORG,IORG+NORGS-makefile000644 025374 000024 00000003400 10413036311 013030 0ustar00archeruser000000 000000 #OPTFLAGS = -g -64 -DEBUG:subscript_check=ON:trap_uninitialized=ON:verbose_runtime -lfpe OPTFLAGS = -O2 -lfpe -DEBUG:subscript_check=ON:trap_uninitialized=ON:verbose_runtime -OPT:Olimit=0 #OPTFLAGS = -Ofast=IP27 -64 #OPTFLAGS = -O2 -tp athlon MPFLAGS = #MPFLAGS = -mp -mpio -DMP #MPFLAGS = -DMPI #FC = pgf77 FC = f77 FFLAGS = $(OPTFLAGS) $(MPFLAGS) OBJS = full_steady_state.o porewater_steady_state.o \ porewater_update.o \ init.o initorgc.o \ o2ss.o hsio4ss.o no3ss.o nh4ss.o co3ss.o mnss.o h2s_fe_ss.o \ solid_iter.o solid_all_iter.o \ u.o moly.o \ misc.o calc_co2chem.o findalk.o \ outputmuds.o # writemudcdf.o INCLUDES = array.sizes.h defines.h rate.constants.h stoic.h tuners.h \ bottomwater.h mol_id.h species.h zlevels.h muds.mpi.h INCLUDEPATH = -I/usr/local/include -I. -I/usr/local/mpi/include LFLAGS = -lnetcdf .SUFFIXES: .c .F muds: muds.o $(OBJS) makefile $(INCLUDES) $(FC) -o muds $(FFLAGS) muds.o $(OBJS) -lnetcdf muds.constcal: muds.constcal.o $(OBJS) makefile $(INCLUDES) $(FC) -o muds $(FFLAGS) muds.constcal.o $(OBJS) -lnetcdf muds.global: muds.global.o $(OBJS) makefile $(INCLUDES) $(FC) -o muds $(FFLAGS) muds.global.o $(OBJS) -lnetcdf muds.multi: muds.multi.o $(OBJS) makefile $(INCLUDES) $(FC) -o muds $(FFLAGS) muds.multi.o $(OBJS) -lnetcdf muds.mpi: muds.mpi.o $(OBJS) makefile $(INCLUDES) mpif90 -o muds.mpi $(FFLAGS) muds.mpi.o $(OBJS) -lnetcdf clean: rm -f *.o *.f # make object files from .c files .c.o: makefile cc $(FFLAGS) $(OptionFLAGS) -c $(*).c $(LFLAGS) -I/usr/local/include/hdf # make object files from .f files .F.o: makefile $(INCLUDES) /lib/cpp -P $(INCLUDEPATH) $(*).F > $(*).f $(FC) $(FFLAGS) $(OptionFLAGS) -c $(*).f $(LFLAGS) rm $(*).f akefile $(INCLUDES) $(FC) -o muds $(FFLAGS) muds.multi.o $(OBJS) -lnetcdf muds.mpi: muds.mpi.o $(OBJS) makefile $(INCLUDES) mpif90 -o muds.mpi $(FFLAGS) muds.mpi.o $(OBJS) -lnetcdf clean: rm -f *.o *.f # make object files from .c files .c.o: mmisc.F000644 025374 000024 00000016650 10413036311 012405 0ustar00archeruser000000 000000 SUBROUTINE NEWT2(ALK,TCO2,SAL,TEMP,K1,K2,KB, * CO2,HCO3,CO3) implicit none double precision K1,K2,KB,KW double precision alk, tco2, sal, temp double precision co2, hco3, co3, tbor, tkt, tk, a,x, $ wm, ah1 double precision fh, c1, c2, c4, aht, bm, sim, pm integer icnt TBOR = 4.106E-4*SAL/35. TKT = TEMP+273 TK = TKT/100. C1 = K1/2.0 C2 = 1.0-4.0*K2/K1 C4 = TBOR*KB AHT= 0.74E-8 DO 100 ICNT=1,100 A = ALK-C4/(KB+AHT) X = A/TCO2 AH1 = C1/X*(1.0-X+SQRT(1.0+C2*X*(-2.+X))) IF(0.5E-4.GE.ABS(1.-AHT/AH1)) GOTO 200 AHT=AH1 100 CONTINUE 200 CONTINUE CO3 = (A-TCO2)/(1.0-(AH1*AH1)/(K1*K2)) HCO3 = TCO2/(1.+AH1/K1+K2/AH1) CO2 = TCO2/(1.0+K1/AH1+K1*K2/(AH1*AH1)) RETURN END subroutine co2chem(temp,sal, $ z, alk, tco2, co2,hco3,co3, $ csat, k1, k2) implicit none double precision k1, k2 double precision temp,sal double precision z,alk,tc,tco2,co2,hco3,co3,co2sat,pco2 double precision t,s, kb, kprime, kpres, csat, tk, cp, prat, $ khco2, delv, rr, pres, dk tk = temp + 15.d0 + 273.d0 C k1 and k2 (apparent), from mehrbach k1 = 13.7201 - 0.031334 * tk * - 3235.76 / tk * - 1.3E-5 * sal * tk * + 0.1032 * sal**(0.5) k1 = 10**(k1) cp = (z/10.) / 83.143 / tk prat = ( 24.2 - 0.085 * temp ) * * cp prat = exp(prat) k1 = k1 * prat k2 = - 5371.9645 * - 1.671221 * tk * + 128375.28 / tk * + 2194.3055 * LOG( tk )/2.30259 * - 0.22913 * sal * - 18.3802 * LOG( sal )/2.30259 * + 8.0944E-4 * sal * tk * + 5617.11 * LOG( sal ) / tk / 2.30259 * - 2.136 * sal / tk k2 = 10**(k2) prat = (16.4 - 0.04*temp) * * cp prat = exp(prat) k2 = k2 * prat C lymans kb kb = 2291.9/(temp+273) . + 0.01756 * (temp+273) . - 3.385 . - .32051 * (sal/1.80655)**(1./3.) kb = 10**(-kb) prat = (27.5 - 0.095*temp) * * cp prat = exp(prat) kb = kb * prat CALL NEWT(alk,tco2,sal,temp, * 0.d0,0.d0, 1 K1,K2,KB,CO2,HCO3,CO3) khco2 = exp ( * -60.2409 + 9345.17 / tk * + 23.3585 * log (tk/100.) * + sal * ( * 0.023517 - 2.3656e-4 * tk * + 4.7036e-7 * tk * tk * ) * ) c Calcite solubility, from sayles, and from millero KPRIME = 4.75E-7 C mol2 / kg2 DELV = -44 C cm3 / mol RR = 83.14 C cm3 bar / K mol PRES = Z/10 C bar DK = -.0133 C cm3 / bar mol KPRES = LOG(KPRIME) * - DELV / (RR * (TEMP + 273) ) * (PRES) * + 0.5 * DK / (RR * (TEMP + 273) ) * (PRES)**2 KPRES = EXP(KPRES) CSAT = KPRES / 0.01 return end subroutine pore_expected(pore,form,calgg,z,kmax) implicit none integer kmax double precision pore(kmax), form(kmax), calgg(kmax), $ z(kmax) double precision pore_exp, pore_asymp integer kz pore_exp = 1.5 pore_asymp = 1 - (0.483 + 0.0045 * 50 ) / 2.5 do kz = 1, kmax pore(kz) = pore_asymp + (1-pore_asymp) * $ exp( - z(kz) / pore_exp ) c pore(kz) = 0.9 enddo call pore_2_form(pore,form,kmax) return end SUBROUTINE CALC_DB_box(db,db_array, . z,delz,pore,KMAX,MLD) implicit none #include #include integer kmax double precision db, db_array(nzmax,nDbs) double precision z(kmax),delz(kmax),pore(kmax) double precision MLD, dbz integer l, i DO 10 I=2, KMAX dbz = db * exp(-z(i)/mld) c write(6,*) i, z(i), dbz IF(I.EQ.2) THEN db_array(i,dbtop) = 0 db_array(i,dbbot) = db db_array(i,DbPlsS) = DB 1 * 2 / ( (DELZ(I) + DELZ(I+1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I+1) )/(2*(1-PORE(I))) db_array(i,DbMinS) = 0. ELSE IF(Z(I).LE.MLD) THEN db_array(i,dbtop) = db db_array(i,dbbot) = db db_array(i,DbPlsS) = DB 1 * 2 / ( (DELZ(I) + DELZ(I+1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I+1) )/(2*(1-PORE(I))) db_array(i,DbMinS) = DB 1 * 2 / ( (DELZ(I) + DELZ(I-1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I-1) )/(2*(1-PORE(I))) ELSE IF(Z(I-1).LE.MLD) THEN db_array(i,DbPlsS) = 0. db_array(i,DbMinS) = DB 1 * 2 / ( (DELZ(I) + DELZ(I-1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I-1) )/(2*(1-PORE(I))) ELSE db_array(i,dbtop) = 0 db_array(i,dbbot) = 0 db_array(i,DbPlsS) = 0. db_array(i,DbMinS) = 0. END IF db_array(i,DbPlsT) = db_array(i,DbPlsS) db_array(i,DbMinT) = db_array(i,DbMinS) 10 CONTINUE RETURN END SUBROUTINE CALC_DB(db,db_array, . z,delz,pore,kmax,mld) implicit none #include #include integer kmax double precision db, db_array(nzmax,nDbs) double precision z(kmax),delz(kmax),pore(kmax) double precision MLD integer l, i DO 10 I=3, KMAX-1 #ifdef DbLinear db_array(i,DbTop) = db * MAX(0.,10-z(i-1)) db_array(i,DbBot) = db * MAX(0.,10-z(i)) #else #ifdef DbCutoff if(z(i-1) .LT. 8.) then db_array(i,DbTop) = db * exp(-(z(i-1)/mld)**2) else db_array(i,DbTop) = 0 endif if(z(i) .LT. 8.) then db_array(i,DbBot) = db * exp(-(z(i)/mld)**2) else db_array(i,DbBot) = 0. endif #else db_array(i,DbTop) = db * exp(-(z(i-1)/mld)**2) db_array(i,DbBot) = db * exp(-(z(i)/mld)**2) #endif #endif db_array(i,DbPlsS) = Db_array(I,DbBot) 1 * 2 / ( (DELZ(I) + DELZ(I+1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I+1) )/(2*(1-PORE(I))) db_array(i,DbMinS) = Db_array(I,DbTop) 1 * 2 / ( (DELZ(I) + DELZ(I-1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I-1) )/(2*(1-PORE(I))) 10 CONTINUE i = 2 db_array(i,DbTop) = 0. #ifdef DbLinear db_array(i,DbBot) = db * MAX(0.,10-z(i)) #else db_array(i,DbBot) = db * exp(-(z(i)/mld)**2) #endif db_array(i,DbPlsS) = Db_array(I,DbBot) 1 * 2 / ( (DELZ(I) + DELZ(I+1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I+1) )/(2*(1-PORE(I))) db_array(i,DbMinS) = 0. i=kmax #ifdef DbLinear db_array(i,DbTop) = db * MAX(0.,10-z(i-1)) #else db_array(i,DbTop) = db * exp(-(z(i-1)/mld)**2) #endif db_array(i,DbBot) = 0. db_array(i,DbPlsS) = 0. db_array(i,DbMinS) = Db_array(I,DbTop) 1 * 2 / ( (DELZ(I) + DELZ(I-1)) * DELZ(I) ) 2 * ( 1-PORE(I)+1-PORE(I-1) )/(2*(1-PORE(I))) do i=2,kmax db_array(i,DbPlsT) = db_array(i,DbPlsS) db_array(i,DbMinT) = db_array(i,DbMinS) enddo RETURN END db_array(i,DbTop) = db * MAX(0.,10-z(i-1)) #else db_array(i,DbTop) = db * emnss.F000644 025374 000024 00000176073 10413036311 012440 0ustar00archeruser000000 000000 #include #define j0_mn_resp 1 #define j0_mn_ox 2 #define j1_mnc_pcp 3 #define xads_src 4 #define org_react 5 #ifdef MnAdsorption c#define MnAdsorptionOx c#define MnAdsorptionPH #endif c#define StdOut SUBROUTINE mnss( $ i_pw_only, $ runid,idebug, $ pw_conc, $ sl_ml, sl_gg, . rc, $ molwt, $ rain_mno2_external, $ omega,db_array, $ z_level, $ diff_array, irrig_array, $ z, delz, form, pore, kmax, $ irrig_oxidation, $ pw_react_tot,diffescape_mn2p_sink, $ mn2p_0,mn2p_scale,d_ads, $ rct) implicit none #include #include #include #include #include integer L_Mn2, L_MnO, L_MnC parameter ( L_Mn2=1, L_MnO=2, L_MnC=3) Integer kmax, i_pw_only, runid, idebug c external variables DOUBLE PRECISION pw_conc(nzmax,nsolutemax), $ sl_ml(nzmax,nsolidmax), sl_gg(nzmax,nsolidmax) double precision rc(nrcmax), $ z_level(nzlevels), $ molwt(nsolidmax), $ rain_mno2_external, $ omega(nzmax),db_array(nzmax,nDBs) double precision $ diff_array(nzmax,2), irrig_array(nzmax) double precision z(nzmax), delz(nzmax), form(nzmax), $ pore(nzmax) double precision rct(nzmax,6) ! resp, ox, mnc, xads_src, org_react double precision pw_react_tot,diffescape_mn2p_sink, $ pw_irrig_flux,burial_mn,mn_balance, $ org_consume(norgs) double precision irrig_oxidation(nzmax) c internal variables double precision x(nzmax,3), dpls(nzmax,3), dmin(nzmax,3) double precision r(nzmax,3), dr(nzmax,3,3,3) #ifdef MnRedepositIrrig c double precision dr2(nzmax) #endif #ifdef MnIrrigOxidation double precision tot_reducing(nzmax), d_irrig_mn2p_sink #endif double precision a(3*nzmax,3*nzmax), b(3*nzmax) ! for gaussj, i_pw_only=0 double precision aa(nzmax), bb(nzmax), cc(nzmax), $ rr(nzmax), uu(nzmax) ! for tridiag, i_pw_only=1 integer negflag(nzmax,3), any_negflag c double precision j0_mn_ox(nzmax), j0_mn_resp(nzmax), c $ j1_mnc_pcp(nzmax), double precision ddmn2_mnc_pcp(nzmax) double precision weight(3), mno2_resolve double precision resp_mn2p_source, irrig_mn2p_sink, $ co3_mn2p_sink, ox_mn2p_sink, diffox_mn2p_sink, $ redeposit_mn2p_sink,mn2p_conserve double precision totlocalsource, tottopsource double precision ztop, zbot double precision ggfac, burial double precision org_react_dummy(nzmax,norgs), $ org_consume_dummy(norgs) integer kz,kz1,ix,iy,iz,ioc, $ imn2prow,imno2row,imnco3row, $ imn2pcol,imno2col,imnco3col, $ row_index, col_index integer i_zmno2_iter, n_zmno2_iters, $ n_zmno2_kick_interval, $ i_mn2p_0, n_mn2p_0, $ n_zmno2_trials,n_zmno2_step double precision rc_scale double precision mn2p_0, mn2p_scale, mn2p_oxic(nzmax), $ mn2p_prod_tot, mn2p_sink_tot, $ mn2p_0_old, z_mno2_old,diffescape_mn2p_sink_old #ifdef MnAdsorption double precision k_ads,xads(nzmax), dxdmn2(nzmax), $ dxdmno(nzmax), sites_tot(nzmax), ! xads_src(nzmax), $ xads_src_tot #endif double precision xads_tot, d_ads if(idebug .EQ. -999) then return endif if(rain_mno2_external .LT. 1.e-20) then do kz=2,kmax pw_conc(kz,IMn2p) = 0. sl_ml(kz,IMnO2) = 0. sl_gg(kz,IMnO2) = 0. enddo pw_react_tot = 0. diffescape_mn2p_sink = 0. do ioc=1,norgs org_consume(ioc) = 0. enddo return endif if(i_pw_only .EQ. 1) then n_zmno2_iters = 1 else n_zmno2_iters = 50 ! 200 endif n_zmno2_kick_interval = 50 n_zmno2_trials = 4 n_zmno2_step = 1 n_mn2p_0 = 30 mno2_resolve = 1.e-2 #ifdef MnAdsorption k_ads = 10.**(3.2) #endif do ioc=1,norgs org_consume(ioc) = 0 enddo ztop = z_level(KOxic) zbot = z(kmax) c if(i_recalculate .EQ. 1) then do kz=1,kmax x(kz,L_Mn2) = pw_conc(kz,IMn2p) x(kz,L_MnO) = sl_gg(kz,IMnO2) x(kz,L_MnC) = sl_gg(kz,IMnCO3) mn2p_oxic(kz) = -99. dpls(kz,L_Mn2) = diff_array(kz,1) dmin(kz,L_Mn2) = diff_array(kz,2) do ix=L_MnO, L_MnC dpls(kz,ix) = db_array(kz,DbPlsS) dmin(kz,ix) = db_array(kz,DbMinS) enddo rct(kz,j0_mn_resp) = 0. rct(kz,j1_mnc_pcp) = 0. rct(kz,j0_mn_ox) = 0. enddo mn2p_0_old = mn2p_0 z_mno2_old = z_level(KMnO2) diffescape_mn2p_sink_old = 0. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do i_zmno2_iter=1, n_zmno2_iters cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do i_mn2p_0 = 1, n_mn2p_0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Initialize do kz=2, kmax do ix=1,3 r(kz,ix) = 0. do iy=1,3 do iz=1,3 dr(kz,ix,iy,iz) = 0. enddo enddo enddo #ifdef MnRedepositIrrig c dr2(kz) = 0. #endif enddo do kz=1,nzmax*3 do iz=1,nzmax*3 a(kz,iz) = 0. enddo b(kz) = 0. enddo do ioc=1,norgs org_consume_dummy(ioc) = 0. do kz=2,kmax org_react_dummy(kz,ioc) = 0. enddo enddo ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #ifdef MnAdsorption c adsorption for Mn2+ c k_ads = 0. c adsorption system tends to blow up when organic carbon reaction c rates get too high, so I shamelessly kill adsorption if(z_level(KMNO2) .LT. 0.5) then k_ads = 0. endif do kz=1,kmax ! setup sites_tot(kz) = ( $ ( x(kz,L_MnO) ! g/g $ + sl_gg(kz,IClay) * 8.5E-4 * 0.5 $ ) $ * 27.e-3 ! mol/l sites $ + ( sl_gg(kz,IFeOOH) $ + sl_gg(kz,IClay) * 4.7E-2 * 0.7 $ ) $ * 11.e-3 $ ) $ * 2.5 * (1-pore(kz)) * 1000. #ifdef StdOut write(6,'(i4,4f15.5)') kz, x(kz,L_Mn2), sites_tot(kz), $ x(kz,l_mn2), pw_conc(kz,ife2p) #endif xads(kz) = k_ads * x(kz,L_Mn2) * sites_tot(kz) $ / ( $ 1. $ + k_ads*x(kz,L_Mn2) $ + k_ads*pw_conc(kz,IFe2P) $ ) dxdmn2(kz) = sites_tot(kz) * k_ads $ * ( 1 + k_ads*pw_conc(kz,IFe2P) ) $ / ( $ 1. $ + k_ads*x(kz,L_Mn2) $ + k_ads*pw_conc(kz,IFe2P) $ )**2 dxdmno(kz) = k_ads * x(kz,L_Mn2) $ * 2.5 * (1-pore(kz)) * 1000. $ * 11.e-3 ! mol/l sites $ / ( $ 1. $ + k_ads*x(kz,L_Mn2) $ + k_ads*pw_conc(kz,IFe2P) $ ) rct(kz,xads_src) = 0. ! defined as Mn2+ src, ! same units as rxn rate enddo d_ads = k_ads * sites_tot(2) ! simple dist coeff at sed surf $ / ( $ 1. $ + k_ads*x(2,L_Mn2) $ + k_ads*pw_conc(2,IFe2P) $ ) #endif ! MnAdsorption xads_tot = 0. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Compute Reaction Rates c-------------------------------------- c use last rates to get sum reactions (diffox) c -> mn2p_0 -> oxidation rates resp_mn2p_source = 0. irrig_mn2p_sink = 0. co3_mn2p_sink = 0. do kz=2,kmax resp_mn2p_source = resp_mn2p_source $ + rct(kz,j0_mn_resp) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr co3_mn2p_sink = co3_mn2p_sink $ + rct(kz,j1_mnc_pcp) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) enddo call irrig_flux(x(1,L_Mn2), $ irrig_array, $ pore,delz,kmax, $ irrig_mn2p_sink) c the diffusion flux into the oxic zone diffox_mn2p_sink = $ resp_mn2p_source $ - co3_mn2p_sink $ - irrig_mn2p_sink diffox_mn2p_sink = max(0., diffox_mn2p_sink) c diffox_mn2p_sink = min(diffox_mn2p_sink, c $ 1.e6*rain_mno2_external) c new mn2p concentration at z_level(Koxic) mn2p_scale = sqrt( $ diff_array(1,1) $ / ( rc(JMNOX) #ifdef MnAdsorptionOx $ * (1+d_ads) #endif $ ) $ ) #ifdef MnOx mn2p_0 = ! concentration at the oxic boundary $ diffox_mn2p_sink $ / 3.15e7 $ / mn2p_scale $ / rc(JMnOX) #ifdef MnAdsorptionOx $ / (1+d_ads) #endif $ * 1000. #else mn2p_0 = 0. #endif c------------------------------------------------------ c new rates, including oxidation rates call mn_rates(x(1,L_Mn2),sl_ml,rc, #ifdef MnAdsorptionOx $ d_ads, #endif $ mn2p_0, mn2p_scale, $ z,z_level,delz,kmax, $ rct, mn2p_oxic, $ ddmn2_mnc_pcp) c this also sets mn2p_oxic profile c compute diffusive escape ox_mn2p_sink = 0. do kz=2,kmax ox_mn2p_sink = ox_mn2p_sink $ + rct(kz,j0_mn_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo diffescape_mn2p_sink = $ resp_mn2p_source $ - ox_mn2p_sink $ - co3_mn2p_sink $ - irrig_mn2p_sink diffescape_mn2p_sink = MAX(0.,diffescape_mn2p_sink) mn2p_conserve = $ resp_mn2p_source $ - ox_mn2p_sink $ - co3_mn2p_sink $ - diffescape_mn2p_sink $ - irrig_mn2p_sink c time (step) filter weight(1) = 1. diffescape_mn2p_sink = weight(1) * diffescape_mn2p_sink $ + (1.-weight(1)) * diffescape_mn2p_sink_old diffescape_mn2p_sink_old = diffescape_mn2p_sink #ifdef StdOut ox_mn2p_sink = 0. do kz=2,kmax ox_mn2p_sink = ox_mn2p_sink $ + rct(kz,j0_mn_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo mn2p_conserve = $ resp_mn2p_source $ - ox_mn2p_sink $ - co3_mn2p_sink $ - diffescape_mn2p_sink $ - irrig_mn2p_sink #endif c------------------------------------------------------------ c Adjust oxidation rates for irrigation and redeposition c oxidation by irrigated oxidizing capacity #ifdef MnIrrigOxidation d_irrig_mn2p_sink = 0. do kz=2,kmax tot_reducing(kz) = $ + irrig_array(kz) * x(kz,L_Mn2) * 2. if(irrig_oxidation(kz) .GT. 0 $ .AND. $ mn2p_oxic(kz) .LT. 0) then if(irrig_oxidation(kz) .GT. tot_reducing(kz)) then rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) d_irrig_mn2p_sink = d_irrig_mn2p_sink $ + irrig_array(kz) $ * x(kz,L_Mn2) $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr else ! flux of reducing > flux of oxidizing rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) $ * irrig_oxidation(kz) / tot_reducing(kz) d_irrig_mn2p_sink = d_irrig_mn2p_sink $ + irrig_array(kz) * x(kz,L_Mn2) $ * irrig_oxidation(kz) / tot_reducing(kz) $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr endif endif enddo irrig_mn2p_sink = irrig_mn2p_sink $ - d_irrig_mn2p_sink #ifdef StdOut ox_mn2p_sink = 0. do kz=2,kmax ox_mn2p_sink = ox_mn2p_sink $ + rct(kz,j0_mn_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo mn2p_conserve = $ resp_mn2p_source $ - ox_mn2p_sink $ - co3_mn2p_sink $ - diffescape_mn2p_sink $ - irrig_mn2p_sink c write(6,*) "After IrrigOx Mn2p_conserve ", mn2p_conserve #endif #endif MnIrrigOxidation c now readjust oxidation rates for redeposition #ifdef MnRedepositIrrig do kz=2,kmax if(z(kz) .LT. z_level(KOXIC)) then rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ + irrig_mn2p_sink * rc(JMnIR) $ / 3.15e7 * 1000. $ / z_level(KOXIC) elseif(z(kz-1) .LT. z_level(KOXIC)) then rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ + irrig_mn2p_sink * rc(JMnIR) $ / 3.15e7 * 1000. $ / z_level(KOXIC) $ * (z_level(KOXIC)-z(kz-1)) / delz(kz) endif enddo #ifdef MnRedepositIrrigTopLayer j0_mn_ox(2) = j0_mn_ox(2) $ + irrig_mn2p_sink * rc(JMnIR) $ / 3.15e7 * 1000. $ / delz(2) irrig_mn2p_sink = irrig_mn2p_sink $ * (1.-rc(JMnIR)) #endif #ifdef OldShit redeposit_mn2p_sink = 0. do kz=2,kmax c if(mn2p_oxic(kz) .LT. 0) then j0_mn_ox(2) = j0_mn_ox(2) $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) $ * delz(kz) / delz(2) $ * rc(JMnIR) ! units mol/l tot sec dr2(kz) = dr2(kz) $ + irrig_array(kz) $ * pore(kz) $ * delz(kz) / delz(2) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(2))*1000) $ * rc(JMnIR) redeposit_mn2p_sink = redeposit_mn2p_sink $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) $ * delz(kz) / delz(2) $ * rc(JMnIR) ! units mol/l tot sec $ / 1000. * 3.15e7 $ * delz(2) c endif enddo irrig_mn2p_sink = irrig_mn2p_sink $ * (1.-rc(JMnIR)) #endif #ifdef StdOut ox_mn2p_sink = 0. do kz=2,kmax ox_mn2p_sink = ox_mn2p_sink $ + rct(kz,j0_mn_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo mn2p_conserve = $ resp_mn2p_source $ - ox_mn2p_sink $ - co3_mn2p_sink $ - diffescape_mn2p_sink $ - irrig_mn2p_sink c write(6,*) "After RedepositIrrig ", mn2p_conserve #endif #endif #ifdef MnRedepositDiffusion j0_mn_ox(2) = j0_mn_ox(2) $ + diffescape_mn2p_sink ! units mol / cm2 yr $ * rc(JMnDR) $ / delz(2) * 1000. / 3.15E7 diffescape_mn2p_sink = diffescape_mn2p_sink $ * (1.-rc(JMnDR)) #ifdef StdOut ox_mn2p_sink = 0. do kz=2,kmax ox_mn2p_sink = ox_mn2p_sink $ + rct(kz,j0_mn_ox) $ / 1000. * 3.15e7 $ * delz(kz) enddo mn2p_conserve = $ resp_mn2p_source $ - ox_mn2p_sink $ - co3_mn2p_sink $ - diffescape_mn2p_sink $ - irrig_mn2p_sink c write(6,*) "After RedepositDiff ", mn2p_conserve #endif #endif kz = kz cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c transport operators -- diffusion do kz=2,kmax ! all cells 2:N get upward diffusion do ix=1,3 r(kz,ix) = r(kz,ix) $ - dmin(kz,ix) * (x(kz,ix)-x(kz-1,ix)) dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - dmin(kz,ix) dr(kz,ix,ix,1) = dr(kz,ix,ix,1) $ + dmin(kz,ix) enddo enddo do kz=2,kmax-1 ! exclude cell N for downward diffusion do ix=1,3 r(kz,ix) = r(kz,ix) $ + dpls(kz,ix) * (x(kz+1,ix)-x(kz,ix)) dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - dpls(kz,ix) ! dRi/dxi(n) dr(kz,ix,ix,3) = dr(kz,ix,ix,3) $ + dpls(kz,ix) ! dRi/dxi(n+1) enddo enddo totlocalsource = 0. tottopsource = 0. c -- irrigation do kz=2,kmax r(kz,L_Mn2) = r(kz,L_Mn2) $ - irrig_array(kz) * x(kz,L_Mn2) dr(kz,L_Mn2,L_Mn2,2) = dr(kz,L_Mn2,L_Mn2,2) $ - irrig_array(kz) #ifdef MnRedepositIrrigLocal r(kz,L_MnO) = r(kz,L_MnO) $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(kz))*1000) dr(kz,L_MnO,L_Mn2,2) = dr(kz,L_MnO,L_Mn2,2) $ + irrig_array(kz) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(kz))*1000) totlocalsource = totlocalsource $ + irrig_array(kz) * x(kz,L_Mn2) ! mol/l pw s $ * pore(kz) ! mol/l $ * delz(kz) #endif #ifdef MnRedepositIrrigOld r(2,L_MnO) = r(2,L_MnO) $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) $ * delz(kz) / delz(2) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(2))*1000) dr2(kz) = dr2(kz) $ + irrig_array(kz) $ * pore(kz) $ * delz(kz) / delz(2) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(2))*1000) tottopsource = tottopsource $ + irrig_array(kz) * x(kz,L_Mn2) $ * pore(kz) $ * delz(kz) / delz(2) $ * delz(2) #endif enddo c -- omega (solid advection) do kz=3,kmax do ix=2,3 r(kz,ix) = r(kz,ix) $ + x(kz-1,ix) $ * omega(kz-1) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 $ - x(kz,ix) $ * omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 dr(kz,ix,ix,1) = dr(kz,ix,ix,1) $ + omega(kz-1) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 enddo enddo kz = 2 do ix=2,3 r(kz,ix) = r(kz,ix) $ - x(kz,ix) $ * omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 dr(kz,ix,ix,2) = dr(kz,ix,ix,2) $ - omega(kz) . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 enddo ix=2 ! solid rain r(kz,ix) = r(kz,ix) $ + rain_mno2_external * molwt(IMnO2) . / delz(2) . / ( 1 - pore(2) ) . / 2.5 #ifdef MnAdsorption #ifdef MnAdsorptionMixing do kz=3,kmax ! cells 3:N get upward diffusion if(mn2p_oxic(kz) .LT. 0.) then r(kz,L_Mn2) = r(kz,L_Mn2) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now Dbtop /dz(interp) /dzi $ / 3.15e7 ! cm2/sec $ * ( xads(kz) - xads(kz-1) ) ! units mol/l pw sec $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * ( xads(kz) - xads(kz-1) ) ! units mol/l tot s xads_tot = xads_tot $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ * ( xads(kz) - xads(kz-1) ) ! units mol/l tot s $ / 1000. * delz(kz) ! mol / cm2 s dr(kz,L_Mn2,L_Mn2,2) = dr(kz,L_Mn2,L_Mn2,2) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmn2(kz) ) dr(kz,L_Mn2,L_Mn2,1) = dr(kz,L_Mn2,L_Mn2,1) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmn2(kz-1) ) dr(kz,L_Mn2,L_MnO,2) = dr(kz,L_Mn2,L_MnO,2) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmno(kz) ) dr(kz,L_Mn2,L_MnO,1) = dr(kz,L_Mn2,L_MnO,1) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmno(kz-1) ) endif enddo do kz=2,kmax-1 if(mn2p_oxic(kz) .LT. 0.) then r(kz,L_Mn2) = r(kz,L_Mn2) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * ( xads(kz+1) - xads(kz) ) $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * ( xads(kz+1) - xads(kz) ) xads_tot = xads_tot $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ * ( xads(kz+1) - xads(kz) ) $ / 1000. * delz(kz) ! mol / cm2 s dr(kz,L_Mn2,L_Mn2,2) = dr(kz,L_Mn2,L_Mn2,2) $ - db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmn2(kz) ) dr(kz,L_Mn2,L_Mn2,3) = dr(kz,L_Mn2,L_Mn2,3) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmn2(kz+1) ) dr(kz,L_Mn2,L_MnO,2) = dr(kz,L_Mn2,L_MnO,2) $ - db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmno(kz) ) dr(kz,L_Mn2,L_MnO,1) = dr(kz,L_Mn2,L_MnO,1) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( dxdmno(kz+1) ) endif enddo #endif #ifdef MnAdsorptionBurial c burial flux of adsorbed Mn2+ do kz=3,kmax c if(mn2p_oxic(kz-1) .LT. 0) then r(kz,L_Mn2) = r(kz,L_Mn2) ! incoming stuff $ + xads(kz-1) ! mol/l total $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) ! incoming stuff $ + xads(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 xads_tot = xads_tot $ + xads(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / (1-pore(kz)) $ / 2.5 / 1000 ! mol / cm2 yr dr(kz,L_Mn2,L_Mn2,1) = dr(kz,L_Mn2,L_Mn2,1) $ + dxdmn2(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 dr(kz,L_Mn2,L_MnO,1) = dr(kz,L_Mn2,L_MnO,1) $ + dxdmno(kz-1) ! mol/l $ * omega(kz-1) ! g/cm2 yr $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 c endif enddo do kz=2,kmax c if(mn2p_oxic(kz) .LT. 0) then r(kz,L_Mn2) = r(kz,L_Mn2) ! outgoing stuff $ - xads(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 $ / pore(kz) rct(kz,xads_src) = rct(kz,xads_src) ! outgoing stuff $ - xads(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 3.15e7 xads_tot = xads_tot $ - xads(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / (1-pore(kz)) $ / 2.5 / 1000. dr(kz,L_Mn2,L_Mn2,2) = dr(kz,L_Mn2,L_Mn2,2) $ - dxdmn2(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 dr(kz,L_Mn2,L_MnO,2) = dr(kz,L_Mn2,L_MnO,2) $ - dxdmno(kz) ! mol/l $ * omega(kz) ! g/cm2 yr $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 c endif enddo #endif ! MnAdsorptionBurial #endif ! MnAdsorption #ifdef MnReactions do kz=2, kmax c respiration r(kz,l_Mn2) = r(kz,l_Mn2) + rct(kz,j0_mn_resp) $ / pore(kz) r(kz,L_MnO) = r(kz,L_MnO) - rct(kz,j0_mn_resp) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(kz))*1000) c mn2+ oxidation c r(kz,l_mn2) = r(kz,l_mn2) ! commented because Mn2+ implicit in oxic zone c $ - rct(kz,j0_mn_ox) c dr(kz,l_mn2,L_MN2,2) = dr(kz,L_MN2,L_MN2,2) r(kz,L_MNO) = r(kz,L_MNO) $ + rct(kz,j0_mn_ox) $ * 3.15e7 $ * molwt(IMnO2)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_MNO,L_MN2,2) = dr(kz,L_MNO,L_MN2,2) c mnco3 precipitation r(kz,L_MN2) = r(kz,L_MN2) $ - rct(kz,j1_mnc_pcp) $ / pore(kz) dr(kz,L_MN2,L_MN2,2) = dr(kz,L_MN2,L_MN2,2) $ - ddmn2_mnc_pcp(kz) $ / pore(kz) r(kz,L_MNc) = r(kz,L_MNC) $ + rct(kz,j1_mnc_pcp) $ * 3.15e7 $ * molwt(IMnCO3)/(2.5*(1-pore(kz))*1000) ! ml to gg dr(kz,L_MnC,L_Mn2,2) = dr(kz,L_MnC,L_Mn2,2) $ + ddmn2_mnc_pcp(kz) $ * 3.15e7 $ * molwt(IMnCO3)/(2.5*(1-pore(kz))*1000) ! ml to gg enddo c relax to specified exponential concentrations in the oxic zone do kz=2,kmax if(mn2p_oxic(kz) .GT. -1.) then c cell center is oxic -- toss lots of complicated stuff out the window c relax to the assumed exponential profile r(kz,L_Mn2) = x(kz,L_Mn2) - mn2p_oxic(kz) c dont care about other species do ix=1,3 dr(kz,L_Mn2,ix,2) = 0. enddo c or diffusion up and down dr(kz,L_Mn2,L_Mn2,1) = 0. dr(kz,L_Mn2,L_Mn2,3) = 0. c d/dconc = 1. dr(kz,L_Mn2,L_Mn2,2) = 1. endif enddo #endif c load arrays if(i_pw_only .EQ. 1) then do kz=1,kmax-2 aa(kz+1) = dr(kz+2,L_Mn2,L_Mn2,1) ! dfmins(j+2) in nh4ss bb(kz) = dr(kz+1,L_Mn2,L_Mn2,2) ! dfzero(j+1) cc(kz) = dr(kz+1,L_Mn2,L_Mn2,3) ! dfplus(j+1) enddo bb(kmax-1) = dr(kmax,L_Mn2,L_Mn2,2) ! dfzero(kmax) $ + dr(kmax,L_Mn2,L_Mn2,3) ! dfplus(kmax) do kz=1,kmax-1 rr(kz) = - r(kz+1,L_Mn2) enddo call tridiag(runid,idebug,aa,bb,cc,rr,uu,kmax-1) weight(L_Mn2) = 0.25 do kz=2,kmax if(pw_conc(kz,iMn2p) + uu(kz-1) .GT. 0.) then pw_conc(kz,iMn2p) = pw_conc(kz,iMn2p) $ + uu(kz-1) * weight(L_Mn2) else pw_conc(kz,iMn2p) = 0.1 * pw_conc(kz,iMn2p) endif enddo else ! it's doing solids as well do ix = 1,3 do kz = 2, kmax row_index = (kz-1) + (ix-1) * (kmax-1) c residuals b(row_index) = -r(kz,ix) c local derivatives (same box, all species) do iy=1,3 col_index = (kz-1) + (iy-1) * (kmax-1) a(row_index,col_index) = $ a(row_index,col_index) $ + dr(kz,ix,iy,2) enddo enddo c vertical derivates (same species) do kz=3,kmax-1 row_index = (kz-1) + (ix-1) * (kmax-1) do iz=1,3,2 col_index = row_index + iz - 2 a(row_index,col_index) = $ a(row_index,col_index) $ + dr(kz,ix,ix,iz) enddo enddo kz=2 row_index = (kz-1) + (ix-1) * (kmax-1) iz=3 col_index = row_index + iz - 2 a(row_index,col_index) = a(row_index,col_index) $ + dr(kz,ix,ix,iz) kz=kmax row_index = (kz-1) + (ix-1) * (kmax-1) iz=1 col_index = row_index + iz - 2 a(row_index,col_index) = a(row_index,col_index) $ + dr(kz,ix,ix,iz) enddo #ifdef MnRedepositIrrigOld do kz=2,kmax row_index = (2-1) + (L_MnO-1) * (kmax-1) col_index = (kz-1) + (L_Mn2-1) * (kmax-1) a(row_index,col_index) = a(row_index,col_index) $ + dr2(kz) enddo #endif call gaussj(runid,idebug, $ a,(kmax-1)*3,nzmax*3,b,1,1) do ix=1,3 weight(ix) = 0.25 enddo any_negflag = 0 do kz = 2, kmax do ix = 1, 3 row_index = (ix-1)*(kmax-1)+(kz-1) c if(x(kz,ix) .GT. 0 c $ .AND. b(row_index) .GT. 10.*x(kz,ix)) then c x(kz,ix) = x(kz,ix) * 10. c else if(x(kz,ix) + b(row_index) .GE. 0) then x(kz,ix) = x(kz,ix) + b(row_index) $ * weight(ix) negflag(kz,ix) = 0 else x(kz,ix) = 0.1 * x(kz,ix) negflag(kz,ix) = 1 any_negflag = 1 endif #ifdef StdOut if(x(kz,ix) .LT. 0) then write(6,*) "negative x ", kz, ix, x(kz,ix) endif #endif x(kz,ix) = MAX(x(kz,ix),0.) c x(kz,ix) = MIN(x(kz,ix), 1.E6) enddo x(kz,L_Mn2) = MIN(x(kz,L_Mn2), 0.1) ! 10,000 uM ought to be enough enddo c Assess -- are we there yet? call irrig_flux(x(1,L_Mn2), $ irrig_array, $ pore,delz,kmax, $ pw_irrig_flux) #ifdef MnIrrigOxidation pw_irrig_flux = pw_irrig_flux $ - d_irrig_mn2p_sink #endif #ifdef MnRedepositIrrig pw_irrig_flux = pw_irrig_flux $ * (1. - rc(JMnIR)) #endif burial_mn = omega(kmax) $ * x(kmax,L_MnC) ! g Mn /cm2 yr $ / molwt(IMnO2) ! mol Mn /cm2 yr #ifdef MnAdsorptionBurialDiagnostics c why the hell doesnt this work? burial_mn = burial_mn $ + omega(kmax) ! g / cm2 yr $ * xads(kmax) ! mol/l $ / 2.5 / (1-pore(kmax)) / 1000. #endif if(z_level(KMnO2) .GT. z(kmax)-1.) then burial_mn = burial_mn $ + omega(kmax) $ * x(kmax,L_MnO) ! g Mn /cm2 yr $ / molwt(IMnO2) endif mn_balance = ( rain_mno2_external $ - diffescape_mn2p_sink $ - pw_irrig_flux $ - burial_mn $ ) / rain_mno2_external c -ve => too many sinks; z_level(KMnO2) too deep #ifdef StdOut write(6,199) "mn2p_0 iter ", $ i_mn2p_0, 1 mn2p_0, 2 rain_mno2_external, 3 resp_mn2p_source, 4 diffox_mn2p_sink, 5 ox_mn2p_sink, 6 diffescape_mn2p_sink, 7 pw_irrig_flux, 8 xads_tot, 9 burial_mn, $ mn_balance 199 format(a20,i4,10g11.4) #endif c if( i_mn2p_0 .EQ. 3 c $ .AND. any_negflag .EQ. 0) then c goto 109 c endif endif ! i_pw_only=0, i.e. do solids too enddo ! i_mn2p_0 c 109 continue ! useless? if(i_pw_only .EQ. 1) then pw_react_tot = 0. do kz=2,kmax pw_react_tot = pw_react_tot $ + rct(kz,j0_mn_resp) $ * delz(kz) / 1000 * 3.15E7 pw_react_tot = pw_react_tot $ - rct(kz,j0_mn_ox) $ * delz(kz) / 1000 * 3.15E7 enddo return else if( i_zmno2_iter .LT. n_zmno2_trials ) then #ifdef StdOut write(6,*) "warming up" #endif ix = ix c goto 20 ! warming up elseif( i_zmno2_iter .EQ. n_zmno2_trials ) then if(z_level(KMnO2) .EQ. z(kmax)) then if(negflag(kmax,L_MnO) .EQ. 0) then if(ABS(mn_balance) .LT. mno2_resolve) then #ifdef StdOut write(6,*) "Fully manganized. exiting." #endif goto 10 ! done endif endif else ! z_level(KMnO2) started out less than z(kmax) if(ABS(mn_balance) .LT. mno2_resolve $ .AND. negflag(kmax,L_MnO) .EQ. 0) then #ifdef StdOut write(6,*) "last zMnO2 still OK" #endif goto 10 elseif(mn_balance .LT. 0) then ! reset the old limits for the search #ifdef StdOut write(6,*) "initial z_level(KMnO2) too deep" #endif ztop = z_level(Koxic) zbot = z_level(KMnO2) else #ifdef StdOut write(6,*) "initial z_level(KMnO2) too shallow" #endif ztop = z_level(KMnO2) zbot = z(kmax) c z_level(KMnO2) = (ztop + zbot) / 2 endif endif else ! #iterations greater than trial period if(ABS(mn_balance) .LT. mno2_resolve $ ) then c $ .AND. negflag(kmax,L_MnO) .EQ. 0 #ifdef StdOut write(6,*) "found OK zMnO2" #endif goto 10 endif if( $ MOD(i_zmno2_iter,n_zmno2_kick_interval) .EQ. 0 $ .AND. $ i_zmno2_iter .LT. n_zmno2_iters $ ) then #ifdef StdOut write(6,*) "Kick me" #endif c ztop = z_level(KMnO2) c $ - 2. c ztop = MAX(ztop,z_level(KOxic)) c ztop = z_level(KOxic) c zbot = z_level(KMnO2) c $ + 20. c zbot = MIN(zbot,z(kmax)) c n_mn2p_0 = 300 if(mn_balance .LT. 0) then ztop = z_level(KOxic) else zbot = z(kmax) endif z_level(KMnO2) = (ztop+zbot)/2 elseif( MOD( i_zmno2_iter $ - n_zmno2_trials,n_zmno2_step $ ) $ .EQ. 0 $ ) then if(mn_balance .LT. 0) then zbot = z_level(KMnO2) else ztop = z_level(KMnO2) endif #ifdef WhatTheFuckIsThis if(mn_balance .GT. 0 $ .AND. $ burial_mn .LT. rain_mno2_external / 10.) then zbot = zbot + 1. endif #endif endif z_level(KMnO2) = (ztop+zbot)/2. #ifdef StdOut write(6,*) "Adjusting zMnO2 search limits", $ i_zmno2_iter write(6,'(a20,3f12.6)') "Trying z(mno2) = ", $ zbot, z_level(KMnO2), ztop if(i_zmno2_iter .EQ. 15) then write(6,*) "here I am" endif #endif c if(ztop .EQ. zbot) then c goto 10 c endif endif ! test iteration number endif 20 continue ! land here to avoid resetting z_level(KMnO2) enddo ! i_zmno2_iter 10 continue ! land here to escape the loop if(ABS(mn_balance) .GT. mno2_resolve) then ! drop 10 and punt c if(ABS(mn_balance) .GT. 100) then ! drop 10 and punt #ifdef StdOut write(6,*) "didn't get there in mn" #endif mn2p_0 = mn2p_0_old c z_level(KMnO2) = z_mno2_old else ! OK accept the results weight(1) = 1. if(z_level(KMnO2) .GT. z_mno2_old) then c #ifdef StdOut #ifdef StdOut if(z_level(KMnO2) .GT. 2*z_mno2_old) then write(6,*) "squashing sudden increase in z_mno2" endif #endif c#endif weight(1) = ( z_mno2_old / z_level(KMnO2) )**2 endif c mn2p_0 = weight(1) * mn2p_0 c $ + (1-weight(1)) * mn2p_0_old z_level(KMnO2) = weight(1) * z_level(KMnO2) $ + (1-weight(1)) * z_mno2_old do kz=2,kmax pw_conc(kz,IMn2P) = x(kz,L_Mn2) sl_gg(kz,IMnO2) = x(kz,L_MnO) if(z(kz-1) .GT. z_level(KMnO2)) then sl_gg(kz,IMnO2) = 0. endif sl_gg(kz,IMnCO3) = x(kz,L_MnC) enddo call sldcon(sl_gg(1,IMnO2), sl_ml(1,IMnO2), $ molwt(IMnO2), pore,kmax) call sldcon(sl_gg(1,IMnCO3), sl_ml(1,IMnCO3), $ molwt(IMnCO3), pore,kmax) burial = -omega(kmax) * $ (sl_gg(kmax,IMNO2)/molwt(IMnO2) $ + sl_gg(kmax,IMnCO3)/molwt(IMnCO3)) c call diffusive_flux(pw_conc(1,IMn2P), c $ diff_array(1,1), c $ form,pore,delz,kmax, c $ diffescape_mn2p_sink) endif #ifdef MnAdsorption xads_src_tot = 0. do kz=2,kmax xads_src_tot = xads_src_tot $ + rct(kz,xads_src) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr enddo #endif mn2p_scale = sqrt( $ diff_array(1,1) $ / ( rc(JMNOX) #ifdef MnAdsorptionOx $ * (1+d_ads) #endif $ ) $ ) call mn_rates(pw_conc(1,IMn2p),sl_ml,rc, #ifdef MnAdsorptionOx $ d_ads, #endif $ mn2p_0, mn2p_scale, $ z,z_level,delz,kmax, $ rct, mn2p_oxic, $ ddmn2_mnc_pcp) call irrig_flux(pw_conc(1,IMn2p), $ irrig_array, $ pore,delz,kmax, $ irrig_mn2p_sink) #ifdef MnIrrigOxidation d_irrig_mn2p_sink = 0. do kz=2,kmax tot_reducing(kz) = $ + irrig_array(kz) * pw_conc(kz,IMn2p) * 2. if(irrig_oxidation(kz) .GT. 0 $ .AND. $ z(kz) .GT. z_level(KOxic)) then if(irrig_oxidation(kz) .GT. tot_reducing(kz)) then rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ + irrig_array(kz) * pw_conc(kz,IMn2p) $ * pore(kz) d_irrig_mn2p_sink = d_irrig_mn2p_sink $ + irrig_array(kz) $ * pw_conc(kz,IMn2p) $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr else ! flux of reducing > flux of oxidizing rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ + irrig_array(kz) * pw_conc(kz,IMn2p) $ * pore(kz) $ * irrig_oxidation(kz) / tot_reducing(kz) d_irrig_mn2p_sink = d_irrig_mn2p_sink $ + irrig_array(kz) $ * pw_conc(kz,IMn2p) $ * irrig_oxidation(kz) / tot_reducing(kz) $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr endif endif enddo irrig_mn2p_sink = irrig_mn2p_sink $ - d_irrig_mn2p_sink #endif #ifdef MnRedepositIrrig rct(2,j0_mn_ox) = rct(2,j0_mn_ox) $ + irrig_mn2p_sink * rc(JMnIR) $ / 3.15e7 * 1000. $ / delz(2) irrig_mn2p_sink = irrig_mn2p_sink $ * (1.-rc(JMnIR)) #endif pw_react_tot = 0. do kz=2,kmax #ifdef MnIrrigOxidation if(irrig_oxidation(kz) .GT. 0) then if(irrig_oxidation(kz) .GT. tot_reducing(kz)) then irrig_oxidation(kz) = irrig_oxidation(kz) $ - irrig_array(kz) $ * pw_conc(kz,IMn2p) else irrig_oxidation(kz) = 0. endif endif #endif pw_react_tot = pw_react_tot $ + rct(kz,j0_mn_resp) $ * delz(kz) / 1000 * 3.15E7 pw_react_tot = pw_react_tot $ - rct(kz,j0_mn_ox) $ * delz(kz) / 1000 * 3.15E7 enddo ! i_pw_only = 0 (i.e. do solids) return end subroutine apply_mnrates(rct, $ pw_react,sl_react, $ pw_react_tot,org_consume, $ delz,kmax) implicit none #include #include integer ioc,kz,kmax double precision rct(nzmax,6), $ pw_react(nzmax,nsolutemax), $ sl_react(nzmax,nsolidmax) double precision pw_react_tot, org_consume(norgs) double precision delz(nzmax) double precision proton_balance, alk_src, tc_src, mn_src double precision xads_tot pw_react_tot = 0. sl_react(1,IMnCO3) = -99. sl_react(1,IMnO2) = -99. proton_balance = 0. alk_src = 0. tc_src = 0. mn_src = 0. #ifdef MnReactions do kz=2,kmax c respiration do ioc=1,norgs sl_react(kz,ioc) = sl_react(kz,ioc) $ + rct(kz,org_react+ioc-1) org_consume(ioc) = org_consume(ioc) $ * delz(kz) / 1000. * 3.15e7 enddo #ifdef MnSolidRctExport sl_react(kz,IMnO2) = sl_react(kz,IMnO2) $ - rct(kz,j0_mn_resp) #endif c*************************************************** #ifdef MnPHForcingSimple pw_react(kz,ICO2) = pw_react(kz,ICO2) $ - 3./2. * rct(kz,j0_mn_resp) #ifdef MnAdsorption $ - 2 * rct(kz,xads_src) #endif pw_react(kz,IHCO3) = pw_react(kz,IHCO3) $ + 2. * rct(kz,j0_mn_resp) #ifdef MnAdsorption $ + 2. * rct(kz,xads_src) #endif proton_balance = proton_balance $ + ( $ - 2. * rct(kz,j0_mn_resp) #ifdef MnAdsorption $ - 2. * rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr alk_src = alk_src $ + ( $ 2. * rct(kz,j0_mn_resp) #ifdef MnAdsorption $ + 2. * rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr tc_src = tc_src $ + 0.5 * rct(kz,j0_mn_resp) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr mn_src = mn_src $ + ( $ rct(kz,j0_mn_resp) #ifdef MnAdsorption $ + rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr #endif ! MnPHForcingSimple c*************************************************** #ifdef MnPHForcing pw_react(kz,ICO2) = pw_react(kz,ICO2) $ - rct(kz,j0_mn_resp) ! mol of Mn rxn $ * ( 2. $ - STOIC_REDFIELDC / STOIC_MNORGMN $ - STOIC_MnCO3aq $ ) #ifdef MnAdsorption $ - 2.*rct(kz,xads_src) $ * (1.-STOIC_MnCO3aq) #endif pw_react(kz,IHCO3) = pw_react(kz,IHCO3) $ + rct(kz,j0_mn_resp) $ * 2. * (1-STOIC_MnCO3aq) #ifdef MnAdsorption $ + 2. * rct(kz,xads_src) $ * (1.-STOIC_MnCO3aq) #endif proton_balance = proton_balance ! net source of protons $ - 2. * (1.-STOIC_MnCO3aq) $ * rct(kz,j0_mn_resp) #ifdef MnAdsorption $ - 2. * rct(kz,xads_src) $ * (1.-STOIC_MnCO3aq) #endif $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr alk_src = alk_src $ + ( $ 2. * rct(kz,j0_mn_resp) $ * (1. - STOIC_MnCO3aq) #ifdef MnAdsorption $ + 2. * rct(kz,xads_src) $ * (1.-STOIC_MnCO3aq) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr tc_src = tc_src $ + rct(kz,j0_mn_resp) $ * STOIC_REDFIELDC / STOIC_MNORGMN $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr mn_src = mn_src $ + ( $ rct(kz,j0_mn_resp) #ifdef MnAdsorption $ + rct(kz,xads_src) #endif $ ) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr #endif ! MnPHForcing c*************************************************** c oxidation #ifdef MnSolidRctExport sl_react(kz,IMnO2) = sl_react(kz,IMnO2) $ + rct(kz,j0_mn_ox) #endif pw_react(kz,IO2) = pw_react(kz,IO2) $ - rct(kz,j0_mn_ox) / STOIC_MNOXMN #ifdef MnPHForcingSimpleOx pw_react(kz,ICO2) = pw_react(kz,ICO2) $ + rct(kz,j0_mn_ox) $ * 2. pw_react(kz,IHCO3) = pw_react(kz,IHCO3) $ - rct(kz,j0_mn_ox) $ * 2. proton_balance = proton_balance $ + 2 * rct(kz,j0_mn_ox) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr c alk_src = alk_src c $ - 2 * rct(kz,j0_mn_ox) c $ / 1000. * 3.15e7 ! mol/cm3 tot yr c $ * delz(kz) ! mol/cm2 yr #endif #ifdef MnPHForcingOx pw_react(kz,ICO2) = pw_react(kz,ICO2) $ + rct(kz,j0_mn_ox) $ / STOIC_MNOXMN * STOIC_MNOXHP $ * (1 - STOIC_MnCO3aq) pw_react(kz,IHCO3) = pw_react(kz,IHCO3) $ - rct(kz,j0_mn_ox) $ / STOIC_MNOXMN * STOIC_MNOXHP $ * (1 - STOIC_MnCO3aq) proton_balance = proton_balance $ + rct(kz,j0_mn_ox) $ / STOIC_MNOXMN * STOIC_MNOXHP $ * (1 - STOIC_MnCO3aq) $ / 1000. * 3.15e7 ! mol/cm3 tot yr $ * delz(kz) ! mol/cm2 yr #endif pw_react_tot = pw_react_tot $ + rct(kz,j0_mn_resp) $ * delz(kz) / 1000 * 3.15E7 pw_react_tot = pw_react_tot $ - rct(kz,j0_mn_ox) $ * delz(kz) / 1000 * 3.15E7 c precipitation pw_react(kz,ICO3) = pw_react(kz,ICO3) $ - rct(kz,j1_mnc_pcp) #ifdef MnSolidRctExport sl_react(kz,IMnCO3) = sl_react(kz,IMnCO3) $ + rct(kz,j1_mnc_pcp) #endif pw_react_tot = pw_react_tot $ - rct(kz,j1_mnc_pcp) $ * delz(kz) / 1000 * 3.15E7 enddo #endif ! MnReactions #ifdef Stdout c write(6,*) "Proton balance = ", proton_balance write(6,*) "Mn deep alk src = ", alk_src*1.e6, tc_src*1.e6 write(6,*) "Mn2+ src = ", mn_src*1.e6 c write(6,*) "xads_src_tot = ", xads_src_tot*1.e6 c write(6,*) "total = ", (mn_src + xads_src_tot) * 1.e6 #endif c call diffusive_flux(pw_conc(1,IMn2P), c $ diff_array(1,1), c $ form,pore,delz,kmax, c $ diffescape_mn2p_sink) c call irrig_flux(pw_conc(1,IMn2P), c $ irrig_array, c $ pore,delz,kmax, c $ pw_irrig_flux) return end subroutine mn_rates(mn2p, sl_ml, rc, #ifdef MnAdsorptionOx $ d_ads, #endif $ mn2p_0, mn2p_scale, $ z, z_level, delz, kmax, $ rct, mn2p_oxic, $ ddmn2_mnc_pcp) implicit none #include #include #include #include double precision mn2p(nzmax), sl_ml(nzmax,nsolidmax), $ mn2p_0, mn2p_scale #ifdef MnAdsorptionOx double precision d_ads #endif double precision rc(nrcmax), z(nzmax), z_level(nzlevels), $ delz(nzmax) double precision rct(nzmax,6), mn2p_oxic(nzmax), $ ddmn2_mnc_pcp(nzmax) integer kmax double precision rc_scale integer kz, ioc do kz=2,kmax rct(kz,j0_mn_resp) = 0. rct(kz,j0_mn_ox) = 0. rct(kz,j1_mnc_pcp) = 0. do ioc=1,norgs rct(kz,org_react+ioc-1) = 0. enddo ddmn2_mnc_pcp(kz) = 0. rc_scale = exp(-z(kz)/rc(JRespScale)) #ifdef MnCO3Pcp if(mn2p(kz) .GE. rc(JMnCO3sat)) then rct(kz,j1_mnc_pcp) = $ ( $ mn2p(kz) $ - rc(JMnCO3sat) $ ) $ * rc(JMnCO3k) ddmn2_mnc_pcp(kz) = rc(JMnCO3k) endif #endif if( z(kz-1) .GE. z_level(KOXIC) )then ! completely anoxic #ifdef MnResp if(z(kz) .LT. z_level(KMNO2)) then ! mno2 throughout do ioc=1,norgs rct(kz,j0_mn_resp) = rct(kz,j0_mn_resp) $ + rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * STOIC_MNORGMN $ / STOIC_REDFIELDC rct(kz,org_react+ioc-1) = $ - rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) enddo elseif(z(kz-1) .LT. z_level(KMNO2)) then do ioc=1,norgs rct(kz,j0_mn_resp) = rct(kz,j0_mn_resp) $ + rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * STOIC_MNORGMN / STOIC_REDFIELDC $ * (z_level(KMNO2) $ - z(kz-1))/delz(kz) rct(kz,org_react+ioc-1) = rct(kz,org_react+ioc-1) $ - rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * (z_level(KMNO2) $ - z(kz-1))/delz(kz) enddo endif #endif c units mol / l sec elseif( ( z(kz) .LE. z_level(KOXIC) ) ) then ! completely oxic rct(kz,j0_mn_resp) = 0. mn2p_oxic(kz) = mn2p_0 . * exp( $ - ( $ z_level(KOXIC) $ - z(kz) $ + delz(kz)/2 $ ) . / mn2p_scale . ) #ifdef MnOx rct(kz,j0_mn_ox) = rc(JMNOX) * mn2p_0 $ * mn2p_scale / delz(kz) . * ( exp( $ - ( $ z_level(KOXIC) $ - z(kz) $ ) . / mn2p_scale . ) . - exp( $ - ( $ z_level(KOXIC) $ - z(kz-1) $ ) . / mn2p_scale . ) $ ) #ifdef MnAdsorptionOx rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ * (1+d_ads) #endif #endif c units mol/l sec-1 else ! neither completely oxic nor completely anoxic if( ( z(kz-1) .LT. z_level(KOXIC)) $ .AND. $ ( z(kz) .GT. z_level(KOXIC)) $ )then ! depth level contains z_level(KOXIC) if(z(kz) .LT. z_level(KMNO2)) then ! mno2 throughout #ifdef MnResp do ioc=1,norgs rct(kz,j0_mn_resp) = rct(kz,j0_mn_resp) $ + rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * STOIC_MNORGMN / STOIC_REDFIELDC $ * ( z(kz) - z_level(KOXIC) ) $ /delz(kz) rct(kz,org_react+ioc-1) = $ rct(kz,org_react+ioc-1) $ - rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * ( z(kz) - z_level(KOXIC) ) $ /delz(kz) enddo #endif elseif(z(kz-1) .LT. z_level(KMNO2)) then #ifdef MnResp do ioc=1,norgs rct(kz,j0_mn_resp) = rct(kz,j0_mn_resp) $ + rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * STOIC_MNORGMN / STOIC_REDFIELDC $ * ( z_level(KMNO2) $ - z_level(KOXIC) $ ) $ /delz(kz) rct(kz,org_react+ioc-1) = $ rct(kz,org_react+ioc-1) $ - rc(JMnORG+ioc-1) * rc_scale $ * sl_ml(kz,IORG+ioc-1) $ * ( z_level(KMNO2) $ - z_level(KOXIC) $ ) $ /delz(kz) c assumes z_level(KMNO2) deeper than z_level(KOXIC) enddo #endif endif endif if( ( z(kz-1) .LT. z_level(KOXIC)) $ .AND. $ ( z(kz) .GT. z_level(KOXIC)) $ )then ! depth level contains z_level(KOXIC) #ifdef MnOx rct(kz,j0_mn_ox) = rc(JMNOX) * mn2p_0 $ * mn2p_scale $ / ( z_level(KOXIC) - z(kz-1) ) . * ( 1. . - exp( $ - ( $ z_level(KOXIC) $ - z(kz-1) $ ) . / mn2p_scale . ) $ ) . * ( z_level(KOXIC) - z(kz-1) ) $ /delz(kz) #ifdef MnAdsorptionOx rct(kz,j0_mn_ox) = rct(kz,j0_mn_ox) $ * (1+d_ads) #endif #endif if(z(kz)-delz(kz)/2 .LT. z_level(KOXIC)) $ then c cell center oxic (specified) mn2p_oxic(kz) = mn2p_0 . * exp( $ - ( $ z_level(KOXIC) $ - z(kz) $ + delz(kz)/2 $ ) . / mn2p_scale . ) endif endif ! contains z_level(KOXIC) endif enddo return end $ then c cell center oxic (specified) mn2p_oxic(kz) = mn2p_0 . * exp( $ - ( $ z_level(KOXIC) $ - z(kz) $ + delz(kz)/2 $ ) . / mn2p_scale . ) endif endif ! contains z_level(KOXIC) mol_id.h000644 025374 000024 00000003340 10413036311 012747 0ustar00archeruser000000 000000 double precision molwt(nsolidmax) double precision diff_coeff(nsolutemax) character*4 solidname(nsolidmax), . solutename(nsolutemax) double precision solid_scale(nsolidmax), $ solute_scale(nsolutemax), $ cdf_solute_scale(nsolutemax), . flux_scale(nsolidmax) data solidname /"FOrg","SOrg","Clay", . nCaCO3s*"Cal", $ "SiO2","MnO","MnCO3","FeO","FeS","FeCO3" #ifdef Bells_Whistles . ,"14Fm","14Cc","STr","UO2","ReSol","MoSol" #endif . / DATA molwt / 2*12., 1., . nCaCO3s*100., $ 60., 87., 115., 89., 88., 116. #ifdef Bells_Whistles . ,2*100., 1., 270., 186., 96. #endif . / data solid_scale /100., 100., 100., . nCaCO3s*100., . 100.,1.E6, 1.E6,1.E6, 1., 1. #ifdef Bells_Whistles $ ,1.e6,1.E6, 1.E6,1.e9,1.e9,1e6 #endif . / data solutename /"O2","CO2", . "HCO3","CO3","Si", "Mn2p", $ "NO3","Fe2p","SO4","H2S","NH4" #ifdef Bells_Whistles . ,"PO4","Cd","13TCO2","14TCO2", . "U_aq","RePW","MoPW" #endif . / DATA diff_coeff / 12.E-6, 10.5E-6, $ 6.4E-6, 5.2E-6, 5.E-6,5.E-6, . 5*5.E-6 #ifdef Bells_Whistles . ,4*5.e-6, $ 3*5.E-6 #endif . / data solute_scale /1.,1., . 1.,1.,1.,1., . 1.,1.,1.d-3,1.,1. #ifdef Bells_Whistles . ,1.,1000.,1.,1., . 1000.,1.e6,1000. #endif . / data cdf_solute_scale /1.d6,1.d6, . 1.d6,1.d6,1.d6,1.d6, . 1.d6,1.d6,1.d3,1.d6,1.d6 #ifdef Bells_Whistles . ,1.e6,1.e3,1.e6,1.e6, . 1.d9,1.d12,1.d9 #endif . / data flux_scale/nsolidmax*1.E6/ fdef Bells_Whistles . ,4*5.e-6, $ 3*5.E-6 #endif . / data solute_scale /1.,1., . 1.,1.,1.,1., . 1.,1.,1.d-3,1.,1. #ifdef Bells_Whistles . ,1.,1000.,1.,1., . 1000.,1.e6,1000. #endif . / data cdf_solute_scamoly.F000644 025374 000024 00000013274 10413036311 012431 0ustar00archeruser000000 000000 SUBROUTINE molybdenum( $ runid,idebug, $ molypw, $ molysolml, molysolgg, $ h2s, z_oxidize, $ rox, rred, diffmolypw, molwt_molysol, $ omega,db_array,irrig_array, $ z, delz, form, pore, kmax, $ difflux,pw_react_tot,sl_react_tot,burial) implicit none #include #include #include integer kmax, runid, idebug c external variables double precision molypw(nzmax), molysolml(nzmax),molysolgg(nzmax), $ h2s(nzmax) double precision z_oxidize,rox, rred, diffmolypw,molwt_molysol double precision omega(kmax), db_array(nzmax,nDbs), $ irrig_array(kmax) double precision z(kmax) double precision delz(kmax), form(kmax), pore(kmax) double precision stoi_fe, stoi_co3, stoi_red_h, $ stoi_o2, stoi_ox_h, $ difflux,pw_react_tot,sl_react_tot,burial double precision molypwreact(nzmax), molysolreact(nzmax), $ molysol_dreac(nzmax) double precision react_tot,diff_tot c internal variables double precision dmin(nzmax), dpls(nzmax) double precision jox(nzmax), jred(nzmax) double precision a(2*nzmax,2*nzmax), b(2*nzmax) double precision ggfac integer kz, kz1,imolypwpos,imolysolpos CALL calc_pw_diff(diffmolypw, * form,pore,delz,kmax, * dpls,dmin) do kz=2,kmax jox(kz) = 0. jred(kz) = 0. c zone 1. fully oxidizing box -- shallower than z_oxidize if( z(kz) .LE. z_oxidize ) then jox(kz) = rox elseif( z(kz-1) .LT. z_oxidize ) then jox(kz) = rox $ * ( z_oxidize - z(kz-1) ) / delz(kz) endif jred(kz) = rred $ * h2s(kz) / (h2s(kz) + 1.e-7) enddo c zero matrices do kz=1,(kmax-1)*2 do kz1=1,(kmax-1)*2 a(kz,kz1) = 0. enddo b(kz) = 0 enddo do kz=3,kmax-1 ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 imolysolpos = kz-1 imolypwpos = (kmax-1) + kz-1 c molysol c row, col a(imolysolpos,imolysolpos-1) = db_array(kz,DbMinS) $ + omega(kz-1) $ * ggfac a(imolysolpos,imolysolpos) = -db_array(kz,DbMinS) $ - db_array(kz,DbPlsS) $ - jox(kz) ! wants * molysolgg $ * 3.15e7 $ - omega(kz) $ * ggfac a(imolysolpos,imolysolpos+1) = db_array(kz,DbPlsS) a(imolysolpos,imolypwpos) = jred(kz) * 3.15e7 $ * molwt_molysol/(2.5*(1-pore(kz))*1000) ! convert ml to gg c molypw a(imolypwpos,imolypwpos-1) = dmin(kz) a(imolypwpos,imolypwpos) = -dmin(kz) - dpls(kz) $ - irrig_array(kz) $ - jred(kz) / pore(kz) a(imolypwpos,imolypwpos+1) = dpls(kz) c jch2o production of Mn2+ multiplied by mno2gg a(imolypwpos,imolysolpos) = jox(kz) ! implicit *mno2ml $ *2.5*(1-pore(kz))*1000/molwt_molysol ! convert gg to ml $ / pore(kz) b(imolypwpos) = -irrig_array(kz) * molypw(1) enddo kz=2 ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 imolysolpos = kz-1 imolypwpos = (kmax-1) + kz-1 c molysol a(imolysolpos,imolysolpos) = -db_array(kz,DbPlsS) $ - jox(kz) * 3.15e7 $ - omega(kz) $ * ggfac a(imolysolpos,imolysolpos+1) = db_array(kz,DbPlsS) a(imolysolpos,imolypwpos) = jred(kz) * 3.15e7 $ * molwt_molysol/(2.5*(1-pore(kz))*1000) b(imolysolpos) = 0. ! no rain of authigenic molysol c molypw a(imolypwpos,imolypwpos) = -dmin(kz) - dpls(kz) $ - irrig_array(kz) $ - jred(kz) / pore(kz) a(imolypwpos,imolypwpos+1) = dpls(kz) a(imolypwpos,imolysolpos) = jox(kz) / pore(kz) $ * 2.5*(1-pore(kz))*1000/molwt_molysol ! gg -> ml b(imolypwpos) = -dmin(kz) * molypw(1) $ - irrig_array(kz) * molypw(1) kz = kmax ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 imolysolpos = kz-1 imolypwpos = (kmax-1) + kz-1 c molysol a(imolysolpos,imolysolpos-1) = db_array(kz,DbMinS) $ + omega(kz-1) $ * ggfac a(imolysolpos,imolysolpos) = -db_array(kz,DbMinS) $ - omega(kz) $ * ggfac $ - jox(kz) * 3.15e7 a(imolysolpos,imolypwpos) = jred(kz) * 3.15e7 $ * molwt_molysol/(2.5*(1-pore(kz))*1000) ! convert ml to gg c molypw a(imolypwpos,imolypwpos-1) = dmin(kz) a(imolypwpos,imolypwpos) = -dmin(kz) $ - jred(kz) / pore(kz) a(imolypwpos,imolysolpos) = jox(kz) / pore(kz) $ *2.5*(1-pore(kz))*1000/molwt_molysol ! convert gg to m/l call gaussj(runid,idebug,a,(kmax-1)*2,nzmax*2,b,1,1) do kz=2,kmax molysolgg(kz) = b(kz-1) molypw(kz) = b(kz-1+(kmax-1)) enddo call sldcon(molysolgg,molysolml,molwt_molysol,pore,kmax) call diffusive_flux(molypw, $ diffmolypw, $ form,pore,delz,kmax, $ diff_tot) pw_react_tot = 0. do kz=2,kmax pw_react_tot = pw_react_tot $ + ( jred(kz) * molypw(kz) . - jox(kz) * molysolml(kz) . ) $ * delz(kz) / 1000. * 3.15e7 enddo sl_react_tot = pw_react_tot * molwt_molysol burial = -omega(kmax) * $ molysolgg(kmax) return end t_molysol,pore,kmax) call diffusive_flux(molypw, $ diffmolypw, $ form,pore,delz,kmax, $ diff_tot) pw_react_tot = 0. do kz=2,kmax pw_react_tot = pw_react_tot $ + ( jred(kz) * molypw(kz) . - jox(kz) * molysolml(kz) . )mpif.orig.h000644 025374 000024 00000021705 10413036311 013403 0ustar00archeruser000000 000000 ! ! ! (C) 1993 by Argonne National Laboratory and Mississipi State University. ! All rights reserved. See COPYRIGHT in top-level directory. ! ! ! user include file for MPI programs, with no dependencies ! ! It really is not possible to make a perfect include file that can ! be used by both F77 and F90 compilers, but this is close. We have removed ! continuation lines (allows free form input in F90); systems whose ! Fortran compilers support ! instead of just C or * for comments can ! globally replace a C in the first column with !; the resulting file ! should work for both Fortran 77 and Fortran 90. ! ! If your Fortran compiler supports ! for comments, you can run this ! through sed with ! sed -e 's/^C/\!/g' ! ! We have also removed the use of contractions (involving the single quote) ! character because some users use .F instead of .f files (to invoke the ! cpp preprocessor) and further, their preprocessor is determined to find ! matching single quote pairs (and probably double quotes; given the ! different rules in C and Fortran, this sounds like a disaster). Rather than ! take the position that the poor users should get a better system, we ! have removed the text that caused problems. Of course, the users SHOULD ! get a better system... ! ! return codes INTEGER MPI_SUCCESS,MPI_ERR_BUFFER,MPI_ERR_COUNT,MPI_ERR_TYPE INTEGER MPI_ERR_TAG,MPI_ERR_COMM,MPI_ERR_RANK,MPI_ERR_ROOT INTEGER MPI_ERR_GROUP INTEGER MPI_ERR_OP,MPI_ERR_TOPOLOGY,MPI_ERR_DIMS,MPI_ERR_ARG INTEGER MPI_ERR_UNKNOWN,MPI_ERR_TRUNCATE,MPI_ERR_OTHER INTEGER MPI_ERR_INTERN,MPI_ERR_IN_STATUS,MPI_ERR_PENDING INTEGER MPI_ERR_REQUEST, MPI_ERR_LASTCODE PARAMETER (MPI_SUCCESS=0,MPI_ERR_BUFFER=1,MPI_ERR_COUNT=2) PARAMETER (MPI_ERR_TYPE=3,MPI_ERR_TAG=4,MPI_ERR_COMM=5) PARAMETER (MPI_ERR_RANK=6,MPI_ERR_ROOT=7,MPI_ERR_GROUP=8) PARAMETER (MPI_ERR_OP=9,MPI_ERR_TOPOLOGY=10,MPI_ERR_DIMS=11) PARAMETER (MPI_ERR_ARG=12,MPI_ERR_UNKNOWN=13) PARAMETER (MPI_ERR_TRUNCATE=14,MPI_ERR_OTHER=15) PARAMETER (MPI_ERR_INTERN=16,MPI_ERR_IN_STATUS=17) PARAMETER (MPI_ERR_PENDING=18,MPI_ERR_REQUEST=19) PARAMETER (MPI_ERR_LASTCODE=4114) ! INTEGER MPI_UNDEFINED parameter (MPI_UNDEFINED = (-32766)) ! INTEGER MPI_GRAPH, MPI_CART PARAMETER (MPI_GRAPH = 1, MPI_CART = 2) INTEGER MPI_PROC_NULL PARAMETER ( MPI_PROC_NULL = (-1) ) ! INTEGER MPI_BSEND_OVERHEAD PARAMETER ( MPI_BSEND_OVERHEAD = 512 ) INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR PARAMETER(MPI_SOURCE=2, MPI_TAG=3, MPI_ERROR=4) INTEGER MPI_STATUS_SIZE PARAMETER (MPI_STATUS_SIZE=5) INTEGER MPI_MAX_PROCESSOR_NAME, MPI_MAX_ERROR_STRING PARAMETER (MPI_MAX_PROCESSOR_NAME=256) PARAMETER (MPI_MAX_ERROR_STRING=512) INTEGER MPI_MAX_NAME_STRING PARAMETER (MPI_MAX_NAME_STRING=63) ! INTEGER MPI_COMM_NULL PARAMETER (MPI_COMM_NULL=0) ! INTEGER MPI_DATATYPE_NULL PARAMETER (MPI_DATATYPE_NULL = 0) INTEGER MPI_ERRHANDLER_NULL PARAMETER (MPI_ERRHANDLER_NULL = 0) INTEGER MPI_GROUP_NULL PARAMETER (MPI_GROUP_NULL = 0) INTEGER MPI_KEYVAL_INVALID PARAMETER (MPI_KEYVAL_INVALID = 0) INTEGER MPI_REQUEST_NULL PARAMETER (MPI_REQUEST_NULL = 0) ! INTEGER MPI_IDENT, MPI_CONGRUENT, MPI_SIMILAR, MPI_UNEQUAL PARAMETER (MPI_IDENT=0, MPI_CONGRUENT=1, MPI_SIMILAR=2) PARAMETER (MPI_UNEQUAL=3) ! ! MPI_BOTTOM needs to be a known address; here we put it at the ! beginning of the common block. The point-to-point and collective ! routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. ! ! MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE are similar objects ! ! The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. ! Their values are zero if they are not available. Note that ! using these reduces the portability of code (though may enhance ! portability between Crays and other systems) ! INTEGER MPI_TAG_UB, MPI_HOST, MPI_IO INTEGER MPI_BOTTOM, MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE INTEGER MPI_INTEGER, MPI_REAL, MPI_DOUBLE_PRECISION INTEGER MPI_COMPLEX, MPI_DOUBLE_COMPLEX,MPI_LOGICAL INTEGER MPI_CHARACTER, MPI_BYTE, MPI_2INTEGER, MPI_2REAL INTEGER MPI_2DOUBLE_PRECISION, MPI_2COMPLEX, MPI_2DOUBLE_COMPLEX INTEGER MPI_UB, MPI_LB INTEGER MPI_PACKED, MPI_WTIME_IS_GLOBAL INTEGER MPI_COMM_WORLD, MPI_COMM_SELF, MPI_GROUP_EMPTY INTEGER MPI_SUM, MPI_MAX, MPI_MIN, MPI_PROD, MPI_LAND, MPI_BAND INTEGER MPI_LOR, MPI_BOR, MPI_LXOR, MPI_BXOR, MPI_MINLOC INTEGER MPI_MAXLOC INTEGER MPI_OP_NULL INTEGER MPI_ERRORS_ARE_FATAL, MPI_ERRORS_RETURN ! PARAMETER (MPI_ERRORS_ARE_FATAL=119) PARAMETER (MPI_ERRORS_RETURN=120) ! PARAMETER (MPI_COMPLEX=23,MPI_DOUBLE_COMPLEX=24,MPI_LOGICAL=25) PARAMETER (MPI_REAL=26,MPI_DOUBLE_PRECISION=27,MPI_INTEGER=28) PARAMETER (MPI_2INTEGER=29,MPI_2COMPLEX=30,MPI_2DOUBLE_COMPLEX=31) PARAMETER (MPI_2REAL=32,MPI_2DOUBLE_PRECISION=33,MPI_CHARACTER=1) PARAMETER (MPI_BYTE=3,MPI_UB=16,MPI_LB=15,MPI_PACKED=14) INTEGER MPI_ORDER_C, MPI_ORDER_FORTRAN PARAMETER (MPI_ORDER_C=56, MPI_ORDER_FORTRAN=57) INTEGER MPI_DISTRIBUTE_BLOCK, MPI_DISTRIBUTE_CYCLIC INTEGER MPI_DISTRIBUTE_NONE, MPI_DISTRIBUTE_DFLT_DARG PARAMETER (MPI_DISTRIBUTE_BLOCK=121, MPI_DISTRIBUTE_CYCLIC=122) PARAMETER (MPI_DISTRIBUTE_NONE=123) PARAMETER (MPI_DISTRIBUTE_DFLT_DARG=-49767) INTEGER MPI_MAX_INFO_KEY, MPI_MAX_INFO_VAL PARAMETER (MPI_MAX_INFO_KEY=255, MPI_MAX_INFO_VAL=1024) INTEGER MPI_INFO_NULL PARAMETER (MPI_INFO_NULL=0) ! ! Optional Fortran Types. Configure attempts to determine these. ! INTEGER MPI_INTEGER1, MPI_INTEGER2, MPI_INTEGER4, MPI_INTEGER8 INTEGER MPI_INTEGER16 INTEGER MPI_REAL4, MPI_REAL8, MPI_REAL16 INTEGER MPI_COMPLEX8, MPI_COMPLEX16, MPI_COMPLEX32 PARAMETER (MPI_INTEGER1=1,MPI_INTEGER2=4) PARAMETER (MPI_INTEGER4=6) PARAMETER (MPI_INTEGER8=13) PARAMETER (MPI_INTEGER16=0) PARAMETER (MPI_REAL4=10) PARAMETER (MPI_REAL8=11) PARAMETER (MPI_REAL16=0) PARAMETER (MPI_COMPLEX8=23) PARAMETER (MPI_COMPLEX16=24) PARAMETER (MPI_COMPLEX32=0) COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE ! ! Without this save, some Fortran implementations may make the common ! dynamic! ! ! For a Fortran90 module, we might replace /MPIPRIV/ with a simple ! SAVE MPI_BOTTOM ! SAVE /MPIPRIV/ PARAMETER (MPI_MAX=100,MPI_MIN=101,MPI_SUM=102,MPI_PROD=103) PARAMETER (MPI_LAND=104,MPI_BAND=105,MPI_LOR=106,MPI_BOR=107) PARAMETER (MPI_LXOR=108,MPI_BXOR=109,MPI_MINLOC=110) PARAMETER (MPI_MAXLOC=111, MPI_OP_NULL=0) ! PARAMETER (MPI_GROUP_EMPTY=90,MPI_COMM_WORLD=91,MPI_COMM_SELF=92) PARAMETER (MPI_TAG_UB=80,MPI_HOST=82,MPI_IO=84) PARAMETER (MPI_WTIME_IS_GLOBAL=86) ! INTEGER MPI_ANY_SOURCE PARAMETER (MPI_ANY_SOURCE = (-2)) INTEGER MPI_ANY_TAG PARAMETER (MPI_ANY_TAG = (-1)) ! INTEGER MPI_VERSION, MPI_SUBVERSION PARAMETER (MPI_VERSION = 1, MPI_SUBVERSION = 1) ! ! All other MPI routines are subroutines ! This may cause some Fortran compilers to complain about defined and ! not used. Such compilers should be improved. ! ! Some Fortran compilers will not link programs that contain ! external statements to routines that are not provided, even if ! the routine is never called. Remove PMPI_WTIME and PMPI_WTICK ! if you have trouble with them. ! DOUBLE PRECISION MPI_WTIME, MPI_WTICK,PMPI_WTIME, PMPI_WTICK EXTERNAL MPI_WTIME, MPI_WTICK,PMPI_WTIME, PMPI_WTICK ! ! The attribute copy/delete subroutines are symbols that can be passed ! to MPI routines ! EXTERNAL MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN, MPI_DUP_FN ! ! $Id: mpif.orig.h,v 1.1.1.1 2002/11/22 18:25:48 rob Exp $ ! ! Copyright (C) 1997 University of Chicago. ! See COPYRIGHT notice in top-level directory. ! ! ! user include file for Fortran MPI-IO programs ! INTEGER MPI_MODE_RDONLY, MPI_MODE_RDWR, MPI_MODE_WRONLY INTEGER MPI_MODE_DELETE_ON_CLOSE, MPI_MODE_UNIQUE_OPEN INTEGER MPI_MODE_CREATE, MPI_MODE_EXCL INTEGER MPI_MODE_APPEND PARAMETER (MPI_MODE_RDONLY=2, MPI_MODE_RDWR=8, MPI_MODE_WRONLY=4) PARAMETER (MPI_MODE_CREATE=1, MPI_MODE_DELETE_ON_CLOSE=16) PARAMETER (MPI_MODE_UNIQUE_OPEN=32, MPI_MODE_EXCL=64) PARAMETER (MPI_MODE_APPEND=128) ! INTEGER MPI_FILE_NULL PARAMETER (MPI_FILE_NULL=0) ! INTEGER MPI_MAX_DATAREP_STRING PARAMETER (MPI_MAX_DATAREP_STRING=128) ! INTEGER MPI_SEEK_SET, MPI_SEEK_CUR, MPI_SEEK_END PARAMETER (MPI_SEEK_SET=600, MPI_SEEK_CUR=602, MPI_SEEK_END=604) ! INTEGER MPIO_REQUEST_NULL PARAMETER (MPIO_REQUEST_NULL=0) ! INTEGER MPI_OFFSET_KIND PARAMETER (MPI_OFFSET_KIND=8) ! ! ! ! ! ! ! ! ! ! ! ! ! IQUE_OPEN=32, MPI_MODE_EXCL=64) PARAMETER (MPI_MODE_Amuds.F000644 025374 000024 00000022674 10413036311 012425 0ustar00archeruser000000 000000 c#define WWW #define ReadLoop c#define FindTCO2 c#define ReadUOx c#define MudsTimeStep c#define ClayInit c#define MPI_Output program muds implicit none #include #include #include #include #include #include #include #include #include #include integer runid double precision rc(nrcmax) double precision rain(nsolidmax) double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), omega(nzmax), burial(nsolidmax), $ sl_residual(nsolidmax),pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels),storage(Stor_N) double precision bwchem(NBottomWaters), $ rainorg,raincaco3(nCaCO3s), $ rainopal,rainclay character*80 ratefilename integer ituner, idebug, iinit, iread, iter,irc, iunit, $ ioc,isol,isite, itest #ifdef MudsTimeStep double precision delta_t, delta_t_sub, $ cum_rain, cum_react, cum_bur, cum_inv, $ cum_conserve, sl_inv_0 integer idriverline,itimestep,i_year,i_year_start,i_year_to #endif #ifdef FindTCO2 double precision dco3 #endif #ifdef ReadLoop integer i_loop #endif data storage/Stor_N*0./ #ifdef WWW do ioc=1,nBottomWaters bwchem(ioc) = 0. enddo bwchem(BWTemp) = 4. bwchem(BWSal) = 35. READ(5,*) bwchem(BWO2), bwchem(BWNO3), bwchem(BWSi), $ bwchem(BWAlk), bwchem(BWTCO2), $ bwchem(BWDepth), $ rainorg,raincaco3(1),rainopal,rainclay #else read(5,*) read(5,*) #ifdef ReadLoop do i_loop = 1, 1000 #endif READ(5,*,END=999) isite, bwchem, $ rainorg,raincaco3,rainopal,rainclay #ifdef ReadCalciteKineticsFile $ ,ratefilename #endif #endif #ifdef FindTCO2 dco3 = bwchem(BWTCO2) call findtco2(dco3,bwchem(BWAlk),bwchem(BWDepth), $ bwchem(BWTemp),bwchem(BWSal),bwchem(BWTCO2)) c write(6,*) "total CO2 = ", bwchem(BWTCO2) #endif idebug = 2 iunit = 6 iinit = 1 call generate_rates( $ rainorg,raincaco3, $ rainopal,rainclay, $ bwchem,tuners, #ifdef ReadCalciteKineticsFile $ ratefilename, #endif $ rain,rc) #ifdef ReadUOx write(iunit,*) "waiting for J-UOx" read(5,*) rc(JUOX) write(iunit,*) "got ", rc(JUOX) #endif #ifndef MPI_Output write(iunit,*) "

MUDS Model Output

" write(iunit,*) "
"
#endif

      do ioc=1,norgs
         do isol=1,nsolutemax
            org_consume(ioc,isol) = 0.
         enddo
      enddo
      do isol=1,nzlevels
         z_level(isol) = 100.
      enddo

      runid = isite

#ifdef ClayInit
      call all_clay_init(
#else
#ifdef MPI_Output
      call list_mudsargs(
#else
      call full_steady_state(
#endif
#endif
     $     runid,iinit,iunit,idebug,
     $     rc, 
     $     pw_conc, sl_gg,
     $     bwchem, 
     $     rain,
     $     pw_react_tot, pw_diff_tot,
     $     sl_react_tot,
     $     sl_inv, omega, burial,
     $     sl_residual, pw_residual,
     $     org_consume, z_level,
     $     storage,
     $     iter)

#ifdef MPI_Output
      iunit = 6
#endif

#ifdef MudsTimeStep


      i_year_start = 1

      do idriverline=1,1000   ! lines of input driver

         READ(5,*)  i_year_to, bwchem,
     $       rainorg,raincaco3,rainopal,rainclay
#ifdef ReadCalciteKineticsFile
     $        ,ratefilename
#endif

#ifdef FindTCO2
         dco3 = bwchem(BWTCO2)
         call findtco2(dco3,bwchem(BWAlk),bwchem(BWDepth),
     $        bwchem(BWTemp),bwchem(BWSal),bwchem(BWTCO2))
c        write(6,*) "total CO2 = ", bwchem(BWTCO2)
#endif
 
         write(6,*)
         write(6,*) "Working toward year ", i_year_to
         write(6,*)

         call generate_rates(
     $     rainorg,raincaco3,
     $     rainopal,rainclay,
     $     bwchem,tuners,
#ifdef ReadCalciteKineticsFile
     $     ratefilename,
#endif
     $     rain,rc)

         delta_t = 1.
         delta_t_sub = 1.d-3
         sl_inv_0 = sl_inv(iCaCO3)

         do itimestep = i_year_start, i_year_to

            if(itimestep .EQ. i_year_to) then
               write(6,*)
               write(6,*) "Year ", itimestep
               write(6,*)
               idebug=2
            elseif(MOD(itimestep,1000) .EQ. 0) then
               write(6,*)
               write(6,*) "Year ", itimestep
               write(6,*)
               idebug=2
            elseif(MOD(itimestep,100) .EQ. 0) then
               write(6,*) "Year ", itimestep
               idebug = 0
            else
               idebug=0
            endif

            call muds_timestep(
     .        delta_t,delta_t_sub,
     .        runid,itimestep,iunit,idebug,
     $        rc, 
     $        pw_conc, sl_gg,
     $        bwchem,
     $        rain,  
     $        pw_react_tot, pw_diff_tot,
     $        sl_react_tot,
     $        sl_inv, omega, burial,
     $        sl_residual, pw_residual,
     $        org_consume, z_level,
     $        storage,
     $        iter)

            if(itimestep .EQ. 1) then 
               sl_inv_0 = sl_inv(iCaCO3)
               cum_rain = 0.
               cum_react = 0.
               cum_bur = 0.
               cum_inv = 0.
               cum_conserve = 0.
            else
               cum_rain = cum_rain + rain(iCaCO3) ! mol/cm2 yr
     $              * delta_t
               cum_react = cum_react + sl_react_tot(iCaCO3) ! g/cm2 yr
     $              / molwt(iCaCO3) 
     $              * delta_t
               cum_bur = cum_bur + burial(iCaCO3) ! g/cm2 yr
     $              / molwt(iCaCO3)
     $              * delta_t
               cum_inv = (sl_inv(iCaCO3) - sl_inv_0) / molwt(iCaCO3)

               cum_conserve = cum_rain ! input
     $              + cum_react
     $              + cum_bur
     $              - cum_inv
            endif

            if(MOD(itimestep,1000) .EQ. 0) then    ! every thousand years
               write(6,"(a20,6g12.2)") "CaCO3 mass balance",
     $           cum_inv,
     $           cum_rain, cum_react, cum_bur,
     $           cum_conserve, cum_conserve/(cum_rain+1.e-20)
            endif
         

         enddo  ! itimestep
         i_year_start = i_year_to+1
      enddo     ! idriverline
#endif
         


c#define PorewaterSteadyState
#ifdef PorewaterSteadyState
      do ioc=1,Stor_N
         storage(ioc) = 0.
      enddo

      iter = 0
      write(iunit,*) "porewater_steady_state results"

      do itest=1,10
         bwchem(BWO2) = bwchem(BWO2) * 0.9
         call generate_rates(
     $        rainorg,raincaco3,
     $        rainopal,rainclay,
     $        bwchem,tuners,
     $        rain,rc)
         call porewater_steady_state(
     .        runid,iinit,iunit,idebug,
     $        rc, 
     $        pw_conc, sl_gg,
     $        bwchem,
     $        rain,  
     $        pw_react_tot, pw_diff_tot,
     $        sl_react_tot,
     $        sl_inv, burial, pw_residual,
     $        org_consume, z_level,
     $        storage,
     $        iter)
      enddo
#endif


#ifndef MPI_Output
      write(iunit,*) "
" write(iunit,*) write(iunit,*) "
" write(iunit,*) "

Rate Constants Chosen by the Model

" write(iunit,*) "", nrcmax do irc=1,nrcmax c write(iunit,*) irc write(iunit,100) "", $ "", $ "", $ "", $ "", $ "" enddo write(iunit,*) "
", irc,"", ratename(irc),"", rc(irc), "", rateunits(irc),"
" 100 format(a5, $ a5,i4,a5, $ a5,a12,a5, $ a5,g12.4,a5, $ a5,a20,a5, $ a5) write(iunit,*) write(iunit,*) "
" write(iunit,*) "

Calculated Rain Rates umol/cm2yr

" write(iunit,*) "" write(iunit,110) "" write(iunit,110) "" write(iunit,110) "" write(iunit,110) "" 110 format(3a12,g12.4,a12) write(iunit,*) "
", "FastOrg", $ "", rain(1), "
", "FastOrg", $ "", rain(2), "
", "MnO2", $ "", rain(6), "
", "FeOOH", $ "", rain(7), "
" #endif c MPI_Output #ifdef ReadLoop enddo #endif 999 close(9) c call converge_out(pw_conc, sl_gg, c $ residual, sl_react, sl_react_pw, c $ burial) c call profiles_out(pw_conc, sl_gg) c call fluxes_out(pw_conc, sl_gg, c $ pw_react, pw_diff, sl_react_pw, c $ burial, residual) c write(iunit,*) "********************************" c write(iunit,*) "porewaters" c write(iunit,*) c call porewaters(idebug, c $ pw_conc, sl_gg, c $ bwchem, c $ rain(1), rain(2), rain(3), rain(4), c $ rain(5), rain(6), c $ pw_react, pw_diff, sl_react_pw, c $ sl_react, sl_inv, burial, residual, c $ f_org_consume, s_org_consume, c $ iter) c call converge_out(pw_conc, sl_gg, c $ residual, sl_react, sl_react_pw, c $ burial) c call profiles_out(pw_conc, sl_gg) c call fluxes_out(pw_conc, sl_gg, c $ pw_react, pw_diff, sl_react_pw, c $ burial, residual) end em, c $ rain(1), rain(2), rain(3), rain(4), c $ rainmuds.anneal.mpi.F000644 025374 000024 00000013525 10413036311 014441 0ustar00archeruser000000 000000 #define Simultaneous #define AdaptiveTemperature program muds_fit c targets c 1 mn2+ 12 cm c 2 fe2+ 12 cm c 3 nh4 12 cm c 4 orgc 12 cm c 5 mno2 12 cm depth c 6 mno2 surface c 7 zno3 implicit none #include #include #ifdef MPI #include include 'mpif.h' #endif double precision dtuner(ntuners), $ best_tuner(ntuners), $ cost_array(ntargets), dcost_array(ntargets) double precision cost_tot, dcost_tot, best_cost_tot double precision temperature_in, temperature, $ range_master_in, range_master, range(ntuners), $ boltzmann_prob, a_dummy character*80 tune_in, tune_out, anneal_in,targetfile integer ituner,jtuner,itarget,iter,niter,iinit,i, $ i_dummy double precision a_iter integer idum double precision frand #ifdef MPI integer myid, numprocs,ierr #endif #ifdef MPI call MPI_INIT(ierr) call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr) c write(6,*) "I am", myid, " of", numprocs, ierr if(myid .EQ. Master) then #endif ! MPI call getarg(1,tune_in) call getarg(2,tune_out) call getarg(3,anneal_in) c call getarg(4,targetfile) targetfile = 'target.txt' c if(targetfile .EQ. "") then c targetfile = 'target.txt' c endif c write(6,*) "using ", targetfile open(7,file=tune_in) do ituner=1,ntuners read(7,*) tuner(ituner) enddo write(6,21) " ", tune_name write(6,20) "Tune_Ini ", tuner write(6,*) close(7) open(7,file=anneal_in) read(7,*) niter, temperature_in, range_master_in, range write(6,50) "Temp ", $ temperature_in, range_master_in, range close(7) idum = -999 call ran(idum, frand) c write(6,*) "Entering compute_cost_mpi" iinit = 1 ! first time thru #ifdef MPI endif ! Master #endif call compute_cost_mpi(targetfile,tuner,cost_array,iinit) if(myid .EQ. Master) then cost_tot = 0 do itarget = 1, ntargets cost_tot = cost_tot + cost_array(itarget) enddo best_cost_tot = cost_tot write(6,*) write(6,30) target_name write(6,10) "Cost_ini ", " ", cost_array, cost_tot write(6,*) call flush(6) endif c main loop do iter = 1, niter open(7,file=anneal_in) read(7,*) i_dummy, a_dummy, range_master_in, range write(6,50) "Ranges ", $ range_master_in, range close(7) if(myid .EQ. Master) then if(mod(iter,5) .EQ. 0) then iinit = 1 else iinit = 0 endif c iinit = 1 a_iter = iter temperature = temperature_in $ * ( 1. - a_iter/niter ) #ifdef AdaptiveTemperature $ * best_cost_tot #endif range_master = range_master_in $ * ( 1. - a_iter/niter ) write(6,50) "Temp ", $ temperature, range_master, range do ituner=1,ntuners call ran(idum,frand) frand = (frand*2.-1.) ! between -1 and 1 $ * range(ituner) $ * range_master ! now say -.1 to .1 $ + 1. ! 0.9 to 1.1 dtuner(ituner) = tuner(ituner) $ * frand enddo write(6,21) " ", tune_name write(6,20) "Tune_Try ", dtuner call flush(6) write(6,*) endif ! myid .EQ. Master call compute_cost_mpi(targetfile,dtuner,dcost_array,iinit) if(myid .EQ. Master) then dcost_tot = 0 do itarget = 1, ntargets dcost_tot = dcost_tot + dcost_array(itarget) enddo if(dcost_tot .LT. best_cost_tot) then best_cost_tot = dcost_tot open(7,file=tune_out) do ituner=1,ntuners best_tuner(ituner) = dtuner(ituner) write(7,*) best_tuner(ituner) enddo close(7) write(6,21) " ", tune_name write(6,20) "Tune_Best ", best_tuner write(6,*) endif boltzmann_prob = exp((cost_tot - dcost_tot)/temperature) call ran(idum,frand) write(6,*) "Accept if ", boltzmann_prob, " (Boltz) > ", $ frand if(frand .LT. boltzmann_prob) then do ituner=1,ntuners tuner(ituner) = dtuner(ituner) enddo do itarget=1,ntargets cost_array(itarget) = dcost_array(itarget) enddo cost_tot = dcost_tot write(6,*) write(6,30) target_name write(6,10) "Cost_new ", " ", cost_array, cost_tot write(6,21) " ", tune_name write(6,20) "Tune_next ", tuner write(6,*) else write(6,*) write(6,30) target_name write(6,10) "Cost_rej ", " ", dcost_array, dcost_tot write(6,*) endif endif ! myid .EQ. Master enddo #ifdef MPI call MPI_Finalize(ierr) #endif 10 format(2a10,8f10.5,f24.5) 30 format(20x,12a10) 20 format(a10,12f10.4) 21 format(a10,12a10) 40 format(10x,10a10) 50 format(a10,15f8.3) end else write(6,*) write(6,30) target_name write(6,10) "Cost_rej ", " ", dcost_array, dcomuds.constcal.F000644 025374 000024 00000007647 10413036311 014235 0ustar00archeruser000000 000000 program muds_constcal implicit none #include #include #include #include #include #include #include #include #include #include c#define FigenBatch integer runid double precision rc(nrcmax) double precision rain(nsolidmax) double precision porewater_conc(nzmax,nsolutemax) double precision solid_gg(nzmax,nsolidmax) double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), burial(nsolidmax), $ sl_residual(nsolidmax),pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels),storage(Stor_N) double precision bwchem(NBottomWaters), $ rainorg,rainforam,raincocco,rainarag,rainopal,rainclay double precision caco3_target(nCaCO3s), bwdco3 character*80 filename, ratefilename integer ituner, idebug, iinit, iunit,iread, iter,irc, $ ioc,isol,isite #ifdef ReadRCFile character*80 kinetics_filename #endif #ifdef FigenBatch c character*20 site_id integer id_site integer ifigen #endif data storage/Stor_N*0./ do ituner=1,nBottomWaters bwchem(ituner) = 0. enddo #ifdef FigenBatch read(5,*) read(5,*) do ifigen = 1, 1000 #endif READ(5,*) #ifdef FigenBatch . id_site, #endif $ bwchem, $ rainorg,caco3_target,rainopal,rainclay #ifdef ReadCalciteKineticsFile $ ,ratefilename #endif bwdco3 = bwchem(BWTCO2) call findtco2(bwdco3,bwchem(BWAlk), $ bwchem(BWDepth),bwchem(BWTemp), $ bwchem(BWSal),bwchem(BWTCO2)) c write(6,*) bwchem(BWTCO2) idebug = 2 iinit = 1 iunit = 6 call generate_rates( $ rainorg,caco3_target, $ rainopal,rainclay, $ bwchem,tuners, #ifdef ReadCalciteKineticsFile $ ratefilename, #endif $ rain,rc) #ifndef FigenBatch write(6,*) "

MUDS Model Output

" write(6,*) "
"
#endif
      do ioc=1,norgs
         do isol=1,nsolutemax
            org_consume(ioc,isol) = 0.
         enddo
      enddo
      do isol=1,4
         z_level(isol) = 100.
      enddo

#ifdef FigenBatch
      runid = id_site
#else
      runid = 0
#endif

      call const_cal(runid,iinit,iunit,idebug,
     $     rc, 
     $     porewater_conc, solid_gg,
     $     bwchem, 
     $     rain,
     $     pw_react_tot, pw_diff_tot,
     $     sl_react_tot,
     $     sl_inv, burial,
     $     sl_residual, pw_residual,
     $     org_consume, z_level,
     $     storage,
     $     iter)


#ifdef FigenBatch
      enddo
#else
      write(6,*) "
" write(6,*) write(6,*) "
" write(6,*) "

Rate Constants Chosen by the Model

" write(6,*) "", nrcmax do irc=1,nrcmax c write(6,*) irc write(6,100) "", $ "", $ "", $ "", $ "", $ "" enddo write(6,*) "
", irc,"", ratename(irc),"", rc(irc), "", rateunits(irc),"
" 100 format(a5, $ a5,i4,a5, $ a5,a12,a5, $ a5,g12.4,a5, $ a5,a20,a5, $ a5) write(6,*) write(6,*) "
" write(6,*) "

Calculated Rain Rates umol/cm2yr

" write(6,*) "" write(6,110) "" write(6,110) "" write(6,110) "" write(6,110) "" 110 format(3a12,g12.4,a12) write(6,*) "
", "FastOrg", $ "", rain(1), "
", "FastOrg", $ "", rain(2), "
", "MnO2", $ "", rain(6), "
", "FeOOH", $ "", rain(7), "
" #endif end Rain Rates umol/cm2yr" write(6,*) "" write(6,110) " H4SiO4 c rate = rc(JOpal) * (rc(JOpSat) - Si) * SiO2 integer JOpal,JOpSat parameter (JOpal = 144, JOpSat = 145) c----------------------------------------------------------------------- c Radio Tracer decay c rate = rc(JSTracer) * STracer integer JSTracer parameter(JSTracer=146) c----------------------------------------------------------------------- c scale depth for respiration reactions integer JRespScale parameter(JRespScale=147) c Db integer JDb parameter(JDb=148) c bioturbation depth integer JZMix parameter(JZMix=149) c irrigation rate integer JIrrig, JIrrigZ parameter(JIrrig=150, JIrrigZ = 151) c----------------------------------------------------------------------- c manganese recycling integer JMnIR !,JMnDR parameter(JMnIR=152) !, JMnDR=xx) c----------------------------------------------------------------------- c iron recycling integer JFeIR ! ,JFeDR parameter(JFeIR=153) !, JFeDR=xx) c----------------------------------------------------------------------- c iron adsorption integer JFeAds parameter(JFeAds=154) character*10 ratename(nrcmax) character*20 rateunits(nrcmax) data ratename/ . 'JfastOrg','JslowOrg', a 'JMnOx', b 'JfastMnOrg','JslowMnOrg', c 'JfastNO3Org','JslowNO3Org', d 'JFeOx', e 'JfastFeOrg','JslowFeOrg', f 'JfastSO4Org','JslowSO4Org', g 'JH2SOx','JFesPcp','JFeSOx', h 'JNH4Ox','U6+Red','UO2Ox', ! up to 18 now . 10*'JCaPhs', ! 19 i 10*'JCaCO3K', ! 29 1 10*'JCaCO3S', 2 10*'JCaCO3N', . 10*'JCaCO3K1', . 10*'JCaCO3K2', 3 10*'JCaCO3L', 4 10*'JCPcpK', 5 10*'JCPcpS', 6 10*'JCPcpA', 7 10*'JCFrg', 8 10*'JCFrgD', j 'K1','K2','Kb', ! 119 . 'MnCO3k','MnCO3Sat', k 'KOpal','OpalSat','TraceL','RespDepth', l 'Db','ZDb','Irrig','IrrigZ', m 'MnIRedep', ! 'MnDRedep', m 'FeIRedep', ! 'FeDRedep', o 'FeAds'/ data rateunits/'1/s','1/s', a '1/s', b '1/s','1/s', c '1/s','1/s', d '1/s', e '1/s','1/s', f '1/s','1/s', g '1/s','mol^2/s','1/s', h '1/s','1/s','1/s', . 10*' ', i 10*'1/s', 1 10*'mol/l', 2 10*' ', . 10*'1/s', . 10*'1/s', 3 10*' ', 4 10*'1/s', 5 10*' ', 6 10*'m2/g', 7 10*'frc', 8 10*' ', j ' ',' ',' ', 9 '1/s','mol/l', k '1/s','mol/l','1/s','cm', l 'cm^2/yr','cm','cm/day','cm', m 'fraction', ! 'fraction', n 'fraction', ! 'fraction', o ' '/ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C units: pw concentrations in moles / l *porewater* c pw rates in moles / l porewater sec c pw rates may have some "rate hangovers" for next cycle c diagnostic pw_sum_react in moles / cm2 yr C solid concs (-ml) in moles / l *total* C solid fractions in g / g c solid rates calculated in pwss in moles / l total sec c then converted in solidss to g / g yr, then reset to 0 c diagnostic sl_sum_react in g / cm2 yr cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c reactions c OM = (CH2O)stoic(STOIC_REDFIELDC) (NH3)stoic(STOIC_REDFIELDN) (H3PO4) c 106 16 1 c----------------------------------------------------------------------- c OXYGEN respiration c OM + stoic(STOIC_REDFIELDO) O2 -> c stoic(STOIC_REDFIELDC) CO2 + stoic(STOIC_REDFIELDN) NO3+ H3PO4 c 138 106 16 c + (stoic(STOIC_REDFIELDC) + stoic(STOIC_REDFIELDN) ) H2O c 122 c----------------------------------------------------------------------- c MANGANESE oxidation (precipitation; oxic) c stoic(STOIC_MNOXMN)*(1-stoic(STOIC_MnCO3aq)) Mn2+ + O2 -> stoic(STOIC_MNOXMN) MnO2 + stoic(STOIC_MNOXHP) H+ c 2 2 4 c c this is expressed in the code as c c 2Mn2+ + O2 + 4 HCO3- --> 2 MnO2 + 4 H2CO3 c----------------------------------------------------------------------- c MANGANESE reduction (respiration; anoxic) c OM + stoic(STOIC_MNORGMN) MnO2 c + (stoic(STOIC_MNORGHP) c * stoic(MnOrgMn)*stoic(STOIC_MnCO3aq)*2 c H+ c -> c stoic(STOIC_MNORGMN)*(1-STOIC_MnCO3aq) Mn2+ c + stoic(STOIC_MNORGMN)*stoic(STOIC_MnCO3aq) MnCO3(aq) c + ( stoic(106.) c - stoic(STOIC_MnOrgMn)*stoic(STOIC_MnCO3aq) c ) CO2 c + stoic(2)/2 N2 + H3PO4 c + ( stoic(1) + 3/2 stoic(2) + 1/2 stoic(7) ) H2O c c this is expressed in the code as c c 236/106 CH2O + MnO2 + (2 - 106/236 - .35) H2CO3 -> c ~3 c Mn2+ (both speciations) + 2(1-.35) HCO3= c c----------------------------------------------------------------------- c NITRATE respiration c OM + stoic(STOIC_NO3ORGN) HNO3 -> c 94.4 c (stoic(106.) - stoic(STOIC_NO3OrgN)) CO2 c 106-94.4 c + (stoic(16.) + stoic(STOIC_NO3ORGN) )/2 N2 c + H3PO4 c + ( stoic(1) + 3/2 stoic(2) + 1/2 stoic(8) ) H2O c this is expressed in the code as c C H O N H + 94.4 NO3- --> (106-94.4) CO2 + 94.4 HCO3 c 106 212 106 16 48 c----------------------------------------------------------------------- c IRON oxidation (precipitation) c c stoic(STOIC_FEOXF) Fe2+ + O2 -> stoic(STOIC_FEOXF) FeOOH + stoic(STOIC_FEOXHP) H+ c 2 2 2 c c this is expressed in the code as c 5 Fe2+ + NO3- + 9 HCO3 --> 5 FeOOH + 9 CO2 c F H F H c----------------------------------------------------------------------- c IRON respiration (anoxic) c c OM + stoic(STOIC_FEORGF) FeOOH + stoic(STOIC_FEORGHP) H+ -> c 472 944 c stoic(STOIC_FEORGF) Fe2+ + stoic(106.) CO2 c 472 c + stoic(16.) NH4 + H3PO4 + H2O c this is expressed in the code as c OC + 472/106 FeOOH + (944-106)/106 CO2 --> 944/106 HCO3- + 472/106 Fe2+ c----------------------------------------------------------------------- C SULFATE respiration c c OM + stoic(STOIC_SO4ORGS) SO4(2-) + stoic(STOIC_SO4ORGHP) H(+) -> c 59 59 c stoic(106.) CO2 c + stoic(16.)/2 N2 + stoic(STOIC_SO4ORGS) HS(-) c + H3PO4 c c this is expressed in the code as c OC + 59/106 SO4 --> (106-59)/106 CO2 + 59/106 HCO3 + 59/106 HS c----------------------------------------------------------------------- c SULFIDE oxidation C c HS(-) + stoic(STOIC_HSOXO2) O2 -> c 2 c SO4(2-) + stoic(STOIC_HSOXHP) H(+) c 1 c this is expressed in the code as c HS + 2 O2 + HCO3 --> SO4 + CO2 c----------------------------------------------------------------------- c IRON SULFIDE precipitation c c HS(-) + stoic(STOIC_HSFEF) Fe(2+) -> c 1 c Fe(stoic(STOIC_HSFEF))S + stoic(STOIC_HSFEHP) H(+) c 1 1 c----------------------------------------------------------------------- c IRON SULFIDE oxidation c c Fe(stoic(1.))S + stoic(STOIC_FESOXO2) O2 + stoic(STOIC_FESOXHP) H+ c 1 4.5 1 c --> stoic(STOIC_H2HEF) Fe3+ + SO4= c expressed in the code as c FeS + 4.5 O2 + HCO3- --> FeOOH + SO4= + CO2 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Ammonia Oxidation c NH4+ + 2 O2 -> NO3- + 2 H+ c----------------------------------------------------------------------- c URANIUM reduction c c UO2(CO3)3 (4-) + stoic(STOIC_UREDF) Fe(2+) + H2O -> c 2 c UO2 + stoic(STOIC_UREDF) FeOOH c 2 c + stoic(STOIC_UC) CO3(2-) c 3 c + stoic(STOIC_UREDHP) H+ c 6 c U6 ---> UO2 c----------------------------------------------------------------------- C URANIUM oxidation c c UO2 + stoic(STOIC_UOXO2) O2 + stoic(3.) CO3(2-) + stoic(STOIC_UOXHP) H+ -> c 0.5 3 2 c UO2(CO3)3(4-) c----------------------------------------------------------------------- c depths (z_level array) integer koxic, kno3, kmno2, kfe, kso4 parameter(KOXIC=1) parameter(KNO3=2) parameter(KMNO2=3) parameter(KFE=4) parameter(KSO4=5) integer ntuners parameter(ntuners=7) double precision tuners(ntuners) character*5 tune_name(ntuners) data tune_name /"MnR","FeR","SR", . "NR","OxF","Rz", . "IrZ"/ data tuners /1.936750116139906, . 0.3783755732806870, . 1.267417488002148, . 0.1987629916218464, . 1.616305098330981, . 0.7116529651310910, . 0.3462060723323323/ c#define TMnIRedep 7 c#define TFeIRedep 10 c#define TMnDRedep 8 c#define TMnCO3k 10 c#define TFeAds 7 c#define TFeIRedep 8 c#define TMnOx 2 c#define TMnCO3Sat 3 c#define TIrrigScale 6 c#define 6 7 c#define TDbZ 8 c#define TDb 9 ccc#define TIrrigOffset 12 integer nBottomWaters parameter (nBottomWaters=10) integer Stor_N parameter(Stor_N= 18*19) c needs 6 c needs 11 integer runid double precision rc(nrcmax) double precision rain(nsolidmax) double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), omega(nzmax), burial(nsolidmax), $ sl_residual(nsolidmax),pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels),storage(Stor_N) double precision bwchem(NBottomWaters), $ rainorg,raincaco3(nCaCO3s), $ rainopal,rainclay character*80 ratefilename integer ituner, idebug, iinit, iread, iter,irc, iunit, $ ioc,isol,isite, itest data storage/Stor_N*0./ do ioc=1,nBottomWaters bwchem(ioc) = 0. enddo bwchem(9) = 4. bwchem(10) = 35. READ(5,*) bwchem(1), bwchem(2), bwchem(3), $ bwchem(4), bwchem(5), $ bwchem(8), $ rainorg,raincaco3(1),rainopal,rainclay idebug = 2 iunit = 6 iinit = 1 call generate_rates( $ rainorg,raincaco3, $ rainopal,rainclay, $ bwchem,tuners, $ rain,rc) write(iunit,*) "

MUDS Model Output

" write(iunit,*) "
"


      do ioc=1,norgs
         do isol=1,nsolutemax
            org_consume(ioc,isol) = 0.
         enddo
      enddo
      do isol=1,nzlevels
         z_level(isol) = 100.
      enddo

      runid = isite







      call full_steady_state(


     $ runid,iinit,iunit,idebug,
     $ rc,
     $ pw_conc, sl_gg,
     $ bwchem,
     $ rain,
     $ pw_react_tot, pw_diff_tot,
     $ sl_react_tot,
     $ sl_inv, omega, burial,
     $ sl_residual, pw_residual,
     $ org_consume, z_level,
     $ storage,
     $ iter)
c#define PorewaterSteadyState
      write(iunit,*) "
" write(iunit,*) write(iunit,*) "
" write(iunit,*) "

Rate Constants Chosen by the Model

" write(iunit,*) "
", nrcmax do irc=1,nrcmax c write(iunit,*) irc write(iunit,100) "", $ "", $ "", $ "", $ "", $ "" enddo write(iunit,*) "
", irc,"", ratename(irc),"", rc(irc), "", rateunits(irc),"
" 100 format(a5, $ a5,i4,a5, $ a5,a12,a5, $ a5,g12.4,a5, $ a5,a20,a5, $ a5) write(iunit,*) write(iunit,*) "
" write(iunit,*) "

Calculated Rain Rates umol/cm2yr

" write(iunit,*) "" write(iunit,110) "" write(iunit,110) "" write(iunit,110) "" write(iunit,110) "" 110 format(3a12,g12.4,a12) write(iunit,*) "
", "FastOrg", $ "", rain(1), "
", "FastOrg", $ "", rain(2), "
", "MnO2", $ "", rain(6), "
", "FeOOH", $ "", rain(7), "
" c MPI_Output 999 close(9) c call converge_out(pw_conc, sl_gg, c $ residual, sl_react, sl_react_pw, c $ burial) c call profiles_out(pw_conc, sl_gg) c call fluxes_out(pw_conc, sl_gg, c $ pw_react, pw_diff, sl_react_pw, c $ burial, residual) c write(iunit,*) "********************************" c write(iunit,*) "porewaters" c write(iunit,*) c call porewaters(idebug, c $ pw_conc, sl_gg, c $ bwchem, c $ rain(1), rain(2), rain(3), rain(4), c $ rain(5), rain(6), c $ pw_react, pw_diff, sl_react_pw, c $ sl_react, sl_inv, burial, residual, c $ f_org_consume, s_org_consume, c $ iter) c call converge_out(pw_conc, sl_gg, c $ residual, sl_react, sl_react_pw, c $ burial) c call profiles_out(pw_conc, sl_gg) c call fluxes_out(pw_conc, sl_gg, c $ pw_react, pw_diff, sl_react_pw, c $ burial, residual) end ite(iunit,*) "porewaters" c write(iunit,*muds.global.F000644 025374 000024 00000025255 10413036311 013662 0ustar00archeruser000000 000000 #define MPIList PROGRAM jahnke c usage: echo | muds.global implicit none #include #include #include #include #include #include #include #include c muds variables integer nx,ny parameter(nx=180, ny=91) double precision rc(nrcmax) double precision porewater_conc(nzmax,nsolutemax,nx,ny) double precision solid_gg(nzmax,nsolidmax,nx,ny) double precision pw_react(nsolutemax,nx,ny), $ pw_diff(nsolutemax,nx,ny), $ sl_react(nsolidmax,nx,ny), $ sl_react_pw(nsolidmax,nx,ny) double precision $ sl_inv(nsolidmax,nx,ny), $ omega(nzmax,nx,ny), burial(nsolidmax,nx,ny), $ sl_residual(nsolidmax,nx,ny), $ pw_residual(nsolidmax,nx,ny), $ org_consume(norgs,nsolutemax,nx,ny), $ z_level(nzlevels,nx,ny), irrig_rate(nx,ny) double precision porewater_store(nzmax,nsolutemax), $ solidgg_store(nzmax,nsolidmax) double precision rain(nsolidmax) double precision global_burial(nsolidmax), $ global_org(nsolutemax) double precision storage(Stor_N,nx,ny) real pwz(nzmax),drain,daou,aou character*80 cdfname c jahnke variables INTEGER rcode INTEGER rhid INTEGER start(2),count(2),dims(2) REAL resp(nx,ny), dco3bw(nx,ny), z(nx, ny),detrain(nx,ny), $ o2bw(nx,ny), po4bw(nx,ny), tco2bw(nx,ny), sibw(nx,ny), $ temp(nx,ny) real highsed(nx,ny) REAL g_lat(ny), g_long(nx) REAL calpc(nx,ny), acc(nx,ny) double precision bwchem(nBottomWaters) double precision rainratio, siratio,areabox,orgtot integer iz,iz2,iy,iyy,ix,isol,idebug,init,id,ioc,iter integer idResp, idZ, idDCO3, idO2, idPO4, idTCO2, idSI, $ idT, idDetRain DATA start /1, 1/ DATA count /nx, ny/ DATA dims /1, 2/ #ifdef MPIList open(unit=9,file='mpilist.junk') open(unit=10,file='iospecs.junk') #endif open(unit=8, file= $ "grid.txt") do iz=1, 17 read(8,*) pwz(iz) enddo 10 do iz2=iz, nzmax pwz(iz2) = pwz(iz-1) + 2 enddo close(8) c read(5,*) drain,daou drain=0. daou=0. idResp = ncopn('oxygen_flux.cdf', NCNOWRIT,rcode) CALL ncvgt( idResp, 3, start, count, resp, rcode) c oxygen flux, mol/m2 yr from Jahnke GBC 10: 71 idZ = ncopn('z.2.cdf', NCNOWRIT,rcode) CALL ncvgt( idZ, 3, start, count, Z, rcode) idDCO3 = ncopn('dco3bw.cdf', NCNOWRIT,rcode) CALL ncvgt( idDCO3, 3, start, count, dco3bw, rcode) CALL ncvgt(idDCO3, 1, 1, nx, g_long, rcode) CALL ncvgt(idDCO3, 2, 1, ny, g_lat, rcode) idO2 = ncopn('o2bw.cdf', NCNOWRIT,rcode) CALL ncvgt( idO2, 3, start, count, o2bw, rcode) idPO4 = ncopn('po4bw.cdf', NCNOWRIT,rcode) CALL ncvgt( idPO4, 3, start, count, po4bw, rcode) idTCO2 = ncopn('tco2bw.2.cdf', NCNOWRIT,rcode) CALL ncvgt( idTCO2, 3, start, count, tco2bw, rcode) idSi = ncopn('sibw.2.cdf', NCNOWRIT,rcode) CALL ncvgt( idSi, 3, start, count, sibw, rcode) idT = ncopn('tbw.2.cdf', NCNOWRIT,rcode) CALL ncvgt( idT, 3, start, count, temp, rcode) idDetRain = ncopn('ncmar.md.cdf',NCNOWRIT,rcode) CALL ncvgt(idDetRain, 3, start, count, detRain, rcode) open(8,file="highsed.txt") read(8,*) do iy=1,ny read(8,*) iyy,(highsed(ix,iyy),ix=1,nx) enddo close(8) do iy=1,90 do ix=1,179 detrain(ix,iy) = detrain(ix,iy) $ * 0.2 * 2.5 / 1000 * 1.e6 $ + highsed(ix,iy) * 20000. enddo enddo c call init_kinetics( c $ 'kinetics.linear', c $ rc, nrcmax, db, z_mix) do isol=1,nsolidmax global_burial(isol) = 0. enddo do isol=1,nsolutemax global_org(isol) = 0. enddo C$DOACROSS C$& local (iy,rain,rc,iter,areabox,id, c$& porewater_store,solidgg_store,bwchem,init,idebug,aou, c$& rainratio,siratio,ioc) c$& mp_schedtype=dynamic DO ix = 1, nx init = 1 idebug = 0 DO iy = 1, ny IF( detrain(ix,iy) .GT. 0.0 $ .AND. $ resp(ix,iy) .GT. 0.0 $ .AND. $ dco3bw(ix,iy) .GT. -100 $ ) THEN if(o2bw(ix,iy) .LT. 0) then bwchem(BWO2) = 100. else bwchem(BWO2) = MAX(o2bw(ix,iy),0.) endif if(daou .NE. 0) then call do_aou(temp(ix,iy),o2bw(ix,iy),aou) bwchem(BWO2) = bwchem(BWO2) + daou * aou bwchem(BWO2) = MAX(bwchem(BWO2),0.) endif bwchem(BWNO3) = MAX(po4bw(ix,iy)*15,0.) if(sibw(ix,iy) .GT. 0) then bwchem(BWSi) = sibw(ix,iy) else bwchem(BWSi) = 100. endif if(temp(ix,iy) .GT. 0) then bwchem(BWTemp) = temp(ix,iy) else bwchem(BWTemp) = 2. endif bwchem(BWSal) = 34.7 bwchem(BWDepth) = -z(ix,iy) if(tco2bw(ix,iy) .GT. 0) then bwchem(BWTCO2) = tco2bw(ix,iy) else bwchem(BWTCO2) = 2200. endif call findalk(DBLE(dco3bw(ix,iy)), $ bwchem(BWTCO2), $ bwchem(BWDepth), $ bwchem(BWTemp), $ bwchem(BWSal), bwchem(BWAlk)) bwchem(BWH2S) = 0. bwchem(BWNH4) = 0. resp(ix,iy) = resp(ix,iy)*1.d2 resp(ix,iy) = resp(ix,iy) / 1.45 ! 154 O2:106 C c resp(ix,iy) = c $ 1.2 * resp(ix,iy) c $ + 0.002 * resp(ix,iy)**2 if(drain .NE. 0) then resp(ix,iy) = (1 + drain) * resp(ix,iy) endif rainratio = 1.4 siratio = 0.8 call generate_rates(DBLE(resp(ix,iy)), $ DBLE(resp(ix,iy)*rainratio), $ DBLE(resp(ix,iy)*0.1), $ DBLE(resp(ix,iy)*siratio), $ DBLE(detrain(ix,iy)), $ bwchem,tuners, $ rain, $ rc) #ifdef SiteStdOut write(6,*) write(6,*) "******************************" write(6,100) "Grid", ix, iy, $ bwchem(BWO2), bwchem(BWNO3), bwchem(BWSi), $ bwchem(BWAlk),bwchem(BWTCO2),bwchem(BWDepth), $ resp(ix,iy),resp(ix,iy)*rainratio, $ resp(ix,iy)*siratio,detrain(ix,iy) 100 format(a5, 2I4, 10f10.3) #endif id = ix*1000+iy c#define InitBoost #ifdef InitBoost if(init .EQ. 0) then write(6,*) "copying from stored site" call copy_site(porewater_store, $ porewater_conc(1,1,ix,iy), $ solidgg_store, $ solid_gg(1,1,ix,iy)) endif #endif irrig_rate(ix,iy) = rc(JIrrig) areabox = cos(g_lat(iy)/180*3.14159) $ * 111.4 * 111.4 * 4 c km^2 #ifdef MPIList call list_mudsargs( #else call full_steady_state( #endif $ id,init,idebug, $ rc, $ porewater_conc(1,1,ix,iy), $ solid_gg(1,1,ix,iy), $ bwchem, $ rain, $ pw_react(1,ix,iy), pw_diff(1,ix,iy), $ sl_react_pw(1,ix,iy), $ sl_react(1,ix,iy), sl_inv(1,ix,iy), $ omega(1,ix,iy),burial(1,ix,iy), $ sl_residual(1,ix,iy),pw_residual(1,ix,iy), $ org_consume(1,1,ix,iy), z_level(1,ix,iy), $ storage(1,ix,iy), $ iter) call flush(6) #ifndef MPIList do isol=1,nsolidmax global_burial(isol) = global_burial(isol) $ - burial(isol,ix,iy) / molwt(isol) c mol / cm2 yr $ * 1.e10 * areabox c mol / yr enddo do isol=1,nsolutemax do ioc = 1, norgs global_org(isol) = global_org(isol) $ - org_consume(ioc,isol,ix,iy) c mol / cm2 yr $ * 1.e10 * areabox c mol / yr enddo enddo c write(7,*) resp(ix,iy)*1.e2, c $ resp(ix,iy)*rainratio*1.e2, c $ dco3bw(ix,iy), c $ -burial(5,ix,iy)*1.e4 c write(6,*) resp(ix,iy)*1.e2, c $ resp(ix,iy)*rainratio*1.e2, c $ dco3bw(ix,iy), c $ -burial(5,ix,iy)*1.e4 call flush(6) #endif ENDIF ENDDO ENDDO close(7) call getarg(1,cdfname) if(cdfname .EQ. "") then cdfname = "jahnke.cdf" endif #ifndef MPIList write(6,*) write(6,*) "Global Burial" do isol=1,nsolidmax write(6,*) solidname(isol), global_burial(isol) enddo orgtot = 0. do isol=1,nsolutemax orgtot = orgtot + global_org(isol) enddo write(6,*) write(6,*) "Organic Fraction" do isol=1,nsolutemax write(6,*) solutename(isol), global_org(isol)/orgtot enddo write(6,*) #endif #ifdef MPIList call write_iospecs( #else call writemudcdf( #endif $ cdfname, $ porewater_conc,solid_gg, $ burial, omega, sl_react_pw, irrig_rate, $ z_level, org_consume, $ 'longt','lat', $ g_long,g_lat,pwz, $ nx,ny,nzmax) END SUBROUTINE do_aou(t,oxyg,aou) REAL t,s,oxyg,aou real cstar,sato2,aou s = 35. cstar = - 173.4292 1 + 249.6339 * (100 / (t + 273.15) ) 2 + 143.3483 * LOG( (t + 273.15) / 100 ) 3 - 21.8492 * ( (t + 273.15) / 100 ) 4 + s * ( - .033096 5 + .014259 6 * ( (t + 273.15) / 100. ) 7 - .0017000 8 * ( (t + 273.15) / 100. )**2 9 ) C cstar = EXP(cstar) C umol / l sato2 = cstar / 22.414 * 1013. aou = sato2 - oxyg RETURN END (t + 273.15) ) 2 + 143.3483 * LOG( (t + 273.15) / 100 ) 3 - 21.8492 * ( (t + 273.15) / 100 ) 4 + s * ( - .033096 5 + .014259 6 * ( (t + 273.15) / 100. ) 7 - .0017000 8 * ( (t + 273.15) / 10muds.mpi.F000644 025374 000024 00000073417 10413036311 013212 0ustar00archeruser000000 000000 c#define VerboseStdOut #define UseMalloc program muds_list_mpi implicit none #include #include #include #include #include #include #include #include #include #include #include #include integer runid,iinit,idebug,iter(nsitesmax),kmax,iendpos #ifdef UseMalloc double precision, allocatable, dimension (:) :: storage, $ irrig_rate double precision, allocatable, dimension (:,:) :: rc, rain, $ pw_react,pw_diff, sl_react, sl_react_pw, sl_inv, omega, $ burial, sl_residual, pw_residual,z_level, bwchem double precision, allocatable, dimension (:,:,:) :: $ porewater_conc, solid_gg, org_consume #else double precision rc(nrcmax,nsitesmax) double precision rain(nsolidmax,nsitesmax) double precision porewater_conc(nzmax,nsolutemax, $ nsitesmax) double precision solid_gg(nzmax,nsolidmax, $ nsitesmax) double precision pw_react(nsolutemax,nsitesmax), $ pw_diff(nsolutemax,nsitesmax), $ sl_react(nsolidmax,nsitesmax), $ sl_react_pw(nsolidmax,nsitesmax), $ sl_inv(nsolidmax,nsitesmax), $ omega(nzmax,nsitesmax), $ burial(nsolidmax,nsitesmax), $ sl_residual(nsolidmax,nsitesmax), $ pw_residual(nsolutemax,nsitesmax), $ org_consume(norgs,nsolutemax,nsitesmax), $ z_level(nzlevels,nsitesmax), $ storage(Stor_N),irrig_rate(nsitesmax) double precision bwchem(NBottomWaters,nsitesmax) #endif integer i_loop,ituner,nx_out,ny_out,ix,iy,iz,index real x_sp(200),y_sp(200),z_sp(nzmax), buffer(arg_length) double precision z(nzmax),ggtot #ifdef UseMalloc real, allocatable, dimension(:,:) :: arg_array #else real arg_array(in_arg_length,nsitesmax) #endif integer myid, iproc, numprocs, n_sites_found,ierr character*80 filename character*80 xlabel,ylabel,suffix,mpifile,iofile #ifndef UseMalloc data storage/Stor_N*0./ #endif #ifdef MPI call MPI_INIT(ierr) call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr) c write(6,*) "I am", myid, " of", numprocs, ierr #else myid = Master #endif if(myid .EQ. Master) then #ifdef UseMalloc allocate(storage(Stor_N), $ irrig_rate(nsitesmax), $ STAT=ierr) do i_loop=1,Stor_N storage(i_loop) = 0. enddo allocate(rc(nrcmax,nsitesmax), $ rain(nsolidmax,nsitesmax), $ pw_react(nsolutemax,nsitesmax), $ pw_diff(nsolutemax,nsitesmax), $ sl_react(nsolidmax,nsitesmax), $ sl_react_pw(nsolidmax,nsitesmax), $ sl_inv(nsolidmax,nsitesmax), $ omega(nzmax,nsitesmax), $ burial(nsolidmax,nsitesmax), $ sl_residual(nsolidmax,nsitesmax), $ pw_residual(nsolutemax,nsitesmax), $ z_level(nzlevels,nsitesmax), $ bwchem(NBottomWaters,nsitesmax), $ STAT=ierr) allocate(porewater_conc(nzmax,nsolutemax,nsitesmax), $ solid_gg(nzmax,nsolidmax,nsitesmax), $ org_consume(norgs,nsolutemax,nsitesmax), $ STAT=ierr) allocate(arg_array(in_arg_length,nsitesmax),STAT=ierr) if(ierr .EQ. 0) then write(6,*) "process ", myid, " allocating OK" endif c p_arg = malloc(in_arg_length*nsitesmax*4) #endif call getarg(1,suffix) if(suffix .EQ. "" .OR. suffix .EQ. "-p4pg") then suffix = "junk" endif do iendpos=80,1,-1 if(suffix(iendpos:iendpos) .NE. ' ') then goto 99 endif enddo 99 continue mpifile = suffix(1:iendpos) // ".mpilist" iofile = suffix(1:iendpos) // ".iospecs" write(6,*) "reading ", mpifile, iofile open(unit=7,file=mpifile) n_sites_found = 0 do i_loop = 1, nsitesmax READ(7,*,END=200) (arg_array(ix,i_loop), $ ix=1,in_arg_length) n_sites_found = n_sites_found + 1 enddo 200 continue nx_out = n_sites_found ! defaults to 1-d output ny_out = 1 open(10,file=iofile) read(10,180,END=210) filename write(6,*) "writing output cdf files: ", filename if(filename .EQ. 'none') then goto 210 endif read(10,120) xlabel read(10,120) ylabel read(10,*) nx_out,ny_out read(10,*) (x_sp(ix),ix=1,nx_out), $ (y_sp(ix),ix=1,ny_out), $ (z_sp(ix),ix=1,nzmax) c nx_out = 200 c ny_out = 10 do ix=1,nzmax z(ix) = z_sp(ix) enddo 180 format(1x,a80) 120 format(1x,a20) 210 continue c nx_out = 20 c ny_out = 10 write(6,*) "running number of sites ", n_sites_found c zero arrays do index=1,nsitesmax call compact_mudsargs(runid,iinit,idebug, $ rc(1,index), $ porewater_conc(1,1,index), $ solid_gg(1,1,index), $ bwchem(1,index), $ rain(1,index), $ pw_react(1,index), $ pw_diff(1,index), $ sl_react_pw(1,index), $ sl_react(1,index), $ sl_inv(1,index), $ omega(1,index), $ burial(1,index), $ sl_residual(1,index), $ pw_residual(1,index), $ org_consume(1,1,index), $ z_level(1,index), $ storage, $ iter(index), $ buffer,zero_expanded) irrig_rate(index) = 0. enddo endif ! myid .eq. master c#define Dummy #ifdef Dummy if(myid .EQ. Master) then call dummy_all(arg_array,n_sites_found,nx_out,ny_out, $ runid,iinit,idebug, $ rc, $ porewater_conc, $ solid_gg, $ bwchem, $ rain, $ pw_react, $ pw_diff, $ sl_react_pw, $ sl_react, $ sl_inv, $ omega, $ burial, $ sl_residual, $ pw_residual, $ org_consume, $ z_level, $ storage, $ iter) endif #else call queue_all(arg_array,n_sites_found,nx_out,ny_out, $ runid,iinit,idebug, $ rc, $ porewater_conc, $ solid_gg, $ bwchem, $ rain, $ pw_react, $ pw_diff, $ sl_react_pw, $ sl_react, $ sl_inv, $ omega, $ burial, $ sl_residual, $ pw_residual, $ org_consume, $ z_level, $ storage, $ iter) #endif if(myid .EQ. Master) then do i_loop = 1, n_sites_found c do i_loop = 1, 2 runid = arg_array(1,i_loop) ix = runid/1000 iy = MOD(runid,1000) c write(6,*) ix,iy index = ix + (iy-1) * nx_out c write(6,*) "found", ix,iy,index kmax = nzmax-1 irrig_rate(index) = rc(JIrrig,index) ggtot = 0. do ix=1,nsolidmax ggtot = ggtot + solid_gg(kmax,ix,index) enddo if(idebug .GE. 1) then write(6,*) write(6,*) "*******************************************" write(6,300) "Runid", runid, "iters=", iter(index), $ "ggtot=", ggtot*100. write(6,301) "O2","NO3","Alk","TCO2","Si", $ "z","T","S","ROC","RCl","RCa","RAr", $ "RSi", "SSi" write(6,302) bwchem(BWO2,index), $ bwchem(BWNO3,index), $ bwchem(BWAlk,index), $ bwchem(BWTCO2,index), $ bwchem(BWSi,index), $ bwchem(BWDepth,index), $ bwchem(BWTemp,index), $ bwchem(BWSal,index), $ (rain(IORG,index)+rain(IORG+1,index)) * 1.e6, $ (rain(ix,index)*1e6,ix=ICLAY,ISiO2), $ rc(JOpal,index)*1.e6 300 format( a6, i8, a10,i4, a10,f6.2) 301 format(15A8) 302 format(7F8.0,8F8.1) endif if(idebug .GE. 2) then call profiles_out(6,porewater_conc(1,1,index), $ solid_gg(1,1,index), $ z,omega(1,index),kmax, $ solute_scale,z_level(1,index), $ rc(1,index),org_consume(1,1,index), $ solid_scale,solidname,solutename) call solid_report(6,porewater_conc(1,1,index), $ solid_gg(1,1,index), $ sl_residual(1,index), $ sl_react(1,index), $ sl_react_pw(1,index), $ burial(1,index), $ ggtot,kmax,rain(1,index),solidname,molwt) endif enddo ! i_loop if(filename .NE. 'none') then call writemudcdf(filename, $ porewater_conc,solid_gg, $ burial,omega,sl_react_pw,irrig_rate, $ z_level,org_consume, $ xlabel,ylabel, $ x_sp,y_sp,z_sp, $ nx_out,ny_out,nzmax) endif #ifdef MPI do iproc=1,numprocs-1 call MPI_SEND(MPI_BOTTOM, 0, $ MPI_DOUBLE_PRECISION, iproc, 0, $ MPI_COMM_WORLD, ierr) enddo #endif endif ! I'm master #ifdef MPI call MPI_Finalize(ierr) #endif end #ifdef MPI subroutine queue_all(arg_array,nsites,nx,ny, $ runid,iinit,idebug, $ rc, $ porewater_conc, $ solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include #include #include #include double precision rc(nrcmax,nsitesmax), $ porewater_conc(nzmax,nsolutemax,nsitesmax), $ solid_gg(nzmax,nsolidmax,nsitesmax), $ bwchem(nBottomWaters,nsitesmax), $ rain(nsolidmax,nsitesmax), $ pw_react_tot(nsolutemax,nsitesmax), $ pw_diff_tot(nsolutemax,nsitesmax), $ sl_sum_react(nsolidmax,nsitesmax), $ sl_sum_react_pw(nsolidmax,nsitesmax), $ solid_inv(nsolidmax,nsitesmax), $ omega(nzmax,nsitesmax), $ burial(nsolidmax,nsitesmax), $ sl_residual(nsolidmax,nsitesmax), $ pw_residual(nsolutemax,nsitesmax), $ org_consume(norgs,nsolutemax,nsitesmax), $ z_level(nzlevels,nsitesmax), $ storage(Stor_N) real arg_array(in_arg_length,*) real buffer(arg_length) integer nsites, isite, runid, iinit, idebug,iter(nsitesmax), $ nx,ny,index,ix,iy integer procs_list(nprocs_max), isite_list(nprocs_max), $ myid,ierr,numprocs,numsent,i,iout, $ rank,processor integer status(MPI_STATUS_SIZE) call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr) c write(6,*) "nsites = ", nsites call MPI_BCAST(nsites,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) #ifdef VerboseStdOut write(6,*) "I am ", myid,"of ", numprocs,"within queue_all", $ nsites, " arguments" call flush(6) #endif numsent = 0 if(myid .EQ. Master) then #ifdef VerboseStdOut c do i=1,nsites c write(6,*) "sites ", i, arg_array(1,i) c enddo #endif do i=1, MIN(numprocs-1,nsites) processor = i isite = i procs_list(i) = i call MPI_SEND(arg_array(1,isite), in_arg_length, $ MPI_REAL, processor, isite, $ MPI_COMM_WORLD, ierr) procs_list(i) = i isite_list(i) = i numsent = i #ifdef VerboseStdOut write(6,*) "Master: process sent to", processor, $ arg_array(1,isite), arg_length call flush(6) #endif enddo write(6,100) "Running ", $ (procs_list(iout),iout=1,numprocs-1) call flush(6) 100 format(a8, 100i5) do i=1, nsites call MPI_RECV(buffer, $ arg_length, $ MPI_REAL, $ MPI_ANY_SOURCE, MPI_ANY_TAG, $ MPI_COMM_WORLD, $ status, ierr) c waits until anything finishes processor = status(MPI_SOURCE) isite = status(MPI_TAG) runid = buffer(1) ix=runid/1000 iy=MOD(runid,1000) index=ix+(iy-1)*nx c write(6,*) "Got ", runid,ix,iy,index #ifdef VerboseStdOut write(6,*) "Master: message received from ", processor, $ buffer(1), arg_length write(6,*) "Master: expanding to ", ix,iy,index call flush(6) #endif call compact_mudsargs(runid,iinit,idebug, $ rc(1,index), $ porewater_conc(1,1,index), $ solid_gg(1,1,index), $ bwchem(1,index), $ rain(1,index), $ pw_react_tot(1,index), $ pw_diff_tot(1,index), $ sl_sum_react_pw(1,index), $ sl_sum_react(1,index), $ solid_inv(1,index), $ omega(1,index), $ burial(1,index), $ sl_residual(1,index), $ pw_residual(1,index), $ org_consume(1,1,index), ! start here $ z_level(1,index), $ storage, $ iter(index), $ buffer,expand_all) c do iout = 1, arg_length c arg_array(iout,runid) = buffer(iout) c enddo if(numsent .LT. nsites) then isite = numsent+1 call MPI_SEND(arg_array(1,isite), in_arg_length, $ MPI_REAL, processor, isite, $ MPI_COMM_WORLD, ierr) numsent = numsent + 1 procs_list(processor) = isite write(6,100) "Running ", $ (procs_list(iout),iout=1,numprocs-1) call flush(6) #ifdef VerboseStdOut write(6,*) "Master: process sent to", processor, $ arg_array(1,isite), arg_length call flush(6) #endif else ! tell slave there is no more work #ifdef CleanUp call MPI_SEND(MPI_BOTTOM, 0, $ MPI_REAL, processor, 0, $ MPI_COMM_WORLD, ierr) #endif procs_list(processor) = 0 write(6,100) "Running ", $ (procs_list(iout),iout=1,numprocs-1) call flush(6) endif enddo else ! Alas I'm a slave if(myid .GT. nsites) $ goto 200 90 call MPI_RECV(buffer, arg_length, $ MPI_REAL, Master, MPI_ANY_TAG, $ MPI_COMM_WORLD, $ status,ierr) #ifdef VerboseStdOut write(6,*) "Slave: message received by ", myid, buffer(1) call flush(6) #endif if(status(MPI_TAG) .EQ. 0) then goto 200 else isite = status(MPI_TAG) #ifdef VerboseStdOut write(6,*) "Slave: process started ", buffer(1) call flush(6) #endif call full_steady_state_compact(buffer) #ifdef VerboseStdOut write(6,*) "Slave: process completed by ", myid call flush(6) #endif call MPI_SEND(buffer,arg_length, $ MPI_REAL, Master, isite, $ MPI_COMM_WORLD, ierr) #ifdef VerboseStdOut write(6,*) "Slave: message sent by ", myid call flush(6) #endif goto 90 endif 200 continue #ifdef VerboseStdOut write(6,*) "Process ", myid, "Done" call flush(6) #endif endif return end #else ! not MPI subroutine queue_all(arg_array,nsites,nx,ny, $ runid,iinit,idebug, $ rc, $ porewater_conc, $ solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include #include #include double precision rc(nrcmax,nsitesmax), $ porewater_conc(nzmax,nsolutemax,nsitesmax), $ solid_gg(nzmax,nsolidmax,nsitesmax), $ bwchem(nBottomWaters,nsitesmax), $ rain(nsolidmax,nsitesmax), $ pw_react_tot(nsolutemax,nsitesmax), $ pw_diff_tot(nsolutemax,nsitesmax), $ sl_sum_react(nsolidmax,nsitesmax), $ sl_sum_react_pw(nsolidmax,nsitesmax), $ solid_inv(nsolidmax,nsitesmax), $ omega(nzmax,nsitesmax), $ burial(nsolidmax,nsitesmax), $ sl_residual(nsolidmax,nsitesmax), $ pw_residual(nsolutemax,nsitesmax), $ org_consume(norgs,nsolutemax,nsitesmax), $ z_level(nzlevels,nsitesmax), $ storage(Stor_N) real arg_array(in_arg_length,nsitesmax) real buffer(arg_length) integer isite, nsites, runid, iinit, idebug,iter(nsitesmax), $ iarg,nx,ny, $ ix,iy,index do isite=1,nsites do iarg=1,in_arg_length buffer(iarg) = arg_array(iarg,isite) enddo do iarg=in_arg_length+1,arg_length buffer(iarg) = 0. enddo buffer(3) = 2. ! idebug write(6,*) "Running site", isite call full_steady_state_compact( $ buffer) runid = buffer(1) ix=runid/1000 iy=MOD(runid,1000) index=ix+(iy-1)*nx call compact_mudsargs(runid,iinit,idebug, $ rc, $ porewater_conc(1,1,index), $ solid_gg(1,1,index), $ bwchem, $ rain, $ pw_react_tot(1,index), $ pw_diff_tot(1,index), $ sl_sum_react_pw(1,index), $ sl_sum_react(1,index), $ solid_inv(1,index), $ omega(1,index), $ burial(1,index), $ sl_residual(1,index), $ pw_residual(1,index), $ org_consume(1,1,index), $ z_level(1,index), $ storage, $ iter(index), $ buffer,expand_all) enddo return end #endif ! MPI subroutine dummy_all(arg_array,nsites,nx,ny, $ runid,iinit,idebug, $ rc, $ porewater_conc, $ solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include #include #include integer iarg,nsites double precision rc(nrcmax,nsitesmax), $ porewater_conc(nzmax,nsolutemax,nsitesmax), $ solid_gg(nzmax,nsolidmax,nsitesmax), $ bwchem(nBottomWaters,nsitesmax), $ rain(nsolidmax,nsitesmax), $ pw_react_tot(nsolutemax,nsitesmax), $ pw_diff_tot(nsolutemax,nsitesmax), $ sl_sum_react(nsolidmax,nsitesmax), $ sl_sum_react_pw(nsolidmax,nsitesmax), $ solid_inv(nsolidmax,nsitesmax), $ omega(nzmax,nsitesmax), $ burial(nsolidmax,nsitesmax), $ sl_residual(nsolidmax,nsitesmax), $ pw_residual(nsolutemax,nsitesmax), $ org_consume(norgs,nsolutemax,nsitesmax), $ z_level(nzlevels,nsitesmax), $ storage(Stor_N,nsitesmax) real arg_array(in_arg_length,nsites) real buffer(arg_length) integer isite,ix,iy,runid,nx,ny, $ iter(nsitesmax),idebug,iinit,index do iarg=1,in_arg_length buffer(iarg) = arg_array(iarg,1) enddo do iarg=in_arg_length+1,arg_length buffer(iarg) = 0. enddo call full_steady_state_compact(buffer) do isite=1,nsites runid = arg_array(1,isite) ix=runid/1000 iy=MOD(runid,1000) index=ix+(iy-1)*nx c write(6,*) "Got ", runid, ix,iy,index call compact_mudsargs(runid,iinit,idebug, $ rc(1,index), $ porewater_conc(1,1,index), $ solid_gg(1,1,index), $ bwchem(1,index), $ rain, $ pw_react_tot(1,index), $ pw_diff_tot(1,index), $ sl_sum_react_pw(1,index), $ sl_sum_react(1,index), $ solid_inv(1,index), $ omega(1,index), $ burial(1,index), $ sl_residual(1,index), $ pw_residual(1,index), $ org_consume(1,1,index), $ z_level(1,index), $ storage, $ iter(index), $ buffer,expand_all) enddo return end subroutine compact_mudsargs( $ runid,iinit,idebug, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter, $ arg_array,idir) c idir=2 -> compact full args c idir=1 -> compact input args c idir=-1 -> expand input args c idir=-2 -> expand full args implicit none #include #include #include #include #include #include #include #include integer runid, iinit, idebug,iter double precision rc(nrcmax), $ porewater_conc(nzmax,nsolutemax), $ solid_gg(nzmax,nsolidmax), $ bwchem(nBottomWaters), $ rain(nsolidmax), $ pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_sum_react(nsolidmax), sl_sum_react_pw(nsolidmax), $ solid_inv(nsolidmax), omega(nzmax), burial(nsolidmax), $ sl_residual(nsolidmax), $ pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels), $ storage(Stor_N) double precision runidd, iinitd, idebugd, iterd real arg_array(arg_length) integer idir,idir_input,idir_out,izero integer ix,iy,isp if(ABS(idir) .EQ. 1) then ! just inputs idir_input = idir ! = 1 or -1, -> expand idir_out = 2*idir ! = 2 or -2, -> zero the ind. arrays elseif(ABS(idir) .EQ. 2) then ! whole array idir_input = idir / 2 ! = 1 or -1, -> copy idir_out = idir_input ! = 1 or -1, -> copy elseif(idir .EQ. 0) then ! = 0, zero expanded array idir_input = -2 ! zeros the expanded arrays idir_out = -2 endif if(idir .GE. compact_input) then ! then compactify runidd = runid iinitd = iinit idebugd = idebug if(idir .EQ. compact_all) then iterd = iter endif endif isp = 0 call array_copy(arg_array,isp,runidd,1,idir_input) ! 1 call array_copy(arg_array,isp,iinitd,1,idir_input) ! 1 call array_copy(arg_array,isp,idebugd,1,idir_input) ! 1 call array_copy(arg_array,isp,rc,nrcmax,idir_input) ! 38 call array_copy(arg_array,isp,bwchem,nbottomwaters,idir_input) ! 10 call array_copy(arg_array,isp,rain,nsolidmax,idir_input) ! 14 call array_copy(arg_array,isp,porewater_conc, $ nzmax*nsolutemax,idir_out) ! 14*nzmax = 252@18 or 448@32 call array_copy(arg_array,isp,solid_gg,nzmax*nsolidmax,idir_out) ! 252 or 448 call array_copy(arg_array,isp,pw_react_tot,nsolutemax,idir_out) ! 14 call array_copy(arg_array,isp,pw_diff_tot,nsolutemax,idir_out) ! 14 call array_copy(arg_array,isp,sl_sum_react_pw,nsolidmax,idir_out) ! 14 call array_copy(arg_array,isp,sl_sum_react,nsolidmax,idir_out) ! 14 call array_copy(arg_array,isp,solid_inv,nsolidmax,idir_out) ! 14 call array_copy(arg_array,isp,omega,nzmax,idir_out) ! 18 or 32 call array_copy(arg_array,isp,burial,nsolidmax,idir_out) ! 14 call array_copy(arg_array,isp,sl_residual,nsolidmax,idir_out) ! 14 call array_copy(arg_array,isp,pw_residual,nsolutemax,idir_out) ! 14 call array_copy(arg_array,isp,org_consume, $ norgs*nsolutemax,idir_out) ! 28 call array_copy(arg_array,isp,z_level,nzlevels,idir_out) ! 5 call array_copy(arg_array,isp,storage,Stor_N,idir_out) ! 342 or 608 call array_copy(arg_array,isp,iterd,1,idir_out) ! 1 c total: 1074 or 1742 if(idir .LE. expand_input) then runid = runidd iinit = iinitd idebug = idebugd if(idir .EQ. expand_all) then iter = iterd endif endif return end subroutine full_steady_state_dummy(arg_array) #include #include #include #include #include #include #include #include real arg_array(arg_length) integer runid, iinit, idebug,iter double precision rc(nrcmax), $ porewater_conc(nzmax,nsolutemax), $ solid_gg(nzmax,nsolidmax), $ bwchem(nBottomWaters), $ rain(nsolidmax), $ pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_sum_react(nsolidmax), sl_sum_react_pw(nsolidmax), $ solid_inv(nsolidmax), omega(nzmax), burial(nsolidmax), $ sl_residual(nsolidmax), pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels), $ storage(Stor_N) call compact_mudsargs(runid,iinit,idebug, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter, $ arg_array,expand_input) call compact_mudsargs(runid,iinit,idebug, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter, $ arg_array,compact_all) return end subroutine full_steady_state_compact(arg_array) #include #include #include #include #include #include #include #include real arg_array(arg_length) integer runid, iinit, idebug,iter,idebug_stifle double precision rc(nrcmax), $ porewater_conc(nzmax,nsolutemax), $ solid_gg(nzmax,nsolidmax), $ bwchem(nBottomWaters), $ rain(nsolidmax), $ pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_sum_react(nsolidmax), sl_sum_react_pw(nsolidmax), $ solid_inv(nsolidmax), omega(nzmax), burial(nsolidmax), $ sl_residual(nsolidmax), pw_residual(nsolutemax), $ org_consume(norgs,nsolutemax), $ z_level(nzlevels), $ storage(Stor_N) call compact_mudsargs(runid,iinit,idebug, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter, $ arg_array,expand_input) #ifdef VerboseStdOut write(6,*) "uncompacted ", bwchem, rain #endif #ifdef MPI idebug_stifle = 0 #else idebug_stifle = idebug #endif call full_steady_state(runid,iinit,idebug_stifle, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) call compact_mudsargs(runid,iinit,idebug, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_sum_react_pw, sl_sum_react, $ solid_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter, $ arg_array, compact_all) return end l, pw_residual, $ org_consume, z_level, $ storage, $ iter) call compact_mudsargs(runid,iinit,idebug, $ rc, $ porewater_conc,solid_gg, $ bwchem, $ rain, $ pw_reamuds.mpi.h000644 025374 000024 00000001170 10413036311 013237 0ustar00archeruser000000 000000 integer in_arg_length, arg_length, nprocs_max #if MUDS_NZ==18 parameter(in_arg_length=180, arg_length=1422, #else #if MUDS_NZ==32 parameter(in_arg_length=68, arg_length=1800, #endif #endif . nprocs_max=100) integer compact_all, compact_input, expand_all, expand_input, . zero_expanded, . run_full_steady_state, run_timestep parameter(compact_all=2,compact_input=1, . expand_all=-2,expand_input=-1,zero_expanded=0, . run_full_steady_state=1,run_timestep=2) integer nsitesmax parameter(nsitesmax=16380) #define Master 0 #else #if MUDS_NZ==32 parameter(in_arg_length=68, arg_length=1800, #endif #endif . nprocs_max=100) integer compact_all, compact_input, expand_all, expand_input, . zero_expanded, . run_full_steady_state, run_timestep parameter(compact_all=2,compact_input=1, . expand_all=-2,expand_input=-1,zero_expanded=0, . muds.multi.F000644 025374 000024 00000034421 10413036311 013547 0ustar00archeruser000000 000000 #define MPIList c#define SpotCheck c#define WriteTest program run_ss cc CaCO3 bathymetry runs c#define MudsCO3Bath #define Berelson 1.5 c#define ReadO2 c#define ReadScaleCaCO3Prod cc#define POP ! otherwise Hamocc c#define ReadRCFile c#define ReadClayRain c#define MudsRedox c oxygen, organic rain c#define MudsCaCO3 c orgrain, dco3 c#define MudsCaCO3b c#define MudsCaCO3c c dco3, oxygen #define MudsBath implicit none #include #include #include #include #include #include #include integer nx,ny c parameter(nx=100,ny=100) c parameter(nx=50,ny=50) #ifdef MudsRedox ! oxygen, organic rain c parameter(nx=30,ny=40) c parameter(nx=29,ny=21) c parameter(nx=15,ny=51) c parameter(nx=61,ny=51) c parameter(nx=31,ny=51) c parameter(nx=31,ny=51) c parameter(nx=61,ny=101) c parameter(nx=121,ny=101) c parameter(nx=31,ny=26) parameter(nx=16,ny=16) c parameter(nx=4,ny=5) c parameter(nx=2,ny=2) c parameter(nx=30,ny=26) c parameter(nx=15,ny=11) c parameter(nx=8,ny=6) c parameter(nx=2,ny=13) c parameter(nx=2,ny=2) #endif #ifdef MudsCaCO3 parameter(nx=25,ny=40) c parameter(nx=15,ny=13) c parameter(nx=2,ny=2) #endif #ifdef MudsCaCO3b parameter(nx=20,ny=21) c parameter(nx=2,ny=2) #endif #ifdef MudsCaCO3c parameter(nx=160,ny=20) #endif #ifdef MudsBath c parameter(nx=40,ny=32) c parameter(nx=1,ny=32) parameter(nx=41,ny=32) c parameter(nx=4,ny=4) #endif #ifdef MudsCO3Bath #ifdef POP parameter(nx=160,ny=25) #else !!!! Hamocc parameter(nx=160,ny=11) #endif #endif c parameter(nx=20,ny=20) c parameter(nx=8,ny=8) c parameter(nx=5,ny=5) c parameter(nx=4,ny=4) c parameter(nx=2,ny=2) double precision rainorg,raincal(nCaCO3s), $ rainopal,rainclay double precision rc(nrcmax), db, z_mix, irrig_rate(nx,ny) double precision porewater_conc(nzmax,nsolutemax,nx,ny) double precision solid_gg(nzmax,nsolidmax,nx,ny) double precision pw_react(nsolutemax,nx,ny), $ pw_diff(nsolutemax,nx,ny), $ sl_react(nsolidmax,nx,ny), $ sl_react_pw(nsolidmax,nx,ny), $ sl_inv(nsolidmax,nx,ny), $ omega(nzmax,nx,ny), $ burial(nsolidmax,nx,ny), $ sl_residual(nsolidmax,nx,ny), $ pw_residual(nsolutemax,nx,ny), $ org_consume(norgs,nsolutemax,nx,ny), $ z_level(nzlevels,nx,ny), $ storage(Stor_N,nx,ny) double precision bwchem(nBottomWaters), $ rain(nsolidmax) #ifdef ReadO2 double precision o2bw_in #endif #ifdef ReadRainRatio double precision rainratio #endif #ifdef ReadScaleCaCO3Prod double precision raincal_scale, rainarag_scale #endif real x(nx), y(ny), z(nzmax) double precision dco3 integer idebug, iinit,iunit,iendpos, $ iread, iter,irc, runid,ix,iy,iz,iz2, $ isol,iorgc #ifdef SpotCheck integer ix_in,iy_in #endif character*80 outfile_basename #include c#ifdef MudsBath real watz(32) data watz /10, 20, 30, 50, 75, 100, 125, $ 150, 200, 250, 300, 400, 500, 600, 700, $ 800, 900, 1000, 1100, 1200, 1300, 1400, $ 1500, 1750, 2000, 2500, 3000, 3500, 4000, $ 4500, 5000, 5500/ c#endif #ifdef MudsBath double precision batho2(nx,ny), bathz(ny) integer idummy #endif #ifdef Middelberg real middelburg_fc, middelburg_fb #endif #ifdef Berelson real berelson_resp, burial_fract #endif call getarg(1,outfile_basename) if(outfile_basename .EQ. '') $ outfile_basename = 'junk' do iendpos=80,1,-1 if(outfile_basename(iendpos:iendpos) .NE. ' ') then goto 99 endif enddo 99 continue #ifdef MPIList open(9,file=outfile_basename(1:iendpos) // '.mpilist') open(10,file=outfile_basename(1:iendpos) // '.iospecs') #endif #ifdef MudsCO3Bath #ifndef ReadO2 open(7,file='o2avg.co3.out') read(7,*) do iy=1,ny read(7,*) bathz(iy),(batho2(ix,iy),ix=1,nx) enddo close(7) #else open(7,file='gcm.zlevels') do iy=1,ny read(7,*) bathz(iy) enddo #endif #endif do ix=1,nx do iy=1,ny do iz=1,nzmax do isol = 1,nsolutemax porewater_conc(iz,isol,ix,iy) = 0. do iorgc=1,norgs org_consume(iorgc,isol,ix,iy) = 0. enddo enddo do isol = 1,nsolidmax solid_gg(iz,isol,ix,iy) = 0. burial(isol,ix,iy) = 0. enddo enddo irrig_rate(ix,iy) = 0. do iz=1,nzlevels z_level(iz,ix,iy) = 0. enddo enddo enddo do ix=1,nx do iy=1,ny do iz=1,Stor_N storage(iz,ix,iy) = 0. enddo enddo enddo #ifdef SpotCheck write(6,*) "waiting for ix, iy" read(5,*) ix_in, iy_in #endif #ifdef ReadO2 write(6,*) "waiting for o2bw" read(5,*) o2bw_in write(6,*) "got ", o2bw_in #endif #ifdef ReadRainRatio write(6,*) "waiting for rain ratio" read(5,*) rainratio write(6,*) "got ", rainratio #endif #ifdef ReadClayRain write(6,*) "waiting for clay rain" read(5,*) rainclay write(6,*) "got ", rainclay #endif #ifdef ReadScaleCaCO3Prod write(6,*) "waiting for raincal_scale, rainarag_scale" read(5,*) raincal_scale, rainarag_scale write(6,*) "got ", raincal_scale, rainarag_scale #endif c$doacross c$& local (bwchem,rainorg,raincal,rainarag, c$& rainopal,rainclay,rc,db,z_mix,dco3, c$& ix,iy,idebug,iinit,middelburg_fb,middelburg_fc, c$& runid,iter,rain) c$& mp_schedtype=dynamic #ifdef SpotCheck do ix=ix_in,ix_in do iy=iy_in,iy_in #else do ix=1,nx do iy=1,ny #endif bwchem(BWDepth) = 3000 #ifdef MudsRedox bwchem(BWO2) = ( ix-1 ) * (125. / nx) ! was 300 #endif #ifdef MudsCaCO3 bwchem(BWO2) = o2bw_in #endif #ifdef MudsCaCO3b o2bw = o2bw_in #endif #ifdef MudsBath c bwchem(BWO2) = (ix) * 10. - 5. c bwchem(BWO2) = 0 c bwchem(BWO2) = 1.e-1*(ix-1) if(ix .EQ. 1) then bwchem(BWO2) = 0. else bwchem(BWO2) = (ix-1) * 10 - 5. endif #endif #ifdef MudsCO3Bath #ifdef ReadO2 batho2(ix,iy) = o2bw_in bwchem(BWO2) = o2bw_in #else bwchem(BWO2) = batho2(ix,iy) * 1000. #endif #endif #ifdef MudsCaCO3c bwchem(BWO2) = (iy-1) * 10. #endif bwchem(BWNO3) = -0.0004*bwchem(BWO2)**2 $ + 0.03*bwchem(BWO2) + 41. bwchem(BWNO3) = bwchem(BWNO3) $ * bwchem(BWO2) / (bwchem(BWO2) + 4.) bwchem(BWNO3) = MAX(bwchem(BWNO3),0.) bwchem(BWTemp) = 4. bwchem(BWSal) = 35. #ifdef MudsRedox bwchem(BWAlk) = 2300. bwchem(BWTCO2) = 2000. + (300.-bwchem(BWO2))*1.2 #endif #ifdef MudsCaCO3 bwchem(BWTCO2) = 2158. dco3 = ( -50. + (iy-1)*2.5 ) Call findalk(dco3,bwchem(BWTCO2),bwchem(BWDepth), $ bwchem(BWTemp),bwchem(BWSal),bwchem(BWAlk)) #endif #ifdef MudsCaCO3b tco2bw = (2325 - 0.06624*o2bw)/1.027786 dco3 = ( -40. + (iy-1)*5. ) Call findalk(dco3,tco2bw,depth,temp,sal,alkbw) #endif #ifdef MudsBath bwchem(BWAlk) = 2300. bwchem(BWTCO2) = 2000. + (300.-bwchem(BWO2))*1.2 #endif #ifdef MudsCO3Bath bwchem(BWAlk) = 2300. dco3 = 2.5 * (ix-1) - 98.75 call findtco2(dco3,bwchem(BWAlk),bathz(iy), $ bwchem(BWTemp),bwchem(BWSal),bwchem(BWTCO2)) #endif #ifdef MudsCaCO3c bwchem(BWAlk) = 2300. dco3 = 2.5 * (ix-1) - 98.75 call findtco2(dco3,bwchem(BWAlk),100.D0, $ bwchem(BWTemp),bwchem(BWSal),bwchem(BWTCO2)) #endif bwchem(BWSi) = 150. bwchem(BWH2S) = 0. bwchem(BWNH4) = 0. #ifdef MudsRedox c rainorg = iy * (50. / ny) c rainorg = 10**((iy-1)*(2.5/(ny-1)) + 0.5) ! log scale to 1000 cc rainorg = 10**((iy+40)*.05 + 0.5) rainorg = ( iy ) * ( 36.5 / ny ) raincal(1) = rainorg * 1.4 c raincal = 0. c raincal2 = 0. c raincal3 = 0. rainopal = rainorg c rainclay = 0.8 * rainorg**(2.4) c rainclay = 350. * rainorg c rainclay = 88. * rainorg #ifndef ReadClayRain rainclay = 48.556 * rainorg**(1.1765) #else raincal(1) = 0 rainarag = 0 rainopal = 0 #endif #endif ! MudsRedox #ifdef MudsCaCO3 rainorg = ix*2 raincal(1) = 18. rainclay = 180. rainopal = 0. #endif #ifdef MudsCaCO3b rainorg = ix * 5. raincal(1) = rainorg / rainratio c rainclay = 0.8 * rainorg**(2.4) rainclay = 350. * rainorg rainopal = rainorg #endif #ifdef MudsBath bwchem(BWDepth) = watz(iy) #ifdef Middelberg middelburg_fb = 10**(-0.84672973-0.00061506*watz(iy))*4.4e3 middelburg_fc = 10**(-0.50860503-0.00038900*watz(iy))*1.8e3 rainorg = middelburg_fb + middelburg_fc raincal(1) = rainorg #endif #ifdef Berelson berelson_resp = 241. * watz(iy)**(-0.6865) ! mmol/m2d $ * 36.5 ! umol/cm2y $ - 15. ! offset to fix deep sea berelson_resp = MIN( berelson_resp, 1000.) burial_fract = exp(-watz(iy)/1000) * .45 rainorg = berelson_resp / (1.-burial_fract) rainorg = MIN(rainorg,1000.) #endif c rainorg = 0.5 * rainorg raincal(1) = MIN(35. * exp(-watz(iy) / 1000.) + 15, $ rainorg*1.4) rainclay = 48.556 * rainorg**(1.1765) rainorg = rainorg * Berelson rainopal = rainorg #endif #ifdef MudsCO3Bath bwchem(BWDepth) = bathz(iy) #ifdef Middelberg middelburg_fb = 10**(-0.84672973-0.00061506*bathz(iy))*4.4e3 middelburg_fc = 10**(-0.50860503-0.00038900*bathz(iy))*1.8e3 rainorg = middelburg_fb + middelburg_fc raincal(1) = rainorg * 1.4 #endif #ifdef Berelson berelson_resp = 241. * bathz(iy)**(-0.6865) ! mmol/m2d $ * 36.5 ! umol/cm2y $ - 15. ! offset to fix deep sea berelson_resp = MIN( berelson_resp, 1000.) burial_fract = exp(-bathz(iy)/1000) * .45 rainorg = berelson_resp / (1.-burial_fract) rainorg = MIN(rainorg,1000.) #endif raincal(1) = MIN(35. * exp(-bathz(iy) / 1000.) + 15, $ rainorg*1.4) rainarag = 55. * exp(-bathz(iy)/1000.) #ifdef ReadScaleCaCO3Prod raincal(1) = raincal(1) * raincal_scale rainarag = rainarag * rainarag_scale #endif rainclay = 9.1 * rainorg**(1.41) ! modified from tromp, lower at low end rainopal = rainorg #endif #ifdef MudsCaCO3c rainorg = 1000. raincal(1) = 50. rainarag = 50. rainopal = 100. rainclay = 9.1 * rainorg**(1.41) #endif #ifdef WriteTest open(7,file='multi.testin') write(7,'(i4,20g15.5)') 99, bwchem, $ rainorg,raincal(1), $ rainopal,rainclay close(7) stop #endif call generate_rates(rainorg,raincal, $ rainopal,rainclay, $ bwchem,tuners, #ifdef ReadCalciteKineticsFile . 'muds_v2.rates', #endif $ rain,rc) #ifdef SpotCheck idebug = 5 #else idebug = 2 #endif iinit = 1 #ifdef MPIList iunit = 9 #else iunit = 6 #endif #ifdef MudsRedox x(ix) = bwchem(BWO2) y(iy) = rainorg #endif #ifdef MudsCaCO3 x(ix) = rainorg y(iy) = dco3 #endif #ifdef MudsCaCO3b x(ix) = rainorg y(iy) = dco3 #endif #ifdef MudsBath x(ix) = bwchem(BWO2) y(iy) = bwchem(BWDepth) #endif #ifdef MudsCO3Bath x(ix) = dco3 y(iy) = bwchem(BWDepth) #endif #ifdef MudsCaCO3c x(ix) = dco3 y(iy) = bwchem(BWO2) #endif irrig_rate(ix,iy) = rc(JIrrig) runid = ix*1000+iy #ifdef MudsCO3Bath if(batho2(ix,iy) .GE. -90.) then #endif #ifdef MPIList call list_mudsargs( #else call full_steady_state( #endif $ runid,iinit,iunit,idebug, $ rc, $ porewater_conc(1,1,ix,iy), $ solid_gg(1,1,ix,iy), $ bwchem, $ rain, $ pw_react(1,ix,iy), pw_diff(1,ix,iy), $ sl_react(1,ix,iy), sl_inv(1,ix,iy), $ omega(1,ix,iy), burial(1,ix,iy), $ sl_residual(1,ix,iy), pw_residual(1,ix,iy), $ org_consume(1,1,ix,iy), z_level(1,ix,iy), $ storage(1,ix,iy), $ iter) #ifdef MudsCO3Bath endif #endif call flush(6) enddo enddo #ifndef SpotCheck #ifdef MPIList call write_iospecs( #else call writemudcdf( #endif $ outfile_basename, $ porewater_conc, solid_gg, $ burial, omega, sl_react_pw, irrig_rate, $ z_level, org_consume, #ifdef MudsRedox $ 'o2bw','orgrain', #endif #ifdef MudsCaCO3 $ 'rainorg','dco3', #endif #ifdef MudsCaCO3b $ 'rainorg','dco3', #endif #ifdef MudsBath $ 'bwo2','depth', #endif #ifdef MudsCO3Bath $ 'bwdco3','depth', #endif #ifdef MudsCaCO3c $ 'bwdco3','o2', #endif $ x, y, z, $ nx, ny, nzmax-1) #endif 100 continue end porewater_conc, solid_gg, $ burial, omega, sl_react_pw, irrig_rate, $ z_level, org_consume, #ifdef MudsRedox $ 'o2bw','orgrain', #endif #ifdef MudsCaCO3 $ 'rainorg','dco3', #endif #ifdef MudsCaCO3b nh4ss.F000644 025374 000024 00000027046 10413036311 012512 0ustar00archeruser000000 000000 c#define StdOut #include subroutine nh4ss(runid,idebug, $ nh4, $ z_oxic, $ diff_nh4,irrig_array, $ omega, db_array, $ nh4_react, $ no3_react, $ o2_react, $ co2_react, $ hco3_react, $ rc_ox, $ z, delz, form, pore, kmax, $ diff_tot, react_tot) implicit none #include #include integer kmax, kz, iter, j, runid, idebug double precision nh4(nzmax), $ nh4_react(nzmax), no3_react(nzmax), o2_react(nzmax), $ co2_react(nzmax), hco3_react(nzmax), $ rc_ox, z_oxic, diff_nh4(nzmax,2),irrig_array(nzmax), $ omega(nzmax),db_array(nzmax,nDbs), $ z(nzmax), delz(nzmax), form(nzmax), pore(nzmax), $ diff_tot, react_tot c internal double precision nh4_internal_react(nzmax), dummy(nzmax) double precision xads(nzmax), dxdn(nzmax) double precision res(nzmax), dfplus(nzmax), dfzero(nzmax), $ dfmins(nzmax) double precision a(nzmax), b(nzmax), c(nzmax), r(nzmax), $ u(nzmax), weight do iter=1,10 do kz=2,kmax nh4_internal_react(kz) = nh4_react(kz) dummy(kz) = 0. enddo call nh4_react_rates(nh4, $ z_oxic, z, delz, rc_ox, kmax, $ nh4_internal_react, $ dummy, $ dummy, $ dummy, dummy) do kz=2,kmax res(kz) = 0. dfplus(kz) = 0. dfzero(kz) = 0. dfmins(kz) = 0. enddo c reaction do kz=2,kmax res(kz) = res(kz) $ + nh4_internal_react(kz) / pore(kz) enddo c diffusion do kz = 2, kmax ! diffusion upward res(kz) = res(kz) * - diff_nh4(kz,2) * ( nh4( kz ) - nh4( kz-1 ) ) dfzero(kz) = dfzero(kz) $ - diff_nh4(kz,2) dfmins(kz) = dfmins(kz) $ + diff_nh4(kz,2) enddo do kz=2,kmax-1 ! exclude cell N for downward diffusion res(kz) = res(kz) $ + diff_nh4(kz,1) * ( nh4( kz+1 ) - nh4(kz) ) dfzero(kz) = dfzero(kz) $ - diff_nh4(kz,1) dfplus(kz) = dfplus(kz) $ + diff_nh4(kz,1) enddo #ifdef NH4Irrigation c irrigation do kz=2, kmax res(kz) = res(kz) $ - irrig_array(kz) $ * nh4(kz) dfzero(kz) = dfzero(kz) $ - irrig_array(kz) enddo #endif #ifdef NH4Adsorption do kz = 2, kmax xads(kz) = 1.4 $ * pore(kz) / 2.5 / (1-pore(kz)) $ * nh4(kz) dxdn(kz) = 1.4 $ * pore(kz) / 2.5 / (1-pore(kz)) enddo kz=1 xads(kz) = 0. dxdn(kz) = 0. do kz = 2, kmax ! diffusion upward res(kz) = res(kz) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ / pore(kz) $ * ( xads(kz) - xads(kz-1) ) dfzero(kz) = dfzero(kz) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ / pore(kz) $ * dxdn(kz) dfmins(kz) = dfmins(kz) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ / pore(kz) $ * dxdn(kz-1) enddo do kz=2,kmax-1 ! exclude cell N for downward diffusion res(kz) = res(kz) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * ( xads(kz+1) - xads(kz) ) dfzero(kz) = dfzero(kz) $ - db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * dxdn(kz) dfplus(kz) = dfplus(kz) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ / pore(kz) $ * dxdn(kz+1) enddo c burial of adsorpted nh4 do kz=3, kmax ! incoming to box res(kz) = res(kz) $ + omega(kz-1) $ * xads(kz-1) $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 dfmins(kz) = dfmins(kz) $ + omega(kz-1) $ * dxdn(kz-1) $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 enddo do kz=2,kmax ! going out of box res(kz) = res(kz) $ - omega(kz) $ * xads(kz) $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 dfzero(kz) = dfzero(kz) $ - omega(kz) $ * dxdn(kz) $ / delz(kz) $ / pore(kz) / (1-pore(kz)) $ / 2.5 / 3.15e7 enddo #endif do j = 1, kmax-2 a(j+1) = dfmins(j+2) b(j) = dfzero(j+1) c(j) = dfplus(j+1) enddo b(kmax-1) = dfzero(kmax) + dfplus(kmax) do j = 1, kmax-1 r(j) = -res(j+1) enddo CALL tridiag(runid,idebug,a,b,c,r,u, * kmax-1) react_tot = 0. weight = 0.25 do kz = 2, kmax if( nh4(kz) + u(kz-1) .GT. 0) then nh4(kz) = nh4(kz) + u(kz-1) * weight else nh4(kz) = 0.1 * nh4(kz) endif react_tot = react_tot + nh4_react(kz) $ * delz(kz) / 1000 * 3.15E7 c units of mole / cm2 yr enddo call diffusive_flux(nh4, diff_nh4(1,1), $ form,pore,delz,kmax,diff_tot) #ifdef StdOut write(6,10) iter, react_tot,diff_tot, nh4(kmax) 10 format(i4,3g15.5) #endif enddo ! iter call nh4_react_rates(nh4, $ z_oxic, z, delz, rc_ox, kmax, $ nh4_react, $ no3_react, $ o2_react, $ co2_react, hco3_react) do kz=2,kmax nh4_react(kz) = 0. enddo return end subroutine nh4_react_rates(nh4, $ z_oxic, z, delz, rc_ox, kmax, $ nh4_react, $ no3_react, $ o2_react, $ co2_react, hco3_react) implicit none integer kmax double precision nh4(kmax), z(kmax), delz(kmax), $ z_oxic, rc_ox double precision nh4_react(kmax), no3_react(kmax), $ o2_react(kmax), co2_react(kmax),hco3_react(kmax) integer kz do kz=2,kmax if(z(kz) .LT. z_oxic) then nh4_react(kz) = nh4_react(kz) $ - rc_ox * nh4(kz) no3_react(kz) = no3_react(kz) $ + rc_ox * nh4(kz) o2_react(kz) = o2_react(kz) $ - 2 * rc_ox * nh4(kz) co2_react(kz) = co2_react(kz) $ + 2 * rc_ox * nh4(kz) hco3_react(kz) = hco3_react(kz) $ - 2 * rc_ox * nh4(kz) elseif(z(kz-1) .LT. z_oxic) then nh4_react(kz) = nh4_react(kz) $ - rc_ox * nh4(kz) $ * (z_oxic - z(kz-1)) / delz(kz) no3_react(kz) = no3_react(kz) $ + rc_ox * nh4(kz) $ * (z_oxic - z(kz-1)) / delz(kz) o2_react(kz) = o2_react(kz) $ - 2 * rc_ox * nh4(kz) $ * (z_oxic - z(kz-1)) / delz(kz) co2_react(kz) = co2_react(kz) $ + 2 * rc_ox * nh4(kz) $ * (z_oxic - z(kz-1)) / delz(kz) hco3_react(kz) = hco3_react(kz) $ - 2 * rc_ox * nh4(kz) $ * (z_oxic - z(kz-1)) / delz(kz) endif enddo return end #ifdef OldJunkCode res(kz) = res(kz) $ + diff_nh4(kz,1) * ( nh4( kz+1 ) - nh4(kz) ) * - diff_nh4(kz,2) * ( nh4( kz ) - nh4( kz-1 ) ) $ + irrig_array(kz) $ * ( nh4(1) - nh4(kz) ) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * ( xads(kz+1) - xads(kz) ) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * ( xads(kz) - xads(kz-1) ) $ * omega(kz-1) ! g/cm2 yr $ + xads(kz-1) ! mol/l $ / delz(kz) $ * pore(kz) / (1-pore(kz)) $ * 2.5 / 3.15e7 * + nh4_internal_react(kz) / pore(kz) dfplus(kz) = diff_nh4(kz,1) $ + db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * dxdn(kz+1) dfzero(kz) = $ -diff_nh4(kz,1) $ - diff_nh4(kz,2) $ - irrig_array(kz) $ - db_array(kz,DbPlsS) 2 / ( 1-PORE(kz)+1-PORE(kz+1) ) $ * (2*(1-PORE(kz))) $ / 3.15e7 $ * dxdn(kz) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * dxdn(kz) dfmins(kz) = diff_nh4(kz,2) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * dxdn(kz-1) enddo kz = kmax res(kz) = * - diff_nh4(kz,2) * ( nh4( kz ) - nh4( kz-1 ) ) $ + irrig_array(kz) $ * ( nh4(1) - nh4(kz) ) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * ( xads(kz) - xads(kz-1) ) * + nh4_internal_react(kz) / pore(kz) dfplus(kz) = diff_nh4(kz,1) dfzero(kz) = -diff_nh4(kz,1) - diff_nh4(kz,2) $ - irrig_array(kz) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * dxdn(kz) dfmins(kz) = diff_nh4(kz,2) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * dxdn(kz-1) #endif _array(kz) $ - db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec $ * dxdn(kz) dfmins(kz) = diff_nh4(kz,2) $ + db_array(kz,DbMinS) 2 / ( 1-PORE(kz)+1-PORE(kz-1) ) $ * (2*(1-PORE(kz))) ! now back to "dbtop", cm2/yr $ / 3.15e7 ! cm2/sec no3ss.F000644 025374 000024 00000031335 10413036311 012514 0ustar00archeruser000000 000000 #include c#define StdOut SUBROUTINE no3ss(runid,idebug, $ no3,orgml, . rc,z_level, $ diff_array, irrig_array, $ z, delz, form, pore, kmax, $ pw_react, $ org_react, $ org_dreac, $ irrig_oxidation, $ react_tot, diff_tot, $ org_consume) implicit none #include #include #include #include integer kmax integer kz, iter, ioc, runid,idebug c external variables DOUBLE PRECISION no3(nzmax) double precision pw_react(nzmax,nsolutemax) double precision orgml(nzmax,norgs) double precision rc(nrcmax),z_level(nzlevels), $ diff_array(nzmax,2), irrig_array(nzmax) DOUBLE PRECISION $ org_react(nzmax,norgs), $ org_dreac(nzmax,norgs), $ irrig_oxidation(nzmax) double precision form(nzmax), pore(nzmax), delz(nzmax), $ z(nzmax) double precision react_tot, diff_tot, $ org_consume(norgs) c internal variables c DOUBLE PRECISION a(nzmax,nzmax),b(nzmax,1),r(nzmax) double precision no3_internal_react(nzmax), $ dummy(nzmax,norgs), irrig_internal_array(nzmax), $ no3min double precision zup, zdn, z_no3_internal,weight, z_no3_last double precision tot_react data z_no3_last /30./ tot_react = 0. do kz=2,kmax tot_react = tot_react + pw_react(kz,INO3) enddo if(tot_react .EQ. 0. .AND. no3(1) .EQ. 0) then z_level(KNO3) = 0. react_tot = 0. diff_tot = 0. return endif If( z_level(KNO3) .LT. z_level(KOxic) ) then z_no3_internal = z_level(KOxic) else z_no3_internal = z_level(KNO3) endif do kz=2, kmax no3_internal_react(kz) = pw_react(kz,INO3) #ifdef StdOut write(6,*) "pw_react", pw_react(kz,INO3) #endif do ioc=1,norgs dummy(kz,ioc) = 0. enddo enddo call no3_react_rates(no3,orgml, . rc, $ z_level(KOXIC),z_no3_internal, $ z,delz,kmax, $ no3_internal_react, $ dummy,dummy, $ dummy, $ dummy, $ org_consume) call cutoff_irrig(irrig_array, $ z,delz,z_no3_internal,kmax, $ irrig_internal_array) call pw_1_ss(runid,idebug, $ no3,no3_internal_react, $ z,delz,form,pore, $ diff_array, irrig_internal_array, $ kmax, $ react_tot,diff_tot) no3min = no3(2) do kz=3,kmax if(no3(kz) .LT. no3min) no3min = no3(kz) enddo if( $ ( ABS(z_no3_internal) .LT. z(kmax) $ .AND. $ ABS(no3min) .LT. 1.E-8 $ ) $ .OR. $ ( no3min .GT. 1.E-8 .AND. z_no3_internal .EQ. z(kmax) ) $ ) goto 100 zup = z_level(KOxic) zdn = z(kmax) do iter = 1, 100 if( no3(kmax) .LT. 0. ) then c z_no3_internal too deep zdn = z_no3_internal else c z_no3_internal too shallow zup = z_no3_internal endif z_no3_internal = ( zup + zdn ) / 2 #ifdef StdOut write(6,*) "z_no3 ", z_no3_internal, no3(kmax), z_level(KNO3) #endif do kz=2, kmax ! imports source from outside no3_internal_react(kz) = pw_react(kz,INO3) enddo call no3_react_rates(no3,orgml, . rc, $ z_level(KOxic),z_no3_internal, $ z,delz,kmax, $ no3_internal_react, $ dummy,dummy, $ dummy, $ dummy, $ org_consume) call cutoff_irrig(irrig_array, $ z,delz,z_no3_internal,kmax, $ irrig_internal_array) call pw_1_ss(runid,idebug, $ no3,no3_internal_react, $ z,delz,form,pore, $ diff_array, irrig_internal_array, $ kmax, $ react_tot,diff_tot) no3min = no3(2) do kz=3,kmax if(no3(kz) .LT. no3min) no3min = no3(kz) enddo if( $ ( ABS(z_no3_internal) .LT. z(kmax) $ .AND. $ ABS( no3min) .LT. 1.E-8 $ ) $ .OR. $ ( no3min .GT. 1.E-8 $ .AND. z_no3_internal .EQ. z(kmax) ) $ ) goto 100 enddo 100 continue call no3_react_rates(no3,orgml, . rc, $ z_level(KOxic),z_no3_internal, $ z,delz,kmax, $ pw_react(1,INO3), $ pw_react(1,ICO2), $ pw_react(1,IHCO3), $ org_react, $ org_dreac, $ org_consume) c weight = 0.1 weight = 1. z_level(KNO3) = weight * z_no3_internal $ + (1-weight) * z_level(KNO3) do kz = 2, kmax if( no3(kz) .LT. 0 ) no3(kz) = 0. pw_react(kz,INO3) = 0. if(z(kz) .LT. z_level(KNO3)) then ! fully oxic irrig_oxidation(kz) = irrig_oxidation(kz) + 0. elseif(z(kz-1) .GT. z_level(KNO3)) then ! fully anoxic no3(kz) = 0. c residual o2 source, to be gobbled up by fe, etc. #ifdef IrrigOxidation irrig_oxidation(kz) = irrig_oxidation(kz) $ + irrig_array(kz) * no3(1) / delz(kz) * 1000. c l pw / cm2 tot s 1/cm tot c mol/l pw c mol/l tot sec = mol / l tot sec OK . * 5. #endif else ! box contains z_no3 #ifdef IrrigOxidation irrig_oxidation(kz) = irrig_oxidation(kz) $ + irrig_array(kz) * no3(1) / delz(kz) * 1000. $ * (z_level(KNO3)-z(kz-1)) / delz(kz) $ * 5. #endif endif enddo return end subroutine no3_react_rates(no3,orgml, $ rc,z_oxic,z_no3,z,delz,kmax, $ no3_react, $ co2_react, hco3_react, $ org_react, $ org_dreac, $ org_consume) implicit none #include #include #include #include integer kmax, kz,ioc c external variables double precision $ rc(nrcmax), z_oxic double precision no3(kmax), orgml(nzmax,norgs) double precision z(kmax), delz(kmax) double precision no3_react(kmax), $ co2_react(kmax), hco3_react(kmax), $ org_react(nzmax,norgs), $ org_dreac(nzmax,norgs) double precision z_no3 double precision org_consume(norgs) double precision rc_scale c ------------ z() c >>> source zone 1 c ------------ z() c <--z_oxic zone 4, 6 c ------------ z() c <<< sink zone 2, 6 c ------------ z() c <--z_no3 zone c ------------ z() c zero concentration zone 3 c ------------ z() do ioc=1,norgs org_consume(ioc) = 0. enddo do kz = 2, kmax rc_scale = exp(-z(kz)/rc(JRespScale)) c rc_scale = 1. c zone 1. source, fully oxic box if( z(kz) .LE. z_oxic ) then no3_react(kz) = no3_react(kz) c the source term specified in o2 subroutine c zone 2. anoxic sink for no3 elseif( ( z(kz-1) .GE. z_oxic ) $ .AND. $ ( z(kz) .LE. z_no3 ) $ ) then do ioc=1,norgs no3_react(kz) = no3_react(kz) $ - STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) co2_react(kz) = co2_react(kz) $ + (STOIC_REDFIELDC - STOIC_NO3ORGN) / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) hco3_react(kz) = hco3_react(kz) $ + STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) org_react(kz,ioc) = org_react(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale org_consume(ioc) = org_consume(ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) $ * delz(kz) / 1000 * 3.15E7 enddo c zone 3. nitrate depleted elseif( z(kz-1) .GE. z_no3 ) then no3_react(kz) = no3_react(kz) c zone 6. box contains both z_oxic and z_no3 boundaries elseif( ( z(kz-1) .LE. z_oxic ) $ .AND. $ ( z(kz) .GE. z_oxic) $ .AND. $ ( z(kz-1) .LE. z_no3 ) $ .AND. $ ( z(kz) .GE. z_no3 ) $ ) then do ioc=1,norgs no3_react(kz) = no3_react(kz) $ - STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z_oxic )/delz(kz) co2_react(kz) = co2_react(kz) $ + (STOIC_REDFIELDC - STOIC_NO3ORGN) $ / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z_oxic )/delz(kz) hco3_react(kz) = hco3_react(kz) $ + STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z_oxic )/delz(kz) org_react(kz,ioc) = org_react(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z_oxic )/delz(kz) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * * ( z_no3 - z_oxic )/delz(kz) org_consume(ioc) = org_consume(ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z_oxic )/delz(kz) $ * delz(kz) / 1000 * 3.15E7 enddo c zone 4. box contains only oxygen boundary elseif( ( z(kz) .GE. z_oxic ) $ .AND. $ ( z(kz-1) .LE. z_oxic ) $ ) then do ioc=1,norgs no3_react(kz) = no3_react(kz) $ - STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * (z(kz)-z_oxic)/delz(kz) co2_react(kz) = co2_react(kz) $ + (STOIC_REDFIELDC - STOIC_NO3ORGN) $ / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * (z(kz)-z_oxic)/delz(kz) hco3_react(kz) = hco3_react(kz) $ + STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * (z(kz)-z_oxic)/delz(kz) org_react(kz,ioc) = org_react(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * (z(kz)-z_oxic)/delz(kz) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * * (z(kz)-z_oxic)/delz(kz) org_consume(ioc) = org_consume(ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * (z(kz)-z_oxic)/delz(kz) $ * delz(kz) / 1000 * 3.15E7 enddo c zone 5. box contains only z_no3 no3 depletion boundary elseif( ( z(kz) .GE. z_no3 ) $ .AND. $ ( z(kz-1) .LE. z_no3 ) $ ) then do ioc=1,norgs no3_react(kz) = no3_react(kz) $ - STOIC_NO3ORGN / STOIC_REDFIELDC $ * rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z(kz-1) )/delz(kz) org_react(kz,ioc) = org_react(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z(kz-1) )/delz(kz) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * * ( z_no3 - z(kz-1) )/delz(kz) org_consume(ioc) = org_consume(ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * * ( z_no3 - z(kz-1) )/delz(kz) $ * delz(kz) / 1000 * 3.15E7 enddo else write(6,*) "nitrate source no fit ", kz endif enddo return end 1) )/delz(kz) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * * ( z_no3 - z(kz-1) )/delz(kz) org_consume(ioc) = org_consume(ioc) $ - rc(JNO3Org+ioc-1) * rc_scale * orgml(kz,ioc) * o2ss.F000644 025374 000024 00000023714 10413036311 012337 0ustar00archeruser000000 000000 #include c#define StdOut SUBROUTINE o2ss(runid,idebug, $ o2, $ orgml, . rc,scale_depth, $ diff_array, irrig_array, $ z, delz, form, pore, kmax, $ o2_react, $ co2_react, $ no3_react, $ org_react, $ org_dreac, $ irrig_oxidation, $ z_oxic, $ react_tot,diff_tot, $ org_consume) implicit none #include #include integer kmax, runid,idebug c external variables DOUBLE PRECISION o2(kmax),orgml(nzmax,norgs) DOUBLE PRECISION o2_react(kmax),co2_react(kmax) DOUBLE PRECISION no3_react(kmax) double precision org_react(nzmax,norgs) double precision org_dreac(nzmax,norgs) double precision irrig_oxidation(nzmax) double precision org_consume(norgs) double precision rc(norgs), scale_depth double precision $ diff_array(nzmax,2), irrig_array(nzmax) double precision form(kmax), pore(kmax), delz(kmax), $ z(kmax),z_oxic double precision react_tot, diff_tot c internal variables DOUBLE PRECISION a(nzmax,nzmax),b(nzmax,1),r(nzmax) double precision o2_internal_react(nzmax),dummy(nzmax,norgs), $ irrig_internal_array(nzmax), o2min integer kz, iter,ioc double precision zup, zdn, z_oxic_internal, weight if(o2(1) .LT. 1.e-20) then z_oxic = 0. react_tot = 0. diff_tot = 0. return endif z_oxic_internal = z_oxic do kz=2, kmax o2_internal_react(kz) = 0. do ioc=1,norgs dummy(kz,ioc) = 0. enddo enddo call o2_react_rates(orgml, $ z,delz,z_oxic_internal,rc,scale_depth, $ o2_internal_react,dummy,dummy, $ dummy, $ dummy, $ kmax, $ org_consume) call cutoff_irrig(irrig_array, $ z,delz,z_oxic_internal,kmax, $ irrig_internal_array) call pw_1_ss(runid,idebug, $ o2,o2_internal_react, $ z,delz,form,pore, $ diff_array, irrig_internal_array, $ kmax, $ react_tot,diff_tot) o2min = o2(2) do kz=3,kmax if(o2(kz) .LT. o2min) o2min = o2(kz) enddo IF(o2min .LT. 0) then zup = 0.0 zdn = z_oxic_internal elseif( o2min .GT. 1.E-6 $ .AND. z_oxic_internal .LT. z(kmax) ) then zup = z_oxic_internal zdn = z(kmax) else goto 100 endif do iter = 1, 100 do kz=2, kmax o2_internal_react(kz) = 0. enddo call o2_react_rates(orgml, $ z,delz,z_oxic_internal,rc,scale_depth, $ o2_internal_react,dummy,dummy, $ dummy, $ dummy, $ kmax, $ org_consume) call cutoff_irrig(irrig_array, $ z,delz,z_oxic_internal,kmax, $ irrig_internal_array) #ifdef StdOut write(6,*) "o2ss ", iter, z_oxic_internal, o2min, o2(kmax) do kz=2,kmax write(6,*) kz,o2(kz), o2_internal_react(kz) enddo #endif call pw_1_ss(runid,idebug,o2,o2_internal_react, $ z,delz,form,pore, $ diff_array, irrig_internal_array, $ kmax, $ react_tot,diff_tot) o2min = o2(2) do kz=3,kmax if(o2(kz) .LT. o2min) o2min = o2(kz) enddo if( ABS(o2min) .LT. 1E-7) goto 100 #ifdef StdOut write(6,*) "o2ss ", iter, z_oxic_internal, o2min, o2(kmax) do kz=2,kmax write(6,*) kz,o2(kz) enddo #endif IF(o2min .LT. 0) then zdn = z_oxic_internal z_oxic_internal = (z_oxic_internal + zup) / 2. ELSE zup = z_oxic_internal z_oxic_internal = (z_oxic_internal + zdn) / 2. ENDIF enddo 100 continue weight = 1.0 z_oxic = weight * z_oxic_internal $ + (1.-weight) * z_oxic call o2_react_rates(orgml, $ z,delz,z_oxic,rc,scale_depth, $ o2_react,co2_react,no3_react, $ org_react, $ org_dreac, $ kmax, $ org_consume) do kz=2,kmax irrig_oxidation(kz) = 0. enddo do kz = 2, kmax if( o2(kz) .LT. 0 ) o2(kz) = 0. o2_react(kz) = 0. irrig_oxidation(kz) = 0. if(z(kz) .LT. z_oxic) then ! fully oxic irrig_oxidation(kz) = irrig_oxidation(kz) + 0. elseif(z(kz-1) .GT. z_oxic) then ! fully anoxic o2(kz) = 0. c residual o2 source, to be gobbled up by fe, etc. #ifdef IrrigOxidation irrig_oxidation(kz) = irrig_oxidation(kz) $ + irrig_array(kz) * o2(1) * pore(kz) c 1/s mol/l pw mol/l(tot) sec OK c mol/l pw . * 4. ! electron equivalents #endif else ! box contains z_oxic #ifdef IrrigOxidation irrig_oxidation(kz) = irrig_oxidation(kz) $ + irrig_array(kz) * o2(1) * pore(kz) $ * (z_oxic-z(kz-1)) / delz(kz) $ * 4. #endif endif enddo return end subroutine o2_react_rates(orgml, $ z,delz,zrct,rc,scale_depth, $ o2_react,co2_react,no3_react, $ org_react, $ org_dreac, $ kmax, $ org_consume) implicit none #include #include #include integer kmax double precision orgml(nzmax,norgs) double precision z(kmax),delz(kmax) double precision zrct, rc(norgs) double precision o2_react(kmax),co2_react(kmax), $ no3_react(kmax) double precision org_react(nzmax,norgs) double precision org_dreac(nzmax,norgs) double precision org_consume(norgs) integer kz,ioc double precision rc_scale, scale_depth do ioc=1,norgs org_consume(ioc) = 0. enddo DO kz = 2, kmax-1 rc_scale = exp(-z(kz)/scale_depth) c rc_scale = 1 c write(6,*) kz, z(kz), zrct IF(z(kz).le.zrct) then do ioc=1,norgs o2_react(kz) = o2_react(kz) $ - STOIC_REDFIELDO / STOIC_REDFIELDC . * rc(ioc) * rc_scale $ * orgml(kz,ioc) #define OxicpH #ifdef OxicpH co2_react(kz) = co2_react(kz) $ + rc(ioc) * rc_scale * orgml(kz,ioc) #endif no3_react(kz) = no3_react(kz) $ + STOIC_REDFIELDN / STOIC_REDFIELDC $ * rc(ioc) * rc_scale $ * orgml(kz,ioc) org_react(kz,ioc) = org_react(kz,ioc) $ - rc(ioc) * rc_scale * orgml(kz,ioc) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(ioc) * rc_scale org_consume(ioc) = org_consume(ioc) $ - rc(ioc) * rc_scale * orgml(kz,ioc) $ * delz(kz) / 1000 * 3.15E7 enddo ELSEIF(z(kz-1).le.zrct) then do ioc=1,norgs o2_react(kz) = o2_react(kz) $ - STOIC_REDFIELDO / STOIC_REDFIELDC $ * rc(ioc) * rc_scale $ * orgml(kz,ioc) * * (zrct-z(kz-1))/delz(kz) #ifdef OxicpH co2_react(kz) = co2_react(kz) $ + rc(ioc) * rc_scale * orgml(kz,ioc) * * (zrct-z(kz-1))/delz(kz) #endif no3_react(kz) = no3_react(kz) $ + STOIC_REDFIELDN / STOIC_REDFIELDC $ * rc(ioc) * rc_scale * orgml(kz,ioc) * * (zrct-z(kz-1))/delz(kz) org_react(kz,ioc) = org_react(kz,ioc) $ - rc(ioc) * rc_scale * orgml(kz,ioc) * * (zrct-z(kz-1))/delz(kz) org_dreac(kz,ioc) = org_dreac(kz,ioc) $ - rc(ioc) * rc_scale * * (zrct-z(kz-1))/delz(kz) org_consume(ioc) = org_consume(ioc) $ - rc(ioc) * rc_scale * orgml(kz,ioc) * * (zrct-z(kz-1))/delz(kz) $ * delz(kz) / 1000 * 3.15E7 enddo ENDIF enddo return end subroutine irrig_org(irrig_oxidation, $ orgml, $ rc,delz,kmax, $ org_react, org_dreac) implicit none #include #include #include integer kmax, kz, ioc double precision irrig_oxidation(kmax), $ orgml(nzmax,3), $ rc(3),delz(nzmax), $ org_react(nzmax,3), org_dreac(nzmax,3) c internal variables double precision orgtot, reacttot(norgs) do ioc=1,norgs reacttot(ioc) = 0 enddo do kz=2,kmax orgtot = 0. do ioc=1,norgs orgtot = orgtot $ + orgml(kz,ioc) * rc(ioc) $ + 1.e-20 enddo do ioc=1,norgs org_react(kz,ioc) = org_react(kz,ioc) $ - irrig_oxidation(kmax) / 4. ! O2 equivalents $ * STOIC_REDFIELDC / STOIC_REDFIELDO $ * orgml(kz,ioc) * rc(ioc) / orgtot ! scaled by availability reacttot(ioc) = reacttot(ioc) $ - irrig_oxidation(kmax) / 4. ! O2 equivalents $ * STOIC_REDFIELDC / STOIC_REDFIELDO $ * orgml(kz,ioc) * rc(ioc) / orgtot ! scaled by availability $ * delz(kz) / 1000 * 3.15e7 enddo irrig_oxidation(kz) = 0. enddo c write(6,*) "irrig oxidation org react", reacttot return end REDFIELDO $ * orgml(kz,ioc) * rc(ioc)outputmuds.F000644 025374 000024 00000026400 10413036311 013675 0ustar00archeruser000000 000000 subroutine solid_report(iunit,pw_conc, sl_gg, $ sl_residual, sl_react_tot, burial, g ggtot, kmax, c rain, solidname, molwt) implicit none #include #include #include integer iunit,kmax c external variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision sl_residual(nsolidmax), $ sl_react_tot(nsolidmax), $ burial(nsolidmax) c gridvars double precision ggtot(kmax) c chemvars double precision rain(nsolidmax), molwt(nsolidmax) character*4 solidname(nsolidmax) c internal variables double precision sumreact_pw, sumreact_sl, msrain double precision solid_scale(nsolidmax) integer l, isol do isol=1,nsolidmax solid_scale(isol) = 1. enddo solid_scale(IMnO2) = 1.e4 solid_scale(IFeOOH) = 1.e4 #ifdef Bells_Whistles solid_scale(IUO2) = 1.e6 #endif write(iunit,*) c names write(iunit,10) "SolBal", (solidname(isol),isol=1,iSiO2) 10 format(a6, 15a8) 20 format(a6, 15f8.1) c g/g write(iunit,20) "g/g", $ (sl_gg(2,isol)*solid_scale(isol), isol=1,iSiO2) c rain write(iunit,20) "rain", (rain(isol)*solid_scale(isol) $ *1.D6,isol=1,iSiO2) c ,rain(IUO2)*solid_scale(IUO2)*1.e6 c pw react, units of umol/cm2 yr write(iunit,20) "pwrct", $ (sl_react_tot(isol)*solid_scale(isol)*1.e6/molwt(isol), $ isol=1,iSiO2) c bur write(iunit,20) "bur", (burial(isol)/molwt(isol) $ *solid_scale(isol) * 1.d6, $ isol=1,iSiO2) c $ burial(IUO2)/molwt(IUO2)*solid_scale(IUO2) * 1e6 ! E-12 mol/cm2 yr c residual write(iunit,20) "resid%", (sl_residual(isol) $ *100., isol=1,iSiO2) return end subroutine porewater_report(iunit,pw_conc, sl_gg, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, burial, pw_residual, c solutename, rain, molwt ) implicit none #include #include integer iunit,kmax c internal variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), burial(nsolidmax), $ pw_residual(nsolutemax) character*4 solutename(nsolutemax) double precision rain(nsolidmax), molwt(nsolidmax) c internal variables integer isol, ipw integer itco2, ialky parameter(itco2=2, ialky=3) double precision co2_rain, alk_rain write(iunit,*) 50 format(11a8) 60 format(a8,4f8.1,9f8.2) write(iunit,50) "PWBal", "O2", "TCO2", "Alky", $ (solutename(isol), isol=5, 5) !nsolutemax-1) write(iunit,60) "diff", $ (pw_diff_tot(ipw)*1.D6,ipw=1, 3), $ pw_diff_tot(ISi)*1.D6 c $ , c $ pw_diff_tot(IMn2P)*1.D9, c $ pw_diff_tot(IFe2P)*1.D6, c $ (pw_diff_tot(ipw)*1.D9,ipw=8, 11) write(iunit,60) "rct", $ (pw_react_tot(ipw)*1.D6, ipw=1, 3), $ pw_react_tot(ISi) *1.D6 c $ , c $ pw_react_tot(IMn2P) *1.D9, c $ pw_react_tot(IFe2P) *1.D6, c $ (pw_react_tot(ipw)*1.D9, ipw=8, 11) co2_rain = 0. alk_rain = 0. do isol=IOrg,IOrg+NOrgs-1 co2_rain = co2_rain + rain(isol) enddo do isol=ICaCO3,ICaCO3+NCaCO3s-1 co2_rain = co2_rain + rain(isol) alk_rain = alk_rain + rain(isol) * 2 enddo write(iunit,60) "rain", 0., $ co2_rain*1.d6, $ alk_rain*1.d6, $ rain(ISiO2)*1.d6 c $ , c $ rain(IMNO2)*1.d9, c $ 0., ! NO3 c $ rain(IFEOOH)*1.d9, 0., 0., c $ 0. co2_rain = 0. alk_rain = 0. do isol=IOrg,IOrg+NOrgs-1 co2_rain = co2_rain + burial(isol)/molwt(isol)*1.d6 enddo do isol=ICaCO3,ICaCO3+NCaCO3s-1 co2_rain = co2_rain + burial(isol)/molwt(isol)*1.d6 alk_rain = alk_rain + burial(isol)/molwt(isol)*1.d6*2 enddo write(iunit,60) "bur", 0., $ co2_rain, $ alk_rain, $ burial(ISiO2)/molwt(ISiO2)*1.d6 c $ , c $ burial(IMNO2)/molwt(IMNO2)*1.d9 c $ +burial(IMnCO3)/molwt(IMnCO3)*1.d9, c $ 0., ! NO3 c $ burial(IFEOOH)/molwt(IFEOOH)*1.d9 c $ +burial(IFeCO3)/molwt(IFeCO3)*1.d9, c $ 0., c $ burial(IFES)/molwt(IFES)*1.d9, c $ burial(IUO2)/molwt(IUO2)*1.d9 write(iunit,60) "resid", $ (pw_residual(ipw)*100.,ipw=1,3), $ (pw_residual(ipw)*100., $ ipw=5,5) ! nsolutemax) c write(iunit,60) "pwss", c $ ((pw_diff_tot(ipw)+pw_react_tot(ipw))*1d6,ipw=1,3), c $ (pw_diff_tot(ISi)+pw_react_tot(ISi))*1.D6, c $ (pw_diff_tot(IMn2P)+pw_react_tot(IMn2P))*1.D9, c $ (pw_diff_tot(INO3)+pw_react_tot(INO3))*1.D6, c $ ((pw_diff_tot(ipw)+pw_react_tot(ipw))*1.D9,ipw=8, 11) c write(iunit,60) "slss", c $ 0., ! oxygen c $ (rain(ISLOWORG)+rain(IFASTORG)+rain(ICALCITE) ! total co2 c $ -pw_react_tot(itco2) c $ +burial(IFASTORG)/molwt(IFASTORG) c $ +burial(ISLOWORG)/molwt(ISLOWORG) c $ +burial(ICALCITE)/molwt(ICALCITE))*1.d6, c $ (rain(ICALCITE)*2 ! alkalinity c $ -pw_react_tot(ialky) c $ +burial(ICALCITE)/molwt(ICALCITE)*2)*1.d6, c $ (rain(ISiO2)-pw_react_tot(ISi) c $ +burial(ISiO2)/molwt(ISiO2))*1.d6, ! Si c $ (rain(IMNO2)-pw_react_tot(IMn2P) c $ +burial(IMnO2)/molwt(IMNO2))*1.d9, !Mn c $ 0., ! NO3 c $ (rain(IFEOOH)-pw_react_tot(IFE2P) c $ +burial(IFEOOH)/molwt(IFEOOH))*1.d9, c $ 0., c $ 0., c $ 0. return end subroutine profiles_base(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc,org_consume, $ solid_scale, solidname, solutename) implicit none #include #include #include integer iunit,kmax c external variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) c gridvars double precision z(nzmax), omega(nzmax) c chemvars double precision solid_scale(nsolidmax), $ solute_scale(nsolutemax) character*4 solidname(nsolidmax), solutename(nsolutemax) double precision z_level(nzlevels), $ org_consume(norgs,nsolutemax) double precision rc(nrcmax) c internal variables integer k, isol, ipw, i,j double precision org_react(nsolutemax), org_react_tot, $ org_sub_tot(norgs), pH, alk character*6 tag(3) data tag /"fast%","slow%","tot%"/ write(iunit,*) write(iunit,'(13a7)') "S_Maj", (solidname(isol), $ isol=1,iSiO2), . 'bur' do k=2, kmax write(iunit,'(13f7.2)') z(k), $ (sl_gg(k,isol)*solid_scale(isol), $ isol=1, iSiO2), $ omega(k)*1e4 enddo write(iunit,'(a28,7f7.2)') "Csat", . (rc(JCaCO3sat+i)*1.D6,i=0,nCaCO3s-1) write(iunit,*) write(iunit,'(a7,12a10)') "S_Min", (solidname(isol), $ isol=iSiO2+1, ISolidBells-1) do k=2, kmax write(iunit,'(f7.2,12f10.2)') z(k), $ (sl_gg(k,isol)*solid_scale(isol), $ isol=iSiO2+1, ISolidBells-1) enddo 51 format(a7, 6a7, 4a10, 5a7) 60 format(f7.2,5f7.0, f7.2,2f10.2,f10.5,f10.2,f7.0,f7.3,f7.0) write(iunit,*) write(iunit,51) "PW", . (solutename(isol), isol=1, iSoluteBells-1), $ "pH", "alk" do k=1, kmax pH = -0.4343*log( $ rc(JK2) $ * pw_conc(k,IHCO3) $ / pw_conc(k,ICO3) $ ) alk = 0. do ipw=2,4 alk = alk + pw_conc(k,ipw) enddo write(iunit,60) z(k), $ (pw_conc(k,ipw)*1.D6*solute_scale(ipw), $ ipw=1, iSoluteBells-1), pH, alk*1.e6 enddo do i=1,nsolutemax org_react(i) = 0. enddo org_react_tot = 1.e-20 do i=1,norgs org_sub_tot(i) = 1.e-20 enddo do j=1,nsolutemax do i=1,norgs c sum over organic fractions org_react(j) = org_react(j) + org_consume(i,j) c total reaction of each sub-fraction org_sub_tot(i) = org_sub_tot(i) + org_consume(i,j) c total respiration rate org_react_tot = org_react_tot + org_consume(i,j) enddo enddo do j=1,nsolutemax org_react(j) = org_react(j) / org_react_tot enddo c critical depth levels write(iunit,*) write(iunit,30) "Redox","Oxygen", "Nitrate", "Mn", "Iron", $ "Sulfur" 30 format(a7,7a12) 40 format(a7, 7f12.4, 2f6.0) write(iunit,40) "pen. z", $ (z_level(i), i=1,5) do i=1,norgs write(iunit,40) tag(i), $ org_consume(i,IO2)/org_sub_tot(i), $ org_consume(i,INO3)/org_sub_tot(i), $ org_consume(i,IMN2P)/org_sub_tot(i), $ org_consume(i,IFE2P)/org_sub_tot(i), $ org_consume(i,ISO4)/org_sub_tot(i) enddo write(iunit,40) tag(3), $ org_react(IO2), $ org_react(INO3), $ org_react(IMN2P), $ org_react(IFE2P), $ org_react(ISO4) return end subroutine profiles_bells(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc,org_consume, $ solid_scale, solidname, solutename) implicit none #include #include #include integer iunit,kmax c external variables double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) c gridvars double precision z(nzmax), omega(nzmax) c chemvars double precision solid_scale(nsolidmax), $ solute_scale(nsolutemax) character*4 solidname(nsolidmax), solutename(nsolutemax) double precision z_level(nzlevels), $ org_consume(norgs,nsolutemax) double precision rc(nrcmax) c internal variables integer k, isol, ipw, i,j double precision org_react(nsolutemax), org_react_tot, $ org_sub_tot(norgs), pH character*6 tag(3) data tag /"fast%","slow%","tot%"/ write(iunit,*) write(iunit,*) "Bells&Whistles" write(iunit,'(13a10)') "SolB", (solidname(isol), $ isol=iSolidBells,nSolidMax) do k=2, kmax write(iunit,'(13f10.2)') z(k), $ (sl_gg(k,isol)*solid_scale(isol), $ isol=iSolidBells,nSolidMax) enddo write(iunit,*) write(iunit,'(12a10)') "PWB", . (solutename(ipw), . ipw=iSoluteBells, nSoluteMax) do k=1, kmax write(iunit,'(12f10.2)') z(k), $ (pw_conc(k,ipw)*1.D6*solute_scale(ipw), . ipw=iSoluteBells, nSoluteMax) enddo return end isol=iSolidBells,nSolidMax) do k=2, kmax write(iunit,'(13f10.2)') z(k), $ (sl_gg(k,isol)*solid_scale(isol), $ isol=iSolidBells,nSolidMax) enddo write(iunit,*) write(iunit,'(12a10)') "PWB", . porewater_steady_state.F000644 025374 000024 00000012655 10413036311 016234 0ustar00archeruser000000 000000 #define STDOUT subroutine porewater_steady_state( $ runid,idummy,iunit,idebug, $ rc, $ pw_conc,sl_gg, $ bwchem, $ rain, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, $ sl_inv, omega, burial, $ sl_residual, pw_residual, $ org_consume, z_level, $ storage, $ iter) implicit none #include #include #include #include #include #include c external variables double precision rc(nrcmax) double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax) double precision bwchem(nBottomWaters) c internal variables double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), burial(nsolidmax), $ pw_residual(nsolidmax), sl_residual(nsolidmax), $ org_consume(norgs,nsolutemax) double precision storage(Stor_N) double precision omega_new(nzmax) c grid stuff double precision form(nzmax), pore(nzmax), delz(nzmax), $ z(nzmax), z_mix integer kmax c solid advection double precision omega(nzmax), ggtot(nzmax) c mixing and diffusion double precision db, db_array(nzmax,nDbs), $ irrig_array(nzmax), diff_array(nzmax,2,nsolutemax) c chemical variables c porewater concentrations double precision z_level(nzlevels) c solid concentrations double precision sl_ml(nzmax,nsolidmax), $ rain(nsolidmax), msrain c reaction rates and stoiciometries double precision pw_react_rates(nzmax,nsolutemax) double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax) integer runid, idummy,idebug, iunit, iter, isol,i_pw_only logical i_bail data i_bail / .FALSE. / integer niter data niter /200/ #include #include if(runid .EQ. -999) then return endif c begin call init_update(pw_conc, sl_gg, sl_ml, $ bwchem, g z,delz,form, pore, kmax, g diff_coeff,diff_array, $ irrig_array, $ omega, g rc, $ pw_react_rates,sl_react_rates,sl_dreac, $ db_array, c molwt, c rain,msrain) i_pw_only = 1 call porewater_update(runid,-1,idebug,i_pw_only, $ pw_conc, sl_gg, $ sl_ml, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, sl_inv, burial, $ org_consume, g z, delz, form, pore, kmax, c diff_array, irrig_array, $ rc, molwt, $ rain, omega,db_array, $ pw_react_rates, sl_react_rates, c sl_dreac, z_level, $ storage) call flux_convergence(omega, sl_gg, $ sl_react_tot, $ rain, burial, molwt, $ pw_diff_tot, pw_react_tot, $ kmax, $ sl_residual, pw_residual) do isol=1,nsolidmax ! want burial g/cm2 yr burial(isol) = - rain(isol) ! mol/cm2 yr $ * molwt(isol) ! g/cm2 yr $ - sl_react_tot(isol) ! g/cm2 yr enddo #ifdef STDOUT if(idebug .ge. 1) then c write(6,*) "excessive iterations in porewater", iter call profiles_base(iunit,pw_conc, sl_gg, g z, omega, kmax, c solute_scale, z_level, rc, org_consume, c solid_scale,solidname, solutename) call porewater_report(iunit,pw_conc, sl_gg, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, burial,pw_residual, c solutename, rain, molwt ) endif #endif return end subroutine flux_convergence(omega, sl_gg, $ sl_react_tot, $ rain, burial, molwt, $ pw_diff_tot, pw_react_tot, $ kmax, $ sl_residual, pw_residual) implicit none #include #include integer kmax, isol, ipw double precision omega(kmax), sl_gg(nzmax, nsolidmax), $ sl_react_tot(nsolidmax), $ burial(nsolidmax),rain(nsolidmax), molwt(nsolidmax), $ pw_diff_tot(nsolutemax), pw_react_tot(nsolutemax), $ sl_residual(nsolidmax), pw_residual(nsolutemax) do isol=1, nsolidmax c burial(isol) = c $ - omega(kmax) cc [ g sl / cm2 y ] c . * sl_gg(kmax,isol) cc [ g spec / g sl ] sl_residual(isol) = sl_react_tot(isol) $ + burial(isol) $ + rain(isol)*molwt(isol) c now scale it if(rain(isol) .GT. 0) then sl_residual(isol) = sl_residual(isol) $ / rain(isol) / molwt(isol) elseif( sl_react_tot(isol) .GT. 0) then sl_residual(isol) = sl_residual(isol) ! / molwt(isol) $ / sl_react_tot(isol) else sl_residual(isol) = 0. endif enddo #ifdef Bells_Whistles sl_residual(IUO2) = sl_residual(IUO2) * 10. #endif do ipw = 1, nsolutemax c write(6,*) "porewater loop", ipw pw_residual(ipw) = pw_diff_tot(ipw) + pw_react_tot(ipw) if( ABS(pw_diff_tot(ipw)) .GT. 1.e-9) then pw_residual(ipw) = pw_residual(ipw) / pw_diff_tot(ipw) else pw_residual(ipw) = 0. endif enddo return end sl_residual(isol) = 0. endif enddo #ifdef Bells_Whistleporewater_update.F000644 025374 000024 00000056642 10413036311 015031 0ustar00archeruser000000 000000 c#define DebugAnoxicPH subroutine porewater_update( $ runid,iter, idebug, i_pw_only, $ pw_conc, sl_gg, $ sl_ml, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, sl_inv, sl_burial_tot, $ org_consume, g z, delz, form, pore, kmax, $ diff_array, irrig_array, c rc, molwt, $ rain, omega, db_array, $ pw_react, sl_react, c sl_dreac, z_level, $ stor) c calls each of the individual pwss routines just once. c each one dumps pw reaction rates into the other pw species, c and resets its own, so they can accumulate over a c cycle, even from the end of the routine back to the c beginning (on the next call). c each one acccumulates sl reaction rates into the appropriate c sl_react(). implicit none #include #include #include #include #include #include c external variables integer ipw, isol, kz, kmax,ioc integer runid, iter, idebug, i_recalculate, i_pw_only double precision pw_conc(nzmax,nsolutemax) double precision sl_gg(nzmax,nsolidmax), $ sl_ml(nzmax, nsolidmax) double precision pw_react_tot(nsolutemax), $ pw_diff_tot(nsolutemax), $ sl_react_tot(nsolidmax), $ sl_inv(nsolidmax), sl_burial_tot(nsolidmax), $ org_consume(norgs,nsolutemax) c gridvars double precision z(kmax), delz(kmax), form(kmax), $ pore(kmax), $ diff_array(nzmax,2,nsolutemax), irrig_array(nzmax) c chemvars double precision rc(nrcmax), molwt(nsolidmax) double precision rain(nsolidmax), omega(nzmax), $ db_array(nzmax,nDBs) double precision pw_react(nzmax,nsolutemax) double precision sl_react(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax), $ z_level(nzlevels), $ stor(Stor_N) c internal variables double precision co2_dummy_react(nzmax), $ hco3_dummy_react(nzmax), $ irrig_oxidation(nzmax), $ fe2p_zoxic, h2s_zoxic double precision co2_balance #ifdef DebugAnoxicPH double precision ttral, ttrtc #endif do isol=1, nsolutemax do ioc = 1, norgs c org_consume(ioc,isol) = 0. enddo pw_react_tot(isol) = 0. pw_diff_tot(isol) = 0. enddo do isol=1, nsolidmax sl_react_tot(isol) = 0. enddo do kz=1, nzmax co2_dummy_react(kz) = 0. hco3_dummy_react(kz) = 0. irrig_oxidation(kz) = 0. enddo c do isol=1,4 c z_level(isol) = 100. c enddo CALL o2ss(runid,idebug, $ pw_conc(1,IO2), $ sl_ml(1,IORG), $ rc(JORG),rc(JRespScale), $ diff_array(1,1,IO2), irrig_array, $ z, delz, form, pore, kmax, $ pw_react(1,IO2), $ pw_react(1,ICO2), $ pw_react(1,INO3), $ sl_react(1,IORG), $ sl_dreac(1,IORG), $ irrig_oxidation, $ z_level(KOxic), $ pw_react_tot(IO2), pw_diff_tot(IO2), $ org_consume(1,IO2)) if(idebug .LT. 0) then write(6,*) "tridiag error in o2ss", runid return endif call no3ss(runid,idebug, $ pw_conc(1,INO3), $ sl_ml(1,IORG), . rc,z_level, $ diff_array(1,1,INO3), irrig_array, $ z, delz, form, pore, kmax, $ pw_react, $ sl_react(1,IORG), sl_dreac(1,IORG), $ irrig_oxidation, $ pw_react_tot(INO3), pw_diff_tot(INO3), $ org_consume(1,INO3)) if(idebug .LT. 0) then write(6,*) "tridiag error in no3ss", runid return endif #ifdef SkipFeMnUpdate if(iter .LT. 0) then i_recalculate = 1 elseif(iter .LE. 2) then i_recalculate = 1 elseif(pw_conc(kmax,ISO4) $ .LT. pw_conc(1,ISO4)*0.9) then i_recalculate = 1 c elseif(iter .GE. 100) then c i_recalculate = 1 elseif(MOD(iter,SkipFeMnUpdate) .EQ. 0) then i_recalculate = 1 else i_recalculate = 0 endif #else i_recalculate = 1 #endif c smelly anoxic shit #define H2S_FE #ifdef H2S_FE if(i_recalculate .EQ. 1) then call h2s_fe_pwss( $ runid,idebug,i_pw_only, $ pw_conc, $ sl_ml, sl_gg, $ rc, $ z,delz,form,pore,kmax, $ z_level, $ rain(IFEOOH), $ omega,db_array, $ diff_array, $ irrig_array, $ irrig_oxidation, $ pw_react_tot, pw_diff_tot, $ sl_react_tot, sl_burial_tot, $ stor(Stor_Fe_0), stor(Stor_S_0), ! single values $ stor(Stor_Fe_Rx)) ! nzmax * 11 endif if(idebug .LT. 0) then return else call apply_ferates(stor(Stor_Fe_Rx), $ pw_react,sl_react, $ pw_react_tot,org_consume, $ delz,kmax) endif #else sl_react(1,IFEOOH) = -99. sl_react(1,IFES) = -99. sl_react(1,IFECO3) = -99. pw_diff_tot(IH2S) = 0. pw_diff_tot(IFe2p) = 0. pw_diff_tot(ISO4) = 0. pw_react_tot(IH2S) = 0. pw_react_tot(IFe2p) = 0. pw_react_tot(ISO4) = 0. #endif #ifdef DebugAnoxicPH do kz=2,kmax pw_react(kz,IHCO3) = 0. pw_react(kz,ICO3) = 0. enddo #endif if(i_recalculate .EQ. 1) then call mnss( $ i_pw_only, $ runid,idebug, $ pw_conc, $ sl_ml, sl_gg, $ rc, $ molwt, $ rain(IMNO2),omega,db_array, $ z_level, $ diff_array(1,1,IMN2P), irrig_array, $ z, delz, form, pore, kmax, $ irrig_oxidation, $ pw_react_tot(IMN2P),pw_diff_tot(IMN2P), $ stor(Stor_Mn_0),stor(Stor_Mn_Sc),stor(Stor_Mn_Da), $ stor(Stor_Mn_Rx)) ! uses 6*nzmax => ends 108 + 6 = 114 endif if(idebug .LT. 0) then return else call apply_mnrates(stor(Stor_Mn_Rx), $ pw_react,sl_react, $ pw_react_tot(IMN2P),org_consume(1,IMn2p), $ delz,kmax) endif sl_react(1,IMNO2) = -99. sl_react(1,IMNCO3) = -99. #ifdef DEBUG do ipw = 2,4 call pw_react_tot_rates(pw_react(1,ipw), $ delz,kmax, pw_react_tot(ipw)) enddo do isol = 1, 2 call sl_react_tot_pwrates(sl_react(1,isol), $ delz,molwt(isol),kmax, $ sl_react_tot(isol)) enddo co2_balance =pw_react_tot(ICO2) + pw_react_tot(IHCO3) $ + (sl_react_tot(IORG)+sl_react_tot(IORG+1)) $ / molwt(IORG) #endif c kill off the remainder of the irrigation oxidation power #ifdef IrrigOxidation call irrig_org(irrig_oxidation, $ sl_ml(1,IORG), $ rc(JORG),delz,kmax, $ sl_react(1,IORG),sl_dreac(1,IORG)) #endif c ammonia call nh4ss(runid, idebug, $ pw_conc(1,INH4), $ z_level(KOXIC), $ diff_array(1,1,INH4), irrig_array, $ omega, db_array, $ pw_react(1,INH4), $ pw_react(1,INO3), $ pw_react(1,IO2), $ pw_react(1,ICO2), $ pw_react(1,IHCO3), $ rc(JNH4Ox), $ z,delz,form,pore,kmax, $ pw_react_tot(INH4),pw_diff_tot(INH4)) if(idebug .LT. 0) then write(6,*) "tridiag error in nh4ss", runid return endif c #ifdef Bells_Whistles c uranium (reduced insoluble) c call u6ss( c $ pw_conc(1,IUO2CO3), c $ sl_ml(1,IUO2), c $ z_level(KOXIC), z_level(KNO3), c $ rc(JUOX), rc(JURED), diff_array(1,1,IUO2CO3), c $ z, delz, form, pore, kmax, c $ pw_diff_tot(IUO2CO3), c $ pw_react(1,IUO2CO3), c $ sl_react(1,IUO2), c $ sl_dreac(1,IUO2), c $ pw_react_tot(IUO2CO3), pw_diff_tot(IUO2CO3)) c #endif #ifdef Bells_Whistles sl_react(1,IUO2) = -99. pw_react_tot(IUO2CO3) = 0. pw_diff_tot(IUO2CO3) = 0. #endif #ifdef DebugAnoxicPH ccc#define BoudreauCompare c rc(JCaCO3k) = 0. #ifdef BoudreauCompare do kz=2,kmax if(z(kz) .LT. z_level(KOXIC)) then pw_react(kz,ICO2) = $ 15. * exp(-1.*(z(kz)+z(kz-1))/2.) ! micromol / cm2 yr $ * 1.e-3 / 3.15e7 ! mol / l s pw_react(kz,IHCO3) = 0. else pw_react(kz,ICO2) = $ ( 0.187 / 5. $ * exp(-0.18 * (z(kz)+z(kz-1)/2.)) $ - 3. * 0.076 $ * exp(-0.18 * (z(kz)+z(kz-1)/2.)) $ ) ! millimol / l yr $ * 1.e-3 / 3.15e7 ! mol / l s pw_react(kz,IHCO3) = $ ( 4 * 0.187 / 5. * exp(-0.18 * z(kz)) $ + 4. * 0.076 * exp(-0.18 * z(kz)) $ ) * 1.e-3 / 3.15e7 endif pw_react(kz,ICO3) = 0. enddo #endif #ifdef SetSource do kz=2,kmax do ipw = ICO2, ICO3 pw_react(kz,ipw) = 0. enddo enddo pw_react(10,ICO2) = - 15.E-6 ! mol/cm2 yr $ / delz(10) / 3.15e7 ! mol/cm3 tot s $ * 1.e3 ! mol / l pw s pw_react(10,IHCO3) = + 15.E-6 ! mol/cm2 yr $ / delz(10) / 3.15e7 ! mol/cm3 tot s $ * 1.e3 ! mol / l pw s #endif #ifdef CO3Diagnostics ttral = 0. ttrtc = 0. do kz=2,kmax c if(z(kz-1) .GT. z_level(KOXIC)) then ttral = ttral $ + ( pw_react(kz,IHCO3) + 2*pw_react(kz,ICO3) ) $ * delz(kz) * * 3.15E7 / 1e3 ttrtc = ttrtc $ + ( pw_react(kz,ICO2) $ + pw_react(kz,IHCO3) $ + pw_react(kz,ICO3) $ ) $ * delz(kz) * * 3.15E7 / 1e3 c endif enddo write(6,*) "going into co3ss ttral, ttrtc ", $ ttral*1e6, ttrtc*1.e6 #endif #endif !DebugAnoxicPH c calcite dissolution c if(sl_gg(2,iCaCO3+iCalcite) .GT. -99.) then ! 1.e-9) then call co3ss_borate(runid,idebug, $ pw_react(1,ICO2), $ rc, $ diff_array(1,1,ICO2), irrig_array, $ db_array,omega, $ z, delz, form, pore, kmax, $ sl_ml,sl_gg, $ pw_conc(1,ICO2), $ pw_react_tot(ICO2), pw_diff_tot(ICO2), $ pw_react_tot(IHCO3), pw_diff_tot(IHCO3), $ sl_react(1,iCaCO3),sl_dreac(1,iCaCO3)) if(idebug .EQ. -999) then write(6,*) "singular matrix in co3ss", runid return endif pw_react_tot(ICO3) = 0. pw_diff_tot(ICO3) = 0. c else c do ipw = ICO2, ICO3 c pw_react_tot(ipw) = 0. c pw_diff_tot(ipw) = 0. c enddo c do kz=2,kmax c do ipw=1,ncalcites c sl_react(1,ICALCITE+ncalcites-1) = 0. c sl_dreac(1,ICALCITE+ncalcites-1) = 0. c enddo c enddo c endif c opal call hsio4ss(runid,idebug,pw_conc(1,ISi), $ sl_gg(1,ISiO2), $ rc(JOpal), rc(JOpSat), $ diff_array(1,1,ISi),irrig_array, $ z,delz,form,pore,kmax, $ pw_react(1,ISi), $ sl_react(1,ISiO2),sl_dreac(1,ISiO2), $ pw_react_tot(ISi),pw_diff_tot(ISi) ) if(idebug .LT. 0) then write(6,*) "tridiag error in hsio4ss", runid return endif c ad-hocery metal annealing c call metal_anneal(sl_ml(1,IMNO2), c $ sl_react(1,IMNO2), c $ sl_react(1,IMnStable), c $ sl_dreac(1,IMNO2), sl_dreac(1,IMnStable), c $ rc(JMnAnneal),kmax) c call metal_anneal(sl_ml(1,IFEOOH), c $ sl_react(1,IFEOOH), c $ sl_react(1,IFeStable), c $ sl_dreac(1,IFEOOH), sl_dreac(1,IFeStable), c $ rc(JFeAnneal),kmax) c radiotracer #ifdef Bells_Whistles call radiotracer(sl_ml(1,ISTracer), $ sl_react(1,ISTracer), $ sl_dreac(1,ISTracer), $ rc(JSTracer), kmax) c uranium sl_react(1,IUO2) = -99. pw_react_tot(IUO2CO3) = 0. pw_diff_tot(IUO2CO3) = 0. c rhenium sl_react(1,IReSol) = -99. pw_react_tot(IRePW) = 0. pw_diff_tot(IRePW) = 0. c molybdenum sl_react(1,IMoSol) = -99. pw_react_tot(IMoPW) = 0. pw_diff_tot(IMoPW) = 0. #endif c diagnostics do isol = 1, nsolidmax call sl_react_tot_pwrates(sl_react(1,isol), $ delz,molwt(isol),kmax, $ sl_react_tot(isol)) enddo return end subroutine metal_anneal(solml, react_from, react_to, $ dreac_from, dreac_to, rc, kmax) implicit none #include #include integer kz, kmax double precision solml(kmax), $ react_to(kmax), react_from(kmax), $ dreac_to(kmax), dreac_from(kmax), $ rc do kz=2, kmax react_from(kz) = react_from(kz) - rc * solml(kz) react_to(kz) = react_to(kz) + rc * solml(kz) dreac_from(kz) = dreac_from(kz) - rc dreac_to(kz) = dreac_to(kz) enddo return end subroutine radiotracer(solml,react,dreac,rc,kmax) implicit none #include #include integer kz, kmax double precision solml(kmax), react(kmax), dreac(kmax), $ rc do kz=2, kmax react(kz) = react(kz) - rc * solml(kz) dreac(kz) = dreac(kz) - rc enddo return end subroutine pw_1_ss(runid,idebug,solute,react, $ z,delz,form,pore, $ diff_array,irrig_array, $ kmax, $ react_tot,diff_tot) implicit none #include #include integer kmax,runid,idebug c external variables double precision solute(kmax),react(kmax), $ diff_array(nzmax,2), irrig_array(nzmax) double precision z(kmax),delz(kmax),form(kmax),pore(kmax) double precision react_tot, diff_tot c internal variables double precision res(nzmax) double precision a(nzmax),b(nzmax), c(nzmax),r(nzmax),u(nzmax) c double precision dpls(nzmax), dmin(nzmax) DOUBLE PRECISION dfplus(nzmax), dfzero(nzmax), dfmins(nzmax) integer kz, j c CALL calc_pw_diff(diff_coeff, c * form,pore,delz,kmax, c * dpls,dmin) c takes reaction rates in units of moles / l *total* sec #define IrrigPW1 do kz = 2, kmax-1 res(kz) = diff_array(kz,1) * ( solute( kz+1 ) - solute(kz) ) * - diff_array(kz,2) * ( solute( kz ) - solute( kz-1 ) ) #ifdef IrrigPW1 $ + irrig_array(kz) $ * ( solute(1) - solute(kz) ) #endif * + react(kz) / pore(kz) dfplus(kz) = diff_array(kz,1) dfzero(kz) = -diff_array(kz,1) - diff_array(kz,2) #ifdef IrrigPW1 $ - irrig_array(kz) #endif dfmins(kz) = diff_array(kz,2) enddo kz = kmax res(kz) = * - diff_array(kz,2) * ( solute( kz ) - solute( kz-1 ) ) #ifdef IrrigPW1 $ + irrig_array(kz) $ * ( solute(1) - solute(kz) ) #endif * + react(kz) / pore(kz) dfplus(kz) = diff_array(kz,1) dfzero(kz) = -diff_array(kz,1) - diff_array(kz,2) #ifdef IrrigPW1 $ - irrig_array(kz) #endif dfmins(kz) = diff_array(kz,2) do j = 1, kmax-2 a(j+1) = dfmins(j+2) b(j) = dfzero(j+1) c(j) = dfplus(j+1) enddo b(kmax-1) = dfzero(kmax) + dfplus(kmax) do j = 1, kmax-1 r(j) = -res(j+1) enddo CALL tridiag(runid,idebug,a,b,c,r,u, * kmax-1) react_tot = 0. do kz = 2, kmax solute(kz) = solute(kz) + u(kz-1) react_tot = react_tot + react(kz) $ * delz(kz) / 1000 * 3.15E7 c units of mole / cm2 yr enddo call diffusive_flux(solute, diff_array(1,1), $ form,pore,delz,kmax,diff_tot) return end subroutine pw_1_ss_d(runid,idebug,solute,react,dreact, $ z,delz,form,pore, $ diff_array, irrig_array, $ kmax, $ react_tot,diff_tot) implicit none #include #include integer kmax,runid,idebug c external variables double precision solute(kmax),react(kmax),dreact(kmax) double precision z(kmax),delz(kmax),form(kmax),pore(kmax) double precision diff_array(nzmax,2), irrig_array(nzmax), $ react_tot, diff_tot c internal variables double precision res(nzmax) double precision a(nzmax),b(nzmax), c(nzmax),r(nzmax),u(nzmax) double precision dpls(nzmax), dmin(nzmax) DOUBLE PRECISION dfplus(nzmax), dfzero(nzmax), dfmins(nzmax) integer kz, j c CALL calc_pw_diff(diff_coeff, c * form,pore,delz,kmax, c * dpls,dmin) c takes reaction rates in units of moles / l *total* sec #define IrrigPW1d do kz = 2, kmax-1 res(kz) = diff_array(kz,1) * ( solute( kz+1 ) - solute(kz) ) * - diff_array(kz,2) * ( solute( kz ) - solute( kz-1 ) ) #ifdef IrrigPW1d $ + irrig_array(kz) $ * ( solute(1) - solute(kz) ) #endif * + react(kz) / pore(kz) dfplus(kz) = diff_array(kz,1) dfzero(kz) = -diff_array(kz,1) - diff_array(kz,2) #ifdef IrrigPW1d $ - irrig_array(kz) #endif $ + dreact(kz) dfmins(kz) = diff_array(kz,2) enddo kz = kmax res(kz) = * - diff_array(kz,2) * ( solute( kz ) - solute( kz-1 ) ) #ifdef IrrigPW1d $ + irrig_array(kz) $ * ( solute(1) - solute(kz) ) #endif * + react(kz) dfplus(kz) = diff_array(kz,1) dfzero(kz) = -diff_array(kz,1) - diff_array(kz,2) #ifdef IrrigPW1d $ - irrig_array(kz) #endif $ + dreact(kz) dfmins(kz) = diff_array(kz,2) do j = 1, kmax-2 a(j+1) = dfmins(j+2) b(j) = dfzero(j+1) c(j) = dfplus(j+1) enddo b(kmax-1) = dfzero(kmax) + dfplus(kmax) do j = 1, kmax-1 r(j) = -res(j+1) enddo CALL tridiag(runid,idebug,a,b,c,r,u, * kmax-1) react_tot = 0. do kz = 2, kmax solute(kz) = solute(kz) + u(kz-1) react_tot = react_tot + react(kz) $ * delz(kz) / 1000 * 3.15E7 c units of mole / cm2 yr enddo call diffusive_flux(solute, diff_array(1,1), $ form,pore,delz,kmax,diff_tot) return end subroutine cutoff_irrig(irrig_array, $ z,delz,z_cutoff,kmax, $ irrig_cutoff) c keeps irrigation only to upper zone, c e.g. o2 irrigation only to oxic zone. c in anoxic zone, o2 reacts immediately, so c irrigation contributes nothing to the observed o2 profile. implicit none integer kmax, kz double precision irrig_array(kmax), z(kmax), delz(kmax) double precision z_cutoff, irrig_cutoff(kmax) do kz=2,kmax if(z(kz) .LT. z_cutoff) then ! keep irrigation irrig_cutoff(kz) = irrig_array(kz) elseif(z(kz-1) .LT. z_cutoff) then ! partially oxic irrig_cutoff(kz) = irrig_array(kz) $ * (z_cutoff-z(kz-1)) / delz(kz) else irrig_cutoff(kz) = 0 endif enddo return end subroutine diffusive_flux(conc,diff_coeff, $ form,pore,delz,kmax,flux) ! mol/cm2 sec implicit none integer kmax double precision conc(kmax),form(kmax),pore(kmax),delz(kmax) double precision diff_coeff, diff_tot double precision dmin, flux dmin = diff_coeff 1 *(form(2)+1)/2 2 *1/pore(2) 3 *1/delz(2)**2 flux = dmin 1 * ( conc(1) - conc(2) ) 2 * pore(2) 3 * delz(2) 4 * 3.15e7 / 1e3 return end subroutine irrig_flux(conc,irrig, $ pore,delz,kmax,flux) implicit none integer kmax,kz double precision conc(kmax),pore(kmax),delz(kmax), $ irrig(kmax), flux flux = 0. do kz=2,kmax flux = flux $ + irrig(kz) * conc(kz) ! mol/l pw sec $ * pore(kz) * delz(kz) $ * 3.15e7 / 1000 ! mol/cm2 yr enddo return end SUBROUTINE calc_pw_diff(dif_free, * form,pore,delz,kmax, * dopls,domin) implicit none integer kmax DOUBLE PRECISION dif_free DOUBLE PRECISION form(kmax),pore(kmax),delz(kmax) DOUBLE PRECISION dopls(kmax), domin(kmax) integer i DO 30 i=3,kmax-1 dopls(i)=dif_free 1 *((form(i+1)+form(i))/2) 2 * 1 / pore(i) 3 * 2 / ( (delz(i+1)+delz(i)) * delz(i) ) domin(i)=dif_free 1 *((form(i-1)+form(i))/2) 2 * 1/pore(i) 3 * 2 / ( (delz(i-1)+delz(i)) * delz(i) ) 30 CONTINUE i=kmax dopls(i)=0. domin(i)=dif_free 1 *((form(i-1)+form(i))/2) 2 *1/pore(i) 3 * 2 / ( (delz(i-1)+delz(i)) * delz(i) ) i=2 dopls(i)=dif_free 1 *((form(i+1)+form(i))/2) 2 *1/pore(i) 3 * 2 / ( (delz(i+1)+delz(i)) * delz(i) ) domin(i)=dif_free 1 *(form(i)+1)/2 2 *1/pore(i) 3 *1/delz(i)**2 dopls(1) = dif_free domin(1) = dif_free RETURN END SUBROUTINE tridiag(runid,idebug,a,b,c,r,u,n) implicit none INTEGER n INTEGER j integer runid, idebug double precision gam(1000), a(n), b(n), c(n), r(n), u(n) double precision bet if (b(1).EQ.0.) then write(6,*) "b(1) = 1 in tridiag", runid idebug = -9999 return endif bet=b(1) u(1)=r(1)/bet DO 1 j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j)*gam(j) IF(bet.EQ.0.) then write(6,*) 'singular matrix in tridiag', runid idebug = -9999 return endif u(j)=(r(j)-a(j)*u(j-1))/bet 1 CONTINUE DO 2 j=n-1,1,-1 u(j)=u(j)-gam(j+1)*u(j+1) 2 CONTINUE RETURN END subroutine pw_react_tot_rates(react, $ delz, kmax, react_tot) implicit none integer kmax double precision react(kmax),delz(kmax) double precision react_tot integer kz react_tot = 0. do kz=2, kmax react_tot = react_tot + react(kz) $ * delz(kz) / 1000 * 3.15E7 c units of mole / cm2 yr enddo return end subroutine sl_react_tot_pwrates(react,delz,molwt,kmax, $ smrct) c units g / cm2 yr for consistency with sl_react_tot integer kmax double precision react(kmax), delz(kmax), molwt, smrct smrct = 0. do k=2, kmax smrct = smrct $ + react(k) c mol / l second $ * delz(k) / 1000. c mol / cm2 sec $ * 3.15E7 c mol / cm2 yr $ * molwt c g / cm2 yr enddo return end t_tot_pwrates(react,delz,molwt,kmax, $ smrct) c units g / cm2 yr for consistency rate.constants.h000644 025374 000024 00000014034 10413036311 014454 0ustar00archeruser000000 000000 integer nrcmax parameter(nrcmax=154) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Organic matter integer jorg parameter(JORG=1) c----------------------------------------------------------------------- c MnO2 precipitation integer jmnox parameter(JMNOX=3) c----------------------------------------------------------------------- c MnO2 + OC integer jmnorg parameter(JMNORG=4) ! , 5 c----------------------------------------------------------------------- c NITRATE respiration integer jno3org parameter(JNO3ORG=6) ! , 7 c----------------------------------------------------------------------- c IRON oxidation (precipitation) integer jfeox parameter(JFEOX=8) c----------------------------------------------------------------------- c IRON respiration (anoxic) integer jfeorg parameter(JFEORG=9) ! , 10 c----------------------------------------------------------------------- C SULFATE respiration integer jso4org parameter(JSO4ORG=11) ! , 12 c----------------------------------------------------------------------- c SULFIDE oxidation integer jhsox parameter(JHSOX=13) c----------------------------------------------------------------------- c IRON SULFIDE precipitation integer jfespcp parameter(JFESPCP=14) c IRON SULFIDE oxidation integer jfesox parameter(JFESOX=15) c----------------------------------------------------------------------- c Ammonia Oxidation c rate = rc(JNH4Ox) * NH4 integer JNH4Ox parameter(JNH4Ox=16) c----------------------------------------------------------------------- c URANIUM reduction integer jured parameter(JURED=17) c----------------------------------------------------------------------- c URANIUM oxidation integer juox parameter(JUOX=18) c----------------------------------------------------------------------- c CaCO3 dissolution --- seven phases c rate = rc(JCaCO3k) (1-co3=/rc(JCaCO3s))** rc(JCaCO3n) integer jcaco3phase, jcaco3k, jcaco3n, jcaco3sat, jcaco3law, . JCaCO3K1, JCaCO3K2, . jCaCO3PcpK,JCaCO3PcpSeed,JCaCO3PcpArea, . jCaCO3Frag,jCaCO3FragDaug parameter(JCaCO3Phase=19) parameter(JCaCO3K=29) parameter(JCaCO3Sat=39) parameter(JCaCO3N=49) parameter(JCaCO3K1=59) parameter(JCaCO3K2=69) parameter(JCaCO3Law=79) parameter(JCaCO3PcpK=89) parameter(JCaCO3PcpSeed=99) ! 1 if by calcite, 2 if by arag, 3 Mg parameter(JCaCO3PcpArea=109) ! units m2/g CaCO3 parameter(JCaCO3Frag=119) ! frag to dissoln fraction of large calt parameter(JCaCO3FragDaug=129) ! what each fragments into c k1 is rc(JK1), k2 is rc(JK2) integer jk1, jk2, jkb parameter(JK1=139, JK2=140, JKB=141) c----------------------------------------------------------------------- c MnCO3 formation integer jmnco3k,jmnco3sat parameter(JMnCO3k=142,JMnCO3Sat=143) c----------------------------------------------------------------------- c Opal dissolution c SiO2 -> H4SiO4 c rate = rc(JOpal) * (rc(JOpSat) - Si) * SiO2 integer JOpal,JOpSat parameter (JOpal = 144, JOpSat = 145) c----------------------------------------------------------------------- c Radio Tracer decay c rate = rc(JSTracer) * STracer integer JSTracer parameter(JSTracer=146) c----------------------------------------------------------------------- c scale depth for respiration reactions integer JRespScale parameter(JRespScale=147) c Db integer JDb parameter(JDb=148) c bioturbation depth integer JZMix parameter(JZMix=149) c irrigation rate integer JIrrig, JIrrigZ parameter(JIrrig=150, JIrrigZ = 151) c----------------------------------------------------------------------- c manganese recycling integer JMnIR !,JMnDR parameter(JMnIR=152) !, JMnDR=xx) c----------------------------------------------------------------------- c iron recycling integer JFeIR ! ,JFeDR parameter(JFeIR=153) !, JFeDR=xx) c----------------------------------------------------------------------- c iron adsorption integer JFeAds parameter(JFeAds=154) character*10 ratename(nrcmax) character*20 rateunits(nrcmax) data ratename/ . 'JfastOrg','JslowOrg', a 'JMnOx', b 'JfastMnOrg','JslowMnOrg', c 'JfastNO3Org','JslowNO3Org', d 'JFeOx', e 'JfastFeOrg','JslowFeOrg', f 'JfastSO4Org','JslowSO4Org', g 'JH2SOx','JFesPcp','JFeSOx', h 'JNH4Ox','U6+Red','UO2Ox', ! up to 18 now . 10*'JCaPhs', ! 19 i 10*'JCaCO3K', ! 29 1 10*'JCaCO3S', 2 10*'JCaCO3N', . 10*'JCaCO3K1', . 10*'JCaCO3K2', 3 10*'JCaCO3L', 4 10*'JCPcpK', 5 10*'JCPcpS', 6 10*'JCPcpA', 7 10*'JCFrg', 8 10*'JCFrgD', j 'K1','K2','Kb', ! 119 . 'MnCO3k','MnCO3Sat', k 'KOpal','OpalSat','TraceL','RespDepth', l 'Db','ZDb','Irrig','IrrigZ', m 'MnIRedep', ! 'MnDRedep', m 'FeIRedep', ! 'FeDRedep', o 'FeAds'/ data rateunits/'1/s','1/s', a '1/s', b '1/s','1/s', c '1/s','1/s', d '1/s', e '1/s','1/s', f '1/s','1/s', g '1/s','mol^2/s','1/s', h '1/s','1/s','1/s', . 10*' ', i 10*'1/s', 1 10*'mol/l', 2 10*' ', . 10*'1/s', . 10*'1/s', 3 10*' ', 4 10*'1/s', 5 10*' ', 6 10*'m2/g', 7 10*'frc', 8 10*' ', j ' ',' ',' ', 9 '1/s','mol/l', k '1/s','mol/l','1/s','cm', l 'cm^2/yr','cm','cm/day','cm', m 'fraction', ! 'fraction', n 'fraction', ! 'fraction', o ' '/ '1/s', h '1/s','1/s','1/s', . 10*' ', i 10*'1/s', 1 10*'mol/l', 2 10*' ', . 10*'1/s', . 10*'1/s', 3 10*' ', 4 10*'1/s', 5 10*' ', 6 10*'m2/g', 7 10*'frc', 8 10*' ', j ' ',' ',' ', 9 '1/s','mol/l', k '1/s','mol/l','1/s','cm', l 'cm^2/yr','cm','cm/day','cm', m 'fraction', ! 'fraction', n 'fraction', ! 'solid_all_iter.F000644 025374 000024 00000015531 10413036311 014434 0ustar00archeruser000000 000000 #include subroutine solid_all_iter(runid,idebug, $ nitermax, ifast, $ sl_gg, $ sl_ml, $ sl_react_tot, $ burial, sl_inv, g delz, pore, omega, db_array, ggtot, kmax, c rain, sl_react_rates, sl_dreac, molwt ) c calculates steady state solid concentration profiles c uses solid reaction rates which accumulate in pwss routines implicit none #include #include integer kmax,runid,idebug c external variables double precision sl_gg(nzmax,nsolidmax), $ sl_ml(nzmax,nsolidmax) double precision sl_react_tot(nsolidmax), $ burial(nsolidmax), residual(nsolidmax), $ sl_inv(nsolidmax) c gridvars double precision delz(nzmax), pore(nzmax), omega(nzmax), $ db_array(nzmax,nDbs), ggtot(nzmax) c chemvars double precision rain(nsolidmax), molwt(nsolidmax) double precision sl_react_rates(nzmax,nsolidmax), $ sl_dreac(nzmax,nsolidmax) c internal variables integer isol, iter, nitermax, k, l, niter, ifast double precision weight do isol = 1, nsolidmax c compute diagnostic total solid rxn rates call sl_react_tot_pwrates(sl_react_rates(1,isol), $ delz,molwt(isol),kmax, sl_react_tot(isol)) c convert reaction rates to g/g yr call rct_ml_2_gg(sl_react_rates(1,isol), molwt(isol), $ pore, kmax) call drct_ml_2_gg(sl_dreac(1,isol), kmax) c calculate integrated reaction rates c call sl_react_tot_slrates( c $ sl_react_rates(1,isol), c $ pore, delz, c $ kmax, sl_react_tot(isol)) enddo do isol=1,nsolidmax niter = nitermax if(isol .GE. IORG $ .AND. isol .LT. IORG + NORGS) then niter = 1 endif do iter = 1, niter if(ifast .EQ. 1) then if(isol .EQ. IORG) then weight = 0.1 elseif(isol .GT. IORG $ .AND. isol .LE. IORG+NORGS-1) then weight = 0.2 else weight = 0.5 endif else ! go slow if(isol .EQ. IORG) then weight = 0.05 elseif(isol .GT. IORG $ .AND. isol .LE. IORG+NORGS-1) then weight = 0.05 else weight = 0.5 endif endif if(sl_react_rates(1,isol) .GE. 0) then call solid_iter(runid,idebug, $ rain(isol)*molwt(isol), $ sl_react_rates(1,isol), sl_dreac(1,isol), $ sl_gg(1,isol), molwt(isol), g delz, pore, omega, db_array, kmax, c sl_ml(1,isol), $ weight ) endif c call sl_react_tot_slrates( c . sl_react_rates(1,isol), pore, delz, c $ kmax, sl_react_tot(isol)) enddo enddo do k = 2, kmax ggtot(k) = 0. do isol = 1, nsolidmax c sl_gg(k,isol) = MIN(1., sl_gg(k,isol)) ggtot(k) = ggtot(k) + sl_gg(k,isol) enddo enddo c calculate burial rates do isol = 1, nsolidmax burial(isol) = $ - omega(kmax) c [ g sl / cm2 y ] . * sl_gg(kmax,isol) c [ g spec / g sl ] -> g species / cm2 yr enddo do isol = 1, nsolidmax c reset reaction rates do k = 1, kmax sl_react_rates(k,isol) = 0. sl_dreac(k,isol) = 0. enddo enddo call calc_sl_inv(sl_ml, delz, molwt,kmax,sl_inv) return end subroutine sl_react_tot_slrates( $ react, pore, delz, kmax, smrct) c units g / cm2 yr implicit none integer kmax double precision react(kmax), pore(kmax), delz(kmax), $ smrct integer k smrct = 0. do k = 2, kmax smrct = smrct . + react(k) C [ g diss / g sl yr ] . * 2.5 C [ g sl / cm3 sl ] . * ( 1 - pore(k) ) C [ cm3 sl / cm3 total ] . * delz(k) C [ cm (total) ] C = [ g diss / cm2 yr ] enddo return end subroutine rct_ml_2_gg(react, molwt, $ pore, kmax) implicit none integer kmax double precision react(kmax), molwt, pore(kmax) integer iz c takes reaction rates in moles / l *total* sec c and converts to g / g solid yr do iz = 2, kmax react(iz) = react(iz)*molwt*3.15E7 c mol/l s g/l s g/l yr $ /(2.5*(1-pore(iz))*1000) c g sol l sol ml sol enddo return end subroutine drct_ml_2_gg(dreac, kmax) implicit none integer kmax double precision dreac(kmax) integer iz c takes dreaction rates in moles / l *total* sec c and converts to g / g solid yr do iz = 2, kmax dreac(iz) = dreac(iz)*3.15E7 enddo return end #define CalcSolidInv #ifdef CalcSolidInv subroutine calc_sl_inv(sl_ml, delz, molwt, $ kmax, sl_inv) c units g/cm2 implicit none #include #include double precision sl_ml(nzmax,nsolidmax), $ delz(nzmax), molwt(nsolidmax), sl_inv(nsolidmax) integer kmax, kz, isol do isol=1,nsolidmax sl_inv(isol) = 0. enddo do kz=2, kmax do isol=1,nsolidmax sl_inv(isol) = sl_inv(isol) $ + sl_ml(kz,isol) $ / 1000. * delz(kz) * molwt(isol) enddo enddo return end #endif SUBROUTINE sldfrc(solml,solgg,wtmol,pore,imax) C update the solid wt. pct. accounts implicit none integer imax double precision solgg(imax),solml(imax),pore(imax), wtmol integer i DO 21 i=2,imax solgg(i)=solml(i)*wtmol/(2.5*(1-pore(i))*1000) 21 CONTINUE RETURN END SUBROUTINE sldcon(solgg,solml,wtmol,pore,imax) C update the solid concentration accounts implicit none integer imax double precision solgg(imax),solml(imax),pore(imax), wtmol integer i DO 21 i=2,imax solml(i)=solgg(i)*2.5*(1-pore(i))*1000/wtmol 21 CONTINUE RETURN END SUBROUTINE pore_2_form(pore,form,kmax) implicit none integer kmax DOUBLE PRECISION form(kmax), pore(kmax), expb integer k expb = 3.0 DO 10 k = 2, kmax form(k) = pore(k)**expb #ifdef SimpleForm form(k) = 1. #endif 10 CONTINUE RETURN END double precision solgg(imax),solml(imax),pore(imax), wtmol integer i DO 21 i=2,imax solml(i)=solgg(i)*2.5*(1-pore(i))*1000/wtmol 21 CONTINUEsolid_iter.F000644 025374 000024 00000022250 10413036311 013600 0ustar00archeruser000000 000000 subroutine solid_iter(runid,idebug, $ rain,react,dreac,solgg, molwt, g delz, pore, omega, db_array, kmax, c solml, $ weight) c reaction rates arrive in units of g/g yr and are c not reset implicit none #include #include #include integer kmax, runid,idebug c external variables double precision solgg(kmax), $ rain, molwt, react(kmax), dreac(kmax) c gridvars double precision delz(kmax), pore(kmax), omega(kmax), $ db_array(nzmax,nDbs) c chemvars double precision solml(kmax) c internal variables double precision res(nzmax), dres(nzmax,3) double precision a(nzmax),b(nzmax),c(nzmax), $ r(nzmax),u(nzmax) double precision eps, rmserr, weight integer i eps = 1.D-30 C************************ DO 12 i=3, kmax-1 C residual(i) res(i) = db_array(i,DbPlsS) . * ( . solgg(i+1) . - solgg(i) . ) . - db_array(i,DbMinS) . * ( . solgg(i) . - solgg(i-1) . ) . + react(i) . - omega(i) $ * solgg(i) c . * ( solgg(i+1)*delz(i) + solgg(i)*delz(i+1) ) c . / ( delz(i) + delz(i+1) ) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 . + omega(i-1) $ * solgg(i-1) c . * ( solgg(i)*delz(i-1) + solgg(i-1)*delz(i) ) c . / ( delz(i-1) + delz(i) ) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 C dr/dx(i+1) dres(i,1) = db_array(i,DbPlsS) c . - omega(i) c . * delz(i)/(delz(i)+delz(i+1)) c . / delz(i) c . / ( 1 - pore(i) ) / 2.5 C dr/dx(i) dres(i,2) = - db_array(i,DbPlsS) . - db_array(i,DbMinS) . + dreac(i) . - omega(i) c . * delz(i+1)/(delz(i)+delz(i+1)) . / delz(i) . / ( 1 - pore(i) ) / 2.5 c ? - dreac(i) c ? * ( solgg(i+1)*delz(i) + solgg(i)*delz(i+1) ) c ? / ( delz(i) + delz(i+1) ) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 c . + omega(i-1) c . * delz(i-1)/(delz(i)+delz(i-1)) c . / delz(i) c . / ( 1 - pore(i) ) / 2.5 C dr/dx(i-1) dres(i,3) = db_array(i,DbMinS) c ? - dreac(i-1) c ? * ( solgg(i+1)*delz(i) + solgg(i)*delz(i+1) ) c ? / ( delz(i) + delz(i+1) ) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 . + omega(i-1) c . * delz(i)/(delz(i)+delz(i-1)) . / delz(i) . / ( 1 - pore(i) ) / 2.5 c ? + dreac(i-1) c ? * ( solgg(i)*delz(i-1) + solgg(i-1)*delz(i) ) c ? / ( delz(i-1) + delz(i) ) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 c dreac(i) is d omega(i) / d c(i) c dreac(i-1) is d omega(i) / d c(i-1), and c d omega(i-1) / d c(i-1) 12 CONTINUE C ************************** i=2 C residual(2) res(i) = db_array(i,DbPlsS) . * ( . solgg(i+1) . - solgg(i) . ) . + react(i) . + rain . / delz(i) . / ( 1 - pore(i) ) . / 2.5 . - omega(i) $ * solgg(i) c . * ( solgg(i+1)*delz(i) + solgg(i)*delz(i+1) ) c . / ( delz(i) + delz(i+1) ) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 C dr/dx(i+1) dres(i,1) = db_array(i,DbPlsS) c . - omega(i) c . * delz(i)/(delz(i)+delz(i+1)) c . / delz(i) c . / ( 1 - pore(i) ) c . / 2.5 C dr/dx(i) dres(i,2) = - db_array(i,DbPlsS) . + dreac(i) . - omega(i) c . * delz(i+1)/(delz(i)+delz(i+1)) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 c ? - dreac(i) c ? * ( solgg(i+1)*delz(i) + solgg(i)*delz(i+1) ) c ? / ( delz(i) + delz(i+1) ) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 C dr/dx(i-1) (not defined anyway for i=2) dres(i,3) = 0.0 C******************************** i = kmax C residual(kmax) res(i) = . - db_array(i,DbMinS) . * ( . solgg(i) . - solgg(i-1) . ) . + react(i) . - omega(i) . * solgg(i) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 . + omega(i-1) $ * solgg(i-1) c . * ( solgg(i)*delz(i-1) c * + solgg(i-1)*delz(i) c * ) c . / ( delz(i-1) + delz(i) ) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 C dr/dx(i+1) (not defined anyway) dres(i,1) = 0.0 C dr/dx(i) dres(i,2) = - db_array(i,DbMinS) . + dreac(i) . - omega(i) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 c ? - dreac(i) c ? * solgg(i) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 c . + omega(i-1) c . * delz(i-1)/(delz(i)+delz(i-1)) c . / delz(i) c . / ( 1 - pore(i) ) c . / 2.5 C dr/dx(i-1) dres(i,3) = db_array(i,DbMinS) c ? - dreac(i-1) c ? * solgg(i) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 . + omega(i-1) . / delz(i) . / ( 1 - pore(i) ) . / 2.5 c ? + dreac(i-1) c ? * ( solgg(i)*delz(i-1) + solgg(i-1)*delz(i) ) c ? / ( delz(i-1) + delz(i) ) c ? / delz(i) c ? / ( 1 - pore(i) ) c ? / 2.5 C******************************* C set up the residual array DO 24 i=1, kmax-1 r(i) = -res(i+1) C want res(2) into r(1), etc 24 CONTINUE C lower off-diagonal, dri/dxi-1 DO 36 i = 1, kmax-2 a(i+1) = dres(i+2,3) c want dres(3,3) in a(2), dres(4,3) in a(3), etc 36 CONTINUE C diagonal, dri/dxi DO 28 i = 1, kmax-1 b(i) = dres(i+1,2) c want dres(2,2) in b(1), dres(3,2) in b(2), etc 28 CONTINUE C upper off-diagonal, dri/dxi+1 DO 32 i = 1,kmax-2 c(i) = dres(i+1,1) c want dres(2,1) in c(1), dres(3,1) in c(2) etc 32 CONTINUE CALL tridiag(runid,idebug,a,b,c,r,u,kmax-1) C update the concentration and reaction rate arrays rmserr = 0 c if u>0, the concentration is increasing, which we allow unfettered c if u<0, we want to take at most half of whats there c weight = 0.1 DO 52 i=1,kmax-1 if(u(i) .LT. 0) then weight = MIN(weight, -0.9*(solgg(i+1) / u(i))) c elseif(u(i) .GT. 0) then c weight = MIN(weight, 0.9*(1.0-solgg(i+1)) / u(i)) endif solgg(i+1) = solgg(i+1) + u(i) * weight solgg(i+1) = MIN(solgg(i+1), 1.2) react(i+1) = react(i+1) + u(i) * dreac(i+1) * weight rmserr = rmserr + res(i+1)**2 52 CONTINUE solgg(2) = MIN(solgg(2), 1.D0) solgg(kmax) = MIN(solgg(kmax), solgg(kmax-1)*2.D0) CALL sldcon(solgg,solml,molwt,pore,kmax) RETURN END .9*(solgg(i+1) / u(i))) c elseif(u(i) .GT. 0) then c weight = MIN(weight, 0.9*(1.0-solgg(i+1)) / u(i)) endif solgg(i+1) = solgg(i+1) + u(i) * weight solgg(i+1) = MIN(solgg(i+1), 1.2) react(i+1) = react(i+1) + u(i) * dreac(i+1) * weight rmserr = rmserr + res(i+1)**2 52 CONTINUEspecies.h000644 025374 000024 00000003312 10413036311 013136 0ustar00archeruser000000 000000 c solids integer iOrg, nOrgs, iClay, . iCaCO3, nCaCO3s, c . iCalcite, nCalcites, c . iAragonite, nAragonites, c . iMgCalcite, nMgCalcites, . isio2, $ imno2, ifeooh, $ ifes, iuo2, imnco3, ifeco3, . isolidbells,i14caco3,n14caco3s,istracer,iresol,imosol parameter(IOrg=1) parameter(NOrgs=2) parameter(IClay=3) parameter(ICaCO3=4) parameter(NCaCO3s=1) ! phases total parameter(ISiO2=iCaCO3+nCaCO3s) parameter(IMNO2=iCaCO3+nCaCO3s+1) parameter(IMnCO3=iCaCO3+nCaCO3s+2) parameter(IFEOOH=iCaCO3+nCaCO3s+3) parameter(IFES=iCaCO3+nCaCO3s+4) parameter(IFeCO3=iCaCO3+nCaCO3s+5) parameter(ISolidBells=iCaCO3+nCaCO3s+6) #ifdef Bells_Whistles parameter(I14CaCO3=iCaCO3+nCaCO3s+7) parameter(N14CaCO3s=nCaCO3s) parameter(ISTracer=iCaCO3+2*nCaCO3s+7) parameter(IUO2=iCaCO3+2*nCaCO3s+8) parameter(IReSol=iCaCO3+2*nCaCO3s+9) parameter(IMoSol=iCaCO3+2*nCaCO3s+10) #endif c solutes integer io2, ico2, ihco3, ico3, isi, imn2p, ino3, ife2p, iso4, $ ih2s, inh4, isolutebells, . iPO4, iCd,i13tco2, i14tco2, iuo2co3, irepw, imopw parameter(IO2=1) parameter(ICO2=2) parameter(IHCO3=3) parameter(ICO3=4) parameter(ISi=5) parameter(IMN2P=6) parameter(INO3=7) parameter(IFE2P=8) parameter(ISO4=9) parameter(IH2S=10) parameter(INH4=11) parameter(ISoluteBells=12) #ifdef Bells_Whistles parameter(IPO4=12) parameter(ICd=13) parameter(I13TCO2=14) parameter(I14TCO2=15) parameter(IUO2CO3=16) parameter(IRePW=17) parameter(IMoPW=18) #endif parameter(IO2=1) parameter(ICO2=2) parameter(IHCO3=3) parameter(ICO3=4) parameter(ISi=5) parameter(IMN2P=6) parameter(INO3=7) parameter(IFE2P=8) parameter(ISO4=9) parameter(IH2S=10) parameter(INH4=11) parameter(ISoluteBells=12) #ifdef Bellsstoic.h000644 025374 000024 00000015635 10413036311 012637 0ustar00archeruser000000 000000 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C units: pw concentrations in moles / l *porewater* c pw rates in moles / l porewater sec c pw rates may have some "rate hangovers" for next cycle c diagnostic pw_sum_react in moles / cm2 yr C solid concs (-ml) in moles / l *total* C solid fractions in g / g c solid rates calculated in pwss in moles / l total sec c then converted in solidss to g / g yr, then reset to 0 c diagnostic sl_sum_react in g / cm2 yr cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c reactions c OM = (CH2O)stoic(STOIC_REDFIELDC) (NH3)stoic(STOIC_REDFIELDN) (H3PO4) c 106 16 1 c----------------------------------------------------------------------- c OXYGEN respiration c OM + stoic(STOIC_REDFIELDO) O2 -> c stoic(STOIC_REDFIELDC) CO2 + stoic(STOIC_REDFIELDN) NO3+ H3PO4 c 138 106 16 c + (stoic(STOIC_REDFIELDC) + stoic(STOIC_REDFIELDN) ) H2O c 122 #define STOIC_REDFIELDC 106. #define STOIC_REDFIELDN 16. #define STOIC_REDFIELDO 138. c----------------------------------------------------------------------- c MANGANESE oxidation (precipitation; oxic) c stoic(STOIC_MNOXMN)*(1-stoic(STOIC_MnCO3aq)) Mn2+ + O2 -> stoic(STOIC_MNOXMN) MnO2 + stoic(STOIC_MNOXHP) H+ c 2 2 4 c c this is expressed in the code as c c 2Mn2+ + O2 + 4 HCO3- --> 2 MnO2 + 4 H2CO3 #define STOIC_MNOXMN 2. #define STOIC_MNOXHP 4. c----------------------------------------------------------------------- c MANGANESE reduction (respiration; anoxic) c OM + stoic(STOIC_MNORGMN) MnO2 c + (stoic(STOIC_MNORGHP) c * stoic(MnOrgMn)*stoic(STOIC_MnCO3aq)*2 c H+ c -> c stoic(STOIC_MNORGMN)*(1-STOIC_MnCO3aq) Mn2+ c + stoic(STOIC_MNORGMN)*stoic(STOIC_MnCO3aq) MnCO3(aq) c + ( stoic(STOIC_REDFIELDC) c - stoic(STOIC_MnOrgMn)*stoic(STOIC_MnCO3aq) c ) CO2 c + stoic(2)/2 N2 + H3PO4 c + ( stoic(1) + 3/2 stoic(2) + 1/2 stoic(7) ) H2O c c this is expressed in the code as c c 236/106 CH2O + MnO2 + (2 - 106/236 - .35) H2CO3 -> c ~3 c Mn2+ (both speciations) + 2(1-.35) HCO3= c #define STOIC_MNORGMN 236. #define STOIC_MNORGHP 472. #define STOIC_MnCO3aq 0.0 c----------------------------------------------------------------------- c NITRATE respiration c OM + stoic(STOIC_NO3ORGN) HNO3 -> c 94.4 c (stoic(STOIC_REDFIELDC) - stoic(STOIC_NO3OrgN)) CO2 c 106-94.4 c + (stoic(STOIC_REDFIELDN) + stoic(STOIC_NO3ORGN) )/2 N2 c + H3PO4 c + ( stoic(1) + 3/2 stoic(2) + 1/2 stoic(8) ) H2O c this is expressed in the code as c C H O N H + 94.4 NO3- --> (106-94.4) CO2 + 94.4 HCO3 c 106 212 106 16 48 #define STOIC_NO3ORGN 94.4 c----------------------------------------------------------------------- c IRON oxidation (precipitation) c c stoic(STOIC_FEOXF) Fe2+ + O2 -> stoic(STOIC_FEOXF) FeOOH + stoic(STOIC_FEOXHP) H+ c 2 2 2 c c this is expressed in the code as c 5 Fe2+ + NO3- + 9 HCO3 --> 5 FeOOH + 9 CO2 c F H F H #define STOIC_FEOXF 5. #define STOIC_FEOXHP 9. c----------------------------------------------------------------------- c IRON respiration (anoxic) c c OM + stoic(STOIC_FEORGF) FeOOH + stoic(STOIC_FEORGHP) H+ -> c 472 944 c stoic(STOIC_FEORGF) Fe2+ + stoic(STOIC_REDFIELDC) CO2 c 472 c + stoic(STOIC_REDFIELDN) NH4 + H3PO4 + H2O c this is expressed in the code as c OC + 472/106 FeOOH + (944-106)/106 CO2 --> 944/106 HCO3- + 472/106 Fe2+ #define STOIC_FEORGF 472. #define STOIC_FEORGHP 925. c----------------------------------------------------------------------- C SULFATE respiration c c OM + stoic(STOIC_SO4ORGS) SO4(2-) + stoic(STOIC_SO4ORGHP) H(+) -> c 59 59 c stoic(STOIC_REDFIELDC) CO2 c + stoic(STOIC_REDFIELDN)/2 N2 + stoic(STOIC_SO4ORGS) HS(-) c + H3PO4 c c this is expressed in the code as c OC + 59/106 SO4 --> (106-59)/106 CO2 + 59/106 HCO3 + 59/106 HS #define STOIC_SO4ORGS 59. #define STOIC_SO4ORGHP 75. c----------------------------------------------------------------------- c SULFIDE oxidation C c HS(-) + stoic(STOIC_HSOXO2) O2 -> c 2 c SO4(2-) + stoic(STOIC_HSOXHP) H(+) c 1 c this is expressed in the code as c HS + 2 O2 + HCO3 --> SO4 + CO2 #define STOIC_HSOXO2 2. #define STOIC_HSOXHP 1. c----------------------------------------------------------------------- c IRON SULFIDE precipitation c c HS(-) + stoic(STOIC_HSFEF) Fe(2+) -> c 1 c Fe(stoic(STOIC_HSFEF))S + stoic(STOIC_HSFEHP) H(+) c 1 1 #define STOIC_HSFEF 1. #define STOIC_HSFEHP 1. c----------------------------------------------------------------------- c IRON SULFIDE oxidation c c Fe(stoic(STOIC_HSFEF))S + stoic(STOIC_FESOXO2) O2 + stoic(STOIC_FESOXHP) H+ c 1 4.5 1 c --> stoic(STOIC_H2HEF) Fe3+ + SO4= c expressed in the code as c FeS + 4.5 O2 + HCO3- --> FeOOH + SO4= + CO2 #define STOIC_FESOXO2 4.5 #define STOIC_FESOXHP 1. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Ammonia Oxidation c NH4+ + 2 O2 -> NO3- + 2 H+ #define STOIC_NH4OX 2. #define STOIC_NH4HP 2. c----------------------------------------------------------------------- c URANIUM reduction c c UO2(CO3)3 (4-) + stoic(STOIC_UREDF) Fe(2+) + H2O -> c 2 c UO2 + stoic(STOIC_UREDF) FeOOH c 2 c + stoic(STOIC_UC) CO3(2-) c 3 c + stoic(STOIC_UREDHP) H+ c 6 c U6 ---> UO2 #define STOIC_UREDF 2. #define STOIC_UC 3. #define STOIC_UREDHP 6. c----------------------------------------------------------------------- C URANIUM oxidation c c UO2 + stoic(STOIC_UOXO2) O2 + stoic(STOIC_UC) CO3(2-) + stoic(STOIC_UOXHP) H+ -> c 0.5 3 2 c UO2(CO3)3(4-) #define STOIC_UOXO2 0.5 #define STOIC_UOXHP 2. + stoic(STOIC_UREDHP) H+ c 6 c U6 ---> UO2 #define STOIC_UREDF storage.h000644 025374 000024 00000000372 10413036311 013152 0ustar00archeruser000000 000000 integer Stor_N parameter(Stor_N= MUDS_NZ*19) #define Stor_Mn_0 1 #define Stor_Mn_Sc 2 #define Stor_Mn_Da 3 #define Stor_Fe_0 4 #define Stor_S_0 5 #define Stor_Mn_Rx MUDS_NZ*1+1 c needs 6 #define Stor_Fe_Rx MUDS_NZ*7+1 c needs 11 .5 3 2 c UO2(CO3)3(4-) #define STOIC_UOXO2 0.5 #define STOIC_UOXHP 2. + stoic(STOIC_UREDHP) H+ c 6 c U6 ---> UO2 #define STOIC_UREDF test.in000644 025374 000024 00000012756 10413036311 012655 0ustar00archeruser000000 000000 37 140 34.6 160 2300 2192 0 0 3500 4 35 80 104 80 8418.375093 55 5 -99 1.2 989 11425 4 0 "PEsc" 80 100 8000 28 167 31.63 160 2410 2310 0 0 4450 4 35 20 26 20 150 4 -99 1 0.2 -99 -99 100 0 "ManopC" 20 7.5 150 29 110 37.9 160 2410 2310 0 0 3100 4 35 15 19.5 15 630 12 0 1 1.3 -99 -99 15 0 "ManopM" 15 42 630 0 120 30 150 2450 2400 0 0 3000 2 35 12 18 0 200 2 213 5 5 3300 3140 0 0 62 4 22 405.15 567.21 405.15 6250 -99 -99 -99 2 5500 82500 -99 0 "bs2" 1 211 4 5 3300 3100 0 0 52 4 22 1452.7 2033.78 1452.7 6250 13 1 51 2 110 440 -99 0 "BS1" 42 10 48.9 160 2300 2348 0 0 2000 4 35 80 104 80 8418.375093 6 30 -99 5 385 3955 0.5 0 "scruz" 80 100 8000 1 211 4 5 3300 3100 0 0 52 4 22 1452.7 2033.78 1452.7 6250 -99 -99 -99 2 1375 13750 -99 0 "bs1" 7 0 0 10 4200 4000 295 82.45 1176 4 22 110 154 110 3750 -99 -99 -99 5 212.5 212.5 -99 -99 "bs7" 30 167 31.63 160 2410 2310 0 0 4925 4 35 2 2.6 2 40 1 -99 1 0.6 -99 -99 100 0 "ManopS" 2 20 40 201 10 29 150 2300 2348 0 0 3000 4 35 4 3.2 3.2 188.1 2151 194 31 150 2300 2128 0 0 3000 4 35 1000 1000 1000 164339 216 10 29 150 2300 2348 0 0 3000 4 35 17.8 17.8 17.8 1435.1 1345 116 38 150 2300 2221 0 0 3000 4 35 501 501 501 72911 2249 203 30 150 2300 2116 0 0 3000 4 35 794.3 794.3 794.3 125341.0 43 5 49.45 160 2300 2354 0 0 2000 4 35 80 104 80 8418.375093 5 150 -99 12 373 216 0.5 0 "smb" 80 100 8000 41 60 43.4 160 2300 2288 0 0 1800 4 35 80 104 80 8418.375093 20 10 -99 3 494 6482 2 0 "SCB" 80 100 8000 16 231 24.59 10 2300 2060 0 0 190 4 35 905.3333333 60 60 146193.5176 30 140 200 4 110 330 0.5 0.5 "DS4" 39 231 24.59 10 2300 2060 0 0 380 4 35 673 673 673 103134.1814 20 80 175 4 110 330 1 0.5 "DS6" 100 415 30 37 150 2300 2324 0 0 3000 4 35 37.5 37.5 37.5 3452.2 315 20 37 150 2300 2324 0 0 3000 4 35 37.5 37.5 37.5 3452.2 44 35 46.15 150 2300 2318 0 0 2000 4 35 80 104 80 8418.375093 30 5 -99 5 439 28289 0.5 0 "stnick" 80 100 8000 4 5 0 5 3300 3210 0 8 130 4 22 100 140 100 6250 -99 -99 -99 2 5500 20625 -99 0 "bs4" 3 75 4 5 3300 3150 0 0 77 4 22 156.95 219.73 156.95 6250 -99 -99 -99 2 6875 15125 -99 0 "bs3" 5 0 0 5 3300 3300 8 18 181 4 22 300 420 300 3750 -99 -99 -99 3 212.5 212.5 -99 -99 "bs5" 6 0 0 5 3600 3600 75 45 396 4 22 120 168 120 3750 -99 -99 -99 3 212.5 212.5 -99 -99 "bs6" 8 0 0 25 4200 4200 380 91.8 2045 4 22 110 154 110 2500 -99 -99 -99 5 212.5 212.5 -99 -99 "bs8" 9 37 45.93 120 2380 2340 0 0 1443 4 35 28 36.4 28 940 5 -99 16 2.4 -99 -99 1.1 0 "CM-CD" 28 33.57142857 940 10 120 36.8 160 2400 2340 0 0 3320 4 35 64 83.2 64 3600 5 40 75 2.6 -99 -99 1.7 0 "CM-CG" 64 56.25 3600 11 20 47.8 110 2350 2330 0 0 1000 4 35 37 48.1 37 5700 12 1 9 0.4 -99 -99 0.5 0 "CM-CK" 37 154.0540541 5700 12 72 42.08 120 2370 2340 0 0 1880 4 35 43 55.9 43 1700 3 5 5 1.5 -99 -99 1.5 0 "CM-CL" 43 39.53488372 1700 13 129 35.81 160 2400 2340 0 0 3720 4 35 63 81.9 63 6355.753703 8 10 35 2.7 -99 -99 2 0 "CM-CM" 63 100 6300 14 100 39 160 2380 2340 0 0 3111 4 35 17 22.1 17 1361.024863 -99 -99 -99 1.4 -99 -99 5 0 "CM-NMd" 17 100 1700 15 80 41.2 150 2380 2340 0 0 2712 4 35 38 49.4 38 3506.37454 -99 -99 -99 2 -99 -99 1 0 "CM-NNs" 38 100 3800 16 250 22.5 40 2330 2200 0 0 5036 4 35 18 23.4 18 1455.69706 0 -99 1 -99 -99 -99 100 0 "J10BC" 18 100 1800 17 240 23.6 40 2330 2200 0 0 3860 4 35 22 28.6 22 1843.330405 0 -99 4 0.3 -99 -99 100 0 "J12BC" 22 100 2200 18 225 25.25 40 2330 2200 0 0 4900 4 35 14 18.2 14 1083.084989 0 -99 1 0.5 -99 -99 100 0 "J13BC" 14 100 1400 19 250 22.5 40 2330 2200 0 0 5100 4 35 11 14.3 11 815.5327327 0 -99 1 -99 -99 -99 100 0 "J14BC" 11 100 1100 20 250 22.5 40 2330 2200 0 0 5360 4 35 11 14.3 11 815.5327327 0 -99 2 -99 -99 -99 100 0 "J15BC" 11 100 1100 21 240 23.6 20 2320 2190 0 0 1445 4 35 64 83.2 64 360 6 36 41 3.3 150 320 3.5 0 "J1BC" 64 5.625 360 22 200 28 40 2325 2200 0 0 3000 4 35 30 39 30 2655.070509 13 -99 -99 0.27 780 1240 7.5 0 "J2BC" 30 100 3000 23 230 24.7 40 2325 2200 0 0 2981 4 35 38 49.4 38 3600 23 25 30 -99 250 1270 4.5 0 "J3BC" 38 94.73684211 3600 24 140 34.6 20 2320 2190 0 0 1006 4 35 33 42.9 33 2970.123808 5 32 9 0.7 -99 -99 6 0 "J4BC" 33 100 3300 25 240 23.6 40 2330 2200 0 0 4400 4 35 22 28.6 22 1843.330405 0 2 1 0.6 -99 -99 100 0 "J6BC" 22 100 2200 26 250 22.5 40 2330 2200 0 0 4600 4 35 20 26 20 1647.800737 0 -99 4 -99 -99 -99 100 0 "J7BC" 20 100 2000 27 240 23.6 40 2330 2200 0 0 2760 4 35 28 36.4 28 2448.072789 0 -99 2 0.3 -99 -99 100 0 "J8BC" 28 100 2800 31 140 34.6 160 2420 2350 0 0 3570 4 35 36 46.8 36 3290.279525 10 -99 -99 2 -99 -99 100 0 "NEP-2" 36 100 3600 32 154 33.06 160 2420 2350 0 0 4211 4 35 33 42.9 33 2970.123808 8 -99 -99 0.8 -99 -99 18 0 "NEP-3" 33 100 3300 33 155 32.95 160 2420 2350 0 0 4772 4 35 8 10.4 8 560.6970517 0 -99 -99 0.3 -99 -99 100 0 "NEP-4" 8 100 800 34 158 32.62 160 2420 2350 0 0 4980 4 35 5 6.5 5 322.5381665 0 -99 -99 0.2 -99 -99 100 0 "NEP-5" 5 100 500 35 164 31.96 160 2420 2350 0 0 5668 4 35 2 2.6 2 109.7500414 0 -99 -99 0.1 -99 -99 100 0 "NEP-6" 2 100 200 36 208 27.12 100 2300 2060 0 0 500 4 35 64 80 64 1500 -99 -99 10 0.4 -99 -99 100 0 "OMEXB" 100 38 231 24.59 10 2300 2060 0 0 190 4 35 905.3333333 905.3333333 905.3333333 146193.5176 30 140 200 4 110 330 0.5 0 "s4" 100 39 231 24.59 10 2300 2060 0 0 380 4 35 673 673 673 103134.1814 20 80 175 4 110 330 1 0 "s6" 100 40 248 22.72 10 2300 2060 0 0 695 4 35 565.6666667 565.6666667 565.6666667 84067.94551 400 0 80 4 200 16500 1 0 "s9" 100 45 56 43.84 160 2300 2293 0 0 1994 4 35 59 76.7 59 9100 20 10 60 2.4 390 1030 4 0 "WEC203" 59 154.2372881 9100 46 38 45.82 160 2300 2314 0 0 1025 4 35 33 42.9 33 9200 5 1 5 1.6 370 510 5 0 "WEC206" 33 278.7878788 9200 5.3333333 905.3333tuners.h000644 025374 000024 00000001613 10413036311 013025 0ustar00archeruser000000 000000 integer ntuners parameter(ntuners=7) double precision tuners(ntuners) character*5 tune_name(ntuners) data tune_name /"MnR","FeR","SR", . "NR","OxF","Rz", . "IrZ"/ #define TMnResp 1 #define TFeResp 2 #define TSResp 3 #define TNO3Resp 4 #define TOxFrac 5 #define TRespScale 6 #define TIrrigZ 7 data tuners /1.936750116139906, . 0.3783755732806870, . 1.267417488002148, . 0.1987629916218464, . 1.616305098330981, . 0.7116529651310910, . 0.3462060723323323/ c#define TMnIRedep 7 c#define TFeIRedep 10 c#define TMnDRedep 8 c#define TMnCO3k 10 c#define TFeAds 7 c#define TFeIRedep 8 c#define TMnOx 2 c#define TMnCO3Sat 3 c#define TIrrigScale 6 c#define TRespScale 7 c#define TDbZ 8 c#define TDb 9 ccc#define TIrrigOffset 12 6139906, . 0.3783755732806870, . 1.267417488002148, . 0.1987629916u.F000644 025374 000024 00000020670 10413036311 011713 0ustar00archeruser000000 000000 SUBROUTINE uranium( $ runid,idebug, $ u6, uo2ml, uo2gg, $ z_oxidize, z_reduce, $ rain_uo2, $ rox, rred, diffu6, molwt_uo2, $ omega,db_array,irrig_array, $ z, delz, form, pore, kmax, $ difflux,pw_react_tot,sl_react_tot,burial) c solves the solute/solvent system directly (not relaxation) implicit none #include #include #include integer kmax, runid, idebug c external variables double precision u6(nzmax), uo2ml(nzmax),uo2gg(nzmax) double precision z_oxidize, z_reduce, rain_uo2, $ rox, rred, diffu6,molwt_uo2 double precision omega(kmax), db_array(nzmax,nDbs), $ irrig_array(kmax) double precision z(kmax) double precision delz(kmax), form(kmax), pore(kmax) double precision stoi_fe, stoi_co3, stoi_red_h, $ stoi_o2, stoi_ox_h, $ difflux,pw_react_tot,sl_react_tot,burial double precision u6react(nzmax), uo2react(nzmax), $ uo2_dreac(nzmax) double precision react_tot,diff_tot c internal variables double precision dmin(nzmax), dpls(nzmax) double precision jox(nzmax), jred(nzmax) double precision a(2*nzmax,2*nzmax), b(2*nzmax) double precision ggfac integer kz, kz1,iu6pos,iuo2pos CALL calc_pw_diff(diffu6, * form,pore,delz,kmax, * dpls,dmin) do kz=2,kmax jox(kz) = 0. jred(kz) = 0. c zone 1. fully oxidizing box -- shallower than z_oxidize if( z(kz) .LE. z_oxidize ) then jox(kz) = rox c zone 2. fully reducing box -- deeper than z_reduce elseif( z(kz-1) .GE. z_reduce ) then jred(kz) = rred c fully between z_oxidize and z_reduce -- no reaction elseif( $ ( z(kz-1) .GE. z_oxidize ) $ .AND. $ ( z(kz) .LE. z_reduce) $ ) then jred(kz) = 0. jox(kz) = 0. c box contains both z_oxidize and z_reduce elseif ( $ ( z(kz-1) .LT. z_oxidize ) $ .AND. $ ( z(kz) .GT. z_oxidize ) $ .AND. $ ( z(kz-1) .LT. z_reduce ) $ .AND. $ ( z(kz) .GT. z_reduce ) $ ) then jox(kz) = rox $ * ( z_oxidize - z(kz-1) ) / delz(kz) jred(kz) = rred $ * ( z(kz) - z_reduce ) / delz(kz) c box contains only z_oxidize elseif ( $ ( z(kz-1) .LT. z_oxidize ) $ .AND. $ ( z(kz) .GT. z_oxidize ) $ ) then jox(kz) = rox $ * ( z_oxidize - z(kz-1) ) / delz(kz) elseif ( $ ( z(kz-1) .LT. z_reduce ) $ .AND. $ ( z(kz) .GT. z_reduce ) $ ) then jred(kz) = rred $ * ( z(kz) - z_reduce ) / delz(kz) else write(6,*) "Something missed in u2.f" endif enddo c zero matrices do kz=1,(kmax-1)*2 do kz1=1,(kmax-1)*2 a(kz,kz1) = 0. enddo b(kz) = 0 enddo do kz=3,kmax-1 ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 iuo2pos = kz-1 iu6pos = (kmax-1) + kz-1 c uo2 c row, col a(iuo2pos,iuo2pos-1) = db_array(kz,DbMinS) $ + omega(kz-1) $ * ggfac a(iuo2pos,iuo2pos) = -db_array(kz,DbMinS) $ - db_array(kz,DbPlsS) $ - jox(kz) ! wants * uo2gg $ * 3.15e7 $ - omega(kz) $ * ggfac a(iuo2pos,iuo2pos+1) = db_array(kz,DbPlsS) a(iuo2pos,iu6pos) = jred(kz) * 3.15e7 $ * molwt_uo2/(2.5*(1-pore(kz))*1000) ! convert ml to gg c u6+ a(iu6pos,iu6pos-1) = dmin(kz) a(iu6pos,iu6pos) = -dmin(kz) - dpls(kz) c $ - irrig_array(kz) $ - jred(kz) / pore(kz) a(iu6pos,iu6pos+1) = dpls(kz) c jch2o production of solute multiplied by solid a(iu6pos,iuo2pos) = jox(kz) ! implicit *solidgg $ *2.5*(1-pore(kz))*1000/molwt_uo2 ! convert gg to ml $ / pore(kz) c b(iu6pos) = irrig_array(kz) * u6(1) enddo kz=2 ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 iuo2pos = kz-1 iu6pos = (kmax-1) + kz-1 c uo2 a(iuo2pos,iuo2pos) = $ - db_array(kz,DbPlsS) $ - jox(kz) * 3.15e7 $ - omega(kz) $ * ggfac a(iuo2pos,iuo2pos+1) = db_array(kz,DbPlsS) a(iuo2pos,iu6pos) = jred(kz) * 3.15e7 $ * molwt_uo2/(2.5*(1-pore(kz))*1000) b(iuo2pos) = ! no rain of authigenic uo2 $ - rain_uo2 * molwt_uo2 . / delz(2) . / ( 1 - pore(2) ) . / 2.5 c u6+ a(iu6pos,iu6pos) = -dmin(kz) - dpls(kz) c $ - irrig_array(kz) $ - jred(kz) / pore(kz) a(iu6pos,iu6pos+1) = dpls(kz) a(iu6pos,iuo2pos) = jox(kz) / pore(kz) $ * 2.5*(1-pore(kz))*1000/molwt_uo2 ! gg -> ml b(iu6pos) = -dmin(kz) * u6(1) c $ + irrig_array(kz) * u6(1) kz = kmax ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 iuo2pos = kz-1 iu6pos = (kmax-1) + kz-1 c uo2 a(iuo2pos,iuo2pos-1) = db_array(kz,DbMinS) $ + omega(kz-1) $ * ggfac a(iuo2pos,iuo2pos) = -db_array(kz,DbMinS) $ - omega(kz) $ * ggfac $ - jox(kz) * 3.15e7 a(iuo2pos,iu6pos) = jred(kz) * 3.15e7 $ * molwt_uo2/(2.5*(1-pore(kz))*1000) ! convert ml to gg c u6+ a(iu6pos,iu6pos-1) = dmin(kz) a(iu6pos,iu6pos) = -dmin(kz) $ - jred(kz) / pore(kz) a(iu6pos,iuo2pos) = jox(kz) / pore(kz) $ *2.5*(1-pore(kz))*1000/molwt_uo2 ! convert gg to m/l do kz=2,kmax ggfac = 1 . / delz(kz) . / ( 1 - pore(kz) ) . / 2.5 iuo2pos = kz-1 iu6pos = (kmax-1) + kz-1 a(iu6pos,iu6pos) = a(iu6pos,iu6pos) $ - irrig_array(kz) b(iu6pos) = b(iu6pos) $ - irrig_array(kz) * u6(1) #ifdef Junk if(z(kz) .LE. z_reduce) then ! completely oxidizing a(iu6pos,iu6pos) = a(iu6pos,iu6pos) $ - irrig_array(kz) b(iu6pos) = b(iu6pos) $ - irrig_array(kz) * u6(1) elseif( z(kz-1) .GT. z_reduce ) then ! completely reducing b(iuo2pos) = b(iuo2pos) $ - irrig_array(kz) * u6(1) ! mol/l s $ * 3.15e7 $ * molwt_uo2/(2.5*(1-pore(kz))*1000) ! convert ml to gg c all downward irrigated u6 gets converted to uo2. else ! straddles a(iu6pos,iu6pos) = a(iu6pos,iu6pos) - irrig_array(kz) $ * ( z_reduce - z(kz-1) ) / delz(kz) b(iu6pos) = b(iu6pos) - irrig_array(kz) * u6(1) $ * ( z_reduce - z(kz-1) ) / delz(kz) b(iuo2pos) = b(iuo2pos) $ - irrig_array(kz) * u6(1) ! mol/l s $ * 3.15e7 $ * molwt_uo2/(2.5*(1-pore(kz))*1000) ! convert ml to gg $ * ( z(kz) - z_reduce ) / delz(kz) endif #endif enddo call gaussj(runid,idebug,a,(kmax-1)*2,nzmax*2,b,1,1) do kz=2,kmax uo2gg(kz) = b(kz-1) u6(kz) = b(kz-1+(kmax-1)) enddo call sldcon(uo2gg,uo2ml,molwt_uo2,pore,kmax) call diffusive_flux(u6, $ diffu6, $ form,pore,delz,kmax, $ diff_tot) pw_react_tot = 0. do kz=2,kmax pw_react_tot = pw_react_tot $ + ( jred(kz) * u6(kz) . - jox(kz) * uo2ml(kz) . ) ! mol/l s $ * delz(kz) / 1000. * 3.15e7 c mol / cm2 yr enddo sl_react_tot = pw_react_tot * molwt_uo2 ! g / cm2 yr burial = -omega(kmax) * $ uo2gg(kmax) ! g / cm2 yr return end diffu6, $ form,pore,delz,kmax, $ diff_tot) writemudcdf.F000644 025374 000024 00000045007 10413036311 013765 0ustar00archeruser000000 000000 #include #define netCDF SUBROUTINE write_iospecs(filename, $ pw_conc, sl_gg, $ burial, omega, react, irrig_rate, $ z_level, org_consume, $ xlabel, ylabel, $ x, y, z, $ nx, ny, kmax) implicit none #ifndef Malloc integer ndmax parameter(ndmax = 200) #endif #include #include #include #include #include #include #include c external variables integer nx, ny, kmax,nz,i, ioc, isolute, iendpos double precision pw_conc (*), sl_gg(*) double precision burial(*), omega(*), $ react(*), irrig_rate(*), $ z_level(*), org_consume(*) double precision ones(nzmax) real*4 x(nx), y(ny), z(nzmax) character*(*) xlabel, ylabel character*(*) filename write(10,*) filename write(10,*) xlabel write(10,*) ylabel write(10,*) nx,ny write(10,*) x,y,z return end SUBROUTINE writemudcdf(filename, $ pw_conc, sl_gg, $ burial, omega, react, irrig_rate, $ z_level, org_consume, $ xlabel, ylabel, $ x, y, z, $ nx, ny, kmax) implicit none #ifndef Malloc integer ndmax parameter(ndmax = 200) #endif #include #include #include #include #include #include #include c external variables integer nx, ny, kmax,nz,i, ioc, isolute, iendpos double precision pw_conc (*), sl_gg(*) c actually, (nzmax, nsolutemax, nx, ny) double precision burial(*), omega(*), $ react(*), irrig_rate(*), $ z_level(*), org_consume(*) double precision ones(nzmax) c really (nsolidmax, nx, ny) real*4 x(nx), y(ny), z(kmax) character*20 hdffilename, xlabel, ylabel, dataname c character*80 filename !!!!! , dumpfilename character*(*) filename character*8 dummyname #ifdef Malloc c internal variables pointer(pcg_p, pw_conc_g) pointer(sgg_p, sl_gg_g) pointer(tc_p,toc) pointer(dop_p,dop) pointer(csr_p,csr) c pointer(dm_p,dummy) pointer(zl_p,z_level_g) pointer(bg_p, burial_g) pointer(rg_p, react_g) real*4 pw_conc_g(*), $ sl_gg_g(*), $ toc(*), $ dop(*), $ csr(*), $ z_level_g(*), $ burial_g(*), $ react_g(*) #else real*4 pw_conc_g(ndmax*ndmax*kmax*nsolutemax), $ sl_gg_g(ndmax*ndmax*kmax*nsolidmax), $ toc(ndmax*ndmax*kmax), $ dop(ndmax*ndmax*kmax), $ csr(ndmax*ndmax*kmax), $ z_level_g(ndmax*ndmax*5) real*4 burial_g(ndmax*ndmax*nsolidmax), $ omega_g(ndmax*ndmax*kmax), $ react_g(ndmax*ndmax*nsolidmax), $ irrig_rate_g(ndmax*ndmax), $ org_react_g(ndmax*ndmax*nsolutemax),org_react_tot double precision invmolwt(nsolidmax) #endif character*4 tracername integer dims(3) integer start(3), count(3) integer idSolid(nsolidmax), idSolute(nsolutemax), $ idSBur(nsolidmax), idSRct(nsolidmax), $ idZO2, idZNO3, idZMnO2, idZFEO, idZSO4, $ idTOC, idCS, idDOP, $ idirrig,idomega, $ idoresp,idnresp,idfresp,idsresp,idmresp, $ idNCConc, idNCFlux, rcode, $ idx, idy, idz, isol, ipw, nstp, ipos, idigit, $ ix,iy,iz, $ index,index1, index2, index3, index4, offset data ones /nzmax*1.0/ data start /1,1,1/ data dims /1, 2, 3/ do isol=1,nsolidmax invmolwt(isol) = 1/molwt(isol) enddo count(1) = nx count(2) = ny count(3) = kmax do iz=1, kmax z(iz) = - z(iz) enddo #ifdef Malloc pcg_p = malloc(nx*ny*kmax*nsolutemax*4) sgg_p = malloc(nx*ny*kmax*nsolidmax*4) tc_p = malloc(nx*ny*kmax*4) dop_p = malloc(nx*ny*kmax*4) csr_p = malloc(nx*ny*kmax*4) c dm_p = malloc(nx*ny*kmax*4) bg_p = malloc(nx*ny*4) rg_p = malloc(nx*ny*4) zl_p = malloc(nx*ny*4*4) #endif call dp2sp(pw_conc, pw_conc_g, $ cdf_solute_scale, $ nx,ny,nzmax,kmax,nsolutemax) call dp2sp(sl_gg, sl_gg_g, $ solid_scale, $ nx,ny,nzmax,kmax,nsolidmax) call dp2sp(burial, burial_g, invmolwt, $ nx,ny,1,1,nsolidmax) ! mol/cm2 yr call dp2sp(omega, omega_g, ones, $ nx,ny,nzmax,kmax,1) call dp2sp(react, react_g, invmolwt, $ nx,ny,1,1,nsolidmax) call dp2sp(irrig_rate, irrig_rate_g, ones, $ nx,ny,1,1,1) call dp2sp(z_level,z_level_g, ones, $ nx,ny,1,1,nzlevels) c calculated diagnostics c total organic C do ix=1,nx do iy=1,ny do iz=1,kmax index1 = (IORG-1) * nx * ny * kmax index2 = (IORG ) * nx * ny * kmax c index3 = (IORG+1) * nx * ny * kmax offset = 1 + (ix-1) + (iy-1) * nx + (iz-1) * nx * ny toc(offset) = sl_gg_g(index1+offset) $ + sl_gg_g(index2+offset) c $ + sl_gg_g(index3+offset) enddo enddo enddo write(6,*) "Done TOC" c degree of pyritization do ix=1,nx do iy=1,ny do iz=1,kmax index1 = (IFEOOH-1) * nx * ny * kmax index2 = (IFES-1) * nx * ny * kmax offset = 1 + (ix-1) + (iy-1) * nx + (iz-1) * nx * ny dop(offset) = sl_gg_g(index2+offset) $ / ( sl_gg_g(index2+offset) $ + sl_gg_g(index1+offset) $ + 1.e-20 $ ) enddo enddo enddo write(6,*) "Done DOP" c C/S ratio do ix=1,nx do iy=1,ny do iz=1, kmax index1 = (IORG-1) * nx * ny * kmax index2 = (IORG ) * nx * ny * kmax index3 = (IORG+1) * nx * ny * kmax offset = 1 + (ix-1) + (iy-1) * nx + (iz-1) * nx * ny csr(offset) = sl_gg_g(index1+offset) $ + sl_gg_g(index2+offset) $ + sl_gg_g(index3+offset) csr(offset) = csr(offset) $ / solid_scale(IORG) / molwt(IORG) index4 = (IFES-1) * nx * ny * kmax if( sl_gg_g(index4+offset) $ .GT. 0.001 ) then csr(offset) = csr(offset) $ / ( $ sl_gg_g(index4+offset) $ / solid_scale(IFES) / molwt(IFES) $ + 1.e-20 $ ) else csr(offset) = -1. endif enddo enddo enddo write(6,*) "Done CS ratio" c fate of organic carbon do ix=1,nx do iy=1,ny do isolute = 1, nsolutemax index = 1 + (ix-1) + (iy-1)*nx $ + (isolute-1) * nx * ny org_react_g(index) = 0. enddo enddo enddo do ix=1,nx do iy=1,ny org_react_tot = 0. do isolute = 1, nsolutemax c for org_react_g(nx,ny,nsolutemax) index1 = 1 + (ix-1) + (iy-1) * nx $ + (isolute-1) * nx * ny do ioc = 1, norgs c for org_consume(norgs,nsolutemax,nx,ny) index2 = 1 + (ioc-1) + (isolute-1) * norgs $ + (ix-1) * norgs * nsolutemax $ + (iy-1) * norgs * nsolutemax * nx org_react_g(index1) = org_react_g(index1) $ - org_consume(index2) * 1.e6 org_react_tot = org_react_tot $ - org_consume(index2) * 1.e6 enddo enddo do isolute = 1, nsolutemax index1 = 1 + (ix-1) + (iy-1) * nx $ + (isolute-1) * nx * ny if(org_react_tot .GT. 0) then org_react_g(index1) = org_react_g(index1) $ / ( org_react_tot + 1.e-20 ) endif enddo enddo enddo write(6,*) "Done Resp Fractions" do iendpos=80,1,-1 if(filename(iendpos:iendpos) .NE. ' ') then goto 100 endif enddo 100 continue #ifdef Dump c output dump for later conversion to hdf c call getarg(3,dumpfilename) c if(dumpfilename .EQ. "") then c dumpfilename = 'dump.out' c endif filename(iendpos+1:iendpos+6) = ".tohdf" open(unit=7,file=filename, $ form='unformatted') write(7) nx,ny,kmax write(7) $ (pw_conc_g(i),i=1,nx*ny*kmax*nsolutemax), $ (sl_gg_g(i),i=1,nx*ny*kmax*nsolidmax), $ (burial_g(i),i=1,nx*ny*nsolidmax), $ (react_g(i),i=1,nx*ny*nsolidmax), $ (irrig_rate_g(i),i=1,nx*ny), $ (z_level_g(i),i=1,nx*ny*5), $ (toc(i),i=1,nx*ny*kmax), $ (dop(i),i=1,nx*ny*kmax), $ (csr(i),i=1,nx*ny*kmax), $ (org_react_g(i),i=1,nx*ny*nsolutemax), $ x,y,z, $ xlabel,ylabel close(7) write(6,*) "Done dump" #endif #ifdef sHDF do isol=1, nsolidmax c write(6,*) "outputting solid ", isol, " with name ", c $ solidname(isol) dataname = solidname(isol) index = (isol-1) * nx * ny * kmax + 1 nz=kmax-1 call outhdf(nx,ny,nz, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ sl_gg_g(index)) dataname = solidname(isol)//'b' index = (isol-1) * nx * ny + 1 call outhdf(nx,ny,1, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ burial_g(index)) dataname = solidname(isol)//'r' call outhdf(nx,ny,1, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ react_g(index)) enddo do ipw=1, nsolutemax c write(6,*) "outputting solute ", ipw, " with name ", c $ solutename(ipw) dataname = solutename(ipw) index = (ipw-1) * nx * ny * kmax + 1 call outhdf(nx,ny,nz, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ pw_conc_g(index)) enddo dataname = "zo2" call outhdf(nx,ny,1, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ z_level_g(1 + nx*ny*(KOXIC-1) )) dataname = "zno3" call outhdf(nx,ny,1, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ z_level_g(1 + nx*ny*(KNO3-1) )) dataname = "zmn" call outhdf(nx,ny,1, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ z_level_g(1 + nx*ny*(KMnO2-1) )) dataname = "zfe" call outhdf(nx,ny,1, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ z_level_g(1 + nx*ny*(KFe-1) )) dataname = "toc" call outhdf(nx,ny,nz, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ dummy) dataname = "dop" call outhdf(nx,ny,nz, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ dummy) dataname = "csr" call outhdf(nx,ny,nz, $ xlabel, ylabel, 'Z', $ dataname, $ x, y, z, $ dummy) #endif #ifdef netCDF c Concentrations netcdf file filename(iendpos+1:iendpos+9) = ".conc.cdf" write(6,*) filename,NCCLOB idNCConc = nccre(filename, $ NCCLOB,rcode) write(6,*) idNCConc idX = ncddef(idNCConc,xlabel,nx,rcode) idY = ncddef(idNCConc,ylabel,ny,rcode) idZ = ncddef(idNCConc,'Z',kmax,rcode) idX = ncvdef(idNCConc,xlabel,NCFLOAT,1,1,rcode) idY = ncvdef(idNCConc,ylabel,NCFLOAT,1,2,rcode) idZ = ncvdef(idNCConc,'Z',NCFLOAT,1,3,rcode) do isol=1, nsolidmax idSolid(isol) = ncvdef(idNCConc, solidname(isol), $ NCFLOAT, 3, $ dims, rcode) enddo do ipw=1, nsolutemax idSolute(ipw) = ncvdef(idNCConc, solutename(ipw), $ NCFLOAT, 3, $ dims, rcode) enddo idTOC = ncvdef(idNCConc, "TOC", NCFLOAT, 3, dims,rcode) idDOP = ncvdef(idNCConc, "DoPyr", NCFLOAT,3,dims,rcode) idCS = ncvdef(idNCConc, "CtoS", NCFLOAT,3,dims,rcode) idZO2 = ncvdef(idNCConc,"ZO2", $ NCFLOAT, 2, dims,rcode) idZNO3 = ncvdef(idNCConc,"ZNO3", $ NCFLOAT, 2, dims,rcode) idZMnO2 = ncvdef(idNCConc,"ZMnO2", $ NCFLOAT, 2, dims,rcode) idZFEO = ncvdef(idNCConc,"ZFEO", $ NCFLOAT, 2, dims,rcode) idZSO4 = ncvdef(idNCConc,"ZSO4", $ NCFLOAT, 2, dims,rcode) call ncendf(idNCConc,rcode) c Fluxes netcdf file filename(iendpos+1:iendpos+9) = ".flux.cdf" write(6,*) filename, NCCLOB idNCFlux = nccre(filename, $ NCCLOB,rcode) write(6,*) idNCFlux idX = ncddef(idNCFlux,xlabel,nx,rcode) idY = ncddef(idNCFlux,ylabel,ny,rcode) idZ = ncddef(idNCFlux,'Z',kmax,rcode) idX = ncvdef(idNCFlux,xlabel,NCFLOAT,1,1,rcode) idY = ncvdef(idNCFlux,ylabel,NCFLOAT,1,2,rcode) idZ = ncvdef(idNCFlux,'Z',NCFLOAT,1,3,rcode) c 2-d fields do isol=1, nsolidmax dummyname = "B"//solidname(isol) c write(6,*) dummyname idSBur(isol) = ncvdef(idNCFlux,dummyname, $ NCFLOAT, 2, dims,rcode) dummyname = "R"//solidname(isol) write(6,*) dummyname idSRct(isol) = ncvdef(idNCFlux,"R"//solidname(isol), $ NCFLOAT, 2, dims,rcode) enddo idomega = ncvdef(idNCFlux, "Omega", NCFLOAT,3,dims,rcode) ! 3D idirrig = ncvdef(idNCFlux, "Irrig", NCFLOAT,2,dims,rcode) c derived quantities idoresp = ncvdef(idNCFlux, "Oxresp", NCFLOAT,2,dims,rcode) idmresp = ncvdef(idNCFlux, "Mnresp", NCFLOAT,2,dims,rcode) idnresp = ncvdef(idNCFlux, "Nresp", NCFLOAT,2,dims,rcode) idfresp = ncvdef(idNCFlux, "Feresp", NCFLOAT,2,dims,rcode) idsresp = ncvdef(idNCFlux, "Sresp", NCFLOAT,2,dims,rcode) call ncendf(idNCFlux,rcode) write(6,*) "Done with variable defines" c write data to concentrations file call ncvpt(idNCConc,idX, 1, nx, x, rcode) call ncvpt(idNCConc,idY, 1, ny, y, rcode) call ncvpt(idNCConc,idZ, 1, kmax, z, rcode) do isol=1, nsolidmax index = (isol-1) * nx * ny * kmax + 1 call ncvpt(idNCConc, idSolid(isol), start, count, $ sl_gg_g(index), rcode) write(6,*) "Done put solid ", isol enddo do ipw=1, nsolutemax index = (ipw-1) * nx * ny * kmax + 1 call ncvpt(idNCConc, idSolute(ipw), start, count, $ pw_conc_g(index), rcode) write(6,*) "Done put solute ", ipw enddo c penetration depths call ncvpt(idNCConc, idZO2, start,count, $ z_level_g(1 + nx*ny*(KOXIC-1)),rcode) call ncvpt(idNCConc, idZNO3, start,count, $ z_level_g(1 + nx*ny*(KNO3-1)),rcode) call ncvpt(idNCConc, idZMnO2, start,count, $ z_level_g(1 + nx*ny*(KMnO2-1)),rcode) call ncvpt(idNCConc, idZFEO, start,count, $ z_level_g(1 + nx*ny*(KFe-1)),rcode) call ncvpt(idNCConc, idZSO4, start,count, $ z_level_g(1 + nx*ny*(KSO4-1)),rcode) write(6,*) "Done with z levels" c derived quantitites c total organic C call ncvpt(idNCConc, idTOC, start,count,toc,rcode) write(6,*) "Done with TOC" c degree of pyritization call ncvpt(idNCConc, idDOP, start,count, dop, rcode) write(6,*) "Done with DOP" c C/S ratio call ncvpt(idNCConc, idCS, start, count, csr, rcode) write(6,*) "Done with CS ratio" call ncclos(idNCConc,rcode) c now do flux file call ncvpt(idNCFlux,idX, 1, nx, x, rcode) call ncvpt(idNCFlux,idY, 1, ny, y, rcode) call ncvpt(idNCFlux,idZ, 1, kmax, z, rcode) c burial and reaction rates do isol=1, nsolidmax index = (isol-1) * nx * ny + 1 call ncvpt(idNCFlux, idSBur(isol), start, count, $ burial_g(index), rcode) call ncvpt(idNCFlux, idSRct(isol), start, count, $ react_g(index), rcode) enddo write(6,*) "Done putting burial and reaction rates" call ncvpt(idNCFlux,idomega,start,count,omega_g,rcode) write(6,*) "Put omega" call ncvpt(idNCFlux, idirrig, start,count, $ irrig_rate_g, rcode) call ncvpt(idNCFlux, idoresp, start, count, $ org_react_g(1+(IO2-1)*nx*ny), rcode) write(6,*) "Done with ox resp" call ncvpt(idNCFlux, idnresp, start, count, $ org_react_g(1+(INO3-1)*nx*ny), rcode) write(6,*) "Done with no3 resp" call ncvpt(idNCFlux, idfresp, start, count, $ org_react_g(1+(IFE2P-1)*nx*ny), rcode) write(6,*) "Done with fe resp" call ncvpt(idNCFlux, idsresp, start, count, $ org_react_g(1+(ISO4-1)*nx*ny), rcode) write(6,*) "Done with s resp" call ncvpt(idNCFlux, idmresp, start, count, $ org_react_g(1+(IMN2P-1)*nx*ny), rcode) write(6,*) "Done with mn resp" call ncclos(idNCFlux,rcode) write(6,*) "Closing netcdf" c call gzip(filename) #endif RETURN END subroutine dp2sp(dparr, sparr, $ scale, $ nx,ny,nzin,nzout,nsol) implicit none integer nx, ny, nzin, nzout, nsol double precision dparr(nzin,nsol,nx,ny), scale(nsol) real*4 sparr(nx,ny,nzout,nsol) integer ix,iy,iz,isol do ix=1, nx do iy=1, ny do iz=1,nzout do isol=1, nsol sparr(ix,iy,iz,isol) = dparr(iz,isol,ix,iy) $ * scale(isol) enddo enddo enddo enddo return end subroutine gzip(filename) character*(*) filename character*32 syscallstring c compress velocity file write(syscallstring,105) "gzip -f ", filename 105 format(A7,A25) write(6,*) syscallstring call system(syscallstring) return end c tracername = 'pw00' c nstp = ipw c do ipos=4,3,-1 c idigit = mod(nstp,10) c tracername(ipos:ipos) = char(ichar('0') + idigit) c nstp = nstp/10 c enddo c write(6,*) "defining solute ", ipw, " with name ", c $ solutename(ipw) ing c compress velocity file write(syscallstring,105) "gzip -f ", filename 105 format(A7,A25) write(6,*) syscallstring call system(syscallstring) return end c tracername = 'pw00' c nstp = ipw c do ipos=4,3,-1 c idigit = mod(nstp,10) c tracername(ipos:ipos) = char(ichar('0') + idigit) c nstp = nstp/10 c enddo c write(6,*) "defining solute ", ipw, " with name ", c $ solutenamezlevels.h000644 025374 000024 00000000416 10413036311 013171 0ustar00archeruser000000 000000 c----------------------------------------------------------------------- c depths (z_level array) integer koxic, kno3, kmno2, kfe, kso4 parameter(KOXIC=1) parameter(KNO3=2) parameter(KMNO2=3) parameter(KFE=4) parameter(KSO4=5) ipos=4,3,-1 c idigit = mod(nstp,10) c tracername(ipos:ipos) = char(ichar('0') + idigit) c nstp = nstp/10 c enddo c write(6,*) "defining solute ", ipw, " with name ", c $ solutename