Retro1.org codex

DPRT
* /---   FILE TYPE = E
* /---   BLOCK      DEFINES    00 000   80/01/25  00.46 
*      OVERLAY(DPRINT,0,0)
      PROGRAM DPRINT(INPUT,OUTPUT)
C 
C 
C     PRINT TUTOR STUDENT DATA
C 
C 
      IMPLICIT INTEGER (A-Z)
C 
      COMMON /GETLINE/ PRTDEN,INFO(3),LINE(64),BLOCK,NXT,END
C 
      COMMON /OUTPUT/ OUTBUF(11),LTH,TERMX(2),TIME,DATE 
C 
      COMMON /DISK/ DISKF1,DISKF2,BUFF(320) 
C 
      REAL V
C 
      EQUIVALENCE (PDEN,PRTDEN) 
      EQUIVALENCE (FILE,INFO(1))
      EQUIVALENCE (BLOCKS,INFO(2))
      EQUIVALENCE (TBLKS,INFO(3)) 
C 
      EQUIVALENCE (NAME,LINE(2))
      EQUIVALENCE (NAME1,LINE(3)) 
      EQUIVALENCE (LESSON,LINE(4))
      EQUIVALENCE (AREA,LINE(5))
C 
      DIMENSION STATE(12) 
      DIMENSION ETYPE(14) 
      DIMENSION MESS1(4)
      DIMENSION MESS2(2)
C 
* /---   BLOCK      STARTUP    00 000   80/02/01  00.46 
C 
1     ETYPE(1)=10LUNKNOWN ER
      ETYPE(2)=10LROR 
      ETYPE(3)=10LILLEGAL CO
      ETYPE(4)=10LMMAND 
      ETYPE(5)=10LMISSING UN
      ETYPE(6)=10LIT
      ETYPE(7)=10LTIME SLICE
      ETYPE(8)=10L EXCEEDED 
      ETYPE(9)=10LTUTOR OUTF
      ETYPE(10)=10LOW 
      ETYPE(11)=10LSTATION OU 
      ETYPE(12)=10LTFLOW
      ETYPE(13)=10LILL ACTION 
      ETYPE(14)=10LREQUEST
C 
      STATE(1)=10LREG PRE-AR
      STATE(2)=10LROW 
      STATE(3)=10LREG POST-A
      STATE(4)=10LRROW
      STATE(5)=10LJUDGING 
      STATE(6)=10L
      STATE(7)=10LREG POST-J
      STATE(8)=10LUDGE
      STATE(9)=10LSEARCH
      STATE(10)=10L 
      STATE(11)=10LUNKNOWN ST 
      STATE(12)=10LATE
C 
      MESS1(1)=10LCONTINUATI
      MESS1(2)=10LON OF PREV
      MESS1(3)=10LIOUS SESSI
      MESS1(4)=10LON
C 
C    GET CM/ECS/TIME/DATE/NAME OF FILE
C 
      CALL SETUP
C 
C 
C     'IF PDEN = 0, SET HIGH DENSITY
C 
      IF (PDEN.EQ.0) PRINT 1007 
C 
C    PAGE EJECT 
7     PRINT 1000
C 
C     PRINT DAYFILE PRINT INFO IF ANY 
C 
      IF (LINE(1).EQ.0) GOTO 8
      CALL IBFILLB(LINE(1),20)
      PRINT 1008,(LINE(I),I=1,4)
      PRINT 1008,(LINE(I),I=5,8)
      PRINT 1008,(LINE(I),I=9,12) 
      PRINT 1008,(LINE(I),I=13,16)
      PRINT 1008,(LINE(I),I=17,20)
      PRINT 1009
      PRINT 1010
8     DO 9 I = 1,20 
9     LINE(I) = 0 
      CALL FILL (10L**********) 
      PRINT 1001,(OUTBUF(I),I=1,11) 
      CALL ATTACH (FILE)
      CALL IBFILL(FILE,TIME,DATE) 
      PRINT 1002,FILE,TIME,DATE 
      CALL DISKIN (0) 
      TBLKS=BUFF(3) 
C  NUMBER OF BLOCKS IN USE
      BLOCKS = BUFF(4).AND.(77777B) 
C  PRINT FILE INFORMATION 
      CALL IBFILLB(BUFF(9),10)
      PRINT 1005,(BUFF(J),J=9,13) 
      PRINT 1006,(BUFF(J),J=14,18)
      PRINT 1001,(OUTBUF(I),I=1,11) 
111   CALL ISTLIN 
      IF (END.NE.0)GOTO 90
C 
* /---   BLOCK      MAIN LOOP  00 000   78/07/02  17.11 
C 
C 
C     MAIN LOOP - PROCESS NEXT DATA RECORD
C 
10    CALL GETLINE
      IF(END.NE.0)GOTO 90 
      TYPE=LINE(1).AND.77B
      LTH=(ISHR(LINE(1),6)).AND.77B 
      IF(TYPE.EQ.0)GOTO 90
      IF(TYPE.GT.13)GOTO 10 
C      IF(TYPE-9)X,X,10 
      GOTO(100,200,300,400,500,600,700,800,900,550,560,10,1300)TYPE 
C 
C 
C 
C     -OUTPUT- COMMAND DATA 
C 
100   II=ISHL(((ISHL(LINE(1),30)).AND.777777B),7) 
      V=II/60000.0
      CALL IBFILL(NAME,NAME1,LESSON,AREA) 
      PRINT 2100,V,NAME,NAME1,LESSON,AREA 
      CALL OUTFORM
      CALL IBFILLB(OUTBUF,11) 
      PRINT 2110,(OUTBUF(I),I=1,11) 
      GOTO 10 
C 
2100  FORMAT (3X,*OUTPUT*,4X,F5.1,4X,A10,A8,3X,A10,2X,
     *        *AREA *,A10)
2110  FORMAT (22X,11A10,/)
C 
C 
C 
C     STUDENT RESPONSE
C 
200   II=ISHL(((ISHL(LINE(1),18)).AND.777777B),7) 
      V=II/60000.0
      ARR=(ISHL(LINE(1),33)).AND.777B 
      N1=0
      N2=0
      IF((ISHL(LINE(1),36)).GE.0)GOTO 210 
      N1=10LUNRECOGNIZ
      N2=10LED WORD 
      GOTO 220
