c this is a program that converts a UBC/Perkins/Berman type thermo c data file to vertex format. To get it to work you have to change c the first elements in the thermo data file to be read (named c ubcformat) to be the same (and in the same order, i.e. na mg al si k c ca ti mn fe o h c) as those which will be used in the vertex c format file (written to new.dat). In addition file ubcformat c should be all lower case. the currently permitted elements are c na mg al si k ca ti mn fe o h c to add elements, or change c their order, you must modify the part of pread2 which converts c the UBC enthalpy to a gibbs energy (do not use the gibbs free c energies given in most Berman data files because these are often c wrong, although the enthalpies are correct). c this program was made by chopping up ernie perkin's ptx program. c jadc, dec '92 open (3,file='ubcformat') open (10,file='errors') open (9,file='new.dat') call pread1 call elread call pread2 (1) end subroutine pread1 c this routine reads part one of the data base - the element data implicit double precision(a-h,o-z) common /eldata/ phcmp(40), weight(40), psyco(40), nccc character*8 ncomp(40) common /namele/ ncomp character*1 dummy(100) c read the number of elements, their symbols and weights read (3,1001) nccc i = 0 do 30 j = 1, (1 + ((nccc - 1)/7)) read (3,1002) dummy istart = 1 kk = nccc - (7 * (j - 1)) if (kk .gt. 7) kk = 7 do 20 k = 1, kk call ignore(dummy,100, ' ', 1, istart,100, ifound) if (ifound .eq. 0) go to 20 istart = ifound call findc (dummy,100, ' ', 1, istart,100, ifound) if (ifound .eq. 0) go to 20 i = i + 1 do 10 l = 1, 8 if (l .le. (ifound - istart) ) then ncomp(i)(l:l) = dummy((istart + l - 1)) else ncomp(i)(l:l) = ' ' endif 10 continue istart = ifound 20 continue 30 continue read (3,*) (weight(i), i = 1, nccc) 1001 format(i4) 1002 format(100a1) 1003 format(7f10.5) end subroutine elread c this routine asks for the system elements c only elements given here will be considered implicit double precision(a-h,o-z) parameter ( maxcmp=15) common /therm / thermo(11), comp(maxcmp), . reac, act, therlm( 9, 20), . therdi( 9, 20), iweird, ndx, . idis, lmda(3), npr, nctz common /info / axx(2), axy(2), ysize, xsize, npnum, ilabel common /diagra/ xval, yval, iptx, ix, iy common /eldata/ phcmp(40), weight(40), psyco(40), nccc character*8 ncomp(40) common /namele/ ncomp character*120 buffer character*20 ndum character*8 nabv character*1 dummy(100) c read - ignore blank responses write (*,*) 'enter: na mg al si k ca ti mn fe o h c' read (*,1002) dummy buffer(1:) = 'system ' istart = 1 j = 12 40 call ignore (dummy,100, ' ', 1, istart,100, ifound) if (ifound .eq. 0) go to 70 istart = ifound call findc (dummy,100, ' ', 1, istart,100, ifound) if (ifound .eq. 0) ifound =101 do 50 i = istart, (ifound - 1) buffer(j:j) = dummy(i) j = j + 1 50 continue buffer(j:) = '(1)' j = j + 3 istart = ifound if (istart .lt.100) go to 40 70 do 100 i = 1,100 if (i .le. j) then dummy(i) = buffer(i:i) else dummy(i) = ' ' endif 100 continue c get elements in system - how many call decode(psyco,ndum,nccc,ncomp,dummy,nabv,100,40,0) nctz = 0 do 200 i = 1, nccc if (psyco(i).ne.0.0) nctz = nctz + 1 200 continue 1001 format(/,' enter elements in system - separate by blanks or', . ' commas ',/,' no default ') 1002 format(100a1) end subroutine pread2(iswit1) c read part two of the data base - the thermodynamic properties c of minerals and gases c iswit1 = 0 -- data with h greater than 99999 is excluded. c gases without critical info are excluded. c = 1 -- all accepted c c thermo(i,j) contains the following (i = property j=phase) c 1 = h 2 = s c 3 = k0 (constant term) 4 = k5 (t term) c 5 = k2 (t**-2 term) 6 = volume c 7 = k1 (t**-.5 term) 8 = k4 (t**-1 term) c 9 = k6 (t**2 term) 10 = k3 (t**-3 term) c 11 = g (generally not used) c c k0 to k6 are heat capacity terms c implicit double precision(a-h,o-z) parameter (maxphs=100, maxcmp=15) common /therm / thermo(11), comp(maxcmp), . reac, act, therlm( 9, 20), . therdi( 9, 20), iweird, ndx, . jdis, lmda(3), npr, nctz common /choose/ ichh2o, ichco2, ichmix common /info / axx(2), axy(2), ysize, xsize, npnum, ilabel common /excl / kncr(maxcmp), iexcl(50,maxcmp+1), mex, icl, . nrc, nrr, iaf, inf common /inter / a, b, c, xd, xe, xf, xg, g, h, xmf(10), . xnmol(10), p, s, tc, v, xother, xnacl common /bases / basis(maxcmp,maxcmp), base(maxcmp), . nce(maxcmp), infc(maxcmp+1), nfc, nfld, nfchl dimension therm(16), tlm(9,3), tdi(9) character*8 namea character*20 name character*120 title common /chname/ title, name, namea common /eldata/ phcmp(40), weight(40), psyco(40), nccc character*8 ncomp(40) common /namele/ ncomp character*4 code common /namcod/ code c dimension data(5) character*255 buffer character*20 ndum, critn(10) character*8 nabv character*1 dummy(100) data critn/ 'water ', 'carbon dioxide ', . 'oxygen gas ', 'hydrogen gas ', . 'sulfur gas ', ' ', . ' ', ' ', . ' ', ' '/ data ncrit/ 5/ name = ' ' namea = ' ' code = ' ' iweird = 0 ndx = 0 act = 0.0 do 22 j = 1, maxcmp comp(j) = 0.0 22 continue c read lines until a section heading is found 30 read ( 3,1001, end=99) dummy call ignore(dummy,100, ' ', 1, 1,100, ifound) if (ifound .eq. 0) go to 30 if (dummy(ifound) .ne. '*') go to 30 c what section heading has been found - if it can not be identified c ignore til the next section 40 call findc(dummy,100, '*mineral', 8, 1,100, ifound) if (ifound .ne. 0) then npws = 1 go to 100 endif call findc(dummy,100, '*gas', 4, 1,100, ifound) if (ifound .ne. 0) then npws = 4 go to 100 endif call findc(dummy,100, '*stop', 5, 1,100, ifound) if (ifound .ne. 0) then go to 99 endif call findc(dummy,100, '*end', 4, 1,100, ifound) if (ifound .ne. 0) then go to 99 endif c ignore until next section heading is read go to 30 c read in phase (mineral or gas) properties c if a blank line, read next line c if first non-blank character is a *, go to section decode area c decide if it is in compositional space of reaction c read name, formula, abbreviation (skip blank lines) c check line for a '(' - if not present, keep reading c lines till one is found (this is the way that we know c that we are at the start of a new set of phase data. c this is also used to skip phases not in the right c compositonal space) c if a gas, check that we know about it 100 read( 3,1001,end=99) dummy 110 call ignore(dummy,100, ' ', 1, 1,100, ifound) if (ifound .eq. 0) go to 100 if (dummy(ifound) .eq. '!') go to 100 if (dummy(ifound) .eq. '*') go to 40 call findc(dummy,100, '(', 1, 1,100, ifound) if (ifound .eq. 0) go to 100 call decode(phcmp,ndum,nccc,ncomp,dummy,nabv,100,40,1) do 130 k = 1, nccc if (psyco(k).eq.0.0 .and. phcmp(k).ne.0.0) go to 100 130 continue kk = 0 if (npws.eq.4) then do 140 i = 1, ncrit if (ndum.eq.critn(i)) then kk = i if (dabs(xmf(kk)) .lt. 1.0d-06) go to 100 go to 190 endif 140 continue write(6,1002) ndum go to 100 endif c got a new entry, write c the old one: c first write name card 190 write (9,2000) namea,6,0,ilam,idis,name c next get number of oxygens, etc sk = 64.68 sna = 51.30 sca = 41.63 sc = 5.74 sti = 30.63 sal = 28.35 ssi = 18.81 smg = 32.68 smn = 32.01 sfe = 27.28 c values from Robie so = 205.15 /2. sh = 130.68 /2. c values from Berman, c strictly, these should be used for c consistency with the data given c for H2 and O2 by berman, however c the G's given by Berman '88 can c only be reproduced with the entropies c from Robie. c so = 205.03/ 2. c sh = 130.57/ 2. dsf = therm(2) - comp(1) * sna - comp(2) * smg * - comp(3) * sal - comp(4) * ssi * - comp(5) * sk - comp(6) * sca * - comp(7) * sti - comp(9) * sfe * - comp(8) * smn - comp(10) * so * - comp(11) * sh - comp(12) * sc gp = enth - 298.15 * dsf if (dabs(gp-therm(1)).gt.100.0 .and. therm(1).ne.0.0) then write (*,*) 'something fishy for:',namea write (*,*) 'g calculated from h =',gp write (*,*) 'therm(1) =',therm(1),' delta =',gp-therm(1) therm(1) = gp else if (therm(1).eq.0.0) then therm(1) = gp write (*,*) 'calculated g(',gp,') for ',namea else write (*,*) namea,gp-therm(1) therm(1) = gp end if comp(1) = comp(1)/2. comp(5) = comp(5)/2. comp(3) = comp(3)/2. comp(11) = comp(11)/2. comp(10) = (comp(10) - comp(1) - comp(2) - 3. * comp(3) * - 2. * comp(4) - comp(5) - comp(6) * - 2. * comp(7) - comp(8) - comp(9) * - comp(11) - 2. * comp(12))/2. comp(9) = comp(9) write (9,2001) (comp(j), j = 1, 12) write (9,2002) therm if (idis.ne.0) write (9,2002) tdi if (ilam.ne.0) then do i = 1, ilam write (9,2002) (tlm(j,i), j = 1, 9) end do end if do i = 1, 16 therm(i)=0.0 end do do i = 1, 12 comp(i) = 0.0 end do do i = 1, 9 tdi(i) = 0.0 do j = 1, 3 tlm(i,j) = 0.0 end do end do idis = 0 ilam = 0 ndx = kk namea = nabv name = ndum j = 0 do 200 i = 1, nccc if (psyco(i).ne.0.0) then j = j + 1 comp(j) = phcmp(i) endif 200 continue c read next lines - if they are blank or have a "(" on the line, c they belong to the next phase. otherwise, c check the first character and ignore or store c in appropiate array 210 read( 3,1001,end=99) dummy call ignore(dummy,100, ' ', 1, 1,100, ifound) if (ifound .eq. 0) go to 100 if (dummy(ifound) .eq. '!') go to 210 j = ifound call findc(dummy,100, '(', 1, 1,100, ifound) if (ifound .ne. 0) go to 110 ifound = j j = ifound + 1 if (dummy(ifound) .eq. '*') then go to 40 else if (dummy(ifound) .eq.'s' .and. dummy(j) .eq. 't') then c read ss card: write (buffer, '(100a1)' ) dummy read ( buffer,1003) (data(i),i=1,4) therm(1) = data(1) therm(2) = data(3) therm(3) = data(4) enth = data(2) else if (dummy(ifound) .eq. 'c') then c read c cards write(buffer,'(100a1)') dummy read (buffer,1003) (data(i),i=1,5) if (dummy(j) .eq. '1') then therm(4) = data(1) therm(8) = data(2) therm(6) = data(3) therm(10) = data(4) else if (dummy(j) .eq. '2') then therm(9) = data(1) therm(5) = data(2) therm(7) = data(3) else if (dummy(j) .eq. '3') then therm(4) = data(1) therm(5) = data(2) therm(6) = data(3) endif else if (dummy(ifound) .eq. 't') then c read t cards write(buffer,'(100a1)') dummy read (buffer,1003) (data(i),i=1,5) if (dummy(j) .eq. '1' .or. dummy(j) .eq. '3' .or. . dummy(j) .eq. '5' ) then if (dummy(j) .eq. '1') then ilam = ilam + 1 else if (dummy(j) .eq. '3') then ilam = ilam + 1 else if (dummy(j) .eq. '5') then ilam = ilam + 1 endif tlm(1,ilam) = data(3) tlm(2,ilam) = data(4) tlm(3,ilam) = data(1) tlm(7,ilam) = data(2) tlm(8,ilam) = data(5) else if (dummy(j) .eq. '2' .or. dummy(j) .eq. '4' .or. . dummy(j) .eq. '6' ) then tlm(4,ilam) = data(1) c data(2) not used in vertex, nor ubc tlm(5,ilam) = data(3) tlm(6,ilam) = data(4) end if else if (dummy(ifound) .eq. 'd') then c read d cards write(buffer,'(100a1)') dummy read (buffer,1003) (data(i),i=1,5) idis = 1 if (dummy(j) .eq. '1') then tdi(1) = data(1) tdi(2) = data(2) tdi(3) = data(3) tdi(5) = data(4) else if (dummy(j) .eq. '2') then tdi(6) = data(1) tdi(7) = data(2) tdi(8) = data(3) tdi(9) = data(4) endif else if (dummy(ifound) .eq. 'v') then c read v cards write(buffer,'(100a1)') dummy read (buffer,1003) (data(i),i=1,4) therm(11) = data(1) * therm(3) / 1.d5 therm(16) = data(2) * therm(3) / 1.d5 therm(13) = data(3) * therm(3) / 1.d5 therm(15) = data(4) * therm(3) / 1.d8 else if (dummy(ifound) .eq. 'a') then istart = ifound call findc(dummy,100, ' ', 1, istart,100, ifound) if (ifound .ne. 0) then istart = ifound call ignore(dummy,100, ' ', 1, istart,100, ifound) endif if (ifound .ne. 0) then ifound = ifound - 1 do 290 i = 1, 4 ifound = ifound + 1 code(i:i) = dummy(ifound) 290 continue iweird = 1 endif endif goto 210 2000 format (a8,4(i2),1x,a20) 2002 format (5(g13.7,1x)) 2001 format (12(f5.2,1x)) 1000 format(//,' ********************************************',/, . ' as a result of your input,',i4,' phases have',/, . ' been extracted from the data base but the ',/, . ' program is dimensioned for a maximum of',i4 ,/, . ' chose a simplier system or recompile the ',/, . ' program after changing the maxphs parameter',/, . ' *******************************************',//) 1001 format(100a1) 1002 format(// ,a20,' is a gas and its critical properties ', . /,'could not be found - it will be ignored.') 1003 format(5x,5f15.5) 1004 format(' phase ',a20,'has an delta h of zero in the data bank') 1005 format(//,' you have eliminated too many phases - there ',/, . ' are none left. try again.') 99 end subroutine ignore( l1, l1dim, l2, l2dim, istart, ifin, ifound) implicit double precision (a-h,o-z) c this routine searchs for the the first occurance (starting at c istart and ending at ifin) of a l2dim long character string c in the array l1 (dimensioned l1dim) that does not match the c l2dim long character string in the array l2. c if a string that does not match is found, then ifound is set c to the first position of that string (in l1). c if the string is a perfect match, ifound is set to 0. character*1 l1(l1dim), l2(l2dim) iend = ifin + 1 - l2dim do 20 i = istart, iend, l2dim do 10 j = 1, l2dim ii = i + j - 1 if( l1(ii) .ne. l2(j)) then ifound = i return endif 10 continue 20 continue ifound = 0 end subroutine decode(phcmp,name,nctz,ncomp,ldummy,nabv,isize, . ndim, iswt) implicit double precision (a-h,o-z) c c the elemental symbols are passed in ncomp (a4 format) c the number of elements is nctz c ldummy optionally containing one or more of the following: c (a) a mineral name, 3 blanks (or more), c (b) a chemical formula, 3 blanks (or more), c (c) an abreviation, 3 blanks (or more), c (d) miss. information c all in a1 format. (d) is always ignored. c dimensioned isize c c iswt contains a number .ge. -2 .and. .le. 4 c if iswt = -2, ldummy contains (a) c " " -1, " " (a), (c) c " " 0, " " (a), (b) c " " 1, " " (a), (b), (c) c " " 2, " " (b), (c) c " " 3, " " (b) c " " 4, " " (c) c c the mineral name is returned in name (in a20 format) c the formula is returned in phcmp, in order specified by symbols c in ncomp. dimensioned ndim c the abreviation is returned in nabv (in a8 format) c c three blanks ( ) are used as deliminators between fields c c single blanks are ignored c dimension phcmp(ndim) character*20 name character*8 nabv, ncomp(ndim) character*1 ldummy(isize), ltemp(80) c error output unit iout = 6 nabv = ' ' name = ' ' do 5 i = 1, ndim phcmp(i) = 0.0e00 5 continue istart = 1 ifound = 1 ifin = isize c check if name is present if (iswt .ge. 2) go to 100 c find first non blank character, and then 3 blanks -- name is c between these two strings call ignore(ldummy,isize,' ',1,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1001) (ldummy(i),i=1,isize) write(iout,1002) stop end if istart = ifound call findc(ldummy,isize,' ',3,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1001) (ldummy(i),i=1,isize) write(iout,1003) stop end if inum = ifound - istart if (inum .gt. 20) then write(iout,1008) (ldummy(i), i=1,isize) inum = 20 endif call movec(inum,isize,80,istart,ldummy,ltemp) do 10 i = 1, inum name(i:i) = ltemp(i) 10 continue c test if formula comes next 100 if (iswt .eq. -2) return if (iswt .eq. -1) go to 200 if (iswt .eq. 4) go to 200 c find start of formula, then 3 blanks. in between is formula, c decode with elsort istart = ifound call ignore(ldummy,isize,' ',1,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1001) (ldummy(i),i=1,isize) write(iout,1004) stop end if istart = ifound call findc(ldummy,isize,' ',3,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1001) (ldummy(i),i=1,isize) write(iout,1005) stop end if inum = ifound - istart call movec(inum,isize,80,istart,ldummy,ltemp) if ( inum .lt. 80) then do 150 i = (inum+1), 80 ltemp(i) = ' ' 150 continue else if ( inum .gt. 80) then write(iout,1009) (ldummy(i), i=1,isize) stop end if call elsort(phcmp, ltemp, ncomp, ndim, nctz, 80, iout, -1) c c test if abreviation comes next c 200 if (iswt .eq. 0) return if (iswt .eq. 3) return c find start of abreviation, then 3 blanks. abv is between istart = ifound call ignore(ldummy,isize,' ',1,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1001) (ldummy(i),i=1,isize) write(iout,1006) stop end if istart = ifound call findc(ldummy,isize,' ',3,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1001) (ldummy(i),i=1,isize) write(iout,1007) stop end if inum = ifound - istart if (inum .gt. 8) then inum = 8 write(iout,1010) (ldummy(i),i=1,isize) endif call movec(inum,isize,80,istart,ldummy,ltemp) do 250 i = 1, inum nabv(i:i) = ltemp(i) 250 continue 1001 format(' error in thermodynamic data bank. line in error is',/, . ' ',100a1) 1002 format(' in particular, the entire line is blank thus there', . ' is no phase/species name.') 1003 format(' in particular, the name is too long or 3 blanks', . ' were not found as a terminator.') 1004 format(' in particular, no formula was found.') 1005 format(' in particular, the formula is too long or 3 blanks', . ' were not found as a terminator.') 1006 format(' in particular, no abreviation was found.') 1007 format(' in particular, the abreviation is too long or 3', . ' blanks were not found as a terminator.') 1008 format(' truncation of phase name to 20 characters ', . ' line in question is: ',/, . 101a1) 1009 format(' formula truncated - please correct data base ',/, . ' and rerun. line in question is: ',/, . 101a1) 1010 format(' abreviation truncated. line in question is:',/, . 101a1) end subroutine movec(num,n1,n2,istart,l1,l2) c c this routine transfers num characters from the character c array l1 (dimensioned n1) starting at the istart'th character c to the character array l2 (dimensioned n2). c this routine does not check for array overflow, so be careful. c character*1 l1(n1), l2(n2) do 10 i = 1, num j = istart + i - 1 10 l2(i) = l1(j) end subroutine findc(l1,l1dim,l2,l2dim,istart,ifin,ifound) c this routine searchs the character array l1 (starting c at location istart, ending at location ifin) for the string c with length l2dim which is stored in the character array l2. c if found, ifound is set the starting position of the string, c if not, ifound is set to zero. character*1 l1(l1dim), l2(l2dim) ifound = 0 iend = ifin - l2dim + 1 do 20 i = istart, iend do 10 j = 1, l2dim ii = i + j - 1 if (l1(ii) .ne. l2(j)) go to 20 10 continue ifound = i return 20 continue end subroutine elsort( comp, ldummy, elname, nchem, numel, len, . iout,iswt) implicit double precision (a-h,o-z) c c this routine decodes a formula which has the general form c ca(3)al(2)si(3)o(12) c see notes on format below c c input: ldummy - contains the formula (see notes on format below) c len - dimension of ldummy c elname - elemental symbols c nchem - dimension of comp and elname c numel - number of elemental symbols in elname c iswt - if iswt .ge. 0 and an unknown element if found c (symbol not in elname), adds symbol c to elname and adds 1 to numel c - if iswt .lt. 0 and an unknown element if found c (symbol not in elname), an error c message is printed and program c stops c iout - unit to which error messages are written c c output: comp - contains the coefficients for each of the elements c - zero if an element is not present c - ordered by the order of the atomic symbols in c elname c c c notes on format of the formula: c c elemental symbols must be separated by the sequence: left c deliminator, coefficient, right deliminator c the left parenthesis '(' is the left deliminator of a c coefficient c the right parenthesis ')' is the right deliminator of a c coefficient c deliminators must be paired c the coefficients can be either integers or real numbers c elemental symbols/coefficients can be repeated as many times as c need be. ca(1)ca(3)ca(5.0)..... is prefectly legal c c repeat groups can also be used. the deliminators are [ and ], c respectively left and right, and must be paired. they c must be followed by ( coeff ) sequence. c dimension comp(nchem) character*20 buffer character*8 elname(nchem), name1 character*1 ldummy(len), lname1(8), lblank c data lblank/' '/ c do 1 i = 1, nchem comp(i) = 0.0 1 continue ifin = 0 irepl = 0 irepr = 0 irepn = 0 irepn2 = 0 repeat = 0.0 c 10 istart = ifin + 1 ifin = len if (istart .eq. irepl) istart = istart + 1 if (istart .eq. irepr) istart = irepn + 1 if (istart .ge. len) return c look for [ if present, repeat group exists. c only look if a repeat group is not currently active if (istart .ge. irepl .and. istart .ge. irepr) then call findc(ldummy,len,'[',1,istart,ifin,ifound) if (ifound .le. 0) then irepl = 0 irepr = len + 1 irepn = len + 1 repeat = 1.0 else irepl = ifound call findc(ldummy,len,']',1,irepl,ifin,ifound) if (ifound .gt. 0) then irepr = ifound irepn = ifound + 1 else write(iout,1400) (ldummy(i),i=1,len) stop endif c now decode repeat coefficient if (ldummy(irepn) .ne. '(' ) then write(iout,1410) (ldummy(i),i=1,len) stop endif call findc(ldummy,len,')',1,irepn,ifin,ifound) if (ifound.eq.0) then write(iout,1100) (ldummy(i),i=1,len) stop end if irepn2 = ifound - 1 irepn = irepn + 1 call findc(ldummy,len,'.',1,irepn,irepn2,ifound) if (ifound.ne.0) then write(buffer,'(20a1)') (ldummy(i),i=irepn, irepn2) read(buffer,'(f12.3)',err=100) repeat else inum = 6 - (irepn2 - irepn) if(inum.ne.0) write(buffer,'(20a1)') . (lblank,j=1,inum),(ldummy(i),i=irepn,irepn2) if(inum.eq.0) write(buffer,'(20a1)') . (ldummy(i),i=irepn,irepn2) read(buffer,'(i7)',err=100) i repeat = float(i) endif irepn = irepn2 + 1 endif endif ifin = len c find a "(". value between the 0'th position or the last ")" and c this "(" is the symbol of an element. call findc(ldummy,len,'(',1,istart,ifin,ifound) if (ifound.eq.0) return inum = ifound - istart name1 = ' ' call movec(inum,len,8,istart,ldummy,lname1) do 15 i = 1, inum name1(i:i) = lname1(i) 15 continue c if it is a new element, store name and obtain index. if it c has alread been input, get index. if (numel.gt.0) then do 20 i=1, numel index = i if(elname(i).eq.name1) go to 30 20 continue end if if (iswt.lt.0) then write(iout,1200) name1, (ldummy(i),i=1,len) stop end if numel = numel + 1 index = numel elname(numel) = name1 c find the next ")". characters between last "(" and this ")" c correspond to the number of moles the the element just read c in. this element has location index in the composition array c comp. store number of moles here. 30 istart = ifound + 1 call findc(ldummy,len,')',1,istart,ifin,ifound) if (ifound.eq.0) then write(iout,1100) (ldummy(i),i=1,len) stop end if ifin = ifound - 1 call findc(ldummy,len,'.',1,istart,ifin,ifound) if (ifound.ne.0) then write(buffer,'(20a1)') (ldummy(i),i=istart,ifin) read(buffer,'(f12.3)',err=100) x else inum = 6 - (ifin - istart) if(inum.ne.0) write(buffer,'(20a1)') (lblank,j=1,inum), . (ldummy(i),i=istart,ifin) if(inum.eq.0) write(buffer,'(20a1)') (ldummy(i),i=istart . ,ifin) read(buffer,'(i7)',err=100) i x = float(i) end if if (istart .ge. irepl .and. istart .le. irepr) . x = x * repeat comp(index) = comp(index) + x ifin = ifin + 1 go to 10 100 write(iout,1300) (ldummy(i),i=1,len) stop 1100 format(' one of the coefficients in a formula does not', . ' have a closing',/, . ' bracket. line in question is:',/, . ' ',101a1) 1200 format(' one of the elemental symbols could not be recognized.', . /,' symbol in question is: ',a8,/, . ' and is contained in the line: ',/,' ',101a1) 1300 format(' one of the coefficients', . ' in a formula has non-numeric symbols ', . /,' embeded in it. line in question is: ',/, . ' ',101a1) 1400 format(' a repeat group does', . ' not have a closing ] ',/,' line in questions is:',/, . ' ',101a1) 1410 format(' coefficient does', . ' not immediately follow a repeat group.',/, . ' line in question is: ',/,' ',101a1) end