	PROGRAM RESEQ
C***************************************************************************
C
C	SOURCE:	RESEQ.FOR
C
C	AUTHOR:	LAWRENCE L. MORTON
C		1747 SO. DOUGLASS ROAD, SUITE D
C		ANAHEIM, CA  92806
C		(714) 634-1662
C
C	DATE:	OCTOBER 10, 1980
C
C	MODIFIED: 7-JUN-81
C	MODIFIED ACCORDING TO L L MORTON'S CHANGES BY RWB. 6/81
C
C THIS PROGRAM WILL RESEQUENCE THE STATEMENT LABELS IN A FORTRAN SOURCE
C LISTING. IN THE CASE WHERE THE STATEMENT LABELS ARE COMPUTED VALUES
C IT WILL BE NECESSARY FOR THE USER TO GO BACK INTO THE FINAL SOURCE
C AND REWRITE THE EQUATIONS THAT PRODUCE THE ORIGINAL STATEMENT LABELS
C THIS PROGRAM MUST BE LINKED WITH: LOOKUP, NGOTO, NIF, NACCEP,
C NREAD, NCLOSE AND LARRY1 TO RUN.
C
C LIMITATIONS:
C
C	*NO QUOTED LITERALS OR HOLLERITH STRINGS CONTAINING A TAB FOLLOWED
C	 BY THE WORDS 'SUBROUTINE' OR 'FUNCTION' FOLLOWED BY A SPACE, ARE
C	 ALLOWED UNLESS THEY ARE SIGNIFYING A NEW SUBROUTINE OR FUNCTION
C	 OR ARE CONTAINED IN A COMMENT LINE.
C	*CURSOR POSITIONING WILL WORK ONLY FOR A VT100 (OR A VT52 IF THE
C	 VT100 ANSI/VT52 MODE SEQUENCE IS REMOVED).
C	*THE PROGRAM WILL NOT RESEQUENCE ITSELF.
C	*ALL SOURCE LINES MUST BEGIN WITH EITHER A COMMENT SIGNIFIER (C)
C	 OR A TAB OR A STATEMENT LABEL FOLLOWED BY A TAB, OR BE A CON-
C	 TINUATION LINE.
C
C***************************************************************************
C
	LOGICAL*1 STRING(81), NUMBER(11), FILE(14), BUF(40)
	LOGICAL*1 DIGIT(6), NULL, SPARE(81), TAB, VT100(5)
	INTEGER LABEL(500), START, TUBE(8)
	EXTERNAL LOOKUP, INDEX, NIF, NACCEP, NCLOSE, NREAD, NGOTO, LEN
	EQUIVALENCE (IBUF,BUF),(FILE,BUF)
C
	DATA NUMBER/'1','1','2','3','4','5','6','7','8','9','0'/
	DATA TAB/09/
	DATA NULL/0/
	DATA Z/3RDK0/
	DATA VT100/"033,"133,"077,"062,"154/	!VT100 TO 'VT52' MODE CHANGE
C
C COMMON STATEMENTS TO TRANSFER DATA TO SUBROUTINES
C
	COMMON /B/ ISTART, START, LNDEX, DIGIT, LABEL, NUMBER, NULL
	COMMON /C/ LL, L, STRING, SPARE
	COMMON/SCREEN/TUBE
C
	CALL ASSIGN(6,'TT:')
	CALL VTCNTL(1,TUBE)
	WRITE(6,5) VT100	!PUT VT100 IN VT52 MODE
5	FORMAT(1H+,5A1)
	CALL CURSOR(6,TUBE(1),1)
	CALL CURSOR(6,TUBE(2),1)
	CALL INPOS(6,IPOS,1001)
	WRITE(6,10)
10	FORMAT(1H+,T8,' INPUT FILE NAME TO BE RESEQUENCED ? ',$)
	ACCEPT 666, FILE