C 
210   IF(((ISHL(LINE(1),24)).AND.77B).NE.3)GOTO 220 
      N1=10HUNRECOGNIZ
      N2=7HED -NO-
C 
220   CALL IBFILL(NAME,NAME1,LESSON,AREA,LINE(6),N1,N2) 
      PRINT 2200,V,NAME,NAME1,LESSON,AREA,LINE(6),ARR,
     *      N1,N2 
      CALL ANSFORM
      CALL IBFILLB(OUTBUF(1),11)
      PRINT 2210,(OUTBUF(I),I=1,11) 
      GOTO 10 
C 
2200  FORMAT (3X,*RESPONSE  *,F5.1,4X,A10,A8,3X,A10,
     *        2X,*AREA *,A10,2X,*UNIT *,A8,3X,*ARROW*,I3, 
     *        10X,2A10) 
2210  FORMAT (22X,11A10,/)
C 
* /---   BLOCK      AREA/TERM  00 000   77/11/12  01.38 
C 
C 
C     -AREA- COMMAND DATA 
C 
300   II=ISHL(((ISHL(LINE(1),18)).AND.777777B),7) 
      V=II/60000.0
      IF((ISHL(LINE(8),18)).GE.0)GOTO 310 
      N6=8HCOMPLETE 
      GOTO 320
C 
310   N6=10HINCOMPLETE
C 
320   CALL IBFILL(NAME,NAME1,LESSON,AREA,N6)
      PRINT 2300,V,NAME,NAME1,LESSON,AREA 
      N1=ISHL(((ISHL(LINE(8),18)).AND.777777B),7) 
      V=N1/60000.0
      N1=LINE(6).AND.777B 
      N2=(ISHR(LINE(7),9)).AND.777B 
      N3=(ISHR(LINE(7),18)).AND.777B
      PRINT 2310,V,N1,N2,N3 
      N1=(ISHR(LINE(6),36)).AND.777B
      N2=(ISHR(LINE(6),27)).AND.777B
      N3=LINE(7).AND.777B 
      N4=(ISHR(LINE(7),27)).AND.777B
      PRINT 2320,N1,N2,N3,N4
      N1=(ISHR(LINE(6),18)).AND.777B
      N2=(ISHR(LINE(6),9)).AND.777B 
      PRINT 2330,N1,N2
      IF((ISHL(LINE(8),19)).GE.0)GOTO 330 
      PRINT 2340,N6,MESS1(1),MESS1(2),MESS1(3),MESS1(4) 
      GOTO 10 
330   PRINT 2345,N6 
      GOTO 10 
C 
2300  FORMAT (3X,*AREA*,6X,F5.1,4X,A10,A8,3X,A10,2X,
     *        *AREA *,A10)
2310  FORMAT (22X,*ELAPSED *,F5.1,8X,*ARROWS  *,I4,5X,
     *        *ANSWERS OK*,I4,5X,*OK IST TRY*,I4) 
2320  FORMAT (22X,*TERMS OK*,I4,9X,*TERMS NO*,I4,5X,
     *        *ANSWERS NO*,I4,5X,*UNRECOG NO*,I4) 
2330  FORMAT (22X,*HELPS OK*,I4,9X,*HELPS NO*,I4) 
C 
2340  FORMAT (22X,A10,2X,4A10,/)
C 
2345  FORMAT (22X,A10,/)
C 
C 
C 
C     TERM KEY DATA 
C 
400   II=ISHL(((ISHL(LINE(1),18)).AND.777777B),7) 
      V=II/60000.0
      CALL IBFILL(NAME,NAME1,LESSON,AREA) 
      PRINT 2400,V,NAME,NAME1,LESSON,AREA 
      TERM=LINE(6).AND.77777777777777770000B
      TERM1=(LINE(6).AND.1)+1 
      TERM1=TERMX(TERM1)
      CALL IBFILL(TERM,TERM1) 
      PRINT 2410,TERM,TERM1 
      GOTO 10 
C 
2400  FORMAT (3X,*TERM*,6X,F5.1,4X,A10,A8,3X,A10,2X,
     *        *AREA *,A10)
2410  FORMAT (22X,A8,13X,A10,/) 
C 
* /---   BLOCK      SIGN/OUTL  00 000   76/08/21  12.06 
C 
C 
C     STUDENT SIGN-ON 
C 
500   II=LINE(1).AND.77777 77777 00000 00000B 
      CALL IBFILL(NAME,NAME1,LESSON,LINE(5),II) 
      PRINT 2500,NAME,NAME1,LESSON,LINE(5),II 
      GOTO 10 
C 
2500  FORMAT (3X,*SIGNIN*,13X,A10,A8,3X,A10,
     *        1X,A10,6X,A5,/) 
C 
C 
C 
C 
C     STUDENT SIGN-OFF
C 
550   II=LINE(1).AND.77777 77777 00000 00000B 
      V=LINE(6)/60000.0 
      CALL IBFILL(NAME,NAME1,LESSON,LINE(5),II) 
      PRINT 2550,NAME,NAME1,LESSON,LINE(5),II,V 
      GOTO 10 
C 
2550  FORMAT (3X,*DATAOFF*,12X,A10,A8,3X,A10, 
     *        1X,A10,6X,A5,6X,F5.1,/) 
C 
C 
C 
C     STUDENT SIGNOFF (2) 
C 
560   II=LINE(1).AND.77777 77777 00000 00000B 
      CALL IBFILL(NAME,NAME1,LESSON,LINE(5),II) 
      PRINT 2560,NAME,NAME1,LESSON,LINE(5),II 
      N3=LINE(6).AND.77777 77777B 
      IF(LINE(6).GE.0)GOTO 561
      N1=10HNOT COMPLE
      N2=3HTED
      PRINT 2561,N3,N1,N2 
      GOTO 570
C 
561   N1=10HCOMPLETION
      N2=5H TIME
      N4=(ISHL(LINE(6),30)).AND.77777 77777B
      PRINT 2562,N3,N1,N2,N4
570   GOTO 10 
C 
2560  FORMAT (3X,*SIGNOFF*,12X,A10,A8,3X,A10, 
     *        1X,A10,6X,A5,6X)
2561  FORMAT (22X,*ELAPSED TIME*,3X,I4,6X,A10,A10,/)
2562  FORMAT (22X,*ELAPSED TIME*,3X,I4,6X,A10,A10,
     *        3X,I4,/)
