Trailing-Edge
-
PDP-10 Archives
-
decuslib20-08
-
decus/20-0175/jobsrt.for
There is 1 other file named jobsrt.for in the archive. Click here to see a list.
C RENBR(JOBSRT/SORT LIST OF STUDENT NAME)/R)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C THIS PROGRAM IS PART OF THE JOB INTERVIEW REQUEST SYSTEM
C
C THIS PROGRAM SORTS THE LIST OF STUDENTS WHO HAVE REQUESTED
C JOB INTERVIEWS ALPHABETICALLY BY THE STUDENT'S NAME
C
C A RIGHTMOST ABBREVIATION OR WORD APPEARING TO RIGHT
C OF A COMMA IS IGNORED FOR PURPOSES OF SORTING.
C
C THE ENTIRE LIST OF STUDENT NAMES AND NUMBERS IS READ
C INTO CORE, SORTED AND WRITTEN OUT. THE ARRAYS ARE
C DIMENSIONED LARGE ENOUGH TO SORT 400 STUDENT NAMES.
C
DIMENSION LTRNAM(400,30),LTRABC(26),LTRSUF(10),LNGSUF(5),
1LWRABC(26),LTRDGT(10),LOCBGN(400),LNGNAM(400),LTRNUM(400,6),
2LTRPRE(2),LNGPRE(1),LTRPAS(400,20),LTRBFR(60)
C
C LMTNUM = NUMBER OF CHARACTERS IN NUMERIC FIELDS
C LMTPAS = LENGTH OF SINGLE PASSWORD
C LMTLNG = LENGTH OF SINGLE NAME
C LMTNAM = MAXIMUM NUMBER OF NAMES
DATA LMTNUM,LMTPAS,LMTLNG,LMTNAM/6,20,30,400/
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 PREFIXES TO BE CONSIDERED PART OF THE LAST NAME
C LTRPRE = LETTERS IN PREFIXES
C LNGPRE = LENGTHS OF PREFIXES
C KNTPRE = NUMBER OF PREFIXES
DATA LTRPRE/
11HD,1HU/
DATA LNGPRE/2/
DATA KNTPRE/1/
C
C SUFFIXES TO BE DISCARDED FOR PURPOSES SORTING
C LTRSUF = LETTERS IN SUFFIXES
C LNGSUF = LENGTHS OF SUFFIXES
C KNTSUF = NUMBER OF SUFFIXES
DATA LTRSUF/
11HI,
21HI,1HI,
31HI,1HI,1HI,
41HI,1HV,
51HJ,1HR/
DATA LNGSUF/1,2,3,2,2/
DATA KNTSUF/5/
C
C VARIOUS OTHER CHARACTERS
C LTRSPA = THE SPACE CHARACTER
C LTRUPA = THE UP ARROW OR CIRCUMFLEX
C LTRUND = THE LEFT ARROW OR UNDERSCORE
C LTRAST = THE ASTERISK
C LTRDOT = THE PERIOD
C LTRCOM = THE COMMA
DATA LTRSPA,LTRDOT,LTRCOM/
1 1H ,1H.,1H,/
C
C UNIT NUMBERS
DATA ITTY,IDISK,JDISK,KDISK,LDISK/5,1,20,21,22/
C
C TELL USER WHAT PROGRAM THIS IS
WRITE(ITTY,1)
1 FORMAT(' JOBSRT'/
1' Sorts list of student who have requested job interviews'/1X)
C
C OPEN INPUT FILE
CALL LCLOPN( 7,1,1,ITTY,IDISK,JDISK,KDISK,LDISK)
C
C STORE TOP TITLE LINE
READ(IDISK,2)LTRBFR
2 FORMAT(60A1)
C
C READ STUDENT NUMBERS AND NAMES
KNTNAM=0
3 KNTNAM=KNTNAM+1
IF(KNTNAM.GT.LMTNAM)GO TO 70
4 READ(IDISK,5,END=26)(LTRNUM(KNTNAM,I),I=1,LMTNUM),
1(LTRNAM(KNTNAM,I),I=1,LMTLNG),(LTRPAS(KNTNAM,I),I=1,LMTPAS)
5 FORMAT(1X,6A1,1X,30A1,20A1)
C
C REJECT ANY LINE WITHOUT NUMBERS IN PROPER COLUMNS
DO 7 I=1,LMTNUM
LTRNOW=LTRNUM(KNTNAM,I)
IF(LTRNOW.EQ.LTRSPA)GO TO 7
DO 6 J=1,10
IF(LTRNOW.EQ.LTRDGT(J))GO TO 7
6 CONTINUE
GO TO 4
7 CONTINUE
C
C LOOK FOR RIGHTMOST PRINTING CHARACTER, OR RIGHTMOST TO COMMA
MAXBFR=0
IFANY=0
DO 9 I=1,LMTLNG
LTRNOW=LTRNAM(KNTNAM,I)
IF(LTRNOW.EQ.LTRSPA)GO TO 9
IF(LTRNOW.EQ.LTRCOM)IFANY=1
IF(IFANY.EQ.0)MAXBFR=I
DO 8 J=1,26
IF(LTRNOW.NE.LWRABC(J))GO TO 8
LTRNAM(KNTNAM,I)=LTRABC(J)
GO TO 9
8 CONTINUE
9 CONTINUE
C
C EXCLUDE VARIOUS RIGHTMOST SUFFIXES
IF(MAXBFR.LE.0)GO TO 17
IF(KNTSUF.LE.0)GO TO 14
MAXRJT=0
DO 12 NOWRJT=1,KNTSUF
MINRJT=MAXRJT+1
MAXRJT=MAXRJT+LNGSUF(NOWRJT)
NEWRJT=MAXBFR-LNGSUF(NOWRJT)
IF(NEWRJT.LE.0)GO TO 12
IF(LTRNAM(KNTNAM,NEWRJT).NE.LTRSPA)GO TO 12
DO 10 KMPRJT=MINRJT,MAXRJT
NEWRJT=NEWRJT+1
IF(LTRNAM(KNTNAM,NEWRJT).NE.LTRSUF(KMPRJT))GO TO 12
10 CONTINUE
MAXBFR=MAXBFR-LNGSUF(NOWRJT)
11 IF(LTRNAM(KNTNAM,MAXBFR).NE.LTRSPA)GO TO 13
MAXBFR=MAXBFR-1
IF(MAXBFR.GT.0)GO TO 11
GO TO 17
12 CONTINUE
13 CONTINUE
C
C EXCLUDE ANY RIGHTMOST ABBREVIATION ENDING IN PERIOD
14 IF(MAXBFR.LE.0)GO TO 17
IF(LTRNAM(KNTNAM,MAXBFR).NE.LTRDOT)GO TO 19
15 MAXBFR=MAXBFR-1
IF(MAXBFR.LE.0)GO TO 17
IF(LTRNAM(KNTNAM,MAXBFR).NE.LTRSPA)GO TO 15
16 MAXBFR=MAXBFR-1
IF(MAXBFR.LE.0)GO TO 17
IF(LTRNAM(KNTNAM,MAXBFR).EQ.LTRSPA)GO TO 16
GO TO 19
17 WRITE(ITTY,18)(LTRNUM(KNTNAM,I),I=1,LMTNUM),
1(LTRNAM(KNTNAM,I),I=1,LMTLNG),(LTRPAS(KNTNAM,I),I=1,LMTPAS)
18 FORMAT(' Following line has been rejected'/
11X,6A1,1X,30A1,20A1)
GO TO 4
C
C LOOK FOR LEFTMOST PRINTING CHARACTER IN LAST NAME
19 MINBFR=MAXBFR
20 IF(MINBFR.LE.0)GO TO 21
IF(LTRNAM(KNTNAM,MINBFR).EQ.LTRSPA)GO TO 21
MINBFR=MINBFR-1
GO TO 20
21 MINBFR=MINBFR+1
C
C STORE THE STARTING POINT AND LENGTH OF LAST NAME
LOCBGN(KNTNAM)=MINBFR
LNGNAM(KNTNAM)=MAXBFR
C
C EXCLUDE VARIOUS RIGHTMOST PREFIXES
IF(KNTPRE.LE.0)GO TO 25
NOWBFR=MINBFR
22 NOWBFR=NOWBFR-1
IF(NOWBFR.LE.0)GO TO 25
IF(LTRNAM(KNTNAM,NOWBFR).EQ.LTRSPA)GO TO 22
MAXRJT=0
DO 24 NOWRJT=1,KNTPRE
MINRJT=MAXRJT+1
MAXRJT=MAXRJT+LNGPRE(NOWRJT)
NEWRJT=NOWBFR-LNGPRE(NOWRJT)
IF(NEWRJT.LE.0)GO TO 24
IF(LTRNAM(KNTNAM,NEWRJT).NE.LTRSPA)GO TO 24
DO 23 KMPRJT=MINRJT,MAXRJT
NEWRJT=NEWRJT+1
IF(LTRNAM(KNTNAM,NEWRJT).NE.LTRPRE(KMPRJT))GO TO 24
23 CONTINUE
NOWBFR=NOWBFR-LNGPRE(NOWRJT)
LOCBGN(KNTNAM)=NOWBFR
GO TO 25
24 CONTINUE
25 GO TO 3
C
C REPORT THE NUMBER OF NAMES ENCOUNTERED
26 CALL LCLCLS( 7,1,1,ITTY,IDISK,JDISK,KDISK,LDISK)
KNTNAM=KNTNAM-1
IF(KNTNAM.LE.0)GO TO 68
WRITE(ITTY,27)KNTNAM
27 FORMAT(' Number of names:',1I5)
C
C OPEN OUTPUT FILE
CALL LCLOPN(11,1,3,ITTY,IDISK,JDISK,KDISK,LDISK)
C
C WRITE TOP TITLE LINE
WRITE(KDISK,28)LTRBFR
28 FORMAT(60A1/1X)
C
C PREPARE FOR SORT LOOP
C IFANY = 0 IF NO WORD WAS DISPLAYED ON PREVIOUS LINE
C JFANY = 0 IF NO MINIMUM HAS BEEN FOUND SINCE PREVIOUS LINE
C LSTNAM = LOCATION OF NAME DISPLAYED ON PREVIOUS LINE
C NXTNAM = LOCATION OF MINIMUM FOUND SINCE PREVIOUS LINE
C
IFANY=0
DO 67 IOUTER=1,KNTNAM
JFANY=0
DO 65 INNER=1,KNTNAM
C
C TEST IF NEW WORD IS GREATER THAN OLD WORD
C TRANSFER TO )65 IF NEW NAME HAS ALREADY BEEN PRINTED
C TRANSFER TO )46 IF NEW NAME SORTS AFTER PREVIOUS NAME
C SO CAN TEST IF IT IS EARLIER THAN THE
C NEXT ONE WE HAVE READY TO BE PRINTED
IF(IFANY.EQ.0)GO TO 46
JTEST=LOCBGN(LSTNAM)
KTEST=LOCBGN(INNER)
29 IF(JTEST.GT.LNGNAM(LSTNAM))GO TO 35
IF(KTEST.GT.LNGNAM(INNER))GO TO 35
30 LTRNOW=LTRNAM(LSTNAM,JTEST)
DO 31 I=1,26
IF(LTRNOW.NE.LTRABC(I))GO TO 31
JVALUE=I
GO TO 32
31 CONTINUE
JTEST=JTEST+1
IF(JTEST.LE.LNGNAM(LSTNAM))GO TO 30
32 LTRNOW=LTRNAM(INNER,KTEST)
DO 33 I=1,26
IF(LTRNOW.NE.LTRABC(I))GO TO 33
KVALUE=I
GO TO 34
33 CONTINUE
KTEST=KTEST+1
IF(KTEST.LE.LNGNAM(INNER))GO TO 32
34 IF(JTEST.GT.LNGNAM(LSTNAM))GO TO 35
IF(KTEST.GT.LNGNAM(INNER))GO TO 35
IF(JVALUE.GT.KVALUE)GO TO 65
IF(JVALUE.LT.KVALUE)GO TO 46
JTEST=JTEST+1
KTEST=KTEST+1
GO TO 29
35 IF(KTEST.GT.LNGNAM(INNER))GO TO 36
IF(JTEST.GT.LNGNAM(LSTNAM))GO TO 46
GO TO 65
36 IF(JTEST.LE.LNGNAM(LSTNAM))GO TO 65
C
C IF LAST NAMES MATCH, USE THE FIRST NAMES FOR SORT
JTEST=1
KTEST=1
JBLANK=1
KBLANK=1
37 IF(JTEST.GE.LOCBGN(LSTNAM))GO TO 43
IF(KTEST.GE.LOCBGN(INNER))GO TO 43
38 LTRNOW=LTRNAM(LSTNAM,JTEST)
DO 39 J=1,26
IF(LTRNOW.NE.LTRABC(J))GO TO 39
JVALUE=J
GO TO 40
39 CONTINUE
JBLANK=1
JTEST=JTEST+1
IF(JTEST.LT.LOCBGN(LSTNAM))GO TO 38
40 LTRNOW=LTRNAM(INNER,KTEST)
DO 41 J=1,26
IF(LTRNOW.NE.LTRABC(J))GO TO 41
KVALUE=J
GO TO 42
41 CONTINUE
KBLANK=1
KTEST=KTEST+1
IF(KTEST.LT.LOCBGN(INNER))GO TO 40
42 CONTINUE
43 IF(JTEST.GE.LOCBGN(LSTNAM))GO TO 45
IF(KTEST.GE.LOCBGN(INNER))GO TO 65
IF(JBLANK.EQ.KBLANK)GO TO 44
IF(JBLANK.NE.0)GO TO 46
GO TO 65
44 IF(JVALUE.GT.KVALUE)GO TO 65
IF(JVALUE.LT.KVALUE)GO TO 46
JTEST=JTEST+1
KTEST=KTEST+1
JBLANK=0
KBLANK=0
GO TO 37
45 IF(KTEST.LT.LOCBGN(INNER))GO TO 46
C
C NAMES ARE EXACTLY THE SAME AS FAR AS WE CAN TELL
IF(LSTNAM.GE.INNER)GO TO 65
C
C TEST IF NEW WORD IS LESS THAN CURRENTLY FOUND MINIMUM
C TRANSFER TO )65 IF NEW NAME SORTS AFTER THE NAME WHICH
C WE HAVE FOUND AS BEING THE NEXT TO PRINT
C TRANSFER TO )64 IF NEW NAME SORTS BEFORE THE NAME WHICH
C WE HAVE FOUND AS BEING THE NEXT TO PRINT
46 IF(JFANY.EQ.0)GO TO 64
JTEST=LOCBGN(NXTNAM)
KTEST=LOCBGN(INNER)
47 IF(JTEST.GT.LNGNAM(NXTNAM))GO TO 53
IF(KTEST.GT.LNGNAM(INNER))GO TO 53
48 LTRNOW=LTRNAM(NXTNAM,JTEST)
DO 49 I=1,26
IF(LTRNOW.NE.LTRABC(I))GO TO 49
JVALUE=I
GO TO 50
49 CONTINUE
JTEST=JTEST+1
IF(JTEST.LE.LNGNAM(NXTNAM))GO TO 48
50 LTRNOW=LTRNAM(INNER,KTEST)
DO 51 I=1,26
IF(LTRNOW.NE.LTRABC(I))GO TO 51
KVALUE=I
GO TO 52
51 CONTINUE
KTEST=KTEST+1
IF(KTEST.LE.LNGNAM(INNER))GO TO 50
52 IF(JTEST.GT.LNGNAM(NXTNAM))GO TO 53
IF(KTEST.GT.LNGNAM(INNER))GO TO 53
IF(JVALUE.LT.KVALUE)GO TO 65
IF(JVALUE.GT.KVALUE)GO TO 64
JTEST=JTEST+1
KTEST=KTEST+1
GO TO 47
53 IF(JTEST.GT.LNGNAM(NXTNAM))GO TO 54
IF(KTEST.GT.LNGNAM(INNER))GO TO 64
GO TO 65
54 IF(KTEST.LE.LNGNAM(INNER))GO TO 65
C
C IF LAST NAMES MATCH, USE THE FIRST NAMES FOR SORT
JTEST=1
KTEST=1
JBLANK=1
KBLANK=1
55 IF(JTEST.GE.LOCBGN(NXTNAM))GO TO 61
IF(KTEST.GE.LOCBGN(INNER))GO TO 61
56 LTRNOW=LTRNAM(NXTNAM,JTEST)
DO 57 J=1,26
IF(LTRNOW.NE.LTRABC(J))GO TO 57
JVALUE=J
GO TO 58
57 CONTINUE
JBLANK=1
JTEST=JTEST+1
IF(JTEST.LT.LOCBGN(NXTNAM))GO TO 56
58 LTRNOW=LTRNAM(INNER,KTEST)
DO 59 J=1,26
IF(LTRNOW.NE.LTRABC(J))GO TO 59
KVALUE=J
GO TO 60
59 CONTINUE
KBLANK=1
KTEST=KTEST+1
IF(KTEST.LT.LOCBGN(INNER))GO TO 58
60 CONTINUE
61 IF(KTEST.GE.LOCBGN(INNER))GO TO 63
IF(JTEST.GE.LOCBGN(NXTNAM))GO TO 65
IF(JBLANK.EQ.KBLANK)GO TO 62
IF(KBLANK.NE.0)GO TO 64
GO TO 65
62 IF(JVALUE.LT.KVALUE)GO TO 65
IF(JVALUE.GT.KVALUE)GO TO 64
JTEST=JTEST+1
KTEST=KTEST+1
JBLANK=0
KBLANK=0
GO TO 55
63 IF(JTEST.LT.LOCBGN(NXTNAM))GO TO 64
C
C NAMES ARE EXACTLY THE SAME AS FAR AS WE CAN TELL
C TEST IS ALWAYS TRUE IF REACH HERE
IF(NXTNAM.LE.INNER)GO TO 65
C
C STORE THE NEW MINIMUM
64 JFANY=1
NXTNAM=INNER
65 CONTINUE
C
C WRITE THE LOWEST NAME NOT YET WRITTEN
IFANY=1
LSTNAM=NXTNAM
WRITE(KDISK,66)(LTRNUM(NXTNAM,I),I=1,LMTNUM),
1(LTRNAM(NXTNAM,I),I=1,LMTLNG),(LTRPAS(NXTNAM,I),I=1,LMTPAS)
66 FORMAT(1X,6A1,1X,30A1,20A1)
67 CONTINUE
CALL LCLCLS(11,1,3,ITTY,IDISK,JDISK,KDISK,LDISK)
GO TO 72
C
C ERROR MESSAGES
68 WRITE(ITTY,69)
69 FORMAT(' Input file is empty')
GO TO 72
70 WRITE(ITTY,71)LMTNAM
71 FORMAT(' More than',1I6,' names in input file.'/
1' Increase size of arrays and value of LMTNAM and run again.')
GO TO 72
72 STOP
END