implicit double precision (a-h,o-z) double precision comp(20) character*2 namel(40), form*80, name*8, lname*16 common /namele/ namel, nel c entropies of the elements at 298, 1bar 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.20 /2. sh = 130.70 /2. open (3,file='gott.dat') open (10,file='crap') open (9,file='new.dat') call elread 10 read (3,1010) lname,name,form write (*,1000) name,form read (3,*) h,s,a,b,c,d,e,v,alpha,beta ilam = 0 if (name.eq.'t') then read (3,1000) name ilam = 4 write (*,1000) name read (3,*) at,bt,ct,dt,et,vt,alphat,betat,tt, ds, dv end if call formul (form, comp, ier) c convert hp H to G dsf = s - comp(1) * sna - comp(2) * smg * - comp(3) * sal - comp(4) * ssi * - comp(5) * sk - comp(6) * sca * - comp(7) * sti - comp(8) * smn * - comp(9) * sfe - comp(10) * so * - comp(11) * sh - comp(12) * sc g = 1000.*h - 298.15 * dsf v = v / 10. vt = vt /10. dv = dv / 10. beta = -beta /10. betat = -betat / 10. c convert to oxide stoichiometry comp(1) = comp(1)/2. comp(3) = comp(3)/2. comp(5) = comp(5)/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) comp(10) = comp(10) / 2. write (10,2000) name,1,0,ilam,0,lname,form write (10,2001) (comp(j), j = 1, 12) write (10,2002) g,s,v,a,b,c,d,e,0.,0.,alpha,0.,beta,0.,0.,0. if (ilam.eq.4) then write (10,2002) tt,ds/dv,ds,at,bt,ct,dt,et,0. end if if (ier.ne.0) write (*,*) name, ' fuck me!' 1000 format (16x,a8,a40) 1010 format (a16,a8,a40) 2000 format (a8,4(i2),1x,a16,1x,a40) 2002 format (5(g13.7,1x)) 2001 format (12(f5.2,1x)) goto 10 end subroutine formul (record, comp, ier) c------------------------------------------------------------- c formula decomposes a chemical formula written in an 80 c character variable "record" and outputs the stoichiometry c of each valid element in the formula to the array comp. c the nel valid elements are in the array namel. if an invalid c element is found the formula is rejected (ier = 1) c the formula must have a format like Ca(1)Mg(2)O(3)H(1)... c the same element may occur more than once. c jadc 1992. c------------------------------------------------------------- implicit double precision (a-h,o-z) double precision comp(20) character*2 namel(40), dummy(80)*1, formel, record*80 common /namele/ namel, nel read (record,1010) dummy istart = 1 iel = 0 ier = 0 do i = 1, nel comp(i) = 0. end do 10 if (dummy(istart).eq.' ') then istart = istart + 1 if (istart.eq.80) goto 99 goto 10 end if iend = istart + 1 if (dummy(iend).ne.'(') then iend = iend + 1 if (iend.eq.80) then write (*,*) 'bad format 1' stop end if end if formel = record(istart:iend-1) do i = 1, nel iel = i if (namel(i).eq.formel) goto 20 end do ier = 1 goto 99 20 istart = iend + 1 iend = iend + 2 30 if (dummy(iend).ne.')') then iend = iend + 1 if (iend.gt.80) then write (*,*) 'bad format 2' stop end if goto 30 end if formel = record(istart:iend-1) read (formel,1020) int comp(iel) = comp(iel) + int istart = iend + 1 if (istart.eq.80) goto 99 goto 10 1010 format (80a1) 1020 format (i2) 99 end subroutine elread c routine to get a list of elements: implicit double precision(a-h,o-z) character*2 namel(40), dummy(80)*1 common /namele/ namel, nel nel = 0 write (*,*) 'enter desired elements: ', * 'na mg al si k ca ti fe mn o h c' read (*,1000) dummy istart = 1 10 if (dummy(istart).eq.' ') then istart = istart + 1 if (istart.eq.80) goto 99 goto 10 end if iend = istart + 1 if (dummy(iend).ne.' ') iend = iend + 1 nel = nel + 1 write (namel(nel),1010) (dummy(i),i=istart,iend-1) istart = iend + 1 if (istart.gt.80) goto 99 goto 10 1000 format (80a1) 1010 format (2a1) 99 end