* Program Hprons2023
* Converts a ThermoCalc format text file (Holland & Powell dataset)
* to SPRONS.DAT mineral format text file (Supcrt dataset)
* The formating of the input file from Holland and Powell may change with
* sucessive releases. The read formats here will corretly read the formatting
* as shown in H&P file tc-ds636.txt (15:57 Wed 3 May,2023) but with a
+ revised header and removal of unneeded data, as in file hpthrm.dat
* Mineral names between the two formats are correlated in file Mins_ptx.tbl
* ThermoCalc currently contains 18 elements
* 1 Si 11 H
* 2 Ti 12 C
* 3 Al 13 Cl
* 4 Fe 14 electron e-, not used
* 5 Mg 15 Ni
* 6 Mn 16 Zr
* 7 Ca 17 S
* 8 Na 18 Cu
* 9 K 19 Cr
* 10 O
* Copyright 1996, 2016, 2026 James Palandri
* James Palandri hereby disclaims all copyright interest in the program
* “Hprons2023” (which reformats text data) written by James Palandri
* Signature of James Palandri, 24 January 2024
* James Palandri
* This file is part of Hprons2023.
* Hprons2023 is free software: you can redistribute it and/or modify it under
* the terms of the GNU General Public License as published by the
* Free Software Foundation, either version 3 of the License, or (at your
* option) any later version. Hprons2023 is distributed in the hope that it
* will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
* Public License for more details. You should have received a copy of the GNU
* General Public License along with Hprons2023. If not, see
* .
implicit none
integer nelem
parameter (nelem = 19) !Current number of components
INTEGER IELEM(NELEM) !index for each of the components
INTEGER DUM, K, LSCF, LECF
INTEGER IREAD, ILOOP, KLOOP, IWRT, JWRT
INTEGER TCFLAG, ITEMP
INTEGER COEMAX
INTEGER INP1, INP2, IOUT1, IOUT2, ISPACES
CHARACTER*120 LINE120
CHARACTER*32 FILENAME
CHARACTER*20 SPRONSNAME
CHARACTER*6 REF
CHARACTER*9 DATE
CHARACTER*38 ELSTRING
CHARACTER*9 CHRTMP
CHARACTER CHRTMP2(9)
CHARACTER ECFORM(40) !
CHARACTER SCFORM(40)
CHARACTER ELSYMB(NELEM,2)
CHARACTER BLANK, SKPREC
CHARACTER ABBR(7), ABBR2(7)
REAL*8 COELEM(NELEM)
REAL*8 SELEM(NELEM), stotal
REAL*8 DFG, DFH, S, V
REAL*8 CPA, CPB, CPC, CPD
REAL*8 AV, BV, TC
REAL*8 SMAX, TMAX
BLANK = ' '
INP1 = 4 ! User selects file name, modified ThermoCalc-formatted input file
INP2 = 5 ! 'HP_PTX.tbl', name index table
IOUT1 = 10 ! User selects file name, Supcrt96-formatted output file
IOUT2 = 11 ! 'MISSMINS.LST', list of input abbreviations not found in the name index table
* Entropy of the elements - J/(mol*K), Robie and Hemingway, 1995
SELEM(1) = 18.81 !Si
SELEM(2) = 30.76 !Ti
SELEM(3) = 28.30 !Al
SELEM(4) = 27.09 !Fe
SELEM(5) = 32.67 !Mg
SELEM(6) = 32.01 !Mn
SELEM(7) = 42.90 !Ca
SELEM(8) = 51.46 !Na
SELEM(9) = 64.67 !K
SELEM(10) = 102.575 !O O2=205.15
SELEM(11) = 65.34 !H H2=130.68
SELEM(12) = 5.74 !C
SELEM(13) = 111.54 !Cl CLECF=223.08
SELEM(14) = 0.0 !e- Not used
SELEM(15) = 29.87 !Ni
SELEM(16) = 38.87 !Zr
SELEM(17) = 32.05 !S
SELEM(18) = 33.14 !Cu
SELEM(19) = 23.62 !Cr
*** Read ELSTRING into elsymbol for writing structural formulas
ELSTRING = 'SiTiAlFeMgMnCaNaK O H C ClXXNiZrS CuCr'
READ (ELSTRING,'(40A1)') (ELSYMB(IREAD,1), ELSYMB(IREAD,2),
+ IREAD = 1,NELEM)
WRITE (*,'(/,A,/)') ' Enter name of H&P input file:'
READ (*,'(A20)') filename
OPEN (INP1 , FILE = filename, STATUS = 'OLD')
WRITE (*,'(/,A,/)') ' Enter name of output file:'
READ (*,'(A20)') filename
OPEN (IOUT1, FILE = filename, STATUS = 'UNKNOWN')
OPEN (INP2 , FILE = 'MINS_PTX.tbl', STATUS = 'OLD')
OPEN (IOUT2, FILE = 'MissingItems.lst', STATUS = 'UNKNOWN')
write (iout2,'(/,A,A,/)') ' The following items were not found',
+ ' in the name index table file:'
* Read the reference, date and maximum temperature from input file
READ (INP1, '(A6)') REF
READ (INP1, '(A9)') DATE
* (Re)set ecform and scform to blanks
10 DO 20 ILOOP = 1,40
SCFORM(ILOOP) = ' ' !Structural chemical formula (with parentheses)
ECFORM(ILOOP) = ' ' !Elemental chemical formula
20 CONTINUE
* Read an input file record
READ (INP1,'(/,A120)') LINE120
IF (LINE120(1:1).EQ.BLANK) GOTO 700
READ (LINE120,'(7A1)') ABBR
* Find flag for start of the stoichiometry, a '0')
ISPACES = 1
ILOOP = 8
DO WHILE (LINE120(ILOOP:ILOOP).NE.'0')
ILOOP = ILOOP + 1
ISPACES = ILOOP
END DO
READ (line120,805) (IELEM(IREAD), COELEM(IREAD), IREAD = 1,NELEM)
805 FORMAT (X,19(I3,F9.4))
READ (INP1,*) TCFlag, DFH, S, V
READ (INP1,*) CPA, CPB, CPC, CPD
IF (TCFLAG.EQ.1) THEN !If phase change get the T
READ (INP1,'(39X,F4.0)') TMAX
write (*,*) abbr, ' tmax = ', tmax
ELSE
READ (INP1,*)
TMAX = 1000.
ENDIF
* Calculate STOTAL and then DFG
STOTAL = 0.0
K = 1
120 IF (IELEM(K).EQ.0) THEN
GOTO 190
ELSE
STOTAL = STOTAL+(SELEM(IELEM(K))*COELEM(K))
K = K + 1
GOTO 120
190 ENDIF
STOTAL = S - STOTAL/1000
DFG = DFH - 298.15*STOTAL
* Convert to calories and V from kJ/(kbar*mole) to cc/mole
* NOTE: Values tabulated in Holland & Powell's text file are ACTUAL VALUES
* whereas in the reference, S, b, aV, bV & Smax use various exponents of 10.
* Energy units are kj.
* Factors used to match the Supcrt96 SPRONS format:
DFG = DFG /4.184 * 1000.0
DFH = DFH /4.184 * 1000.0
S = S /4.184 * 1000.0
SMAX = SMAX/4.184 * 1000.0
CPA = CPA /4.184 * 1000.0
CPB = CPB /4.184 * 1000.0 * 1000.0 !Supcrt scaling factor
CPC = CPC /4.184 * 1000.0 * 0.00001 !Supcrt scaling factor
CPD = CPD /4.184 * 1000.0
V = V * 10.0
* Write the structural and elemental chemical formulas into SCFORM and ECFORM
LSCF = 1 !length of SCFORM
LECF = 1 !length of ECFORM
K = 1
220 IF (IELEM(K).NE.0) THEN
SCFORM(LSCF) = ELSYMB(IELEM(K),1)
LSCF = LSCF + 1
ECFORM(LECF) = ELSYMB(IELEM(K),1)
LECF = LECF + 1
IF (ELSYMB(IELEM(K),2).NE.' ') THEN
SCFORM(LSCF) = ELSYMB(IELEM(K),2)
LSCF = LSCF + 1
ECFORM(LECF) = ELSYMB(IELEM(K),2)
LECF = LECF + 1
ENDIF
* Read the real coefficient COELEM into SCFORM & ECFORM. First convert to integer
* ITEMP, then into character*9 CHRTMP, then into character CHRTMP2(9)
* While ThermoCalc (and Soltherm) use real coefficients, they are all integers
* of one or two characters. What follows was likely not necessary.
ECFORM(LECF) = '('
LECF = LECF + 1
ITEMP = INT4(COELEM(K))
IF (ITEMP.EQ.1) THEN
ECFORM(LECF) = '1'
LECF = LECF + 1
ELSE
WRITE (CHRTMP,'(f9.4)') COELEM(K)
READ (CHRTMP,'(9A1)') (CHRTMP2(IREAD), IREAD = 1,9)
DO 100, ILOOP = 1,4
IF (CHRTMP2(ILOOP).NE.' ') THEN
SCFORM(LSCF) = CHRTMP2(ILOOP)
LSCF = LSCF + 1
ECFORM(LECF) = CHRTMP2(ILOOP)
LECF = LECF + 1
ENDIF
100 CONTINUE
COEMAX = 0
IF (CHRTMP2(6).NE.'0') COEMAX = 6
IF (CHRTMP2(7).NE.'0') COEMAX = 7
IF (CHRTMP2(8).NE.'0') COEMAX = 8
IF (CHRTMP2(9).NE.'0') COEMAX = 9
IF (COEMAX.GT.0) THEN
SCFORM(LSCF) = '.'
LSCF = LSCF + 1
ECFORM(LECF) = '.'
LECF = LECF + 1
DO 200, ILOOP = 6,COEMAX
SCFORM(LSCF) = CHRTMP2(ILOOP)
LSCF = LSCF + 1
ECFORM(LECF) = CHRTMP2(ILOOP)
LECF = LECF + 1
200 CONTINUE
ENDIF
ENDIF
* Always write the third character of I3 integer COELEM(K) and closing
* and closing parentheses for ECFORM. Omit from SCFORM if COELEM(K) = 1
ECFORM(LECF) = ')'
LECF = LECF + 1
K = K + 1
GOTO 220
300 ENDIF
*** Find start of list in name index table
SKPREC = '*'
DO WHILE (SKPREC.EQ.'*')
READ (INP2,'(A1)') SKPREC
END DO
BACKSPACE INP2
**** Read an H&P mineral abbreviation and a mineral name from the name index table file
310 READ (INP2,710) (ABBR2(IREAD), IREAD = 1,7), SPRONSNAME
710 FORMAT (22X,7A1,3X,A20)
**** Test if hpthrm.dat ABBR matches the name index table ABBR2 and continue
IF (ABBR(1).EQ.ABBR2(1).AND.
2 ABBR(2).EQ.ABBR2(2).AND.
3 ABBR(3).EQ.ABBR2(3).AND.
4 ABBR(4).EQ.ABBR2(4).AND.
5 ABBR(5).EQ.ABBR2(5)) GOTO 320
**** Or reach the end of the file without finding a match - add it to the list
IF (ABBR2(1).EQ.BLANK) then
WRITE (IOUT2,'(5x,7A)') ABBR
goto 320
endif
GOTO 310
320 REWIND INP2
* Move abbr flush left - no longer needed
* DO 400 ILOOP = 1,7
* IF (ABBR(1).EQ.' ') THEN
* DO 350 KLOOP = 1,7
* ABBR(KLOOP) = ABBR(KLOOP + 1)
*350 CONTINUE
* ABBR(8) = ' '
* ENDIF
*400 CONTINUE
**** Write a Sprons96 record.
WRITE (IOUT1,900) SPRONSNAME, (SCFORM(IWRT), IWRT = 1,40)
WRITE (IOUT1,910) (ABBR(IWRT), IWRT = 1,7),
+ (ECFORM(JWRT), JWRT = 1,40)
WRITE (IOUT1,920) REF, DATE
WRITE (IOUT1,930) DFG, DFH, S, V
WRITE (IOUT1,940) CPA, CPB, CPC, CPD
430 WRITE (IOUT1,950) TMAX
GOTO 10
700 WRITE (*,'(//,a,/,3x,a,/,3x,a//)') ' Done writing files: ',
+ filename, 'MissingItems.lst'
STOP
**** OUTPUT FORMATS FOR SPRONS.DAT
900 FORMAT (1X,A20,40A1)
910 FORMAT (1X,7A1,13X,40A1)
920 FORMAT (1X,A6,14X,A9)
930 FORMAT (4X,2(2X,F12.1),2(2X,F8.3))
940 FORMAT (4X,4(1X,F13.6))
950 FORMAT (8X,F7.2,8X,F7.2,10X,F7.4)
960 FORMAT (8X,F7.2,20X,F8.4)
1000 FORMAT (I6,A1,A1)
END