Trailing-Edge
-
PDP-10 Archives
-
decuslib20-07
-
decus/20-0169/lbld10.for
There is 1 other file named lbld10.for in the archive. Click here to see a list.
SUBROUTINE FILOPN(ISTORE,IDISK ,ITTY ,JTTY ,IWRITE,
1IFOPEN)
C RENBR(/USER SPECIFICATION OF DECSYSTEM10/20 FILE)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C This routine reads a file name typed by the user, and
C attempts to open the file. The routine does not ask
C the user for the file name. The routine reports to
C the calling program whether the file could be opened.
C If the file cannot be opened, then the calling
C program should ask the user to type the file name,
C then call this routine again.
C
C This version of this routine is written for the
C DECsystem10, or for the DECsystem20 using the TOPS10
C emulator. The file names which can be processed by
C this routine must consist of 1 to 6 letters or digits
C optionally followed by a period and then by up to 3
C letters or digits.
C
C
C ISTORE = number assigned by the main program to all
C of the files having a particular function.
C ISTORE identifies where in the FILSTR array
C the name of the file is stored so that it
C can be used by other routines.
C IDISK = number of the unit from which the file is to
C be read or to which the file is to be
C written. This is the number which appears
C first in the READ or WRITE statements.
C ITTY = number of the unit to which messages to be
C seen by the user are to be written.
C JTTY = number of the unit from which the file names
C typed by the user on the terminal are to be
C read.
C IWRITE = determines whether file is opened to be read
C or to be written.
C = 0, open the file for reading.
C = 1, open the file for writing.
C IFOPEN = returned describing whether the file could
C be opened. The input value is ignored.
C = -1, returned if the file could not be
C opened. The calling program should issue
C the prompt again and then call this program
C again.
C = 0, returned if the user did not specify a
C file name. The user just pressed the RETURN
C key.
C = 1, returned if the file was opened
C successfully.
C
COMMON/FILSTR/FILSTR(6)
DOUBLE PRECISION FILNAM,FILSTR
DIMENSION LTRFIL(20),LTRABC(26),LWRABC(26),LTRDGT(10)
C
C LMTFIL = DIMENSION OF LTRFIL ARRAY. MAXIMUM NUMBER OF
C CHARACTERS, INCLUDING SPACES AND TABS, WHICH
C CAN BE TYPED BY USER IN A FILE NAME.
C
DATA LMTFIL/20/
C
C LTRSPA = THE SPACE CHARACTER
C LTRTAB = THE TAB CHARACTER. SET TO SPACE IF THE
C COMPUTER SYSTEM DOES NOT HAVE TAB CHARACTER
C LTRDOT = THE PERIOD CHARACTER
C LTRABC = UPPER CASE ALPHABETIC LETTERS A THROUGH Z
C LWRABC = LOWER CASE ALPHABETIC LETTERS A THROUGH Z
C LTRDGT = DIGITS ZERO THROUGH NINE
C
DATA LTRSPA/1H /
DATA LTRTAB/"045004020100/
DATA LTRDOT/1H./
DATA LTRABC /1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,
2 1HX,1HY,1HZ/
DATA LWRABC /1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
1 1Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,1Hu,1Hv,1Hw,
2 1Hx,1Hy,1Hz/
DATA LTRDGT /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C READ FILE NAME
READ(JTTY,1,END=18)LTRFIL
1 FORMAT(20A1)
C
C REMOVE NON-PRINTING CHARACTERS FROM FILE NAME
MAXFIL=0
DO 2 I=1,LMTFIL
IF(LTRFIL(I).EQ.LTRSPA)GO TO 2
IF(LTRFIL(I).EQ.LTRTAB)GO TO 2
MAXFIL=MAXFIL+1
IF(MAXFIL.EQ.I)GO TO 2
LTRFIL(MAXFIL)=LTRFIL(I)
LTRFIL(I)=LTRSPA
2 CONTINUE
IF(MAXFIL.LE.0)GO TO 21
C
C CHECK FOR ILLEGAL CHARACTER IN FILE NAME
LOCDOT=0
DO 6 I=1,MAXFIL
LTRNOW=LTRFIL(I)
IF(LTRNOW.EQ.LTRDOT)GO TO 5
DO 3 J=1,26
IF(LTRNOW.EQ.LTRABC(J))GO TO 6
IF(LTRNOW.EQ.LWRABC(J))GO TO 6
3 CONTINUE
DO 4 J=1,10
IF(LTRNOW.EQ.LTRDGT(J))GO TO 6
4 CONTINUE
GO TO 16
5 IF(LOCDOT.GT.0)GO TO 16
LOCDOT=I
6 CONTINUE
C
C CHECK LOCATION OF DOT
IF(LOCDOT.GT.0)GO TO 7
IF(MAXFIL.GT.6)GO TO 16
GO TO 8
7 IF(LOCDOT.EQ.1)GO TO 16
IF(LOCDOT.GT.7)GO TO 16
IF((MAXFIL-LOCDOT).GT.3)GO TO 16
8 CONTINUE
C
C CONVERT FROM A1 TO A10 FORM
IF(LOCDOT.GT.0)GO TO 10
ENCODE(10,9,FILNAM)(LTRFIL(I),I=1,6)
9 FORMAT(6A1,4H. )
GO TO 12
10 ENCODE(10,11,FILNAM)(LTRFIL(I),I=1,10)
11 FORMAT(10A1)
C
C OPEN FILE FOR OUTPUT, CREATING NEW FILE
12 IF(IWRITE.EQ.0)GO TO 13
OPEN(UNIT=IDISK,FILE=FILNAM,ACCESS='SEQOUT',ERR=14)
GO TO 22
C
C OPEN FILE FOR INPUT, READING OLD FILE
13 OPEN(UNIT=IDISK,FILE=FILNAM,ACCESS='SEQIN',ERR=14)
GO TO 22
C
C ERROR MESSAGES
14 WRITE(ITTY,15)
15 FORMAT(' File cannot be opened'/1X)
GO TO 20
16 WRITE(ITTY,17)
17 FORMAT(
1' File name must be 1 to 6 letters or digits, optionally'/
2' followed by a period and then 0 to 3 letters or digits.')
GO TO 20
C
C CONTROL-Z TYPED ON TERMINAL
18 CLOSE(UNIT=JTTY)
WRITE(ITTY,19)
19 FORMAT(
11X/' END-OF-FILE read from terminal but file name expected'/1X)
C
C RETURN TO CALLING PROGRAM
20 IFOPEN=-1
GO TO 23
21 IFOPEN=0
GO TO 23
22 IFOPEN=1
IF(ISTORE.LE.0)GO TO 23
FILSTR(ISTORE)=FILNAM
23 RETURN
END
SUBROUTINE FILNXT(ISTORE,IDISK,ITTY,KNTFIL,IPRGRM)
C RENBR(/OPEN NEXT UNUSED FILE IN SEQUENCE LABELS.NNN)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C Too many labels might be produced by the LABELS
C program to fit into a single output file. The files
C are given names based upon a serial number which is
C increased each time that this routine is called.
C This routine opens the next output file to which
C these labels are to be written. The routine checks
C to see if the file already exists. If it does not
C exist, then it is used for producing the new labels.
C If it already exists, then the next serial number is
C tried instead.
C
C This version of this routine is written for the
C DECsystem10, or for the DECsystem20 using the TOPS10
C emulator. The file names produced by this routine
C have the form LABELS.nnn where nnn represents a 3
C digit serial number ranging from 001 through 999.
C
C
C ISTORE = number assigned by the main program to all
C of the files having a particular function.
C This has no relationship to the KNTFIL
C argument, which counts the number of files
C having names based upon a particular naming
C scheme. ISTORE identifies where in the
C FILSTR array the name of the file is to be
C stored so that it can be used by other
C routines.
C IDISK = number of the unit to which the file is to
C be written. This is the number which
C appears first in the WRITE statements.
C ITTY = number of the unit to which messages to be
C seen by the user are to be written.
C KNTFIL = serial number of the previous file which was
C written by the current run of the program.
C This is the number used to construct the
C name of the previous file in the sequence.
C = 0, input if this is the first time that this
C routine has been called.
C = returned containing the serial number of the
C new file.
C = 0, returned if no file could be opened.
C IPRGRM = identifies which program called this routine
C and which stem is used for file names
C = 1, called by LABELS program.
C = 2, called by ENVELO program.
C
COMMON/FILSTR/FILSTR(6)
DOUBLE PRECISION FILNAM,FILSTR,FILNOW,FILSTM(2)
DATA FILSTM/'LABELS ','ENVELO '/
C
C CONSTRUCT NEXT NAME IN SEQUENCE
FILNOW=FILSTM(IPRGRM)
1 KNTFIL=KNTFIL+1
IF(KNTFIL.GE.1000)GO TO 10
IF(KNTFIL.GE.100)GO TO 5
IF(KNTFIL.GE.10)GO TO 3
IF(KNTFIL.LE.0)KNTFIL=1
ENCODE(10,2,FILNAM)FILNOW,KNTFIL
2 FORMAT(1A6,'.00',1I1)
GO TO 7
3 ENCODE(10,4,FILNAM)FILNOW,KNTFIL
4 FORMAT(1A6,'.0',1I2)
GO TO 7
5 ENCODE(10,6,FILNAM)FILNOW,KNTFIL
6 FORMAT(1A6,'.',1I3)
7 OPEN(UNIT=IDISK,FILE=FILNAM,ACCESS='SEQIN',ERR=8)
CLOSE(UNIT=IDISK)
GOTO 1
C
C OPEN UNUSED NAME AS AN OUTPUT FILE
8 OPEN(UNIT=IDISK,ACCESS='SEQOUT',FILE=FILNAM,ERR=1)
WRITE(ITTY,9)KNTFIL,FILNAM
9 FORMAT(' Output file number',1I4,' is named ',1A10)
FILSTR(ISTORE)=FILNAM
GO TO 11
C
C ALL SEQUENCE NUMBERS 1 THROUGH 999 IN USE
10 KNTFIL=0
C
C RETURN TO CALLING PROGRAM
11 RETURN
END
SUBROUTINE FILOLD(ISTORE,IDISK ,ITTY ,IFOPEN)
C RENBR(/REOPEN FILE SPECIFIED BEFORE BY USER)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C This routine reopens an input file earlier specified
C by the user. Each file which must be opened more
C than once is assigned a number when it is first
C opened. This routine uses that number to locate the
C file name in the storage of all of the file names.
C
C This version of this routine is written for the
C DECsystem10, or for the DECsystem20 using the TOPS10
C emulator.
C
C
C ISTORE = number assigned by the main program to all
C of the files having a particular function.
C ISTORE identifies where in the FILSTR array
C the name of the file is stored so that it
C can be used by other routines.
C IDISK = number of the unit from which the file is to
C be read. This is the number which appears
C first in the READ statements.
C ITTY = number of the unit to which messages to be
C seen by the user are to be written.
C IFOPEN = returned describing whether the file could
C be opened. The input value is ignored.
C = -1, returned if the file could not be
C opened.
C = 1, returned if the file was opened
C successfully.
C
COMMON/FILSTR/FILSTR(6)
DOUBLE PRECISION FILNAM,FILSTR
C
C GET FILE NAME
FILNAM=FILSTR(ISTORE)
C
C OPEN FILE FOR INPUT
OPEN(UNIT=IDISK,FILE=FILNAM,ACCESS='SEQIN',ERR=1)
GO TO 4
C
C ERROR MESSAGES
1 WRITE(ITTY,2)
2 FORMAT(' File cannot be reopened'/1X)
GO TO 3
C
C RETURN TO CALLING PROGRAM
3 IFOPEN=-1
GO TO 5
4 IFOPEN=1
5 RETURN
END
SUBROUTINE FILCUT(ISTORE,IDISK)
C RENBR(/INSURE THAT LABELS SO FAR ARE IN OUTPUT FILE)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C This routine insures that the labels written to the
C output file will actually be found in the file even
C if the program is terminated abnormally while
C processing a subsequent input file. The calls to
C this routine can be removed without hurting the
C functionality of the program. The routine is not
C necessary if the program which calls it terminates
C normally.
C
C This version of this routine is written for the
C DECsystem10, or for the DECsystem20 using the TOPS10
C emulator. The routine closes the file so that any
C labels which might be in the output buffer are
C written to the file, then reopens the file in append
C mode so that any additional labels which might be
C written to the file are appended to the end, rather
C than replacing those just written.
C
C
C ISTORE = number assigned to the file by the main
C program when it called either the FILOPN or
C FILNXT routine to open the file. This
C number identifies where in the FILSTR array
C the name of the file is to be found when
C needed.
C IDISK = number of the unit to which the file is
C being written. This is the number which
C appears first in the WRITE statements.
C
COMMON/FILSTR/FILSTR(6)
DOUBLE PRECISION FILNAM,FILSTR
C
C GET THE NAME OF THE LABEL FILE
FILNAM=FILSTR(ISTORE)
C
C CLOSE THE FILE TO WRITE OUT LABELS IN BUFFER
CLOSE(UNIT=IDISK)
C
C REOPEN FILE IN APPEND MODE SO CAN ADD TO IT
OPEN(UNIT=IDISK,FILE=FILNAM,ACCESS='APPEND')
RETURN
END
SUBROUTINE FILEND(ISTORE,IDISK)
C RENBR(/CLOSE OUTPUT FILE)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C This routine closes the output file indicated by
C ISTORE. This routine is not really necessary. The
C call to this routine can be replaced by just a CLOSE
C statement.
C
C This version of this routine is written for the
C DECsystem10, or for the DECsystem20 using the TOPS10
C emulator.
C
C
C ISTORE = number assigned to the file by the main
C program when it called either the FILOPN or
C FILNXT routine to open the file. This
C number identifies where in the FILSTR array
C the name of the file is to be found when
C needed.
C IDISK = number of the unit to which the file is
C being written. This is the number which
C appears first in the WRITE statements.
C
COMMON/FILSTR/FILSTR(6)
DOUBLE PRECISION FILNAM,FILSTR
C
C GET THE NAME OF THE LABEL FILE
FILNAM=FILSTR(ISTORE)
C
C CLOSE THE FILE
CLOSE(UNIT=IDISK)
RETURN
END
SUBROUTINE TTYEOF(JTTY)
C RENBR(/CLEAR END-OF-FILE READ FROM TERMINAL)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C This routine allows the program to accept more text
C typed by the user after an end-of-file or control-Z
C has been typed. Without this, under some
C DECsystem-10 operating systems, the program would go
C into an infinite loop after reading the end-of-file
C with a READ statement having an END= test, since the
C end-of-file would be not be cleared and would be
C sensed each time the program attempted to read the
C next line typed by the user.
C
C
C JTTY = number of the unit from which the text typed
C by the user is read.
C
CLOSE(UNIT=JTTY)
RETURN
END
SUBROUTINE TSTOPS(LTRLIN,IFINAL,JFINAL,LTROUT,MAXPRT)
C RENBR(/CONVERT MULTIPLE SPACES TO TAB CHARACTERS)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C *****************************************************
C * THIS ROUTINE MUST BE CHANGED FOR OTHER COMPUTERS. *
C * THIS VERSION IS FOR THE DECSYSTEM10 COMPUTER *
C * OR FOR THE DECSYSTEM20 WITH TOPS10 EMULATOR. *
C *****************************************************
C
C This routine converts the spaces between columns of
C labels to tab characters so that the labels require
C less disk space to store and so that the labels can
C be typed faster on slow transmission lines. The tab
C character is a single ASCII character which causes
C the next character after it to be printed in the next
C column to the right of the next integral multiple of
C 8 columns.
C
C The program which calls this routine will still
C perform correctly if this routine is changed to
C merely copy all of the characters input in LTRLIN(1)
C through LTRLIN(IFINAL) into the LTROUT array, and
C return MAXPRT set to the value of IFINAL.
C
C
C LTRLIN = array input containing the characters in a
C single line across all of the parallel rows
C of labels before conversion of multiple
C spaces to tabs. The blank space between the
C printing characters consists of space
C characters, one per printing column
C position.
C IFINAL = total number of characters which are in the
C input array counting each space as a
C separate character.
C JFINAL = maximum number of characters which can be in
C the line after conversion of multiple spaces
C to tabs. Dimension of the LTROUT array.
C LTROUT = array returned containing the characters in
C a single line across all of the parallel
C rows of labels after conversion of multiple
C spaces to tabs.
C MAXPRT = returned specifying the position in the
C LTROUT array of the rightmost printing
C character.
C
C
DIMENSION LTRLIN(IFINAL),LTROUT(JFINAL)
C
C LTRSPA = the space character
C LTRTAB = the tab character, causes next character to
C appear to the right of the next integral
C multiple of 8 columns. LTRTAB is defined in
C octal notation since the editor used at Yale
C converts tab characters in a file being
C edited to spaces directly.
C
DATA LTRSPA,LTRTAB/1H ,"045004020100/
C
C MLTTAB = the tab stop interval.
DATA MLTTAB/8/
C
NXTTAB=0
JUSED=0
MAXPRT=0
IF(IFINAL.LE.0)GO TO 6
KOLUMN=1
1 IF(JUSED.GE.JFINAL)GO TO 7
IF(KOLUMN.GT.NXTTAB)NXTTAB=NXTTAB+MLTTAB
IF(LTRLIN(KOLUMN).NE.LTRSPA)GO TO 4
IF(NXTTAB.GT.IFINAL)GO TO 3
DO 2 ITEST=KOLUMN,NXTTAB
IF(LTRLIN(ITEST).NE.LTRSPA)GO TO 3
2 CONTINUE
JUSED=JUSED+1
LTROUT(JUSED)=LTRTAB
KOLUMN=NXTTAB
GO TO 5
3 JUSED=JUSED+1
LTROUT(JUSED)=LTRLIN(KOLUMN)
GO TO 5
4 JUSED=JUSED+1
LTROUT(JUSED)=LTRLIN(KOLUMN)
MAXPRT=JUSED
5 KOLUMN=KOLUMN+1
IF(KOLUMN.LE.IFINAL)GO TO 1
GO TO 7
6 MAXPRT=1
LTROUT(1)=LTRSPA
7 RETURN
END