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	MODIFIED: 20-AUG-82 TO ADD PARSE FEATURE AND REMOVE NON-STANDARD
C	SCREEN CALLS (REPLACED WITH "VT" LIBRARY)
C	MODIFIED: 9-FEB-84 TO UPDATE PARSE AND VT LIBRARY CALLS
C	 CHANGES NEEDED TO ACCOMODATE FORTRAN V2.6, ALSO.
C	 FIXED BUG IN "DO" PROCESSING.
C	MODIFIED: 18-MAR-85 BY KURT BALSER, UNIVERSITY OF GIESSEN
C	 TAB'S AFTER READ, IF, ...
C	MODIFIED: 21-JUN-85 BY RWB. 
C	 A <FF> CHARACTER WILL NOW BE HANDLED PROPERLY.
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 APPLIB 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 
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.  IF A STATEMENT HAS A LABEL FOLLOWED BY SPACES
C	 TO GET TO COLUMN 7, THE LABEL WILL BE CORRECTLY RECOMPUTED, BUT
C	 THE STATEMENT WILL BE MISALIGNED IN THE OUTPUT FILE.
C	*BE SURE YOU DON'T USE VARIABLES WHICH HAVE SUBSTRINGS WHICH
C	 ARE FORTRAN RESERVED WORDS (I.E., "THREAD" LOOKS LIKE "READ").
C
C***************************************************************************
C
	BYTE STRING(81), SPARE(81), NUMBER(11), DIGIT(6), NULL, TAB
	BYTE FF
	BYTE FILE(14), INPNAM(15), OUPNAM(15), WRKNAM(15)
	INTEGER LABEL(500), START, DEVR, EXTIR, EXTOR, TMPR, ODEV
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
	EXTERNAL LOOKUP, INDEX, NIF, NACCEP, NCLOSE, NREAD, NGOTO, LEN
C
	DATA NUMBER /'1','1','2','3','4','5','6','7','8','9','0'/
	DATA TAB, NULL /09, 0 /
	DATA FF /12/
	DATA DEVR, EXTIR, EXTOR, TMPR /3RSY , 3RFOR, 3RRSQ, 3RTMP /
C
	LASCHR= 0
	CALL HOME
	CALL CENTER (5, 43, 80, 'S')
	TYPE 5
5	FORMAT ('+RESEQUENCE PROGRAM, VERSION 2.5.  21-Jun-85')
158	CALL CUP (10,4)
	TYPE 10
10	FORMAT 
	*('+FILE NAME TO BE RESEQUENCED (DEFAULT=SY:XXXXXX.FOR) ? ',$)
	ACCEPT 666, FILE
666	FORMAT (14A1)
	CALL PARSE (FILE, INPNAM, DEVR, EXTIR, LASCHR)
	CALL PARSE (INPNAM, OUPNAM, DEVR, EXTOR, LASCHR)
	CALL PARSE (INPNAM, WRKNAM, DEVR, TMPR, LASCHR)
	OPEN (UNIT=1, NAME=INPNAM, TYPE='OLD', CARRIAGECONTROL=
     1'LIST', ERR= 569)
	OPEN (UNIT=2, NAME=WRKNAM, TYPE='SCRATCH', CARRIAGECONTROL=
     1'LIST')
	I= INDEX (OUPNAM,':')
	I= I- 1
	CALL IRAD50 (I, OUPNAM, ODEV)
	CALL CUP (12, 20)
	TYPE 25
25	FORMAT ('+STARTING STATEMENT NUMBER (INTEGER) ? ',$)
	ACCEPT *, START
	CALL CUP (14, 24)
	TYPE 30
30	FORMAT ('+INPUT SEQUENCE FACTOR (INTEGER) ? ',$)
	ACCEPT *, LNDEX
	CALL HOME
	CALL CENTER (10, 40, 80, 'D')
	TYPE 57
57	FORMAT ('+PROGRAM RESEQUENCING')
	CALL CENTER (12, 22, 80, 'D')
	TYPE 159
