PROGRAM RESEQ

C	ORIGINAL AUTHOR: LAWRENCE L. MORTON
C			 1747 SO. DOUGLASS ROAD, SUITE D
C			 ANAHEIM, CA  92806
C			 (714) 634-1662

C	DATE:	OCTOBER 10, 1980.    FORTRAN IV.  SYSLIB STRING SUBROUTINES.


C	MODIFIED AND APPENDED DURING DECADE: (6/81; 7-JUN-81; 20-AUG-82;
C	9-FEB-84; 6/87; 3/88; 3/89; 11/89).

C	RESTRUCTURED, AND CODED IN F77   January 1990 (JEF).

	INCLUDE          'X:RESINC.FOR'

	CHARACTER*3      INDEV, OUTDEV, INEXT, OUTEXT

	CHARACTER*6      INNAME, OUTNAM

	CHARACTER*14     INFIL, OUTFIL, WRKFIL

	CHARACTER*28     TITLE1, TITLE2, TITLE3, TITLE4, TITLE5, TITLE6

	CHARACTER*50     TITLE

	DATA   TAB       /9/

	DATA   INDEV, INEXT   /'VM0', 'FOR'/

	DATA   OUTDEV, OUTEXT   /'VM0', 'RSQ'/

	DATA   INFIL(4:4), INFIL(11:11)   /':', '.'/

	DATA   OUTFIL(4:4), OUTFIL(11:11)   /':', '.'/

	DATA   WRKFIL    /'VM0:WRKFIL.TMP'/

	DATA   TITLE, TITLE1, TITLE2, TITLE3, TITLE4, TITLE5, TITLE6

	1 /'FORTRAN RESEQUENCING:  VERSION 2.6. (JEF).  Jan-90',
	1 'PROGRAM RESEQUENCING', 'IN PROGRESS', 'PLEASE DO NOT DISTURB...',
	2 'RESEQUENCING IS COMPLETE.', 'THE NEW AND RESEQUENCED FILE',
	3 'APPEARS UNDER THE NAME'/

	CALL CLRHOM

	CALL BOLD

	CALL CENTER ('R E S E Q',9,80,IP,'D')

	CALL DBLWID ('R E S E Q',9,2,IP)

	CALL TXTOFF

	CALL CENTER(TITLE,50,80,IPT,'S')

	CALL CURMOV(6,IPT)

	TYPE 10, TITLE

10	FORMAT(1H+,A)

20	TYPE '(//1H ,''CHANGE INPUT DEVICE [Default= VM0= CR] ? '',$)'

	ACCEPT 30, YN

30	FORMAT (A)

	IF (YN .NE. ' ')  THEN

	TYPE '(1H ,''ENTER INPUT DEVICE ? '',$)'

	ACCEPT 30,   INDEV

	ENDIF

	TYPE '(1H ,''CHANGE INPUT EXTENSION [Default= FOR= CR] ? '',$)'

	ACCEPT 30, YN

	IF (YN .NE. ' ')  THEN

	TYPE '(1H ,''ENTER INPUT EXTENSION ? '',$)'

	ACCEPT 30,   INEXT

	ENDIF

	TYPE '(1H ,''INPUT FILE NAME ? '',$)'

	ACCEPT 30, INNAME

	INFIL(1:3)= INDEV

	INFIL(5:10)= INNAME

	INFIL(12:14)= INEXT

	NB= 1

	NE= 13

40	DO 50 J= NB,NE

	IF (INFIL(J:J) .EQ. ' ')  THEN

	INFIL(J:)= INFIL(J+1:)

	NB= J

	NE= NE-1

	GOTO 40

	ENDIF

50	CONTINUE

	OPEN (1, FILE= INFIL, STATUS= 'OLD', ERR= 20)

	TYPE '(1H ,''CHANGE OUTPUT DEVICE [Default= VM0= CR] ? '',$)'

	ACCEPT 30, YN

	IF (YN .NE. ' ')  THEN

	TYPE '(1H ,''ENTER OUTPUT DEVICE ? '',$)'

	ACCEPT 30,   OUTDEV

	ENDIF

	TYPE '(1H ,''CHANGE OUTPUT EXTENSION [Default= RSQ= CR] ? '',$)'

	ACCEPT 30, YN

	IF (YN .NE. ' ')  THEN

	TYPE '(1H ,''ENTER OUTPUT EXTENSION ? '',$)'

	ACCEPT 30,   OUTEXT

	ENDIF

	OUTNAM= INNAME

	TYPE '(1H ,''CHANGE OUTPUT FILE NAME [Default= Input Name= CR] ?'',$)'

	ACCEPT 30, YN

	IF (YN .NE. ' ')  THEN

	TYPE '(1H ,''ENTER OUTPUT FILE NAME ? '',$)'

	ACCEPT 30, OUTNAM

	ENDIF

	OUTFIL(1:3)= OUTDEV

	OUTFIL(5:10)= OUTNAM

	OUTFIL(12:14)= OUTEXT

	NB= 1

	NE= 13

