implicit double precision (a-h,o-z) double precision comp(20) character*2 namel(40), record*80 common /namele/ namel, nel call elread write (*,*) (namel(i), i = 1, nel) 10 write (*,*) 'enter formula:' read (*,1000) record call formul (record, comp, ier) if (ier.eq.1) goto 10 do i = 1, nel write (*,*) namel(i),comp(i) end do goto 10 1000 format (a40) 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