!! Copyright (C) Stichting Deltares, 2012-2014. !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License version 3, !! as published by the Free Software Foundation. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !! contact: delft3d.support@deltares.nl !! Stichting Deltares !! P.O. Box 177 !! 2600 MH Delft, The Netherlands !! !! All indications and logos of, and references to registered trademarks !! of Stichting Deltares remain the property of Stichting Deltares. All !! rights reserved. subroutine partmp ( pmsa , fl , ipoint , increm , noseg , & noflux , iexpnt , iknmrk , noq1 , noq2 , & noq3 , noq4 ) !>\file !> Partitioning of micropollutants C********************************************************************** C +----------------------------------------+ C | D E L F T H Y D R A U L I C S | C | WAter Resources and Environment | C +----------------------------------------+ C C*********************************************************************** C C Project : STANDAARDISATIE PROCES FORMULES T721.72 C Author : Jos van Gils C Date : 970815 Version : 0.02 C C History : C C Date Author Description C ------ -------------- ----------------------------------- C ...... .............. .............................. C 950614 Jos van Gils Create first version C 970815 Rik Sonneveldt ophogen pointers buiten actieve segmenten C if gehaald. C 980717 Jos van Gils Evaluation total vs. dis-par corrected C 980718 Jos van Gils Initial evaluation of FFFOPT ... corrected C 000518 Jos van Gils Correct treatment of different metal groups C including explcit definition of metal groups C Integrate with sediment version C Add check on second KENMERK C Add output quantities from MPQUAL C Bug desorption flux sediment corrected! C 000519 Jos van Gils Added a 4-th substances group (OMP's) C 000913 Jan van Beek IAP moet een real zijn C 010716 Johannes Smits Correction for porosity in CDIS, C change of all names HM into MP, C change routine name from PWHM in PARTMP C C*********************************************************************** C C Description of the module : C C General water quality module for DELWAQ: C C PARTITIONING OF MICROPOLLUTANTS: FREE DISSOLVED AND ADSORBED TO C INORGANIC MATTER (THREE FRACTIONS), ORGANIC MATTER (SUM OF DETC C OOC) AND ALGAE (3 GROUPS). NON-EQUILIBRIUM PARTITIONING C C Name T L I/O Description Units C ---- --- - - ------------------- ---- C AIMi R*4 1 I mass of inorganic SS [g/m3] C CDIS R*4 1 O concentration free dissolved MP [g/m3] C CDOC R*4 1 O concentration adsorbed to DOC [g/m3] C DELT R*4 1 I DELWAQ timestep [d] C DOC R*4 1 I dissolved organic Carbon [gC/m3] C FACi R*4 1 L product of conc. sorbent and Kd [-] C FDIS R*4 1 L fraction free dissolved in equilibrium [-] C FDIS2 R*4 1 O fraction free dissolved [-] C FDCOR R*4 1 L factor actual/eq. for free dissolved and DOC fr. [-] C FDOC R*4 1 O fraction sorbed to DOC [-] C FIMi R*4 1 O fraction sorbed to IMi [-] C FPARTE R*4 1 L fraction particulate in equilibrium [-] C FPARTO R*4 1 L fraction particulate begin of present time step [-] C FPART R*4 1 L fraction particulate end of present time step [-] C FPCOR R*4 1 L factor actual/eq. for POC-PHYT-IMx fractions [-] C FPHYT R*4 1 O fraction sorbed to PHYT [-] C FPOC R*4 1 O fraction sorbed to POC [-] C MP R*4 1 L concentration MP waterphase [g/m3] C MPDIS R*4 1 I concentration MP waterphase [free+DOC] [g/m3] C MPPAR R*4 1 I concentration MP waterphase [IMx+POC+PHYT] [g/m3] C MPHUM R*4 1 I concentration MP waterphase [IMx+DOC+POC+PHYT] [g/m3] C HVTADS R*4 1 I half life time kinetic adsorption [d] C HVTDES R*4 1 I half life time kinetic adsorption [d] C KDIMi R*4 1 I partition coefficient inorganic matter [m3/gDM] C KDOC R*4 1 L partition coefficient organic carbon [m3/gC] C KPHYT R*4 1 I partition coefficient phytoplankton [m3/gC] C KPOC R*4 1 I partition coefficient organic carbon [m3/gC] C PHYT R*4 1 I phytoplankton [gC/m3] C POC R*4 1 I particulate organic Carbon [gC/m3] C POR R*4 1 I porosity waterphase [m3/m3] C RATE R*4 1 L actual rate constant kinetic sorption [1/d] C Qy R*4 1 O quality of MP in adsorbens y [g/g] C XDOC R*4 1 I KdDOC/KdPOC [-] C Logical Units : - IMPLICIT REAL (A-H,J-Z) REAL PMSA ( * ) , FL (*) INTEGER IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX, + IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4 LOGICAL IM1OPT , IM2OPT , IM3OPT , IM4OPT , IM5OPT , IM6OPT , * FFFOPT , QQQOPT , WATOPT , HVTOPT , TWOFRC , QUALOPT INTEGER IP1 ,IP2 ,IP3 ,IP4 ,IP5 ,IP6 ,IP7 ,IP8 ,IP9 ,IP10, J IP11,IP12,IP13,IP14,IP15,IP16,IP17,IP18,IP19,IP20, J IP21,IP22,IP23,IP24,IP25,IP26,IP27,IP28,IP29,IP30, J IP31,IP32,IP33,IP34,IP35,IP36,IP37,IP38,IP39,IP40, J IP41,IP42,IP43,IP44,IP45,IP46,IP47,IP48,IP49,IP50 INTEGER IN1 ,IN2 ,IN3 ,IN4 ,IN5 ,IN6 ,IN7 ,IN8 ,IN9 ,IN10, J IN11,IN12,IN13,IN14,IN15,IN16,IN17,IN18,IN19,IN20, J IN21,IN22,IN23,IN24,IN25,IN26,IN27,IN28,IN29,IN30, J IN31,IN32,IN33,IN34,IN35,IN36,IN37,IN38,IN39,IN40, J IN41,IN42,IN43,IN44,IN45,IN46,IN47,IN48,IN49,IN50 REAL AIM1 , KDIM1 , FAC1 , AIM2 , KDIM2 , FAC2 , J AIM3 , KDIM3 , FAC3 , POC , KPOC , FAC4 , J PHYT , KPHYT , FAC5 , DOC , XDOC , KDOC , J FAC6 , HVTADS, HVTDES, MPPAR , MPDIS , DELT , J MP , POR , FPREC , SUMKD , FDIS , AFACT , J MPHUM , FPARTE, FPARTO, RATE , FPCOR , FDCOR , J FPART , PH , KCROHS, KCROH1, KCROH2, KCROH3, J OH , KSOL , CDIS , CRTOT , CRFREE, MOLWT , J FIM1 , FIM2 , FIM3 , FPOC , FPHYT , FDOC , J QIM1 , QIM2 , QIM3 , QPOC , QPHYT , CDOC , J DISS , DISHS , LKSOL , LKMES , LKMEHS, FSULF , J FDIS2 , CDISM , QUAL , KDALL , VOLUME, IAP , J FAC6C INTEGER IFLUX , ISEG , IKMRK1, ISWOX , IGROUP LOGICAL SEDIME C IP1 = IPOINT( 1) IP2 = IPOINT( 2) IP3 = IPOINT( 3) IP4 = IPOINT( 4) IP5 = IPOINT( 5) IP6 = IPOINT( 6) IP7 = IPOINT( 7) IP8 = IPOINT( 8) IP9 = IPOINT( 9) IP10 = IPOINT(10) IP11 = IPOINT(11) IP12 = IPOINT(12) IP13 = IPOINT(13) IP14 = IPOINT(14) IP15 = IPOINT(15) IP16 = IPOINT(16) IP17 = IPOINT(17) IP18 = IPOINT(18) IP19 = IPOINT(19) IP20 = IPOINT(20) IP21 = IPOINT(21) IP22 = IPOINT(22) IP23 = IPOINT(23) IP24 = IPOINT(24) IP25 = IPOINT(25) IP26 = IPOINT(26) IP27 = IPOINT(27) IP28 = IPOINT(28) IP29 = IPOINT(29) IP30 = IPOINT(30) IP31 = IPOINT(31) IP32 = IPOINT(32) IP33 = IPOINT(33) IP34 = IPOINT(34) IP35 = IPOINT(35) IP36 = IPOINT(36) IP37 = IPOINT(37) IP38 = IPOINT(38) IP39 = IPOINT(39) IP40 = IPOINT(40) IP41 = IPOINT(41) IP42 = IPOINT(42) IP43 = IPOINT(43) IP44 = IPOINT(44) IP45 = IPOINT(45) IP46 = IPOINT(46) IP47 = IPOINT(47) IP48 = IPOINT(48) IP49 = IPOINT(49) IP50 = IPOINT(50) C IN1 = INCREM( 1) IN2 = INCREM( 2) IN3 = INCREM( 3) IN4 = INCREM( 4) IN5 = INCREM( 5) IN6 = INCREM( 6) IN7 = INCREM( 7) IN8 = INCREM( 8) IN9 = INCREM( 9) IN10 = INCREM(10) IN11 = INCREM(11) IN12 = INCREM(12) IN13 = INCREM(13) IN14 = INCREM(14) IN15 = INCREM(15) IN16 = INCREM(16) IN17 = INCREM(17) IN18 = INCREM(18) IN19 = INCREM(19) IN20 = INCREM(20) IN21 = INCREM(21) IN22 = INCREM(22) IN23 = INCREM(23) IN24 = INCREM(24) IN25 = INCREM(25) IN26 = INCREM(26) IN27 = INCREM(27) IN28 = INCREM(28) IN29 = INCREM(29) IN30 = INCREM(30) IN31 = INCREM(31) IN32 = INCREM(32) IN33 = INCREM(33) IN34 = INCREM(34) IN35 = INCREM(35) IN36 = INCREM(36) IN37 = INCREM(37) IN38 = INCREM(38) IN39 = INCREM(39) IN40 = INCREM(40) IN41 = INCREM(41) IN42 = INCREM(42) IN43 = INCREM(43) IN44 = INCREM(44) IN45 = INCREM(45) IN46 = INCREM(46) IN47 = INCREM(47) IN48 = INCREM(48) IN49 = INCREM(49) IN50 = INCREM(50) C C Check sediment switch for first segment C SEDIME = .FALSE. IF ( PMSA(IP30) .GT. 0.5 ) SEDIME = .TRUE. C C Find metal group for first segment C 1 = GENERAL (ZN, CU, CD, PB, HG, NI) C 2 = CR C 3 = VA, AS C 4 = OMP's C IGROUP = NINT(PMSA(IP31)) C C OPTIMALISATION PART OUTSIDE SEGMENT LOOP C C inorganic matter 1 C IF ( IN4 .EQ. 0 .AND. IN11 .EQ. 0 ) THEN AIM1 = PMSA( IP4 ) KDIM1 = PMSA( IP11 ) / 1000. FAC1 = AIM1*KDIM1 IM1OPT = .TRUE. ELSE IM1OPT = .FALSE. ENDIF C inorganic matter 2 IF ( IN5 .EQ. 0 .AND. IN12 .EQ. 0 ) THEN AIM2 = PMSA( IP5 ) KDIM2 = PMSA( IP12 ) / 1000. FAC2 = AIM2*KDIM2 IM2OPT = .TRUE. ELSE IM2OPT = .FALSE. ENDIF C inorganic matter 3 IF ( IN6 .EQ. 0 .AND. IN13 .EQ. 0 ) THEN AIM3 = PMSA( IP6 ) KDIM3 = PMSA( IP13 ) / 1000. FAC3 = AIM3*KDIM3 IM3OPT = .TRUE. ELSE IM3OPT = .FALSE. ENDIF C POC IF ( IN9 .EQ. 0 .AND. IN14 .EQ. 0 ) THEN POC = PMSA( IP9 ) IF ( IGROUP .EQ. 4 ) THEN KPOC = 10**PMSA(IP14 ) / 1.E+6 ELSE KPOC = PMSA( IP14 ) / 1000. ENDIF FAC4 = POC *KPOC IM4OPT = .TRUE. ELSE IM4OPT = .FALSE. ENDIF C Phytoplankton IF ( IN10.EQ. 0 .AND. IN15 .EQ. 0 ) THEN PHYT = PMSA( IP10) IF ( IGROUP .EQ. 4 ) THEN KPHYT = 10**PMSA(IP15 ) / 1.E+6 ELSE KPHYT = PMSA( IP15 ) / 1000. ENDIF FAC5 = PHYT*KPHYT IM5OPT = .TRUE. ELSE IM5OPT = .FALSE. ENDIF C DOC and XDOC IF ( IN7 .EQ. 0 .AND. IN8 .EQ. 0 .AND. * IN14 .EQ. 0 ) THEN DOC = PMSA( IP7 ) XDOC = PMSA( IP8 ) IF ( IGROUP .EQ. 4 ) THEN KDOC = 10**PMSA(IP14 ) / 1.E+6 ELSE KDOC = PMSA( IP14 ) / 1000. ENDIF FAC6 = DOC *XDOC *KDOC IM6OPT = .TRUE. ELSE IM6OPT = .FALSE. ENDIF C C Kinetic sorption C IF ( IN20 .EQ. 0 .AND. IN21 .EQ. 0 ) THEN HVTADS = PMSA( IP20 ) HVTDES = PMSA( IP21 ) HVTOPT = .TRUE. ELSE HVTOPT = .FALSE. ENDIF C C Check for modelling of total or dis/par C IF (IN2.EQ.0.AND.IN3.EQ.0) THEN TWOFRC = .FALSE. ELSE TWOFRC = .TRUE. ENDIF IF (TWOFRC) THEN IF (IN2.EQ.0) THEN WRITE(*,*) 'PARTMP: No value for MPDIS in dis/par modelling' CALL SRSTOP(1) ENDIF IF (IN3.EQ.0) THEN WRITE(*,*) 'PARTMP: No value for MPPAR in dis/par modelling' CALL SRSTOP(1) ENDIF ELSE IF (IN2.GT.0) THEN WRITE(*,*) 'PARTMP: Values for MPDIS and MP!' CALL SRSTOP(1) ENDIF IF (IN3.GT.0) THEN WRITE(*,*) 'PARTMP: Values for MPPAR and MP!' CALL SRSTOP(1) ENDIF ENDIF C Compute F-values or not IF ( IN34 .EQ. 0 .AND. IN35 .EQ. 0 .AND. * IN36 .EQ. 0 .AND. IN37 .EQ. 0 .AND. * IN38 .EQ. 0 .AND. IN39 .EQ. 0 .AND. * IN49 .EQ. 0 .AND. IN50 .EQ. 0 ) THEN FFFOPT = .TRUE. ELSE FFFOPT = .FALSE. ENDIF C Compute Q-values or not IF ( IN43 .EQ. 0 .AND. IN44 .EQ. 0 .AND. * IN45 .EQ. 0 .AND. IN46 .EQ. 0 .AND. * IN47 .EQ. 0 ) THEN QQQOPT = .TRUE. ELSE QQQOPT = .FALSE. ENDIF C Compute Waterphase-values or not IF ( IN33 .EQ. 0 .AND. IN41 .EQ. 0 .AND. * IN42 .EQ. 0 .AND. IN49 .EQ. 0 .AND. * IN50 .EQ. 0 ) THEN WATOPT = .TRUE. ELSE WATOPT = .FALSE. ENDIF C Compute qual or not IF ( IN49 .EQ. 0 .AND. IN50 .EQ. 0 ) THEN QUALOPT = .TRUE. ELSE QUALOPT = .FALSE. ENDIF DELT = PMSA(IP22) IF (DELT .LT. 1E-20 ) CALL ERRSYS ('DELT in PARTMP zero', 1 ) C C----------------------------------------------------------------------C C SEGMENT LOOP C----------------------------------------------------------------------C C IFLUX = 0 DO 9000 ISEG = 1 , NOSEG !! CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1) !! IF (IKMRK1.GT.0) THEN IF (BTEST(IKNMRK(ISEG),0)) THEN CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2) IF ((IKMRK2.EQ.0.OR.IKMRK2.EQ.3).OR..NOT.SEDIME) THEN MP = PMSA(IP1 ) MPDIS = PMSA(IP2 ) MPPAR = PMSA(IP3 ) ISWOX = NINT(PMSA(IP23)) IF (TWOFRC) THEN IF (IGROUP.EQ.2) THEN WRITE(*,*) 'PARTMP: Kinetic sorption for Chromium not ', 1 'implemented!' CALL SRSTOP(1) ENDIF MP = MPDIS + MPPAR ENDIF PMSA(IP48) = MP POR = PMSA(IP16) THICK = PMSA(IP17) SURF = PMSA(IP18) DMS1 = PMSA(IP19) VOLUME = PMSA(IP32) FL(1+IFLUX) = 0.0 C C OXIC (ISWOX = 1) PARTITIONING FOR GENERAL METALS (GROUP 1) C OR CR (GROUP 2) OR VA/AS (GROUP 3) or OMP's (GROUP 4) C IF ( ( ISWOX.EQ.1 .AND. IGROUP .EQ. 1 ) .OR. J IGROUP .EQ. 2 .OR. J IGROUP .EQ. 3 .OR. J IGROUP .EQ. 4 ) THEN FPREC = 0.0 C inorganic matter 1 IF ( .NOT. IM1OPT ) THEN AIM1 = PMSA( IP4 ) KDIM1 = PMSA( IP11 ) / 1000. FAC1 = AIM1*KDIM1 ENDIF C inorganic matter 2 IF ( .NOT. IM2OPT ) THEN AIM2 = PMSA( IP5 ) KDIM2 = PMSA( IP12 ) / 1000. FAC2 = AIM2*KDIM2 ENDIF C inorganic matter 3 IF ( .NOT. IM3OPT ) THEN AIM3 = PMSA( IP6 ) KDIM3 = PMSA( IP13 ) / 1000. FAC3 = AIM3*KDIM3 ENDIF C POC IF ( .NOT. IM4OPT ) THEN POC = PMSA( IP9 ) IF ( IGROUP .EQ. 4 ) THEN KPOC = 10**PMSA(IP14 ) / 1.E+6 ELSE KPOC = PMSA( IP14 ) / 1000. ENDIF FAC4 = POC *KPOC ENDIF C Phytoplankton IF ( .NOT. IM5OPT ) THEN PHYT = PMSA( IP10 ) IF ( IGROUP .EQ. 4 ) THEN KPHYT = 10**PMSA(IP15 ) / 1.E+6 ELSE KPHYT = PMSA( IP15 ) / 1000. ENDIF FAC5 = PHYT*KPHYT ENDIF C DOC and XDOC IF ( .NOT. IM6OPT ) THEN DOC = PMSA( IP7 ) XDOC = PMSA( IP8 ) IF ( IGROUP .EQ. 4 ) THEN KDOC = 10**PMSA(IP14 ) / 1.E+6 ELSE KDOC = PMSA( IP14 ) / 1000. ENDIF FAC6 = DOC *XDOC *KDOC ENDIF C IF (.NOT.SEDIME .AND. POR.LT.1E-20 ) J CALL ERRSYS ('POR in PARTMP zero', 1 ) C C*********************************************************************** C**** Processes connected to the HEAVY METAL PARTITIONING C*********************************************************************** C C Convert DOC (g/m3) to (g/m2) FOR SEDIMENT C FAC6C = FAC6 IF (SEDIME) FAC6C = FAC6 * POR * THICK C C Partitioning (free dissolved and adsorbed) C SUMKD = FAC1 + FAC2 + FAC3 + FAC4 + FAC5 + FAC6C IF ( SUMKD .GT. 1.E-20) THEN IF ( SEDIME ) THEN IF ( THICK .GT. 1.E-20 ) THEN FDIS = POR / ( POR + SUMKD / THICK ) ELSE FDIS = 1.0 ENDIF ELSE FDIS = POR / ( POR + SUMKD ) ENDIF AFACT = ( 1.0 - FDIS ) / SUMKD ELSE FDIS = 1.0 AFACT = 0.0 ENDIF MPHUM = AFACT * MP C C Equilibrium fraction PART (excluding DOC!!!) C FPARTE = AFACT * (FAC1 + FAC2 + FAC3 + FAC4 + FAC5) C C Kinetic sorption C IF ( .NOT. HVTOPT ) THEN HVTADS = PMSA( IP20 ) HVTDES = PMSA( IP21 ) ENDIF IF ( HVTADS .GT. 1E-20 .OR. HVTDES .GT. 1E-20 ) THEN IF (.NOT.TWOFRC) THEN WRITE(*,*) 'PARTMP: Kinetic sorption one MP fraction ', 1 'not possible!' WRITE(*,*) 'Create MP-Dis & MP-Part for kinetic sorption' WRITE(*,*) 'or set HLTAdsMP and HLTDesMP to zero' CALL SRSTOP(1) ENDIF C Let op: PART is in dit verband POC + IMx + PHYT !!! C Actual fraction PART IF ( MP .GT. 1E-20 ) THEN FPARTO = MPPAR / MP ELSE FPARTO = 0.0 ENDIF RATE = -1.0 IF ( FPARTO .GT. FPARTE .AND. HVTDES .GT. 1E-20 ) J RATE = LOG(2.) / HVTDES IF ( FPARTO .LT. FPARTE .AND. HVTADS .GT. 1E-20 ) J RATE = LOG(2.) / HVTADS C Fraction part at end of present time step IF ( RATE .GT. 0.0 .AND. FPARTE .GT. 1E-20 J .AND. FPARTE .LT. 1.0 ) THEN FPART = FPARTE - ( FPARTE - FPARTO ) * EXP (-RATE*DELT) FPCOR = FPART/FPARTE FDCOR = ( 1.0 - FPART ) / ( 1.0 - FPARTE ) ELSE FPART = FPARTE FPCOR = 1.0 FDCOR = 1.0 ENDIF ELSE FPART = FPARTE FPCOR = 1.0 FDCOR = 1.0 ENDIF C C Flux from particulate to dissolved fraction C IF (TWOFRC) THEN IF ( SEDIME ) THEN FL(1+IFLUX) = ( FPART * MP - MPPAR ) / DELT / VOLUME ELSE FL(1+IFLUX) = ( FPART * MP - MPPAR ) / DELT ENDIF ELSE FL(1+IFLUX) = 0.0 ENDIF C C CHROMIUM C IF (IGROUP.EQ.2) THEN PH = PMSA(IP24) KCROHS = PMSA(IP25) MOLWT = PMSA(IP26) KCROH1 = PMSA(IP27) KCROH2 = PMSA(IP28) KCROH3 = PMSA(IP29) OH = 10.0**(-(14-PH)) C C-- 1.4 Determine solubility product (as a dissociation K !!). C KSOL = 10**(- KCROHS) C C-- 2.2 Determine concentration of free Cr3+ ,using fdis as calculated C under (2.1), and calculate IAP of Cr(OH)3s. C C CDIS (mg/m3) corresponds with CRTOT (mol/l). C conversion = ug/l * 1.e-6 g/ug / (M g/mol) C IF (POR .LE. 1E-10 ) THEN CDIS = 0.0 ELSE IF ( SEDIME ) THEN IF ( THICK .GT. 1.E-20 ) THEN CDIS = FDIS * MP / (POR * THICK ) ELSE CDIS = 0.0 ENDIF ELSE CDIS = FDIS * MP / POR ENDIF ENDIF CRTOT = CDIS * 1.0E-3 / MOLWT C C-- Crtot = Cr3+ + (CrOH 2+) + (Cr(OH)2 +) + (Cr(OH)3 0+) C Cr3+ = Crtot / (1 + K1*OH + K2*(OH)^2 + K3*(OH)^3) C (mol/l), K's of the association reaction. C CRFREE = CRTOT / ( 1 + & 10**(KCROH1) * OH + & 10**(KCROH2) * OH**2 + & 10**(KCROH3) * OH**3 ) C IAP = CRFREE * OH**3 C C-- 2.3 If IAP > Ksol Cr(OH)3s precipitation will take place. In this C case fdis must be recalculated. C If IAP < Ksol no precipitation will take place and the under C (2.1) calculated fdis is correct. C IF (IAP .GE. KSOL) THEN C C------ 2.3a Calculate Cr3+ and Crtot at present OH- concentration, C (mol/l) and convert to concentration in mg/m3 (= ug/l). C CRFREE = KSOL / (OH**3) CRTOT = CRFREE * ( 1 + & 10**(KCROH1) * OH + & 10**(KCROH2) * OH**2 + & 10**(KCROH3) * OH**3 ) C C------ Conversion = mol/l * M g/mol * 1.0e+6 ug/g C CRTOT= CRTOT * MOLWT * 1.0E+3 IF (SEDIME ) THEN FPREC = 1. - (CRTOT * POR * THICK / (FDIS*MP)) ELSE FPREC = 1. - (CRTOT * POR / (FDIS*MP)) ENDIF ENDIF ENDIF C PMSA(IP40) = FPREC IF ( .NOT. FFFOPT ) THEN FIM1 = AFACT * FAC1 * FPCOR * (1.-FPREC) FIM2 = AFACT * FAC2 * FPCOR * (1.-FPREC) FIM3 = AFACT * FAC3 * FPCOR * (1.-FPREC) FPOC = AFACT * FAC4 * FPCOR * (1.-FPREC) FPHYT = AFACT * FAC5 * FPCOR * (1.-FPREC) FDOC = AFACT * FAC6C * FDCOR * (1.-FPREC) PMSA(IP34) = FDOC PMSA(IP35) = FIM1 PMSA(IP36) = FIM2 PMSA(IP37) = FIM3 PMSA(IP38) = FPOC PMSA(IP39) = FPHYT ENDIF C IF ( .NOT. QQQOPT ) THEN QIM1 = 0.0 QIM2 = 0.0 QIM3 = 0.0 QPOC = 0.0 QPHYT = 0.0 IF ( MPHUM .GT. 1E-20 ) THEN IF (AIM1.GT.1E-20) QIM1 = MPHUM * KDIM1 * FPCOR * (1.-FPREC) IF (AIM2.GT.1E-20) QIM2 = MPHUM * KDIM2 * FPCOR * (1.-FPREC) IF (AIM3.GT.1E-20) QIM3 = MPHUM * KDIM3 * FPCOR * (1.-FPREC) IF (POC .GT.1E-20) QPOC = MPHUM * KPOC * FPCOR * (1.-FPREC) IF (PHYT.GT.1E-20) QPHYT = MPHUM * KPHYT * FPCOR * (1.-FPREC) ENDIF PMSA(IP43) = QIM1 PMSA(IP44) = QIM2 PMSA(IP45) = QIM3 PMSA(IP46) = QPOC PMSA(IP47) = QPHYT ENDIF IF ( .NOT. WATOPT ) THEN C@ Concentration free dissolved MP and DOC waterphase FDIS = FDIS * (1.-FPREC) FDIS2 = FDIS * FDCOR IF (POR .LE. 1.E-10) THEN CDIS = 0.0 CDOC = 0.0 ELSE IF ( SEDIME ) THEN IF ( THICK .GT. 1.E-20 ) THEN CDIS = FDIS * MP * FDCOR / (THICK * POR ) CDOC = (1.0 - FPREC) * AFACT * FAC6C * MP * FDCOR / & (THICK * POR) ELSE CDIS = 0.0 CDOC = 0.0 ENDIF ELSE CDIS = FDIS * MP * FDCOR / POR CDOC = (1.0 - FPREC) * AFACT * FAC6C * MP * FDCOR / POR ENDIF ENDIF C@ Quality of MP adsorbens waterphase FDIS = FDIS2 PMSA(IP33) = FDIS PMSA(IP41) = CDIS PMSA(IP42) = CDOC ENDIF C C SULFIDIC PARTITIONING (ISWOX = 0) FOR GENERAL METALS C ELSEIF ( ISWOX.EQ.0 .AND. IGROUP .EQ. 1 ) THEN PMSA(IP34) = 0.0 PMSA(IP35) = 0.0 PMSA(IP36) = 0.0 PMSA(IP37) = 0.0 PMSA(IP38) = 0.0 PMSA(IP39) = 0.0 PMSA(IP42) = 0.0 PMSA(IP43) = 0.0 PMSA(IP44) = 0.0 PMSA(IP45) = 0.0 PMSA(IP46) = 0.0 PMSA(IP47) = 0.0 DISS = PMSA(IP24) DISHS = PMSA(IP25) IF (DISS .LE. 1E-20) THEN WRITE(*,*) 'SwPoreChWK = ',ISWOX,' 1- oxic, 0 - sulfidic, or' WRITE(*,*) 'DisSWK or DisSSx = ',DISS ,'should not equal zero' CALL ERRSYS ('Fatal error in PARTMP', 1 ) ENDIF MOLWT = PMSA(IP26) LKSOL = PMSA(IP27) LKMES = PMSA(IP28) LKMEHS = PMSA(IP29) IF ( DMS1 .LT. 1E-03 ) THEN FDIS = 1.0 IF (SEDIME) THEN IF ( THICK .GT. 1.E-20 ) THEN CDIS = MP / ( THICK * POR ) ELSE CDIS = 0.0 ENDIF ELSE CDIS = MP / POR ENDIF FSULF = 0.0 ELSEIF ( POR .LT. 1E-10) THEN FSULF = 1.0 FDIS = 0.0 CDIS = 0.0 ELSE CDISM = (1/(10**LKSOL * DISS)) * & (1 + 10**LKMES * DISS + 10**LKMEHS * DISHS) CDIS = CDISM * MOLWT * 1000. IF (SEDIME) THEN FDIS = CDIS * THICK * POR / MP ELSE FDIS = CDIS * POR / MP ENDIF ENDIF FSULF = 1. - FDIS FDOC = 0.0 CDOC = 0.0 PMSA(IP33) = FDIS PMSA(IP40) = FSULF PMSA(IP41) = CDIS ELSE WRITE(*,*) 'Invalid option for partitioning!' WRITE(*,*) 'SwOXIC= ',ISWOX,' 1- oxic, 0 - anoxic' WRITE(*,*) 'Group = ',IGROUP,' 1- General, 2-Cr, 3-As/Va, 4-OMP' CALL SRSTOP(1) ENDIF C C Addition of former process MPQUAL C QUAL = 0.0 KDALL = 0.0 IF ( .NOT. QUALOPT ) THEN IF ( DMS1 .GE. 1E-20 ) THEN C C Compute in g/g C QUAL = MP * (1.0 - FDIS - FDOC) / DMS1 C C Overall partitioning coefficient C IF ( (CDIS + CDOC) .GE. 1E-20 ) THEN C g/g g/m3 = m3/g KDALL = QUAL / (CDIS + CDOC) ELSE KDALL = 0.0 ENDIF C C Convert to mg/kg (QUAL) or to l/kg (KDALL) C QUAL = QUAL * 1.E6 KDALL = KDALL * 1.E6 ENDIF ENDIF C C Output C PMSA (IP49) = QUAL PMSA (IP50) = KDALL ENDIF ENDIF C IP1 = IP1 + IN1 IP2 = IP2 + IN2 IP3 = IP3 + IN3 IP4 = IP4 + IN4 IP5 = IP5 + IN5 IP6 = IP6 + IN6 IP7 = IP7 + IN7 IP8 = IP8 + IN8 IP9 = IP9 + IN9 IP10 = IP10 + IN10 IP11 = IP11 + IN11 IP12 = IP12 + IN12 IP13 = IP13 + IN13 IP14 = IP14 + IN14 IP15 = IP15 + IN15 IP16 = IP16 + IN16 IP17 = IP17 + IN17 IP18 = IP18 + IN18 IP19 = IP19 + IN19 IP20 = IP20 + IN20 IP21 = IP21 + IN21 IP22 = IP22 + IN22 IP23 = IP23 + IN23 IP24 = IP24 + IN24 IP25 = IP25 + IN25 IP26 = IP26 + IN26 IP27 = IP27 + IN27 IP28 = IP28 + IN28 IP29 = IP29 + IN29 IP30 = IP30 + IN30 IP31 = IP31 + IN31 IP32 = IP32 + IN32 IP33 = IP33 + IN33 IP34 = IP34 + IN34 IP35 = IP35 + IN35 IP36 = IP36 + IN36 IP37 = IP37 + IN37 IP38 = IP38 + IN38 IP39 = IP39 + IN39 IP40 = IP40 + IN40 IP41 = IP41 + IN41 IP42 = IP42 + IN42 IP43 = IP43 + IN43 IP44 = IP44 + IN44 IP45 = IP45 + IN45 IP46 = IP46 + IN46 IP47 = IP47 + IN47 IP48 = IP48 + IN48 IP49 = IP49 + IN49 IP50 = IP50 + IN50 IFLUX = IFLUX + NOFLUX C C 9000 CONTINUE c RETURN END