60	DO 70 J= NB,NE

	IF (OUTFIL(J:J) .EQ. ' ')  THEN

	OUTFIL(J:)= OUTFIL(J+1:)

	NB= J

	NE= NE-1

	GOTO 60

	ENDIF

70	CONTINUE

	TYPE '(1H ,''SCRATCH FILE=VM:WRKFIL.TMP:- OK [Y/N: CR= Yes] ? '',$)'

	ACCEPT 30, YN

	IF (YN .NE. ' ')  THEN

80	TYPE '(1H ,''SCRATCH FILE NAME ? '',$)'

	ACCEPT 30,   WRKFIL

	ENDIF

	OPEN (2, FILE= WRKFIL, STATUS= 'SCRATCH',
	1 CARRIAGECONTROL= 'FORTRAN', ERR= 80)		

	CALL CLRHOM

	CALL CURMOV(6,IPT)

	TYPE 10, TITLE

	CALL CURMOV(12,19)

	TYPE '(1H+,''INTEGER START NUMBER (CR ->  DEFAULT= 10)? '',$)'

	ACCEPT 90, START

90	FORMAT(I)

	IF (START .EQ. 0)  START= 10

	CALL CURMOV(14,21)

	TYPE '(1H+,''INTEGER INCREMENT (CR -> DEFAULT= 10)? '',$)'

	ACCEPT 90, INCREM

	IF (INCREM .EQ. 0)  INCREM= 10

	CALL CUROFF

	CALL CLRSCR

	CALL CENTER(TITLE1,20,80,IP,'D')

	CALL DBLWID(TITLE1,20,6,IP)

	CALL CENTER(TITLE2,11,80,IP,'D')

	CALL DBLWID(TITLE2,11,8,IP)

	CALL CENTER(TITLE3,24,80,IP,'D')

	CALL DBLWID(TITLE3,24,12,IP,'D')

	CALL CURMOV(18,21)

	TYPE '(1H+,''First Pass:  Lines Read='')'

	NL= 0		! No. lines read.

	LAB= 1

	START= START-INCREM

	ISTART= START

	CCGTFL= 0		! GOTO CONTINUED LINE FLAG.

C	Assume no statement # for 1st line: e.g. "PROGRAM", "FUNCTION", etc.

	READ (1,30)   STMENT	! Avoid blank 1st line in output file.

	NL= NL+1

	TYPE 100,  27,91,18,59,47,72,  NL	! Running count: STMENTs read.

100	FORMAT(1H+,2A1,I2,A1,I2,A1,I4)

	CALL STMLEN(STMENT,SLEN)

	WRITE(2,10)  STMENT(1:SLEN)		! Don't write trailing spaces.

110	READ (1,30,END=190)   STMENT

	NL= NL+1

C	Running tally.

	TYPE 100,  27,91,18,59,47,72,  NL

	IF (STMENT(1:1) .EQ. ' ' .OR. STMENT(1:1) .EQ. 'C'
	1 .OR. STMENT(1:1) .EQ. '*')   GOTO 170

	KXP= INDEX (STMENT,'!')	   ! LOCATE "!" INDICATING FOLLOWING COMMENT.

C	STARTS LINE NUMBERING OVER AT EACH SUBROUTINE OR FUNCTION.
					
	LLL= INDEX (STMENT,'SUBROUTINE')
C					     ! THIS MOD. (cf. Version 2.3)
	KKK= INDEX (STMENT,'FUNCTION')	     ! ACCOMMODATES TYPE (e.g.,
C					     ! "INTEGER" or "REAL") FUNCTION.

	IF (LLL .EQ. 0 .AND. KKK .EQ. 0) GOTO 120