C 
C 
C 
C     -HELP- KEY DATA 
C 
600   II=ISHL(((ISHL(LINE(1),18)).AND.777777B),7) 
      V=II/60000.0
      CALL IBFILL(NAME,NAME1,LESSON,AREA,LINE(6)) 
      PRINT 2600,V,NAME,NAME1,LESSON,AREA,LINE(6) 
      N1=LINE(8).AND.(-777777B) 
      N2=LINE(7).AND.(-7777B) 
      IF(N2.NE.0)GOTO 610 
      N2=7LNO UNIT
C 
610   CALL IBFILL(N1,N2)
      PRINT 2610,N1,N2
      GOTO 10 
C 
2600  FORMAT (3X,*HELP*,6X,F5.1,4X,A10,A8,3X,A10, 
     *        2X,*AREA *,A10,2X,*UNIT *,A8) 
2610  FORMAT (22X,A7,3X,A8,/) 
C 
C 
C 
C     -OUTPUTL- COMMAND DATA
C 
700   II=ISHL(((ISHL(LINE(1),18)).AND.777777B),7) 
      V=II/60000.0
      CALL IBFILL(NAME,NAME1,LESSON,AREA,LINE(6)) 
      PRINT 2700,V,NAME,NAME1,LESSON,AREA,LINE(6) 
      II=LTH-6
      IF(II.LE.0)GOTO 715 
C 
      DO 710 I=1,II 
      N1=LINE(6+I)
      CALL VFORM (N1,V) 
      N2=N1 
      CALL IBFILL(N2) 
      PRINT 2710,N2,N1,N1,V 
C 
710   CONTINUE
715   PRINT 1004
      GOTO 10 
C 
2700  FORMAT (3X,*OUTPUT-L  *,F5.1,4X,A10,A8,3X,A10,
     *        2X,*AREA *,A10,2X,*LABEL *,A10) 
2710  FORMAT (22X,A10,2X,I10,3X,O20,3X,F10.4) 
C 
* /---   BLOCK      EXEC ERR   00 000   76/08/21  11.56 
C 
C 
C     EXECUTION ERROR DATA
C 
800   CALL IBFILL(NAME,NAME1,LESSON,LINE(6))
      PRINT 2800,NAME,NAME1,LESSON,LINE(6)
      NERROR=(ISHL(LINE(1),6)).AND.77B
      IF(NERROR.LE.0)GOTO 805 
      IF(NERROR.LE.6)GOTO 810 
C 
805   N1=ETYPE(1) 
      N2=ETYPE(2) 
      GOTO 812
C 
810   II=2*NERROR+1 
      N1=ETYPE(II)
      N2=ETYPE(II+1)
C 
812   N3=(ISHL(LINE(1),21)).AND.777B
      II=(ISHL(LINE(1),12)).AND.77B 
      IF(II.LE.4)GOTO 820 
      II=5
C 
820   II=2*II+1 
      N4=STATE(II)
      N5=STATE(II+1)
      CALL IBFILL(N1,N2,LINE(7),LINE(8),N4,N5)
      PRINT 2810,N1,N2,LINE(7),LINE(8),N3,N4,N5 
      N1=(ISHL(LINE(1),30)).AND.77B 
      IF(N1.LE.0)GOTO 870 
      N2=LINE(9).AND.(-7777B) 
      N3=LINE(9).AND.777B 
      CALL IBFILL(N2) 
      PRINT 2820,N2,N3
      IF(N1.LE.1)GOTO 870 
C 
      DO 850 II=2,N1
      N2=LINE(8+II).AND.(-7777B)
      N3=LINE(8+II).AND.777B
      CALL IBFILL(N2) 
      PRINT 2830,N2,N3
850   CONTINUE
C 
870   PRINT 1004
      GOTO 10 
C 
2800  FORMAT (3X,*EXECUTION ERROR*,4X,A10,A8,3X,A10,
     *        2X,*UNIT *,A8)
2810  FORMAT (22X,A10,A10,1X,A8,4X,A10,2X,*LINE *,I3, 
     *        3X,2A10)
2820  FORMAT (22X,*JOIN SEQUENCE   *,A8,3X,*LINE *,I3)
2830  FORMAT (38X,A8,3X,*LINE *,I3) 
C 
C 
C 
C     UNLABLED -OUTPUTL- DATA 
C 
900   PRINT 2900
      II=LTH-1
      IF(II.LE.0)GOTO 915 
C 
      DO 910 I=1,II 
      N1=LINE(1+I)
      CALL VFORM (N1,V) 
      N2=N1 
      CALL IBFILL(N2) 
      PRINT 2910,N2,N1,N1,V 
C 
910   CONTINUE
915   PRINT 1004
      GOTO 10 
C 
2900  FORMAT (3X,*OUTPUT-L*,11X,*NO OUTPUT LABEL*)
2910  FORMAT (22X,A10,2X,I10,3X,O20,3X,F10.4) 
* /---   BLOCK      OUTPUTT    00 000   77/07/05  13.44 
C 
C 
C     -OUTPUTT- COMMAND DATA
C 
C         LINE(5) IS THE INFO TYPE (LABEL) LIMITED TO 
C         7 CHARS MAX SPACE FILLED. 
C 
C         THERE IS A NAME AND LESSON BUT NO AREA. 
C 
C         LINE(6)-LINE(N) IS DISPLAYED IN -TEXT- FORMAT.
C 
1300  CALL IBFILL(LINE(5),NAME,NAME1,LESSON)
      PRINT 3300,LINE(5),NAME,NAME1,LESSON
      STARTL=6
1310  IF (STARTL.GT.LTH) GOTO 1390
      CALL FINDEOL(STARTL,ENDL) 
      LINELTH=ENDL-STARTL+1 
      TENDL=ENDL
      IF (LINELTH.GT.10) TENDL=STARTL+11
      CALL IBFILL(LINE(TENDL))
      IF (LINELTH.GT.1) CALL IBFILL(LINE(TENDL-1))
      PRINT 3310,(LINE(J),J=STARTL,TENDL) 
      STARTL=ENDL+1 
      GOTO 1310 
* 
1390  PRINT 1004
      GOTO 10 
* 
* 
3300  FORMAT(3X,A7,12X,A10,A8,3X,A10) 
3310  FORMAT(22X,10A10) 
* /---   BLOCK      END        00 000   80/02/01  00.46 
C 
C 
90    PRINT 1003
C 
C    DETACH FILE AND RELEASE ALL ECS
C 
99    CALL DETACH 
      CALL RELECS 
      STOP
