implicit double precision (a-h,o-z) 

      double precision comp(20),
     *                 tt(3),st(3),vt(3),at(3),bt(3),
     *                 ct(3),dt(3),et(3),ft(3),gt(3)
                                 
                       
      character*2 namel(40), form*80, name*8, lname*17
                                                 
      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='new.dat')
      open ( 9,file='junk')
c                           name of velid elements:
      form ='na mg al si k ca ti mn fe o h c'

      call elread (form)
c                   vesuvianite      Ves  Ca(19)Mg(2)Al(11)Si(18)O(78)H(9)
c                   12345678901234567123451234567890123456789012345678901234567890
10    read (3,1010) lname,name,form

1010  format (a17,a5,a40)

      write (*,1000) name,form
      read (3,*) h,s,t1,s1,v1,a,b,c,d,e,f,g,tjunk,v,alpha,beta
      read (3,*) itrans
      ilam = 3 + itrans 
      if (itrans.ne.0.d0) then
         do i = 1, itrans
            read (3,*) tt(i),st(i),vt(i),at(i),bt(i),
     *                 ct(i),dt(i),et(i),ft(i),gt(i)
         end do 
      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

      gf = 1000.*h - 298.15 * dsf 
      v = v / 10.
      cp = f
      dp = c
      ep = d
      fp = e
      beta = -beta /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.

      if (ilam.lt.4) ilam = 0

      write (10,2000) name,1,0,ilam,0,lname,form
      write (10,2001) (comp(j), j = 1, 12)
      write (10,2002) gf,s,v,a,b,cp,dp,ep,fp,g,0.,0.,
     *                alpha,0.,0.,0.,0.,beta
      if (ilam.ge.4) then

         do i = 1, itrans
            if (vt(i).eq.0.d0) then
               clap = 0.d0
            else 
               clap = st(i)/(vt(i)/10.)
               if (clap.lt.0.d0) write (9,*) name,' neg clap'
               if (i.gt.1) write (9,*) name,' >1 clap trans'
            end if
            write (10,2002) tt(i),clap,st(i),at(i),bt(i),
     *                      ft(i),ct(i),dt(i),et(i),gt(i)
         end do 

      end if 

      if (ier.ne.0) write (*,*) name, ' darn it!'

1000  format (16x,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*3, 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

      if (int.gt.99) write (*,*) ' whopper'

      comp(iel) = comp(iel) + int

      istart = iend + 1
      if (istart.eq.80) goto 99

      goto 10

1010  format (80a1)
1020  format (i3)

99    end


      subroutine elread (form)                                                                 
c   routine to get a list of elements:                                                                          
      implicit double precision(a-h,o-z)                                      
                       
      character*2 namel(40), dummy(80)*1, form*80 
                                                 
      common /namele/ namel, nel                                                                                                                                                            

      nel = 0 

c      write (*,*) 'enter desired elements: ',
c     *            'na mg al si k ca ti fe mn o h c'                                                                  
      read (form,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