159	FORMAT ('+IN PROGRESS')
	CALL CENTER (14, 48, 80, 'D')
	TYPE 58
58	FORMAT ('+PLEASE DO NOT DISTURB...')
	CALL CENTER (16, 80, 80, 'S')
	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 (80A1)
		IF (STRING(1).EQ.NULL .OR. STRING(1).EQ.'C') GO TO 50
C
C IF THE MODULES ARE SEPARATED BY A <FF>, WRITE IT OUT AS A SEPARATE
C RECORD, AND SHIFT THE REMAINDER OF THE STRING
C
		IF (STRING(1).NE.FF) GO TO 38
		WRITE (2,35,ERR=140) FF		!WRITE THE <FF>.
		DO 37 J= 1,79
37		STRING(J)= STRING(J+1)		!NOW SHIFT THE STRING.
		STRING(80)= ' '			!JUST IN CASE.
38		CONTINUE
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) GO TO 49
		LABEL(LAB)= 'XX'
		LAB= LAB+ 1
		ISTART= -(((LAB-1)*LNDEX)-START)
		GO TO 50
49		IF (STRING(1).GT.'9'.OR.STRING(1).LT.'0') GO TO 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 .OR. STRING(J).EQ.' ') GO TO 75
C		J IS POSITION OF END OF LABEL
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) GO TO 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)
		GO TO 98
78		IF (NEWLAB.GT.99) GO TO 81
		JJ= 2
		GO TO 91
81		IF (NEWLAB.GT.999) GO TO 83
		JJ= 3
		GO TO 91
83		IF (NEWLAB.GT.9999) GO TO 85
		JJ= 4
		GO TO 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) GO TO 97
		DIGIT(II)= NUMBER(11)
		GO TO 99
97		DIGIT(II)= NUMBER(M+1)
		NEWLAB= NEWLAB-IJ*M
99	CONTINUE
		IF (NEWLAB.NE.0) GO TO 96
		DIGIT(JJ)= NUMBER(11)
		GO TO 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
	CLOSE (UNIT=1)