C	OVERLOOK LITERALS:-   'FUNCTION','SUBROUTINE', or  ! comment.

	IF (KXP .NE. 0 .AND. (KXP .LE. KKK .OR. KXP .LE. LLL))   GOTO 120

	IF (INDEX(STMENT,'''') .NE. 0 .OR. INDEX(STMENT,'"') .NE. 0) GOTO 120

	LABEL(LAB)= 'XX'

	LAB= LAB+1

	ISTART= -(((LAB-1)*INCREM)-START)

	GOTO 170

C	DETERMINES LOCATION OF TAB IN STMENT, AND CONSEQUENTLY,
C	THE NUMBER OF CHARACTERS IN THE LABEL.

120	IF (STMENT(1:1) .GT. '9' .OR. STMENT(1:1) .LT. '0')  GOTO 170

	DO 130, KT= 1,6

	IF (STMENT(KT:KT) .EQ. TAB .OR. STMENT(KT:KT) .EQ. ' ')  GOTO 140

130	CONTINUE

C	CHANGES THE ASCII CODE FOR THE STATEMENT LABEL TO AN INTEGER.

140	K= KT-1

	READ(STMENT(1:K),90)  LABOLD

	LABEL(LAB)= LABOLD		!STORE OLD LABEL FOR REFERENCE

	NEWLAB= LAB*INCREM+ISTART	!NEW LABEL

	LAB= LAB+1

	WRITE(TEMP,'(I5)')  NEWLAB

	DO 150 K= 1,5

	IF (TEMP(K:K) .NE. ' ')  GOTO 160

150	CONTINUE

160	KK= 6-K

	STMENT(KK+1:)= STMENT(KT:)

	STMENT(1:KK)=  TEMP(K:5)

170	CALL STMLEN(STMENT,SLEN)

	IF (SLEN .EQ. 0)  THEN

	WRITE(2,180)		!BLANK LINE (write just CR).

180	FORMAT(1H ,A)

	ELSE

	WRITE(2,180)  STMENT(1:SLEN)

	ENDIF

	GOTO 110

190	REWIND 2

	CLOSE (1)

C	OPEN OUTPUT FILE "OUTFIL" AS THE FINAL INPUT FILE
C	TO END UP WITH THE RESEQUENCED VERSION OF THE ORIGINAL INPUT FILE.

	OPEN (1, NAME=OUTFIL, TYPE='NEW', CARRIAGECONTROL= 'FORTRAN')

C	MAIN DO LOOP TO PROCESS ALL STATEMENT LINES.

	CALL CURMOV(20,20)

	TYPE '(1H+,''Second Pass:  Lines Read='')'

	ISTART= START

	NLOOH= NL/100+1

	NL1= 1

	NL2= NLOOH

	READ (2,30)  STMENT

	CALL STMLEN(STMENT,SLEN)

	WRITE(1,10)   STMENT(1:SLEN)

	DO 400  JNL= 0,99

	DO 390  KNL= NL1,NL2

	READ (2,30,END=410)    STMENT

	IF (STMENT(1:1) .EQ. ' ' .OR. STMENT(1:1) .EQ. 'C'
	1 .OR. STMENT(1:1) .EQ. '*')  GOTO 370

C	DETERMINE WHETHER THE STMENT HAS AN EXCLAMATION POINT
C	INDICATING LINE COMMENTS.

	KXP= INDEX (STMENT,'!')		! LOCATE EXCLAMATION POINT.

C	DETERMINES IF A NEW SUBROUTINE IS STARTING TO BEGIN LABEL NUMBERING
C	FROM BEGINNING.

	ISUB= INDEX (STMENT,'SUBROUTINE')

	IFUNC= INDEX (STMENT,'FUNCTION')

	IF (ISUB .EQ. 0 .AND. IFUNC .EQ. 0)  GOTO 220

C	OVERLOOK LITERALS:-   'FUNCTION','SUBROUTINE', or  ! comment.

	IF (KXP .NE. 0 .AND. (KXP .LE. ISUB .OR. KXP .LE. IFUNC))  GOTO 220

	IF (INDEX(STMENT,'''') .NE. 0 .OR. INDEX(STMENT,'"') .NE. 0)  GOTO 220

	DO 200, I= 1,LAB

	IF (LABEL(I) .EQ. 'XX')  GOTO 210

200	LABEL(I)= 0

210	LABEL(I)= 0

	ISTART= -(I*INCREM-START)

	GOTO 370

C	DON'T TRIM FORMAT STATEMENTS WHICH DON'T END IN A ")" - THE FINAL
C	BLANKS MAY BE IMPORTANT.  ->  NOT FOR JEF:-  FORMAT CONTINUATION LINE!

C	COMPILE WITH "D" SWITCH IF WANT THIS TRIM.

220	CONTINUE

D	L= INDEX (STMENT,'FORMAT')
D	IF (L .EQ. 0) GOTO 230		!NOT "FORMAT" - ONWARDS
D	L= INDEX (STMENT,')')		!IS "FORMAT" STMT
D	IF (L .NE. 0) GOTO 370		!END OF STMT - TRIM IT.
D	GOTO  380			!NOT THE END - JUST WRITE IT OUT.


C	'IF' STATEMENT.

230	L= INDEX (STMENT,'IF')
	IF (L .EQ. 0) GOTO 240
	IF (KXP .NE. 0 .AND. KXP .LE. L) GOTO 240
	LL= 2
	CALL NIF()

C	'ACCEPT' STATEMENT.

240	L= INDEX (STMENT,'ACCEPT')
	IF (L .EQ. 0) GOTO 250
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 250
	JFL= INDEX (STMENT,'''(')	! F77 LITERAL FORMAT.
	IF (JFL .NE. 0) GOTO 370
	LL= 6
	CALL NACCEP()
	GOTO 370

C	'ASSIGN' STATEMENT.

250	L= INDEX (STMENT,'ASSIGN')
	IF (L .EQ. 0) GOTO 260
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 260
	LL= 6
	CALL NACCEP()
	GOTO 370

C	'DECODE' STATEMENT.

260	L= INDEX (STMENT,'DECODE')
	IF (L .EQ. 0) GOTO 270
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 270
	LL= 6
	CALL NREAD()
	GOTO 350

C	'DO' STATEMENT.

270	L= INDEX (STMENT,'DO ')
	IF (L .EQ. 0) GOTO 280
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 280
	LL= 2
	CALL NACCEP()
	GOTO 370

C	'ENCODE' STATEMENT.

280	L= INDEX (STMENT,'ENCODE')
	IF (L .EQ. 0) GOTO 290
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 290
	LL= 6
	CALL NREAD()
	GOTO 350

C	'GOTO' STATEMENT.

290	L= INDEX (STMENT,'GOTO')
	IF (L .EQ. 0) GOTO 300
	IF (KXP .NE. 0 .AND. KXP .LE. L) GOTO 300
	LL= 4
	CALL NGOTO
	GOTO 370

C	'GO TO' STATEMENT.

300	L= INDEX (STMENT,'GO TO')
	IF (L .EQ. 0) GOTO 310
	IF (KXP .NE. 0 .AND. KXP .LE. L) GOTO 310
	LL= 5
	CALL NGOTO
	GOTO 370

C	'PRINT' STATEMENT.

310	L= INDEX (STMENT,'PRINT')
	IF (L .EQ. 0) GOTO 320
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 320
	JFL= INDEX (STMENT,'''(')		! F77 LITERAL FORMAT.
	IF (JFL .NE. 0) GOTO 370
	LL= 5
	CALL NACCEP()
	GOTO 370

C	'READ' STATEMENT.

320	L= INDEX (STMENT,'READ')
	IF (L .EQ. 0) GOTO 330
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 330
	JFL= INDEX (STMENT,'''(')	! F77 LITERAL FORMAT.
	IF (JFL .NE. 0) GOTO 350
	LL= 4
	CALL NREAD()
	GOTO 350

C	'TYPE' STATEMENT.

330	L= INDEX (STMENT,'TYPE')
	IF (L .EQ. 0) GOTO 340
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 340	
	JFL= INDEX (STMENT,'''(')		! F77 LITERAL FORMAT.
	IF (JFL .NE. 0) GOTO 370
	LL= 4
	CALL NACCEP()
	GOTO 350

C	'WRITE' STATEMENT.

340	L= INDEX (STMENT,'WRITE')
	IF (L .EQ. 0) GOTO 350
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 370
	JFL= INDEX (STMENT,'''(')	! F77 LITERAL FORMAT.
	IF (JFL .NE. 0) GOTO 350
	LL= 5
	CALL NREAD()

C	THIS TAKES CARE OF ANY 'ERR' CODES IN ANY OF THE STATEMENTS INCLUDING
C	THE 'CLOSE', 'OPEN' STATEMENTS.

350	L= INDEX (STMENT,'ERR')
	IF (L .EQ. 0) GOTO 360
	IF  (KXP .NE. 0 .AND. KXP .LE. L) GOTO 360
	CALL NCLOSE()

C	CLEAR ANY TRAILING SPACES IN 'STMENT' AND WRITE IT TO THE NEW FILE.

360	IF (CCGTFL .EQ. 0) GOTO 370

	IF (STMENT(2:2) .EQ. ' ')  GOTO 370

	CALL NGOTO

370	CALL STMLEN(STMENT,SLEN)

	IF (SLEN .EQ. 0)  THEN

	WRITE(1,180)		! BLANK LINE (write just CR).

	ELSE

380	WRITE(1,180)  STMENT(1:SLEN)

	ENDIF

390	CONTINUE

	TYPE 100,  27,91,20,59,47,72,  KNL-1

	NL1= NL1+NLOOH

	NL2= NL2+NLOOH

400	CONTINUE

C	ALL DONE.

410	TYPE 100,  27,91,20,59,47,72,  KNL

	CALL ISLEEP(0,0,1,0)

	CALL CLRSCR

	CALL CENTER(TITLE4,24,80,IP,'S')

	CALL CURMOV(10,IP)

	TYPE 10, TITLE4

	CALL CENTER(TITLE5,28,80,IP,'S')

	CALL CURMOV(12,IP)

	TYPE 10, TITLE5

	CALL CENTER(TITLE6,37,80,IP,'S')

	CALL CURMOV(14,IP)

	TYPE '(1H+,2A///)',  TITLE6, OUTFIL

	CALL CURON

	CALL EXIT

	END