       PROGRAM SINGLE

C THIS PROGRAM IS INTENDED TO BE A PREPROCESSOR TO CONVERT THE
C PERFECT CLUB CODES TO SINGLE PRECISION FOR USE ON MACHINES WHERE
C REAL = 64 BITS.
C WRITTEN BY: L. POINTER / CSRD URBANA, IL / AUGUST, 1989 
C DIRECT ANY COMMENTS TO: lpointer@uicsrd.csrd.uiuc.edu
C THERE ARE NO GUAREENTEES THAT THIS CODE WORKS. USE AT YOUR OWN RISK.


C DIGIT			LOGICAL FUNCTION - IS CHARACTER A DIGIT?
C I                     DO LOOP COUNTER
C I1,I2,I3              INDEX INTO STRING
C IFILE			UNIT NUMBER ASSIGNED TO IFILENME
C IFILENME		THE FILE TO BE CONVERTED (INPUT)
C ILINE			LINE COUNTER
C ITERM			UNIT NUMBER ASSIGNED TO TERMINAL FOR INPUT
C L                     COUNTER FOR LENGTH OF LINE
C LINE			FILE RECORD
C OFILE			UNIT NUMBER ASSIGNED TO OFILENME
C OFILENME		THE CONVERTED FILE (OUTPUT)
C STAT                  IOSTAT 
C STUSED                NUMBER OF CHARACTERS IN THE LINE

      IMPLICIT NONE

      CHARACTER*1 RESPONSE
      CHARACTER*15 IFILENME, OFILENME
      CHARACTER*72 LINE
      INTEGER I, I1, I2, I3, ILINE, L, STAT, STRUSD
      LOGICAL DIGIT

      INTEGER IFILE, OFILE, ITERM, OTERM
      PARAMETER (IFILE = 1, OFILE = 2, ITERM = 5, OTERM = 6)

      WRITE(OTERM,*) 'ENTER THE FILE TO BE CONVERTED (INPUT):'
      READ(ITERM,1) IFILENME
      WRITE(OTERM,*) 'ENTER THE CONVERTED FILE (OUTPUT):'
      READ(ITERM,1) OFILENME
1     FORMAT(A)

      IF (IFILENME.EQ.OFILENME) THEN
         WRITE(OTERM,*) 'ERROR: THE OUTPUT FILE NAME MUST BE DIFFERENT',
     .   ' FROM THE INPUT FILE NAME.'
         STOP
      ENDIF

99    OPEN (UNIT = IFILE, 
     .      FILE = IFILENME(1:LEN(IFILENME)),
     .      FORM = 'FORMATTED', STATUS = 'OLD', ERR = 100)
      GOTO 101

100   WRITE(OTERM,*) 'ERROR: INPUT NAME NOT FOUND'
      WRITE(OTERM,*) 'CONTINUE? Y OR N:'
      READ(ITERM,2) RESPONSE
2     FORMAT(A1)
      IF ((RESPONSE.EQ.'Y').OR.(RESPONSE.EQ.'y')) THEN
         WRITE(OTERM,*) 'FILE TO BE CONVERTED (INPUT):'
         READ(ITERM,1) IFILENME
         GOTO 99
      ELSE
         STOP
      ENDIF

101   CONTINUE
      OPEN (UNIT = OFILE, 
     .      FILE = OFILENME(1:LEN(OFILENME)),
     .      FORM = 'FORMATTED', STATUS = 'NEW', ERR = 200)
      GOTO 201

200   WRITE(OTERM,*) 'ERROR: UNABLE TO OPEN OUTPUT FILE'
      STOP

201   CONTINUE
      WRITE(OTERM,*) 'TRANSLATING FILE...'
      ILINE = 1
      READ(IFILE,3,IOSTAT=STAT) LINE
3     FORMAT(A72)

300   IF (STAT.EQ.0) THEN 
C LINE CAN CONTAIN AT MOST ONE OF THESE KEYEWORDS
         L = STRUSD(LINE)

         IF (LINE(1:1).EQ.'C') GOTO 390
C
         I1 = INDEX(LINE,'DOUBLE PRECISION')
         IF (I1.NE.0) THEN
             LINE(I1:I1+15) = 'REAL            '
             GOTO 390
         ENDIF
C
C SEARCH FOR KEYWORDS THAT CAN BE CONTINED IN THE SAME LINE
C
317      I1 = INDEX(LINE,'DBLE')
         IF (I1.NE.0) THEN
            LINE(I1:I1+3) = 'REAL'
            GOTO 317
         ENDIF
C
318      I1 = INDEX(LINE,'DCMPLX')
         IF (I1.NE.0) THEN
            LINE(I1:I1+5) = ' CMPLX'
            GOTO 318
         ENDIF
C
319      I1 = INDEX(LINE,'DIMAG')
         IF (I1.NE.0) THEN
            LINE(I1:I1+4) = 'AIMAG'
            GOTO 319
         ENDIF
C
         I3 = 0
         I1 = INDEX(LINE,'.')
328      IF (I1.EQ.0) GOTO 390
         I1 = I1 + I3
         IF (.NOT.(DIGIT(LINE(I1-1:I1-1)))) GOTO 331
         I2 = INDEX(LINE(I1:L),'D') + I1 - 1
         IF (I2.EQ.0) GOTO 390
         IF (I2.LT.I1) GOTO 390
         DO 330 I=I1+1,I2-1
            IF(.NOT.(DIGIT(LINE(I:I)))) GOTO 331
330      CONTINUE
         LINE(I2:I2) = 'E'
331      I3 = I1
         I1 = INDEX(LINE(I1+1:L),'.')
         GOTO 328
C
390      CONTINUE
396      WRITE(OFILE,4) LINE(1:L)
4        FORMAT(A)
	 READ(IFILE,3,IOSTAT=STAT) LINE
	 ILINE = ILINE + 1
	 GOTO 300
      ELSE IF (STAT.GT.0) THEN
	 WRITE(OTERM,*) 'ERROR: IN READING INPUT LINE'
	 WRITE(OTERM,*) 'LINE COUNTER = ', ILINE
	 STOP 'PROGRAM ABORTED'
      ELSE
	 WRITE(OTERM,*) 'END OF FILE'
	 WRITE(OTERM,*) ILINE, ' LINES WRITTEN'
      ENDIF

400   CLOSE(IFILE)
      CLOSE(OFILE)
      STOP 'PROGRAM CONVERTED TO SINGLE PRECISION'
      END


      FUNCTION DIGIT(CHAR)
C
      CHARACTER*1 CHAR
      LOGICAL DIGIT, D
C
      D = .FALSE.
      IF (CHAR.EQ.'0') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'1') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'2') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'3') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'4') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'5') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'6') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'7') THEN
	 D = .TRUE.
      ELSE IF (CHAR.EQ.'8') THEN
        D = .TRUE.
      ELSE IF (CHAR.EQ.'9') THEN
         D = .TRUE.
      ENDIF
C
      DIGIT = D
C
      RETURN
      END
    
      FUNCTION STRUSD(LINE)

      CHARACTER*72 LINE
      INTEGER L, STRUSD

      L = 72
      DO 395 I = 72,2,-1
          IF (LINE(I:I).NE.' ') THEN
              GOTO 396
          ELSE
              L = L - 1
          ENDIF
395   CONTINUE

396   CONTINUE
      STRUSD = L
      RETURN
      END