C
C OPEN OUTPUT FILE "OUPNAM" AS THE FINAL INPUT FILE
C TO END UP WITH THE RESEQUENCED VERSION OF THE ORIGINAL INPUT FILE
C
	OPEN (UNIT=1, NAME=OUPNAM, 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') GO TO 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) GO TO 998
		DO 842, IV= 1,500
			IF (LABEL(IV).EQ.'XX') GO TO 843
			LABEL(IV)= 0
842		CONTINUE
843		LABEL(IV)= 0
		ISTART= -(IV*LNDEX-START)
		GO TO 510
C DETERMINE WHETHER THE STRING HAS AN EXCLAMATION POINT
C INDICATING LINE COMMENTS
C
998	KT= INDEX (STRING,'!')		!CHECK FOR EXCLAM POINT
C
C DON'T TRIM FORMAT STATEMENTS WHICH DON'T END IN A ")" - THE FINAL
C BLANKS MAY BE IMPORTANT.
C
		L= INDEX (STRING,'FORMAT')
		IF (L.EQ.0) GO TO 501		!NOT "FORMAT" - ONWARDS
		L= INDEX (STRING,')')		!IS "FORMAT" STMT
		IF (L.NE.0) GO TO 510		!END OF STMT - TRIM IT.
		GO TO 570		!NOT THE END - JUST WRITE IT OUT.
C 'IF' STATEMENT
501		L= INDEX (STRING,'IF')
		IF (L.EQ.0) GO TO 505
		IF (KT.LE.L .AND. KT.NE.0) GO TO 505
		LL= 2
		CALL NIF()
C 'ACCEPT' STATEMENT
505		L= INDEX (STRING,'ACCEPT')
		IF (L.EQ.0) GO TO 515
		IF (KT.LE.L .AND. KT.NE.0) GO TO 515
		LL= 6
		CALL NACCEP()
		GO TO 500
C 'ASSIGN' STATEMENT
515		L= INDEX (STRING,'ASSIGN')
		IF (L.EQ.0) GO TO 535
		IF (KT.LE.L .AND. KT.NE.0) GO TO 535
		LL= 6
		CALL NACCEP()
		GO TO 500
C 'DECODE' STATEMENT
535		L= INDEX (STRING,'DECODE')
		IF (L.EQ.0) GO TO 545
		IF (KT.LE.L .AND. KT.NE.0) GO TO 545
		LL= 6
		CALL NREAD()
		GO TO 500
C 'DO' STATEMENT
545		L= INDEX (STRING,'DO ')
		IF (L.EQ.0) GO TO 555
		IF (KT.LE.L .AND. KT.NE.0) GO TO 555
		LL= 2
		CALL NACCEP()
		GO TO 500
C 'ENCODE' STATEMENT
555		L= INDEX (STRING,'ENCODE')
		IF (L.EQ.0) GO TO 565
		IF (KT.LE.L .AND. KT.NE.0) GO TO 565
		LL= 6
		CALL NREAD()
		GO TO 500
C 'GOTO' STATEMENT
565		L= INDEX (STRING,'GOTO')
		IF (L.EQ.0) GO TO 575
		IF (KT.LE.L .AND. KT.NE.0) GO TO 575
		LL= 4
		CALL NGOTO()
		GO TO 500
C 'GO TO' STATEMENT
575		L= INDEX (STRING,'GO TO')
		IF (L.EQ.0) GO TO 595
		IF (KT.LE.L .AND. KT.NE.0) GO TO 595
		LL= 5
		CALL NGOTO()
		GO TO 500
C 'PRINT' STATEMENT
595		L= INDEX (STRING,'PRINT')
		IF (L.EQ.0) GO TO 605
		IF (KT.LE.L .AND. KT.NE.0) GO TO 605
		LL= 5
		CALL NACCEP()
		GO TO 500
C 'READ' STATEMENT
605		L= INDEX (STRING,'READ')
		IF (L.EQ.0) GO TO 615
		IF (KT.LE.L .AND. KT.NE.0) GO TO 615
		LL= 4
		CALL NREAD()
		GO TO 500
C 'TYPE' STATEMENT
615		L= INDEX (STRING,'TYPE')
		IF (L.EQ.0) GO TO 625
		IF (KT.LE.L .AND. KT.NE.0) GO TO 625
		LL= 4
		CALL NACCEP()
		GO TO 500
C 'WRITE' STATEMENT
625		L= INDEX (STRING,'WRITE')
		IF (L.EQ.0) GO TO 500
		IF (KT.LE.L .AND. KT.NE.0) GO TO 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) GO TO 510
		IF (KT.LE.L .AND. KT.NE.0) GO TO 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)
570		WRITE (1,35,ERR=140) (STRING(J), J=1,LEN(STRING))
1000	CONTINUE
C
C FETCH THE OUTPUT DEVICE HANDLER
C
3300	IF (IFETCH(ODEV).NE.0) STOP 'FATAL ERROR FETCHING HANDLER'
C
C CLEAN UP
	CLOSE (UNIT=1)
	CLOSE (UNIT=2)
	CALL HOME
	CALL CUP (10,1)
	TYPE 333
333	FORMAT ('+               RESEQUENCING IS COMPLETE - THE NEW',
     1  ' RESEQUENCED FILE',///)
	TYPE 334, (OUPNAM(L),L=1,14)
334	FORMAT ('+                    APPEARS UNDER THE NAME',
     1  ' '14A1)
	CALL CUP (22,1)
	STOP
C
569	CALL CUP (22,1)
	TYPE 568, 7, (INPNAM(J),J=1,14)
	GO TO 158
568	FORMAT ('0FILE NOT FOUND - '15A1)
C
110	STOP 'READ ERROR'
120	WRITE (6,121) STRING
121	FORMAT (' STRING = ',80A1)
	STOP 'DECODE ERROR'
140	STOP 'WRITE ERROR'
	END