!! Barlow and Barnett, Computing for Scientists 1998
!! page 145-150                C++ and Fortran 90

PROGRAM Molecular_Weight

  IMPLICIT NONE
  INTEGER , PARAMETER :: max_el = 92
  REAL      :: AtWt(max_el+1)
  CHARACTER :: symbol(max_el+1)*2
  INTEGER   ::  xnpt
  REAL      :: molwt
  INTEGER   :: jstat = 0
  CHARACTER :: formula*100
  CALL read_data_file
  DO
     !   Get formula and compute molecular weight
     PRINT * , ' Please enter formula'
     READ  * ,  formula
     PRINT * ,  formula
     molwt = value_of(formula)
     PRINT '(A,F15.4)' , ' Molecular Weight is', molwt
  ENDDO
STOP ' normal exit from MolWt'
 
CONTAINS

  SUBROUTINE read_data_file
    !integer  :: xnpt ! correctly fails ... very instructive
    OPEN(UNIT = 1 , FILE = 'pt.dat')
    xnpt = 1
    DO WHILE(jstat >= 0)
       READ(1 , '(A2 , F15.3)' , IOSTAT=jstat) symbol(xnpt) , AtWt(xnpt)
       IF(xnpt>=max_el) exit
       xnpt = xnpt + 1
    END DO
    PRINT * , xnpt , ' elements read in'
    CLOSE(UNIT = 1)
    RETURN
  END SUBROUTINE read_data_file

  REAL RECURSIVE FUNCTION value_of(form) RESULT (val)
    CHARACTER :: form*(*)
    INTEGER   ::  fcount  
    REAL      :: fhead 
    IF(LEN_TRIM(form) .EQ. 0) THEN
       val = 0.0
       RETURN
    ENDIF

    fhead = val_head(form)
    fcount = val_count(form)
    val = fhead * fcount + value_of(form)
    RETURN
  END FUNCTION value_of

  REAL RECURSIVE FUNCTION val_head(form) RESULT(val)
    CHARACTER :: form*(*)
    IF(form(1:1) == '(') THEN
       val = val_group(form)
    ELSE
       val = val_element(form)
    ENDIF
    RETURN
  END FUNCTION val_head

  REAL RECURSIVE FUNCTION val_element(form) RESULT(val)
    INTEGER    :: i , j
    CHARACTER  :: form*(*)
    CHARACTER  :: work*2
    i = 1
    IF(form(2:2)>='a' .AND. form(2:2)<='z')  i = 2
    work = form(1:i)
    DO j = 1 , xnpt
       IF(work==symbol(j)) THEN
          val = AtWt(j)
          form = form(i+1:)
          RETURN
       ENDIF
    ENDDO
    PRINT * , 'Unknown Element ', form(1:i)
    STOP ' a serious error found here'
  END FUNCTION  val_element

  INTEGER FUNCTION val_count(form)
    INTEGER   :: j
    CHARACTER :: form*(*)
    val_count = 0
    DO
       j=INDEX('0123456789' , form(1:1))
       IF (j == 0) THEN
          IF (val_count == 0) val_count=1
          RETURN
       ENDIF
       form = form(2:)
       val_count = 10*val_count+j-1
    ENDDO
  END FUNCTION val_count

  REAL RECURSIVE FUNCTION val_group(form) RESULT(val)
    CHARACTER :: form*(*)
    CHARACTER :: work*100
    INTEGER   :: i , j
    j = 0
    DO i = 2 , LEN(form)
       
       IF( form(i:i)=='(' ) j = j+1
       IF( form(i:i)==')' ) j = j-1
       IF(j < 0) THEN
          work = form(2:i-1)
          form = form(i+1:)
          val = value_of(work)
          RETURN
       ENDIF
    ENDDO
    STOP ' Missing right bracket'
  END FUNCTION val_group

END PROGRAM Molecular_Weight


