CCL Home Page
Up Directory CCL enable.for
C******************************************************************************
      PROGRAM ENABLE
C******************************************************************************
      IMPLICIT REAL (A-H,O-Z)
C
      PARAMETER(NID = 8)
C
      CHARACTER*80 STRING
      CHARACTER*10 NAME
      CHARACTER*3  ID,IDENT(NID)
      CHARACTER*1  STAR,BLANK
C
      DATA IDENT      /'GEN','AMP','GMS','HND','G82','G86','G88','G90'/
      DATA NAME       /'XXXNBO.FOR'/
      DATA STAR,BLANK /'*',' '/
C
      DATA LFNIN,LFNOUT,LFNSRC,LFNFOR/5,6,7,8/
C
C  WHICH VERSION OF THE NBO PROGRAM SHOULD BE ENABLE?
C
   10 WRITE(LFNOUT,900)
      READ(LFNIN,1000) ID
C
C  MAKE SURE THIS IDENTIFIER IS RECOGNIZED:
C
      IFLG = 0
      DO 20 I = 1,NID
        IF(IDENT(I).EQ.ID) IFLG = I
   20 CONTINUE
      IF(IFLG.EQ.0) GOTO 10
C
C  OPEN THE INPUT NBO SOURCE FILE AND THE OUTPUT FORTRAN FILE:
C
      OPEN(UNIT=LFNSRC, FILE='nbo.src', STATUS='OLD', ERR=800)
C
      NAME(1:3) = ID
      OPEN(UNIT=LFNFOR, FILE=NAME, STATUS='NEW')
C
C  READ SOURCE CODE, WRITING OUT LINES LABELLED WITH THE APPROPRIATE
C  IDENTIFIER:
C
      ICNT = 0
   30 ICNT = ICNT + 1
      READ(LFNSRC,1010,ERR=810,END=50) STRING
C
C  IF THE FIRST CHARACTER OF A LINE IS A '*' AND THE LINE IS LABELLED
C  BY 'ID', REMOVE THE '*' (COMMENT):
C
      IF(STRING(1:1).EQ.STAR) THEN
        IF(STRING(73:75).EQ.ID) THEN
          STRING(1:1) = BLANK
C
C  IF THE FIRST CHARACTER IS A '*' AND THE LABELLED IS UNRECOGNIZED,
C  HALT PROGRAM EXECUTION:
C
        ELSE
          JFLG = 0
          DO 40 I = 1,NID
            IF(STRING(73:75).EQ.IDENT(I)) JFLG = I
   40     CONTINUE
          IF(JFLG.EQ.0) GOTO 820
        END IF
      END IF
C
C  WRITE THIS LINE TO THE FORTRAN FILE:
C
      WRITE(LFNFOR,940) STRING
      GOTO 30
C
C  FINISH UP:
C
   50 ICNT = ICNT - 1
      WRITE(LFNOUT,950) ICNT,NAME
      CLOSE(LFNSRC)
      CLOSE(LFNFOR)
      CALL EXIT
C
  800 WRITE(LFNOUT,910)
      STOP
C
  810 WRITE(LFNOUT,920) ICNT
      STOP
C
  820 WRITE(LFNOUT,930) STRING(73:75),ICNT
      STOP
C
  900 FORMAT(1X,'NBO Program version to enable?  ')
  910 FORMAT(1X,'NBO source code (NBO.SRC) is not found.')
  920 FORMAT(1X,'Error reading from NBO.SRC as line ',I5,'.')
  930 FORMAT(1X,'Unknown version label (',A3,') at line ',I5,
     + ' for NBO.SRC.')
  940 FORMAT(A80)
  950 FORMAT(1X,I5,' lines written to ',A10,'.')
 1000 FORMAT(A3)
 1010 FORMAT(A80)
      END
Modified: Fri Aug 19 16:00:00 1994 GMT
Page accessed 9102 times since Sat Apr 17 21:34:59 1999 GMT