666	FORMAT (14A1)
C	CALL ENTER(BUF,3,14,NC,1045,6,0)
	CALL ASSIGN(1,FILE,0,'OLD','NC',1)
	OPEN(UNIT=2,NAME='WORK.XXX',TYPE='SCRATCH',CARRIAGECONTROL=
     1'LIST')
	CALL INPOS(6,IPOS,1201)
	WRITE(6,25)
25	FORMAT(1H+,T8,' STARTING STATEMENT NUMBER (INTEGER) ? ',$)
	ACCEPT *, START
C	CALL ENTER(BUF,1,5,NC,1247,6,0)
C	START = IBUF
	CALL INPOS(6,IPOS,1401)
	WRITE(6,30)
30	FORMAT(1H+,T8,' INPUT SEQUENCE FACTOR (INTEGER) ? ',$)
	ACCEPT *, LNDEX
C	CALL ENTER(BUF,1,5,NC,1443,6,0)
C	LNDEX = IBUF
	CALL CURSOR(6,TUBE(1),1)
	CALL CURSOR(6,TUBE(2),1)
	CALL INPOS(6,IPOS,1001)
	WRITE(6,57)
57	FORMAT(1H+,'                      PROGRAM RESEQUENCING',
     1  ' IN PROGRESS',///)
	WRITE(6,58)
58	FORMAT(1H+,'                           PLEASE DO NOT DISTURB...')
	LAB = 1
	START=START-LNDEX
	ISTART=START
C
	DO 100, I=1,3000
		READ(1,35,ERR=110,END=105) (STRING(J), J=1,80)
35		FORMAT( 80(A1))
		IF(STRING(1) .EQ. NULL .OR. STRING(1) .EQ. 'C') GOTO 50
C
C STARTS LINE NUMBERING OVER AT EACH SUBROUTINE OR FUNCTION
C
		LLL = INDEX(STRING,'	SUBROUTINE ')
		KKK = INDEX(STRING,'	FUNCTION ')
		IF((LLL .EQ. 0 .AND. KKK .EQ. 0) .OR. LLL .GT. 1
     1		.OR. KKK .GT. 1) GOTO 49
		LABEL(LAB) = 'XX'
		LAB = LAB+1
		ISTART=-(((LAB-1)*LNDEX)-START)
		GOTO 50
49		IF(STRING(1).GT.'9'.OR.STRING(1).LT.'0') GOTO 50
C
C DETERMINES THE POSITION IN 'STRING' WHERE THE TAB STARTS AND
C CONSEQUENTLY, THE NUMBER OF CHARACTERS IN THE LABEL.
C
	DO 70, J=1,6
		IF(STRING(J) .EQ. TAB) GOTO 75	!J IS TAB POSITION
70	CONTINUE
C
C CHANGES THE ASCII CODE FOR THE STATEMENT LABEL TO AN INTEGER
C
75		DECODE(J-1,76,STRING,ERR=120) LABOLD	!OLD LABEL
76		FORMAT( I5)
C
C COPIES ALL OF 'STRING' EXCEPT THE STATEMENT LABEL OVER TO 'SPARE'
C
		CALL SUBSTR(STRING,SPARE,J)
		LABEL(LAB) = LABOLD	!STORE OLD LABEL FOR REFERENCE
		NEWLAB=LAB*LNDEX+ISTART	!NEW LABEL
C
C A SERIES TO DETERMINE THE NUMBER OF CHARACTERS IN THE NEW LABEL.
C JJ IS THE NUMBER OF CHARACTERS IN THE NEW STATEMENT LABEL
C
		IF(NEWLAB .GT. 9) GOTO 78
		JJ=1
C
C IF THE LABEL IS A ONE DIGIT VALUE THEN THE VALUE IS ATTACHED HERE
C RATHER THAN IN THE DO LOOP BELOW
C
		DIGIT(1)=NUMBER(NEWLAB+1)
		GOTO 98
78		IF(NEWLAB .GT. 99) GOTO 81
		JJ=2
		GOTO 91
81		IF(NEWLAB .GT. 999) GOTO 83
		JJ=3
		GOTO 91
83		IF(NEWLAB .GT. 9999) GOTO 85
		JJ=4
		GOTO 91
85		JJ=5
91		II=0
C
C BREAKS THE INTEGER VALUE OF THE NEW LABEL UP INTO INDIVIDUAL
C DIGITS AND PLACES THE ASCII EQUIVALENTS INTO 'DIGIT'
C
	DO 99, J=JJ-1,1,-1
		II=II+1
		IJ=10**J
		M=NEWLAB/IJ
		IF( M .NE. 0) GOTO 97
		DIGIT(II) = NUMBER(11)
		GOTO 99
97		DIGIT(II)=NUMBER(M+1)
		NEWLAB=NEWLAB-IJ*M
99	CONTINUE
		IF(NEWLAB .NE. 0) GOTO 96
		DIGIT(JJ)=NUMBER(11)
		GOTO 98
96		DIGIT(JJ)=NUMBER(NEWLAB+1)
C
C A NULL IS INSERTED AT THE END OF 'DIGIT' SO THAT 'CONCAT' DOES NOT
C WRITE THE ENTIRE 6-ELEMENT ARRAY TO STRING IF THERE ARE LESS THAN 6
C DIGITS IN THE NEW LABEL
C
98		DIGIT(JJ+1)=NULL
C
C TAKES THE NEW LABEL AND THE ORIGINAL STRING ('SPARE') AND PLACES
C THEM IN 'STRING'
C
		CALL CONCAT(DIGIT,SPARE,STRING,80)
		LAB=LAB+1
50		CALL TRIM(STRING)
		WRITE(2,35,ERR=140) (STRING(J), J=1,LEN(STRING))
100	CONTINUE
105	REWIND 1
	REWIND 2
	CALL CLOSE(1)
C
C OPEN 'NEW.SEQ' AS THE FINAL INPUT FILE
C TO END UP WITH THE RESEQUENCED VERSION OF THE ORIGINAL INPUT FILE
C
	OPEN (UNIT=1,NAME='NEW.SEQ',TYPE='NEW',CARRIAGECONTROL='LIST')
C
C MAIN DO LOOP TO PROCESS ALL STATEMENT LINES
C
	ISTART=START
	DO 1000, I=1,3000	!UP TO 3000 LINES
		READ(2,35,ERR=110,END=3300) (STRING(J), J=1,80)
		IF(STRING(1) .EQ. NULL .OR. STRING(1) .EQ. 'C') GOTO 510
C
C DETERMINES IS A NEW SUBROUTINE IS STARTING TO BEGIN LABEL NUMBERING
C FROM BEGINNING
C
	IF(INDEX(STRING,'	SUBROUTINE ') .EQ. 0 .AND.
     1  INDEX(STRING,'	FUNCTION ') .EQ. 0) GOTO 998
		DO 842, IV=1,500
			IF(LABEL(IV) .EQ. 'XX') GOTO 843
			LABEL(IV) = 0
842		CONTINUE
843		LABEL(IV) = 0
		ISTART = -(IV*LNDEX-START)
		GOTO 510
C DETERMINE WHETHER THE STRING HAS AN EXCLAMATION POINT
C INDICATING LINE COMMENTS
C
998	KT = INDEX(STRING,'!')	!CHECK FOR EXCLAM POINT
C 'IF' STATEMENT
		L = INDEX(STRING,'IF')
		IF(L .EQ. 0) GOTO 505
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 505
		LL = 2
		CALL NIF()
C 'ACCEPT' STATEMENT
505		L = INDEX(STRING,'ACCEPT')
		IF(L .EQ. 0) GOTO 515
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 515
		LL = 6
		CALL NACCEP()
		GOTO 500
C 'ASSIGN' STATEMENT
515		L = INDEX(STRING,'ASSIGN')
		IF(L .EQ. 0) GOTO 535
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 535
		LL = 6
		CALL NACCEP()
		GOTO 500
C 'DECODE' STATEMENT
535		L = INDEX(STRING,'DECODE')
		IF(L .EQ. 0) GOTO 545
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 545
		LL = 6
		CALL NREAD()
		GOTO 500
C 'DO' STATEMENT
545		L = INDEX(STRING,'DO')
		IF(L .EQ. 0) GOTO 555
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 555
		LL = 2
		CALL NACCEP()
		GOTO 500
C 'ENCODE' STATEMENT
555		L = INDEX(STRING,'ENCODE')
		IF(L .EQ. 0) GOTO 565
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 565
		LL = 6
		CALL NREAD()
		GOTO 500
C 'GOTO' STATEMENT
565		L = INDEX(STRING,'GOTO')
		IF(L .EQ. 0) GOTO 575
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 575
		LL = 4
		CALL NGOTO()
		GOTO 500
C 'GO TO' STATEMENT
575		L = INDEX(STRING,'GO TO')
		IF(L .EQ. 0) GOTO 595
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 595
		LL = 5
		CALL NGOTO()
		GOTO 500
C 'PRINT' STATEMENT
595		L = INDEX(STRING,'PRINT')
		IF(L .EQ. 0) GOTO 605
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 605
		LL = 5
		CALL NACCEP()
		GOTO 500
C 'READ' STATEMENT
605		L = INDEX(STRING,'READ')
		IF(L .EQ. 0) GOTO 615
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 615
		LL = 4
		CALL NREAD()
		GOTO 500
C 'TYPE' STATEMENT
615		L = INDEX(STRING,'TYPE')
		IF(L .EQ. 0) GOTO 625
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 625
		LL = 4
		CALL NACCEP()
		GOTO 500
C 'WRITE' STATEMENT
625		L = INDEX(STRING,'WRITE')
		IF(L .EQ. 0) GOTO 500
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 500
		LL = 5
		CALL NREAD()
C
C THIS TAKES CARE OF ANY 'ERR' CODES IN ANY OF THE STATEMENTS INCLUDING
C THE 'CLOSE', 'OPEN' STATEMENTS
C
500		L = INDEX(STRING,'ERR')
		IF(L .EQ. 0) GOTO 510
		IF(KT .LE. L .AND. KT .NE. 0) GOTO 510
		LL = 3
		CALL NCLOSE()
C
C CLEAR ANY TRAILING SPACES IN 'STRING' AND WRITE IT TO THE NEW FILE
C
510		CALL TRIM(STRING)
		WRITE(1,35,ERR=140) (STRING(J), J=1,LEN(STRING))
1000	CONTINUE
C
C FETCH THE DK: DEVICE HANDLER
C
3300	IF(IFETCH(Z) .NE. 0) STOP 'FATAL ERROR FETCHING HANDLER'
C
C DELETE THE OLD 'WORK.XXX' FILE FROM THE DIRECTORY
	CALL IDELET(ILUN(2),'DK:WORK.XXX')
	CALL CLOSE(1)
	CALL CLOSE(2)
	CALL CURSOR(6,TUBE(1),1)
	CALL CURSOR(6,TUBE(2),1)
	CALL INPOS(6,IPOS,1001)
	WRITE(6,333)
333	FORMAT(1H+,'               RESEQUENCING IS COMPLETE - THE NEW',
     1  ' RESEQUENCED FILE',///)
	WRITE(6,334)
334	FORMAT(1H+,'                    APPEARS UNDER THE NAME',
     1  '  "NEW.SEQ" ON DK:')
	CALL INPOS(6,IPOS,2401)
	CALL CLOSE(6)
	STOP
110	STOP 'READ ERROR'
120	STOP 'DECODE ERROR'
140	STOP 'WRITE ERROR'
	END
