*** supcrt96 - Modified from supcrt92 to use the Holland-Powell heat *** capacity regression equation in addition to Maier-Kelly. *** ALL properly formatted sequential-access databases are *** forwards compatible with Supcrt96+Cprons96. These changes *** were made in 1996, with further increases in array sizes *** in 2005 and 2008. -J.Palandri *** *** supcrt92 - Calculates the standard molal thermodynamic properties *** of reactions among minerals, gases, and aqueous species *** using equations and data given by Helgeson et al. (1978), *** Tanger and Helgeson (1988), Shock and Helgeson *** (1988, 1990), Shock et al. (1989, 1991), Johnson and *** Norton (1991), Johnson et al. (1991), and Sverjensky *** et al. (1991). *** ************************************************************************ *** *** Author: James W. Johnson *** Earth Sciences Department, L-219 *** Lawrence Livermore National Laboratory *** Livermore, CA 94550 *** johnson@s05.es.llnl.gov *** *** Abandoned: 13 November 1991 *** ************************************************************************ *** *** Changes Feb-Apr 05. Modify to run up to 400 reactions and up to 300 *** uneven increments. Due to increasing array dimensions, this version *** will not run on 16-bit systems. -J.Palandri *** -Change MAXRXN from 10 to 400 (max reactions in .rxn file) *** -Change MAXINC from 21 to 300 (max increms, 2nd indep state *** prop in the con file, >= MAXODD) *** -Change MAXODD from 21 to 300 (max # T-P coordinates, non *** uniform increments, <= MAXINC) *** -Change MAXISO from 11 to 21 (max # of isopleths in con file) *** -change 13*MAXISO*MAXINC = 3575 to 81900 *** -change 2*MAXISO*MAXINC = 550 to 12600 *** *** 13*MAXISO*MAXINC = 81900 *** ***DATA dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, Zw, Qw, Yw, Xw *** *JP 1 / 3003*0.0d0 / *** 1 / 81900*0.0d0 / *** *** 2*MAXISO*MAXINC = 12600 *** *JP DATA lvdome, H2Oerr / 462*.FALSE. / *** DATA lvdome, H2Oerr / 12600*.FALSE. / *** Add capability of output tab file (tabf) with T, P, log K, DG, DH *** only, in columns (J.Palandri). *** -Add integer variable OUTFLG: 1 = normal output *** 2 = T, P, log K, DG, DH only *** -Computes TEMP(K) as well as TEMP(degC) for option 2. *** -Remove some blank lines from tab file (tabf). ***___________________________________ *** Changes Jan 08. Modify to run up to 900 uneven increments. *** (J.Palandri). *** -Change MAXINC from 300 to 900 (max increms, 2nd indep state *** prop in the con file, >= MAXODD) *** -Change MAXODD from 300 to 900 (max # T-P coordinates, non *** uniform incremENTS, <= MAXINC) *** -change 13*MAXISO*MAXINC = 81900 to 245700 *** -change 2*MAXISO*MAXINC = 12600 to 37800 *** *** 13*MAXISO*MAXINC = 81900 *** ***DATA dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, Zw, Qw, Yw, Xw *** *JP 1 / 81900*0.0d0 / *** 1 / 245700*0.0d0 / *** *** 2*MAXISO*MAXINC = 12600 *** *JP DATA lvdome, H2Oerr / 12600*.FALSE. / *** DATA lvdome, H2Oerr / 37800*.FALSE. / ************************************************************************ PROGRAM supcrt PARAMETER (NPLOTF = 8) LOGICAL wetrun, unirun INTEGER reac, rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), *JP Added integer variable outflg is a runtime option switch to select *JP either standard output, or output formatted for post processing *JP into SOLTHERM records 1 outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE CALL banner CALL readin(nreac,wetrun,unirun) WRITE(wterm,10) 10 FORMAT(/,' execution in progress ... ',/) IF (wetrun) THEN WRITE(wterm,20) 20 FORMAT(' calculating H2O properties ...',/) CALL getH2O(unirun) END IF CALL tabtop DO 30 reac = 1,nreac WRITE(wterm,40) reac, nreac 40 FORMAT(' calculating properties for reaction ',i3, 1 ' of ',i3,' ...') CALL getmgi(reac) CALL wrtrxn(reac) 30 CALL runrxn(reac,wetrun) WRITE(wterm,50) 50 FORMAT(/,' ... execution completed.',/) END ******************************************************************** *** banner - Write program banner to the terminal screen. SUBROUTINE banner PARAMETER (NPLOTF = 8) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE WRITE(wterm,10) 10 FORMAT(/,5x, ' Welcome to SUPCRT92 Version 1.1', 1 /,5x, ' Author: James W. Johnson', 2 /,5x, ' Abandoned: 13 November 1991', + //,5x,' Modified 1996, Apr-May 2005, May 2008', + /,5x, ' This version of SUPCRT has been modified to', + /,5x, ' use the four-term heat capacity equation of', + /,5x, ' Holland and Powell, in addition to that of', + /,5x, ' Maier-Kelly, with the requisite DPRONS database.' + /,5x, ' Selected array dimensions have been increased.', + /,5x, ' Modifications by J. Palandri; call it V.1.96', + /,5x, ' Abandoned: 19 May 2005',/) END ******************************************************************** *** consts - Constants BLOCK DATA consts IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXISO = 21, MAXINC = 900, NPLOTF = 8) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 tempf, mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 rec1m1, rec1m2, rec1m3, rec1m4, rec1aa, rec1gg, 3 outflg DOUBLE PRECISION mwH2O, satmin(2) DOUBLE PRECISION dsvar(MAXINC,MAXISO), Vw(MAXINC,MAXISO), 1 bew(MAXINC,MAXISO), alw(MAXINC,MAXISO), 2 dalw(MAXINC,MAXISO), Sw(MAXINC,MAXISO), 3 Cpw(MAXINC,MAXISO), Hw(MAXINC,MAXISO), 4 Gw(MAXINC,MAXISO), Zw(MAXINC,MAXISO), 5 Qw(MAXINC,MAXISO), Yw(MAXINC,MAXISO), 6 Xw(MAXINC,MAXISO) LOGICAL lvdome(MAXINC,MAXISO), H2Oerr(MAXINC,MAXISO), 1 EQ3run, lv1bar CHARACTER*4 incvar(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /io2/ tempf COMMON /stvars/ isosat, isovar, incvar COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /headmp/ isov, incv, var3 COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /tranm2/ ntrm2 COMMON /aqscon/ eta, theta, psi, anion, cation, gref COMMON /qtzcon/ aa, ba, ca, VPtTta, VPrTtb, Stran COMMON /satend/ satmin COMMON /defval/ DPMIN, DPMAX, DPINC, DTMIN, DTMAX, DTINC, 1 DTSMIN, DTSMAX, DTSINC COMMON /null/ XNULLM, XNULLA COMMON /badtd/ lvdome, H2Oerr COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /EQ36/ EQ3run COMMON /lv1b/ lv1bar COMMON /H2Ogrd/ dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, 1 Zw, Qw, Yw, Xw COMMON /H2Oss/ Dwss, Vwss, bewss, alwss, dalwss, Swss, 1 Cpwss, Hwss, Gwss, Zwss, Qwss, Ywss, Xwss SAVE DATA EQ3run, lv1bar / 2*.FALSE. / *** 8 = NPLOTF DATA namepf / 8*' ' / *** 13*MAXISO*MAXINC = 245700 DATA dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, Zw, Qw, Yw, Xw *jp 1 / 81900*0.0d0 / 1 / 245700*0.0d0 / *** 2*MAXISO*MAXINC = 37800 *jp DATA lvdome, H2Oerr / 12600*.FALSE. / DATA lvdome, H2Oerr / 37800*.FALSE. / DATA Dwss, Vwss, bewss, alwss, dalwss, Swss, 1 Cpwss, Hwss, Gwss, Zwss, Qwss, Ywss, Xwss / 13*0.0d0 / DATA XNULLM, XNULLA / 999999.0d0, 999.0d0 / DATA DPMIN, DPMAX, DPINC / 500.0d0, 5000.0d0, 500.0d0 / DATA DTMIN, DTMAX, DTINC / 0.0d0, 1000.0d0, 100.0d0 / DATA DTSMIN, DTSMAX, DTSINC / 0.0d0, 350.0d0, 25.0d0 / DATA satmin / 0.01d0, 0.006117316772d0 / DATA aa, ba, ca / 0.549824d3, 0.65995d0, -0.4973d-4 / DATA VPtTta, VPrTtb, Stran / 0.23348d2, 0.2372d2, 0.342d0 / DATA eta, theta, psi / 0.166027d6, 0.228d3, 0.26d4 / DATA anion, cation, gref / 0.0d0, 0.94d0, 0.0d0 / DATA mwH2O, R / 18.0152d0, 1.9872d0 / DATA Pref, Tref / 0.1d1, 0.29815d3 / *** ZPrTr, YPrTr calculated in SUBR getH2O as f(epseqn) DATA rterm, wterm, iconf, reacf, pronf, tabf, tempf 1 / 5, 6, 40, 41, 42, 43, 44 / *** 8 = NPLOTF DATA plotf / 61, 62, 63, 64, 65, 66, 67, 68 / DATA isovar / 'CHORES(g/cc)', 'BARS(bars) ', 3*'THERMS(degC)', 1 'BARS(bars) ' / DATA incvar / 2*'TEMP', 'DENS' , 2*'PRES', 'TEMP' / DATA isosat / 'TEMP(degC)', 'PRES(bars)' / DATA isov / 'DH2O(g/cc)', 'PRES(bars)', 3*'TEMP(degC)', 1 'PRES(bars)' / DATA incv / 2*'TEMP(degC)', 'DH2O(g/cc)', 'PRES(bars)', 1 'PRES(bars)', 'TEMP(degC)' / DATA var3 / 'PRES(bars)', 'DH2O(g/cc)', 'PRES(bars)', 1 3*'DH2O(g/cc)' / DATA mapiso / 3, 2, 1, 1, 1, 2 / DATA mapinc / 1, 1, 3, 2, 2, 1 / DATA mapv3 / 2, 3, 2, 3, 4, 4 / END ************************************************************************ *** readin - Open user-specified, direct-access data file (STOP if none *** can be located); open/read or create[/store] an input file *** containing i/o specifications and state conditions; *** open/read line 1 of an existing file containing reaction *** titles and stoichiometries or create[/store] such a file *** in its entirety. SUBROUTINE readin(nreac,wetrun,unirun) LOGICAL wetrun, wetcon, wetrxn, unirun, getdf SAVE IF (.NOT. getdf()) STOP CALL getcon(wetcon,unirun) CALL getrxn(nreac,wetrxn) wetrun = (wetcon) .OR. (wetrxn) CALL getout END ************************************************************************ *** getdf - Returns .TRUE. if an appropriate direct-access *** data file can be opened; otherwise returns .FALSE. LOGICAL FUNCTION getdf() PARAMETER (MAXTRY = 5, NPLOTF = 8) CHARACTER*1 ans CHARACTER*20 pfname LOGICAL openf INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), try, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa, outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /dapron/ pfname SAVE 1 WRITE(wterm,10) 10 FORMAT(/,' would you like to use the default thermodynamic' 1 ,' database, dpronshp.dat? (y/n)',/) READ(rterm,20) ans 20 FORMAT(a1) IF ((ans .NE. 'y') .AND. (ans .NE. 'Y') .AND. 1 (ans .NE. 'n') .AND. (ans .NE. 'N')) THEN GO TO 1 END IF IF ((ans .EQ. 'y') .OR. (ans .EQ. 'Y')) THEN pfname = 'dpronshp.dat' ELSE WRITE(wterm,30) 30 FORMAT(/,' specify filename for thermodynamic database: ',/) READ(rterm,40) pfname 40 FORMAT(a20) END IF try = 0 *JP* 2 IF (openf(wterm,pronf,pfname,1,2,1,90)) THEN *JP* Change record length 90 to 104 to accomodate the fourth *JP* heat capacity coefficient. 2 IF (openf(wterm,pronf,pfname,1,2,1,104)) THEN READ(pronf,50,REC=1) nmin1, nmin2, nmin3, nmin4, 1 ngas, naqs * 50 FORMAT(6(1x,i4)) 50 FORMAT(6(i5)) READ(pronf,50,REC=2) rec1m1, rec1m2, rec1m3, rec1m4, 1 rec1gg, rec1aa getdf = .TRUE. RETURN ELSE try = try + 1 IF (try .LT. MAXTRY) THEN *** prompt for alternative file *** WRITE(wterm,60) pfname 60 FORMAT(/,' Cannot find ',a20, 1 /,' enter correct filename: ',/) READ(rterm,40) pfname GO TO 2 ELSE *** give up *** WRITE(wterm,70) 70 FORMAT(/,' I am tired of looking for this file;', 1 /,' please do the legwork yourself!', 2 //,' Bye for now ...',/) getdf = .FALSE. RETURN END IF END IF END ************************************************************************ *** getcon - Open/read or create[/store] an input (CON) file that *** contains i/o specifications and state conditions. SUBROUTINE getcon(wetcon,unirun) PARAMETER (NPLOTF = 8) LOGICAL wetcon, unirun INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE 1 WRITE(wterm,10) 10 FORMAT(/,' choose file option for specifying', 1 ' reaction-independent parameters: ', 1 /,' 1 = select one of three default files', 2 /,' 2 = select an existing non-default file', 3 /,' 3 = build a new file:',/) READ(rterm,*) ifopt IF ((ifopt .LT. 1) .OR. (ifopt .GT. 3)) GO TO 1 IF (ifopt .EQ. 1) THEN unirun = .FALSE. CALL defaul(wetcon) RETURN END IF IF (ifopt .EQ. 2) THEN CALL readcf(wetcon,unirun) ELSE CALL makecf(wetcon,unirun) END IF END ************************************************************************ *** defaul - Set default options / state conditions. SUBROUTINE defaul(wetcon) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, NPLOTF = 8) DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) INTEGER rterm, wterm, reacf, pronf, tabf, 1 plotf(NPLOTF), univar, useLVS, epseqn, geqn, 2 outflg LOGICAL wetcon, EQ3run, savecf, saverf COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /defval/ DPMIN, DPMAX, DPINC, DTMIN, DTMAX, DTINC, 1 DTSMIN, DTSMAX, DTSINC COMMON /EQ36/ EQ3run COMMON /saveif/ savecf, saverf SAVE univar = 0 noninc = 0 useLVS = 1 epseqn = 4 geqn = 3 EQ3run = .FALSE. savecf = .FALSE. ***** prompt for / read isat ***** 1 WRITE(wterm,10) 10 FORMAT(/,' input solvent phase region', 1 /,' 1 = one-phase region ', 2 /,' 2 = liq-vap saturation curve:', 3 /,' 3 = EQ3/6 one-phase/sat grid:',/) READ(rterm,*) isat IF ((isat .LT. 1) .OR. (isat .GT. 3)) THEN GO TO 1 ELSE isat = isat - 1 wetcon = (isat .EQ. 1) END IF IF (isat .EQ. 0) THEN iopt = 2 iplot = 1 isomin = DPMIN isomax = DPMAX isoinc = DPINC niso = 1 + NINT((isomax - isomin)/isoinc) v2min = DTMIN v2max = DTMAX v2inc = DTINC nv2 = 1 + NINT((v2max - v2min)/v2inc) RETURN END IF IF (isat .EQ. 1) THEN iopt = 1 iplot = 3 v2min = DTSMIN v2max = DTSMAX v2inc = DTSINC nv2 = 1 + NINT((v2max - v2min)/v2inc) isomin = 0.0d0 isomax = 0.0d0 isoinc = 0.0d0 niso = 1 RETURN END IF IF (isat .EQ. 2) THEN isat = 0 iopt = 2 iplot = 2 niso = 0 nv2 = 0 noninc = 8 EQ3run = .TRUE. oddv1(1) = 0.01d0 oddv1(2) = 25.00d0 oddv1(3) = 60.00d0 oddv1(4) = 100.00d0 oddv1(5) = 150.00d0 oddv1(6) = 200.00d0 oddv1(7) = 250.00d0 oddv1(8) = 300.00d0 oddv2(1) = 1.01322d0 oddv2(2) = 1.01322d0 oddv2(3) = 1.01322d0 oddv2(4) = 1.01322d0 oddv2(5) = 4.75717d0 oddv2(6) = 15.53650d0 oddv2(7) = 39.73649d0 oddv2(8) = 85.83784d0 RETURN END IF END ************************************************************************ *** readcf - Read options / state conditions (CON) file. SUBROUTINE readcf(wetcon,unirun) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXISO = 21, MAXINC = 900, MAXODD = 900, 1 NPLOTF = 8, TOL = 1.0d-6) CHARACTER*1 TP(2) CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) LOGICAL openf, wetcon, unirun, savecf, saverf DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 univar, useLVS, epseqn, geqn, outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /saveif/ savecf, saverf SAVE DATA TP / 'T', 'P' / 1 WRITE(wterm,10) 10 FORMAT(/,' specify file name:',/) READ(rterm,20) namecf 20 FORMAT(a20) IF (.NOT. openf(wterm,iconf,namecf,1,1,1,132)) GO TO 1 savecf = .TRUE. ***** skip first 4 comment lines READ(iconf,21) 21 FORMAT(///) ********************************************************** *** READ and hardwire statements for distribution version READ(iconf,*) isat, iopt, iplot, univar, noninc useLVS = 1 epseqn = 4 geqn = 3 *** READ statement for development version * READ(iconf,*) isat, iopt, iplot, univar, noninc, * 1 useLVS, epseqn, geqn ********************************************************** *** insert validity checker for /icon/ *** variables here if desired later wetcon = (isat .EQ. 1) .OR. (iopt .EQ. 1) unirun = (univar .EQ. 1) IF (noninc .NE. 0) THEN *** univar = 0 *** read non-incremental state conditions IF (noninc .GT. MAXODD) THEN WRITE(wterm,131) noninc, MAXODD WRITE(tabf,131) noninc, MAXODD 131 FORMAT(/,' Number of specified odd-increment pairs ' 1 ,'(',i3,') exceeds MAXODD (',i3,').', 2 /,' Revise specifications.') STOP END IF DO 30 i = 1,noninc IF (isat .EQ. 1) THEN READ(iconf,*) oddv1(i) ELSE READ(iconf,*) oddv1(i), oddv2(i) END IF 30 CONTINUE RETURN END IF IF (isat .EQ. 0) THEN READ(iconf,*) isomin, isomax, isoinc IF (isomin .EQ. isomax) THEN niso = 1 ELSE IF (isoinc .EQ. 0.0d0) THEN WRITE(wterm,935) WRITE(tabf,935) 935 FORMAT(/,' Ill-defined ', 1 ' min,max,increment trio',/, 2 ' Revise specifications.') STOP END IF fpniso = 1.0d0 + ((isomax - isomin)/isoinc) niso = NINT(fpniso) IF (DABS(fpniso-DBLE(niso)) .GT. TOL) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF END IF IF (niso .GT. MAXISO) THEN WRITE(wterm,31) niso, MAXISO WRITE(tabf,31) niso, MAXISO 31 FORMAT(/,' Number of specified isopleths (',i4,')' 1 ,' exceeds MAXISO (',i3,').', 2 /,' Revise specifications.') STOP END IF ELSE READ(iconf,*) v2min, v2max, v2inc IF (v2min .EQ. v2max) THEN nv2 = 1 ELSE IF (v2inc .EQ. 0.0d0) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF fpnv2 = 1.0d0 + ((v2max - v2min)/v2inc) nv2 = NINT(fpnv2) IF (DABS(fpnv2-DBLE(nv2)) .GT. TOL) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF END IF IF (nv2 .GT. MAXINC) THEN WRITE(wterm,32) nv2, MAXINC WRITE(tabf,32) nv2, MAXINC 32 FORMAT(/,' Number of specified increments ' 1 ,'(',i3,') exceeds MAXINC (',i3,').', 2 /,' Revise specifications.') STOP END IF niso = 1 isomin = 0.0d0 isomax = 0.0d0 isoinc = 0.0d0 RETURN END IF IF (univar .EQ. 1) THEN *** univariant curve option enabled READ(iconf,*) Kmin, Kmax, Kinc IF (Kmin .EQ. Kmax) THEN nlogK = 1 ELSE IF (Kinc .EQ. 0.0d0) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF fplK = 1.0d0 + ((Kmax - Kmin)/Kinc) nlogK = NINT(fplK) IF (DABS(fplK-DBLE(nlogK)) .GT. TOL) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF END IF READ(iconf,*) v2min, v2max IF (v2min .LT. v2max) THEN v2inc = 0.0d0 ELSE WRITE(wterm,152) TP(iplot), TP(iplot) 152 FORMAT(/,1x,a1,'min >= ',a1,'max ', 1 /,1x,' revise specifications') STOP END IF ELSE *** univariant curve option disabled READ(iconf,*) v2min, v2max, v2inc IF (v2min .EQ. v2max) THEN nv2 = 1 ELSE IF (v2inc .EQ. 0.0d0) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF fpnv2 = 1.0d0 + ((v2max - v2min)/v2inc) nv2 = NINT(fpnv2) IF (DABS(fpnv2-DBLE(nv2)) .GT. TOL) THEN WRITE(wterm,935) WRITE(tabf,935) STOP END IF END IF IF (nv2 .GT. MAXINC) THEN WRITE(wterm,32) nv2, MAXINC WRITE(tabf,32) nv2, MAXINC STOP END IF END IF END ************************************************************************ *** makecf - Prompt for and create options / state conditions *** (CON) file. SUBROUTINE makecf(wetcon,unirun) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXISO = 21, MAXINC = 900, MAXODD = 900, 1 NPLOTF = 8, TOL = 1.0d-6) CHARACTER*1 ptype2(2), TP(2), ans CHARACTER*4 incvar(2,3) CHARACTER*6 ptype1(2) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) LOGICAL openf, wetcon, unirun, savecf, saverf DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 univar, useLVS, epseqn, geqn, outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /stvars/ isosat, isovar, incvar COMMON /headmp/ isov, incv, var3 COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /saveif/ savecf, saverf SAVE DATA TP / 'T', 'P' / DATA ptype2 / 'D', 'P' / DATA ptype1 / 'CHORIC', 'BARIC ' / ***** prompt for / read isat ***** 1 WRITE(wterm,10) 10 FORMAT(/,' specify solvent phase region ', 1 /,' 1 = one-phase region ', 2 /,' 2 = liq-vap saturation curve:',/) READ(rterm,*) isat IF ((isat .NE. 1) .AND. (isat .NE. 2)) THEN GO TO 1 ELSE isat = isat - 1 END IF ***** prompt for / read iopt ***** 2 IF (isat .EQ. 0) THEN WRITE(wterm,20) 20 FORMAT(/,' specify independent state variables: ', 1 /,' 1 = temperature (degC), density[H2O] (g/cc) ', 2 /,' 2 = temperature (degC), pressure (bars)',/) ELSE WRITE(wterm,30) 30 FORMAT(/,' specify independent liq-vap saturation variable:', 1 /,' 1 = temperature (degC)', 2 /,' 2 = pressure (bars)',/) END IF READ(rterm,*) iopt IF ((iopt .NE. 1) .AND. (iopt .NE. 2)) GO TO 2 wetcon = (isat .EQ. 1) .OR. (iopt .EQ. 1) IF (isat .EQ. 1) THEN ***** saturation curve option enabled ***** ***** set univar and iplot ***** univar = 0 iplot = 3 ***** prompt for / read noninc ***** 3 WRITE(wterm,40) 40 FORMAT(/,' specify table-increment option: ', 1 /,' 1 = calculate tables having uniform increments', 2 /,' 2 = calculate tables having unequal increments',/) READ(rterm,*) noninc IF ((noninc .NE. 1) .AND. (noninc .NE. 2)) THEN GO TO 3 ELSE noninc = noninc - 1 IF (noninc .EQ. 0) THEN ***** prompt for / read state condition range along ***** the saturation curve curve isopleth 444 WRITE(wterm,50) isosat(iopt) 50 FORMAT(/,' specify ',a10, ' range:',/, 1 ' min, max, increment:' 1 ,/) READ(rterm,*) v2min, v2max, v2inc IF (v2max .GT. 373.917d0) THEN WRITE(wterm,899) v2max 899 FORMAT(/,' Maximum saturation temperature ', 1 '(',f4.0,') > critical temperature', 2 ' (373.917).', 3 /,' Revise specifications.') GO TO 444 END IF IF (v2min .EQ. v2max) THEN nv2 = 1 ELSE IF (v2inc .EQ. 0.0d0) THEN WRITE(wterm,935) 935 FORMAT(/,' Ill-defined ', 1 ' min,max,increment trio',/, 2 ' Revise specifications.') GO TO 444 END IF fpnv2 = 1.0d0 + ((v2max - v2min)/v2inc) nv2 = NINT(fpnv2) IF (DABS(fpnv2-DBLE(nv2)) .GT. TOL) THEN WRITE(wterm,935) GO TO 444 END IF IF (nv2 .GT. MAXINC) THEN WRITE(wterm,31) nv2, MAXINC 31 FORMAT(/,' Number of specified isopleths' 1 ,' (',i4,') exceeds MAXINC (',i3,').' 2 ,/,' Revise specifications.') GO TO 444 END IF END IF niso = 1 isomin = 0.0d0 isomax = 0.0d0 isoinc = 0.0d0 ELSE ***** prompt for / read [noninc] non-incremental state ***** ***** condition points along saturation curve ***** WRITE(wterm,60) isosat(iopt) 60 FORMAT(/,' specify liq-vap saturation ',a10, 1 ' values', 2 /,' one per line, concluding with a zero:',/) 4 READ(rterm,*) oddv1(noninc) IF ((oddv1(noninc) .NE. 0.0d0) .AND. 1 (noninc .LT. MAXODD)) THEN noninc = noninc + 1 GO TO 4 END IF IF (oddv1(noninc) .EQ. 0.0d0) THEN noninc = noninc - 1 ELSE WRITE(wterm,241) MAXODD 241 FORMAT(/,' Only ',i3,' coordinates separated', 1 ' by unequal increments',/,' can be', 2 ' processed during one SUPCRT92 execution',/) END IF END IF END IF ELSE ***** saturation curve option curve disabled ***** IF (iopt .EQ. 1) THEN univar = 0 ELSE ***** prompt for / read univar ***** 5 WRITE(wterm,70) 70 FORMAT(/,' would you like to use the univariant curve', 1 ' option;', 2 /,' i.e., calculate T(logK,P) or P(logK,T) ', 3 ' (y/n)',/) READ(rterm,75) ans 75 FORMAT(a1) IF ((ans .NE. 'y') .AND. (ans .NE. 'Y') .AND. 1 (ans .NE. 'n') .AND. (ans .NE. 'N')) THEN GO TO 5 END IF IF ((ans .EQ. 'y') .OR. (ans .EQ. 'Y')) THEN univar = 1 ELSE univar = 0 END IF END IF IF (univar .EQ. 0) THEN ***** univariant curve option disabled ***** ***** prompt for / read iplot ***** 6 WRITE(wterm,80) ptype1(iopt), ptype2(iopt) 80 FORMAT(/,' specify tablulation option:', 1 /,' 1 = calculate ISO',a6,'(T) tables, ', 2 /,' 2 = calculate ISOTHERMAL(',a1,') ', 3 'tables ',/) READ(rterm,*) iplot IF ((iplot .NE. 1) .AND. (iplot .NE. 2)) THEN GO TO 6 END IF ***** prompt for / read noninc ***** 7 WRITE(wterm,40) READ(rterm,*) noninc IF ((noninc .NE. 1) .AND. (noninc .NE. 2)) THEN GO TO 7 ELSE noninc = noninc - 1 END IF IF (noninc .EQ. 0) THEN ***** prompt for / read state condition ranges in one-phase region ***** 445 WRITE(wterm,100) isovar(iopt,iplot) 100 FORMAT(/,' specify ISO',a12, 1 /,' min, max, increment',/) READ(rterm,*) isomin, isomax, isoinc IF (isomin .EQ. isomax) THEN niso = 1 ELSE IF (isoinc .EQ. 0.0d0) THEN WRITE(wterm,935) GO TO 445 END IF fpniso = 1.0d0 + ((isomax - isomin)/isoinc) niso = NINT(fpniso) IF (DABS(fpniso-DBLE(niso)) .GT. TOL) THEN WRITE(wterm,935) GO TO 445 END IF END IF IF (niso .GT. MAXISO) THEN WRITE(wterm,31) niso, MAXISO GO TO 445 END IF 446 WRITE(wterm,110) incv(iopt,iplot) 110 FORMAT(/,' specify ',a10,' range', 1 /,' min, max, increment',/) READ(rterm,*) v2min, v2max, v2inc IF (v2min .EQ. v2max) THEN nv2 = 1 ELSE IF (v2inc .EQ. 0.0d0) THEN WRITE(wterm,935) GO TO 446 END IF fpnv2 = 1.0d0 + ((v2max - v2min)/v2inc) nv2 = NINT(fpnv2) IF (DABS(fpnv2-DBLE(nv2)) .GT. TOL) THEN WRITE(wterm,935) GO TO 446 END IF END IF IF (nv2 .GT. MAXINC) THEN WRITE(wterm,32) nv2, MAXINC 32 FORMAT(/,' Number of specified increments' 1 ,' (',i4,') exceeds MAXINC (',i3,').', 2 /,' Revise specifications.') GO TO 446 END IF ELSE ***** prompt for / read [noninc] non-incremental state ***** ***** condition points in the one-phase region ***** WRITE(wterm,120) isov(iopt,iplot), incv(iopt,iplot) 120 FORMAT(/,' specify ',a10,', ',a10,' values; ', 1 /,' one pair per line, concluding with 0,0:',/) 8 READ(rterm,*) oddv1(noninc), oddv2(noninc) IF ((oddv1(noninc) .NE. 0.0d0) .AND. 1 (noninc .LT. MAXODD)) THEN noninc = noninc + 1 GO TO 8 END IF IF (oddv1(noninc) .EQ. 0.0d0) THEN noninc = noninc - 1 ELSE WRITE(wterm,241) END IF END IF ELSE ***** univariant curve option enabled ***** ***** set noninc ***** noninc = 0 ***** prompt for / read iplot ***** 9 WRITE(wterm,130) 130 FORMAT(/,' specify univariant calculation option:', 1 /,' 1 = calculate T(logK,isobars), ', 2 /,' 2 = calculate P(logK,isotherms): ',/) READ(rterm,*) iplot IF ((iplot .NE. 1) .AND. (iplot .NE. 2)) THEN GO TO 9 END IF ***** prompt for / read state condition ranges in one-phase region ***** 447 WRITE(wterm,140) isovar(iopt,iplot) 140 FORMAT(/,' specify ISO',a12, 1 /,' min, max, increment ',/) READ(rterm,*) isomin, isomax, isoinc IF (isomin .EQ. isomax) THEN niso = 1 ELSE IF (isoinc .EQ. 0.0d0) THEN WRITE(wterm,935) GO TO 447 END IF fpniso = 1.0d0 + ((isomax - isomin)/isoinc) niso = NINT(fpniso) IF (DABS(fpniso-DBLE(niso)) .GT. TOL) THEN WRITE(wterm,935) GO TO 447 END IF END IF IF (niso .GT. MAXISO) THEN WRITE(wterm,31) niso, MAXISO GO TO 447 END IF 448 WRITE(wterm,150) 150 FORMAT(/,' specify logK range: ', 1 /,' Kmin, Kmax, Kincrement: ',/) READ(rterm,*) Kmin, Kmax, Kinc IF (Kmin .EQ. Kmax) THEN nlogK = 1 ELSE IF (Kinc .EQ. 0.0d0) THEN WRITE(wterm,935) GO TO 448 END IF fpnK = 1.0d0 + ((Kmax - Kmin)/Kinc) nlogK = NINT(fpnK) IF (DABS(fpnK-DBLE(nlogK)) .GT. TOL) THEN WRITE(wterm,935) GO TO 448 END IF END IF 449 WRITE(wterm,151) incv(iopt,iplot), 1 TP(iplot), TP(iplot) 151 FORMAT(/,' specify bounding ',a10,' range:', 1 /,1x,a1,'min, ',a1,'max: ',/) READ(rterm,*) v2min, v2max IF (v2min .LT. v2max) THEN v2inc = 0.0d0 ELSE WRITE(wterm,152) TP(iplot), TP(iplot) 152 FORMAT(/,1x,a1,'min >= ',a1,'max ', 1 /,1x,' revise specifications') GO TO 449 END IF END IF END IF *************************************************************** *** variable assignments for distribution version useLVS = 1 epseqn = 4 geqn = 3 *** select equation options for development version * CALL geteqn(useLVS,epseqn,geqn) *************************************************************** ***** set unirun ****** unirun = (univar .EQ. 1) ***** write input parameters to new file if desired ***** 16 WRITE(wterm,210) 210 FORMAT(/,' would you like to save these reaction-independent', 1 /,' parameters to a file (y/n):',/) READ(rterm,75) ans IF ((ans .NE. 'y') .AND. (ans .NE. 'Y') .AND. 1 (ans .NE. 'n') .AND. (ans .NE. 'N')) GO TO 16 savecf = ((ans .EQ. 'y') .OR. (ans .EQ. 'Y')) IF (savecf) THEN 17 WRITE(wterm,230) 230 FORMAT(/,' specify file name:',/) READ(rterm,240) namecf 240 FORMAT(a20) IF (.NOT. openf(wterm,iconf,namecf,2,1,1,132)) THEN GO TO 17 END IF ****************************************************************** WRITE(iconf,250) *** statement 250 for distribution versions 250 FORMAT(' Line 1 (free format):', 1 ' isat, iopt, iplot, univar, noninc') *** statement 250 for development versions *250 FORMAT(' Line 1 (free format): isat, iopt, iplot,', * 1 ' univar, noninc, useLVS, epseqn, geqn') ****************************************************************** IF (noninc .EQ. 0) THEN IF (isat .EQ. 1) THEN WRITE(iconf,251) 251 FORMAT(' Line 2 (free format): v2min, v2max, v2inc') WRITE(iconf,256) 256 FORMAT(66('*')) ELSE WRITE(iconf,249) 249 FORMAT(' Line 2 (free format): isomin, isomax, isoinc') END IF ELSE IF (isat .EQ. 1) THEN WRITE(iconf,252) noninc + 1 252 FORMAT(' Lines i=2..',i3, 1 ' (free format): oddv1(i)') ELSE WRITE(iconf,253) noninc + 1 253 FORMAT(' Lines i=2..',i3, 1 ' (free format): oddv1(i), oddv2(i)') END IF WRITE(iconf,256) END IF IF ((isat .EQ. 0) .AND. (noninc .EQ. 0)) THEN IF (univar .EQ. 0) THEN WRITE(iconf,254) 254 FORMAT(' Line 3 (free format):', 1 ' v2min, v2max, v2inc') ELSE WRITE(iconf,255) 255 FORMAT(' Line 3 (free format):', 1 ' Kmin, Kmax, Kinc') WRITE(iconf,259) 259 FORMAT(' Line 4 (free format):', 1 ' v2min, v2max') END IF END IF IF (univar .EQ. 0) THEN WRITE(iconf,256) END IF ************************************************************* *** WRITE statement for distribution version WRITE(iconf,350) isat, iopt, iplot, univar, noninc 350 FORMAT(5(1x,i3)) *** WRITE statement for development version * WRITE(iconf,350) isat, iopt, iplot, univar, noninc, * 1 useLVS, epseqn, geqn *350 FORMAT(8(1x,i3)) ************************************************************* IF (noninc .EQ. 0) THEN IF (isat .EQ. 1) THEN WRITE(iconf,*) v2min, v2max, v2inc ELSE WRITE(iconf,*) isomin, isomax, isoinc END IF ELSE DO 360 i = 1,noninc IF (isat .EQ. 1) THEN WRITE(iconf,*) oddv1(i) ELSE WRITE(iconf,*) oddv1(i), oddv2(i) END IF 360 CONTINUE END IF IF ((isat .EQ. 0) .AND. (noninc .EQ. 0)) THEN IF (univar .EQ. 0) THEN WRITE(iconf,*) v2min, v2max, v2inc ELSE WRITE(iconf,*) Kmin, Kmax, Kinc WRITE(iconf,*) v2min, v2max END IF END IF END IF END ************************************************************************ *** geteqn - prompt for / read useLVS, epseqn, geqn. SUBROUTINE geteqn(useLVS,epseqn,geqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8) CHARACTER*1 ans INTEGER useLVS, epseqn, geqn, rterm, wterm, reacf, 1 pronf, tabf, plotf(NPLOTF), outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE 11 WRITE(wterm,160) 160 FORMAT(/,' would you like to use the Levelt Sengers et al. (1983)' 1 ,/,' equation of state for H2O in the critical region (y/n)' 2 ,/) READ(rterm,165) ans 165 FORMAT(a1) IF ((ans .NE. 'y') .AND. (ans .NE. 'Y') .AND. 1 (ans .NE. 'n') .AND. (ans .NE. 'N')) GO TO 11 IF ((ans .EQ. 'y') .OR. (ans .EQ. 'Y')) THEN useLVS = 1 ELSE useLVS = 0 END IF 12 WRITE(wterm,170) 170 FORMAT(/,' specify dielectric option: ', 1 /,' 1 = use Helgeson-Kirkham (1974) equation', 2 /,' 2 = use Pitzer (1983) equation', 3 /,' 3 = use Uematsu-Franck (1980) equation', 4 /,' 4 = use Johnson-Norton (1991) equation', 5 /,' 5 = use Archer-Wang (1990) equation',/) READ(rterm,*) epseqn IF ((epseqn .LT. 1) .OR. (epseqn .GT. 5)) GO TO 12 13 WRITE(wterm,180) 180 FORMAT(/,' specify g-function option', 1 /,' 1 = use Tanger-Helgeson (1988) equation', 2 /,' 2 = use Shock et al. (in prep.) equation', 3 /,' 3 = use modified Shock et al. equation',/) READ(rterm,*) geqn IF ((geqn .LT. 1) .OR. (geqn .GT. 3)) GO TO 13 END ************************************************************************ *** getrxn - Open and read an existing reaction (RXN) file or *** prompt for, create, [and save] a new reaction file. SUBROUTINE getrxn(nreac,wetrxn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8) LOGICAL wetrxn INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE 1 WRITE(wterm,10) 10 FORMAT(/,' choose file option for specifying reactions ', 1 /,' 1 = use an existing reaction file', 2 /,' 2 = build a new reaction file:',/) READ(rterm,*) ifopt IF ((ifopt .NE. 1) .AND. (ifopt .NE. 2)) GO TO 1 IF (ifopt .EQ. 1) THEN CALL readrf(nreac,wetrxn) ELSE CALL makerf(nreac,wetrxn) END IF END ******************************************************************** *** parse - If the first non-blank substring of the input character *** string (chrstr) represents a valid integer or *** non-exponential floating-point number, parse returns *** .TRUE. and converts this first substring into the *** corresponding real number (r8num), then transfers the *** second such subset into a CHAR*20 variable (name); *** otherwise, parse returns .FALSE. LOGICAL FUNCTION parse(chrstr,r8num,name) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXLEN = 20) CHARACTER*(*) chrstr CHARACTER*20 numstr, name LOGICAL sign, deci INTEGER chrlen, tempf COMMON /io2/ tempf SAVE *** calculate length of chrstr *** chrlen = LEN(chrstr) *** read through leading blanks *** nblank = 0 DO 10 i = 1,chrlen IF (chrstr(i:i) .EQ. ' ') THEN nblank = nblank + 1 ELSE GO TO 2 END IF 10 CONTINUE *** initialize local variables *** 2 sign = .FALSE. deci = .FALSE. *** extract numerical string (integer or *** non-exponentiated floating-point numbers only) numlen = 0 DO 20 i = nblank+1,chrlen IF (chrstr(i:i) .EQ. ' ') THEN IF (((numlen .EQ. 1) .AND. (sign .OR. deci)) .OR. 1 ((numlen .EQ. 2) .AND. (sign .AND. deci))) THEN parse = .FALSE. RETURN ELSE *** valid integer or non-exponentiated floating-point *** number has been read; pad numerical string with blanks; *** read numerical numerical character string numstr into *** real*8 variable r8num; jump below to read in name. parse = .TRUE. DO 30 j = numlen+1,MAXLEN numstr(j:j) = ' ' 30 CONTINUE *** the following CHARACTER-to-DOUBLE PRECISION conversion is acceptable *** to most compilers ... but not all * READ(numstr,*) r8num *** hence, portability considerations require use of the following *** procedure, which is equivalent and universally acceptable *** ... albeit ugly OPEN(UNIT=tempf,FILE='zero.dat') WRITE(tempf,*) numstr BACKSPACE(tempf) READ(tempf,*) r8num CLOSE(UNIT=tempf) GO TO 3 END IF END IF IF ((chrstr(i:i) .EQ. '-') .OR. (chrstr(i:i) .EQ. '+')) THEN IF ((.NOT. sign) .AND. (numlen .EQ. 0)) THEN sign = .TRUE. numlen = numlen + 1 numstr(numlen:numlen) = chrstr(i:i) ELSE parse = .FALSE. RETURN END IF ELSE IF (chrstr(i:i) .EQ. '.') THEN IF (.NOT. deci) THEN deci = .TRUE. numlen = numlen + 1 numstr(numlen:numlen) = chrstr(i:i) ELSE parse = .FALSE. RETURN END IF ELSE IF ((chrstr(i:i) .GE. '0') .AND. 1 (chrstr(i:i) .LE. '9')) THEN numlen = numlen + 1 numstr(numlen:numlen) = chrstr(i:i) ELSE parse = .FALSE. RETURN END IF 20 CONTINUE *** read through blanks that separate the *** number string from the name string 3 DO 40 name1 = nblank+numlen+1,chrlen IF (chrstr(name1:name1) .NE. ' ') GO TO 4 40 CONTINUE *** transfer non-blank substring beginning *** at chrstr(name1:name1) into name 4 j = 0 DO 50 i = name1,chrlen IF (chrstr(i:i) .NE. ' ') THEN j = j + 1 name(j:j) = chrstr(i:i) ELSE IF (j .NE. 0) THEN *** valid non-blank substring has been read into *** CHAR*20 variable name; pad name with blanks; *** return GO TO 5 ELSE parse = .FALSE. RETURN END IF END IF 50 CONTINUE 5 DO 60 i = j+1,MAXLEN name(i:i) = ' ' 60 CONTINUE RETURN END ************************************************************************ *** getout - Prompt for and read names for output files. SUBROUTINE getout PARAMETER (NPLOTF = 8) LOGICAL openf, EQ3run CHARACTER*4 suffx(NPLOTF) CHARACTER*13 prefx2 CHARACTER*16 prefx1 CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 univar, useLVS, epseqn, geqn, xyplot, end, outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /plottr/ xyplot, end, nplots COMMON /EQ36/ EQ3run SAVE DATA suffx / '.kxy', '.gxy', '.hxy', '.sxy', 1 '.cxy', '.vxy', '.dxy', '.2xy' / 1 WRITE(wterm,10) 10 FORMAT(/,' specify name for tabulated output file:',/) READ(rterm,20) nametf 20 FORMAT(a20) IF (.NOT. openf(wterm,tabf,nametf,2,1,1,132)) THEN GO TO 1 END IF *JP___________ OUTFLG = 1 22 WRITE (wterm,25) 25 FORMAT (/,' specify option for tabulated output file:' 1 /,' 1 = Normal output' 2 /,' 2 = T, P, logK, DG, DH, and DS only',/) READ (*,*) OUTFLG IF ((OUTFLG.NE.1) .AND. (OUTFLG.NE.2)) GOTO 22 *JP___________ IF ((noninc .GT. 0) .AND. (.NOT. EQ3run)) THEN xyplot = 0 RETURN ELSE 2 WRITE(wterm,30) 30 FORMAT(/,' specify option for x-y plot files:', 1 /,' logK, G, H, S, Cp, and V of reaction: ', 1 /,' 1 = do not generate plot files ', 2 /,' 2 = generate plot files in generic format', 3 /,' 3 = generate plot files in KaleidaGraph format',/) READ(rterm,*) xyplot IF ((xyplot .LT. 1) .OR. (xyplot .GT. 3)) THEN GO TO 2 ELSE xyplot = xyplot - 1 END IF END IF IF (xyplot .EQ. 0) RETURN IF (xyplot .EQ. 1) THEN IF (EQ3run) THEN nplots = NPLOTF ELSE IF (univar .EQ. 1) THEN nplots = 1 ELSE nplots = (NPLOTF-1)+isat END IF END IF IF (univar .EQ. 1) THEN WRITE(wterm,35) 35 FORMAT(/,' specify prefix for name of x-y plot file;', 1 /,' suffix will be ".uxy"',/) ELSE WRITE(wterm,40) 40 FORMAT(/,' specify prefix for names of x-y plot files;', 1 /,' suffix will be ".[d,[2],k,g,h,s,c,v]xy"',/) END IF READ(rterm,50) prefx1 50 FORMAT(a16) DO 60 i = 1,LEN(prefx1) IF (prefx1(i:i) .EQ. ' ') THEN end = i-1 GO TO 65 END IF 60 CONTINUE 65 IF (univar .EQ. 1) THEN namepf(1)(1:end) = prefx1(1:end) namepf(1)(end+1:end+4) = '.uxy' ELSE DO 70 i = 1,nplots namepf(i)(1:end) = prefx1(1:end) namepf(i)(end+1:end+4) = suffx(i) 70 CONTINUE END IF RETURN END IF *** xyplot = 2 IF ((isat .EQ. 1) .OR. EQ3run) THEN nplots = 1 WRITE(wterm,80) 80 FORMAT(/,' specify prefix for names of x-y plot files;', 1 /,' suffix will be "R#.axy"',/) READ(rterm,90) prefx2 90 FORMAT(a13) ELSE IF (univar .EQ. 1) THEN nplots = 1 WRITE(wterm,100) 100 FORMAT(/,' specify prefix for names of x-y plot files;', 1 /,' suffix will be "R#.uxy"',/) READ(rterm,90) prefx2 ELSE nplots = NPLOTF-1 WRITE(wterm,110) 110 FORMAT(/,' specify prefix for names of x-y plot files;', 1 /,' suffix will be "R#.[d,[2],k,g,h,s,c,v]xy"',/) READ(rterm,90) prefx2 END IF END IF DO 120 i = 1,LEN(prefx2) IF (prefx2(i:i) .EQ. ' ') THEN end = i-1 GO TO 125 END IF 120 CONTINUE 125 IF ((isat .EQ. 1) .OR. EQ3run) THEN namepf(1)(1:end) = prefx2(1:end) namepf(1)(end+1:end+3) = 'R01' namepf(1)(end+4:end+7) = '.axy' RETURN END IF IF (univar .EQ. 1) THEN namepf(1)(1:end) = prefx2(1:end) namepf(1)(end+1:end+3) = 'R01' namepf(1)(end+4:end+7) = '.uxy' RETURN END IF DO 130 i = 1,nplots namepf(i)(1:end) = prefx2(1:end) namepf(i)(end+1:end+3) = 'R01' namepf(i)(end+4:end+7) = suffx(i) 130 CONTINUE END ************************************************************************ *** getH2O - Calculate/store requisite H2O properties over the *** user-specified state condition grid. SUBROUTINE getH2O(unirun) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP2 = 46) LOGICAL unirun, error INTEGER univar, useLVS, epseqn, geqn, specs(10) DOUBLE PRECISION states(4), props(NPROP2), mwH2O COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn SAVE DATA specs / 2,2,2,5,1,0,0,0,0,0 / DATA states / 4*0.0d0 / specs(8) = useLVS specs(9) = epseqn ***************************************************************** *** assignment of [Z,Y]PrTr to Johnson-Norton (1991) *** values for distribution version ZPrTr = -0.1278034682d-1 YPrTr = -0.5798650444d-4 *** set ZPrTr and YPrTR per espeqn value for development version * CALL seteps(Tref-273.15d0,Pref,epseqn,ZPrTr,YPrTr) ***************************************************************** ***** calculate H2O properties at standard state of 25 degC, 1 bar states(1) = Tref-273.15d0 states(2) = Pref specs(6) = 0 specs(7) = 2 CALL H2O92(specs,states,props,error) CALL H2Ostd(states,props) IF (unirun) RETURN IF (noninc .GT. 0) THEN CALL oddH2O RETURN END IF IF (isat .EQ. 0) THEN CALL oneH2O ELSE CALL twoH2O END IF END ************************************************************************ *** oddH2O - Calculate/store requisite H2O properties over the *** user-specified set of state conditions. SUBROUTINE oddH2O IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, MAXINC = 900, MAXISO = 21, NPROP2 = 46) LOGICAL error, lvdome(MAXINC,MAXISO), 1 H2Oerr(MAXINC,MAXISO), EQ3run INTEGER mapiso(2,3), mapinc(2,3), mapv3(2,3), 1 univar, useLVS, epseqn, geqn, specs(10) DOUBLE PRECISION states(4), props(NPROP2), 1 isomin, isomax, isoinc, Kmin, Kmax, Kinc, 2 oddv1(MAXODD), oddv2(MAXODD) COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /badtd/ lvdome, H2Oerr COMMON /EQ36/ EQ3run SAVE DATA specs / 2,2,2,5,1,0,0,0,0,0 / DATA states / 4*0.0d0 / specs(6) = isat specs(7) = iopt specs(8) = useLVS specs(9) = epseqn DO 30 iodd = 1,noninc states(mapiso(iopt,iplot)) = oddv1(iodd) IF (isat .EQ. 0) THEN states(mapinc(iopt,iplot)) = oddv2(iodd) END IF CALL H2O92(specs,states,props,error) H2Oerr(iodd,1) = error IF (.NOT. error) THEN lvdome(iodd,1) = ((iplot .NE. 3) .AND. 1 (specs(6) .EQ. 1) .AND. 2 (.NOT. EQ3run)) IF (lvdome(iodd,1)) THEN specs(6) = 0 ELSE IF (EQ3run .AND. (specs(6) .EQ. 1)) THEN isat = 1 specs(7) = 1 END IF CALL H2Osav(iodd,1,states,props) END IF END IF 30 CONTINUE IF (EQ3run) isat = 0 END ************************************************************************ *** oneH2O - Calculate/store requisite H2O properties over the *** user-specified state condition grid in the *** one-phase region. SUBROUTINE oneH2O IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, MAXINC = 900, MAXISO = 21, NPROP2 = 46) LOGICAL error, lvdome(MAXINC,MAXISO), H2Oerr(MAXINC,MAXISO) INTEGER mapiso(2,3), mapinc(2,3), mapv3(2,3), 1 univar, useLVS, epseqn, geqn, specs(10) DOUBLE PRECISION states(4), props(NPROP2), 1 isomin, isomax, isoinc, Kmin, Kmax, Kinc, 2 oddv1(MAXODD), oddv2(MAXODD) COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /badtd/ lvdome, H2Oerr SAVE DATA specs / 2,2,2,5,1,0,0,0,0,0 / DATA states / 4*0.0d0 / specs(6) = isat specs(7) = iopt specs(8) = useLVS specs(9) = epseqn DO 10 iso = 1,niso states(mapiso(iopt,iplot)) = isomin + (iso-1)*isoinc DO 10 inc = 1,nv2 specs(6) = isat specs(7) = iopt states(mapinc(iopt,iplot)) = v2min + (inc-1)*v2inc CALL H2O92(specs,states,props,error) H2Oerr(inc,iso) = error IF (error) THEN states(mapiso(iopt,iplot)) = isomin + 1 (iso-1)*isoinc ELSE lvdome(inc,iso) = (specs(6) .EQ. 1) IF (lvdome(inc,iso)) THEN specs(6) = 0 states(mapiso(iopt,iplot)) = 1 isomin + (iso-1)*isoinc ELSE CALL H2Osav(inc,iso,states,props) END IF END IF 10 CONTINUE END ************************************************************************ *** twoH2O - Calculate/store requisite H2O properties over the *** user-specified state condition grid along the *** vaporization boundary. SUBROUTINE twoH2O IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, MAXINC = 900, MAXISO = 21, NPROP2 = 46) PARAMETER (TS1BAR = 99.6324d0) LOGICAL error, lvdome(MAXINC,MAXISO), 1 H2Oerr(MAXINC,MAXISO), lv1bar INTEGER mapiso(2,3), mapinc(2,3), mapv3(2,3), 1 univar, useLVS, epseqn, geqn, specs(10) DOUBLE PRECISION states(4), props(NPROP2), mwH2O, satmin(2), 1 isomin, isomax, isoinc, Kmin, Kmax, Kinc, 2 oddv1(MAXODD), oddv2(MAXODD) COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /satend/ satmin COMMON /badtd/ lvdome, H2Oerr COMMON /lv1b/ lv1bar SAVE DATA specs / 2,2,2,5,1,0,0,0,0,0 / DATA states / 4*0.0d0 / specs(6) = isat specs(7) = iopt specs(8) = useLVS specs(9) = epseqn lv1bar = (iopt .EQ. 1) .AND. (v2min .LE. TS1BAR) DO 10 inc = 1,nv2 IF ((inc .EQ. 1) .AND. (v2min. EQ. 0.0d0)) THEN states(mapiso(iopt,iplot)) = satmin(iopt) ELSE states(mapiso(iopt,iplot)) = v2min+(inc-1)*v2inc END IF IF (lv1bar .AND. (states(mapiso(iopt,iplot)) 1 .LE. TS1BAR)) THEN isat = 0 specs(6) = 0 specs(7) = 2 states(2) = Pref ELSE IF (lv1bar) THEN isat = 1 END IF specs(6) = isat specs(7) = iopt END IF CALL H2O92(specs,states,props,error) H2Oerr(inc,1) = error IF (.NOT. error) CALL H2Osav(inc,1,states,props) 10 CONTINUE END ************************************************************************ *** seteps - Set ZPrTr and YPrTR per espeqn value. SUBROUTINE seteps(TCref,Pref,epseqn,ZPrTr,YPrTr) IMPLICIT DOUBLE PRECISION (a-h,o-z) LOGICAL error INTEGER epseqn, specs(10) DOUBLE PRECISION states(4), props(46) SAVE DATA specs / 2,2,2,5,1,0,2,0,0,0 / specs(9) = epseqn states(1) = TCref states(2) = Pref states(3) = 0.0d0 CALL H2O92(specs,states,props,error) ZPrTr = props(37) YPrTr = props(39) END ************************************************************************ *** H2Ostd - Archive requisite H2O properties for the *** standard state of 25 degC, 1 bar. SUBROUTINE H2Ostd(states,props) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP2 = 46) INTEGER A, G, S, U, H, Cv, Cp, vs, al, be, 1 di, vi, tc, st, td, Pr, vik, albe, 2 Z, Y, Q, daldT, X DOUBLE PRECISION states(4), props(NPROP2), mwH2O DOUBLE PRECISION Dwss, Vwss, bewss, alwss, dalwss, Swss, 1 Cpwss, Hwss, Gwss, Zwss, Qwss, Ywss, Xwss COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /H2Oss/ Dwss, Vwss, bewss, alwss, dalwss, Swss, 1 Cpwss, Hwss, Gwss, Zwss, Qwss, Ywss, Xwss SAVE DATA A, G, S, U, H, Cv, Cp, vs, al, be, di, vi, 1 tc, st, td, Pr, vik, albe, Z, Y, Q, daldT, X 2 / 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 3 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45 / *** archive requisite properties *** Dwss = states(3) Vwss = mwH2O/states(3) bewss = props(be) alwss = props(al) dalwss = props(daldT) Swss = props(S) Cpwss = props(Cp) Hwss = props(H) Gwss = props(G) Zwss = props(Z) Qwss = props(Q) Ywss = props(Y) Xwss = props(X) END ************************************************************************ *** H2Osav - Archive requisite H2O properties over the *** user-specified state condition grid. SUBROUTINE H2Osav(row,col,states,props) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP2 = 46, MAXINC = 900, MAXISO = 21) LOGICAL EQ3run, lv1bar INTEGER row, col INTEGER mapiso(2,3), mapinc(2,3), mapv3(2,3), 1 univar, useLVS, epseqn, geqn INTEGER A, G, S, U, H, Cv, Cp, vs, al, be, 1 di, vi, tc, st, td, Pr, vik, albe, 2 Z, Y, Q, daldT, X DOUBLE PRECISION states(4), props(NPROP2), mwH2O DOUBLE PRECISION dsvar(MAXINC,MAXISO), Vw(MAXINC,MAXISO), 1 bew(MAXINC,MAXISO), alw(MAXINC,MAXISO), 2 dalw(MAXINC,MAXISO), Sw(MAXINC,MAXISO), 3 Cpw(MAXINC,MAXISO), Hw(MAXINC,MAXISO), 4 Gw(MAXINC,MAXISO), Zw(MAXINC,MAXISO), 5 Qw(MAXINC,MAXISO), Yw(MAXINC,MAXISO), 6 Xw(MAXINC,MAXISO) COMMON /EQ36/ EQ3run COMMON /lv1b/ lv1bar COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /H2Ogrd/ dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, 1 Zw, Qw, Yw, Xw SAVE DATA A, G, S, U, H, Cv, Cp, vs, al, be, di, vi, 1 tc, st, td, Pr, vik, albe, Z, Y, Q, daldT, X 2 / 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 3 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45 / *** archive dependent state variables *** IF (isat .EQ. 1) THEN IF (EQ3run) THEN dsvar(row,col) = states(4) ELSE dsvar(row,col) = states(2/iopt) END IF ELSE IF (lv1bar) THEN dsvar(row,col) = states(2) ELSE dsvar(row,col) = states(mapv3(iopt,iplot)) END IF END IF *** archive requisite properties *** Vw(row,col) = mwH2O/states(3+isat) bew(row,col) = props(be+isat) alw(row,col) = props(al+isat) dalw(row,col) = props(daldT+isat) Sw(row,col) = props(S+isat) Cpw(row,col) = props(Cp+isat) Hw(row,col) = props(H+isat) Gw(row,col) = props(G+isat) Zw(row,col) = props(Z+isat) Qw(row,col) = props(Q+isat) Yw(row,col) = props(Y+isat) Xw(row,col) = props(X+isat) END ************************************************************************ *** getmgi - Read standard state properties, equation of state *** parameters, and heat capacity coefficients for all *** mineral, gas, and aqueous species in the current *** reaction. SUBROUTINE getmgi(ireac) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, MAXRXN = 800) CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN) INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac SAVE *** retrieve thermodynamic data for minerals DO 10 i = 1,nm(ireac) CALL getmin(i,rec1m(ireac,i)) 10 CONTINUE *** retrieve thermodynamic data for gases DO 20 i = 1,ng(ireac) CALL getgas(i,rec1g(ireac,i)) 20 CONTINUE *** retrieve thermodynamic data for aqueous species DO 30 i = 1,na(ireac) CALL getaqs(i,rec1a(ireac,i)) 30 CONTINUE END ************************************************************************ *** getmin - Read, from dprons.dat or an analogous database (starting *** at record rec1), standard state parameters for the i[th] *** one-phase mineral species in the current reaction; *** set ntran(i) to zero. SUBROUTINE getmin(i,rec1) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4, MAXMK = 4, 1 NPLOTF = 8) INTEGER rec1, ntran(MAXMIN) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa, 2 outflg CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN), mnform, aqform DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN), mvolum COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran **JP* Add mvolum, mnform, aqform for post-processing to make Soltherm records. Common /solth1/ mvolum Common /solth2/ mnform, aqform SAVE mnform(1:30) = ' ' mvolum = 0.0 **JP* following 4 statements added to allow additional heat capacity coef d. **JP* Need to reset to zero when used by minerals that don't use d. MK1(4,i)=0. MK2(4,i)=0. MK3(4,i)=0. MK4(4,i)=0. IF (rec1 .LT. rec1m2) THEN ntran(i) = 0 GO TO 1 END IF IF (rec1 .LT. rec1m3) THEN ntran(i) = 1 GO TO 1 END IF IF (rec1 .LT. rec1m4) THEN ntran(i) = 2 GO TO 1 END IF ntran(i) = 3 1 READ(pronf,10,REC=rec1) mname(i), mform(i) 10 FORMAT(1x,a20,a30) READ(pronf,20,REC=rec1+3) Gfmin(i), Hfmin(i), SPrTrm(i), VPrTrm(i) 20 FORMAT(4x,2(2x,f12.1),2(2x,f8.3)) mnform = mform(i) mvolum = VPrTrm(i) IF (ntran(i) .EQ. 0) THEN **JP* READ(pronf,30,REC=rec1+4) (MK1(j,i), j=1,3) **JP* 30 FORMAT(4x,3(2x,f12.6)) READ(pronf,30,REC=rec1+4) (MK1(j,i), j=1,4) 30 FORMAT(4x,4(2x,f12.6)) 31 FORMAT(4x,3(2x,f12.6)) CMR*** adjust magnitude for coefficient d MK1(4,i), also **JP* adjustment of MK1(4,i) not neccessary since already adjusted in **JP* HPRONS.FOR---however MK1(2,i) and MK1(3,i) need to **JP* be "deadjusted" in HPRONS.FOR (CPB and CPC in that program) **JP* so as to avoid modifying the code here. Line for MK1(4,i) with **JP* coef of 1.0 added anyway to facilitate later modification **** adjust magnitude for Cp coeffs MK1(2,i) = MK1(2,i)*1.0d-3 MK1(3,i) = MK1(3,i)*1.0d5 **JP* MK1(4,i) = MK1(4,i)*1.0d0 READ(pronf,40,REC=rec1+5) Tmaxm(i) 40 FORMAT(8x,f7.2) RETURN END IF IF (ntran(i) .EQ. 1) THEN READ(pronf,50,REC=rec1+4) (MK1(j,i), j=1,3), 1 Ttran(1,i), Htran(1,i), Vtran(1,i), dPdTtr(1,i) * write(*,50) (MK1(j,i), j=1,3), * 1 Ttran(1,i), Htran(1,i), Vtran(1,i), dPdTtr(1,i) 50 FORMAT(4x,3(2x,f12.6),2x,f7.2,2x,f8.1,2(2x,f10.3)) ***** adjust magnitude for Cp coeffs MK1(2,i) = MK1(2,i)*1.0d-3 MK1(3,i) = MK1(3,i)*1.0d5 **JP* READ(pronf,30,REC=rec1+5) (MK2(j,i), j=1,3) READ(pronf,31,REC=rec1+5) (MK2(j,i), j=1,3) * write(*,31) (MK2(j,i), j=1,3) ***** adjust magnitude for Cp coeffs MK2(2,i) = MK2(2,i)*1.0d-3 MK2(3,i) = MK2(3,i)*1.0d5 READ(pronf,40,REC=rec1+6) Tmaxm(i) RETURN END IF IF (ntran(i) .EQ. 2) THEN READ(pronf,50,REC=rec1+4) (MK1(j,i), j=1,3), 1 Ttran(1,i), Htran(1,i), Vtran(1,i), dPdTtr(1,i) ***** adjust magnitude for Cp coeffs MK1(2,i) = MK1(2,i)*1.0d-3 MK1(3,i) = MK1(3,i)*1.0d5 * write(*,50) (MK1(j,i), j=1,3), * 1 Ttran(1,i), Htran(1,i), Vtran(1,i), dPdTtr(1,i) READ(pronf,50,REC=rec1+5) (MK2(j,i), j=1,3), 1 Ttran(2,i), Htran(2,i), Vtran(2,i), dPdTtr(2,i) ***** adjust magnitude for Cp coeffs MK2(2,i) = MK2(2,i)*1.0d-3 MK2(3,i) = MK2(3,i)*1.0d5 * write(*,50) (MK1(j,i), j=1,3), * 1 Ttran(1,i), Htran(1,i), Vtran(1,i), dPdTtr(1,i) READ(pronf,31,REC=rec1+6) (MK3(j,i), j=1,3) ***** adjust magnitude for Cp coeffs MK3(2,i) = MK3(2,i)*1.0d-3 MK3(3,i) = MK3(3,i)*1.0d5 READ(pronf,40,REC=rec1+7) Tmaxm(i) RETURN END IF IF (ntran(i) .EQ. 3) THEN READ(pronf,50,REC=rec1+4) (MK1(j,i), j=1,3), 1 Ttran(1,i), Htran(1,i), Vtran(1,i), dPdTtr(1,i) ***** adjust magnitude for Cp coeffs MK1(2,i) = MK1(2,i)*1.0d-3 MK1(3,i) = MK1(3,i)*1.0d5 READ(pronf,50,REC=rec1+5) (MK2(j,i), j=1,3), 1 Ttran(2,i), Htran(2,i), Vtran(2,i), dPdTtr(2,i) ***** adjust magnitude for Cp coeffs MK2(2,i) = MK2(2,i)*1.0d-3 MK2(3,i) = MK2(3,i)*1.0d5 READ(pronf,50,REC=rec1+6) (MK3(j,i), j=1,3), 1 Ttran(3,i), Htran(3,i), Vtran(3,i), dPdTtr(3,i) ***** adjust magnitude for Cp coeffs MK3(2,i) = MK3(2,i)*1.0d-3 MK3(3,i) = MK3(3,i)*1.0d5 READ(pronf,31,REC=rec1+7) (MK4(j,i), j=1,3) ***** adjust magnitude for Cp coeffs MK4(2,i) = MK4(2,i)*1.0d-3 MK4(3,i) = MK4(3,i)*1.0d5 READ(pronf,40,REC=rec1+8) Tmaxm(i) RETURN END IF END ************************************************************************ *** getgas - Read, from dprons.dat or an analogous database (starting *** at record rec1), standard state parameters for the i[th] *** gas species in the current reaction. SUBROUTINE getgas(i,rec1) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXGAS = 10, IABC = 4, NPLOTF = 8) INTEGER rec1 INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), outflg CHARACTER*20 gname(MAXGAS) CHARACTER*30 gform(MAXGAS), mnform, aqform DOUBLE PRECISION Gfgas(MAXGAS), Hfgas(MAXGAS), VPrTrg(MAXGAS), 1 SPrTrg(MAXGAS), MKg(IABC,MAXGAS), Tmaxg(MAXGAS), 2 mvolum COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /gnames/ gname, gform COMMON /gasref/ Gfgas, Hfgas, SPrTrg, VPrTrg, MKg, Tmaxg Common /solth1/ mvolum Common /solth2/ mnform, aqform SAVE mnform(1:30) = ' ' mvolum = 0.0 **JP* following statement added to allow additional heat capacity coef d. **JP* Need to reset to zero when used by minerals that don't use d. MKg(4,i)=0. READ(pronf,20,REC=rec1) gname(i), gform(i) 20 FORMAT(1x,a20,a30) READ(pronf,30,REC=rec1+3) Gfgas(i), Hfgas(i), SPrTrg(i), VPrTrg(i) 30 FORMAT(4x,2(2x,f12.1),2(2x,f8.3)) mnform = gform(i) mvolum = VPrTrg(i) **JP* READ(pronf,40,REC=rec1+4) MKg(1,i), MKg(2,i), MKg(3,i) **JP* 40 FORMAT(4x,3(2x,f12.6)) READ(pronf,40,REC=rec1+4) MKg(1,i), MKg(2,i), MKg(3,i), MKg(4,i) 40 FORMAT(4x,4(2x,f12.6)) READ(pronf,50,REC=rec1+5) Tmaxg(i) 50 FORMAT(8x,f7.2) ***** adjust magnitude for Cp coeffs MKg(2,i) = MKg(2,i)*1.0d-3 MKg(3,i) = MKg(3,i)*1.0d5 END ************************************************************************ *** getaqs - Read, from dprons.dat or an analogous database (starting *** at record rec1), standard state parameters for the i[th] *** aqueous species in the current reaction. SUBROUTINE getaqs(i,rec1) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXAQS = 10, NPLOTF = 8) INTEGER rec1 INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), outflg CHARACTER*20 aname(MAXAQS) CHARACTER*30 aform(MAXAQS), mnform, aqform DOUBLE PRECISION Gfaqs(MAXAQS), Hfaqs(MAXAQS), SPrTra(MAXAQS), 1 a(4,MAXAQS), c(2,MAXAQS), 2 wref(MAXAQS), chg(MAXAQS) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /anames/ aname, aform COMMON /aqsref/ Gfaqs, Hfaqs, SPrTra, c, a, wref, chg **JP* Add mvolum, mnform, aqform for post-processing to make Soltherm records. Common /solth2/ mnform, aqform SAVE READ(pronf,20,REC=rec1) aname(i), aform(i) 20 FORMAT(1x,a20,a30) aqform = aform(1) READ(pronf,30,REC=rec1+3) Gfaqs(i), Hfaqs(i), SPrTra(i) 30 FORMAT(4x,2(2x,f10.0),4x,f8.3) READ(pronf,40,REC=rec1+4) a(1,i), a(2,i), a(3,i), a(4,i) 40 FORMAT(4x,4(2x,f8.4,2x)) READ(pronf,50,REC=rec1+5) c(1,i), c(2,i), wref(i), chg(i) 50 FORMAT(4x,3(2x,f8.4,2x),9x,f3.0) ***** adjust magnitude for e-o-s coefficients and omega a(1,i) = a(1,i)*1.0d-1 a(2,i) = a(2,i)*1.0d2 a(4,i) = a(4,i)*1.0d4 c(2,i) = c(2,i)*1.0d4 wref(i) = wref(i)*1.0d5 END ************************************************************************ *** runrxn - Calculate the standard molal thermodynamic properties of *** the i[th] reaction over the range of user-specified state *** conditions. SUBROUTINE runrxn(i,wetrun) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER univar, useLVS, epseqn, geqn LOGICAL wetrun COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn SAVE IF (univar .EQ. 1) THEN ***** univariant curve option enabled ***** CALL rununi(i) RETURN END IF IF (noninc .EQ. 0) THEN ***** run orthogonal T-d or T-P grid ***** CALL rungrd(i,wetrun) ELSE ***** run "oddball" T,P or T,d pairs ***** CALL runodd(i) END IF END ************************************************************************ *** rungrd - Calculate the standard molal thermodynamic properties of *** the i[th] reaction over the user-specified *** state-condition grid. SUBROUTINE rungrd(i,wetrun) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, MXTRAN = 3, 1 MAXINC = 900, MAXISO = 21, MAXODD = 900, MAXRXN = 800, 2 NPLOTF = 8) LOGICAL m2reac(MAXRXN), rptran, newiso, wetrun, 1 lvdome(MAXINC,MAXISO), H2Oerr(MAXINC,MAXISO) CHARACTER*80 rtitle(MAXRXN) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 univar, useLVS, epseqn, geqn, ptrans(MAXMIN), 3 outflg INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 logKr, oddv1(MAXODD), oddv2(MAXODD), 2 TPD(3), TPDtrn(MAXMIN,MXTRAN,3), 3 mwH2O, satmin(2) DOUBLE PRECISION dsvar(MAXINC,MAXISO), Vw(MAXINC,MAXISO), 1 bew(MAXINC,MAXISO), alw(MAXINC,MAXISO), 2 dalw(MAXINC,MAXISO), Sw(MAXINC,MAXISO), 3 Cpw(MAXINC,MAXISO), Hw(MAXINC,MAXISO), 4 Gw(MAXINC,MAXISO), Zw(MAXINC,MAXISO), 5 Qw(MAXINC,MAXISO), Yw(MAXINC,MAXISO), 6 Xw(MAXINC,MAXISO) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /H2Ogrd/ dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, 1 Zw, Qw, Yw, Xw COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /fmeq/ dVr, dSr, dCpr, dHr, dGr, logKr, dlogKT, dlogKP COMMON /satend/ satmin COMMON /badtd/ lvdome, H2Oerr SAVE DO 10 iso = 1,niso IF (isat .EQ. 0) 1 TPD(mapiso(iopt,iplot)) = isomin + (iso-1)*isoinc DO 20 inc = 1,nv2 IF (isat .EQ. 0) THEN TPD(mapinc(iopt,iplot)) = v2min + (inc-1)*v2inc TPD(mapv3(iopt,iplot)) = dsvar(inc,iso) ELSE IF ((inc .EQ. 1) .AND. (v2min .EQ. 0.0d0)) THEN TPD(mapiso(iopt,iplot)) = satmin(iopt) ELSE TPD(mapiso(iopt,iplot)) = v2min + (inc-1)*v2inc END IF TPD(mapinc(iopt,iplot)) = dsvar(inc,iso) TPD(mapv3(iopt,iplot)-isat) = mwH2O/Vw(inc,iso) END IF IF (.NOT. (lvdome(inc,iso) .OR. H2Oerr(inc,iso))) THEN CALL reac92(i,TPD(2),TPD(1),TPD(3),Vw(inc,iso), 1 bew(inc,iso), alw(inc,iso), dalw(inc,iso), 2 Sw(inc,iso), Cpw(inc,iso), Hw(inc,iso), 3 Gw(inc,iso), Zw(inc,iso), Qw(inc,iso), 4 Yw(inc,iso), Xw(inc,iso), geqn) END IF IF (.NOT. m2reac(i)) THEN rptran = .FALSE. ELSE newiso = ((inc .EQ. 1) .OR. lvdome(inc-1,iso) .OR. 1 H2Oerr(inc-1,iso)) CALL m2tran(inc,iso,newiso,nm(i), 1 rptran,ptrans,TPD,TPDtrn,wetrun) END IF CALL report(i,iso,inc,TPD,TPDtrn,rptran,ptrans, 1 dVr,dSr,dCpr,dHr,dGr,logKr, 2 lvdome(inc,iso),H2Oerr(inc,iso), 3 .FALSE.) 20 CONTINUE 10 CONTINUE END ******************************************************************* *** m2tran - Returns rptran = .TRUE. if a phase transition occurs *** for one or more minerals in the current reaction between *** the immediately previous and current state conditions. SUBROUTINE m2tran(inc,iso,newiso,nmreac,rptran,ptrans,TPD,TPDtrn, 1 wetrun) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MXTRAN = 3, MAXMIN = 10) LOGICAL rptran, newiso, wetrun INTEGER phaser(MAXMIN), prprev(MAXMIN), ptrans(MAXMIN) DOUBLE PRECISION TPD(3), TPDtrn(MAXMIN,MXTRAN,3) DOUBLE PRECISION Vmin(MAXMIN), Smin(MAXMIN), Cpmin(MAXMIN), 2 Hmin(MAXMIN), Gmin(MAXMIN) COMMON /minsp/ Vmin, Smin, Cpmin, Hmin, Gmin, phaser SAVE rptran = .FALSE. IF (newiso) THEN DO 10 imin = 1,nmreac prprev(imin) = phaser(imin) ptrans(imin) = 0 10 CONTINUE ELSE DO 20 imin = 1,nmreac IF (prprev(imin) .EQ. phaser(imin)) THEN ptrans(imin) = 0 ELSE rptran = .TRUE. ptrans(imin) = IABS(phaser(imin) - prprev(imin)) prprev(imin) = phaser(imin) CALL getsct(inc,iso,imin,phaser(imin), 1 ptrans(imin),TPD,TPDtrn,wetrun) END IF 20 CONTINUE END IF END ********************************************************************* *** getsct - Get s[tate] c[onditions of phase] t[ransition] *** iphase for mineral imin. SUBROUTINE getsct(inc,iso,imin,iphase,ntrans,TPD,TPDtrn,wetrun) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MXTRAN = 3, MAXMIN = 10, IABC = 4, NPROP2 = 46, 1 MAXINC = 900, MAXISO = 21, MAXODD = 900, NPLOTF = 8) LOGICAL error, wetrun CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 outflg INTEGER univar, useLVS, epseqn, geqn, ntran(MAXMIN), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), specs(10) DOUBLE PRECISION TPDtrn(MAXMIN,MXTRAN,3), TtranP(MXTRAN,MAXMIN), 2 PtranT(MXTRAN,MAXMIN), states(4), props(NPROP2), 3 isomin, isomax, isoinc, Kmin, Kmax, Kinc, 4 oddv1(MAXODD), oddv2(MAXODD), TPD(3) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) DOUBLE PRECISION dsvar(MAXINC,MAXISO), Vw(MAXINC,MAXISO), 1 bew(MAXINC,MAXISO), alw(MAXINC,MAXISO), 2 dalw(MAXINC,MAXISO), Sw(MAXINC,MAXISO), 3 Cpw(MAXINC,MAXISO), Hw(MAXINC,MAXISO), 4 Gw(MAXINC,MAXISO), Zw(MAXINC,MAXISO), 5 Qw(MAXINC,MAXISO), Yw(MAXINC,MAXISO), 6 Xw(MAXINC,MAXISO) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /PTtran/ TtranP, PtranT COMMON /H2Ogrd/ dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, 1 Zw, Qw, Yw, Xw COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK SAVE DATA specs / 2,2,2,5,1,0,0,0,0,0 / DATA states / 4*0.0d0 / DATA Tfssat / 139.8888149d0 / specs(6) = isat specs(7) = iopt specs(8) = useLVS specs(9) = epseqn *** ntrans = # phase transitions for mineral imin between *** current and last isopleth locations. DO 10 itran = ntrans,1,-1 IF (isat .EQ. 1) THEN *** vaporization boundary IF (mname(imin)(1:11) .EQ. 'FERROSILITE') THEN states(1) = Tfssat ELSE states(1) = TtranP(iphase-itran,imin) - 273.15d0 END IF IF (specs(7) .EQ. 2) THEN specs(7) = 1 END IF ELSE IF (iplot .EQ. 2) THEN *** isotherms(pres or dens) states(1) = TPD(mapiso(iopt,iplot)) states(2) = PtranT(iphase-itran+1,imin) IF (specs(7) .EQ. 1) THEN specs(7) = 2 END IF ELSE IF (iopt .EQ. 2) THEN *** isobars(temp) states(1) = TtranP(iphase-itran,imin) 1 - 273.15d0 states(2) = TPD(mapiso(iopt,iplot)) ELSE *** isochores(temp) states(3) = TPD(mapiso(iopt,iplot)) IF (dPdTtr(iphase-1,imin) .EQ. 0.0d0) THEN states(1) = TtranP(iphase-itran,imin) 1 - 273.15d0 ELSE *** special case, make *** appropriate approximation P1 = dsvar(inc-1,iso) P2 = dsvar(inc,iso) T1 = v2min + (inc-2)*v2inc T2 = v2min + (inc-1)*v2inc states(1) = Tint(P1,P2,T1,T2, 1 TtranP(iphase-itran,imin)-273.15d0, 2 dPdTtr(iphase-itran,imin)) END IF END IF END IF END IF IF (wetrun) THEN CALL H2O92(specs,states,props,error) ELSE error = .FALSE. states(isat+3) = 0.0d0 END IF IF (error) THEN WRITE(wterm,20) (states(jjj), jjj=1,3) WRITE(tabf,20) (states(jjj), jjj=1,3) 20 format(/,' State conditions fall beyond validity limits of', 1 /,' the Haar et al. (1984) H2O equation of state:', 2 /,' T < Tfusion@P; T > 2250 degC; or P > 30kb.', 3 /,' SUPCRT92 stopped in SUBROUTINE getsct:', 4 //,' T = ',e12.5, 5 /,' P = ',e12.5, 6 /,' D = ',e12.5,/) STOP ELSE TPDtrn(imin,itran,1) = states(1) TPDtrn(imin,itran,2) = states(2) TPDtrn(imin,itran,3) = states(isat+3) END IF 10 CONTINUE END ********************************************************************* *** Tint - Returns the temperature intersection of isochore(T) *** with a mineral phase transition boundary where *** (dP/dT)tr .NE. 0. Approximation involves assumption *** that (dP/dT)isochore is linear between P1,T1,D *** and P2,T2,D (consecutive locations on isochore D(T)) *** that bridge the phase transition. DOUBLE PRECISION FUNCTION Tint(P1,P2,T1,T2,TtrnP2,dPdTtr) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE bmin = P2 - dPdTtr*TtrnP2 dPdTi = (P2 - P1)/(T2 - T1) biso = P2 - dPdTi*T2 Tint = (bmin - biso)/(dPdTi - dPdTtr) END ************************************************************************ *** runodd - Calculate the standard molal thermodynamic properties of *** the i[th] reaction over the user-specified set of *** nonincremental state condition pairs. SUBROUTINE runodd(i) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, MXTRAN = 3, 1 MAXINC = 900, MAXISO = 21, MAXODD = 900, NPLOTF = 8) LOGICAL rptdum, lvdome(MAXINC,MAXISO), H2Oerr(MAXINC,MAXISO) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 univar, useLVS, epseqn, geqn, ptdumb(MAXMIN), 3 outflg DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 logKr, oddv1(MAXODD), oddv2(MAXODD), 2 TPD(3), mwH2O DOUBLE PRECISION dsvar(MAXINC,MAXISO), Vw(MAXINC,MAXISO), 1 bew(MAXINC,MAXISO), alw(MAXINC,MAXISO), 2 dalw(MAXINC,MAXISO), Sw(MAXINC,MAXISO), 3 Cpw(MAXINC,MAXISO), Hw(MAXINC,MAXISO), 4 Gw(MAXINC,MAXISO), Zw(MAXINC,MAXISO), 5 Qw(MAXINC,MAXISO), Yw(MAXINC,MAXISO), 6 Xw(MAXINC,MAXISO), 7 TPDdum(MAXMIN,MXTRAN,3) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /H2Ogrd/ dsvar, Vw, bew, alw, dalw, Sw, Cpw, Hw, Gw, 1 Zw, Qw, Yw, Xw COMMON /fmeq/ dVr, dSr, dCpr, dHr, dGr, logKr, dlogKT, dlogKP COMMON /badtd/ lvdome, H2Oerr SAVE *** MAXMIN*MXTRAN*3 = 90 *** DATA TPDdum / 90*0.0d0 / DATA rptdum / .FALSE. / *** MAXMIN*0 DATA ptdumb / 10*0 / DO 10 iodd = 1,noninc TPD(mapiso(iopt,iplot)) = oddv1(iodd) IF (isat .EQ. 0) THEN TPD(mapinc(iopt,iplot)) = oddv2(iodd) TPD(mapv3(iopt,iplot)) = dsvar(iodd,1) ELSE TPD(mapinc(iopt,iplot)) = dsvar(iodd,1) TPD(mapv3(iopt,iplot)-isat) = mwH2O/Vw(iodd,1) END IF IF (.NOT. (lvdome(iodd,1) .OR. H2Oerr(iodd,1))) THEN CALL reac92(i,TPD(2),TPD(1),TPD(3),Vw(iodd,1), 1 bew(iodd,1), alw(iodd,1), dalw(iodd,1), 2 Sw(iodd,1), Cpw(iodd,1), Hw(iodd,1), 3 Gw(iodd,1), Zw(iodd,1), Qw(iodd,1), 4 Yw(iodd,1), Xw(iodd,1), geqn) END IF CALL report(i, 1, iodd, TPD, TPDdum, rptdum, ptdumb, 1 dVr, dSr, dCpr, dHr, dGr, logKr, 2 lvdome(iodd,1), H2Oerr(iodd,1),.FALSE.) 10 CONTINUE END ************************************************************************ *** rununi - Calculate the standard molal thermodynamic properties of *** the i[th] reaction over the user-specified set of T,logK *** or P,logK pairs. SUBROUTINE rununi(i) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800, 1 MAXODD = 900, MXTRAN = 3, NPLOTF = 8) LOGICAL foundK, Kfound, wetrxn, m2reac(MAXRXN), rptdum CHARACTER*80 rtitle(MAXRXN) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 univar, useLVS, epseqn, geqn, ptdumb(MAXMIN), 3 outflg INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 Kfind, logKr, isoval, oddv1(MAXODD), 2 oddv2(MAXODD), TPD(3), TPDdum(MAXMIN,MXTRAN,3) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /fmeq/ dVr, dSr, dCpr, dHr, dGr, logKr, dlogKT, dlogKP SAVE *** MAXMIN*MXTRAN*3 = 90 *** DATA TPDdum / 90*0.0d0 / DATA rptdum / .FALSE. / *** MAXMIN*0 DATA ptdumb / 10*0 / nv2 = nlogK wetrxn = ((nw(i) .GT. 0) .OR. (na(i) .GT. 0)) DO 10 iso = 1,niso isoval = isomin + (iso-1)*isoinc DO 10 inc = 1,nlogK Kfind = Kmin + (inc-1)*Kinc Kfound = foundK(i,wetrxn,Kfind,isoval, 1 v2min,v2max,v2val,dH2O) IF (.NOT. Kfound) logKr = Kfind TPD(mapiso(iopt,iplot)) = isoval TPD(mapinc(iopt,iplot)) = v2val TPD(3) = dH2O CALL report(i, iso, inc, TPD, TPDdum, rptdum, 1 ptdumb, dVr, dSr, dCpr, dHr, dGr, logKr, 2 .FALSE.,.FALSE.,Kfound) 10 CONTINUE END ******************************************************************** *** SUBRs report, wrtrxn, wrtssp, report *** SUBR blanks ******************************************************************** *** foundK - Returns '.TRUE.' and v2Kfnd[T|P](isoval[P|T],Kfind) if *** (1) logK(isoval,var2=v2min..v2max) for the i[th] reaction *** is unimodal, and (2) logK value Kfind at isoval occurs *** within v2min..v2max; otherwise returns '.FALSE.'. *** v2Kfnd(usival,Kfind) is isolated using a straightforward *** implementation of the golden section search algorithm *** (e.g., Miller (1984), pp. 130-133.) LOGICAL FUNCTION foundK(i,wetrxn,Kfind,isoval,v2min,v2max, 1 v2val,dH2O) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP2 = 46, MXEVAL = 50, TOL = 1.0d6, NPLOTF = 8) LOGICAL wetrxn, error INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 outflg INTEGER mapiso(2,3), mapinc(2,3), mapv3(2,3), 1 univar, useLVS, epseqn, geqn, specs(10) INTEGER AA, G, S, U, H, Cv, Cp, vs, al, be, 1 di, vi, tc, st, td, Pr, vik, albe, 2 Z, Y, Q, daldT, X DOUBLE PRECISION isoval, Kfind, major, logKr, mwH2O, 1 states(4), props(NPROP2) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /refval/ mwH2O, RR, Pref, Tref, ZPrTr, YPrTr COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /fmeq/ dVr, dSr, dCpr, dHr, dGr, 1 logKr, dlogKT, dlogKP SAVE DATA AA, G, S, U, H, Cv, Cp, vs, al, be, di, vi, 1 tc, st, td, Pr, vik, albe, Z, Y, Q, daldT, X 2 / 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 3 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45 / DATA specs / 2,2,2,5,1,0,2,0,0,0 / DATA props / 46*0.0d0 / DATA error / .FALSE. / foundK = .TRUE. j = 0 a = v2min b = v2max r = (3.0d0 - DSQRT(5.0d0)) / 2.0d0 major = r * (b-a) c = a + major d = b - major *** set acceptance tolerance per TOL accept = (1.0d0 + DABS(Kfind))/TOL states(mapiso(iopt,iplot)) = isoval states(mapinc(iopt,iplot)) = c states(3) = 1.0d0 IF (wetrxn) THEN specs(8) = useLVS specs(9) = epseqn CALL H2O92(specs,states,props,error) IF (error) THEN WRITE(wterm,10) (states(jjj), jjj=1,3) WRITE(tabf,10) (states(jjj), jjj=1,3) 10 format(/,' State conditions fall beyond validity limits of', 1 /,' the Haar et al. (1984) H2O equation of state:', 2 /,' T < Tfusion@P; T > 2250 degC; or P > 30kb.', 3 /,' SUPCRT92 stopped in LOGICAL FUNCTION foundK:', 4 //,' T = ',e12.5, 5 /,' P = ',e12.5, 6 /,' D = ',e12.5,/) STOP END IF END IF CALL reac92(i,states(2),states(1),states(3), 1 mwH2O/states(3),props(be),props(al),props(daldT), 2 props(S),props(Cp),props(H),props(G),props(Z),props(Q), 3 props(Y),props(X),geqn) fc = DABS(logKr - Kfind) states(mapiso(iopt,iplot)) = isoval states(mapinc(iopt,iplot)) = d IF (wetrxn) THEN CALL H2O92(specs,states,props,error) IF (error) THEN WRITE(wterm,10) STOP END IF END IF CALL reac92(i,states(2),states(1),states(3), 1 mwH2O/states(3),props(be),props(al),props(daldT), 2 props(S),props(Cp),props(H),props(G),props(Z),props(Q), 3 props(Y),props(X),geqn) fd = DABS(logKr - Kfind) 1 IF (fc .LE. accept) THEN states(mapiso(iopt,iplot)) = isoval states(mapinc(iopt,iplot)) = c IF (wetrxn) THEN CALL H2O92(specs,states,props,error) IF (error) THEN WRITE(wterm,10) STOP END IF END IF CALL reac92(i,states(2),states(1),states(3), 1 mwH2O/states(3),props(be),props(al),props(daldT), 2 props(S),props(Cp),props(H),props(G),props(Z),props(Q), 3 props(Y),props(X),geqn) v2val = c IF (wetrxn) THEN dH2O = states(3) ELSE dH2O = 0.0d0 END IF RETURN END IF IF (fd .LE. accept) THEN states(mapiso(iopt,iplot)) = isoval states(mapinc(iopt,iplot)) = d IF (wetrxn) THEN CALL H2O92(specs,states,props,error) IF (error) THEN WRITE(wterm,10) STOP END IF END IF CALL reac92(i,states(2),states(1),states(3), 1 mwH2O/states(3),props(be),props(al),props(daldT), 2 props(S),props(Cp),props(H),props(G),props(Z),props(Q), 3 props(Y),props(X),geqn) v2val = d IF (wetrxn) THEN dH2O = states(3) ELSE dH2O = 0.0d0 END IF RETURN END IF IF (j .GT. MXEVAL) THEN foundK = .FALSE. IF (wetrxn) THEN dH2O = states(3) ELSE dH2O = 0.0d0 END IF RETURN ELSE j = j + 1 END IF IF (fc .LT. fd) THEN b = d d = c fd = fc c = a + r*(b-a) states(mapiso(iopt,iplot)) = isoval states(mapinc(iopt,iplot)) = c IF (wetrxn) THEN CALL H2O92(specs,states,props,error) IF (error) THEN WRITE(wterm,10) STOP END IF END IF CALL reac92(i,states(2),states(1),states(3), 1 mwH2O/states(3),props(be),props(al),props(daldT), 2 props(S),props(Cp),props(H),props(G),props(Z), 3 props(Q),props(Y),props(X),geqn) fc = DABS(logKr - Kfind) ELSE a = c c = d fc = fd d = b - r*(b-a) states(mapiso(iopt,iplot)) = isoval states(mapinc(iopt,iplot)) = d IF (wetrxn) THEN CALL H2O92(specs,states,props,error) IF (error) THEN WRITE(wterm,10) STOP END IF END IF CALL reac92(i,states(2),states(1),states(3), 1 mwH2O/states(3),props(be),props(al),props(daldT), 2 props(S),props(Cp),props(H),props(G),props(Z), 3 props(Q),props(Y),props(X),geqn) fd = DABS(logKr - Kfind) END IF GO TO 1 END ********************************************************************* *** makerf - Prompt for and create a reaction (RXN) file. SUBROUTINE makerf(nreac,wetrxn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800, 1 MAXBAD = 10, NPLOTF = 8) CHARACTER*1 ans CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) CHARACTER*20 specie, namem(MAXRXN,MAXMIN), 1 namea(MAXRXN,MAXAQS), nameg(MAXRXN,MAXGAS), 2 sbad(MAXBAD) CHARACTER*30 form, formm(MAXRXN,MAXMIN), formg(MAXRXN,MAXGAS), 1 forma(MAXRXN,MAXAQS) CHARACTER*80 rtitle(MAXRXN), string LOGICAL openf, wetrxn, m2reac(MAXRXN), parse, 1 savecf, saverf, rxnok, match INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), rec1, 1 nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 2 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 3 rec1g(MAXRXN,MAXGAS), univar, useLVS, epseqn, geqn, 4 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa, outflg DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /saveif/ savecf, saverf SAVE nm1234 = nmin1 + nmin2 + nmin3 + nmin4 nmga = nm1234 + ngas + naqs ***** prompt for / read nreac ***** 1 WRITE(wterm,5) 5 FORMAT(/,' specify number of reactions to be processed: ',/) READ(rterm,*) nreac IF (nreac .LE. 0) GO TO 1 DO 10 ireac = 1,nreac ***** prompt for / read specifications for next reaction ***** WRITE(wterm,15) ireac, nreac 15 FORMAT(/,' input title for reaction ',i3,' of ',i3,':',/) READ(rterm,25) rtitle(ireac) 25 FORMAT(a80) 333 WRITE(wterm,35) ireac 35 FORMAT(/,' enter [coeff species] pairs, separated by' 1 /,' blanks, one pair per line, for reaction ',i3, 2 /,' (conclude with [0 done]) ',/) ibad = 0 m2reac(ireac) = .FALSE. nm(ireac) = 0 ng(ireac) = 0 na(ireac) = 0 nw(ireac) = 0 111 READ(rterm,112) string 112 FORMAT(a80) IF (.NOT. parse(string,coeff,specie)) THEN WRITE(wterm,113) 113 FORMAT(/,' ill-defined [coeff species] pair; ', 1 'try again',/) GO TO 111 END IF IF (coeff .EQ. 0.0d0) THEN ****** reaction stoichiometry complete ****** IF (ibad .NE. 0) THEN CALL wrtbad(ibad,sbad) GO TO 111 ELSE ****** ensure that stoichiometry is correct CALL chkrxn(ireac,namem,namea,nameg, 1 formm,forma,formg,rxnok) IF (.NOT. rxnok) THEN GO TO 333 END IF END IF ELSE ****** determine disposition of current specie: either H2O, ****** found or not found within the current database IF (specie .EQ. 'H2O') THEN nw(ireac) = 1 coefw(ireac) = coeff ELSE IF (match(specie,form,rec1,rec1m1,1,nmga,nm1234)) 1 THEN ****** update [n|coef|rec1][m|g|a]; continue CALL umaker(ireac,coeff,specie,form,rec1, 1 namem,namea,nameg,formm,forma,formg) ELSE ibad = ibad + 1 sbad(ibad) = specie END IF END IF GO TO 111 END IF 10 CONTINUE ****** set wetrxn variable ****** iwet = 0 wetrxn = .FALSE. IF ((isat .EQ. 1) .OR. (iopt .EQ. 1)) THEN wetrxn = .TRUE. iwet = 1 ELSE DO 70 ireac = 1,nreac IF ((nw(ireac) .EQ. 1) .OR. (na(ireac) .GT. 0)) THEN wetrxn = .TRUE. iwet = 1 GO TO 444 END IF 70 CONTINUE END IF ****** save reaction file if desired ****** 444 WRITE(wterm,125) 125 FORMAT(/,' would you like to save these reactions to a file ', 1 '(y/n)',/) READ(rterm,135) ans 135 FORMAT(a1) IF ((ans .NE. 'y') .AND. (ans .NE. 'Y') .AND. 1 (ans .NE. 'n') .AND. (ans .NE. 'N')) GO TO 444 saverf = ((ans .EQ. 'y') .OR. (ans .EQ. 'Y')) IF (saverf) THEN 555 WRITE(wterm,145) 145 FORMAT(/,' specify file name:',/) READ(rterm,155) namerf 155 FORMAT(a20) IF (.NOT. openf(wterm,reacf,namerf,2,1,1,132)) THEN GO TO 555 ELSE *** write generic header WRITE(reacf,205) 205 FORMAT(' Line 1: nreac, iwet',12x, 1 '(free format)') WRITE(reacf,210) 210 FORMAT(' Line 2: [blank]',16x, 1 '(free format)') WRITE(reacf,215) 215 FORMAT(' Line 3: descriptive title',6x, 1 '(a80)') WRITE(reacf,220) 220 FORMAT(' Line 4: nm, na, ng, nw',9x, 1 '(free format)') WRITE(reacf,225) 225 FORMAT(' nm Lines: coeff mname mform',2x, 1 '(1x,f9.3,2x,a20,2x,a30)') WRITE(reacf,230) 230 FORMAT(' ng Lines: coeff aname aform',2x, 1 '(1x,f9.3,2x,a20,2x,a30)') WRITE(reacf,235) 235 FORMAT(' na Lines: coeff gname gform',2x, 1 '(1x,f9.3,2x,a20,2x,a30)') WRITE(reacf,240) 240 FORMAT(' [1 Line: coeff H2O H2O] ',2x, 1 '(1x,f9.3,2x,a20,2x,a30)',/) WRITE(reacf,245) 245 FORMAT('*** each of the nreac reaction blocks',/, 1 '*** contains 3+nm+ng+na+nw lines',/) WRITE(reacf,250) 250 FORMAT(55('*'),/) *** write reaction information WRITE(reacf,165) nreac, iwet 165 FORMAT(2(1x,i3)) END IF DO 80 ireac = 1,nreac WRITE(reacf,175) rtitle(ireac), nm(ireac), 1 na(ireac), ng(ireac), nw(ireac) 175 FORMAT(/,1x,a80,/,4(1x,i3)) IF (nm(ireac) .GT. 0) WRITE(reacf,185) 1 (coefm(ireac,imin), namem(ireac,imin), 2 formm(ireac,imin), imin = 1,nm(ireac)) 185 FORMAT(1x,f9.3,2x,a20,2x,a30) IF (na(ireac) .GT. 0) WRITE(reacf,185) 1 (coefa(ireac,iaqs), namea(ireac,iaqs), 2 forma(ireac,iaqs), iaqs = 1,na(ireac)) IF (ng(ireac) .GT. 0) WRITE(reacf,185) 1 (coefg(ireac,igas), nameg(ireac,igas), 2 formg(ireac,igas), igas = 1,ng(ireac)) IF (nw(ireac) .EQ. 1) WRITE(reacf,195) 1 coefw(ireac), 'H2O ', 2 'H2O ' 195 FORMAT(1x,f9.3,2x,a20,2x,a30) 80 CONTINUE END IF END *************************************************************** *** nxtrec - Get rec1 for next database species. INTEGER FUNCTION nxtrec(irec,mga,nm1234) INTEGER rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa SAVE IF ((mga .LE. nmin1) .OR. (mga .GT. nm1234)) THEN *** one-phase mineral, gas, or aqueous species nxtrec = irec + 6 RETURN END IF IF (mga .LE. (nmin1 + nmin2)) THEN *** two-phase mineral nxtrec = irec + 7 RETURN END IF IF (mga .LE. (nmin1 + nmin2 + nmin3)) THEN *** three-phase mineral nxtrec = irec + 8 ELSE *** four-phase mineral nxtrec = irec + 9 END IF RETURN END ******************************************************************* *** readrf - Open/read user-specified reaction (RXN) file. SUBROUTINE readrf(nreac,wetrxn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800, 1 NPLOTF = 8) CHARACTER*20 namecf, namerf, nametf, spname, namepf(NPLOTF), 1 pfname CHARACTER*30 form CHARACTER*80 rtitle(MAXRXN) LOGICAL openf, wetrxn, m2reac(MAXRXN), savecf, saverf, match INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa, outflg INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS), rec1 DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /saveif/ savecf, saverf COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /dapron/ pfname SAVE nm1234 = nmin1 + nmin2 + nmin3 + nmin4 nmga = nm1234 + ngas + naqs 1 WRITE(wterm,10) 10 FORMAT(/,' specify name of reaction file:',/) READ(rterm,20) namerf 20 FORMAT(a20) IF (.NOT. openf(wterm,reacf,namerf,1,1,1,132)) GO TO 1 saverf = .TRUE. ***** read number of reactions and their wet/dry character ****** ***** skip first 13 comment lines READ(reacf,25) 25 FORMAT(////////////) READ(reacf,*) nreac, iwet wetrxn = (iwet .EQ. 1) DO 30 ireac = 1,nreac ***** read title, nm, na, ng, nw for next reaction ***** READ(reacf,40) rtitle(ireac) 40 FORMAT(/,1x,a80) READ(reacf,*) nm(ireac), na(ireac), ng(ireac), nw(ireac) ***** read mineral, aqueous species, gas, H2O stoichiometry ***** m2reac(ireac) = .FALSE. IF (nm(ireac) .GT. 0) THEN DO 50 imin = 1,nm(ireac) READ(reacf,51) coefm(ireac,imin), spname, form 51 FORMAT(1x,f9.3,2x,a20,2x,a30) IF (.NOT. match(spname,form,rec1,rec1m1,1, 1 nm1234,nm1234)) THEN GO TO 999 ELSE rec1m(ireac,imin) = rec1 IF (rec1m(ireac,imin) .GE. rec1m2) THEN m2reac(ireac) = .TRUE. END IF END IF 50 CONTINUE END IF IF (na(ireac) .GT. 0) THEN istart = nm1234 + ngas + 1 DO 60 iaqs = 1,na(ireac) READ(reacf,51) coefa(ireac,iaqs), spname, form IF (.NOT. match(spname,form,rec1,rec1aa,istart, 1 nmga,nm1234)) THEN GO TO 999 ELSE rec1a(ireac,iaqs) = rec1 END IF 60 CONTINUE END IF IF (ng(ireac) .GT. 0) THEN istart = nm1234 + 1 iend = nm1234 + ngas DO 70 igas = 1,ng(ireac) READ(reacf,51) coefg(ireac,igas), spname, form IF (.NOT. match(spname,form,rec1,rec1gg,istart, 1 iend,nm1234)) THEN GO TO 999 ELSE rec1g(ireac,igas) = rec1 END IF 70 CONTINUE END IF IF (nw(ireac) .EQ. 0) THEN coefw(ireac) = 0 ELSE READ(reacf,*) coefw(ireac) END IF 30 CONTINUE RETURN 999 WRITE(wterm,1000) ireac, spname, pfname 1000 FORMAT(//,' Reaction ',i3,' species ',a20, 1 /,' not found in database ',a20,/ 1 /,' re-run with correct database or re-create', 2 /,' reaction file from this database.',/) STOP END ************************************************************************ *** wrtbad - Write the list of species not found in database pfname; *** prompt for repeats. SUBROUTINE wrtbad(ibad,sbad) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8, MAXBAD = 10) INTEGER rterm, wterm, iconf, reacf, pronf, tabf, 1 plotf(NPLOTF), outflg CHARACTER*20 sbad(MAXBAD), pfname COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /dapron/ pfname SAVE WRITE(wterm,45) pfname 45 FORMAT(/,' the following species were not', 1 /,' found in database ',a20,/) DO 20 i = 1,ibad WRITE(wterm,55) sbad(i) 55 FORMAT(5x,a20) 20 CONTINUE WRITE(wterm,65) 65 FORMAT(/,' input new [coeff species] pairs', 1 /,' to replace these incorrect entries', 2 /,' (conclude with [0 done]) ',/) ibad = 0 END ************************************************************************ *** chkrxn - Give the user a chance to look over rxn stoichiometry; *** if it's ok, then rxnok returns .TRUE.; otherwise, *** returns .FALSE. SUBROUTINE chkrxn(ireac,namem,namea,nameg,formm,forma,formg,rxnok) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800, 1 NPLOTF = 8) CHARACTER*1 ans CHARACTER*20 namem(MAXRXN,MAXMIN), namea(MAXRXN,MAXAQS), 1 nameg(MAXRXN,MAXGAS), namew CHARACTER*30 formm(MAXRXN,MAXMIN), formg(MAXRXN,MAXGAS), 1 forma(MAXRXN,MAXAQS), formw CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN), rxnok INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 2 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 3 rec1g(MAXRXN,MAXGAS), outflg DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac SAVE DATA namew, formw / 1 'H2O ', 2 'H2O '/ WRITE(wterm,75) ireac 75 FORMAT(/,' reaction ',i3,' stoichiometry:',/) ***** write reactants DO 30 imin = 1,nm(ireac) IF (coefm(ireac,imin) .LT. 0.0d0) THEN WRITE(wterm,85) coefm(ireac,imin), 1 namem(ireac,imin), formm(ireac,imin) 85 FORMAT(6x,f7.3,3x,a20,3x,a30) END IF 30 CONTINUE DO 40 igas = 1,ng(ireac) IF (coefg(ireac,igas) .LT. 0.0d0) THEN WRITE(wterm,86) coefg(ireac,igas), 1 formg(ireac,igas)(1:20), nameg(ireac,igas) 86 FORMAT(6x,f7.3,3x,a20,3x,a20) END IF 40 CONTINUE DO 50 iaqs = 1,na(ireac) IF (coefa(ireac,iaqs) .LT. 0.0d0) THEN WRITE(wterm,85) coefa(ireac,iaqs), 1 namea(ireac,iaqs), forma(ireac,iaqs) END IF 50 CONTINUE IF ((nw(ireac) .EQ. 1) .AND. (coefw(ireac) .LT. 0.0d0)) THEN WRITE(wterm,85) coefw(ireac), namew, formw END IF ***** write products DO 31 imin = 1,nm(ireac) IF (coefm(ireac,imin) .GT. 0.0d0) THEN WRITE(wterm,85) coefm(ireac,imin), 1 namem(ireac,imin), formm(ireac,imin) END IF 31 CONTINUE DO 41 igas = 1,ng(ireac) IF (coefg(ireac,igas) .GT. 0.0d0) THEN WRITE(wterm,86) coefg(ireac,igas), 1 formg(ireac,igas)(1:20), nameg(ireac,igas) END IF 41 CONTINUE DO 51 iaqs = 1,na(ireac) IF (coefa(ireac,iaqs) .GT. 0.0d0) THEN WRITE(wterm,85) coefa(ireac,iaqs), 1 namea(ireac,iaqs), forma(ireac,iaqs) END IF 51 CONTINUE IF ((nw(ireac) .EQ. 1) .AND. (coefw(ireac) .GT. 0.0d0)) THEN WRITE(wterm,85) coefw(ireac), namew, formw END IF 222 WRITE(wterm,95) 95 FORMAT(/,' is this correct? (y/n)',/) READ(rterm,105) ans 105 FORMAT(a1) IF ((ans .NE. 'Y') .AND. (ans .NE. 'y') .AND. 1 (ans .NE. 'N') .AND. (ans .NE. 'n')) THEN GO TO 222 ELSE rxnok = ((ans .EQ. 'Y') .OR. (ans .EQ. 'y')) END IF END ******************************************************************* *** match - Returns .TRUE. (and rec1sp) if specie is found in *** database pfname; otherwise returns .FALSE. LOGICAL FUNCTION match(specie,form,rec1sp,rec1ty,first,last, 1 nm1234) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8) CHARACTER*20 specie, name CHARACTER*30 form INTEGER rterm, wterm, iconf, reacf, pronf, tabf, 1 plotf(NPLOTF), rec1sp, rec1ty, first, last, 2 outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE irec = rec1ty DO 60 mga = first,last READ(pronf,115,REC=irec) name, form 115 FORMAT(1x,a20,a30) IF (specie .EQ. name) THEN match = .TRUE. rec1sp = irec RETURN ELSE irec = nxtrec(irec,mga,nm1234) END IF 60 CONTINUE match = .FALSE. RETURN END ******************************************************************* *** umaker - Update /reac/ arrays to include current species. SUBROUTINE umaker(ireac,coeff,specie,form,rec1, 1 namem,namea,nameg,formm,forma,formg) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800) CHARACTER*20 specie, namem(MAXRXN,MAXMIN), namea(MAXRXN,MAXAQS), 1 nameg(MAXRXN,MAXGAS) CHARACTER*30 form, formm(MAXRXN,MAXMIN), formg(MAXRXN,MAXGAS), 1 forma(MAXRXN,MAXAQS) CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN) INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 2 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 3 rec1g(MAXRXN,MAXGAS), 4 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa, rec1 DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /rlimit/ nmin1, nmin2, nmin3, nmin4, ngas, naqs, 1 rec1m1, rec1m2, rec1m3, rec1m4, rec1gg, rec1aa COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac SAVE IF (rec1 .GE. rec1aa) THEN na(ireac) = na(ireac) + 1 coefa(ireac,na(ireac)) = coeff rec1a(ireac,na(ireac)) = rec1 namea(ireac,na(ireac)) = specie forma(ireac,na(ireac)) = form RETURN END IF IF (rec1 .GE. rec1gg) THEN ng(ireac) = ng(ireac) + 1 coefg(ireac,ng(ireac)) = coeff rec1g(ireac,ng(ireac)) = rec1 nameg(ireac,ng(ireac)) = specie formg(ireac,ng(ireac)) = form ELSE nm(ireac) = nm(ireac) + 1 coefm(ireac,nm(ireac)) = coeff rec1m(ireac,nm(ireac)) = rec1 namem(ireac,nm(ireac)) = specie formm(ireac,nm(ireac)) = form IF (rec1 .GE. rec1m2) THEN m2reac(ireac) = .TRUE. END IF END IF RETURN END ************************************************************************ *** openf - Returns .TRUE. and opens the file specified by fname, *** fstat, facces, fform, and frecl if this file exists and is *** accessible; otherwise, returns .FALSE. and prints an *** appropriate error message to the device specified by iterm. *** LOGICAL FUNCTION openf(iterm,iunit,fname,istat,iacces,iform,irecl) CHARACTER*11 fform(2) CHARACTER*10 facces(2) CHARACTER*20 fname CHARACTER*3 fstat(2) SAVE DATA fform / 'FORMATTED ', 'UNFORMATTED' / DATA facces / 'SEQUENTIAL', 'DIRECT ' / DATA fstat / 'OLD', 'NEW' / openf = .FALSE. IF ((iacces .LT. 1) .OR. (iacces .GT. 2) .OR. 1 (iform .LT. 1) .OR. (iform .GT. 2) .OR. 2 (istat .LT. 1) .OR. (istat .GT. 2)) GO TO 10 IF (iacces .EQ. 1) THEN OPEN(UNIT=iunit,FILE=fname,ACCESS=facces(iacces), 1 FORM=fform(iform),STATUS=fstat(istat),ERR=10) openf = .TRUE. RETURN ELSE OPEN(UNIT=iunit,FILE=fname,ACCESS=facces(iacces), 1 FORM=fform(iform),STATUS=fstat(istat),RECL=irecl, 2 ERR=10) openf = .TRUE. RETURN END IF 10 WRITE(iterm,20) 20 FORMAT(/,' nonexistant file or invalid specifications', 1 ' ... try again',/) RETURN END *** rep92 - Collection of routines that write the calculated standard *** molal thermodynamic properties of reactions to the TAB *** file and, optionally, the PLOT files. *** ********************************************************************* *** *** Author: James W. Johnson *** Earth Sciences Department, L-219 *** Lawrence Livermore National Laboratory *** Livermore, CA 94550 *** johnson@s05.es.llnl.gov *** *** Abandoned: 8 November 1991 *** ********************************************************************* *** tabtop - Write global header for output file. SUBROUTINE tabtop IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, NPLOTF = 8) LOGICAL savecf, saverf INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 univar, useLVS, epseqn, geqn, xyplot, end, 3 outflg DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) CHARACTER*4 incvar(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 pfname, namecf, namerf, nametf, namepf(NPLOTF), 1 nosave COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /dapron/ pfname COMMON /stvars/ isosat, isovar, incvar COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /headmp/ isov, incv, var3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 2 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /saveif/ savecf, saverf COMMON /plottr/ xyplot, end, nplots SAVE DATA nosave / 'file not saved ' / IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,71) 'Name ',isov(iopt,iplot), 1 incv(iopt,iplot),' TEMP(K) ' 71 FORMAT(A8,12x,2x,a10,2x,a10,4x,a10, 1 2x,' LOG_K DG(cal) DH(cal)', 2 ' DS(cal/K)') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,73) 'Name ',isov(iopt,iplot),' TEMP(K) ', 1 incv(iopt,iplot) 73 FORMAT(A8,12x,2x,a10,2x,a10,2x,a10, 1 2x,' LOG_K DG(cal) DH(cal)', 2 ' DS(cal/K)') endif else WRITE(tabf,5) 5 FORMAT(' ***** SUPCRT92: input/output specifications for', 1 ' this run',/) IF (savecf) THEN WRITE(tabf,15) namecf ELSE WRITE(tabf,15) nosave END IF 15 FORMAT( ' USER-SPECIFIED CON FILE containing ', 1 /,' T-P-D grid & option switches: ',a20,/) IF (saverf) THEN WRITE(tabf,25) namerf ELSE WRITE(tabf,25) nosave END IF 25 FORMAT( ' USER-SPECIFIED RXN FILE containing ', 1 /,' chemical reactions: ',a20,/) WRITE(tabf,35) pfname 35 FORMAT( ' THERMODYNAMIC DATABASE: ',a20,/) WRITE(tabf,45) nametf 45 FORMAT( ' SUPCRT-GENERATED TAB FILE containing ', 1 /,' tabulated reaction properties ', 2 '(this file): ',a20) IF (xyplot .GT. 0) THEN WRITE(tabf,47) namepf(1) 47 FORMAT(/,' SUPCRT-GENERATED PLT FILES containing ', 1 /,' reaction properties for x-y plots: ' 2 ,a20,' etc.') END IF CALL wrtopt endif END ******************************************************************* *** wrtopt - Write various switch options to tabular output file. SUBROUTINE wrtopt IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, NPLOTF = 8) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 2 univar, useLVS, epseqn, geqn, outflg DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) CHARACTER*4 incvar(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /stvars/ isosat, isovar, incvar COMMON /headmp/ isov, incv, var3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 2 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /fnames/ namecf, namerf, nametf, namepf SAVE WRITE(tabf,75) 75 FORMAT(/,' ***** summary of option switches ') WRITE(tabf,85) isat,iopt,iplot,univar,noninc 85 FORMAT( ' isat, iopt, iplot, univar, noninc: ',4i3,i4) *** useLVS, epseqn, geqn not written to TAB for distribution copies *** * WRITE(tabf,105) useLVS,epseqn,geqn * 105 FORMAT( ' useLVS, epseqn, geqn: ',3i3) WRITE(tabf,115) 115 FORMAT(/,' ***** summary of state conditions ') IF (noninc .EQ. 0) THEN IF (isat .EQ. 0) THEN WRITE(tabf,125) isovar(iopt,iplot),isomin,isomax,isoinc 125 FORMAT(12x,'ISO',a12,': min, max, increment:', 1 3(2x,f10.4)) WRITE(tabf,135) incv(iopt,iplot),v2min, v2max, v2inc 135 FORMAT(12x,a10,' range: min, max, increment:', 1 3(2x,f10.4)) ELSE WRITE(tabf,145) isosat(iopt),v2min, v2max, v2inc 145 FORMAT(12x,'saturation ',a10,' range: min, max,', 1 ' increment:',3(2x,f10.4)) END IF ELSE IF (isat .EQ. 0) THEN WRITE(tabf,155) isov(iopt,iplot), incv(iopt,iplot), 1 noninc 155 FORMAT(12x,'nonincremental ',a10,', ',a10, 1 ' coordinates: ',i3,' pair') ELSE WRITE(tabf,165) isosat(iopt), noninc 165 FORMAT(12x,'nonincremental saturation ',a10,': ',i3, 1 ' points') END IF END IF END ********************************************************************* *** wrtop2 - Write various switch options to plot file k. SUBROUTINE wrtop2(k) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXODD = 900, NPLOTF = 8) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 2 univar, useLVS, epseqn, geqn, outflg DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) CHARACTER*4 incvar(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /stvars/ isosat, isovar, incvar COMMON /headmp/ isov, incv, var3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 2 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /fnames/ namecf, namerf, nametf, namepf SAVE WRITE(plotf(k),75) 75 FORMAT(/,' ***** summary of option switches ',/) WRITE(plotf(k),85) isat,iopt,iplot,univar,noninc 85 FORMAT( ' isat, iopt, iplot, univar, noninc: ',4i3,i4) *** useLVS, epseqn, geqn not written to PLOT for distribution copies *** * WRITE(plotf(k),105) useLVS,epseqn,geqn * 105 FORMAT( ' useLVS, epseqn, geqn: ',3i3) WRITE(plotf(k),115) 115 FORMAT(/,' ***** summary of state conditions ',/) IF (noninc .EQ. 0) THEN IF (isat .EQ. 0) THEN WRITE(plotf(k),125) isovar(iopt,iplot), 1 isomin,isomax,isoinc 125 FORMAT(12x,'ISO',a12,': min, max, increment:', 1 3(2x,f10.4)) WRITE(plotf(k),135) incv(iopt,iplot),v2min, v2max, v2inc 135 FORMAT(12x,a10,' range: min, max, increment:', 1 3(2x,f10.4)) ELSE WRITE(plotf(k),145) isosat(iopt),v2min, v2max, v2inc 145 FORMAT(12x,'saturation ',a10,' range: min, max,', 1 ' increment:',3(2x,f10.4)) END IF ELSE IF (isat .EQ. 0) THEN WRITE(plotf(k),155) isov(iopt,iplot), incv(iopt,iplot), 1 noninc 155 FORMAT(12x,'nonincremental ',a10,', ',a10, 1 ' coordinates: ',i3,' pair') ELSE WRITE(plotf(k),165) isosat(iopt), noninc 165 FORMAT(12x,'nonincremental saturation ',a10,': ',i3, 1 ' points') END IF END IF WRITE(plotf(k),175) 175 FORMAT(/,86('*')) END *************************************************************** *** wrtrxn - Write header information for the i[th] reaction to *** tabulated output file tabf and (if appropriate) to *** the plot files. SUBROUTINE wrtrxn(i) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, 1 MXTRAN = 3, IABC = 4, MAXRXN = 800, NPLOTF = 8) CHARACTER*4 incvar(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 mname(MAXMIN), gname(MAXGAS), aname(MAXAQS) CHARACTER*30 mform(MAXMIN), gform(MAXGAS), aform(MAXAQS) CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN), nullrx INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 univar, useLVS, epseqn, geqn, xyplot, end, outflg INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) INTEGER ntran(MAXMIN) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) DOUBLE PRECISION Gfgas(MAXGAS), Hfgas(MAXGAS), VPrTrg(MAXGAS), 1 SPrTrg(MAXGAS), MKg(IABC,MAXGAS), Tmaxg(MAXGAS) DOUBLE PRECISION Gfaqs(MAXAQS), Hfaqs(MAXAQS), SPrTra(MAXAQS), 1 a(4,MAXAQS), c(2,MAXAQS), 2 wref(MAXAQS), chg(MAXAQS) COMMON /stvars/ isosat, isovar, incvar COMMON /headmp/ isov, incv, var3 COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /gnames/ gname, gform COMMON /gasref/ Gfgas, Hfgas, SPrTrg, VPrTrg, MKg, Tmaxg COMMON /anames/ aname, aform COMMON /aqsref/ Gfaqs, Hfaqs, SPrTra, c, a, wref, chg COMMON /plottr/ xyplot, end, nplots SAVE ***** write header to TAB file ***** IF (outflg.ne.2) WRITE(tabf,5) i 5 FORMAT(/,36('*'),' REACTION ',i3,2x,36('*'),/) ***** write reaction title and stoichiometry to TAB file ***** IF (outflg.ne.2) WRITE(tabf,15) rtitle(i) 15 FORMAT(' REACTION TITLE: ',/,6x,a80) IF (outflg.eq.2) goto 41 WRITE(tabf,25) 25 FORMAT(/,' REACTION STOICHIOMETRY: ') WRITE(tabf,26) 26 FORMAT(8x,' COEFF.',3x,'NAME',16x,3x,'FORMULA',22x,/, 3 8x,7('-'),3x,20('-'),3x,20('-')) ***** write reactants ***** IF (nm(i) .GT. 0) THEN DO 10 j = 1,nm(i) IF (coefm(i,j) .LT. 0.0d0) THEN WRITE(tabf,35) coefm(i,j), mname(j), mform(j) 35 FORMAT(6x,f9.3,3x,a20,3x,a30) END IF 10 CONTINUE END IF IF (ng(i) .GT. 0) THEN DO 20 j = 1,ng(i) IF (coefg(i,j) .LT. 0.0d0) THEN WRITE(tabf,36) coefg(i,j), gform(j)(1:20), gname(j) 36 FORMAT(6x,f9.3,3x,a20,3x,a20) END IF 20 CONTINUE END IF IF (na(i) .GT. 0) THEN DO 30 j = 1,na(i) IF (coefa(i,j) .LT. 0.0d0) THEN WRITE(tabf,35) coefa(i,j), aname(j), aform(j) END IF 30 CONTINUE END IF IF ((nw(i) .GT. 0) .AND. (coefw(i) .LT. 0.0d0)) THEN WRITE(tabf,55) coefw(i) 55 FORMAT(6x,f9.3,3x,'H2O',17x,3x,'H2O') END IF ***** write products ***** IF (nm(i) .GT. 0) THEN DO 11 j = 1,nm(i) IF (coefm(i,j) .GT. 0.0d0) THEN WRITE(tabf,35) coefm(i,j), mname(j), mform(j) END IF 11 CONTINUE END IF IF (ng(i) .GT. 0) THEN DO 21 j = 1,ng(i) IF (coefg(i,j) .GT. 0.0d0) THEN WRITE(tabf,36) coefg(i,j), gform(j)(1:20), gname(j) END IF 21 CONTINUE END IF IF (na(i) .GT. 0) THEN DO 31 j = 1,na(i) IF (coefa(i,j) .GT. 0.0d0) THEN WRITE(tabf,35) coefa(i,j), aname(j), aform(j) END IF 31 CONTINUE END IF IF ((nw(i) .GT. 0) .AND. (coefw(i) .GT. 0.0d0)) THEN WRITE(tabf,55) coefw(i) END IF 41 Continue ***** write standard state properties, equation-of-state ***** parameters, and heat capacity coefficients CALL wrtssp(i) ***** write header for property tabulation ***** IF (outflg.ne.2) WRITE(tabf,65) 65 FORMAT(/,' STANDARD STATE PROPERTIES OF THE REACTION', 1 ' AT ELEVATED TEMPERATURES AND PRESSURES ') CALL zero(i,nullrx) IF (nullrx) THEN WRITE(tabf,888) 888 FORMAT(' CAUTION: INCOMPLETE DATA FOR ONE OR MORE SPECIES',//) END IF IF (outflg.ne.2) Then WRITE(tabf,75) isov(iopt,iplot), 1 incv(iopt,iplot), 1 var3(iopt,iplot) 75 FORMAT(50x,' DELTA G ',1x, 1 1x,' DELTA H ',1x, 1 1x,' DELTA S ',1x, 1 1x,' DELTA V ',1x, 1 ' DELTA Cp ',1x,/, 1 2x,a10,2x,a10,2x,a10, 1 2x,' LOG K ',1x, 2 1x,' (cal) ',1x, 3 1x,' (cal) ',1x, 4 1x,' (cal/K) ',1x, 5 1x,' (cc) ',1x, 6 1x,' (cal/K) ',1x,/, 7 3(2x,10('-')),1x,6(1x,10('-'),1x)) Endif IF (xyplot .GT. 0) CALL pltrxn(i) END ***************************************************************** ***** zero - Zero-out NULL values for reaction i to eliminate their ***** contribution to standard molal properties at elevated ***** temperatures and pressures; set nullrx to .TRUE. if Gf ***** missing for mineral species or a1..4 for aqueous species. SUBROUTINE zero(i,nullrx) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, MXTRAN = 3, 1 IABC = 4, MAXRXN = 800) CHARACTER*20 mname(MAXMIN), aname(MAXAQS) CHARACTER*30 mform(MAXMIN), aform(MAXAQS) CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN), nullrx INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) INTEGER ntran(MAXMIN) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) DOUBLE PRECISION Gfaqs(MAXAQS), Hfaqs(MAXAQS), SPrTra(MAXAQS), 1 a(4,MAXAQS), c(2,MAXAQS), 2 wref(MAXAQS), chg(MAXAQS) COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /anames/ aname, aform COMMON /aqsref/ Gfaqs, Hfaqs, SPrTra, c, a, wref, chg COMMON /null/ XNULLM, XNULLA SAVE nullrx = .FALSE. DO 10 j = 1,nm(i) IF (Gfmin(j) .EQ. XNULLM) THEN nullrx = .TRUE. Gfmin(j) = 0.0d0 Hfmin(j) = 0.0d0 END IF IF (ntran(j) .GT. 0) THEN DO 20 k = 1,ntran(j) IF (Htran(k,j) .EQ. XNULLM) THEN Htran(k,j) = 0.0d0 END IF IF (Vtran(k,j) .EQ. XNULLM) THEN Vtran(k,j) = 0.0d0 END IF IF (dPdTtr(k,j) .EQ. XNULLM) THEN dPdTtr(k,j) = 0.0d0 END IF 20 CONTINUE END IF 10 CONTINUE DO 30 j = 1,na(i) IF (a(3,j) .EQ. XNULLA) THEN nullrx = .TRUE. DO 40 k = 1,4 a(k,i) = 0.0d0 40 CONTINUE END IF 30 CONTINUE END ***************************************************************** *** wrtssp - Write, to tabf, standard molal thermodynamic *** properties at 25 C and 1 bar, equation-of-state *** parameters, and heat capacity coefficients for all *** species in the i[th] reaction. SUBROUTINE wrtssp(i) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, MAXRXN = 800, 1 MXTRAN = 3, IABC = 4, MAXMK = 4, NPLOTF = 8, 2 ACON = 1.0d0, BCON = 1.0d3, CCON = 1.0d-5, 3 A1CON = 1.0d1, A2CON = 1.0d-2, 4 A3CON = 1.0d0, A4CON = 1.0d-4, 5 C1CON = 1.0d0, C2CON = 1.0d-4, 6 WCON = 1.0d-5) CHARACTER*4 incvar(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3), isosat(2) CHARACTER*12 isovar(2,3) CHARACTER*20 mname(MAXMIN), gname(MAXGAS), aname(MAXAQS), 1 wname CHARACTER*30 mform(MAXMIN), gform(MAXGAS), aform(MAXAQS) CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN), nullrx INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 univar, useLVS, epseqn, geqn, 2 mapiso(2,3), mapinc(2,3), mapv3(2,3), outflg INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS), phaser(MAXMIN) INTEGER ntran(MAXMIN) DOUBLE PRECISION logKr, TPDref(4) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) DOUBLE PRECISION Gfgas(MAXGAS), Hfgas(MAXGAS), VPrTrg(MAXGAS), 1 SPrTrg(MAXGAS), MKg(IABC,MAXGAS), Tmaxg(MAXGAS) DOUBLE PRECISION Gfaqs(MAXAQS), Hfaqs(MAXAQS), SPrTra(MAXAQS), 1 a(4,MAXAQS), c(2,MAXAQS), 2 wref(MAXAQS), chg(MAXAQS) DOUBLE PRECISION Vmin(MAXMIN), Smin(MAXMIN), Cpmin(MAXMIN), 2 Hmin(MAXMIN), Gmin(MAXMIN) DOUBLE PRECISION Vgas(MAXGAS), Sgas(MAXGAS), Cpgas(MAXGAS), 2 Hgas(MAXGAS), Ggas(MAXGAS) DOUBLE PRECISION Vaqs(MAXAQS), Saqs(MAXAQS), Cpaqs(MAXAQS), 2 Haqs(MAXAQS), Gaqs(MAXAQS), 3 VQterm(MAXAQS), SYterm(MAXAQS), CpXtrm(MAXAQS), 4 HYterm(MAXAQS), GZterm(MAXAQS) DOUBLE PRECISION mwH2O, Gftemp(MAXMIN), Hftemp(MAXMIN), 1 a3temp(MAXAQS) COMMON /stvars/ isosat, isovar, incvar COMMON /headmp/ isov, incv, var3 COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /gnames/ gname, gform COMMON /gasref/ Gfgas, Hfgas, SPrTrg, VPrTrg, MKg, Tmaxg COMMON /anames/ aname, aform COMMON /aqsref/ Gfaqs, Hfaqs, SPrTra, c, a, wref, chg COMMON /H2Oss/ Dwss, Vwss, bewss, alwss, dalwss, Swss, 1 Cpwss, Hwss, Gwss, Zwss, Qwss, Ywss, Xwss COMMON /minsp/ Vmin, Smin, Cpmin, Hmin, Gmin, phaser COMMON /gassp/ Vgas, Sgas, Cpgas, Hgas, Ggas COMMON /aqsp/ Vaqs, Saqs, Cpaqs, Haqs, Gaqs COMMON /solvn/ VQterm, SYterm, CpXtrm, HYterm, GZterm COMMON /fmeq/ dVr, dSr, dCpr, dHr, dGr, logKr, dlogKT, dlogKP COMMON /null/ XNULLM, XNULLA SAVE DATA wname / 'H2O ' / ***** remove NULL contributions to standard state calculations nullrx = .FALSE. DO 456 iii = 1, nm(i) Gftemp(iii) = 0.0d0 IF (Gfmin(iii) .EQ. XNULLM) THEN nullrx = .TRUE. Gftemp(iii) = Gfmin(iii) Hftemp(iii) = Hfmin(iii) Gfmin(iii) = 0.0d0 Hfmin(iii) = 0.0d0 END IF 456 CONTINUE DO 556 iii = 1, na(i) a3temp(iii) = 0.0d0 IF (a(3,iii) .EQ. XNULLA) THEN nullrx = .TRUE. a3temp(iii) = a(3,iii) DO 557 jjj = 1,4 a(jjj,iii) = 0.0d0 557 CONTINUE END IF 556 CONTINUE ***** calculate all reaction species heat capacities and reactant ***** aqueous species standard partial molal volumes at ***** 25 degC, 1 bar CALL reac92(i,Pref,Tref-273.15d0,Dwss,Vwss,bewss,alwss,dalwss, 1 Swss,Cpwss,Hwss,Gwss,Zwss,Qwss,Ywss,Xwss,geqn) ***** return NULL contributions to faciltate blanking DO 457 iii = 1, nm(i) IF (Gftemp(iii) .EQ. XNULLM) THEN Gfmin(iii) = Gftemp(iii) Hfmin(iii) = Hftemp(iii) END IF 457 CONTINUE DO 656 iii = 1, na(i) IF (a3temp(iii) .EQ. XNULLA) a(3,iii) = a3temp(iii) 656 CONTINUE IF (outflg.eq.2) goto 989 WRITE(tabf,5) 5 FORMAT(/,' STANDARD STATE PROPERTIES OF THE SPECIES AT', 1 ' 25 DEG C AND 1 BAR') IF (nm(i) .GT. 0) THEN WRITE(tabf,6) 6 FORMAT(/,42x,' ...... MINERALS ...... ',/, 1 24x,' DELTA G ',1x, 1 1x,' DELTA H ',1x, 1 1x,' S ',1x, 1 1x,' V ',1x, 1 1x,' Cp ',1x,/, 1 7x,'NAME',12x, 1 1x,' (cal/mol) ',1x, 2 1x,' (cal/mol) ',1x, 3 1x,' (cal/mol/K) ',1x, 4 1x,' (cc/mol) ',1x, 5 1x,' (cal/mol/K) ',/, 6 2x,20('-'),2x,13('-'),2x,13('-'),2x,13('-'), 7 2x,13('-'),2x,13('-')) ***** write mineral G, H, S, V, Cp at 25 C, 1 bar ***** DO 10 j = 1,nm(i) IF (Gfmin(j) .EQ. XNULLM) THEN WRITE(tabf,14) mname(j), SPrTrm(j), 1 VPrTrm(j), Cpmin(j) 14 FORMAT(2x,a20,30x,5x,f8.3,3x,4x,f8.3,4x,4x,f6.1,6x) ELSE WRITE(tabf,15) mname(j), Gfmin(j), Hfmin(j), 1 SPrTrm(j), VPrTrm(j), Cpmin(j) 15 FORMAT(2x,a20,3x,f10.0,2x,3x,f10.0,2x,5x,f8.3,3x, 1 4x,f8.3,4x,4x,f6.1,6x) END IF 10 CONTINUE WRITE(tabf,7) 7 FORMAT(/,24x,' HEAT CAPACITY COEFFICIENTS ', 1 32x,'PHASE TRANSITION DATA',/, 1 7x,'NAME',11x, 1 1x,' a(10**0) ', 2 ' b(10**3) ', 3 ' c(10**-5) ', 3 1x,' d(10**0) ', 4 1x,' T limit (C)', 5 1x,' Htr (cal/mol)',1x, 6 1x,' Vtr (cc/mol) ',1x, 7 1x,'dPdTtr (bar/K)',1x,/, 8 2x,20('-'), 9 2x,10('-'),1x, 1 1x,10('-'),1x, 1 1x,10('-'),1x, 1 1x,12('-'),1x, 2 1x,11('-'),1x, 3 1x,13('-'),1x, 4 1x,14('-'),1x, 5 1x,14('-'),1x) DO 11 j = 1,nm(i) ***** write mineral heat capacity coefficients ***** a, b, c, d and phase transition T, H, V, dPdT IF (ntran(j) .EQ. 0) THEN WRITE(tabf,16) mname(j), MK1(1,j)*ACON, 1 MK1(2,j)*BCON, MK1(3,j)*CCON, 2 MK1(4,j)*ACON, 3 Tmaxm(j)-273.15d0 16 FORMAT(2x,a20,1x,f9.3,2x,1x,f9.3,2x,1x,f9.3, 1 2x,1x,f11.3,2x,3x,f7.2) ELSE *** following block IFs designed to eliminate *** printing of unknown (i.e., zero-valued) *** Htran, Vtran, dPdTtr. IF (Htran(1,j) .EQ. XNULLM) THEN WRITE(tabf,19) mname(j), MK1(1,j)*ACON, 1 MK1(2,j)*BCON, MK1(3,j)*CCON, 2 MK1(4,j)*ACON, 3 Ttran(1,j)-273.15d0 19 FORMAT(2x,a20,1x,f9.3,2x,1x,f9.3,2x,1x,f9.3, 1 2x,1x,f11.3,2x,3x,f7.2,3x) ELSE IF (Vtran(1,j) .EQ. XNULLM) THEN WRITE(tabf,119) mname(j), MK1(1,j)*ACON, 1 MK1(2,j)*BCON, MK1(3,j)*CCON, 2 MK1(4,j)*ACON, 2 Ttran(1,j)-273.15d0, Htran(1,j) 119 FORMAT(2x,a20,1x,f9.3,2x,1x,f9.3,2x,1x,f9.3, 1 2x,1x,f11.3, 1 2x,3x,f7.2,3x,5x,f6.0,5x) ELSE WRITE(tabf,219) mname(j), MK1(1,j)*ACON, 1 MK1(2,j)*BCON, MK1(3,j)*CCON, 2 MK1(4,j)*ACON, 2 Ttran(1,j)-273.15d0, Htran(1,j), 3 Vtran(1,j), dPdTtr(1,j) 219 FORMAT(2x,a20,1x,f9.3,2x,1x,f9.3,2x,1x,f9.3, 1 2x,1x,f11.3, 1 2x,3x,f7.2,3x,5x,f6.0,5x,4x,f7.3,5x, 2 4x,f7.3,5x) END IF END IF IF (ntran(j) .GE. 2) THEN IF (Htran(2,j) .EQ. XNULLM) THEN WRITE(tabf,25) 1, MK2(1,j)*ACON, 1 MK2(2,j)*BCON, MK2(3,j)*CCON, MK2(4,j)*acon, 2 Ttran(2,j)-273.15d0 25 FORMAT(4x,'post-transition ',i1,1x, 1 1x,f9.3,2x,1x,f9.3,2x,1x,f9.3,2x, 2 2x,1x,f9.3,3x,f7.2,3x) ELSE IF (Vtran(2,j) .EQ. XNULLM) THEN WRITE(tabf,125) 1, MK2(1,j)*ACON, 1 MK2(2,j)*BCON, MK2(3,j)*CCON, 2 MK2(4,j)*ACON, 2 Ttran(2,j)-273.15d0, Htran(2,j) 125 FORMAT(4x,'post-transition ',i1,1x, 1 1x,f9.3,2x,1x,f9.3,2x,1x,f9.3,2x, 2 2x,1x,f9.3,2x, 2 3x,f7.2,3x,5x,f6.0,5x) ELSE WRITE(tabf,225) 1, MK2(1,j)*ACON, 1 MK2(2,j)*BCON, MK2(3,j)*CCON, 2 MK2(4,j)*ACON, 2 Ttran(2,j)-273.15d0, Htran(2,j), 3 Vtran(2,j), dPdTtr(2,j) 225 FORMAT(4x,'post-transition ',i1,1x, 1 1x,f9.3,2x,1x,f9.3,2x,1x,f9.3,2x, 2 2x,1x,f9.3,2x, 2 3x,f7.2,3x,5x,f6.0,5x,4x,f7.3,5x, 3 4x,f7.3,5x) END IF END IF END IF IF (ntran(j) .GE. 3) THEN IF (Htran(3,j) .EQ. XNULLM) THEN WRITE(tabf,25) 2, MK3(1,j)*ACON, 1 MK3(2,j)*BCON, MK3(3,j)*CCON, 2 MK3(4,j)*ACON, 2 Ttran(3,j)-273.15d0 ELSE IF (Vtran(3,j) .EQ. XNULLM) THEN WRITE(tabf,125) 2, MK3(1,j)*ACON, 1 MK3(2,j)*BCON, MK3(3,j)*CCON, 2 MK3(4,j)*ACON, 2 Ttran(3,j)-273.15d0, Htran(3,j) ELSE WRITE(tabf,225) 2, MK3(1,j)*ACON, 1 MK3(2,j)*BCON, MK3(3,j)*CCON, 2 MK3(4,j)*ACON, 2 Ttran(3,j)-273.15d0, Htran(3,j), 3 Vtran(3,j), dPdTtr(3,j) END IF END IF END IF IF (ntran(j) .EQ. 1) THEN WRITE(tabf,39) ntran(j), MK2(1,j)*ACON, 1 MK2(2,j)*BCON,MK2(3,j)*CCON, 2 MK2(4,j)*ACON, Tmaxm(j)-273.15d0 39 FORMAT(4x,'post-transition ',i1,1x,1x,f9.3,2x, 1 1x,f9.3,2x,1x,f9.3,2x,3x,f9.3,2x,3x,f7.2) END IF IF (ntran(j) .EQ. 2) THEN WRITE(tabf,39) ntran(j), MK3(1,j)*ACON, 1 MK3(2,j)*BCON,MK3(3,j)*CCON, 2 MK3(4,j)*ACON,Tmaxm(j)-273.15d0 END IF IF (ntran(j) .EQ. 3) THEN WRITE(tabf,39) ntran(j), MK4(1,j)*ACON, 1 MK4(2,j)*BCON,MK4(3,j)*CCON, 2 MK4(4,j)*ACON,Tmaxm(j)-273.15d0 END IF END IF 11 CONTINUE END IF IF (ng(i) .GT. 0) THEN WRITE(tabf,8) 8 FORMAT(/,42x,' ...... GASES ...... ',/, 1 24x,' DELTA G ',1x, 1 1x,' DELTA H ',1x, 1 1x,' S ',1x, 1 1x,' V ',1x, 1 1x,' Cp ',1x,/, 1 7x,'NAME',12x, 1 1x,' (cal/mol) ',1x, 2 1x,' (cal/mol) ',1x, 3 1x,' (cal/mol/K) ',1x, 4 1x,' (cc/mol) ',1x, 5 1x,' (cal/mol/K) ',/, 6 2x,20('-'),2x,13('-'),2x,13('-'),2x,13('-'), 7 2x,13('-'),2x,13('-')) ***** write gas G, H, S, V, Cp at 25 C, 1 bar and Maier-Kelly ***** heat capacity coefficients a, b, c DO 30 j = 1,ng(i) WRITE(tabf,17) gname(j), Gfgas(j), Hfgas(j), 1 SPrTrg(j), VPrTrg(j), Cpgas(j) 17 FORMAT(2x,a20, 1 3x,f10.0,2x, 2 3x,f10.0,2x, 3 5x,f8.3,3x, 4 7x,f2.0,7x, 5 4x,f6.1,6x) 30 CONTINUE WRITE(tabf,9) 9 FORMAT(/,29x,'MAIER-KELLY COEFFICIENTS',/, 1 7x,'NAME',11x, 1 1x,' a(10**0) ', 2 ' b(10**3) ', 3 ' c(10**-5) ', 4 ' T limit (C)',/, 4 2x,20('-'), 5 2x,10('-'),1x, 6 1x,10('-'),1x, 6 1x,10('-'),1x, 7 1x,10('-')) DO 31 j = 1,ng(i) WRITE(tabf,16) gname(j), MKg(1,j)*ACON, 1 MKg(2,j)*BCON, MKg(3,j)*CCON, 2 MKg(4,j)*ACON, 2 Tmaxg(j)-273.15d0 31 CONTINUE END IF IF ((na(i) .GT. 0) .OR. (nw(i) .GT. 0)) THEN WRITE(tabf,46) 46 FORMAT(/,36x,' ...... AQUEOUS SPECIES ...... ',/, 1 24x,' DELTA G ',1x, 1 1x,' DELTA H ',1x, 1 1x,' S ',1x, 1 1x,' V ',1x, 1 1x,' Cp ',1x,/, 1 7x,'NAME',12x, 1 1x,' (cal/mol) ',1x, 2 1x,' (cal/mol) ',1x, 3 1x,' (cal/mol/K) ',1x, 4 1x,' (cc/mol) ',1x, 5 1x,' (cal/mol/K) ',/, 6 2x,20('-'),2x,13('-'),2x,13('-'),2x,13('-'), 7 2x,13('-'),2x,13('-')) ***** write aqueous species G, H, S, V, Cp at 25 C, 1 bar DO 40 j = 1,na(i) WRITE(tabf,79) aname(j), Gfaqs(j), Hfaqs(j), 1 SPrTra(j), Vaqs(j), Cpaqs(j) 79 FORMAT(2x,a20, 1 3x,f10.0,2x, 2 3x,f10.0,2x, 3 5x,f8.3,3x, 4 5x,f6.1,5x, 5 4x,f6.1,6x) 40 CONTINUE IF (nw(i) .GT. 0) THEN ***** write H2O G, H, S, V, Cp at 25 C, 1 bar ****** WRITE(tabf,79) wname, Gwss, Hwss, 1 Swss, Vwss, Cpwss END IF IF (na(i) .GT. 0) THEN WRITE(tabf,56) 56 FORMAT(/,50x,'EQUATION-OF-STATE COEFFICIENTS',/, 1 7x,'NAME',11x, 1 2x,' a1(10**1) ',1x, 1 1x,' a2(10**-2) ',1x, 1 1x,' a3(10**0) ',1x, 1 1x,' a4(10**-4) ',1x, 2 1x,' c1(10**0) ',1x, 3 1x,' c2(10**-4) ', 1 2x,'omega(10**-5)',/, 4 2x,20('-'), 5 2x,12('-'),1x, 6 1x,12('-'),1x, 6 1x,12('-'),1x, 6 1x,12('-'),1x, 6 1x,12('-'),1x, 6 1x,12('-'),1x, 6 1x,13('-')) ***** write aqueous species equation-of-state parameters ***** wref, c[1..4], a[1..2] DO 50 j = 1,na(i) IF (a(3,j) .EQ. XNULLA) THEN WRITE(tabf,64) aname(j), 2 c(1,j)*C1CON, c(2,j)*C2CON, wref(j)*WCON 64 FORMAT(2x,a20,1x,56x,3(3x,f8.4,3x)) ELSE WRITE(tabf,65) aname(j), 1 a(1,j)*A1CON, a(2,j)*A2CON, a(3,j)*A3CON, 2 a(4,j)*A4CON, c(1,j)*C1CON, c(2,j)*C2CON, 3 wref(j)*WCON 65 FORMAT(2x,a20,1x,7(3x,f8.4,3x)) END IF 50 CONTINUE END IF END IF ***** write reaction properties at 25 C, 1 bar WRITE(tabf,74) 74 FORMAT(/,' STANDARD STATE PROPERTIES OF THE REACTION AT', 1 ' 25 DEG C AND 1 BAR') IF (nullrx) THEN WRITE(tabf,888) 888 FORMAT(' CAUTION: INCOMPLETE DATA FOR ONE OR MORE SPECIES',/) END IF WRITE(tabf,75) isov(iopt,iplot), incv(iopt,iplot), 1 var3(iopt,iplot) 75 FORMAT(50x,' DELTA G ',1x, 1 1x,' DELTA H ',1x, 1 1x,' DELTA S ',1x, 1 1x,' DELTA V ',1x, 1 ' DELTA Cp ',1x,/, 1 2x,a10,2x,a10,2x,a10, 1 2x,' LOG K ',1x, 2 1x,' (cal) ',1x, 3 1x,' (cal) ',1x, 4 1x,' (cal/K) ',1x, 5 1x,' (cc) ',1x, 6 1x,' (cal/K) ',1x,/, 7 3(2x,10('-')),1x,6(1x,10('-'),1x)) TPDref(1) = Tref - 273.15d0 TPDref(2) = Pref TPDref(3) = Dwss TPDref(4) = Dwss WRITE(tabf,85) TPDref(mapiso(iopt,iplot)), 1 TPDref(mapinc(iopt,iplot)), 2 TPDref(mapv3(iopt,iplot)), 3 logKr, dGr, dHr, dSr, dVr, dCpr 85 FORMAT(3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f10.0,1x, 3 1x,f10.0,1x, 4 1x,f9.1,2x, 5 1x,f9.1,2x, 6 1x,f9.1) 989 Continue END ****************************************************************** *** pltrxn - Write header information and reaction titles *** to plot files. SUBROUTINE pltrxn(ireac) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8, MAXRXN = 800, MXRPLT = 10) CHARACTER*80 rtitle(MAXRXN) CHARACTER*20 namecf, namerf, nametf, namepf(NPLOTF) CHARACTER*3 rstamp(MXRPLT) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 xyplot, end, rlen(2), outflg LOGICAL openf COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /plottr/ xyplot, end, nplots COMMON /reac1/ rtitle SAVE DATA rlen / 80, 249 / DATA rstamp / 'R01', 'R02', 'R03', 'R04', 'R05', 1 'R06', 'R07', 'R08', 'R09', 'R10' / *** close files if necessary IF ((xyplot .EQ. 2) .AND. (ireac .GT. 1)) THEN DO 10 i = 1,nplots CLOSE(UNIT=plotf(i)) namepf(i)(end+1:end+3) = rstamp(ireac) 10 CONTINUE END IF *** if necessary, open files and write header IF ((xyplot .EQ. 2) .OR. (ireac .EQ. 1)) THEN DO 20 i = 1,nplots IF (openf(wterm,plotf(i),namepf(i),2,1,1, 1 rlen(xyplot))) THEN CALL plttop(i) ELSE WRITE(wterm,*) ' cannot open plot file ',i END IF 20 CONTINUE END IF *** write reaction number and title DO 30 i = 1,nplots WRITE(plotf(i),40) ireac, rtitle(ireac) 40 FORMAT(//,' REACTION ',i3, 1 /,' TITLE: ',a80) 30 CONTINUE END ********************************************************************** *** plttop - Write global banner to plot file i. SUBROUTINE plttop(i) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8) CHARACTER*20 pfname, namecf, namerf, nametf, namepf(NPLOTF), 1 nosave LOGICAL savecf, saverf INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 xyplot, end, outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /fnames/ namecf, namerf, nametf, namepf COMMON /saveif/ savecf, saverf COMMON /plottr/ xyplot, end, nplots COMMON /dapron/ pfname SAVE DATA nosave / 'file not saved ' / WRITE(plotf(i),20) 20 FORMAT(/,' ***** SUPCRT92: input/output specifications for', 1 ' this run',/) IF (savecf) THEN WRITE(plotf(i),30) namecf 30 FORMAT( ' USER-SPECIFIED CON FILE containing ', 1 /,' T-P-D grid & option switches: ',a20,/) ELSE WRITE(plotf(i),30) nosave END IF IF (saverf) THEN WRITE(plotf(i),40) namerf 40 FORMAT( ' USER-SPECIFIED RXN FILE containing ', 1 /,' chemical reactions: ',a20,/) ELSE WRITE(plotf(i),40) nosave END IF WRITE(plotf(i),50) pfname 50 FORMAT( ' THERMODYNAMIC DATABASE: ',a20,/) WRITE(plotf(i),60) nametf 60 FORMAT(' SUPCRT-GENERATED TAB FILE containing ', 1 /,' tabulated reaction properties: ',a20) CALL wrtop2(i) END ********************************************************************* *** report - Report computed reaction properties. SUBROUTINE report(ireac, iso, inc, TPD, TPDtrn, rptran, ptrans, 1 dVr, dSr, dCpr, dHr, dGr, logKr, 2 lvdome, H2Oerr, Kfound) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800, 1 MXTRAN = 3, IABC = 4, NPLOTF = 8, MAXODD = 900) CHARACTER*1 PT(2) CHARACTER*5 pprop(NPLOTF) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3) CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN), mnform, aqform CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN), xall, xHSVCp, xCp, 1 MKwarn, MKdone, Pwarn, Pdone, Kfound, Klost LOGICAL rptran, lvdome, H2Oerr, EQ3run INTEGER phaser(MAXMIN), ptrans(MAXMIN), ntran(MAXMIN), 1 xyplot, end INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 univar, useLVS, epseqn, geqn, outflg INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) DOUBLE PRECISION TPD(3), TPDtrn(MAXMIN,MXTRAN,3), logKr DOUBLE PRECISION Vmin(MAXMIN), Smin(MAXMIN), Cpmin(MAXMIN), 2 Hmin(MAXMIN), Gmin(MAXMIN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN), mvolum DOUBLE PRECISION isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 1 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /minsp/ Vmin, Smin, Cpmin, Hmin, Gmin, phaser COMMON /headmp/ isov, incv, var3 COMMON /EQ36/ EQ3run COMMON /plottr/ xyplot, end, nplots Common /solth1/ mvolum Common /solth2/ mnform, aqform SAVE DATA PT / 'P', 'T' / DATA MKdone, Pdone / 2*.FALSE. / DATA pprop / 'logK ', 'delG ', 'delH ', 'delS ', 1 'delCp', 'delV ', 'dvar1', 'dvar2' / IF ((inc .EQ. 1)) THEN MKdone = .FALSE. Pdone = .FALSE. * For generating Soltherm records, with one gas or mineral only. IF (outflg.eq.2.and.((ng(ireac).eq.1.and.nm(ireac).eq.0).or. 1 (ng(ireac).eq.0.and.nm(ireac).eq.1))) then write(tabf,5) rtitle(ireac), mnform, 1 'volume, cc/mol =', mvolum GOTO 777 END IF * For reactions with more than one mineral or gas in full P-T grid, * e.g. FMQ buffers, and still write rtitle(ireac). IF (outflg.eq.2.and.(ng(ireac).ge.1.or.nm(ireac).ge.1)) 1 write(tabf,5) rtitle(ireac) 5 FORMAT (A20,2x,A30,2x,A16,F8.3) * For generating Soltherm records, aqueous species. 777 IF (outflg.eq.2.and.ng(ireac).eq.0.and.nm(ireac).eq.0) 1 write(tabf,5) rtitle(ireac), aqform IF (xyplot .EQ. 1) THEN CALL pltln1(TPD) END IF END IF IF ((xyplot .EQ. 2) .AND. (iso .EQ. 1) .AND. (inc .EQ. 1)) THEN CALL pltln1(TPD) END IF IF (lvdome) THEN ***** T,DH2O location falls within liquid-vapor dome IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,11) rtitle(ireac), TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapinc(iopt,iplot))+273.15d0 11 FORMAT(A20,3(2x,f9.3,1x),35x, 1 ' T-DH2O FALLS WITHIN LIQ-VAP T-DH2O DOME ') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,13) rtitle(ireac), TPD(mapiso(iopt,iplot)), 1 TPD(mapiso(iopt,iplot))+273.15d0, 2 TPD(mapinc(iopt,iplot)) 13 FORMAT(A20,3(2x,f9.3,1x),35x, 1 ' T-DH2O FALLS WITHIN LIQ-VAP T-DH2O DOME ') endif Else WRITE(tabf,15) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)) 15 FORMAT(2(2x,f9.3,1x),23x, 1 ' T-DH2O FALLS WITHIN LIQ-VAP T-DH2O DOME ') Endif END IF IF (H2Oerr) THEN ***** T-P-d beyond fluid H2O equation of state IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,516) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapinc(iopt,iplot)), 3 TPD(mapinc(iopt,iplot))+273.15d0, 4 99999.999d0,9999999.9d0, 9999999.9d0 516 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,2x,f11.1,3x,f11.1,3x, 1 '*** BEYOND RANGE OF APPLICABILITY OF ', 2 'H2O EQUATION OF STATE **') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,517) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapiso(iopt,iplot))+273.15d0, 3 TPD(mapinc(iopt,iplot)),99999.999d0, 4 9999999.9d0, 9999999.9d0 517 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,2x,f11.1,3x,f11.1,3x, 1 '*** BEYOND RANGE OF APPLICABILITY OF ', 2 'H2O EQUATION OF STATE **') endif Else WRITE(tabf,16) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)) 16 FORMAT(2(2x,f9.3,1x),14x,' *** BEYOND RANGE OF', 1 ' APPLICABILITY OF H2O EQUATION OF STATE **') Endif END IF Klost = (univar .EQ. 1) .AND. (.NOT. Kfound) IF (Klost) THEN WRITE(tabf,17) TPD(mapiso(iopt,iplot)), logKr, 1 v2min, PT(2/iplot), v2max 17 FORMAT(2x,f9.3,26x,f10.3,4x, 1 ' LOG K NOT FOUND: ',f10.3,' <= ',a1,' <= ',f10.3) END IF IF (rptran) THEN DO 20 imin = 1,nm(ireac) DO 25 itran = ptrans(imin),1,-1 IF ((iplot .EQ. 2) .AND. (isat .EQ. 0)) THEN *** isotherms(P,D): phase c -> b -> a iptnum = phaser(imin) ELSE *** iso[bars,chores](T): phase a -> b -> c iptnum = phaser(imin)-itran END IF IF (outflg.ne.2) then WRITE(tabf,30) 1 TPDtrn(imin,itran,mapiso(iopt,iplot)), 2 TPDtrn(imin,itran,mapinc(iopt,iplot)), 3 TPDtrn(imin,itran,mapv3(iopt,iplot)-isat), 4 iptnum, mname(imin) 30 FORMAT(3(2x,f9.3,1x),11x, 1 ' PHASE TRANSITION #',i1,' for ', 2 a20,/) endif 25 CONTINUE 20 CONTINUE END IF ******************************************************************* *** Assignment of "blank" variables below facilitates full *** reporting of reaction properties beyond certain limits *** of certain equations when the CALL to SUBR blank is *** commented-out for the development version. xall = .FALSE. xHSVCp = .FALSE. xCp = .FALSE. MKwarn = .FALSE. Pwarn = .FALSE. *** SUBR blanks to be called for distribution version; *** not called for development version IF (.NOT. (lvdome .OR. H2Oerr)) 1 CALL blanks(TPD(1),TPD(2),TPD(3),m2reac(ireac),nm(ireac), 2 ng(ireac),na(ireac),xall,xHSVCp,xCp,MKwarn,Pwarn) ***** write reaction properties to plot files IF (xyplot .GT. 0) 1 CALL pltrep(TPD,iso,inc,logKr,dGr,dHr,dSr,dCpr,dVr, 2 lvdome,H2Oerr,Klost,xall,xHSVCp,xCp) IF (lvdome .OR. H2Oerr .OR. Klost) RETURN ******************************************************************* ***** write reaction properties to tab file IF (xall) THEN ***** P-T beyond validity limits of ***** aqueous species equations IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,36) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapinc(iopt,iplot)), 3 TPD(mapinc(iopt,iplot))+273.15d0, 4 99999.999d0,9999999.9d0, 9999999.9d0 36 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,2x,f11.1,3x,f11.1,3x, 1 'BEYOND RANGE OF APPLICABILITY OF ', 2 'AQUEOUS SPECIES EQNS') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,38) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapiso(iopt,iplot))+273.15d0, 3 TPD(mapinc(iopt,iplot)),99999.999d0, 4 9999999.9d0, 9999999.9d0 38 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,2x,f11.1,3x,f11.1,3x, 1 'BEYOND RANGE OF APPLICABILITY OF ', 2 'AQUEOUS SPECIES EQNS') endif Else WRITE(tabf,40) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapv3(iopt,iplot)-isat) 40 FORMAT(3(2x,f9.3,1x),2x,' *** BEYOND RANGE OF', 1 ' APPLICABILITY OF AQUEOUS SPECIES EQNS ***') Endif RETURN END IF IF (xHSVCp) THEN ***** P-T within region where only Gibbs free energy can ***** be computed for charged aqueous species IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,41) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapinc(iopt,iplot)), 3 TPD(mapinc(iopt,iplot))+273.15d0, 4 logKr, dGr, dHr 41 FORMAT(A20,3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f11.1,3x,f11.1,3x, 3 '*** DELTA G ONLY (CHARGED AQUEOUS SPECIES) ***') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,43) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapiso(iopt,iplot))+273.15d0, 3 TPD(mapinc(iopt,iplot)), 4 logKr, dGr, dHr 43 FORMAT(A20,3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f11.1,3x,f11.1,3x, 3 '*** DELTA G ONLY (CHARGED AQUEOUS SPECIES) ***') endif else WRITE(tabf,45) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapv3(iopt,iplot)-isat), logKr, dGr 45 FORMAT(3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f10.0,3x, 3 '*** DELTA G ONLY (CHARGED AQUEOUS SPECIES) ***') endif RETURN END IF IF (MKwarn .AND. (.NOT. MKdone)) THEN ***** beyond temperature limit of Maier-Kelly Cp coefficients; ***** issue warning to this effect. MKdone = .TRUE. * Supcrt wants to write error message here and delta G elsewhere on * separate lines in output, unlike block immediately above. * Comment out for now. * IF (outflg.eq.2) Then * If (iplot.eq.1) then * WRITE(tabf,46) rtitle(ireac), * 1 TPD(mapiso(iopt,iplot)), * 2 TPD(mapinc(iopt,iplot)), * 3 TPD(mapinc(iopt,iplot))+273.15d0,99999.999d0 * 46 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,15x, * 1 ' *** CAUTION: BEYOND P LIMIT OF', * 1 ' CP COEFFS FOR A MINERAL OR GAS') * endif * If (iplot.eq.2.or.iplot.eq.3) then * WRITE(tabf,47) rtitle(ireac), * 1 TPD(mapiso(iopt,iplot)), * 2 TPD(mapiso(iopt,iplot))+273.15d0, * 3 TPD(mapinc(iopt,iplot)),99999.999d0 * 47 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,15x, * 1 ' *** CAUTION: BEYOND P LIMIT OF', * 1 ' CP COEFFS FOR A MINERAL OR GAS') * endif * Else IF (outflg.ne.2) Then WRITE(tabf,48) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapv3(iopt,iplot)-isat) 48 FORMAT(3(2x,f9.3,1x),2x,' *** CAUTION: BEYOND T LIMIT', 1 ' OF CP COEFFS FOR A MINERAL OR GAS ***') Endif END IF IF (Pwarn .AND. (.NOT. Pdone)) THEN ***** beyond qualitative pressure limit of mineral/gas calculations; ***** issue warning to this effect. Pdone = .TRUE. IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,52) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapinc(iopt,iplot)), 3 TPD(mapinc(iopt,iplot))+273.15d0, 4 99999.999d0,9999999.9d0, 9999999.9d0 52 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,2x,f11.1,3x,f11.1,3x, 1 ' *** CAUTION: BEYOND P LIMIT OF', 1 ' APPROXIMATIONS IN MINERAL/GAS EQNS ***') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,53) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapiso(iopt,iplot))+273.15d0, 3 TPD(mapinc(iopt,iplot)),99999.999d0, 4 9999999.9d0, 9999999.9d0 53 FORMAT(A20,3(2x,f9.3,1x),1x,F10.3,2x,f11.1,3x,f11.1,3x, 1 ' *** CAUTION: BEYOND P LIMIT OF', 1 ' APPROXIMATIONS IN MINERAL/GAS EQNS ***') endif Else WRITE(tabf,55) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapv3(iopt,iplot)-isat) 55 FORMAT(3(2x,f9.3,1x),2x,' *** CAUTION: BEYOND P LIMIT', 1 ' OF APPROXIMATIONS IN MINERAL/GAS EQNS ***') Endif END IF IF (xCp) THEN ***** within +/- 25 degC of mineral phase transition; ***** report all property values except dCpr IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,57) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapinc(iopt,iplot)), 3 TPD(mapinc(iopt,iplot))+273.15d0, 4 logKr, dGr, dHr 57 FORMAT(A20,3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f11.1,3x,f11.1,3x, 3 ' PHASE TRANSITION') endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,58) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapiso(iopt,iplot))+273.15d0, 3 TPD(mapinc(iopt,iplot)), 4 logKr, dGr, dHr 58 FORMAT(A20,3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f11.1,3x,f11.1,3x, 3 ' PHASE TRANSITION') endif Else WRITE(tabf,60) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapv3(iopt,iplot)-isat), 3 logKr, dGr, dHr, dSr, dVr 60 FORMAT(3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f10.0,1x, 3 1x,f10.0,1x, 4 1x,f9.1,2x, 5 1x,f9.1,2x,' TRANSITION') Endif RETURN END IF ***** .NOT. (xall .OR. xHSVCp .OR. xCp); ***** report all property values IF (outflg.eq.2) Then If (iplot.eq.1) then WRITE(tabf,66) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapinc(iopt,iplot)), 3 TPD(mapinc(iopt,iplot))+273.15d0, 4 logKr, dGr, dHr, dSr 66 FORMAT(A20,3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,3(f11.1,3x)) endif If (iplot.eq.2.or.iplot.eq.3) then WRITE(tabf,68) rtitle(ireac), 1 TPD(mapiso(iopt,iplot)), 2 TPD(mapiso(iopt,iplot))+273.15d0, 3 TPD(mapinc(iopt,iplot)), 4 logKr, dGr, dHr, dSr 68 FORMAT(A20,3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,3(f11.1,3x)) endif Else WRITE(tabf,70) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)), 2 TPD(mapv3(iopt,iplot)-isat), 3 logKr, dGr, dHr, dSr, dVr, dCpr 70 FORMAT(3(2x,f9.3,1x), 1 1x,f10.3,1x, 2 1x,f10.0,1x, 3 1x,f10.0,1x, 4 1x,f9.1,2x, 5 1x,f9.1,2x, 6 1x,f9.1) Endif RETURN END ******************************************************************* *** pltln1 - Write top line of next property block. SUBROUTINE pltln1(TPD) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8, MXIPLT = 11, MAXODD = 900, MAXINC = 900) DOUBLE PRECISION TPD(3), isomin, isomax, isoinc, Kmin, Kmax, Kinc, 1 oddv1(MAXODD), oddv2(MAXODD), 2 pbuff(MAXINC,MXIPLT,NPLOTF) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), 2 univar, useLVS, epseqn, geqn, xyplot, end, outflg LOGICAL EQ3run CHARACTER*7 isov2(2,3), incv2(2,3), var32(2,3) CHARACTER*10 isov(2,3), incv(2,3), var3(2,3) CHARACTER*13 pprop(NPLOTF) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 2 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /headmp/ isov, incv, var3 COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /EQ36/ EQ3run COMMON /plottr/ xyplot, end, nplots COMMON /pbuffr/ pbuff SAVE DATA pprop / 'logK ', 'delG (cal) ', 'delH (cal) ', 1 'delS (cal/K) ', 'delCp (cal/K)', 'delV (cc) ', 2 'dvar1 ', 'dvar2 ' / DATA isov2 / 'D(g/cc)', 'P(bars)', 3*'T(degC)', 'P(bars)' / DATA incv2 / 2*'T(degC)', 'D(g/cc)', 'P(bars)', 'P(bars)', 1 'T(degC)' / DATA var32 / 'P(bars)', 'D(g/cc)', 'P(bars)', 3*'D(g/cc)' / IF (xyplot .EQ. 1) THEN IF (univar .EQ. 1) THEN RETURN END IF DO 10 i = 1,nplots IF ((isat .EQ. 0) .AND. (.NOT. EQ3run)) THEN IF (i .EQ. 7) THEN WRITE(plotf(i),20) isov(iopt,iplot), 1 TPD(mapiso(iopt,iplot)), 2 incv(iopt,iplot), var3(iopt,iplot) 20 FORMAT(/,1x,a10,' = ',f10.4,' ; ', 1 a10,', ',a10,/) ELSE WRITE(plotf(i),25) isov(iopt,iplot), 1 TPD(mapiso(iopt,iplot)), 2 incv(iopt,iplot), pprop(i) 25 FORMAT(/,1x,a10,' = ',f10.4,' ; ', 1 a10,', ',a13,/) END IF ELSE IF (i .LT. 7) THEN WRITE(plotf(i),30) isov(iopt,iplot), pprop(i) 30 FORMAT(/,1x,a10,', ',a13,/) END IF IF (i .EQ. 7) THEN WRITE(plotf(i),35) isov(iopt,iplot), 1 incv(iopt,iplot) 35 FORMAT(/,1x,a10,', ',a10,/) END IF IF (i .EQ. 8) THEN WRITE(plotf(i),35) isov(iopt,iplot), 1 var3(iopt,iplot) END IF END IF 10 CONTINUE ELSE DO 40 i = 1,nplots IF ((isat .EQ. 1) .OR. EQ3run) THEN WRITE(plotf(i),50) isov2(iopt,iplot), 1 incv2(iopt,iplot), var32(iopt,iplot), 1 (pprop(j), j = 1,6) 50 FORMAT(/,3(a7,2x),6(a13,2x)) GO TO 40 END IF IF (univar .EQ. 0) THEN IF (i .LT. 7) THEN WRITE(plotf(i),60) isov2(iopt,iplot)(1:1), 1 incv2(iopt,iplot)(1:1), pprop(i) 60 FORMAT(/,1x,a1,'-',a1,' grid: ',a13) ELSE WRITE(plotf(i),65) isov2(iopt,iplot)(1:1), 1 incv2(iopt,iplot)(1:1), var32(iopt,iplot) 65 FORMAT(/,1x,a1,'-',a1,' grid: ',a7) END IF WRITE(plotf(i),70) incv2(iopt,iplot), 1 (isov2(iopt,iplot), isomin+(j-1)*isoinc, 2 j=1,MIN(niso,MXIPLT)) *** MXIPLT = 11 70 FORMAT(/,a7,11(2x,a7,' =',e11.4)) ELSE WRITE(plotf(i),80) isov2(iopt,iplot)(1:1), 1 incv2(iopt,iplot) 80 FORMAT(/,1x,a1,'-logK grid: ',a7) WRITE(plotf(i),90) isov2(iopt,iplot), 1 (incv2(iopt,iplot)(1:1), 2 Kmin+(k-1)*Kinc, k=1,MIN(nlogK,MXIPLT)) *** MXIPLT = 11 90 FORMAT(/,a7,11(2x,a1,'(logK =',e11.4,')')) END IF 40 CONTINUE *** initialize property buffer DO 100 k = 1,nplots DO 100 j = 1,MIN(niso,MXIPLT) DO 100 i = 1,nv2 pbuff(i,j,k) = 0.0d0 100 CONTINUE END IF END *********************************************************************** *** pltrep - Report calculated property values to plot files or buffers SUBROUTINE pltrep(TPD,iso,inc,logKr,dGr,dHr,dSr,dCpr,dVr, 1 lvdome,H2Oerr,Klost,xall,xHSVCp,xCp) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXINC = 900, MAXODD = 900, MXIPLT = 11, NPLOTF = 8) LOGICAL lvdome, H2Oerr, Klost, xall, xHSVCp, xCp, EQ3run CHARACTER*10 isov(2,3), incv(2,3), var3(2,3) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), 1 mapiso(2,3), mapinc(2,3), mapv3(2,3), univar, 2 useLVS, epseqn, geqn, xyplot, end, outflg DOUBLE PRECISION TPD(3), pbuff(MAXINC,MXIPLT,NPLOTF), 1 isomin, isomax, isoinc, Kmin, Kmax, Kinc, logKr, 2 oddv1(MAXODD), oddv2(MAXODD), satmin(2) COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg COMMON /TPDmap/ mapiso, mapinc, mapv3 COMMON /headmp/ isov, incv, var3 COMMON /icon/ isat, iopt, iplot, univar, noninc, 1 useLVS, epseqn, geqn COMMON /grid/ isomin, isomax, isoinc, v2min, v2max, v2inc, 2 oddv1, oddv2, Kmin, Kmax, Kinc, niso, nv2, nlogK COMMON /satend/ satmin COMMON /EQ36/ EQ3run COMMON /plottr/ xyplot, end, nplots COMMON /pbuffr/ pbuff SAVE *************************** xyplot = 1 ******************************* IF ((xyplot .EQ. 1) .AND. (lvdome .OR. H2Oerr .OR. xall)) RETURN IF ((xyplot .EQ. 1) .AND. (univar .EQ. 1)) THEN IF (Klost) THEN pbuff(inc,iso,1) = 0.0d0 ELSE pbuff(inc,iso,1) = TPD(mapinc(iopt,iplot)) END IF GO TO 20 END IF IF ((xyplot .EQ. 1) .AND. xHSVCp) THEN IF ((isat .EQ. 1) .OR. EQ3run) THEN WRITE(plotf(1),10) TPD(mapiso(iopt,iplot)), logKr WRITE(plotf(2),10) TPD(mapiso(iopt,iplot)), dGr WRITE(plotf(7),10) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)) WRITE(plotf(8),10) TPD(mapiso(iopt,iplot)), 1 TPD(mapv3(iopt,iplot)-isat) 10 FORMAT(2(1x,e14.7)) END IF IF (univar .EQ. 0) THEN WRITE(plotf(1),10) TPD(mapinc(iopt,iplot)), logKr WRITE(plotf(2),10) TPD(mapinc(iopt,iplot)), dGr WRITE(plotf(7),10) TPD(mapinc(iopt,iplot)), 1 TPD(mapv3(iopt,iplot)-isat) END IF RETURN END IF IF ((xyplot .EQ. 1) .AND. xCp) THEN IF ((isat .EQ. 1) .OR. EQ3run) THEN WRITE(plotf(1),10) TPD(mapiso(iopt,iplot)), logKr WRITE(plotf(2),10) TPD(mapiso(iopt,iplot)), dGr WRITE(plotf(3),10) TPD(mapiso(iopt,iplot)), dHr WRITE(plotf(4),10) TPD(mapiso(iopt,iplot)), dSr WRITE(plotf(6),10) TPD(mapiso(iopt,iplot)), dVr WRITE(plotf(7),10) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)) WRITE(plotf(8),10) TPD(mapiso(iopt,iplot)), 1 TPD(mapv3(iopt,iplot)-isat) RETURN END IF IF (univar .EQ. 0) THEN WRITE(plotf(1),10) TPD(mapinc(iopt,iplot)), logKr WRITE(plotf(2),10) TPD(mapinc(iopt,iplot)), dGr WRITE(plotf(3),10) TPD(mapinc(iopt,iplot)), dHr WRITE(plotf(4),10) TPD(mapinc(iopt,iplot)), dSr WRITE(plotf(6),10) TPD(mapinc(iopt,iplot)), dVr WRITE(plotf(7),10) TPD(mapinc(iopt,iplot)), 1 TPD(mapv3(iopt,iplot)-isat) END IF RETURN END IF IF (xyplot .EQ. 1) THEN *** .NOT. (xall .OR. xHSVCp .OR. xCp) IF ((isat .EQ. 1) .OR. EQ3run) THEN WRITE(plotf(1),10) TPD(mapiso(iopt,iplot)), logKr WRITE(plotf(2),10) TPD(mapiso(iopt,iplot)), dGr WRITE(plotf(3),10) TPD(mapiso(iopt,iplot)), dHr WRITE(plotf(4),10) TPD(mapiso(iopt,iplot)), dSr WRITE(plotf(5),10) TPD(mapiso(iopt,iplot)), dCpr WRITE(plotf(6),10) TPD(mapiso(iopt,iplot)), dVr WRITE(plotf(7),10) TPD(mapiso(iopt,iplot)), 1 TPD(mapinc(iopt,iplot)) WRITE(plotf(8),10) TPD(mapiso(iopt,iplot)), 1 TPD(mapv3(iopt,iplot)-isat) END IF IF ((isat .EQ. 0) .AND. (.NOT. EQ3run)) THEN WRITE(plotf(1),10) TPD(mapinc(iopt,iplot)), logKr WRITE(plotf(2),10) TPD(mapinc(iopt,iplot)), dGr WRITE(plotf(3),10) TPD(mapinc(iopt,iplot)), dHr WRITE(plotf(4),10) TPD(mapinc(iopt,iplot)), dSr WRITE(plotf(5),10) TPD(mapinc(iopt,iplot)), dCpr WRITE(plotf(6),10) TPD(mapinc(iopt,iplot)), dVr WRITE(plotf(7),10) TPD(mapinc(iopt,iplot)), 1 TPD(mapv3(iopt,iplot)-isat) END IF RETURN END IF *************************** xyplot = 2 ******************************* IF (lvdome .OR. H2Oerr .OR. Klost .OR. xall) GO TO 20 IF (univar .EQ. 1) THEN pbuff(inc,iso,1) = TPD(mapinc(iopt,iplot)) GO TO 20 END IF IF (xHSVCp) THEN pbuff(inc,iso,1) = logKr pbuff(inc,iso,2) = dGr pbuff(inc,iso,7) = TPD(mapv3(iopt,iplot)-isat) pbuff(inc,iso,8) = TPD(mapinc(iopt,iplot)) GO TO 20 END IF IF (xCp) THEN pbuff(inc,iso,1) = logKr pbuff(inc,iso,2) = dGr pbuff(inc,iso,3) = dHr pbuff(inc,iso,4) = dSr pbuff(inc,iso,6) = dVr pbuff(inc,iso,7) = TPD(mapv3(iopt,iplot)-isat) pbuff(inc,iso,8) = TPD(mapinc(iopt,iplot)) ELSE pbuff(inc,iso,1) = logKr pbuff(inc,iso,2) = dGr pbuff(inc,iso,3) = dHr pbuff(inc,iso,4) = dSr pbuff(inc,iso,5) = dCpr pbuff(inc,iso,6) = dVr pbuff(inc,iso,7) = TPD(mapv3(iopt,iplot)-isat) pbuff(inc,iso,8) = TPD(mapinc(iopt,iplot)) END IF 20 IF ((iso .LT. niso) .OR. (inc .LT. nv2) .OR. 1 (EQ3run .AND. (inc .LT. noninc))) RETURN *** flush buffers IF (xyplot .EQ. 1) THEN DO 25 i = 1,nlogk WRITE(plotf(1),22) Kmin + (i-1)*Kinc, 1 isov(iopt,iplot), incv(iopt,iplot) 22 FORMAT(/,' LOG K = ',e12.5,' ; ',a10,', ',a10,' = ',/) DO 25 j = 1,niso IF (pbuff(i,j,1) .NE. 0.0d0) THEN WRITE(plotf(1),10) isomin + (j-1)*isoinc, 1 pbuff(i,j,1) END IF 25 CONTINUE RETURN END IF IF (EQ3run) THEN DO 30 i = 1,noninc WRITE(plotf(1),40) oddv1(i), oddv2(i), 1 pbuff(i,1,7), (pbuff(i,1,k), k = 1,6) 40 FORMAT(9(e14.7,2x)) 30 CONTINUE RETURN END IF IF (isat .EQ. 1) THEN DO 50 i = 1,nv2 IF ((i .EQ. 1) .AND. (v2min .EQ. 0.0d0)) THEN WRITE(plotf(1),40) satmin(iopt), 1 pbuff(i,1,8), pbuff(i,1,7), 1 (pbuff(i,1,k), k = 1,6) ELSE WRITE(plotf(1),40) v2min+(i-1)*v2inc, 1 pbuff(i,1,8), pbuff(i,1,7), 1 (pbuff(i,1,k), k = 1,6) END IF 50 CONTINUE RETURN END IF IF (univar .EQ. 0) THEN DO 60 k = 1,nplots DO 60 i = 1,nv2 WRITE(plotf(k),70) v2min+(i-1)*v2inc, 1 (pbuff(i,j,k), j = 1,MIN(niso,MXIPLT)) 70 FORMAT(12(e14.7,2x)) 60 CONTINUE ELSE DO 80 j = 1,niso WRITE(plotf(1),90) isomin+(j-1)*isoinc, 1 (pbuff(i,j,1), i = 1,MIN(nlogK,MXIPLT)) 90 FORMAT(12(e14.7,2x)) 80 CONTINUE END IF END *********************************************************************** *** blanks - Set xall, xCp, and MKwarn per current state conditions. SUBROUTINE blanks(T,P,D,m2reac,nm,ng,na,xall,xHSVCp,xCp, 1 MKwarn,Pwarn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4, 1 MAXGAS = 10, MAXAQS = 10, 1 TCPM2 = 25.0d0, PMAXMG = 10000.0d0, 2 TMAXA = 1000.0d0, PMAXA = 5000.0d0, 3 TMAXX = 400.0d0, PMAXX1 = 500.0d0, 4 TMINX = 350.0d0, PMAXX2 = 1000.0d0, 5 DMINCA = 0.35d0, DMINNA = 0.05d0, TOL = 1.0d-5) CHARACTER*20 mname(MAXMIN), aname(MAXAQS), gname(MAXGAS) CHARACTER*30 mform(MAXMIN), aform(MAXAQS), gform(MAXGAS) LOGICAL m2reac, xall, xHSVCp, xCp, MKwarn, Pwarn, aqschg INTEGER ntran(MAXMIN), phaser(MAXMIN) DOUBLE PRECISION TtranP(MXTRAN,MAXMIN), 1 PtranT(MXTRAN,MAXMIN) DOUBLE PRECISION Vmin(MAXMIN), Smin(MAXMIN), Cpmin(MAXMIN), 2 Hmin(MAXMIN), Gmin(MAXMIN) DOUBLE PRECISION Gfaqs(MAXAQS), Hfaqs(MAXAQS), SPrTra(MAXAQS), 1 a(4,MAXAQS), c(2,MAXAQS), 2 wref(MAXAQS), chg(MAXAQS) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), 1 VPrTrm(MAXMIN), SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) DOUBLE PRECISION Gfgas(MAXGAS), Hfgas(MAXGAS), VPrTrg(MAXGAS), 1 SPrTrg(MAXGAS), MKg(IABC,MAXGAS), Tmaxg(MAXGAS) COMMON /PTtran/ TtranP, PtranT COMMON /minsp/ Vmin, Smin, Cpmin, Hmin, Gmin, phaser COMMON /anames/ aname, aform COMMON /aqsref/ Gfaqs, Hfaqs, SPrTra, c, a, wref, chg COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /gnames/ gname, gform COMMON /gasref/ Gfgas, Hfgas, SPrTrg, VPrTrg, MKg, Tmaxg SAVE xall = .FALSE. xHSVCp = .FALSE. xCp = .FALSE. MKwarn = .FALSE. Pwarn = .FALSE. aqschg = .FALSE. IF ((nm .GT. 0) .OR. (ng .GT. 0)) THEN ***** consider validity limitations of mineral/gas equations IF (P .GT. PMAXMG+TOL) THEN ***** P exceeds pressure limit; issue warning Pwarn = .TRUE. END IF TK = T + 273.15d0 DO 10 i = 1,ng IF (TK .GT. Tmaxg(i)) THEN ***** T beyond limit of Maier-Kelly coefficients; ***** issue appropriate warning in calling routine MKwarn = .TRUE. END IF 10 CONTINUE DO 11 i = 1,nm IF (TK .GT. Tmaxm(i)) THEN ***** T beyond limit of Maier-Kelly coefficients; ***** issue appropriate warning in calling routine MKwarn = .TRUE. END IF 11 CONTINUE IF (m2reac) THEN DO 20 i = 1,nm IF (ntran(i) .GT. 0) THEN ***** blank-out Cp if T within +/- 25 degC of ***** phase transition IF (phaser(i) .EQ. 1) THEN xCp = (DABS(TK - TtranP(phaser(i),i)) 1 .LE. TCPM2) ELSE xCp = (DABS(TK - TtranP(phaser(i)-1,i)) 1 .LE. TCPM2) 2 .OR. 3 (DABS(TK - TtranP(MIN(phaser(i),ntran(i)),i)) 4 .LE. TCPM2) END IF IF (xCp) THEN GO TO 25 END IF END IF 20 CONTINUE END IF END IF 25 IF (na .GT. 0) THEN ***** consider validity limitations of aqueous species equations IF ((P .GT. PMAXA+TOL) .OR. (T .GT. TMAXA+TOL)) THEN ***** P or T exceeds validity limits of equations xall = .TRUE. RETURN END IF DO 30 j = 1,na IF (chg(j) .NE. 0.0d0) THEN aqschg = .TRUE. END IF 30 CONTINUE IF (aqschg) THEN ***** check limits for charged aqueous species xall = ((D .LT. DMINCA) .OR. ((P. LT. PMAXX1) .AND. 1 (T .GT. TMINX) .AND. (T .LT. TMAXX))) xHSVCp = xall .OR. 1 ((P .LT. PMAXX2) .AND. (T .GT. TMINX)) ELSE ***** check limits for neutral aqueous species xall = (D .LT. DMINNA) END IF END IF END *** reac92 - Calculates the standard molal Gibbs free energy, enthalpy, *** entropy, heat capacity, and volume of the i[th] reaction *** (specified in common blocks /icon/ and /reac/) among *** <= MAXMIN minerals, <= MAXAQS aqueous species, <= MAXGAS *** gases, and H2O using equations and data given by Helgeson *** et al. (1978), Tanger and Helgeson (1988), Shock and *** Helgeson (1988, 1990), Shock et al. (1989, 1991), Johnson *** and Norton (1991), Johnson et al. (1991), and Sverjensky *** et al. (1991). *** *** Computed reaction properties are stored in COMMON blocks *** /minsp/, /gassp/, /aqsp/, /solvn/, and /fmeq/. *** ******************************************************************* *** *** Author: James W. Johnson *** Earth Sciences Department, L-219 *** Lawrence Livermore National Laboratory *** Livermore, CA 94550 *** johnson@s05.es.llnl.gov *** *** Abandoned: 8 November 1991 *** ******************************************************************* SUBROUTINE reac92(i,P,TC,Dw,Vw,betaw,alphaw,daldTw, 1 Sw,Cpw,Hw,Gw,Zw,Qw,Yw,Xw,geqn) ******************************************************************* *** argument units: (w suffixes denote H2O properties) *** *** P ............ bars *** TC ........... degC *** Dw ........... g/cm**3 *** Vw ........... cm**3/mol *** betaw, Qw .... bars**(-1) *** alphaw, Yw ... K**(-1) *** daldTw, Xw ... K**(-2) *** Sw, Cpw ...... cal/(mol*K) *** Hw, Gw ....... cal/mol *** Zw ........... dimensionless ********************************************* IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXGAS = 10, MAXAQS = 10, MAXRXN = 800) INTEGER geqn LOGICAL m2reac(MAXRXN) CHARACTER*80 rtitle(MAXRXN) INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS) DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac SAVE TK = TC + 273.15d0 CALL solids(nm(i),P,TK) CALL gases(ng(i),TK) CALL aqsps(na(i),P,TK,Dw,betaw,alphaw,daldTw,Zw,Qw,Yw,Xw,geqn) CALL reactn(i,TK,Vw,Sw,Cpw,Hw,Gw) END ******************************************************************** *** Solids - Computes the standard molal thermodynamic properties of * nmin minerals at P,T using equations given by * Helgeson et al. (1978). SUBROUTINE solids(nmin,P,T) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4) CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN) INTEGER ntran(MAXMIN), phaser(MAXMIN), getphr, getCpr, Cpreg DOUBLE PRECISION mwH2O, TtranP(MXTRAN,MAXMIN), 1 PtranT(MXTRAN,MAXMIN) DOUBLE PRECISION Vmin(MAXMIN), Smin(MAXMIN), Cpmin(MAXMIN), 2 Hmin(MAXMIN), Gmin(MAXMIN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), SPrTrm(MAXMIN), 2 VPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /minsp/ Vmin, Smin, Cpmin, Hmin, Gmin, phaser COMMON /PTtran/ TtranP, PtranT SAVE DO 10 i = 1,nmin phaser(i) = getphr(i,P,T,TtranP) Cpreg = getCpr(i,T) CALL Vterms(i,P,T,phaser(i),Vmin(i),VdP,PtranT) CALL Cptrms('min',i,Cpreg,T,Cpmin(i),CprdT,CprdlT) CALL pttrms(i,phaser(i),T,Spttrm,Hpttrm,Gpttrm) Smin(i) = SPrTrm(i) + CprdlT + Spttrm Hmin(i) = Hfmin(i) + CprdT + VdP + Hpttrm Gmin(i) = Gfmin(i) - SPrTrm(i)*(T-Tref) + 1 CprdT - T*CprdlT + VdP + Gpttrm IF ((mname(i) .EQ. 'QUARTZ') .OR. 1 (mname(i) .EQ. 'COESITE')) THEN Hmin(i) = Hmin(i) - VdP Gmin(i) = Gmin(i) - VdP CALL quartz(mname(i),P,T,Ttran(1,i), 1 Vmin(i),Smin(i),Hmin(i),Gmin(i)) END IF 10 CONTINUE RETURN END ************************************************************************ *** getCpr - Returns the effective phase region for temperature *** integration of Cpr(T) for mineral imin (i.e., the *** phase region specified by T at 1 bar). INTEGER FUNCTION getCpr(imin,T) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4) INTEGER ntran(MAXMIN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), SPrTrm(MAXMIN), 2 VPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran SAVE getCpr = 1 DO 10 i = 1,ntran(imin) IF (T .GT. Ttran(i,imin)) getCpr = getCpr + 1 10 CONTINUE RETURN END *********************************************************************** *** quartz - Revises the standard molal Gibbs free energy (G), enthalpy *** (H), entropy (S), and volume (V) of quartz or coesite to *** account for V(T) > 0 using equations (109) through (115), *** Helgeson et al. (1978). SUBROUTINE quartz(mname,P,T,TtPr,V,S,H,G) IMPLICIT DOUBLE PRECISION (a-h,o-z) CHARACTER*20 mname INTEGER qphase DOUBLE PRECISION k, mwH2O COMMON /refval/ mwH2O, R, Pr, Tr, ZPrTr, YPrTr COMMON /qtzcon/ aa, ba, ca, VPtTta, VPrTtb, Stran SAVE *** VPrTra = VPrTr(a-quartz) *** Vdiff = VPrTr(a-quartz) - VPrTr(coesite) *** k = dPdTtr(a/b-quartz) DATA VPrTra, Vdiff, k / 22.688d0, 2.047d0, 38.5d0 / ***** set qphase = phase region of quartz IF ((T .LE. TtPr) .OR. (P .GE. (Pr + k*(T-TtPr)))) THEN qphase = 1 ELSE qphase = 2 END IF ***** set Pstar and Sstar ***** IF (T .LE. TtPr) THEN Pstar = Pr Sstar = 0.0d0 ELSE IF (qphase .EQ. 2) THEN Pstar = P Sstar = 0.0d0 ELSE Pstar = Pr + k*(T-TtPr) Sstar = Stran END IF END IF IF (qphase .EQ. 2) THEN ***** set volume to beta-quartz ***** V = VPrTtb ELSE ***** calculate volume of alpha-quartz per eqn (109) ***** V = VPrTra + ca*(P-Pr) + (VPtTta - VPrTra - ca*(P-Pr))*(T-Tr) / 1 (TtPr + (P-Pr)/k - Tr) END IF IF (mname .EQ. 'COESITE') V = V - Vdiff ***** leading constant for [G,S]Vterm below ***** is a coversion factor (cal/cm**3/bar) IF (mname .EQ. 'QUARTZ') THEN GVterm = 0.23901488d-1 * (VPrTra*(P-Pstar) + VPrTtb*(Pstar-Pr) - 1 0.5d0*ca*(2.0d0*Pr*(P-Pstar) - (P**2-Pstar**2)) - 2 ca*k*(T-Tr)*(P-Pstar) + 3 k*(ba + aa*ca*k)*(T-Tr)*DLOG((aa + P/k)/(aa + Pstar/k))) ELSE GVterm = 0.23901488d-1 * ((VPrTra-Vdiff)*(P-Pstar) + 1 (VPrTtb-Vdiff)*(Pstar-Pr) - 0.5d0*ca*(2.0d0*Pr*(P-Pstar) - 2 (P**2-Pstar**2)) - ca*k*(T-Tr)*(P-Pstar) + 3 k*(ba + aa*ca*k)*(T-Tr)*DLOG((aa + P/k)/(aa + Pstar/k))) END IF SVterm = 0.23901488d-1 * (-k*(ba + aa*ca*k)* 1 DLOG((aa + P/k)/(aa + Pstar/k)) + ca*k*(P-Pstar)) - 2 Sstar G = G + GVterm S = S + SVterm H = H + GVterm + T*SVterm END ************************************************************************ *** getphr - Returns phase region for mineral imin at P, T; and, as a *** side effect, TtranP(1..MXTRAN,imin) as f(P). *** *** getphr = 1 ... TtranP(1,imin) > T [or imin lacks transn] *** getphr = 2 ... TtranP(1,imin) < T [< TtranP(2,imin)] *** getphr = 3 ... TtranP(2,imin) < T [< TtranP(3,imin)] *** getphr = 4 ... TtranP(3,imin) < T INTEGER FUNCTION getphr(imin,P,T,TtranP) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4) CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN) INTEGER ntran(MAXMIN) DOUBLE PRECISION TtranP(MXTRAN,MAXMIN), mwH2O DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), VPrTrm(MAXMIN), 2 SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr SAVE ****** phase region 1 ****** getphr = 1 IF (ntran(imin) .EQ. 0) RETURN IF (dPdTtr(1,imin) .EQ. 0.0d0) THEN TtranP(1,imin) = Ttran(1,imin) ELSE TtranP(1,imin) = Ttran(1,imin) + (P-Pref)/dPdTtr(1,imin) END IF IF (T .LE. TtranP(1,imin)) RETURN ****** phase region 2 ****** getphr = 2 IF (ntran(imin) .EQ. 1) RETURN IF (dPdTtr(2,imin) .EQ. 0.0d0) THEN TtranP(2,imin) = Ttran(2,imin) ELSE TtranP(2,imin) = Ttran(2,imin) + (P-Pref)/dPdTtr(2,imin) END IF IF (T .LE. TtranP(2,imin)) RETURN ****** phase region 3 ****** getphr = 3 IF (ntran(imin) .EQ. 2) RETURN IF (dPdTtr(3,imin) .EQ. 0.0d0) THEN TtranP(3,imin) = Ttran(3,imin) ELSE TtranP(3,imin) = Ttran(3,imin) + (P-Pref)/dPdTtr(3,imin) END IF IF (T .LE. TtranP(3,imin)) RETURN ****** phase region 4 ****** getphr = 4 RETURN END ************************************************************************ *** Vterms - Computes Vmin(P,T), Vmin*dP, and (if necesary) PtranT. SUBROUTINE Vterms(imin,P,T,phaser,Vmin,VdP,PtranT) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4) CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN) INTEGER phaser, ntran(MAXMIN) DOUBLE PRECISION mwH2O, PtranT(MXTRAN,MAXMIN) DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), VPrTrm(MAXMIN), 2 SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran SAVE Vmin = VPrTrm(imin) DO 10 i = 1,phaser-1 10 Vmin = Vmin + Vtran(i,imin) VdP = Vmin*(P - Pref)*0.23901488d-1 ****** return if Pressure integration does not cross ****** phase transition boundaries IF (ntran(imin) .EQ. 0) RETURN IF (dPdTtr(1,imin) .EQ. 0.0d0) RETURN IF (T .LE. Ttran(1,imin)) RETURN IF ((ntran(imin) .EQ. 1) .AND. (phaser .EQ. 2)) RETURN IF ((ntran(imin) .EQ. 2) .AND. (phaser .EQ. 3)) RETURN IF ((ntran(imin) .EQ. 2) .AND. (phaser .EQ. 2) .AND. 1 (T .LT. Ttran(2,imin))) RETURN ****** take account of cross-boundary pressure integration IF ((ntran(imin) .EQ. 1) .OR. 1 ((phaser .EQ. 1) .AND.(T .LT. Ttran(2,imin)))) THEN PtranT(1,imin) = Pref + (T - Ttran(1,imin))*dPdTtr(1,imin) VdP = 0.23901488d-1 * ( 1 VPrTrm(imin)*(P - Pref) + 2 Vtran(1,imin)*(PtranT(1,imin) - Pref)) RETURN END IF ****** ntran(imin) = 2 and T .GE. Ttran(2,imin) ****** PtranT(2,imin) = Pref + (T - Ttran(2,imin))*dPdTtr(2,imin) IF (phaser .EQ. 2) THEN VdP = 0.23901488d-1 * ( 1 (VPrTrm(imin) + Vtran(1,imin))*(P - Pref) + 2 Vtran(2,imin)*(PtranT(2,imin) - Pref)) ELSE PtranT(1,imin) = Pref + (T - Ttran(1,imin))*dPdTtr(1,imin) VdP = 0.23901488d-1 * ( 1 VPrTrm(imin)*(P - Pref) + 1 Vtran(1,imin)*(PtranT(1,imin) - Pref) + 2 Vtran(2,imin)*(PtranT(2,imin) - Pref)) END IF RETURN END ************************************************************************ *** Cptrms - Computes the standard molal heat capacity and heat capacity *** temperature integrals, evaluated from Tref to T at 1 bar. SUBROUTINE Cptrms(phase,i,Cpreg,T,Cpr,CprdT,CprdlT) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXGAS = 10, MAXMIN = 10, MXTRAN = 3, IABC = 4) CHARACTER*3 phase CHARACTER*20 mname(MAXMIN), gname(MAXGAS) CHARACTER*30 mform(MAXMIN), gform(MAXGAS) INTEGER ntran(MAXMIN), Cpreg DOUBLE PRECISION mwH2O DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), VPrTrm(MAXMIN), 2 SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) DOUBLE PRECISION Gfgas(MAXGAS), Hfgas(MAXGAS), VPrTrg(MAXGAS), 2 SPrTrg(MAXGAS), MKg(IABC,MAXGAS), Tmaxg(MAXGAS) COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran COMMON /gnames/ gname, gform COMMON /gasref/ Gfgas, Hfgas, SPrTrg, VPrTrg, MKg, Tmaxg SAVE IF (phase .EQ. 'gas') THEN **JP* Cpr = Cp(T,MKg(1,i),MKg(2,i),MKg(3,i)) **JP* CprdT = CpdT(Tref,T,MKg(1,i),MKg(2,i),MKg(3,i)) **JP* CprdlT = CpdlnT(Tref,T,MKg(1,i),MKg(2,i),MKg(3,i)) Cpr = Cp(T,MKg(1,i),MKg(2,i),MKg(3,i),MKg(4,i)) CprdT = CpdT(Tref,T,MKg(1,i),MKg(2,i),MKg(3,i),MKg(4,i)) CprdlT = CpdlnT(Tref,T,MKg(1,i),MKg(2,i),MKg(3,i),MKg(4,i)) RETURN END IF ***** phase = "min" ***** IF (Cpreg .EQ. 1) THEN **JP* Cpr = Cp(T,MK1(1,i),MK1(2,i),MK1(3,i)) **JP* CprdT = CpdT(Tref,T,MK1(1,i),MK1(2,i),MK1(3,i)) **JP* CprdlT = CpdlnT(Tref,T,MK1(1,i),MK1(2,i),MK1(3,i)) Cpr = Cp(T,MK1(1,i),MK1(2,i),MK1(3,i),MK1(4,i)) CprdT = CpdT(Tref,T,MK1(1,i),MK1(2,i),MK1(3,i),MK1(4,i)) CprdlT = CpdlnT(Tref,T,MK1(1,i),MK1(2,i),MK1(3,i),MK1(4,i)) RETURN END IF **JP* The following have been modified but not copied and **JP* commented out as above. IF (Cpreg .EQ. 2) THEN Cpr = Cp(T,MK2(1,i),MK2(2,i),MK2(3,i),MK2(4,i)) CprdT = CpdT(Tref,Ttran(1,i),MK1(1,i),MK1(2,i), 2 MK1(3,i),MK1(4,i)) + 3 CpdT(Ttran(1,i),T,MK2(1,i),MK2(2,i),MK2(3,i),MK2(4,i)) CprdlT = CpdlnT(Tref,Ttran(1,i),MK1(1,i),MK1(2,i), 2 MK1(3,i),MK1(4,I)) + 3 CpdlnT(Ttran(1,i),T,MK2(1,i),MK2(2,i),MK2(3,i),MK2(4,i)) RETURN END IF IF (Cpreg .EQ. 3) THEN Cpr = Cp(T,MK3(1,i),MK3(2,i),MK3(3,i),MK3(4,i)) CprdT = CpdT(Tref,Ttran(1,i),MK1(1,i),MK1(2,i), 2 MK1(3,i),MK1(4,i)) + 3 CpdT(Ttran(1,i),Ttran(2,i),MK2(1,i),MK2(2,i), 4 MK2(3,i),MK2(4,i)) + 5 CpdT(Ttran(2,i),T,MK3(1,i),MK3(2,i),MK3(3,i), 6 MK3(4,i)) CprdlT = CpdlnT(Tref,Ttran(1,i),MK1(1,i),MK1(2,i), 2 MK1(3,i),MK1(4,i))+ 3 CpdlnT(Ttran(1,i),Ttran(2,i),MK2(1,i),MK2(2,i), 4 MK2(3,i),MK2(4,i))+ 5 CpdlnT(Ttran(2,i),T,MK3(1,i),MK3(2,i),MK3(3,i),MK3(4,i)) RETURN END IF ***** Cpreg = 4 ***** Cpr = Cp(T,MK4(1,i),MK4(2,i),MK4(3,i),MK4(4,i)) CprdT = CpdT(Tref,Ttran(1,i),MK1(1,i),MK1(2,i), 2 MK1(3,i),MK1(4,i)) + 3 CpdT(Ttran(1,i),Ttran(2,i),MK2(1,i),MK2(2,i), 4 MK2(3,i),MK2(4,i)) + 5 CpdT(Ttran(2,i),Ttran(3,i),MK3(1,i),MK3(2,i), 5 MK3(3,i),MK3(4,i)) + 7 CpdT(Ttran(3,i),T,MK4(1,i),MK4(2,i),MK4(3,i),MK4(4,i)) CprdlT = CpdlnT(Tref,Ttran(1,i),MK1(1,i),MK1(2,i), 2 MK1(3,i),MK1(4,I)) + 3 CpdlnT(Ttran(1,i),Ttran(2,i),MK2(1,i), 4 MK2(2,i),MK2(3,i),MK2(4,i))+ 5 CpdlnT(Ttran(2,i),Ttran(3,i),MK3(1,i),MK3(2,i), 6 MK3(3,i),MK3(4,i))+ 7 CpdlnT(Ttran(3,i),T,MK4(1,i),MK4(2,i), 8 MK4(3,i),MK4(4,i)) RETURN END ********************************************************************* *** Cp - Returns the standard molal heat capacity at T. **JP* DOUBLE PRECISION FUNCTION Cp(T,a,b,c) DOUBLE PRECISION FUNCTION Cp(T,a,b,c,d) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE **JP* Cp = a + b*T + c/T**2 Cp = a + b*T + c/T**2 + d/T**.5 RETURN END ********************************************************************* *** CpdT - Returns the integral CpdT evaluated from T1 to T2. **JP* DOUBLE PRECISION FUNCTION CpdT(T1,T2,a,b,c) DOUBLE PRECISION FUNCTION CpdT(T1,T2,a,b,c,d) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE **JP* CpdT = a*(T2 - T1) + b/2.0d0*(T2**2 - T1**2) - **JP* 2 c*(1.0d0/T2 - 1.0d0/T1) CpdT = a*(T2 - T1) + b/2.0d0*(T2**2 - T1**2) - 2 c*(1.0d0/T2 - 1.0d0/T1) + 3 d/0.5d0*(T2**.5 - T1**.5) RETURN END ********************************************************************* *** CpdlnT - Returns the integral CpdlnT evaluated from T1 to T2. DOUBLE PRECISION FUNCTION CpdlnT(T1,T2,a,b,c,d) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE **JP* CpdlnT = a*DLOG(T2/T1) + b*(T2 - T1) - **JP* 2 c/2.0d0*(1.0d0/T2**2 - 1.0d0/T1**2) - CpdlnT = a*DLOG(T2/T1) + b*(T2 - T1) - 2 c/2.0d0*(1.0d0/T2**2 - 1.0d0/T1**2) - 3 d/0.5d0*(1.0d0/T2**0.5-1.0d0/T1**0.5) RETURN END ********************************************************************* *** pttrms - Computes phase transition terms for Smin, Hmin, and Gmin. SUBROUTINE pttrms(imin,phaser,T,Spttrm,Hpttrm,Gpttrm) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MXTRAN = 3, IABC = 4) CHARACTER*20 mname(MAXMIN) CHARACTER*30 mform(MAXMIN) INTEGER ntran(MAXMIN), phtran, phaser DOUBLE PRECISION Gfmin(MAXMIN), Hfmin(MAXMIN), VPrTrm(MAXMIN), 2 SPrTrm(MAXMIN), 3 MK1(IABC,MAXMIN), MK2(IABC,MAXMIN), 4 MK3(IABC,MAXMIN), MK4(IABC,MAXMIN), 5 Ttran(MXTRAN,MAXMIN), Htran(MXTRAN,MAXMIN), 6 Vtran(MXTRAN,MAXMIN), dPdTtr(MXTRAN,MAXMIN), 7 Tmaxm(MAXMIN) COMMON /mnames/ mname, mform COMMON /minref/ Gfmin, Hfmin, SPrTrm, VPrTrm, MK1, MK2, MK3, MK4, 1 Ttran, Htran, Vtran, dPdTtr, Tmaxm, ntran SAVE Spttrm = 0.0d0 Hpttrm = 0.0d0 Gpttrm = 0.0d0 DO 10 phtran = 1,phaser-1 Spttrm = Spttrm + Htran(phtran,imin)/Ttran(phtran,imin) Hpttrm = Hpttrm + Htran(phtran,imin) Gpttrm = Gpttrm + 1 Htran(phtran,imin)*(1.0d0 - T/Ttran(phtran,imin)) 10 CONTINUE RETURN END ********************************************************************** *** gases - Computes the standard molal thermodynamic properties of * ngas gases at P,T using equations given by * Helgeson et al. (1978). SUBROUTINE gases(ngas,T) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXGAS = 10, IABC = 4, TS1BAR = 99.6324d0) LOGICAL error CHARACTER*20 gname(MAXGAS) CHARACTER*30 gform(MAXGAS) INTEGER specs(10) DOUBLE PRECISION mwH2O DOUBLE PRECISION Vgas(MAXGAS), Sgas(MAXGAS), Cpgas(MAXGAS), 2 Hgas(MAXGAS), Ggas(MAXGAS) DOUBLE PRECISION Gfgas(MAXGAS), Hfgas(MAXGAS), VPrTrg(MAXGAS), 2 SPrTrg(MAXGAS), MKg(IABC,MAXGAS), Tmaxg(MAXGAS) DOUBLE PRECISION states(4), props(46) COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /gnames/ gname, gform COMMON /gasref/ Gfgas, Hfgas, SPrTrg, VPrTrg, MKg, Tmaxg COMMON /gassp/ Vgas, Sgas, Cpgas, Hgas, Ggas SAVE DATA specs / 2,2,2,5,1,0,2,0,4,0 / DATA states / 0.0d0, 1.0d0, 0.0d0, 0.0d0 / TC = T - 273.15d0 DO 10 i = 1,ngas IF ((gname(i) .EQ. 'H2O,g') .AND. (TC .GE. TS1BAR)) THEN *** use Haar et al. (1984) equation of state to *** compute H2O,g properties at 1 bar, T > Tsat(1 bar) = *** 99.6324 C. Note that for T < Tsat(1 bar), *** thermodynamic properties of metastable H2O,g are *** calculated using parameters estimated by J. W. Johnson *** (3/90) that facilitate smooth transition into the *** Haar et al. (1984) equation at Tsat. *** *** Beacuse (1) P = 1 bar, and (2) thermodynamic properties *** of steam are independent of dielectric properties, *** specs(8..9) can be safely hardwired, as above. states(1) = TC CALL H2O92(specs,states,props,error) Vgas(i) = VPrTrg(i) Sgas(i) = props(5) Hgas(i) = props(9) Ggas(i) = props(3) Cpgas(i) = props(13) ELSE Vgas(i) = VPrTrg(i) CALL Cptrms('gas',i,1,T,Cpgas(i),CprdT,CprdlT) Sgas(i) = SPrTrg(i) + CprdlT Hgas(i) = Hfgas(i) + CprdT Ggas(i) = Gfgas(i) - SPrTrg(i)*(T - Tref) + 1 CprdT - T*CprdlT END IF 10 CONTINUE RETURN END ************************************************************************ *** aqsps - Computes the standard partial molal thermodynamic properties *** of naqs aqueous species at P,T using equations given by *** Tanger and Helgeson (1988), Shock et al. (1991), and *** Johnson et al. (1991). SUBROUTINE aqsps(naqs,P,T,Dw,betaw,alphaw,daldTw,Z,Q,Y,X,geqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXAQS = 10) CHARACTER*20 aname(MAXAQS) CHARACTER*30 aform(MAXAQS) INTEGER geqn DOUBLE PRECISION mwH2O DOUBLE PRECISION Vaqs(MAXAQS), Saqs(MAXAQS), Cpaqs(MAXAQS), 2 Haqs(MAXAQS), Gaqs(MAXAQS), 7 VQterm(MAXAQS), SYterm(MAXAQS), CpXtrm(MAXAQS), 8 HYterm(MAXAQS), GZterm(MAXAQS) DOUBLE PRECISION Gfaqs(MAXAQS), Hfaqs(MAXAQS), SPrTra(MAXAQS), 2 a(4,MAXAQS), c(2,MAXAQS), wref(MAXAQS), 3 chg(MAXAQS) COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /aqscon/ eta, theta, psi, anion, cation, gref COMMON /anames/ aname, aform COMMON /aqsref/ Gfaqs, Hfaqs, SPrTra, c, a, wref, chg COMMON /aqsp/ Vaqs, Saqs, Cpaqs, Haqs, Gaqs COMMON /solvn/ VQterm, SYterm, CpXtrm, HYterm, GZterm SAVE IF (naqs .EQ. 0) THEN RETURN ELSE CALL gfun92(T-273.15d0,P,Dw,betaw,alphaw,daldTw, 1 g,dgdP,dgdT,d2gdT2,geqn) END IF DO 10 j = 1,naqs ****** compute w, dwdP, dwdT, d2wdT2 ****** CALL omeg92(g,dgdP,dgdT,d2gdT2,wref(j),chg(j), 1 w,dwdP,dwdT,d2wdT2,aname(j)) VQterm(j) = 0.4184004d2 * (-w*Q + (-Z - 1.0d0)*dwdP) *** the leading constant converts cal/(mol*bar) -> cm3/mol Vaqs(j) = 0.4184004d2 * (a(1,j) + 1 a(2,j)/(psi+P) + 2 a(3,j)/(T-theta) + 3 a(4,j)/(psi+P)/(T-theta)) + 4 VQterm(j) SYterm(j) = w*Y - (-Z - 1.0d0)*dwdT - wref(j)*YPrTr Saqs(j) = SPrTra(j) + c(1,j)*DLOG(T/Tref) - 2 c(2,j)/theta* (1.0d0/(T-theta) - 3 1.0d0/(Tref-theta) + 4 (1.0d0/theta)* 5 DLOG(Tref*(T-theta)/T/(Tref-theta))) + 6 (a(3,j)*(P-Pref) + 7 a(4,j)*DLOG((psi+P)/(psi+Pref))) * 8 (1.0d0/(T-theta))**2 + 9 SYterm(j) CpXtrm(j) = w*T*X + 2.0d0*T*Y*dwdT + T*(Z + 1.0d0)*d2wdT2 Cpaqs(j) = c(1,j) + c(2,j)/(T-theta)**2 - 1 (2.0d0*T/(T-theta)**3) * (a(3,j)*(P-Pref) + 2 a(4,j)*DLOG((psi+P)/(psi+Pref))) + 3 CpXtrm(j) HYterm(j) = w*(-Z - 1.0d0) + w*T*Y - T*(-Z - 1.0d0)*dwdT - 1 wref(j)*(-ZPrTr - 1.0d0) - 2 wref(j)*Tref*YPrTr Haqs(j) = Hfaqs(j) + c(1,j)*(T-Tref) - 1 c(2,j)*(1.0d0/(T-theta) - 1.0d0/(Tref-theta)) + 2 a(1,j)*(P-Pref) + a(2,j)*DLOG((psi+P)/(psi+Pref)) + 3 (a(3,j)*(P-Pref) + a(4,j)*DLOG((psi+P)/(psi+Pref))) * 4 ((2.0d0*T - theta)/(T - theta)**2) + 5 HYterm(j) GZterm(j) = w*(-Z - 1.0d0) - wref(j)*(-ZPrTr - 1.0d0) + 1 wref(j)*YPrTr*(T-Tref) Gaqs(j) = Gfaqs(j) - SPrTra(j)*(T-Tref) - 1 c(1,j)*(T*DLOG(T/Tref)-T+Tref) + 2 a(1,j)*(P-Pref) + a(2,j)*DLOG((psi+P)/(psi+Pref)) - 3 c(2,j)* ( (1.0d0/(T-theta) - 1.0d0/(Tref-theta)) * 4 ((theta-T)/theta) - T/theta**2 * 5 DLOG((Tref*(T-theta))/(T*(Tref-theta))) ) + 6 (1.0d0/(T-theta)) * (a(3,j)*(P-Pref) + 7 a(4,j)*DLOG((psi+P)/(psi+Pref))) + 8 GZterm(j) GZterm(j) = w*(-Z - 1.0d0) 10 CONTINUE RETURN END ************************************************************************ *** omeg92 - Computes the conventinal Born coefficient (w) of the *** current aqueous species, dwdP, dwdP, and dw2dT2 as a *** function of g, dgdP, dgdT, d2gdT2, wref, and Z using *** equations given by Johnson et al. (1991). SUBROUTINE omeg92(g,dgdP,dgdT,d2gdT2,wref,Z, 1 w,dwdP,dwdT,d2wdT2,aname) IMPLICIT DOUBLE PRECISION (a-h,o-z) CHARACTER*20 aname COMMON /aqscon/ eta, theta, psi, anion, cation, gref SAVE IF ((Z .EQ. 0.0d0) .OR. (aname .EQ. 'H+')) THEN *** neutral aqueous species or H+ w = wref dwdP = 0.0d0 dwdT = 0.0d0 d2wdT2 = 0.0d0 RETURN ELSE *** charged aqueous species other than H+ reref = Z**2 / (wref/eta + Z/(3.082d0 + gref)) re = reref + DABS(Z) * g w = eta * (Z**2/re - Z/(3.082d0 + g)) Z3 = DABS(Z**3)/re**2 - Z/(3.082d0 + g)**2 Z4 = DABS(Z**4)/re**3 - Z/(3.082d0 + g)**3 dwdP = -eta * Z3 * dgdP dwdT = -eta * Z3 * dgdT d2wdT2 = 2.0d0 * eta * Z4 * dgdT**2 - eta * Z3 * d2gdT2 END IF END ************************************************************************ *** reactn - Computes the standard molal thermodynamic properties *** of the i[th] reaction. SUBROUTINE reactn(i,T,Vw,Sw,Cpw,Hw,Gw) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (MAXMIN = 10, MAXAQS = 10, MAXGAS = 10, MAXRXN = 800) CHARACTER*80 rtitle(MAXRXN) LOGICAL m2reac(MAXRXN) INTEGER nm(MAXRXN), na(MAXRXN), ng(MAXRXN), nw(MAXRXN), 1 rec1m(MAXRXN,MAXMIN), rec1a(MAXRXN,MAXAQS), 2 rec1g(MAXRXN,MAXGAS), phaser(MAXMIN) DOUBLE PRECISION mwH2O DOUBLE PRECISION coefm(MAXRXN,MAXMIN), coefa(MAXRXN,MAXAQS), 1 coefg(MAXRXN,MAXGAS), coefw(MAXRXN) DOUBLE PRECISION Vmin(MAXMIN), Smin(MAXMIN), Cpmin(MAXMIN), 2 Hmin(MAXMIN), Gmin(MAXMIN), 3 Vgas(MAXGAS), Sgas(MAXGAS), Cpgas(MAXGAS), 4 Hgas(MAXGAS), Ggas(MAXGAS), 5 Vaqs(MAXAQS), Saqs(MAXAQS), Cpaqs(MAXAQS), 6 Haqs(MAXAQS), Gaqs(MAXAQS) DOUBLE PRECISION VQterm(MAXAQS), SYterm(MAXAQS), CpXtrm(MAXAQS), 1 HYterm(MAXAQS), GZterm(MAXAQS), logKr COMMON /refval/ mwH2O, R, Pref, Tref, ZPrTr, YPrTr COMMON /reac1/ rtitle COMMON /reac2/ coefm, coefa, coefg, coefw, nm, na, ng, nw, 1 rec1m, rec1a, rec1g, m2reac COMMON /minsp/ Vmin, Smin, Cpmin, Hmin, Gmin, phaser COMMON /gassp/ Vgas, Sgas, Cpgas, Hgas, Ggas COMMON /aqsp/ Vaqs, Saqs, Cpaqs, Haqs, Gaqs COMMON /fmeq/ dVr, dSr, dCpr, dHr, dGr, 2 logKr, dlogKT, dlogKP COMMON /solvn/ VQterm, SYterm, CpXtrm, HYterm, GZterm SAVE ***** sum mineral contributions ***** dVrm = 0.0d0 dCprm = 0.0d0 dSrm = 0.0d0 dHrm = 0.0d0 dGrm = 0.0d0 DO 10 j = 1,nm(i) dVrm = dVrm + coefm(i,j)*Vmin(j) dCprm = dCprm + coefm(i,j)*Cpmin(j) dSrm = dSrm + coefm(i,j)*Smin(j) dHrm = dHrm + coefm(i,j)*Hmin(j) dGrm = dGrm + coefm(i,j)*Gmin(j) 10 CONTINUE ***** sum gas contributions ***** dVrg = 0.0d0 dCprg = 0.0d0 dSrg = 0.0d0 dHrg = 0.0d0 dGrg = 0.0d0 DO 20 j = 1,ng(i) dVrg = dVrg + coefg(i,j)*Vgas(j) dCprg = dCprg + coefg(i,j)*Cpgas(j) dSrg = dSrg + coefg(i,j)*Sgas(j) dHrg = dHrg + coefg(i,j)*Hgas(j) dGrg = dGrg + coefg(i,j)*Ggas(j) 20 CONTINUE ***** sum aqueous species contributions ***** dVra = 0.0d0 dCpra = 0.0d0 dSra = 0.0d0 dHra = 0.0d0 dGra = 0.0d0 DO 30 j = 1,na(i) dVra = dVra + coefa(i,j)*Vaqs(j) dCpra = dCpra + coefa(i,j)*Cpaqs(j) dSra = dSra + coefa(i,j)*Saqs(j) dHra = dHra + coefa(i,j)*Haqs(j) dGra = dGra + coefa(i,j)*Gaqs(j) 30 CONTINUE ***** calculate H2O contributions ***** dVrw = coefw(i) * Vw dSrw = coefw(i) * Sw dCprw = coefw(i) * Cpw dHrw = coefw(i) * Hw dGrw = coefw(i) * Gw ***** calculate reaction properties ***** dVr = dVrm + dVrg + dVra + dVrw dSr = dSrm + dSrg + dSra + dSrw dCpr = dCprm + dCprg + dCpra + dCprw dHr = dHrm + dHrg + dHra + dHrw dGr = dGrm + dGrg + dGra + dGrw logKr = -dGr / (2.302585d0 * R * T) dlogKT = dHr / (2.302585d0 * R * T**2) dlogKP = -0.23901488d-1 * dVr / (2.302585d0 * R * T) RETURN END ****************************************************************** *** gfun92 - Computes the g function (Tanger and Helgeson, 1988; *** Shock et al., 1991) and its partial derivatives *** (dgdP, dgdT, d2gdT2) at TdegC, Pbars using the *** computational algorithm specified by geqn. *** *** geqn = 1 ...... use Tanger-Helgeson (1988) equations *** geqn = 2 ...... use Shock et al. (1991) equations *** without the f(P,T) difference function *** geqn = 3 ...... use Shock et al. (1991) equations *** with the f(P,T) difference function SUBROUTINE gfun92(TdegC,Pbars,Dgcm3,betab,alphaK,daldT, 1 g,dgdP,dgdT,d2gdT2,geqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (TMAX = 1000.0d0, PMAX = 5000.0d0, TOL=1.0d-4) INTEGER geqn SAVE ****** initialize g and derivatives to zero g = 0.0d0 dgdP = 0.0d0 dgdT = 0.0d0 d2gdT2 = 0.0d0 IF ((TdegC .GT. TMAX+TOL) .OR. (Pbars .GT. PMAX+TOL)) RETURN * IF (geqn .EQ. 1) THEN ****** use Tanger-Helgeson (1988) equations * CALL gTangr(Pbars,TdegC+273.15d0,Dgcm3,betab,alphaK,daldT, * 2 g,dgdP,dgdT,d2gdT2) * RETURN * END IF * IF (geqn .EQ. 2) THEN ****** use Shock et al. (1991) equations ****** without f(P,T) difference function * CALL gShok1(TdegC,Pbars,Dgcm3,betab,alphaK,daldT, * 2 g,dgdP,dgdT,d2gdT2) * RETURN * END IF IF (geqn .EQ. 3) THEN ****** use Shock et al. (1991) equations ****** with f(P,T) difference function CALL gShok2(TdegC,Pbars,Dgcm3,betab,alphaK,daldT, 2 g,dgdP,dgdT,d2gdT2) RETURN END IF END ***************************************************************** *** gShok2- Computes g, dgdP, dgdT, and d2gdT2 using equations given *** by Shock et al. (1991) *** *** units: T ................. C *** D ................. g/cm**3 *** beta, dgdP ........ bars**(-1) *** alpha, dgdT ....... K**(-1) *** daldT, d2gdT2 ..... K**(-2) SUBROUTINE gShok2(T,P,D,beta,alpha,daldT,g,dgdP,dgdT,d2gdT2) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION c(6), cc(3) SAVE DATA c / -0.2037662D+01, 0.5747000D-02, -0.6557892D-05, 1 0.6107361D+01, -0.1074377D-01, 0.1268348D-04 / DATA cc / 0.3666666D+02, -0.1504956D-9, 0.5017997D-13 / IF (D .GE. 1.0d0) RETURN a = c(1) + c(2)*T + c(3)*T**2 b = c(4) + c(5)*T + c(6)*T**2 g = a*(1.0d0 - D)**b dgdD = - a * b * (1.0d0 - D)**(b - 1.0d0) dgdD2 = a * b * (b - 1.0d0) * (1.0d0 - D)**(b - 2.0d0) dadT = c(2) + 2.0d0*c(3)*T dadTT = 2.0d0 * c(3) dbdT = c(5) + 2.0d0*c(6)*T dbdTT = 2.0d0 * c(6) dDdT = - D * alpha dDdP = D * beta dDdTT = - D * (daldT - alpha**2) Db = (1.0d0 - D) ** b dDbdT = -b * (1.0d0 - D)**(b-1.0d0) * dDdT + 1 DLOG(1.0d0 - D) * Db * dbdT dDbdTT = -(b * (1.0d0 - D)**(b-1.0d0) * dDdTT + 1 (1.0d0 - D)**(b-1.0d0) * dDdT * dbdT + b * dDdT * 2 (-(b-1.0d0) * (1.0d0 - D)**(b-2.0d0) * dDdT + 3 DLOG(1.0d0 - D) * (1.0d0 - D)**(b-1.0d0) * dbdT)) + 4 DLOG(1.0d0 - D) * (1.0d0 - D)**b * dbdTT - 5 (1.0d0 - D)**b * dbdT * dDdT / (1.0d0 - D) + 6 DLOG(1.0d0 - D) * dbdT * dDbdT dgdP = dgdD * dDdP dgdT = a*dDbdT + Db*dadT d2gdT2 = a*dDbdTT + 2.0d0*dDbdT*dadT + Db*dadTT IF ((T .LT. 155.0d0) .OR. (P .GT. 1000.0d0) .OR. 1 (T .GT. 355.0d0)) RETURN ft = ((T - 155.0d0)/300.0d0)**4.8 + 1 cc(1)*((T - 155.0d0)/300.0d0)**16 dftdT = 4.8d0/300.0d0*((T - 155.0d0)/300.0d0)**3.8 + 1 16.0d0/300.0d0*cc(1)*((T - 155.0d0)/300.0d0)**15 dftdTT = 3.8d0*4.8d0/300.0d0**2*((T - 155.0d0)/300.0d0)**2.8 + 1 15.0d0*16.0d0/300.0d0**2*cc(1)*((T - 155.0d0)/300.0d0)**14 fp = cc(2)*(1000.0d0 - P)**3 + cc(3)*(1000.0d0 - P)**4 dfpdP = -3.0d0*cc(2)*(1000.0d0 - P)**2 - 1 4.0d0*cc(3)*(1000.0d0 - P)**3 f = ft * fp dfdP = ft * dfpdP dfdT = fp * dftdT d2fdT2 = fp * dftdTT g = g - f dgdP = dgdP - dfdP dgdT = dgdT - dfdT d2gdT2 = d2gdT2 - d2fdT2 RETURN END *___________________________________________________ *** H2O92 - Computes state, thermodynamic, transport, and electroststic *** properties of fluid H2O at T,[P,D] using equations and data *** given by Haar et al. (1984), Levelt Sengers et al. (1983), *** Johnson and Norton (1991), Watson et al. (1980), Sengers and *** Kamgar-Parsi (1984), Sengers et al. (1984), Helgeson and Kirkham *** (1974), Uematsu and Franck (1980), and Pitzer (1983). *** *********************************************************************** *** *** Author: James W. Johnson *** Earth Sciences Dept., L-219 *** Lawrence Livermore National Laboratory *** Livermore, CA 94550 *** johnson@s05.es.llnl.gov *** *** Abandoned: 8 November 1991 *** *********************************************************************** * * specs - Input unit, triple point, saturation, and option specs: * ***** it, id, ip, ih, itripl, isat, iopt, useLVS, epseqn, icrit; * * note that the returned value of isat may differ from * its input value and that icrit need not be specified * prior to invocation. * * * states - State variables: * ***** temp, pres, dens(1), dens(2); * * note that the first three of these must be specified prior * to invocation and that, in the case of saturation, vapor * density is returned in dens(1), liquid in dens(2). * * * props - Thermodynamic, transport, electrostatic, and combined * property values: * ***** A, G, S, U, H, Cv, Cp, Speed, alpha, beta, diel, visc, ***** tcond, surten, tdiff, Prndtl, visck, albe, ***** ZBorn, YBorn, QBorn, daldT, XBorn * * * error - LOGICAL argument that indicates success ("FALSE") or * failure ("TRUE") of the call, the latter value in * response to out-of-bounds specs or states variables. * *********************************************************************** SUBROUTINE H2O92(specs,states,props,error) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23, NPROP2 = 46) INTEGER specs(10) DOUBLE PRECISION states(4), props(NPROP2), Dens(2), 1 wpliq(NPROP), wprops(NPROP) LOGICAL crtreg, valid, error, useLVS COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /wpvals/ wprops, wpliq SAVE CALL unit(specs(1),specs(2),specs(3),specs(4),specs(5)) IF (.NOT. (valid(specs(1),specs(2),specs(3),specs(4),specs(5), 1 specs(6),specs(7),specs(8),specs(9), 2 states(1),states(2),states(3)))) THEN error = .TRUE. RETURN ELSE error = .FALSE. END IF IF (crtreg(specs(6),specs(7),specs(1), 1 states(1),states(2),states(3))) THEN specs(10) = 1 useLVS = (specs(8) .EQ. 1) ELSE specs(10) = 0 useLVS = .FALSE. END IF IF (useLVS) THEN Dens(1) = states(3) CALL LVSeqn(specs(6),specs(7),specs(5), 1 states(1),states(2),Dens,specs(9)) Dens(1) = Dens(1) / 1.0d3 IF (specs(6) .EQ. 1) THEN Dens(2) = Dens(2) / 1.0d3 END IF ELSE Dens(1) = states(3) / 1.0d3 CALL HGKeqn(specs(6),specs(7),specs(5), 1 states(1),states(2),Dens,specs(9)) END IF CALL load(1,wprops,props) IF (specs(6) .EQ. 1) THEN tempy = Dens(1) Dens(1) = Dens(2) Dens(2) = tempy CALL load(2,wpliq,props) END IF states(1) = TdegUS(specs(1),states(1)) states(2) = states(2) * fp states(3) = Dens(1) / fd IF (specs(6) .EQ. 1) THEN states(4) = Dens(2) / fd END IF RETURN END ************************************************************************ *** valid - Returns "TRUE" if unit and equation specifications * are valid and input state conditions fall within * the HGK equation's region of validity; * returns "FALSE" otherwise. LOGICAL FUNCTION valid(it,id,ip,ih,itripl,isat,iopt, 1 useLVS,epseqn,Temp,Pres,Dens) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER useLVS, epseqn LOGICAL valspc, valTD, valTP COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /crits/ Tc, rhoC, Pc, Pcon, Ucon, Scon, dPcon COMMON /tpoint/ Utr, Str, Htr, Atr, Gtr, 1 Ttr, Ptripl, Dltrip, Dvtrip COMMON /HGKbnd/ Ttop, Tbtm, Ptop, Pbtm, Dtop, Dbtm COMMON /liqice/ sDli1, sPli1, sDli37, sPli37, sDIB30, 1 Tli13, Pli13, Dli13, TnIB30, DnIB30 SAVE *** ensure validity of input specifications IF (.NOT. valspc(it,id,ip,ih,itripl,isat,iopt, 1 useLVS,epseqn)) THEN valid = .FALSE. RETURN END IF *** convert to degC, bars, g/cm3 *** T = TdegK(it,Temp) - 273.15d0 D = Dens * fd P = Pres / fp * 1.0d1 Ttripl = Ttr - 273.15d0 Tcrit = Tc - 273.15d0 Pcrit = Pc * 1.0d1 IF (isat .EQ. 0) THEN IF (iopt .EQ. 1) THEN valid = valTD(T,D,isat,epseqn) ELSE valid = valTP(T,P) END IF ELSE IF (iopt .EQ. 1) THEN valid = ((T+FPTOL .GE. Ttripl) .AND. 1 (T-FPTOL .LE. Tcrit)) ELSE valid = ((P+FPTOL .GE. Ptripl) .AND. 1 (P-FPTOL .LE. Pcrit)) END IF END IF RETURN END ***************************************************************** *** valspc - Returns "TRUE" if it, id, ip, ih, itripl, isat, iopt, * useLVS, and epseqn values all define valid input; * returns "FALSE" otherwise. LOGICAL FUNCTION valspc(it,id,ip,ih,itripl,isat,iopt, 1 useLVS,epseqn) INTEGER useLVS, epseqn SAVE valspc = (1 .LE. it) .AND. (it .LE. 4) .AND. 1 (1 .LE. id) .AND. (id .LE. 4) .AND. 2 (1 .LE. ip) .AND. (ip .LE. 5) .AND. 3 (1 .LE. ih) .AND. (ih .LE. 6) .AND. 4 (0 .LE. itripl) .AND. (itripl .LE. 1) .AND. 5 (0 .LE. isat) .AND. (isat .LE. 1) .AND. 6 (1 .LE. iopt) .AND. (iopt .LE. 2) .AND. 7 (0 .LE. useLVS) .AND. (useLVS .LE. 1) .AND. 8 (1 .LE. epseqn) .AND. (epseqn .LE. 5) RETURN END ***************************************************************** *** valTD - Returns "TRUE" if T-D defines liquid or vapor H2O * within validity limits of the HGK equation of state; * returns "FALSE" otherwise. LOGICAL FUNCTION valTD(T,D,isat,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER epseqn COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref COMMON /RTcurr/ rt COMMON /crits/ Tc, rhoC, Pc, Pcon, Ucon, Scon, dPcon COMMON /tpoint/ Utr, Str, Htr, Atr, Gtr, 1 Ttr, Ptripl, Dltrip, Dvtrip COMMON /HGKbnd/ Ttop, Tbtm, Ptop, Pbtm, Dtop, Dbtm COMMON /liqice/ sDli1, sPli1, sDli37, sPli37, sDIB30, 1 Tli13, Pli13, Dli13, TnIB30, DnIB30 COMMON /coefs/ a(20), q(20), x(11) COMMON /satur/ Dliq, Dvap, DH2O, iphase SAVE EQUIVALENCE (TmnLVS, x(1)) IF ((T-FPTOL .GT. Ttop) .OR. (T+FPTOL .LT. Tbtm) .OR. 1 (D-FPTOL .GT. Dtop) .OR. (D+FPTOL .LT. Dbtm)) THEN valTD = .FALSE. RETURN END IF Tcrit = Tc - 273.15d0 Ttripl = Ttr - 273.15d0 IF ((T+FPTOL .GE. Tcrit) .OR. 1 ((T .GE. TnIB30) .AND. (D .GE. Dltrip))) THEN Dlimit = sDIB30 * (T-TnIB30) + Dtop valTD = (D-FPTOL .LE. Dlimit) ELSE IF (D-FPTOL .LE. Dltrip) THEN IF (T .GE. Ttripl) THEN valTD = .TRUE. Tk = T + 273.15d0 IF (Tk .LT. TmnLVS) THEN rt = gascon * Tk CALL pcorr(0,Tk,Ps,Dl,Dv,epseqn) ELSE istemp = 1 DH2O = 0.0d0 P = Pfind(istemp,Tk,DH2O) CALL denLVS(istemp,Tk,P) Dv = Dvap / 1.0d3 Dl = Dliq / 1.0d3 END IF IF ((D .GE. Dv) .AND. (D. LE. Dl)) THEN isat = 1 END IF ELSE P = Psublm(T) PMPa = P / 1.0d1 Tk = T + 273.15d0 Dguess = PMPa / Tk / 0.4d0 rt = gascon * Tk CALL bb(Tk) CALL denHGK(Dsublm,PMPa,Dguess,Tk,dPdD) valTD = (D-FPTOL .LE. Dsublm) END IF ELSE IF (D .LE. Dli13) THEN Dlimit = sDli1 * (T-Tli13) + Dli13 valTD = (D+FPTOL .GE. Dlimit) ELSE Dlimit = sDli37 * (T-Tli13) + Dli13 valTD = (D-FPTOL .LE. Dlimit) END IF END IF END IF RETURN END ***************************************************************** *** valTP - Returns "TRUE" if T-P defines liquid or vapor H2O * within validity limits of the HGK equation of state; * returns "FALSE" otherwise. LOGICAL FUNCTION valTP(T,P) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /crits/ Tcrit, rhoC, Pc, Pcon, Ucon, Scon, dPcon COMMON /tpoint/ Utr, Str, Htr, Atr, Gtr, 1 Ttr, Ptripl, Dltrip, Dvtrip COMMON /HGKbnd/ Ttop, Tbtm, Ptop, Pbtm, Dtop, Dbtm COMMON /liqice/ sDli1, sPli1, sDli37, sPli37, sDIB30, 1 Tli13, Pli13, Dli13, TnIB30, DnIB30 SAVE IF ((T-FPTOL .GT. Ttop) .OR. (T+FPTOL .LT. Tbtm) .OR. 1 (P-FPTOL .GT. Ptop) .OR. (P+FPTOL .LT. Pbtm)) THEN valTP = .FALSE. RETURN ELSE valTP = .TRUE. END IF IF (P .GE. Pli13) THEN Plimit = sPli37 * (T-Tli13) + Pli13 valTP = (P-FPTOL .LE. Plimit) ELSE IF (P .GE. Ptripl) THEN Plimit = sPli1 * (T-Tli13) + Pli13 valTP = (P+FPTOL .GE. Plimit) ELSE Psubl = Psublm(T) valTP = (P-FPTOL .LE. Psubl) END IF END IF RETURN END ***************************************************************** *** Psublm - Returns Psublimation(T) computed from the * equation given by Washburn (1924): Monthly * Weather Rev., v.52, pp.488-490. DOUBLE PRECISION FUNCTION Psublm(Temp) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE T = Temp + 2.731d2 PmmHg = power(1.0d1, (-2.4455646d3/T + 8.2312d0*DLOG10(T) - 1 1.677006d-2*T + 1.20514d-5*T*T - 6.757169d0)) *** convert mmHg to bars *** Psublm = PmmHg * 1.33322d-3 RETURN END ************************************************************************ *** HGKcon - Constant parameters for the H2O equation of state * given by Haar, Gallagher, & Kell (1984): * bp, bq = b(j), B(j) from Table A.1, p.272 * g1, g2, gf = alpha, beta, gamma from eq (A.2), p.272 * g, ii, jj = g(i), k(i), l(i) from eq (A.5), p.272. * Note that tz < tcHGK. * Tolerence limits required in various real & inexact * comparisons are set and stored in COMMON /tolers/. BLOCK DATA HGKcon IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref COMMON /nconst/ g(40), ii(40), jj(40), nc COMMON /ellcon/ g1, g2, gf, b1, b2, b1t, b2t, b1tt, b2tt COMMON /bconst/ bp(10), bq(10) COMMON /addcon/ atz(4), adz(4), aat(4), aad(4) COMMON /HGKcrt/ tcHGK, dcHGK, pcHGK COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /HGKbnd/ Ttop, Tbtm, Ptop, Pbtm, Dtop, Dbtm COMMON /liqice/ sDli1, sPli1, sDli37, sPli37, sDIB30, 1 Tli13, Pli13, Dli13, TnIB30, DnIB30 COMMON /tpoint/ Utripl, Stripl, Htripl, Atripl, Gtripl, 1 Ttripl, Ptripl, Dltrip, Dvtrip SAVE DATA Ttripl, Ptripl, Dltrip, Dvtrip 1 / 2.7316d2, 2 0.611731677193563186622762580414d-2, 3 0.999778211030936587977889295063d0, 4 0.485467583448287303988319166423d-5 / DATA Ttop, Tbtm, Ptop, Pbtm, Dtop, Dbtm 1 / 2.25d3, -2.0d1, 3.0d4, 1.0d-3, 2 0.138074666423686955066817336896d1, 3 0.858745555396173972667420987465d-7 / DATA sDli1, sPli1, sDli37, sPli37, sDIB30, 1 Tli13, Pli13, Dli13, TnIB30, DnIB30 2 / -0.584797401732178547634910059828d-2, 3 -0.138180804975562958027981345769d3, 4 0.183244000000000000000000000007d-2, 5 0.174536874999999999999999999995d3, 6 -0.168375439429928741092636579574d-3, 7 -0.15d2, 8 0.20741d4, 9 0.108755631570602617113573577945d1, 1 0.145d3, 1 0.102631640581853166397515716306d1 / DATA TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL 1 / 1.0d-6, 1.0d-6, 1.0d-9, 1.0d-5, -673.5d0, 1.0d-7 / DATA tcHGK, dcHGK, pcHGK / .647126d3, .322d3, .22055d2 / DATA atz /.64d3, .64d3, .6416d3, .27d3/ DATA adz /.319d0, .319d0, .319d0, .155d1/ DATA aat /.2d5, .2d5, .4d5, .25d2/ DATA aad /.34d2, .4d2, .3d2, .105d4/ DATA wm, gascon, tz, aa, uref, sref 1 / .1801520000d2, .46152200d0, .647073d3, .1d1, 2 -.4328455039d4, .76180802d1 / DATA g1, g2, gf /.11d2, .44333333333333d2, .35d1/ DATA bp / .7478629d0, -.3540782d0, 2*.0d0, .7159876d-2, 1 .0d0, -.3528426d-2, 3*.0d0/ DATA bq / .11278334d1, .0d0, -.5944001d0, -.5010996d1, .0d0, 1 .63684256d0, 4*.0d0/ DATA nc / 36 / DATA g /-.53062968529023d3, .22744901424408d4, .78779333020687d3 1, -.69830527374994d2, .17863832875422d5, -.39514731563338d5 2, .33803884280753d5, -.13855050202703d5, -.25637436613260d6 3, .48212575981415d6, -.34183016969660d6, .12223156417448d6 4, .11797433655832d7, -.21734810110373d7, .10829952168620d7 5, -.25441998064049d6, -.31377774947767d7, .52911910757704d7 6, -.13802577177877d7, -.25109914369001d6, .46561826115608d7 7, -.72752773275387d7, .41774246148294d6, .14016358244614d7 8, -.31555231392127d7, .47929666384584d7, .40912664781209d6 9, -.13626369388386d7, .69625220862664d6, -.10834900096447d7 a, -.22722827401688d6, .38365486000660d6, .68833257944332d4 b, .21757245522644d5, -.26627944829770d4, -.70730418082074d5 c, -.22500000000000d0, -.16800000000000d1 d, .5500000000000d-1, -.93000000000000d2/ DATA ii / 4*0, 4*1, 4*2, 4*3, 4*4, 4*5, 4*6, 4*8, 2*2, 0, 4, 1 3*2, 4/ DATA jj / 2, 3, 5, 7, 2, 3, 5, 7, 2, 3, 5, 7, 2, 3, 5, 7, 1 2, 3, 5, 7, 2, 3, 5, 7, 2, 3, 5, 7, 2, 3, 5, 7, 2 1, 4, 4, 4, 0, 2, 0, 0/ END ********************************************************************* *** LVScon - Constant parameters for the H2O critical region equation * of state given by Levelt Sengers, Kamgar-Parsi, Balfour, * & Sengers (1983). BLOCK DATA LVScon IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /crits/ Tc, rhoC, Pc, Pcon, Ucon, Scon, dPcon COMMON /coefs/ a(20), q(20), x(11) SAVE DATA Tc, rhoC, Pc, Pcon, Ucon, Scon, dPcon 1 / 647.067d0, 322.778d0, 22.046d0, 2 0.034070660379837018423130834983d0, 22046.0d0, 3 0.034070660379837018423130834983d3, 4 0.000000327018783663660700780197d0 / DATA a / -0.017762d0, 5.238000d0, 0.000000d0, -2.549150d1, 1 6.844500d0, 0.325000d0, 1.440300d0, 0.000000d0, 2 1.375700d0, 2.366660d1, 4.820000d0, 0.294200d0, 3 -1.123260d1, -2.265470d1, -1.788760d1, -4.933200d0, 4 1.109430391161019373812391218008d0, 5 -1.981395981400671095301629432211d0, 6 0.246912528778663959151808173743d0, 7 -0.843411332867484343974055795059d0 / DATA q / -0.006000d0, -0.003000d0, 0.000000d0, 6.470670d2, 1 3.227780d2, 2.204600d1, 0.267000d0, -1.600000d0, 2 0.491775937675717720291497417773d0, 0.108500d0, 3 0.586534703230779473334597524774d0, 4 -1.026243389120214352553706598564d0, 5 0.612903225806451612903225804745d0, 0.500000d0, 6 -0.391500d0, 0.825000d0, 0.741500d0, 7 0.103245882826119154987166286332d0, 8 0.160322434159191991394857495360d0, 9 -0.169859514687100893997445721324d0 / DATA x / 6.430000d2, 6.453000d2, 6.950000d2, 1 1.997750d2, 4.200400d2, 2 2.09945691135940719075293945960d1, 3 2.15814057875264119875397458907d1, 4 3.0135d1, 4.0484d1, 5 .175777517046267847932127026995d0, 6 .380293646126229135059562456934d0 / * EQUIVALENCE (cc, a(1) ), (pointA, q(1) ), (Tmin1, x(1)), * 1 (p3, a(2) ), (pointB, q(2) ), (Tmin2, x(2)), * 2 (delroc, a(3) ), (delpc, q(3) ), (Tmax, x(3)), * 3 (p2, a(4) ), (Tc, q(4) ), (Dmin, x(4)), * 4 (p1, a(5) ), (rhoc, q(5) ), (Dmax, x(5)), * 5 (beta, a(6) ), (Pc, q(6) ), (Pmin1, x(6)), * 6 (xko, a(7) ), (dPcdTc, q(7) ), (Pmin2, x(7)), * 7 (delTc, a(8) ), (slopdi, q(8) ), (Pmax1, x(8)), * 8 (besq, a(9) ), (p11, q(9) ), (Pmax2, x(9)), * 9 (aa, a(10)), (alpha, q(10)), (sl1, x(10)), * 0 (delta, a(11)), (p00, q(11)), (sl2, x(11)), * 1 (k1, a(12)), (p20, q(12)), * 2 (muc, a(13)), (p40, q(13)), * 3 (mu1, a(14)), (deli, q(14)), * 4 (mu2, a(15)), (alh1, q(15)), * 5 (mu3, a(16)), (beti, q(16)), * 6 (s00, a(17)), (gami, q(17)), * 7 (s20, a(18)), (p01, q(18)), * 8 (s01, a(19)), (p21, q(19)), * 9 (s21, a(20)), (p41, q(20)) END ******************************************************************* *** unit - Sets internal parameters according to user-specified * choice of units. Internal program units are degK(T), * and gm/cm**3(D); all other properties are computed in * dimensionless form and dimensioned at output time. * NOTE: conversion factors for j/g ---> cal/(g,mole) * (ffh (4 & 5)) are consistent with those given in * Table 1, Helgeson & Kirkham (1974a) for thermal calories, * and differ slightly with those given by Haar et al (1984) * for international calories. SUBROUTINE unit(it,id,ip,ih,itripl) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION fft(4), ffd(4), ffvd(4), ffvk(4), 1 ffs(4), ffp(5), ffh(6), 2 ffst(4), ffcd(4), ffch(6) COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc SAVE DATA fft /1.0d0, 1.0d0, 0.555555556d0, 0.555555556d0 / DATA ffd /1.0d-3, 1.0d0, 1.80152d-2, 1.6018d-2/ DATA ffvd /1.0d0, 1.0d1, 0.555086816d0, 0.671968969d0 / DATA ffvk /1.0d0, 1.0d4, 1.0d4, 1.076391042d1 / DATA ffs /1.0d0, 1.0d2, 1.0d2, 3.280833d0 / DATA ffp /1.0d0, 1.0d1, 9.869232667d0, 1.45038d2, 1.01971d1/ DATA ffh /1.0d0, 1.0d0, 1.80152d1, 2.3901d-1, 1 4.305816d0, 4.299226d-1/ DATA ffst /1.0d0, 1.0d3, 0.555086816d2, 0.2205061d1 / DATA ffcd /1.0d0, 1.0d-2, 1.0d-2, 0.3048d0 / DATA ffch /1.0d-3, 1.0d0, 1.0d0, 0.23901d0, 1 0.23901d0, 0.947244d-3 / ft = fft(it) fd = ffd(id) fvd = ffvd(id) fvk = ffvk(id) fs = ffs(id) fp = ffp(ip) fh = ffh(ih) fst = ffst(id) fc = ffcd(id) * ffch(ih) IF (itripl .EQ. 1) CALL tpset RETURN END *********************************************************************** *** crtreg - Returns "TRUE" if input state conditions fall within * the critical region of H2O; otherwise returns "FALSE". * T, P, D, input in user-specified units, are returned in * degK, MPa, kg/m3. LOGICAL FUNCTION crtreg(isat,iopt,it,T,P,D) IMPLICIT DOUBLE PRECISION (a-h,o-z) LOGICAL llim, ulim COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon COMMON /coefs/ a(20), q(20), x(11) COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc SAVE EQUIVALENCE (Tmin1, x(1)), (Tmin2, x(2)), (Tmax, x(3)), 1 (Dmin, x(4)), (Dmax, x(5)), 2 (Pbase1, x(6)), (Pbase2,x(7)), 3 (PTmins, x(10)), (PTmaxs,x(11)) T = TdegK(it,T) IF (isat .EQ. 0) THEN IF (iopt .EQ. 1) THEN D = D * fd * 1.0d3 crtreg = ((T .GE. Tmin1) .AND. (T .LE. Tmax) .AND. 1 (D .GE. Dmin) .AND. (D .LE. Dmax)) ELSE P = P / fp IF ((T .LT. Tmin1) .OR. (T .GT. Tmax)) THEN crtreg = .FALSE. ELSE Pmin = Pbase1 + PTmins * (T - Tmin1) Pmax = Pbase2 + PTmaxs * (T - Tmin2) llim = (P .GE. Pmin) ulim = (P .LE. Pmax) IF (llim .AND. ulim) THEN crtreg = .TRUE. ELSE IF (llim .AND. (T .LE. Tmin2)) THEN isat1 = 1 ddummy = 0.0d0 Pstest = Pfind(isat1,T,ddummy) crtreg = (P .LE. Pstest) ELSE crtreg = .FALSE. END IF END IF END IF END IF ELSE IF (iopt .EQ. 1) THEN crtreg = (T .GE. Tmin1) ELSE P = P / fp crtreg = (P .GE. Pbase1) END IF END IF RETURN END ********************************************************************* *** HGKeqn - Computes thermodynamic and transport properties of * of H2O from the equation of state given by * Haar, Gallagher, & Kell (1984). SUBROUTINE HGKeqn(isat,iopt,itripl,Temp,Pres,Dens,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23) INTEGER epseqn DOUBLE PRECISION Dens(2), wprops(NPROP), wpliq(NPROP) COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref COMMON /wpvals/ wprops, wpliq COMMON /RTcurr/ rt SAVE rt = gascon * Temp CALL HGKsat(isat,iopt,itripl,Temp,Pres,Dens,epseqn) IF (isat .EQ. 0) THEN CALL bb(Temp) CALL calcv3(iopt,itripl,Temp,Pres,Dens(1),epseqn) CALL thmHGK(Dens(1),Temp) CALL dimHGK(isat,itripl,Temp,Pres,Dens(1),epseqn) ELSE DO 10 i=1,NPROP 10 wpliq(i) = wprops(i) CALL dimHGK(2,itripl,Temp,Pres,Dens(2),epseqn) END IF RETURN END ***************************************************************** *** HGKsat - If isat=1, computes Psat(T) or Tsat(P) (iopt=1,2), * liquid and vapor densities, and associated * thermodynamic and transport properties. * If isat=0, checks whether T-D or T-P (iopt=1,2) * falls on or within TOL of the liquid-vapor * surface; if so, sets isat <- 1 and computes * properties. SUBROUTINE HGKsat(isat,iopt,itripl,Temp,Pres,Dens,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION Dens(2) INTEGER epseqn COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /HGKcrt/ tcHGK, dcHGK, pcHGK COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /tpoint/ Utr, Str, Htr, Atr, Gtr, 1 Ttripl, Ptripl, Dltrip, Dvtrip COMMON /crits/ Tc, rhoC, Pc, Pcon, Ucon, Scon, dPcon SAVE IF (isat .EQ. 1) THEN IF (iopt .EQ. 1) THEN CALL pcorr(itripl,Temp,Pres,Dens(1),Dens(2),epseqn) ELSE CALL tcorr(itripl,Temp,Pres,Dens(1),Dens(2),epseqn) END IF ELSE IF ((Temp .GT. Tc) .OR. (Temp .LT. Ttripl) .OR. 1 ((iopt .EQ. 2) .AND. (Pres .GT. Pc))) THEN RETURN ELSE CALL pcorr(itripl,Temp,Ptemp,dltemp,dvtemp,epseqn) IF (((iopt .EQ. 2) .AND. 1 (DABS(Pres-Ptemp) .LE. PTOL)) .OR. 2 ((iopt .EQ. 1) .AND. 3 ((DABS(Dens(1)-dltemp) .LE. DTOL) .OR. 4 (DABS(Dens(1)-dvtemp) .LE. DTOL)))) THEN isat = 1 Pres = Ptemp Dens(1) = dltemp Dens(2) = dvtemp END IF END IF END IF RETURN END ************************************************************************ *** calcv3 - Compute the dependent state variable. SUBROUTINE calcv3(iopt,itripl,Temp,Pres,Dens,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER epseqn COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /qqqq/ q0, q5 COMMON /aconst/ wm, gascon, tz, aa, z, dz, y, uref, sref COMMON /fcts/ ad, gd, sd, ud, hd, cvd, cpd, dpdt, dvdt, dpdd, 1 cjtt, cjth COMMON /RTcurr/ rt SAVE IF (iopt .EQ. 1) THEN CALL resid(Temp,Dens) CALL base(Dens,Temp) CALL ideal(Temp) Pres = rt * Dens * z + q0 ELSE IF (Temp .LT. tz) THEN CALL pcorr(itripl,Temp,ps,dll,dvv,epseqn) ELSE ps = 2.0d4 dll = 0.0d0 END IF IF (Pres .GT. ps) THEN dguess = dll ELSE dguess = Pres / Temp / 0.4d0 END IF CALL denHGK(Dens,Pres,dguess,Temp,dpdd) CALL ideal(Temp) END IF RETURN END ****************************************************************************** *** thmHGK - Computes thermodynamic functions in dimensionless * units from the HGK equation of state: Helmholtz, Gibbs, * internal energy, and enthalpy functions (ad, gd, ud, hd) are * per RT; entropy and heat capacities (sd, cvd, cpd) are per R. SUBROUTINE thmHGK(d,t) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, y, uref, sref COMMON /qqqq/ qp, qdp COMMON /basef/ ab, gb, sb, ub, hb, cvb, pb, dpdtb COMMON /resf/ ar, gr, sr, ur, hr, cvr, dpdtr COMMON /idf/ ai, gi, si, ui, hi, cvi, cpi COMMON /fcts/ ad, gd, sd, ud, hd, cvd, cpd, dpdt, dvdt, dpdd, 1 cjtt, cjth COMMON /RTcurr/ rt SAVE z = zb + qp/rt/d dpdd = rt * (zb + y * dzb) + qdp ad = ab + ar + ai - uref/t + sref gd = ad + z ud = ub + ur + ui - uref/t dpdt = rt * d * dpdtb + dpdtr cvd = cvb + cvr + cvi cpd = cvd + t*dpdt*dpdt/(d*d*dpdd*gascon) hd = ud + z sd = sb + sr + si - sref dvdt = dpdt / dpdd / d / d cjtt = 1.0d0 / d - t * dvdt cjth = -cjtt / cpd / gascon RETURN END ************************************************************************* *** bb - Computes molecular parameters b, the "excluded volume" * (eq A.3), and B, the second virial coefficient (eq A.4), * in cm3/g (b1,b2) and their first and second derivatives * with respect to temperature (b1t,b1tt,b2t,b2tt). SUBROUTINE bb(t) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION v(10) COMMON /ellcon/ g1, g2, gf, b1, b2, b1t, b2t, b1tt, b2tt COMMON /aconst/ wm, gascon, tz, aa, z, dz, y, uref, sref COMMON /bconst/ bp(10), bq(10) SAVE v(1) = 1.0d0 DO 2 i=2,10 2 v(i) = v(i-1) * tz / t b1 = bp(1) + bp(2) * DLOG(1.0 / v(2)) b2 = bq(1) b1t = bp(2) * v(2) / tz b2t = 0.0d0 b1tt = 0.0d0 b2tt = 0.0d0 DO 4 i=3,10 b1 = b1 + bp(i) * v(i-1) b2 = b2 + bq(i) * v(i-1) b1t = b1t - (i-2) * bp(i) * v(i-1) / t b2t = b2t - (i-2) * bq(i) * v(i-1) / t b1tt = b1tt + bp(i) * (i-2)*(i-2) * v(i-1) / t / t 4 b2tt = b2tt + bq(i) * (i-2)*(i-2) * v(i-1) / t / t b1tt = b1tt - b1t / t b2tt = b2tt - b2t / t RETURN END *********************************************************************** *** base - Computes Abase, Gbase, Sbase, Ubase, Hbase, Cvbase * -- all per RT (dimensionless) -- as well as Pbase & dP/dT * -- both per (DRT) -- for the base function (ab, gb, sb, ub, * hb, cvb, pb, dpdtb). See Haar, Gallagher & Kell (1979), eq(1). SUBROUTINE base(d,t) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /ellcon/ g1, g2, gf, b1, b2, b1t, b2t, b1tt, b2tt COMMON /basef/ ab, gb, sb, ub, hb, cvb, pb, dpdtb COMMON /aconst/ wm, gascon, tz, a, z, dz, y, uref, sref SAVE y = .25d0 * b1 * d x = 1.0d0 - y z0 = (1.0d0 + g1*y + g2*y*y) / (x*x*x) z = z0 + 4.0d0*y*(b2/b1 - gf) dz0 = (g1 + 2.0d0*g2*y)/(x*x*x) + 1 3.0d0*(1.0d0 + g1*y + g2*y*y)/(x*x*x*x) dz = dz0 + 4.0d0*(b2/b1 - gf) pb = z ab = -DLOG(x) - (g2 - 1.0d0)/x + 28.16666667d0/x/x + 1 4.0d0*y*(b2/b1 - gf) + 15.166666667d0 + 2 DLOG(d*t*gascon/.101325d0) gb = ab + z ub = -t*b1t*(z - 1.0d0 - d*b2)/b1 - d*t*b2t sb = ub - ab hb = z + ub bb2tt = t * t * b2tt cvb = 2.0d0*ub + (z0 - 1.0d0)*(((t*b1t/b1)*(t*b1t/b1)) - 1 t*t*b1tt/b1) - d*(bb2tt - gf*b1tt*t*t) - 2 (t*b1t/b1)*(t*b1t/b1)*y*dz0 dpdtb = pb/t + d*(dz*b1t/4.0d0 + b2t - b2/b1*b1t) RETURN END *********************************************************************** *** resid - Computes residual contributions to pressure (q), the * Helmloltz function (ar) , dP/dD (q5), the Gibbs function * (gr), entropy (sr), internal energy (ur), enthalpy (hr), * isochoric heat capacity (cvr), and dP/dT. The first 36 * terms of the residual function represent a global * least-squares fit to experimental data outside the * critical region, terms 37-39 affect only the immediate * vicinity of the critical point, and the last term (40) * contributes only in the high pressure, low temperature * region. SUBROUTINE resid(t,d) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION qr(11), qt(10), qzr(9), qzt(9) COMMON /resf/ ar, gr, sr, ur, hr, cvr, dpdtr COMMON /qqqq/ q, q5 COMMON /nconst/ g(40), ii(40), jj(40), n COMMON /aconst/ wm, gascon, tz, aa, z, dz, y, uref, sref COMMON /addcon/ atz(4), adz(4), aat(4), aad(4) COMMON /RTcurr/ rt COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL SAVE EQUIVALENCE (qr(3), qzr(1)), (qt(2), qzt(1)) qr(1) = 0.0d0 q5 = 0.0d0 q = 0.0d0 ar = 0.0d0 dadt = 0.0d0 cvr = 0.0d0 dpdtr = 0.0d0 e = DEXP(-aa * d) q10 = d * d * e q20 = 1.0d0 - e qr(2) = q10 v = tz / t qt(1) = t / tz DO 4 i=2,10 qr(i+1) = qr(i) * q20 4 qt(i) = qt(i-1) * v DO 10 i=1,n k = ii(i) + 1 l = jj(i) zz = k IF (k .EQ. 1) THEN qp = g(i) * aa * qr(2) * qzt(l) ELSE qp = g(i) * aa * qzr(k-1) * qzt(l) END IF q = q + qp q5 = q5 + aa*(2.0/d - aa*(1.0 - e*(k-1)/q20))*qp ar = ar + g(i)*qzr(k)*qzt(l)/q10/zz/rt dfdt = power(q20,DBLE(k))*(1-l)*qzt(l+1)/tz/k d2f = l * dfdt dpt = dfdt*q10*aa*k/q20 dadt = dadt + g(i)*dfdt dpdtr = dpdtr + g(i)*dpt 10 cvr = cvr + g(i)*d2f/gascon qp = 0.0d0 q2a = 0.0d0 DO 20 j=37,40 IF (g(j) .EQ. 0.0d0) GO TO 20 k = ii(j) km = jj(j) ddz = adz(j-36) del = d/ddz - 1.0d0 IF (DABS(del) .LT. 1.0d-10) del = 1.0d-10 ex1 = -aad(j-36) * power(del,DBLE(k)) IF (ex1 .LT. EXPTOL) THEN dex = 0.0d0 ELSE dex = DEXP(ex1) * power(del,DBLE(km)) END IF att = aat(j-36) tx = atz(j-36) tau = t/tx - 1.0d0 ex2 = -att * tau * tau IF (ex2 .LE. EXPTOL) THEN tex = 0.0d0 ELSE tex = DEXP(ex2) END IF q10 = dex * tex qm = km/del - k*aad(j-36)*power(del,DBLE(k-1)) fct = qm * d*d * q10 / ddz q5t = fct*(2.0d0/d + qm/ddz) - (d/ddz)*(d/ddz)*q10 * 1 (km/del/del + k*(k-1)*aad(j-36) * 2 power(del,DBLE(k-2))) q5 = q5 + q5t*g(j) qp = qp + g(j)*fct dadt = dadt - 2.0d0*g(j)*att*tau* q10 /tx dpdtr = dpdtr - 2.0d0*g(j)*att*tau* fct /tx q2a = q2a + t*g(j)*(4.0d0*att*ex2 + 2.0d0*att)*q10/tx/tx ar = ar + q10*g(j)/rt 20 CONTINUE sr = -dadt / gascon ur = ar + sr cvr = cvr + q2a/gascon q = q + qp RETURN END ************************************************************************ *** ideal - Computes thermodynamic properties for H2O in the * ideal gas state using equations given by Woolley (1979). SUBROUTINE ideal(t) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION c(18) COMMON /idf/ ai, gi, si, ui, hi, cvi, cpi SAVE DATA c / .19730271018d2, .209662681977d2, -.483429455355d0, 1 .605743189245d1, .2256023885d2, -.987532442d1, 2 -.43135538513d1, .458155781d0, -.47754901883d-1, 3 .41238460633d-2, -.27929052852d-3, .14481695261d-4, 4 -.56473658748d-6, .16200446d-7, -.3303822796d-9, 5 .451916067368d-11, -.370734122708d-13, 6 .137546068238d-15/ tt = t / 1.0d2 tl = DLOG(tt) gi = -(c(1)/tt + c(2)) * tl hi = (c(2) + c(1)*(1.0d0 - tl)/tt) cpi = c(2) - c(1)/tt DO 8 i=3,18 emult = power(tt,DBLE(i-6)) gi = gi - c(i) * emult hi = hi + c(i) * (i-6) * emult 8 cpi = cpi + c(i) * (i-6) * (i-5) * emult ai = gi - 1.0d0 ui = hi - 1.0d0 cvi = cpi - 1.0d0 si = ui - ai RETURN END ****************************************************************************** *** dalHGK - Computes/returns (d(alpha)/dt)p(d,t,alpha) * for the Haar et al. (1983) equation of state. DOUBLE PRECISION FUNCTION dalHGK(d,t,alpha) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION tempi(4), densi(4), betai(4), alphai(4), 1 g(40), k, l, km, lm, kp, lp INTEGER ll(40), kk(40) COMMON /aconst/ wm, gascon, tz, a, z, dz, y, uref, sref COMMON /ellcon/ g1, g2, gf, b1, b2, b1t, b2t, b1tt, b2tt COMMON /basef/ ab, gb, sb, ub, hb, cvb, pb, dpdtb COMMON /resf/ ar, gr, sr, ur, hr, cvr, dpdtr COMMON /qqqq/ q, q5 COMMON /nconst/ g, kk, ll, n COMMON /addcon/ tempi, densi, betai, alphai COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL SAVE *** evaluate derivatives for the base function y = .25d0 * b1 * d x = 1.0d0 - y dydtp = (d/4.0d0)*(b1t - b1*alpha) dbdd = gascon*t * ((b1/4.0d0/x) * (1.0d0 - (g2-1.0d0)/x + 1 (g1+g2+1.0d0)/x/x) + b2 - b1*gf + 1.0d0/d) db2dd = gascon*t* ((b1*b1/16.0d0/x/x) * (1.0d0 - 1 2.0d0*(g2-1.0d0)/x + 3.0d0*(g1+g2+1.0d0)/x/x) - 2 1.0d0/d/d) db2ddt = gascon*t * ((b1t/4.0d0/x/x) * 1 (1.0d0 - (g2-1.0d0)*(1.0d0+y)/x + 2 (g1+g2+1.0d0)*(1.0d0+2.0d0*y)/x/x) + 3 b2t - gf*b1t) + dbdd/t db2dtp = dbdd/t + gascon*t* ( (b1*dydtp/4.0d0/x/x/x) * 1 (1.0d0 - g2 + 2.0d0*(g1+g2+1.0d0)/x) + 2 ((x*b1t + b1*dydtp)/4.0d0/x/x) * 3 (1.0d0 - (g2-1.0d0)/x + (g1+g2+1.0d0)/x/x) + 4 b2t - gf*b1t + alpha/d ) db3ddt = db2dd/t + gascon*t * ( (b1*b1*dydtp/8.0d0/x/x/x/x) * 1 (1.0d0 - g2 + 3.0d0*(g1+g2+1.0d0)/x) + 2 (b1*(x*b1t + b1*dydtp)/8.0d0/x/x/x) * 3 (1.0d0 - 2.0d0*(g2-1.0d0)/x + 3.0d0*(g1+g2+1.0d0)/x/x) 4 - 2.0d0*alpha/d/d ) db3dtt = (db2ddt - dbdd/t)/t + gascon*t* ( 1 (b1t*dydtp/2.0d0/x/x/x/x) * (1.0d0 - g2 + 2 (g1+g2+1.0d0)*(2.0d0+y)/x) + 3 ((x*b1tt + 2.0d0*b1t*dydtp)/4.0d0/x/x/x) * (1.0d0 - 4 (g2-1.0d0)*(1+y)/x + (g1+g2+1.0d0)*(1.0d0+2.0d0*y)/x/x) 5 + b2tt - gf*b1tt ) + (t*db2dtp - dbdd)/t/t *********************************************************** *** evaluate derivatives for the residual function * drdd = q/d/d * dr2dd = (q5 - 2.0d0/d*q)/d/d * dr2ddt = dpdtr/d/d e1 = DEXP(-a * d) e2 = 1.0d0 - e1 tzt = tz / t drdd = 0.0d0 dr2dd = 0.0d0 dr2ddt = 0.0d0 dr2dtp = 0.0d0 dr3ddt = 0.0d0 dr3dtt = 0.0d0 *** evaluate terms 1-36 DO 10 i=1,n k = DBLE(kk(i)) + 1.0d0 l = DBLE(ll(i)) - 1.0d0 km = k - 1.0d0 lm = l - 1.0d0 kp = k + 1.0d0 lp = l + 1.0d0 xtzt = power(tzt,l) drdd = drdd + g(i) * xtzt*power(e2,km)*e1 dr2dd = dr2dd + g(i) * e1*xtzt*power(e2,km) * 1 (km*e1/e2 - 1.0d0) dr2ddt = dr2ddt - g(i)*e1*l*power(e2,km)*power(tzt,lp)/tz dr2dtp = dr2dtp + g(i)*e1*power(e2,km)*xtzt * 1 ( d*alpha - l/t - km*e1*d*alpha/e2 ) dr3ddt = dr3ddt + g(i)*( km*d*alpha*e1*e1*xtzt* 1 power(e2,k-3.0d0) + e1*xtzt*power(e2,km)* 2 (km*e1/e2 - 1.0d0) * (d*alpha - l/t - 3 km*d*alpha*e1/e2) ) dr3dtt = dr3dtt + g(i)*l*e1*power(e2,km)*power(tzt,lp)/tz 1 * ( lp/t + d*alpha*km*e1/e2 - d*alpha ) 10 CONTINUE *** evaluate terms 37-40 DO 20 i=37,40 k = DBLE(kk(i)) l = DBLE(ll(i)) km = k - 1.0d0 lm = l - 1.0d0 kp = k + 1.0d0 lp = l + 1.0d0 ai = alphai(i-36) bi = betai(i-36) di = densi(i-36) ti = tempi(i-36) tau = t/ti - 1.0d0 del = d/di - 1.0d0 IF (DABS(del) .LT. 1.0d-10) del = 1.0d-10 ex1 = -ai * power(del,k) IF (ex1 .LT. EXPTOL) THEN dex = 0.0d0 ELSE dex = DEXP(ex1) END IF ex2 = -bi * tau * tau IF (ex2 .LE. EXPTOL) THEN tex = 0.0d0 ELSE tex = DEXP(ex2) END IF ex12 = dex * tex qm = l/del - k*ai*power(del,km) xdell = power(del,l) xdelk = power(del,k) drdd = drdd + g(i)*xdell*ex12/di*qm dr2dd = dr2dd + g(i)*xdell*ex12/di/di * (qm*qm - 1 l/di/di - ai*k*km*power(del,k-2.0d0)) dr2ddt = dr2ddt - g(i)*2.0d0*bi*tau*ex12*xdell/ti/di*qm dr2dtp = dr2dtp + g(i)/di*( d*alpha*xdell*ex12/di/del/del * 1 (l + ai*k*km*xdelk) + qm * ( ex12 * 2 ( xdell* (k*ai*d*alpha*power(del,km)/di - 3 2.0d0*bi*tau/ti) - l*d*alpha*power(del,lm)/di) ) ) dr3ddt = dr3ddt + g(i)/di/di*( xdell*ex12* (2.0d0*qm* 1 (l*d*alpha/di/del/del + ai*k*km*d*alpha* 2 power(del,k-2.0d0)/di) - 2.0d0*l*d*alpha/di/del 3 /del/del + ai*k*km*(k-2.0d0)*power(del,k-3.0d0)* 4 d*alpha/di) + (qm*qm - l/del/del - ai*k*km* 5 power(del,k-2.0d0)) *(ex12*xdell*( ai*k* 6 power(del,k-1.0d0)*d*alpha/di - 2.0d0*bi*tau/ti ) - 7 ex12*l*power(del,l-1.0d0)*d*alpha/di) ) dr3dtt = dr3dtt - 2.0d0*g(i)*bi/ti/di * ( tau*xdell*ex12*d* 1 alpha/del/del/di * (l + ai*k*km*power(del,k)) + 2 qm*( xdell*ex12*( ai*k*d*alpha*tau*power(del,km)/di 3 + (1.0d0 - 2.0d0*bi*tau*tau)/ti - 4 tau*l*d*alpha/di/del ) ) ) 20 CONTINUE *** compute (d(alpha)/dT)P dalHGK = ((db3dtt + dr3dtt)*(2.0d0*(dbdd + drdd) + 1 d*(db2dd + dr2dd)) - 2 (db2ddt + dr2ddt)*(2.0d0*(db2dtp + dr2dtp) + 3 d*(db3ddt + dr3ddt) - d*alpha*(db2dd + dr2dd))) / 4 (2.0d0*(dbdd + drdd) + d*(db2dd + dr2dd)) / 5 (2.0d0*(dbdd + drdd) + d*(db2dd + dr2dd)) RETURN END ****************************************************************************** *** denHGK - Computes density (d in g/cm3) and dP/dD (dPdd) as * f(p(MPa),t(degK)) from an initial density guess (dguess). SUBROUTINE denHGK(d,p,dguess,t,dpdd) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /qqqq/ q0, q5 COMMON /aconst/ wm, gascon, tz, aa, z, dz, y, uref, sref COMMON /basef/ ab, gb, sb, ub, hb, cvb, pb, dpdtb COMMON /RTcurr/ rt SAVE i = 0 d = dguess 10 i = i + 1 IF (d .LE. 0.0d0) d = 1.0d-8 IF (d .GT. 1.9d0) d = 1.9d0 CALL resid(t,d) CALL base(d,t) pp = rt * d * pb + q0 dpdd = rt * (z + y * dz) + q5 *** if dpdd < 0 assume d in 2-phase region and adjust accordingly *** IF (dpdd .GT. 0.0d0) GO TO 20 IF (dguess .GE. 0.2967d0) d = d * 1.02d0 IF (dguess .LT. 0.2967d0) d = d * 0.98d0 IF (i .LE. 10) GO TO 10 20 dpdx = dpdd * 1.1d0 IF (dpdx .LT. 0.1d0) dpdx = 0.1d0 dp = DABS(1.0d0 - pp/p) IF ((dp .LT. 1.0d-8) .OR. 1 ((dguess .GT. 0.3d0) .AND. (dp .LT. 1.0d-7)) .OR. 2 ((dguess .GT. 0.7d0) .AND. (dp .LT. 1.0d-6))) RETURN x = (p - pp) / dpdx IF (DABS(x) .GT. 0.1d0) x = x * 0.1d0 / DABS(x) d = d + x IF (d .LE. 0.0d0) d = 1.0d-8 IF (i .LE. 30) GO TO 10 RETURN END *********************************************************************** *** PsHGK - Returns an approximation to Psaturation(T) that agrees * to within 0.02% of that predicted by the HGK surface * for temperatures up to within roughly a degree of * the critical point. DOUBLE PRECISION FUNCTION PsHGK(t) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION a(8) SAVE DATA a /-.78889166d1, .25514255d1, -.6716169d1, .33239495d2, 1 -.10538479d3, .17435319d3, -.14839348d3, .48631602d2/ IF (T .LE. 314.0d0) THEN pl = 6.3573118d0 - 8858.843d0/t + 1 607.56335d0 * power(t,-0.6d0) PsHGK = 0.1d0 * DEXP(pl) ELSE v = t / 647.25d0 w = DABS(1.0d0 - v) b = 0.0d0 DO 4 i=1,8 z = i b = b + a(i)*power(w,(z + 1.0d0)/2.0d0) 4 CONTINUE q = b / v PsHGK = 22.093d0 * DEXP(q) END IF RETURN END *********************************************************************** *** TsHGK - Returns Tsaturation(P). DOUBLE PRECISION FUNCTION TsHGK(p) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE TsHGK = 0.0d0 IF (p .GT. 22.05d0) RETURN k = 0 pl = 2.302585d0 + DLOG(p) tg = 372.83d0 + 1 pl*(27.7589d0 + pl*(2.3819d0 + pl*(0.24834d0 + 2 pl*0.0193855d0))) 1 IF (tg .LT. 273.15d0) tg = 273.15d0 IF (tg .GT. 647.00d0) tg = 647.00d0 IF (k .GE. 8) THEN TsHGK = tg ELSE k = k + 1 pp = PsHGK(tg) dp = TdPsdT(tg) IF (ABS(1.0d0 - pp/p) .LT. 1.0d-5) THEN TsHGK = tg ELSE tg = tg * (1.0d0 + (p - pp)/dp) GO TO 1 END IF END IF RETURN END *********************************************************************** *** TdPsdT - Returns T*(dPsat/dT). DOUBLE PRECISION FUNCTION TdPsdT(t) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION a(8) SAVE DATA a /-.78889166d1, .25514255d1, -.6716169d1, .33239495d2, 1 -.10538479d3, .17435319d3, -.14839348d3, .48631602d2/ v = t / 647.25d0 w = 1.0 - v b = 0.0d0 c = 0.0d0 DO 4 i=1,8 z = i y = a(i) * power(w,(z + 1.0d0)/2.0d0) c = c + y/w*(0.5d0 - 0.5d0*z - 1.0d0/v) 4 b = b + y q = b / v TdPsdT = 22.093d0 * DEXP(q) * c RETURN END *********************************************************************** *** corr - Computes liquid and vapor densities (dliq & dvap) * and (Gl-Gv)/RT (delg) for T-P conditions on or * near the saturation surface. SUBROUTINE corr(itripl,t,p,dl,dv,delg,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER epseqn COMMON /qqqq/ q00, q11 COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref COMMON /fcts/ ad, gd, sd, ud, hd, cvd, cpd, dpdt, dvdt, dpdd, 1 cjtt, cjth COMMON /basef/ ab, gb, sb, ub, hb, cvb, pb, dpdtb COMMON /RTcurr/ rt COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /HGKcrt/ tcHGK, dcHGK, pcHGK SAVE CALL bb(t) dguess = dl IF (dl .LE. 0.0d0) dguess = 1.11d0 - 0.0004d0*t CALL denHGK(dl,p,dguess,t,dpdd) CALL ideal(t) CALL thmHGK(dl,t) *** save liquid properties CALL dimHGK(1,itripl,t,p,dl,epseqn) gl = gd dguess = dv IF (dv .LE. 0.0d0) dguess = p / rt CALL denHGK(dv,p,dguess,t,dpdd) IF (dv .LT. 5.0d-7) dv = 5.0d-7 CALL ideal(t) CALL thmHGK(dv,t) *** vapor properties will be available *** in COMMON /fcts/ (dimensionless) after *** pcorr's final call of corr (delg < 10d-4) gv = gd delg = gl - gv RETURN END *********************************************************************** *** pcorr - Computes Psaturation(T) (p) and liquid and vapor * densities (dl & dv) from refinement of an initial * approximation (PsHGK(t)) in accord with Gl = Gv. SUBROUTINE pcorr(itripl,t,p,dl,dv,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER epseqn COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref SAVE p = PsHGK(t) dl = 0.0d0 dv = 0.0d0 2 CALL corr(itripl,t,p,dl,dv,delg,epseqn) dp = delg * gascon * T / (1.0d0/dv - 1.0d0/dl) p = p + dp IF (DABS(delg) .GT. 1.0d-4) GO TO 2 RETURN END ************************************************************ *** tcorr - Computes Tsaturation(P) (t) and liquid and vapor * densities (dl & dv) from refinement of an initial * approximation (TsHGK(p)) in accord with Gl = Gv. SUBROUTINE tcorr(itripl,t,p,dl,dv,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) INTEGER epseqn COMMON /aconst/ wm, gascon, tz, aa, zb, dzb, yb, uref, sref COMMON /RTcurr/ rt SAVE t = TsHGK(p) IF (t .EQ. 0.0d0) RETURN dl = 0.0d0 dv = 0.0d0 1 rt = t * gascon CALL corr(itripl,t,p,dl,dv,delg,epseqn) dp = delg * gascon * t / (1.0d0/dv - 1.0d0/dl) t = t * (1.0d0 - dp/TdPsdT(t)) IF (DABS(delg) .GT. 1.0d-4) GO TO 1 RETURN END *************************************************************** *** LVSeqn - Computes thermodynamic and transport properties of * critical region H2O (369.85-419.85 degC, * 0.20-0.42 gm/cm3) from the fundamental equation given * by Levelt Sengers, et al (1983): J.Phys.Chem.Ref.Data, * V.12, No.1, pp.1-28. SUBROUTINE LVSeqn(isat,iopt,itripl,T,P,Dens,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23) DOUBLE PRECISION wprops(NPROP), wpliq(NPROP), Dens(2) LOGICAL cpoint INTEGER epseqn COMMON /coefs/ a(20), q(20), x(11) COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon COMMON /therm/ AE, GE, U, H, Entrop, Cp, Cv, betaw, alphw, 1 heat, Speed COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /param/ r1, th1 COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /wpvals/ wprops, wpliq SAVE cpoint = .FALSE. DH2O = Dens(1) 10 CALL LVSsat(iopt,isat,T,P,DH2O) IF ((isat .NE. 0) .OR. (iopt .NE. 1)) CALL denLVS(isat,T,P) IF (isat .EQ. 0) THEN Dens(1) = DH2O ELSE Dens(1) = Dliq Dens(2) = Dvap END IF IF (isat .EQ. 0) THEN CALL thmLVS(isat,T,r1,th1) CALL dimLVS(isat,itripl,th1,T,P*1.0d1,dl,dv,wprops,epseqn) IF (cpoint) THEN CALL cpswap Dens(1) = cdens Dens(2) = cdens isat = 1 iopt = ioptsv END IF ELSE th1 = -1.0d0 CALL thmLVS(isat,T,r1,th1) CALL dimLVS(isat,itripl,th1,T,P*1.0d1,dl,dv,wprops,epseqn) th1 = 1.0d0 CALL thmLVS(isat,T,r1,th1) CALL dimLVS(isat,itripl,th1,T,P*1.0d1,dl,dv,wpliq,epseqn) IF (dl .EQ. dv) THEN cpoint = .TRUE. cdens = dl T = 647.0670000003d0 P = 22.0460000008d0 ioptsv = iopt iopt = 2 isat = 0 GO TO 10 END IF END IF END ********************************************************************* *** cpswap - Load critical point A, G, U, H, S, Vs, Di, ZB, * albe values from wpliq into wprops and * approximations to critical Cv, Cp, alpha, beta, * visc, tcond, Prndtl, tdiff, visck, YB, QB, XB, * daldT, st values from wprops into wpliq. SUBROUTINE cpswap IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23) INTEGER aw, gw, sw, uw, hw, cvw, cpw, vsw, alw, bew, 1 diw, viw, tcw, stw, tdw, Prw, vikw, albew, 2 ZBw, YBw, QBw, dalwdT, XBw DOUBLE PRECISION wprops(NPROP), wpliq(NPROP) COMMON /wpvals/ wprops, wpliq COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc SAVE DATA aw, gw, sw, uw, hw, cvw, cpw, vsw, alw, bew, diw, viw, 1 tcw, stw, tdw, Prw, vikw, albew, ZBw, YBw, QBw, 2 dalwdT, XBw 2 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 3 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23 / wprops(aw) = wpliq(aw) wprops(gw) = wpliq(gw) wprops(sw) = wpliq(sw) wprops(uw) = wpliq(uw) wprops(hw) = wpliq(hw) wprops(diw) = wpliq(diw) wprops(ZBw) = wpliq(ZBw) wprops(stw) = wpliq(stw) wpliq(cvw) = wprops(cvw) wpliq(cpw) = wprops(cpw) wpliq(alw) = wprops(alw) wpliq(bew) = wprops(bew) wpliq(YBw) = wprops(YBw) wpliq(QBw) = wprops(QBw) wpliq(XBw) = wprops(XBw) wpliq(tcw) = wprops(tcw) wpliq(tdw) = wprops(tdw) wpliq(Prw) = wprops(Prw) wpliq(dalwdT) = wprops(dalwdT) wpliq(albew) = wprops(albew) wprops(vsw) = 0.429352766443498d2 * fs wprops(viw) = 1.0d6 wprops(vikw) = 1.0d6 wpliq(vsw) = wprops(vsw) wpliq(viw) = wprops(viw) wpliq(vikw) = wprops(vikw) END ********************************************************************* *** LVSsat - If isat=1, computes Psat(T) or Tsat(P) (iopt=1,2). * If isat=0, checks whether T-D or T-P (iopt=1,2) * falls on or within TOL of the liq-vap surface; if so, * isat <- 1 and T <- Tsat. SUBROUTINE LVSsat(iopt,isat,T,P,D) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon SAVE DATA ERRTOL, TCTOL / 1.0d-12, 1.0d-2 / IF (isat .EQ. 1) THEN IF (iopt .EQ. 1) THEN P = Pfind(isat,T,D) END IF T = TsLVS(isat,P) ELSE IF (iopt .EQ. 1) THEN P = Pfind(isat,T,D) END IF IF (P-ERRTOL .GT. Pc) THEN RETURN ELSE CALL backup Tsat = TsLVS(isat,P) IF (DABS(Tsat-T) .LT. TCTOL) THEN T = Tsat isat = 1 ELSE CALL restor END IF END IF END IF RETURN END ********************************************************************* *** denLVS - Calculates DH2O(T,P) or Dvap,Dliq(T,P) from the * Levelt Sengers, et al (1983) critical region * equation of state. SUBROUTINE denLVS(isat,T,P) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s(2), sd(2) COMMON /coefs/ a(20), q(20), x(11) COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /therm/ AE, GE, U, H, Entrop, Cp, Cv, betaw, alphw, 1 heat, Speed COMMON /param/ r1, th1 COMMON /deri2/ dPdD, dPdT SAVE EQUIVALENCE (Dmin, x(4)), (Dmax, x(5)), (pw11, q(9)), 1 (xk0, a(7)), (xk1, a(12)) IF (isat .EQ. 0) THEN DH2O = rhoc DO 10 i=1,20 Pnext = Pfind(isat,T,DH2O) Pdif = Pnext - P IF (iphase .EQ. 2) THEN IF (DABS(Pdif) .LE. 0.0d0) THEN RETURN ELSE END IF IF (Pdif .LT. 0.0d0) THEN DH2O = Dmax ELSE DH2O = Dmin END IF ELSE delD = -Pdif/dPdD DH2O = DH2O + delD IF (DH2O .LT. Dmin) DH2O = Dmin IF (DH2O .GT. Dmax) DH2O = Dmax IF (DABS(delD/DH2O) .LT. 1.0d-6) RETURN END IF 10 CONTINUE ELSE Tw = -Tc/T dTw = 1.0d0 + Tw CALL ss(r1,th1,s,sd) rho1 = 1.0d0+pw11*dTw+a(1)*(s(1)+s(2)) rho2 = xk0*power(r1,a(6)) + xk1*power(r1,q(16)) Dvap = rhoc * (rho1 - rho2) Dliq = rhoc * (rho1 + rho2) RETURN END IF RETURN END ********************************************************************* *** TsLVS - Returns saturation T(P) DOUBLE PRECISION FUNCTION TsLVS(isat,P) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /therm/ AE, GE, U, H, Entrop, Cp, Cv, betaw, alphw, 1 heat, Speed COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon COMMON /deri2/ dPdD, dPdT SAVE TsLVS2 = Tc - 1.0d0 D = rhoc DO 10 i=1,20 Pnext = Pfind(isat,TsLVS2,D) dT = (Pnext - P)/dPdT TsLVS2 = TsLVS2 - dT IF (TsLVS2 .GT. Tc) THEN TsLVS2 = Tc ELSE IF (DABS(dT/TsLVS2) .LT. 1.0d-8) THEN GO TO 20 ELSE END IF END IF 10 CONTINUE 20 TsLVS = TsLVS2 RETURN END ********************************************************************* *** Pfind - Returns P(T,D). Computes (dP/dD)T when invoked by SUB * Dfind (isat=0) and (dP/dT)D when invoked by SUB TsLVS * (isat=1). Also computes 1st & 2nd partial derivatives * the singular part of the potential (Delta P tilde) that * are used in SUB thmLVS. DOUBLE PRECISION FUNCTION Pfind(isat,T,D) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s(2), xk(2), sd(2) COMMON /coefs/ a(20), q(20), x(11) COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /therm/ AE, GE, U, H, Entrop, Cp, Cv, betaw, alphw, 1 heat, Speed COMMON /param/ r1, th1 COMMON /tolers/ TTOL, PTOL, DTOL, XTOL, EXPTOL, FPTOL COMMON /deriv/ amu, s, Pw, Tw, dTw, dM0dT, dP0dT, 1 d2PdM2, d2PdMT, d2PdT2, p0th, p1th, xk COMMON /deri2/ dPdD, dPdT *************************************** COMMON /abc2/ r, th *************************************** SAVE EQUIVALENCE (Pw1, a(5)), (Pw2, a(4)), (Pw3, a(2)), 1 (amc, a(13)), (am1, a(14)), (am2, a(15)), 2 (am3, a(16)), (p00, q(11)), (p20, q(12)), 3 (p40, q(13)), (p01, q(18)), (p21, q(19)), 4 (p41, q(20)), (aa, a(10)), (xk0, a(7)), 5 (xk1, a(12)), (pw11,q(9)), (alpha,q(10)), 6 (alhi,q(15)), (besq,a(9)) xk(1) = xk0 xk(2) = xk1 IF (DABS(T-Tc) .LT. FPTOL) T = Tc Tee = (T-Tc)/Tc Tw = -Tc/T dTw = 1.0d0 + Tw IF (isat .EQ. 0) THEN rho = D / rhoc CALL conver(rho,Tee,amu,th1,r1,rho1,s,rhodi,err) ELSE th1 = -1.0d0 th = th1 r1 = dTw/(1.0d0-besq) r = r1 CALL ss(r1,th1,s,sd) rho = th1 * (xk0*power(r1,a(6)) + 1 xk1*power(r1,q(16))) + 2 a(1)*(s(1)+s(2)) rho = 1.0d0+pw11*dTw+rho amu = 0.0d0 D = rho * rhoc END IF tt1 = th1*th1 tt2 = tt1*tt1 Pw0 = 1.0d0+dTw*(Pw1+dTw*(Pw2+dTw*Pw3)) IF (isat .EQ. 0) THEN Pwmu = amu*rhodi ELSE Pwmu = 0.0d0 END IF p0th = p00+p20*tt1+p40*tt2 p1th = p01+p21*tt1+p41*tt2 dPw0 = xk0*p0th*power(r1,2.0d0-alpha) dPw1 = xk1*p1th*power(r1,2.0d0-alhi) dPw = aa*(dPw0+dPw1) Pw = Pw0 + Pwmu + dPw Pfind = Pw * Pcon * T IF (DABS(th1) .LT. 1.0d0) THEN iphase = 1 ELSE iphase = 2 dP0dT = Pw1+dTw*(2.0d0*Pw2+3.0d0*Pw3*dTw) dM0dT = am1+dTw*(2.0d0*am2+3.0d0*am3*dTw) Uw = dP0dT-rho*dM0dT+pw11*amu+s(1)+s(2) dPdTcd = Uw + rho*dM0dT dPwdTw = Pw - Tw*dPdTcd dPdT = Pcon * dPwdTw END IF CALL aux(r1,th1,d2PdT2,d2PdMT,d2PdM2,aa,xk,sd,Cvcoex) IF (iphase .EQ. 1) dPdD = dPcon * D * T / d2PdM2 RETURN END *************************************************************** *** aux - Calculates some second derivatives of the * anomalous part of the equation of state. SUBROUTINE aux(r1,th1,d2PdT2,d2PdMT,d2PdM2,aa,xk,sd,Cvcoex) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION xk(2), s(2), sd(2), w(2), y(2), z(2), coex(2) COMMON /coefs/ a(20), q(20), x(11) SAVE EQUIVALENCE (cc, a(1)), (beta, a(6)), (besq,a(9)), 1 (delta,a(11)), (alpha,q(10)), (s00, a(17)), 2 (s20, a(18)), (s01, a(19)), (s21, a(20)) deli = 0.0d0 s(1) = s00+s20*th1*th1 s(2) = s01+s21*th1*th1 sd(1) = 2.0*th1*s20 sd(2) = 2.0*th1*s21 ww = 0.0d0 yy = 0.0d0 zz = 0.0d0 gamma = beta*(delta-1.0d0) tt1 = th1*th1 ter = 2.0d0*beta*delta-1.0d0 g = (1.0+(besq*ter-3.0)*tt1 - besq*(ter-2.0)*tt1*tt1) Cvcoex = 0.0d0 DO 30 i=1,2 alhi = alpha - deli beti = beta + deli gami = gamma - deli IF (r1 .NE. 0.0d0) THEN w(i) = (1.0-alhi)*(1.0-3.0*tt1)*s(i) - 1 beta*delta*(1.0-tt1)*th1*sd(i) w(i) = (w(i)*power(r1,-alhi))/g w(i) = w(i) * xk(i) ww = ww + w(i) y(i) = beti*(1.0d0-3.0d0*tt1)*th1 - 1 beta*delta*(1.0d0-tt1)*th1 y(i) = (y(i)*power(r1,beti-1.0d0)) * xk(i) / g yy = yy + y(i) z(i) = 1.0d0-besq*(1.0d0-(2.0d0*beti))*tt1 z(i) = (z(i)*power(r1,-gami)) * xk(i) / g zz = zz + z(i) a1 = (beta*(delta-3.0d0)-3.0d0*deli-besq*alhi*gami) / 1 (2.0d0*besq*besq*(2.0d0-alhi)*(1.0d0-alhi)*alhi) a2 = 1+((beta*(delta-3.0d0)-3.0d0*deli-besq*alhi*ter) / 1 (2.0d0*besq*(1.0d0-alhi)*alhi)) a2 = -a2 a4 = 1.0d0+((ter-2.0d0)/(2.0d0*alhi)) f1 = a1 + a2 + a4 coex(i) = ((2.0d0-alhi)*(1.0d0-alhi)*power(r1,-alhi) * 1 f1*xk(i)) Cvcoex = Cvcoex + coex(i) END IF deli = 0.5d0 30 CONTINUE d2PdT2 = aa * ww d2PdMT = yy + aa*cc*ww d2PdM2 = zz/aa + 2.0d0*cc*yy + cc*cc*aa*ww RETURN END *************************************************************** *** conver - Transforms T,D to parametric variables r,theta * according to the revised and scaled equations. SUBROUTINE conver(rho,Tee,amu,th1,r1,rho1s,s1,rhodi,error1) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s1(2), sd(2) COMMON /coefs/ a(20), q(20), x(11) COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon ************************************************************** COMMON /abc2/ r, th ************************************************************** SAVE EQUIVALENCE (beta,a(6)), (delta,a(11)), (xk1, a(12)), 1 (cc, a(1)), (alhi, q(15)), (alpha,q(10)), 2 (besq,a(9)), (p11, q(9)), (deli, q(14)), 3 (p1w, q(18)), (p2w, q(19)), (p4w, q(20)), 4 (aa, a(10)), (xk0, a(7)), (s00, a(17)), 5 (s20, a(18)), (betai,q(16)) Tstar = Tee + 1.0d0 dtstin = 1.0d0 - (1.0d0 / Tstar) r1 = dtstin IF (dtstin .LE. 0.0d0) THEN r1 = dtstin/(1.0d0-besq) th1 = 1.0d0 ELSE th1 = 0.0d0 END IF CALL ss(r1,th1,s1,sd) rhodi = 1.0d0 + p11*dtstin rhodit = rhodi + cc*s1(1) + cc*s1(2) drho = rho - rhodit amu = 0.0d0 IF (dtstin .LE. 0.0d0) THEN rho1co = xk0*power(r1,beta) + xk1*power(r1,betai) twofaz = rho1co IF (DABS(drho) .LE. twofaz) THEN rho1s = DSIGN(rho1co,drho) + cc*s1(1) th1 = DSIGN(1.00d0,drho) error1 = 1.0d0 r = r1 th = th1 RETURN END IF END IF IF (drho .EQ. 0.0d0) THEN th1 = 0.0d0 r1 = dtstin rho1s = cc*s1(1) END IF *** rule for first pass *** y1 = dtstin den1 = rho - rhodit CALL rtheta(r1,th1,den1,y1) tt = th1*th1 amu = aa*power(r1,beta*delta)*th1*(1.0d0-tt) y1 = dtstin + cc*amu CALL ss(r1,th1,s1,sd) rhoweg = xk1*power(r1,betai)*th1 + cc*s1(2) rho1s = den1 + cc*s1(1) + rhoweg error1 = rho - rhodi - rho1s r = r1 th = th1 IF (DABS(error1) .LT. 1.0d-5) THEN RETURN END IF *** rule for second pass *** den12 = rho - rhodi - cc*s1(1) + rhoweg IF (den12 .EQ. den1) den12 = den1 - 1.0d-6 CALL rtheta(r1,th1,den12,y1) tt = th1*th1 amu = aa*power(r1,beta*delta)*th1*(1.0d0-tt) y1 = dtstin + cc*amu CALL ss(r1,th1,s1,sd) rhoweg = xk1*power(r1,betai)*th1 + cc*s1(2) rho1s2 = den12 + cc*s1(1) + rhoweg error2 = rho - rhodi - rho1s2 IF (DABS(error2) .LE. 1.0d-5) THEN r = r1 th = th1 error1 = error2 rho1s = rho1s2 RETURN END IF *** rule for nth pass *** den2 = den12 DO 44 isig=1,10 slope = (error2-error1)/(den2-den1) hold = den2 den2 = den1 - (error1/slope) CALL rtheta(r1,th1,den2,y1) tt = th1*th1 amu = aa*power(r1,beta*delta)*th1*(1.0d0-tt) y1 = dtstin + cc*amu CALL ss(r1,th1,s1,sd) rhoweg = xk1*power(r1,betai)*th1 + cc*s1(2) rho1s = den2 + cc*s1(1) + rhoweg error1 = error2 error2 = rho - rhodi - rho1s r = r1 th = th1 IF (DABS(error2) .LT. 1.0d-6) RETURN den1 = hold 44 CONTINUE RETURN END ********************************************************************* *** rtheta - Fits data for 1.0 < theta < 1.000001. * Solves: * rho = em*theta*(r**beta) * Tee = r*(1.0d0-besq*theta*theta) * * Routine given by Moldover (1978): Jour. Res. NBS, v. 84, n. 4, * p. 329 - 334. SUBROUTINE rtheta(r,theta,rho,Tee) IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /coefs/ a(20), q(20), x(11) SAVE EQUIVALENCE (beta,a(6)), (em,a(7)), (besq,a(9)) IF (em .LE. 0.0d0 .OR. besq .LE. 1.0d0) GO TO 600 absrho = DABS(rho) IF (absrho .LT. 1.0d-12) GO TO 600 bee = DSQRT(besq) IF (DABS(Tee) .LT. 1.0d-12) GO TO 495 IF (Tee .LT. 0.0d0) THEN z = 1.0d0-(1.0d0-bee)*Tee/(1.0d0-besq) * 1 power(em/absrho,1.0d0/beta) ELSE z = power(1.0d0+Tee*power(em/bee/absrho,1.0d0/beta), 1 -beta) END IF IF (z .GT. 1.00234d0*bee) GO TO 496 c = -rho*bee/em/power(DABS(Tee),beta) z = DSIGN(z,rho) DO 500 n=1,16 z2 = z*z z3 = 1.0d0 - z2 dz = z3*(z+c*power(DABS(z3),beta))/(z3+2.0d0*beta*z2) z = z - dz IF (DABS(dz/z) .LT. 1.0d-12) GO TO 498 500 CONTINUE 601 IF (DABS(theta) .GT. 1.0001d0) theta = theta/DABS(theta) RETURN 498 theta = z/bee r = Tee/(1.0d0-z*z) r = DABS(r) RETURN 495 theta = DSIGN(1.0d0,rho)/bee r = power(rho/(em*theta),1.0d0/beta) RETURN 496 theta = DSIGN(1.0d0,rho) r = Tee/(1.0d0-besq) r = DABS(r) RETURN 600 IF (DABS(Tee) .LT. 1.0d-12) GO TO 601 IF (Tee .LT. 0.0d0) GO TO 496 theta = 1.0d-12 r = Tee RETURN END ********************************************************************* *** ss - Computes terms of the summation that defines dPotl/dT * and the 1st derivative of the theta (s) square polynomial. SUBROUTINE ss(r,th,s,sd) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s(2), sd(2), sx(2) COMMON /coefs/ a(20), q(20), x(11) *************************************************************** COMMON /abc1/ dPdM *************************************************************** SAVE EQUIVALENCE (alpha,q(10)), (beta,a(6)), (besq,a(9)), 1 (delta,a(11)), (deli,q(14)), (alhi,q(15)), 2 (beti, q(16)), (gami,q(17)), (p00, q(11)), 3 (p01, q(18)), (s00, a(17)), (s20, a(18)), 4 (s01, a(19)), (s21, a(20)) tt = th*th sx(1) = s00 + s20*tt sd(1) = 2.0d0*s20*th sx(2) = s01 + s21*tt sd(2) = 2.0d0*s21*th s(1) = sx(1)*a(10)*a(7)*power(r,1.0d0-alpha) s(2) = sx(2)*a(10)*a(12)*power(r,1.0d0-alhi) dPdM = power(r,beta)*a(7)*th + a(1)*power(r,1.0d0-alpha)* 1 a(10)*a(7)*sx(1) + 2 power(r,beti)*a(12)*th + a(1)*power(r,1.0d0-alhi)* 3 a(10)*a(12)*sx(2) RETURN END ***************************************************************** *** thmLVS - Calculates thermodynamic and transport properties * of critical region H2O using the Levelt Sengers, et al * (1983) equation of state. SUBROUTINE thmLVS(isat,T,r1,th1) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s(2), xk(2), sd(2) COMMON /coefs/ a(20), q(20), x(11) COMMON /crits/ Tc, rhoc, Pc, Pcon, Ucon, Scon, dPcon COMMON /therm/ AE, GE, U, H, Entrop, Cp, Cv, betaw, alphw, 1 heat, Speed COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /deriv/ amu, s, Pw, Tw, dTw, dM0dT, dP0dT, 1 d2PdM2, d2PdMT, d2PdT2, p0th, p1th, xk COMMON /deri2/ dPdD, dPdT ************************************************************* COMMON /abc1/ dPdM COMMON /abc3/ dPdTcd ************************************************************* SAVE EQUIVALENCE (pw2, a(4)), (pw3, a(2)), (besq, a(9)), 1 (amc, a(13)), (am1, a(14)), (am2, a(15)), 2 (aa, a(10)), (xk0, a(7)), (am3, a(16)), 3 (xk1, a(12)), (pw11,q(9)), (alpha, q(10)), 4 (alhi,q(15)), (pw1, a(5)) d2P0dT = 2.0d0*pw2 + 6.0d0*pw3*dTw d2M0dT = 2.0d0*am2 + 6.0d0*am3*dTw dP0dT = pw1+dTw*(2.0d0*pw2+3.0d0*pw3*dTw) dM0dT = am1+dTw*(2.0d0*am2+3.0d0*am3*dTw) IF (isat .EQ. 0) THEN rho = DH2O / rhoc Uw = dP0dT-rho*dM0dT+pw11*amu+s(1)+s(2) ELSE rho = th1 * (xk0*power(r1,a(6)) + xk1*power(r1,q(16))) 1 + a(1)*(s(1)+s(2)) rho = 1.0d0+pw11*dTw+rho Uw = dP0dT-rho*dM0dT+pw11*amu+s(1)+s(2) DH2O = rho * rhoc dPdT2 = Pw - Tw*(Uw+rho*dM0dT) heat = 1.0d3*T*(Pcon*dPdT2)*(1.0d0/Dvap-1.0d0/Dliq) CALL ss(r1,th1,s,sd) CALL aux(r1,th1,d2PdT2,d2PdMT,d2PdM2,aa,xk,sd,Cvcoex) IF (r1 .NE. 0.0d0) THEN dPdD = dPcon * DH2O * T / d2PdM2 END IF END IF IF (r1 .NE. 0.0d0) THEN dPdTcd = dP0dT+pw11*(amu-rho/d2PdM2)+s(1)+s(2) - 1 d2PdMT*rho/d2PdM2 dPwdTw = Pw - Tw*dPdTcd dPdTal = Pcon * dPwdTw CviTw2 = d2P0dT - rho*d2M0dT + d2PdT2 - 1 (pw11+d2PdMT)*(pw11+d2PdMT)/d2PdM2 Cvw = CviTw2 * Tw*Tw Cpw = Cvw + d2PdM2*dPwdTw*dPwdTw / (rho*rho) betaw = 1.0d0 / (DH2O*dPdD) alphw = betaw * dPdTal Speed = 1.0d3 * DSQRT(Cpw/Cvw*dPdD) ELSE Cvw = 1.0d0 Cpw = 1.0d0 betaw = 1.0d0 alphw = 1.0d0 Speed = 0.0d0 END IF Hw = Pw - Tw*Uw Sw = Hw - rho*(amu+amc+dTw*(am1+dTw*(am2+dTw*am3))) Scond = Scon/DH2O U = Uw * Ucon/DH2O H = Hw * Scond * T entrop = Sw * Scond AE = U - T * entrop GE = H - T * entrop Cv = Cvw * Scond Cp = Cpw * Scond RETURN END ******************************************************** *** dalLVS - Computes/returns (d(alpha)/dt)p(D,T,alpha) * for the Levelt Sengers et al. (1983) * equation of state. Note that D (kg/m**3), * T (degK), P (MPa), alpha (degK**-1). DOUBLE PRECISION FUNCTION dalLVS(D,T,P,alpha) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION sss(2), xk(2), s(2), dsdT(2), sp(2), dspdT(2), 1 k(2), calpha(2), cbeta(2), cgamma(2), 2 u(2), v(2), w(2), dudT(2), dvdT(2), dwdT(2) COMMON /coefs/ aa(20), qq(20), xx(11) COMMON /crits/ Tc, Dc, Pc, Pcon, Ucon, Scon, dPcon COMMON /deriv/ amu, sss, Pw, Tw, dTw, dM0dT, dP0dT, 1 d2PdM2, d2PdMT, d2PdT2, p0th, p1th, xk COMMON /deri2/ dPdD, dPdT ************************************************************* COMMON /abc1/ dPdM COMMON /abc2/ r,th COMMON /abc3/ dPdTcd ************************************************************* SAVE EQUIVALENCE (a, aa(10)), (c, aa(1)), (delta, aa(11)), 1 (bsq, aa(9)), (P11, qq(9)), (Delta1, qq(14)), 2 (P1, aa(5)), (P2, aa(4)), (P3, aa(2)), 3 (s00, aa(17)), (s01, aa(19)), (s20, aa(18)), 4 (s21, aa(20)) IF (r .EQ. 0.0d0) THEN dalLVS = 1.0d6 RETURN END IF k(1) = aa(7) k(2) = aa(12) calpha(1) = qq(10) calpha(2) = qq(15) cbeta(1) = aa(6) cbeta(2) = qq(16) cgamma(1) = cbeta(1)*(delta - 1.0d0) cgamma(2) = cgamma(1) - Delta1 delT = (T - Tc) / T s(1) = s00 + s20*th**2 s(2) = s01 + s21*th**2 sp(1) = 2.0d0*s20*th sp(2) = 2.0d0*s21*th ********************************************************************* *** *** Compute drdT and d0dT from solution of the linear system *** *** ax = b *** *** d(dPdM)/dT = -D/Dc*alpha - P11*Tc/T**2 = ar1*drdT + a01*d0dT = b1 *** d(delT)/dT = Tc/T**2 = ar2*drdT + a02*d0dT = b2 *** b1 = -D/Dc*alpha - P11*Tc/T/T b2 = Tc/T**2 ar1 = 0.0d0 a01 = 0.0d0 DO 10 i = 1,2 ar1 = ar1 + k(i) * (cbeta(i)*th*power(r,cbeta(i)-1.0d0) + 1 a*c*(1.0d0 - calpha(i))*power(r,-calpha(i))*s(i)) a01 = a01 + k(i) * (power(r,cbeta(i)) + a*c*sp(i)* 1 power(r,1.0d0-calpha(i))) 10 CONTINUE ar2 = 1.0d0 - bsq*th**2 - a*c*cbeta(1)*delta* 1 (1.0d0 - th**2)*th*power(r,(cbeta(1)*delta - 1.0d0)) a02 = 3.0d0*a*c*th**2*power(r,cbeta(1)*delta) - 1 2.0d0*bsq*r*th - a*c*power(r,cbeta(1)*delta) ********************************************************************* *** solve the linear system with simplistic GE w/ partial pivoting ********************************************************************* IF (DABS(ar1) .GT. DABS(ar2)) THEN amult = -ar2 / ar1 d0dT = (b2 + amult*b1) / (a02 + amult*a01) drdT = (b1 - a01*d0dT) / ar1 ELSE amult = -ar1 / ar2 d0dT = (b1 + amult*b2) / (a01 + amult*a02) drdT = (b2 - a02*d0dT) / ar2 END IF ********************************************************************* *** *** Compute theta polynomials and their tempertaure derivatives *** dsdT(1) = 2.0d0*s20*th*d0dT dsdT(2) = 2.0d0*s21*th*d0dT dspdT(1) = 2.0d0*s20*d0dT dspdT(2) = 2.0d0*s21*d0dT q = 1.0d0 + (bsq*(2.0d0*cbeta(1)*delta - 1.0d0) - 3.0d0)* 1 th**2 - bsq*(2.0d0*cbeta(1)*delta - 3.0d0)*th**4 dqdT = 2.0d0*(bsq*(2.0d0*cbeta(1)*delta - 1.0d0) - 3.0d0)* 1 th*d0dT - 4.0d0*bsq*(2.0d0*cbeta(1)*delta - 3.0d0)* 2 th**3*d0dT DO 20 i = 1,2 u(i) = (1.0d0 - bsq*(1.0d0 - 2.0d0*cbeta(i))*th**2) / q dudT(i) = (-2.0d0*bsq*(1.0d0 - 2.0d0*cbeta(i))*th*d0dT - 1 u(i)*dqdT) / q v(i) = ((cbeta(i) - cbeta(1)*delta)*th + 1 (cbeta(1)*delta - 3.0d0*cbeta(i))*th**3) / q dvdT(i) = ((cbeta(i) - cbeta(1)*delta)*d0dT + 1 3.0d0*(cbeta(1)*delta - 3.0d0*cbeta(i))* 2 th**2*d0dT - v(i)*dqdT) / q w(i) = ((1.0d0 - calpha(i))*(1.0d0 - 3.0d0*th**2)* 1 s(i) - cbeta(1)*delta*(th - th**3)*sp(i)) / q dwdT(i) = ((1.0d0 - calpha(i))*((1.0d0 - 3.0d0*th**2)* 1 dsdT(i) - 6.0d0*th*s(i)*d0dT) - cbeta(1)* 2 delta*((th - th**3)*dspdT(i) + sp(i)* 3 (d0dT - 3.0d0*th**2*d0dT)) - w(i)*dqdT) / q 20 CONTINUE ********************************************************************* *** *** Compute dP0dTT, ddelMT, dPdTT, dPdMMT, dPdMTT, dPPTT *** dP0dTT = Tc/T**2 * (2.0d0*P2 + 6.0d0*P3*delT) ddelMT = a*power(r,cbeta(1)*delta)* (cbeta(1)*delta*th/r* 1 (1.0d0 - th**2)*drdT + (1.0d0 - 3.0d0*th**2)*d0dT) dPdTT = 0.0d0 dPdMMT = 0.0d0 dPdMTT = 0.0d0 DO 30 i = 1,2 dPdTT = dPdTT + a*k(i) * (power(r,1.0d0-calpha(i))* 1 dsdT(i) + s(i)*(1.0d0 - calpha(i))* 2 power(r,-calpha(i))*drdT) dPdMMT = dPdMMT + k(i) * ((power(r,-cgamma(i))*dudT(i) - 1 u(i)*cgamma(i)*power(r,-1.0d0-cgamma(i))*drdT) / 2 a + 2.0d0*c*(power(r,cbeta(i)-1.0d0)*dvdT(i) + 3 v(i)*(cbeta(i) - 1.0d0)*power(r,cbeta(i)-2.0d0)* 4 drdT) + a*c**2*(power(r,-calpha(i))*dwdT(i) - 5 calpha(i)*w(i)*power(r,-1.0d0-calpha(i))*drdT)) dPdMTT = dPdMTT + k(i) * (power(r,cbeta(i)-1.0d0)*dvdT(i) + 1 v(i)*(cbeta(i) - 1.0d0)*power(r,cbeta(i)-2.0d0)* 2 drdT + a*c*(power(r,-calpha(i))*dwdT(i) - 3 calpha(i)*power(r,-1.0d0-calpha(i))*drdT*w(i))) 30 CONTINUE dPPTT = dP0dTT + dPdTT + P11*ddelMT - D/Dc*dPdMTT/d2PdM2 + 1 (P11 + d2PdMT)*(D/Dc*alpha/d2PdM2 + 2 D/Dc*dPdMMT/d2PdM2**2) pterm = P/Pc + dPdTcd *** compute (d(alpha)/dT)P dalLVS = Tc*Dc**2/D**2/T**2 * (-2.0d0/T*d2PdM2*pterm + 1 2.0d0*alpha*d2PdM2*pterm + pterm*dPdMMT + 2 d2PdM2*dPPTT) RETURN END ********************************************************************* *** backup - Save Pfind COMMON values during saturation check. SUBROUTINE backup IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s(2), xk(2) COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /param/ r1, th1 COMMON /deriv/ amu, s, Pw, Tw, dTw, dM0dT, dP0dT, 1 d2PdM2, d2PdMT, d2PdT2, p0th, p1th, xk COMMON /deri2/ dPdD, dPdT COMMON /store/ sav2, sav3, sav4, sav5, sav6, sav7, sav8, 1 sav9, sav10, sav11, sav12, sav13, sav14, sav15, 2 sav16, sav17, sav18, sav19, isav1 SAVE isav1 = iphase sav2 = r1 sav3 = th1 sav4 = amu sav5 = s(1) sav6 = s(2) sav7 = Pw sav8 = Tw sav9 = dTw sav10 = dM0dT sav11 = dP0dT sav12 = d2PdM2 sav13 = d2PdMT sav14 = d2PdT2 sav15 = p0th sav16 = p1th sav17 = xk(1) sav18 = xk(2) sav19 = dPdD RETURN END ********************************************************************* *** restor - Restore Pfind COMMON values after saturation check. SUBROUTINE restor IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION s(2), xk(2) COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /param/ r1, th1 COMMON /deriv/ amu, s, Pw, Tw, dTw, dM0dT, dP0dT, 1 d2PdM2, d2PdMT, d2PdT2, p0th, p1th, xk COMMON /deri2/ dPdD, dPdT COMMON /store/ sav2, sav3, sav4, sav5, sav6, sav7, sav8, 1 sav9, sav10, sav11, sav12, sav13, sav14, sav15, 2 sav16, sav17, sav18, sav19, isav1 SAVE iphase = isav1 r1 = sav2 th1 = sav3 amu = sav4 s(1) = sav5 s(2) = sav6 Pw = sav7 Tw = sav8 dTw = sav9 dM0dT = sav10 dP0dT = sav11 d2PdM2 = sav12 d2PdMT = sav13 d2PdT2 = sav14 p0th = sav15 p1th = sav16 xk(1) = sav17 xk(2) = sav18 dPdD = sav19 RETURN END ********************************************************************** *** load - Load thermodynamic and transport property values from * ptemp into props. SUBROUTINE load(phase,ptemp,props) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23, NPROP2 = 46) DOUBLE PRECISION ptemp(NPROP), props(NPROP2) INTEGER phase, key(NPROP,2) SAVE DATA key 1 / 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 2 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 3 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 4 26, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46 / DO 10 i = 1,NPROP 10 props(key(i,phase)) = ptemp(i) RETURN END ****************************************************************** *** tpset - Dimension triple point U, S, H, A, G values (in J/g from * Table 2, Helgeson & Kirkham, 1974a) into user-specified units. SUBROUTINE tpset IMPLICIT DOUBLE PRECISION (a-h,o-z) COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /tpoint/ Utripl, Stripl, Htripl, Atripl, Gtripl, 1 Ttripl, Ptripl, Dltrip, Dvtrip SAVE DATA Utr, Str, Htr, Atr, Gtr 1 / -15766.0d0, 3.5144d0, -15971.0d0, -12870.0d0, -13073.0d0 / Utripl = Utr * fh Stripl = Str * fh Htripl = Htr * fh Atripl = Atr * fh Gtripl = Gtr * fh END **************************************************************************** *** triple - Convert U, S, H, A, G values computed with reference to * zero triple point properties (Haar et al., 1984; * Levelt Sengers et al., 1983) into values referenced to * triple point properties given by Helgeson and Kirkham, 1974a. SUBROUTINE triple(T,wpzero) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23) DOUBLE PRECISION wpzero(NPROP) INTEGER A, G, S, U, H COMMON /tpoint/ Utr, Str, Htr, Atr, Gtr, 1 Ttripl, Ptripl, Dltrip, Dvtrip SAVE DATA A, G, S, U, H 1 / 1, 2, 3, 4, 5 / wpzero(S) = wpzero(S) + Str TS = T*wpzero(S) - Ttripl*Str wpzero(G) = wpzero(H) - TS + Gtr wpzero(A) = wpzero(U) - TS + Atr wpzero(H) = wpzero(H) + Htr wpzero(U) = wpzero(U) + Utr END ********************************************************************* *** power - Returns base**exp utilizing the intrinsic FORTRAN * exponentiation function in such a manner so as to * insure computation of machine-independent values * for all defined exponentiations. Attempted undefined * exponentiations produce an error message and cause * program termination. DOUBLE PRECISION FUNCTION power(base,exp) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPLOTF = 8) INTEGER rterm, wterm, reacf, pronf, tabf, plotf(NPLOTF), outflg COMMON /io/ rterm, wterm, iconf, reacf, pronf, tabf, plotf, 1 outflg SAVE DATA TOL / 1.0d-7 / IF (base .GT. 0.0d0) THEN power = base**exp ELSE IF (DABS(base) .GT. TOL) THEN IF (DBLE(INT(exp)) .NE. exp) THEN WRITE(wterm,10) base, exp 10 FORMAT(/,' neg base ** real exp is complex', 1 /,' base,exp: ',2e20.13,/) STOP ELSE IF (MOD(exp,2.0d0) .EQ. 0.0d0) THEN power = (-base)**exp ELSE power = -((-base)**exp) END IF END IF ELSE IF (exp .GT. 0.0d0) THEN power = 0.0d0 ELSE WRITE(wterm,20) base, exp 20 FORMAT(/,' zero base ** (exp <= 0) is undefined', 1 /,' base,exp: ',2e20.13) STOP END IF END IF END IF RETURN END *********************************************************************** *** TdegK - Returns input temperature t converted from * user-specified units to degK. DOUBLE PRECISION FUNCTION TdegK(it,t) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE GO TO (1,2,3,4), it 1 TdegK = t RETURN 2 TdegK = t + 273.15d0 RETURN 3 TdegK = t / 1.8d0 RETURN 4 TdegK = (t + 459.67d0) / 1.8d0 RETURN END *********************************************************************** *** TdegUS - Returns input temperature t converted * from degK to user-specified units. DOUBLE PRECISION FUNCTION TdegUS(it,t) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE GO TO (1,2,3,4), it 1 TdegUS = t RETURN 2 TdegUS = t - 273.15d0 RETURN 3 TdegUS = t * 1.8d0 RETURN 4 TdegUS = t * 1.8d0 - 459.67d0 RETURN END ********************************************************************* *** dim[HGK,LVS] - Dimensioning routines for H2O88. ********************************************************************* *** dimHGK - Dimensions thermodynamic and transport property values * computed from the HGK equation of state per user-specified * choice of units. SUBROUTINE dimHGK(isat,itripl,t,p,d,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23) DOUBLE PRECISION wprops(NPROP), wpliq(NPROP) INTEGER aw, gw, sw, uw, hw, cvw, cpw, vsw, alw, bew, 1 diw, viw, tcw, stw, tdw, Prw, vikw, albew, 2 ZBw, YBw, QBw, dalwdT, XBw INTEGER epseqn COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc COMMON /fcts/ ad, gd, sd, ud, hd, cvd, cpd, dpdt, dvdt, dpdd, 1 cjtt, cjth COMMON /aconst/ wm, gascon, tz, aa, z, dz, y, uref, sref COMMON /RTcurr/ rt COMMON /wpvals/ wprops, wpliq SAVE DATA aw, gw, sw, uw, hw, cvw, cpw, vsw, alw, bew, diw, viw, 1 tcw, stw, tdw, Prw, vikw, albew, ZBw, YBw, QBw, 2 dalwdT, XBw 3 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 4 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23 / wprops(aw) = ad * rt * fh wprops(gw) = gd * rt * fh wprops(sw) = sd * gascon * fh * ft wprops(uw) = ud * rt * fh wprops(hw) = hd * rt * fh wprops(cvw) = cvd * gascon * fh * ft wprops(cpw) = cpd * gascon * fh * ft wprops(vsw) = DSQRT(DABS(cpd*dpdd*1.0d3/cvd)) * fs wprops(bew) = 1.0d0 / (d * dpdd * fp) wprops(alw) = d * dvdt wprops(dalwdT) = dalHGK(d,t,wprops(alw)) pbars = p*1.0d1 dkgm3 = d * 1.0d3 betaPa = wprops(bew)*fp / 1.0d6 betab = wprops(bew)*fp / 1.0d1 CpJKkg = wprops(cpw)/fh/ft * 1.0d3 wprops(viw) = viscos(t,pbars,dkgm3,betaPa) * fvd wprops(tcw) = thcond(t,pbars,dkgm3,wprops(alw),betaPa) * fc * ft IF ((isat .EQ. 0) .OR. (isat .EQ. 2)) THEN wprops(stw) = 0.0d0 ELSE wprops(stw) = surten(t) * fst END IF CALL Born92(t,pbars,dkgm3/1.0d3,betab,wprops(alw),wprops(dalwdT), 1 wprops(diw),wprops(ZBw),wprops(QBw),wprops(YBw), 2 wprops(XBw),epseqn) wprops(tdw) = wprops(tcw)/fc/ft / (dkgm3 * CpJKkg) * fvk IF (wprops(tcw) .NE. 0.0d0) THEN wprops(Prw) = wprops(viw)/fvd * CpJKkg / (wprops(tcw)/fc/ft) ELSE wprops(Prw) = 0.0d0 END IF wprops(vikw) = wprops(viw)/fvd / dkgm3 * fvk wprops(albew) = wprops(alw) / wprops(bew) IF (itripl .EQ. 1) CALL triple(t,wprops) END ***************************************************************************** *** dimLVS - Dimension critical region properties per user-specs * and load into tprops. SUBROUTINE dimLVS(isat,itripl,theta,T,Pbars,dl,dv,tprops,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (NPROP = 23) DOUBLE PRECISION tprops(NPROP) INTEGER aw, gw, sw, uw, hw, cvw, cpw, vsw, alw, bew, 1 diw, viw, tcw, stw, tdw, Prw, vikw, albew, 2 ZBw, YBw, QBw, dalwdT, XBw INTEGER epseqn COMMON /therm/ AE, GE, U, H, Entrop, Cp, Cv, betaw, alphw, 1 heat, Speed COMMON /satur/ Dliq, Dvap, DH2O, iphase COMMON /units/ ft, fd, fvd, fvk, fs, fp, fh, fst, fc ***************************************************************** COMMON /abc2/ r, th ***************************************************************** SAVE DATA aw, gw, sw, uw, hw, cvw, cpw, vsw, alw, bew, diw, viw, 1 tcw, stw, tdw, Prw, vikw, albew, ZBw, YBw, QBw, 2 dalwdT, XBw 3 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 4 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23 / IF (isat .EQ. 1) THEN dv = Dvap dl = Dliq END IF tprops(aw) = AE * fh tprops(gw) = GE * fh tprops(sw) = Entrop * fh * ft tprops(uw) = U * fh tprops(hw) = H * fh tprops(cvw) = Cv * fh * ft tprops(cpw) = Cp * fh * ft tprops(vsw) = Speed * fs tprops(bew) = betaw / fp tprops(alw) = alphw ***************************************************************** th = theta tprops(dalwdT) = dalLVS(DH2O,T,Pbars/1.0d1,tprops(alw)) ***************************************************************** CpJKkg = Cp * 1.0d3 betaPa = betaw / 1.0d6 betab = betaw / 1.0d1 IF (DABS(theta) .NE. 1.0d0) THEN dkgm3 = DH2O tprops(stw) = 0.0d0 ELSE IF (theta .LT. 0.0d0) THEN dkgm3 = Dvap tprops(stw) = 0.0d0 ELSE dkgm3 = Dliq dkgm3 = Dliq tprops(stw) = surten(T) * fst END IF END IF CALL Born92(T,Pbars,dkgm3/1.0d3,betab,tprops(alw),tprops(dalwdT), 1 tprops(diw),tprops(ZBw),tprops(QBw),tprops(YBw), 2 tprops(XBw),epseqn) tprops(viw) = viscos(T,Pbars,dkgm3,betaPa) * fvd tprops(tcw) = thcond(T,Pbars,dkgm3,tprops(alw),betaPa) * fc * ft tprops(tdw) = tprops(tcw)/fc/ft / (dkgm3 * CpJKkg) * fvk tprops(Prw) = tprops(viw)/fvd * CpJKkg / (tprops(tcw)/fc/ft) tprops(vikw) = tprops(viw)/fvd / dkgm3 * fvk tprops(albew) = tprops(alw) / tprops(bew) IF (itripl .EQ. 1) CALL triple(T,tprops) END ********************************************************************** *** tran88 - Set of FORTRAN77 functions that compute transport * properties of fluid H2O. Input state parameters * should be computed from the Haar et al. (1984) * and Levelt Sengers et al. (1983) equations of state in * order to facilitate comparision with published tabular * values referenced below for each function. * ********************************************************************** *** programmer: James W. Johnson *** abandoned: 20 January 1988 ********************************************************************** *** viscos - Returns dynamic viscosity of H2O in kg/m*s (= Pa*s) * if Tk, Pbars falls within the validity region (specified * by the initial IF statement) of the Watson et al. (1980) * equation; otherwise returns zero. See equations 3.1-2 and * 4.1-5 and Tables 1, 6, and 8 from Sengers and * Kamgar-Parsi (1984). DOUBLE PRECISION FUNCTION viscos(Tk,Pbars,Dkgm3,betaPa) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (Tstar = 647.270d0) PARAMETER (Dstar = 317.763d0) PARAMETER (Pstar = 22.1150d6) PARAMETER (ustar = 1.0d-6) DOUBLE PRECISION a(4), b(6,7) SAVE DATA a / 0.0181583d0, 0.0177624d0, 0.0105287d0, -0.0036744d0 / DATA b / 0.5132047d0, 0.3205656d0, 0.0d0, 0.0d0, 1 -0.7782567d0, 0.1885447d0, 0.2151778d0, 0.7317883d0, 2 1.2410440d0, 1.4767830d0, 0.0d0, 0.0d0, 3 -0.2818107d0, -1.0707860d0, -1.2631840d0, 0.0d0, 4 0.0d0, 0.0d0, 0.1778064d0, 0.4605040d0, 5 0.2340379d0, -0.4924179d0, 0.0d0, 0.0d0, 6 -0.0417661d0, 0.0d0, 0.0d0, 0.1600435d0, 7 0.0d0, 0.0d0, 0.0d0, -0.01578386d0, 8 0.0d0, 0.0d0, 0.0d0, 0.0d0, 9 0.0d0, 0.0d0, 0.0d0, -0.003629481d0, 1 0.0d0, 0.0d0 / DATA TOL /1.0d-2/ viscos = 0.0d0 TdegC = Tk - 273.15d0 IF ((Pbars .GT. 5000.0d0+TOL) .OR. 1 ((Pbars .GT. 3500.0d0+TOL).AND.(TdegC .GT. 150.0d0+TOL)).OR. 2 ((Pbars .GT. 3000.0d0+TOL).AND.(TdegC .GT. 600.0d0+TOL)) .OR. 3 (TdegC .GT. 900.0d0+TOL)) RETURN T = Tk / Tstar D = Dkgm3 / Dstar sum = 0.0d0 DO 10 i=0,3 10 sum = sum + a(i+1)/T**i u0 = ustar * DSQRT(T) / sum sum = 0.0d0 DO 20 i=0,5 DO 20 j=0,6 20 sum = sum + b(i+1,j+1) * (1.0d0/T-1)**i * (D-1)**j u1 = DEXP(D*sum) IF ((0.997d0 .LE. T) .AND. (T .LE. 1.0082d0) .AND. 1 (0.755d0 .LE. D) .AND. (D .LE. 1.2900d0)) THEN xt = Pstar/Dstar**2 * betaPa * Dkgm3**2 IF (xt .LT. 22.0d0) THEN u2 = 1.0d0 ELSE u2 = 0.922 * power(xt,0.0263d0) END IF ELSE u2 = 1.0d0 END IF viscos = u0 * u1 * u2 RETURN END ***************************************************************** *** thcond - Returns thermal conductivity of H2O in J/m*deg*s (=W/m*deg) * if Tk, Pbars falls within the validity region (specified * by the initial IF statement) of the Sengers et al. (1984) * equation; returns zero otherwise. See equations 3.2-14 * and tables 2-5 and I.5-6 from the above reference. DOUBLE PRECISION FUNCTION thcond(Tk,Pbars,Dkgm3,alph,betaPa) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (Tstar = 647.270d0) PARAMETER (Dstar = 317.763d0) PARAMETER (Pstar = 22.1150d6) PARAMETER (ustar = 1.0d-6) PARAMETER (C = 3.7711d-8) DOUBLE PRECISION aL(4), au(4), bL(6,5), bu(5,6), L0, L1, L2 SAVE DATA aL / 0.2022230d1, 0.1411166d2, 0.5255970d1, -0.2018700d1 / DATA au / 0.0181583d0, 0.0177624d0, 0.0105287d0, -0.0036744d0 / DATA bL / 1.329304600d0, -0.404524370d0, 0.244094900d0, 1 0.018660751d0, -0.129610680d0, 0.044809953d0, 2 1.701836300d0, -2.215684500d0, 1.651105700d0, 3 -0.767360020d0, 0.372833440d0, -0.112031600d0, 4 5.224615800d0, -1.012411100d1, 4.987468700d0, 5 -0.272976940d0, -0.430833930d0, 0.133338490d0, 6 8.712767500d0, -9.500061100d0, 4.378660600d0, 7 -0.917837820d0, 0.0d0, 0.0d0, 8 -1.852599900d0, 0.934046900d0, 0.0d0, 9 0.0d0, 0.0d0, 0.0d0 / DATA bu / 0.5019380d0, 0.2356220d0, -0.2746370d0, 0.1458310d0, 1 -0.0270448d0, 0.1628880d0, 0.7893930d0, -0.7435390d0, 2 0.2631290d0, -0.0253093d0, -0.1303560d0, 0.6736650d0, 3 -0.9594560d0, 0.3472470d0, -0.0267758d0, 0.9079190d0, 4 1.2075520d0, -0.6873430d0, 0.2134860d0, -0.0822904d0, 5 -0.5511190d0, 0.0670665d0, -0.4970890d0, 0.1007540d0, 6 0.0602253d0, 0.1465430d0, -0.0843370d0, 0.1952860d0, 7 -0.0329320d0, -0.0202595d0 / DATA TOL /1.0d-2/ thcond = 0.0d0 TdegC = Tk - 273.15d0 IF ((Pbars .GT. 4000.0d0+TOL) .OR. 1 ((Pbars .GT. 2000.0d0+TOL).AND.(TdegC .GT. 125.0d0+TOL)).OR. 2 ((Pbars .GT. 1500.0d0+TOL).AND.(TdegC .GT. 400.0d0+TOL)).OR. 3 (TdegC .GT. 800.0d0+TOL)) RETURN T = Tk / Tstar D = Dkgm3 / Dstar sum = 0.0d0 DO 10 i=0,3 10 sum = sum + aL(i+1)/T**i L0 = DSQRT(T) / sum sum = 0.0d0 DO 20 i=0,4 DO 20 j=0,5 20 sum = sum + bL(j+1,i+1) * (1.0d0/T-1)**i * (D-1)**j L1 = DEXP(D*sum) sum = 0.0d0 DO 40 i=0,3 40 sum = sum + au(i+1)/T**i u0 = ustar * DSQRT(T) / sum sum = 0.0d0 DO 50 i=0,5 DO 50 j=0,4 50 sum = sum + bu(j+1,i+1) * (1.0d0/T-1)**i * (D-1)**j u1 = DEXP(D*sum) xt = Pstar/Dstar**2 * betaPa * Dkgm3**2 dPdT = Tstar/Pstar * alph/betaPa L2 = C / (u0*u1) * (T/D)**2 * dPdT**2 * power(xt,0.4678d0) * 1 DSQRT(D) * DEXP(-18.66d0*(T-1)**2 - (D-1)**4) thcond = L0 * L1 + L2 RETURN END ****************************************************************** *** surten - Returns the surface tension of vapor-saturated liquid * H2O in MPa*cm (converted from N/m) as computed from * the Vargaftik et al. (1983) equation. See equations * 10.1-2, Kestin et al. (1984); compare also equation * C.5 and table 11, Haar et al. (1984). DOUBLE PRECISION FUNCTION surten(Tsatur) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (Ttripl = 273.16d0) PARAMETER (Tcrit = 647.067d0) PARAMETER (Tstar = 647.27d0) PARAMETER (Tcstar = 0.999686d0) PARAMETER (v = 1.256d0) PARAMETER (B = -0.625d0) PARAMETER (stref = 0.2358d0) PARAMETER (FPTOL = 1.0d-10) SAVE IF ((Tsatur .LT. Ttripl) .OR. (Tsatur .GT. Tcrit)) THEN surten = 0.0d0 RETURN END IF IF (Tsatur .GE. Tcrit-FPTOL) THEN Tnorm = 0.0d0 ELSE Tnorm = (Tcstar - Tsatur/Tstar) / Tcstar END IF surten = stref * power(Tnorm,v) * (1.0d0 + B*Tnorm) RETURN END ****************************************************************** *** Born92 - Computes the Z, Q, Y, and X Born functions at TK, Pbars. *** *** epseqn = 1 ...... use Helgeson-Kirkham (1974) equation *** epseqn = 2 ...... use Pitzer (1983) equation *** epseqn = 3 ...... use Uematsu-Franck (1980) equation *** epseqn = 4 ...... use Johnson-Norton (1991) equation *** epseqn = 5 ...... use Archer-Wang (1990) equation *** SUBROUTINE Born92(TK,Pbars,Dgcm3,betab,alphaK,daldT, 1 eps,Z,Q,Y,X,epseqn) IMPLICIT DOUBLE PRECISION (a-h,o-z) PARAMETER (TMAX = 1000.0d0, PMAX = 5000.0d0, TOL = 1.0d-3) INTEGER epseqn SAVE eps = 0.0d0 Z = 0.0d0 Y = 0.0d0 Q = 0.0d0 X = 0.0d0 TdegC = TK - 273.15d0 *** The following line can be commented out to facilitate probably *** unreliable, yet potentially useful, predictive calculations *** at state conditions beyond the validity limits of the aqueous *** species equation of state. IF ((TdegC .GT. TMAX+TOL) .OR. (Pbars .GT. PMAX+TOL)) RETURN * IF (epseqn .EQ. 1) THEN * CALL HK74(TK,Dgcm3,betab,alphaK,daldT, * 1 eps,dedP,dedT,d2edT2) * CALL epsBrn(eps,dedP,dedT,d2edT2,Z,Q,Y,X) * RETURN * END IF * IF (epseqn .EQ. 2) THEN * CALL Pitz83(TK,Dgcm3,betab,alphaK,daldT, * 1 eps,dedP,dedT,d2edT2) * CALL epsBrn(eps,dedP,dedT,d2edT2,Z,Q,Y,X) * RETURN * END IF * IF (epseqn .EQ. 3) THEN * CALL UF80(TK,Dgcm3,betab,alphaK,daldT, * 1 eps,dedP,dedT,d2edT2) * CALL epsBrn(eps,dedP,dedT,d2edT2,Z,Q,Y,X) * RETURN * END IF IF (epseqn .EQ. 4) THEN CALL JN91(TK,Dgcm3,betab,alphaK,daldT, 1 eps,dedP,dedT,d2edT2) CALL epsBrn(eps,dedP,dedT,d2edT2,Z,Q,Y,X) RETURN END IF * IF (epseqn .EQ. 5) THEN * Dkgm3 = Dgcm3 * 1.0d3 * PMPa = Pbars / 1.0d1 * betam = betab * 1.0d1 * CALL AW90(TK,PMPa,Dkgm3,betam,alphaK,daldT, * 1 eps,dedP,dedT,d2edT2) **** convert dedP FROM MPa**-1 TO bars**-1 * dedP = dedP / 1.0d1 * CALL epsBrn(eps,dedP,dedT,d2edT2,Z,Q,Y,X) * RETURN * END IF END ********************************************************************* *** JN91 - Compute (eps, dedP, dedT, d2edT2)(T,D) using equations *** given by Johnson and Norton (1991); fit parameters *** regressed from least squares fit to dielectric data *** consistent with the HK74 equation and low temperatures, *** and with the Pitz83 equation at high temperatures. *** *** Units: T ............... K *** D ............... g/cm**3 *** beta, dedP ...... bar**(-1) *** alpha, dedT ..... K**(-1) *** daldT, d2edT2 ... K**(-2) SUBROUTINE JN91(T,D,beta,alpha,daldT,eps,dedP,dedT,d2edT2) IMPLICIT DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION a(10), c(5), dcdT(5), dc2dTT(5) SAVE DATA Tref / 298.15d0 / DATA a / 1 0.1470333593E+02, 2 0.2128462733E+03, 3 -0.1154445173E+03, 4 0.1955210915E+02, 5 -0.8330347980E+02, 6 0.3213240048E+02, 7 -0.6694098645E+01, 8 -0.3786202045E+02, 9 0.6887359646E+02, 1 -0.2729401652E+02 / Tn = T / Tref c(1) = 1.0d0 dcdT(1) = 0.0d0 dc2dTT(1) = 0.0d0 c(2) = a(1)/Tn dcdT(2) = -a(1)*Tref/T**2 dc2dTT(2) = 2.0d0*a(1)*Tref/T**3 c(3) = a(2)/Tn + a(3) + a(4)*Tn dcdT(3) = -a(2)*Tref/T**2 + a(4)/Tref dc2dTT(3) = 2.0d0*a(2)*Tref/T**3 c(4) = a(5)/Tn + a(6)*Tn + a(7)*Tn**2 dcdT(4) = -a(5)*Tref/T**2 + a(6)/Tref 1 + 2.0d0*a(7)*T/Tref**2 dc2dTT(4) = 2.0d0*a(5)*Tref/T**3 + 2.0d0*a(7)/Tref**2 c(5) = a(8)/Tn**2 + a(9)/Tn + a(10) dcdT(5) = -2.0d0*a(8)*Tref**2/T**3 - a(9)*Tref/T**2 dc2dTT(5) = 6.0d0*a(8)*Tref**2/T**4 + 2.0d0*a(9)*Tref/T**3 eps = 0.0d0 DO 50 k=1,5 50 eps = eps + c(k)*D**(k-1) dedP = 0.0d0 DO 100 j = 0,4 100 dedP = dedP + j*c(j+1)*D**j dedP = beta * dedP dedT = 0.0d0 DO 200 j = 0,4 200 dedT = dedT + D**j*(dcdT(j+1) - j*alpha*c(j+1)) d2edT2 = 0.0d0 DO 300 j = 0,4 300 d2edT2 = d2edT2 + D**j*(dc2dTT(j+1) - j*(alpha*dcdT(j+1) + 1 c(j+1)*daldT) - j*alpha*(dcdT(j+1) - j*alpha*c(j+1))) END *************************************************************** *** epsBrn - Compute the Z, Q, Y, and X Born functions from their *** eps, dedP, dedT, and d2edT2 counterparts. SUBROUTINE epsBrn(eps,dedP,dedT,d2edT2,Z,Q,Y,X) IMPLICIT DOUBLE PRECISION (a-h,o-z) SAVE Z = -1.0d0/eps Q = 1.0d0/eps**2 * dedP Y = 1.0d0/eps**2 * dedT X = 1.0d0/eps**2 * d2edT2 - 2.0d0*eps*Y**2 END