C 
1000  FORMAT (1H1)
1001  FORMAT (3X,11A10,//)
1002  FORMAT (3X,*DATA FILE *,A10,5X,*PRINTED AT*,A10,
     *        * ON*,A10,//) 
1003  FORMAT (//,3X,*+++++ END OF DATA +++++*)
1004  FORMAT (/)
1005  FORMAT (3X,5A10)
1006  FORMAT (3X,5A10,//) 
1007  FORMAT (1HT)
1008  FORMAT (44X,4A10,1H*) 
1009  FORMAT (44X,41(1H*))
1010  FORMAT (//) 
C 
      END 
* /---   BLOCK      ITOA       00 000   76/08/21  12.01 
      SUBROUTINE ITOA (IIN,IOUT)
C 
C 
C     INTEGER TO ALPHA CONVERSION 
C 
C 
1     IF(IIN.EQ.0)GOTO 50 
      ENCODE (10,100,IOUT)IIN 
C 
10    IF(((ISHL(IOUT,6)).AND.77B).NE.55B)GOTO 90
      IOUT=(ISHL(IOUT,6)).AND.(-77B)
      GOTO 10 
C 
50    IOUT=1H0
C 
90    RETURN
C 
100   FORMAT (I10)
C 
      END 
      SUBROUTINE FTOA (IIN,IOUT)
C 
C 
C     FLOATING POINT TO ALPHA CONVERSION
C 
C 
1     IF(IIN.EQ.0)GOTO 50 
      ENCODE (10,100,IOUT)IIN 
      I=0 
C 
10    IF(((ISHR(IOUT,(I*6))).AND.77B).NE.1R0)GOTO 20
      IOUT=IOUT.AND.(ISHL((-77B),(I*6)))
      I=I+1 
      IF(I.LT.3)GOTO 10 
C 
20    IF(((ISHL(IOUT,6)).AND.77B).NE.55B)GOTO 90
      IOUT=(ISHL(IOUT,6)).AND.(-77B)
      GOTO 20 
C 
50    IOUT=3H0.0
C 
90    RETURN
C 
100   FORMAT (F10.4)
C 
      END 
* /---   BLOCK      SHIFTS     00 000   76/08/13  14.55 
          IDENT  SHIFTS 
* 
*         FUNCTIONS FOR LEFT AND RIGHT SHIFTS.
*         CALLABLE FROM FTN.
* 
*         LAWRENCE A. WHITE 
*         AUGUST 11, 1976 
* 
          ENTRY  ISHL 
 ISHL     EQ     *+400000B
          SA2    X1          VALUE TO BE SHIFTED
          SA1    A1+1 
          SA3    X1          AMOUNT TO SHIFT IT 
          SB2    X3 
          LX6    X2,B2
          EQ     ISHL 
* 
          ENTRY  ISHR 
 ISHR     EQ     *+400000B
          SA2    X1 
          SA1    A1+1 
          SA3    X1 
          SB2    X3 
          AX6    X2,B2
          EQ     ISHR 
* 
* 
          END 
* /---   BLOCK      SETUP      00 000   80/05/17  19.42 
          IDENT  SETUP
          TITLE  -SETUP-
          LIST   X
*CALL      DPRTX
*CALL      SYSCON 
          LIST   *
          SST 
          SYSCOM
* 
          TITLE  LOAD TIME INITIALIZATIONS
* 
*         -SETUP- 
* 
          ENTRY  SETUP
          EXT    REQECS,GETARG,ECSPRTY
 
 SETUP    EQ     *
 
 
*         WRITE ACCOUNT, COURSE, NAME OF PRINT REQUESTOR
*         TO ACCOUNT FILE 
 
          MESSAGE CCDR,5,RECALL 
 
 
          RJ     GETARG      GET THE FILE NAME
          SA6    FILE        AND, SAVE
 
 IFCDC    IFEQ   CDC,0
 IFCDC    IFEQ   CDC,0
          RJ     GETARG      GET SECOND CONTROL CARD ARG
          SA1    =4LHIGH     SEE IF IT IS '7HIGH'7
          IX6    X1-X6
 IFCDC    ELSE
          MX6    59 
          ENDIF 
 IFCDC    ELSE
          MX6    59 
          ENDIF 
          SA6    PDEN        STORE FOR FTN PROGRAM
 
          SA1    65B         NEXT AVAILABLE CM
          SX6    X1+100B     ROUND UP BY 100B 
          MX0    -6 
          BX6    X0*X6
          LX6    30 
          SA6    CMFL        SET CM FIELD LENGTH
          MEMORY CM,CMFL,RECALL 
          SX6    ECSLTH      SET ECS FIELD LENGTH 
          SA6    ECFL 
          CALL   REQECS,ECFL   REQUEST ECS
          CLOCK  TIME 
          DATE   DATE 
* /---   BLOCK      SETUP      00 000   80/02/01  00.46 
* 
* LOOK FOR PRINT INFO IN DAYFILE.  PASS TO FTN IN 1ST 20 WDS
* OF *LINE* BUFFER.  LINE(1) = 0 IF NOT THERE.  USES *BUFF* 
* AS TEMP. STORAGE
* 
          CONTROL  BUFF,1    GET CARD FOLLOWING DPRINT CARD 
          SA1    BUFF 
          SA2    =10L***** MAIL   HEADER FOR MAILING INFO 
          MX6    0           PRESET NOT THERE 
          SA6    LINE 
          IX1    X1-X2       SEE IF INFO IS THERE 
          NZ     X1,SETUP    --- BRANCH IF NOT
          MX0    0           ECS XFER ADDRESS 
          SX7    A0 
          SA7    SAVEA0      SAVE FOR FTN 
          SX5    A6          INITIAL CM TRANSFER ADDRESS
 PRINFO   CONTROL  BUFF      GET A LINE OF INFO (8 WDS MAX) 
          SA0    BUFF        ONLY THE 1ST 4 WORDS ARE USED
          WE     4           MOVE IT WHERE IT BELONGS 
          RJ     ECSPRTY
          SA0    X5          X5,A0,X0 SAVED OVER SYS CALLS
          RE     4
          RJ     ECSPRTY
          SX5    X5+4        ADDRESS OF NEXT LOCATION 
          SB1    LINE+20     CANNOT DO  SB1 X5-LINE-20
          SB2    X5          CUZ LOADER NO ALLOW
          LT     B2,B1,PRINFO   --- IF NOT DONE YET 
          SA1    SAVEA0      RESTORE A0 
          SA0    X1 
          EQ     SETUP
* 
 CMFL     BSS    1
 ECFL     BSS    1
 SAVEA0   BSS    1
* 
          END 
* /---   BLOCK      GETLINE    00 000   76/10/16  00.27 
          IDENT  GETLINE
          TITLE  READ DATA FILE 
* 
*CALL      DPRTX
* 
          EXT    DISKIN 
* 
          TITLE  -GETLINE-   GET NEXT DATA RECORD 
* 
* 
*         -GETLINE- 
*         READS NEXT DATA RECORD TO *LINE*
* 
* 
          ENTRY  GETLINE
 GETLINE  EQ     *
          SA1    NXT
          SB1    X1          B1 = POINTER TO NEXT WORD
          RJ     ISTWORD
          BX6    X1          STORE HEADER WORD
          SA6    LINE 
          MX0    -6          MASK FOR RECORD LENGTH 
          AX1    6
          BX1    -X0*X1      MASK OFF RECORD LENGTH 
          ZR     X1,ENDFIL
          SB2    1           INDEX IN *LINE*
          SB3    X1          END TEST 
* 
 GETLP    GE     B2,B3,ENDLIN 
          RJ     NXTWORD     GET NEXT WORD OF DATA
          BX6    X1 
          SA6    B2+LINE     MOVE TO *LINE* BUFFER
          SB2    B2+1 
          SB4    B2-64
          NG     B4,GETLP 
          EQ     ENDFIL 
* 
 ENDLIN   SX6    B1 
          SA6    NXT         UPDATE WORD POINTER
          EQ     GETLINE
* 
* 
* 
*         -NXTWORD- 
*         GET NEXT WORD OF DATA RECORD
* 
* 
 NXTWORD  EQ     *
          SX1    B1-BLKLTH   SEE IF AT END OF BUFFER
          PL     X1,NXTW1 
          SA1    B1+BUFF     LOAD NEXT WORD 
          SB1    B1+1        ADVANCE POINTER
          EQ     NXTWORD
* 
 NXTW1    RJ     NXTBLOK     GET NEXT BLOCK 
          EQ     NXTWORD
* 
* 
* /---   BLOCK      GETLINE    00 000   77/01/20  16.30 
* 
*         -ISTWORD- 
*         GET FIRST WORD OF DATA RECORD 
* 
 ISTWORD  EQ     *
          RJ     NXTWORD     GET NEXT WORD
          NZ     X1,ISTWORD 
          RJ     NXTBLOK     GET NEXT BLOCK 
          EQ     ISTWORD
* 
* 
 NXTBLOK  EQ     *
          SX6    B2          SAVE REGISTERS 
          SA6    SAV1 
          SX6    B3 
          SA6    SAV2 
          SA1    BLOCK       BLOCK CURRENTLY ON 
          SX7    X1+1 
          SA7    A1          UPDATE BLOCK COUNT 
          SA2    BLOCKS      NUM FULL BLOCKS IN FILE
          IX2    X1-X2
          PL     X2,ENDFIL   JUMP IF END OF FULL BLOCKS 
          SA2    TBLKS       NUM OF TOTAL BLOCKS IN FILE
          IX2    X7-X2
          PL     X2,ENDFIL   JUMP IF END-OF-FILE
 
          SX1    BLOCK       BLOCK NUMBER FOR -DISKIN-
          CALL   DISKIN 
          SB1    1           RESET WORD POINTER 
          SA1    SAV1 
          SB2    X1          RESTORE B2 
          SA1    SAV2 
          SB3    X1          RESTORE B3 
          SA1    BUFF        LOAD NEXT WORD 
          EQ     NXTBLOK
* 
 ENDFIL   MX6    -1          SET END-OF-FILE FLAG 
          SA6    END
          MX6    0
          SA6    LINE        CLEAR HEADER WORD
          EQ     GETLINE
* 
* 
          TITLE  -ISTLIN-    INITIALIZATIONS
* 
* 
*         -ISTLIN-
*         INITIALIZE FOR -GETLINE-
* 
* 
          ENTRY  ISTLIN 
 ISTLIN   EQ     *
          SX6    1           INITIALIZE BLOCK COUNTER 
          SA6    BLOCK
          SA1    BLOCKS 
          NG     X1,ISTEND
          ZR     X1,ISTEND
          MX6    0
          SA6    END         INITIALIZE END-OF-FILE FLAG
          SA6    NXT         INITIALIZE WORD POINTER
          SX1    BLOCK       BLOCK NUMBER FOR -DISKIN-
          CALL   DISKIN 
          EQ     ISTLIN 
* 
 ISTEND   MX6    -1          MARK END-OF-FILE 
          SA6    END
          EQ     ISTLIN 
* 
* 
* 
 SAV1     BSS    1
 SAV2     BSS    1
* 
* 
          END 
* /---   BLOCK      DISKIN     00 000   80/02/01  00.46 
          IDENT  DISKIN 
          TITLE  -DISKIN- 
* 
*CALL      DPRTX
* 
          EXT    REQECS,OPF,CPF,READPF
* 
          TITLE  ATTACH FILE
* 
* 
*         -ATTACH-
*         ATTACH SPECIFIED FILE 
* 
*         ON ENTRY - X1 = ADDRESS OF FILE NAME
* 
* 
          ENTRY  ATTACH 
 ATTACH   EQ     *
          SA2    X1          GET FILE NAME
          BX6    X2 
          SA6    PFILE
          CALL   OPF,PFILE,READAC 
          NZ     X1,ATTERR   ERROR CHECK
          EQ     ATTACH 
* 
 PFILE    DATA   0           PLATO FILE NAME
          DATA   0           EOL
* 
 ATTERR   MESSAGE ATTMES,0,RECALL 
          MESSAGE PFILE,0,RECALL
          CALL   RELECS      RELEASE ALL ECS
          CALL   DETACH 
          ABORT 
 
* 
          TITLE  DETACH PLATO FILE
* 
* 
*         -DETACH-
*         DETACH SPECIFIED FILE 
* 
* 
          ENTRY  DETACH,ECSPRTY 
 DETACH   EQ     *
          CALL   CPF,PFILE
          EQ     DETACH 
* 
* 
          TITLE  READ BLOCK FROM PLATO DISK FILE
* 
* 
*         -DISKIN-
*         READS SPECIFIED BLOCK FROM DISK AND TRANSFERS 
*         IT TO THE CM BUFFER *BUFF*
* 
*         ON ENTRY -  X1 = ADDRESS OF BLOCK NUMBER
* 
* 
          ENTRY  DISKIN 
 DISKIN   EQ     *
          CALL   READPF,PFILE,X1,DISKBUF
          NZ     X1,DISKERR  ERROR CHECK
* 
          SX6    A0          SAVE A0 FOR FTN
          SA6    A0SAVE 
 
          SX0    DISKBUF     ADDRESS OF ECS BUFFER
          SA0    BUFF 
+         RE     BLKLTH      BRING BLOCK TO CM
          RJ     ECSPRTY
          SA1    A0SAVE      RESTORE A0 
          SA0    X1 
          EQ     DISKIN 
* 
 DISKERR  MESSAGE DISKMES,,RECALL 
          MX6    0
          SA6    BUFF        SET END-OF-FILE
          SA6    BUFF+1 
          EQ     DISKIN      EXIT 
* 
 ECSPRTY  MESSAGE ECSMES,,RECALL
          CALL   RELECS      RELEASE ALL ECS
          CALL   DETACH      DETACH PLATO FILE
          ABORT 
* 
* 
 ATTMES   DIS    ,*ATTACH ERROR*
 DISKMES  DIS    ,$**** DISK ERROR ****$
 ECSMES   DIS    ,$**** ECS ERROR ****$ 
* 
 A0SAVE   DATA   0           FOR SAVING A0 FOR FTN
 IECS     VFD    60/DISKBUF 
 READAC   DATA   4LREAD      OPEN FILE WITH READ ACCESS 
* 
* 
* OPL      XTEXT  COMCSYS 
* 
          END 
* /---   BLOCK      ANSFORM    00 000   76/10/16  00.27 
          IDENT  FORMAT 
          TITLE  OUTPUT FORMATTING
* 
*CALL      DPRTX
* 
* 
          TITLE  -ANSFORM-
* 
* 
*         -ANSFORM- 
*         FORMAT STUDENT RESPONSE AND JUDGEMENT 
* 
* 
          ENTRY  ANSFORM
 ANSFORM  EQ     *
          SX1    =1H         BLANK FILL *OUTBUF*
          CALL   FILL 
          SA1    LTH
          SB2    X1-6        LENGTH OF STUDENT RESPONSE 
          SB1    B2-10
          NG     B1,ANSF1    JUMP IF ANSWER NOT TOO LONG
          SB2    10 
* 
 ANSF1    SB1    B0          INITIALIZE INDEX 
* 
 AFLP     GE     B1,B2,ANSF2
          SA1    B1+LINE+6   LOAD NEXT WORD OF ANSWER 
          BX6    X1 
          SA6    B1+OUTBUF   MOVE TO OUTPUT BUFFER
          SB1    B1+1 
          EQ     AFLP 
* 
 ANSF2    MX0    -4*6        4 CHARACTER MASK 
          SA2    BLANK4 
          NZ     B1,ANSF3    CHECK FOR ZERO LTH ANSWER
          SB1    1
          EQ     ANSF4
* 
 ANSF3    SA1    B1+OUTBUF-1
          BX1    -X0*X1      MASK OFF BOTTOM 4 CHARS
          ZR     X1,ANSF4 
          BX0    X1-X2       SEE IF BLANK 
          ZR     X0,ANSF4 
          SB1    B1+1        ADVANCE TO NEXT WORD 
* 
* /---   BLOCK      ANSFORM    00 000   74/03/20  14.42 
* 
 ANSF4    MX7    -6 
          SA1    LINE        LOAD HEADER WORD 
          LX1    18+6        POSITION JUDGEMENT TYPE
          BX1    -X7*X1 
          SA3    X1+JMENT-1  LOAD JUDGEMENT HOLLERITH 
          MX7    6
          SA1    B1+OUTBUF-1 LOAD LAST WORD 
          SA2    =1L
          SB2    60-24       INITIALIZE SHIFT COUNT 
* 
 AFLP1    BX0    X7*X1       MASK OFF NEXT CHARACTER
          ZR     X0,ANSF5 
          BX0    X0-X2       SEE IF BLANK 
          ZR     X0,ANSF5 
          SB2    B2-6 
          LX7    60-6        RE-POSITION MASK 
          LX2    60-6        RE-POSITION BLANK
          EQ     AFLP1
* 
 ANSF5    MX7    -4*6        MASK FOR 4 CHARACTERS
          LX7    X7,B2       POSITION MASK
          BX7    X7*X1
          LX3    X3,B2       POSITION JUDGEMENT 
          BX7    X3+X7
          SA7    A1          STORE WITH JUDGEMENT ATTACHED
          EQ     ANSFORM
* 
* 
 JMENT    VFD    36/0,24/4L OK
+         VFD    36/0,24/4L NO
+         VFD    36/0,24/4L NO
* 
 BLANK4   VFD    36/0,24/4L 
* 
* 
* /---   BLOCK      OUTFORM    00 000   76/08/21  13.19 
          TITLE  -OUTFORM-
* 
* 
*         -OUTFORM- 
*         FORMAT -OUTPUT- COMMAND DATA
* 
* 
          ENTRY  OUTFORM
 OUTFORM  EQ     *
          SX1    =1H         BLANK FILL *OUTBUF*
          CALL   FILL 
          MX0    -6 
          SA1    LINE        LOAD HEADER WORD 
          LX1    6
          BX2    -X0*X1      MASK OFF NUMBER OF ENTRIES 
          ZR     X2,OUTFORM 
          LX1    6
          BX1    -X0*X1      MASK OFF LENGTH OF TABLE 
          SX6    X1+5        ADDRESS OF START OF DATA 
          SA6    IDAT 
          SX1    X2-21       CHECK NUMBER OF ENTRIES
          NG     X1,OUTF1 
          SX2    20          MAXIMUM OF 20 ENTRIES
* 
 OUTF1    SB3    X2          END TEST 
          MX0    -12         MASK FOR ONE TABLE ENTRY 
          SB1    B0          INITIALIZE INDEX 
          SB2    B0 
* 
 OFLP     SA1    B1+LINE+5   LOAD NEXT WORD OF TABLE
          SB1    B1+1 
          SB4    5           5 TABLE ENTRIES/WORD 
* 
 OFLP1    LX1    12          POSITION NEXT TABLE ENTRY
          BX6    -X0*X1 
          SA6    B2+ITABLE
          SB2    B2+1        ADVANCE TABLE INDEX
          GE     B2,B3,OUTF2
          SB4    B4-1        SEE IF AT END OF WORD
          NZ     B4,OFLP1 
          EQ     OFLP        GET NEXT WORD
* 
* /---   BLOCK      OUTFORM    00 000   74/03/20  14.43 
* 
 OUTF2    MX6    -1          SET TABLE END TEST 
          SA6    B2+ITABLE
          MX6    0
          SA6    TINDX       INITIALIZE INDEX IN TABLE
          SA6    IINDX       INITIALIZE CHARACTER INDEX 
* 
 OUTFLP   SA1    TINDX       CURRENT INDEX IN TABLE 
          SX6    X1+1 
          SA6    A1 
          MX0    -6 
          SA1    X1+ITABLE   LOAD CURRENT TABLE ENTRY 
          NG     X1,PACKUP
          BX2    -X0*X1      MASK OFF LENGTH OF DATA
          ZR     X2,OUTFLP
          AX1    6
          BX1    -X0*X1      MASK OFF DATA TYPE  (A,N,O,V)
          SB1    X1 
          JP     B1+*+1      JUMP BY DATA TYPE
* 
+         EQ     OFALPHA     ALPHA
+         EQ     OFINT       INTEGER
+         EQ     OFOCT       OCTAL
+         EQ     OFFLT       FLOATING 
* 
* 
*         FORMAT ALPHA DATA 
* 
 OFALPHA  SB1    X2          SAVE LENGTH OF DATA ENTRY
* 
 OFALP    SA1    IDAT        POINTER TO NEXT WORD OF DATA 
          SX6    X1+1 
          SA6    A1 
          SA1    X1+LINE     LOAD NEXT WORD OF DATA 
          ZR     X1,OFALP2
          MX0    6
* 
 OFALP1   BX2    X0*X1       MASK OFF NEXT CHARACTER
          NZ     X2,OFALP2
          LX1    6           LEFT JUSTIFY 
          EQ     OFALP1 
* 
* /---   BLOCK      OUTFORM    00 000   76/08/21  12.48 
* 
 OFALP2   CALL   OPEN 
          SB1    B1-1        END TEST 
          ZR     B1,OUTFLP
          NG     B1,OUTFLP
          EQ     OFALP
* 
* 
*         FORMAT INTEGER DATA 
* 
 OFINT    SA1    IDAT        POINTER TO NEXT WORD OF DATA 
          SX6    X1+1 
          SA6    A1 
          SX6    X1+LINE     SET UP FOR CALL
          SA6    ARGS 
          SX6    ITEMP
          SA6    A6+1 
          SA1    ARGS 
          CALL   ITOA        CONVERT TO ALPHA 
          SA1    ITEMP
          CALL   OPEN 
          EQ     OUTFLP 
* 
* 
*         FORMAT OCTAL DATA 
* 
 OFOCT    SA1    IDAT        POINTER TO NEXT WORD OF DATA 
          SX6    X1+1 
          SA6    A1 
          SB1    X1+LINE     SET UP FOR CALL
          SB2    ITEMP
          CALL   OTOA        CONVERT TO ALPHA 
          SA1    ITEMP
          CALL   OPEN 
          SA1    ITEMP1 
          CALL   OPEN 
          EQ     OUTFLP 
* 
* 
*         FORMAT FLOATING POINT DATA
* 
 OFFLT    SA1    IDAT        POINTER TO NEXT WORD OF DATA 
          SX6    X1+1 
          SA6    A1 
          SX6    X1+LINE     SET UP FOR CALL
          SA6    ARGS 
          SX6    ITEMP
          SA6    A6+1 
          SA1    ARGS 
          CALL   FTOA        CONVERT TO ALPHA 
          SA1    ITEMP
          CALL   OPEN 
          EQ     OUTFLP 
* 
* /---   BLOCK      OUTFORM    00 000   74/03/20  14.45 
* 
 PACKUP   SA1    IINDX       POINTER TO NEXT CHARACTER
          MX6    0
          SA6    X1+IOPEN    END TEST 
          SB1    B0 
          SB2    B0 
* 
 PACKLP   SB3    60-6        INITIALIZE SHIFT COUNT 
          MX6    0
* 
 PACKLP1  SA1    B1+IOPEN    LOAD NEXT CHARACTER
          ZR     X1,PACKED   JUMP IF END OF STRING
          SB1    B1+1 
          LX1    X1,B3
          BX6    X1+X6       MERGE WITH WORD BUILDING 
          SB3    B3-6 
          PL     B3,PACKLP1 
          SA6    B2+OUTBUF   STORE COMPLETED WORD 
          SB2    B2+1 
          EQ     PACKLP 
* 
 PACKED   SA6    B2+OUTBUF   STORE LAST WORD
          EQ     OUTFORM
* 
* 
* 
*         -OPEN-
*         OPEN NEXT WORD OF DATA (IN X1) TO *IOPEN* 
* 
* 
 OPEN     EQ     *
          MX0    -6 
          SA2    IINDX       CHARACTER POINTER IN *IOPEN* 
* 
 OPLP     LX1    6
          BX6    -X0*X1      (X6) = NEXT CHARACTER
          ZR     X6,OPN1     IF NULL CHARACTER
          SA6    X2+IOPEN 
          SX2    X2+1        INCREMENT INDEX
          SX6    X2-100 
          PL     X6,OPN2     IF BUFFER IS FULL
 
 OPN1     BX1    X0*X1       CLEAR CHARACTER
          NZ     X1,OPLP     IF MORE CHARACTERS 
          SX6    X2          UPDATE INDEX 
          SA6    IINDX
          EQ     OPEN 
 
 OPN2     SX6    X2-1        UPDATE INDEX 
          SA6    IINDX
          EQ     OPEN 
* 
* /---   BLOCK      OTOA       00 000   76/08/13  14.57 
          TITLE  OCTAL TO ALPHA CONVERSION
* 
* 
*         -OTOA-
*         OCTAL TO ALPHA CONVERSION 
* 
*         ON ENTRY -  B1 = ADDRESS OF WORD TO CONVERT 
*                     B2 = WHERE TO PUT 2 WORD OUTPUT 
* 
* 
          ENTRY  OTOA 
 OTOA     EQ     *
          MX0    -3 
          SA1    B1          LOAD WORD TO CONVERT 
          SB3    2           END TEST - OUTPUT 2 WORDS
* 
 OLP1     SB1    54          INITIALIZE SHIFT COUNT 
          MX6    0
* 
 OLP2     LX1    3           POSITION NEXT OCTAL PLACE
          BX2    -X0*X1 
          SX2    X2+1R0      CONVERT TO ALPHA 
          LX2    X2,B1
          BX6    X2+X6       MERGE WITH REST OF WORD
          SB1    B1-6 
          PL     B1,OLP2     JUMP IF WORD NOT DONE
* 
 OLP3     SA6    B2          STORE COMPLETED WORD 
          SB3    B3-1 
          ZR     B3,OTOA     END TEST 
          SB2    B2+1 
          EQ     OLP1 
* 
* 
          TITLE  -VFORM-
* 
* 
          ENTRY  VFORM
 VFORM    EQ     *
          SA2    X1 
          BX6    X2 
          SA1    A1+1 
          SA6    X1 
          EQ     VFORM
* 
* 
* /---   BLOCK      FILL       00 000   76/08/21  10.12 
          TITLE  -FILL-      FILL -OUTBUF-
* 
* 
*         -FILL-
*         ON ENTRY -  X1 = ADDRESS OF WORD TO FILL WITH 
* 
* 
          ENTRY  FILL 
 FILL     EQ     *
          SB2    10 
          SA2    X1          LOAD FILL WORD 
          BX6    X2 
* 
 FLP      SA6    B2+OUTBUF
          SB2    B2-1 
          PL     B2,FLP 
          EQ     FILL 
* 
* 
 ITEMP    BSS    2
 ITEMP1   EQU    ITEMP+1
* 
 IDAT     BSS    1
 IINDX    BSS    1
 TINDX    BSS    1
 ITABLE   BSS    20+1        ALLOW 20 DATA ENTRIES
 IOPEN    BSS    100+1       ALLOW 100 CHARACTERS 
 ARGS     BSS    2           ADDRESS OF 2 ARGUMENTS FOR A 
*                            FTN SUBROUTINE 
          DATA   0           END OF ARGS FLAG 
* 
* 
          END 
* /---   BLOCK      BLANKFILL  00 000   76/08/21  09.47 
          IDENT  BLFILL 
          TITLE  ZERO TO BLANK ROUTINE
* 
*         -IBFILL-
* 
*         BLANK FILL ALL ARGUMENTS
*         CALLABLE FROM FTN.    CALL IBFILL(I,J,K,L,M,N)
*         CONVERTS ALL 00B CHARS TO 55B 
* 
          ENTRY  IBFILL 
 IBFILL   EQ     *
          SB1    1
 FILLLP   ZR     X1,IBFILL   END OF ARGUMENTS CHECK 
          SA5    X1          GET ARGUMENT 
          RJ     BLFILL      BLANK FILL 
          SA6    X1          RE-STORE BLANK FILLED VERSION
          SA1    A1+1        GET ADDRESS OF NEXT ARGUMENT 
          EQ     FILLLP      GO FILL IT 
 
* 
*         -IBFILLB- 
* 
*         BLANK FILL A BUFFER (CALLABLE FROM FTN) 
* 
*         CALL IBFILLB(BUFFER,NWORDS) 
*         BLANK FILLS *BUFFER* THROUGH *BUFFER+NWORDS-1*
* 
          ENTRY  IBFILLB
 IBFILLB  EQ     *
          SB1    1
          SA5    X1          GET FIRST WORD OF BUFFER 
          SA1    A1+1        GET ADDRESS OF NUMBER WORDS
          SA1    X1          GET NUMBER WORDS 
 FILLBLP  RJ     BLFILL      BLANK FILL WORD
          SA6    A5          RE-STORE 
          SX1    X1-1        DECREMENT WORD COUNTER 
          ZR     X1,IBFILLB  ALL FILLED, ---RETURN
          SA5    A5+1        GET NEXT WORD
          EQ     FILLBLP
 
* 
*         ENTRY  X5 = 10 CHARACTER WORD 
*         EXIT   X6 = SAME THING WITH 6/55B IN PLACE OF 6/0.
* 
 BLFILL   PS
          SA2    =40404040404040404040B 
          BX3    -X5
          LX4    B1,X3
          BX3    X3*X4
          LX4    1
          BX3    X3*X4
          BX4    X3 
          LX4    3
          BX3    X3*X4
          BX3    X3*X2
          BX4    X3 
          LX4    -2 
          BX3    X3+X4
          BX4    X3 
          LX4    -3 
          BX3    X3+X4
          BX6    X5+X3
          EQ     BLFILL 
* 
          END 
* /---   BLOCK      FINDEOL    00 000   77/07/03  00.36 
          IDENT  FINDEOL
          TITLE  FIND END OF LINE 
* 
*CALL      DPRTX
* 
* 
          ENTRY  FINDEOL
* 
*         FIND END OF TEXT LINE 
*         (FTN CALLABLE)
*         ON ENTRY - A1 = ADDRESS OF ARGUMENT ADDRESSES 
*                1ST ARGUMENT = STARTING WORD NUMBER (INDEX 
*                              INTO ARRAY *LINE*) 
* 
*         ON EXIT - 2ND ARGUMENT = END WORD NUMBER (INDEX)
* 
 FINDEOL  PS
          MX0    -12         MASK FOR E-O-L TEST
          SB7    1           FOR INCREMENT
          SA2    X1          STARTING INDEX IN X1 
          SA2    X2+LINDEX-1
* 
 GLOOP    SA2    A2+B7       GET NEXT WORD
          BX2    -X0*X2      LOOK AT BOTTOM 12 BITS 
          NZ     X2,GLOOP    LOOK SOME MORE IF NON-ZERO 
* 
          SX6    A2 
          SX7    LINDEX 
          IX6    X6-X7       CONVERT TO FORTRAN INDEX 
          SA1    A1+1        GET ADDRESS OF ARGUMENT
          SA6    X1          STORE IN RETURN LOCATION 
          EQ     FINDEOL     AND RETURN 
* 
 LINDEX   EQU    LINE-1 
* 
          END