           PCC       0
           SPACE
*****************************************************************
*          VIPLIB  -  HONEYWELL 'VIP' 7200 FORTRAN SUBROUTINES
*
*          THESE SUBROUTINES ARE INTENDED FOR USE OF A FORTRAN
*          PROGRAM UTILIZING A VIP 7200 FOR OUTPUT.
*
*****************************************************************
*
*          SUBROUTINES AND CALLING SEQUENCES
*
*          CALL DIM
*                    WILL CAUSE ANY VISIBLE CHARACTERS PRINTED
*                    AFTER THIS CALL TO BE DISPLAYED IN THE
*                    LOWER DISPLAY INTENSITY
*
*          CALL BRITE
*                    WILL CAUSE ANY VISIBLE CHARACTERS PRINTED
*                    AFTER THIS CALL TO BE DISPLAYED IN THE
*                    HIGHER DISPLAY INTENSITY
*
*          CALL HOME
*                    WILL POSITION THE CURSOR TO THE 'HOME'
*                    POSITION (I.E., COLUMN 1, ROW 1)
*                    THIS CALL IS THE EQUIVALENT OF
*                    CALL MOVEA(1,1)
*
*          CALL ERASE [(IROWS [,ICOL] )]
*                    WILL ERASE THE SCREEN, OR ANY LINE ON THE
*                    SCREEN, OR ANY PORTION OF A LINE TO THE RIGHT
*                    OF THE GIVEN (PRESENT) CURSOR POSITION.  IF NO
*                    ARGUEMENTS ARE GIVEN, THE SCREEN IS ERASED.
*                    IF ONLY IROWS IS GIVEN, THE CORRESPONDING LINE
*                    IS ERASED AND THE CURSOR POSITIONED AT THE
*                    BEGINNING OF THE LINE. IF BOTH ARGUEMENTS ARE
*                    GIVEN, THE CURSOR IS POSITIONED AT THE
*                    CORRESPONDING POINT AND THE REMAINDER OF THE
*                    LINE IS ERASED. IF EITHER ARGUEMENT IS ZERO,
*                    THE CURSOR IS NOT MOVED, BUT THE REMAINDER OF
*                    THE LINE STARTING AT THE PRESENT CURSOR POS-
*                    ITION IS ERASED. THE RANGE FOR IROW IS 0-24,
*                    FOR ICOL IT IS 0-81. ANY OTHERS WILL CAUSE AN
*                    EXIT FORM THE USER PROGRAM.
*
*          CALL CLEAR [(IROWS [,ICOL] )]
*                    SAME AS ERASE, BUT INSTEAD OF ONLY ERASING
*                    TO THE END OF THE LINE, IT CLEARS TO THE END
*                    OF THE PAGE (SCREEN).
*
*          CALL MOVEA (IROW,ICOLUMN)
*                    CAUSES THE CURSOR TO MOVE TO THE LOCATION
*                    INDICATED BY THE INTEGERS IROW AND ICOLUMN.
*                    POSSIBLE VALUES FOR IROW ARE THEREFORE 1-24,
*                    AND POSSIBLE VALUES FOR ICOLUMN ARE THERE-
*                    FORE 1-81. ANY OTHER VALUES WILL PRODUCE AN
*                    ERROR MESSAGE AND EXIT THE USER PROGRAM.
*
*          CALL MOVER (NUMROWS,NUMCOLS)
*                    CAUSES THE CURSOR TO MOVE THE SPECIFIED
*                    NUMBER OF ROWS AND COLUMNS FROM THE CURRENT
*                    CURSOR POSITION. POSSIBLE VALUES FOR NUMROWS
*                    ARE THEREFORE +23 TO -23, POSSIBLE VALUES FOR
*                    NUMCOLS ARE THEREFORE +80 TO -80. ANY OTHER
*                    VALUES WILL PRODUCE AN ERROR MESSAGE AND
*                    EXIT THE USER PROGRAM.  NOTE: NO CHECK IS
*                    MADE TO SEE IF THE DESIRED RELATIVE MOTION
*                    WILL DRIVE THE CURSOR OFF-SCREEN.
*
*****************************************************************
           TITLE     'VIPLIB  -  VIP 7200 FORTRAN LIBRARY'
           TITLE     'VIPLIB  -  REFS, DEFS, EQUS  -  J.L.JOSEPH'
           SPACE     3
*          SYSTEM    BPM
*          SYSTEM    SIG7
           SPACE     3
           DEF       ERASE
           DEF       DIM
           DEF       BRITE
           DEF       MOVEA
           DEF       MOVER
           DEF       HOME
           DEF       CLEAR
           SPACE     3
*****************************************************************
*
*          DCB'S USED BY VIPLIB ARE F:UC AND M:DO.
*          F:UC IS USED SPECIFICALLY FOR BINARY (TRANSPARENT)
*          OUTPUT TO THE TERMINAL.
*
*****************************************************************
          SPACE     3
           REF       F:UC
           REF       M:DO
           PAGE
*****************************************************************
*
*          THE FOLLOWING EQU'S FACILITATE THE BUILDING
*          OF THE BUFFERS THAT GET DUMPED TO THE TERMINAL.
*          NOTE THAT THESE ARE ASCII...NOT EBCDIC CHARACTERS
*          WITH PARITY BITS.....
*
*****************************************************************
           SPACE     3
LITTLEF    EQU       X'66'
ESCAPE     EQU       X'1B'
GRAVEACCT  EQU       X'60'
BIGA       EQU       X'41'
BIGB       EQU       X'42'
BIGC       EQU       X'C3'
BIGD       EQU       X'44'
BIGH       EQU       X'48'
BIGJ       EQU       X'CA'
BIGK       EQU       X'4B'
THREE      EQU       X'33'
FOUR       EQU       X'B4'
LITTLEN    EQU       X'EE'
           TITLE     'VIPLIB DATA AREAS AND FPT''S  -  J.L.JOSEPH'
           SPACE     3
VIPSECT0   CSECT     0
           SPACE
M:ADCB     EQU       %
           DATA      X'14000000'+F:UC
           DATA      X'0000B000'
           DATA      X'00000000'
           DATA      X'01000000'
           DATA      X'00600060'       FBCD,VFC,BIN,DRC
           SPACE
           SPACE
M:TS       EQU       %
           DATA      X'06200000'
           DATA      X'1A000000'
           DATA        00000080        PLATEN WIDTH
           DATA        00000000        PAGE LENGTH
           DATA        00000016        TERMINAL TYPE #
           SPACE
X80        EQU       %
           DATA      X'00000080'
           SPACE
FIRSTFLAG  EQU       %
           DATA      X'00000000'       * INITIALLY ZERO....
           SPACE
CLEAR:BUF  EQU       %
           DATA,1    ESCAPE,GRAVEACCT,0,0
           SPACE
EOP:BUF    EQU       %
           DATA,1    ESCAPE,BIGJ,0,0
           SPACE
ERASE:BUF  EQU       %
           DATA,1    ESCAPE,BIGK,0,0
           SPACE
UP:BUF     EQU       %
           DATA,1    ESCAPE,BIGA,0,0
           SPACE
DOWN:BUF   EQU       %
           DATA,1    ESCAPE,BIGB,0,0
           SPACE
RIGHT:BUF  EQU       %
           DATA,1    ESCAPE,BIGC,0,0
           SPACE
LEFT:BUF   EQU       %
           DATA,1    ESCAPE,BIGD,0,0
           SPACE
HOME:BUF   EQU       %
           DATA,1    ESCAPE,BIGH,0,0
           SPACE
BRITE:BUF  EQU       %
           DATA,1    ESCAPE,THREE,0,0
           SPACE
DIM:BUF    EQU       %
           DATA,1    ESCAPE,FOUR,0,0
           SPACE
MOVEA:BUF  EQU       %
           DATA,1    ESCAPE,LITTLEF,0,0
           SPACE
           BOUND     8
TXT:DIM    TEXT      'DIM     '
TXT:BRITE  TEXT      'BRITE   '
TXT:HOME   TEXT      'HOME    '
TXT:ERASE  TEXT      'ERASE   '
TXT:CLEAR  TEXT      'CLEAR   '
TXT:MOVEA  TEXT      'MOVEA   '
TXT:MOVER  TEXT      'MOVER   '
           BOUND     8
TXT:ERR1   TEXTC     '*ERROR AT CALL XXXXXXXX -----'
TXT:ERR2   TEXTC     'ABORTING YOU BECAUSE OF OPERATIONAL'
TXT:ERR3   TEXTC     'INCONSISTENCIES...READ COMMENTS IN VIPLIB'
TXT:ERR1A  TEXTC     'ILLEGAL NUMBER OF ARGUMENTS IN CALLING LIST'
TXT:ERR1B  TEXTC     'ILLEGAL VALUE IN ONE ARGUMENT'
           TITLE     'VIPLIB  -  SETTERM PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          INTERNAL ROUTINE SETTERM
*
*          THIS SUBROUTINE PERFORMS TWO FUNCTIONS:
*                    1. ADJUSTING THE TERMINAL TYPE TO MATCH
*                       VIP 7200
*                    2. ADJUSTING THE LOADER-BUILD DCB TO MATCH
*                       THE TYPE NECESSARY TO TRANSMIT BINARY ASCII.
*          WE COME HERE ON BAL,11 SETTERM IF FIRSTFLAG
*          IS EQUAL TO ZERO
*
*****************************************************************
           SPACE     3
SETTERM    EQU       %
           MTW,1     FIRSTFLAG         * SET IT TO ONE
           SPACE
           CAL1,8    M:TS              * TERMINAL SETUP
           CAL1,1    M:ADCB            * AND ADJUST DCB
           SPACE
           B         *11               * BACK TO CALLER
           TITLE     'VIPLIB  -  DIM PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE DIM
*
*          ENABLES THE "DIM" OR LOWER INTENSITY DISPLAY MODE
*
*****************************************************************
           SPACE     3
DIM        EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:DIM           * FOR POSSIBLE ERROR:PRINT
           CI,14     0                 * BETTER HAVE NO ARGS
           BNE       ERROR:PRINT       * OOPS
           SPACE
           M:WRITE   F:UC,(BUF,DIM:BUF),(SIZE,2),(WAIT),(BTD,0)
           SPACE
           B         *15               * BACK TO CALLER
           TITLE     'VIPLIB  -  BRITE PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE BRITE
*
*          ENABLES THE NORMAL OR BRIGHTER DISPLAY INTENSITY
*
*****************************************************************
           SPACE     3
BRITE      EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:BRITE         * FOR POSSIBLE ERROR MSG
           CI,14     0                 * ANY ARGUMENTS
           BNE       ERROR:PRINT       * WHOOPS
           SPACE
           M:WRITE   F:UC,(BUF,BRITE:BUF),(SIZE,2),(WAIT),(BTD,0)
           SPACE
           B         *15               * BACK TO USER
           TITLE     'VIPLIB  -  GET:ARGS PROCEDURE  -  G. BRUENING'
           SPACE     3
*****************************************************************
*
*          INTERNAL ROUTINE GET:ARGS
*
*          THIS ROUTINE GETS THE ARGUEMENTS FOR THE CLEAR AND
*          ERASE ROUTINES.  THIS ROUTINE IS ENTERED BY A
*          BAL,11 AND EXITS WITH REG 3 CONTAINING A ROW (1-24)
*          OR A ZERO (INDICATING NO CURSOR MOVEMENT) AND
*          REG 5 CONTAINING A COLUMN (1-80).
*
*          IF THERE ARE NO ARGUEMENTS TO GET (REG 14 = 0)
*          THEN THE SCREEN IS CLEARED AND A DIRECT RETURN
*          IS MADE TO THE CALLING PROGRAM. IF ONE OF THE
*          ARGUEMENTS IS ZERO THEN REG 3 WILL BE SET TO ZERO,
*          AND NO SUBSEQUENT MOVEMENT OF THE CURSOR WILL
*          BE MADE.
*
*****************************************************************
           SPACE     3
GET:ARGS   EQU       %
           CI,14     0
           BL        ERROR:PRINT       * # ARGS<0, WRONG
           BG        GET1              * #ARGS>0, SHK FOR 1 OR 2
CLEAR:     M:WRITE   F:UC,(BUF,CLEAR:BUF),(SIZE,2),(BTD,0),(WAIT)
           B         *15               * HAVE CLEARED SCREEN, RETURN
           SPACE
GET1       LW,3      *15               * GET FIRST ARG
           AI,15     1                 * CORRECT RETURN
           LW,3      *3                * GET ACTUAL VALUE
           LI,5      1                 * SET NCOL
           SPACE
           CI,14     2                 * ARE THERE TWO ARGS
           BG        ERROR:PRINT       * MORE, SO ERROR
           BL        GET2              * ONLY ONE ARG, BRANCH
           LW,5      *15               * GET SECOND ARG
           AI,15     1                 * CORECT RETURN
           LW,5      *5                * GET ACTUAL VALUE
           SPACE
GET2       CI,3      0
           BL        ERROR:PRINT       * NROW<0, ERROR THEM
           BE        GET3              * NROW=0, DONT MOVE CURSOR
           SPACE
           CI,3      24
           BG        ERROR:PRINT       * NROW>24, ERROR THEM
           SPACE
           CI,5      81
           BG        ERROR:PRINT       * NCOL>81, ERROR THEM
           SPACE
           CI,5      0
           BL        ERROR:PRINT       * NCOL<0, ERROR THEM
           BG        GET3              * GOOD, SO DONT SET 3
           SPACE
           LI,3      0                 * SET FOR NO CURSOR MOVE
GET3       B         *11
           TITLE     'VIPLIB  -  MOVE:CUR PROCEDURE -  G. BRUENING'
           SPACE     3
*****************************************************************
*
*          INTERNAL ROUTINE MOVE:CUR
*
*          THIS ROUTINE MOVES THE CURSER TO THE LOCATION
*          SPECIFIED IN REG 3 (NROW) AND REG 5 (NCOL).
*          IT IS ENTERED BY A BAL,11 AND EXITS AFTER
*          POSITIONING THE CURSORS
*
*****************************************************************
           SPACE     3
MOVE:CUR   AI,3      X'1F'             * CONSTANT
           SCS,3     32                *
           BEV       %+2               * IF EVEN, PARITY O.K.
           OR,3      X80               * MAKE PARITY EVEN
           LI,2      3                 * INDEX
           STB,3     MOVEA:BUF,2       * & INTO BUFFER
           SPACE
           AI,5      X'1F'             * SAME FOR REGISTER 5
           SCS,5     32                *
           BEV       %+2               * MAKE SURE WE'RE EVEN
           OR,5      X80               *
           AI,2      -1
           STB,5     MOVEA:BUF,2       * BUFFER IS COMPLETE NOW
           SPACE
           M:WRITE   F:UC,(BUF,MOVEA:BUF),(SIZE,4),(BTD,0),(WAIT)
           B         *11
           TITLE     'VIPLIB  -  ERASE PROCEDURE -  G. BRUENING'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE ERASE [(IROW [,ICOL] )]
*
*          THERE ARE THREE CASES LISTING BELOW:
*
*      (1)  IF NO ARGUEMENTS PASSED, IT WILL CLEAR THE SCREEN.
*
*      (2)  IF IROW IS ONLY GIVEN, THEN THE INTEGER (0-24)
*          WILL INDICATE WHICH LINE IS TO BE ERASED. IF
*          IROW=0 THE PROCEDURE MENTIONED BELOW WILL BE DONE.
*
*      (3)  IF BOTH ARGUEMENTS ARE GIVEN, THEN THE INTEGERS
*          WILL INDICATE A ROW AND COLUMN TO POSITION THE
*          CURSOR AT, AND THE REMAINDER OF THE LINE WILL
*          BE ERASED. IF EITHER ARGUEMENT IS ZERO, THEN THE
*          PROCEDURE MENTIONED BELOW WILL BE TAKEN.
*
*          (IN CASES 2 AND 3, IF IROW OR ICOL IS EQUAL
*          TO ZERO, THEN THE REMAINDER OF THE LINE STARTING
*          AT THE CURRENT CURSOR POSITION WILL BE ERASED.)
*
*          IF THE OPTIONS DO NOT REPRESENT A LEGAL POSITION
*          ON THE SCREEN THE USER WILL BE ABORTED.
*****************************************************************
           SPACE     3
ERASE      EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:ERASE         * FOR POSSIBLE ERROR MESSAGE
           BAL,11    GET:ARGS          * GET ARGUEMENTS
           SPACE
           CI,3      0
           BE        %+2               * DONT MOVE CURSOR
           BAL,11    MOVE:CUR          * MOVE CURSERS
           SPACE
           M:WRITE   F:UC,(BUF,ERASE:BUF),(SIZE,2),(BTD,0),(WAIT)
           B         *15               * HAVE DONE THE ERASE, RETURN
           TITLE     'VIPLIB  -  CLEAR PROCEDURE  -  G. BRUENING'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE CLEAR [(IROW [,ICOL] )]
*
*          SAME AS ERASE, BUT INSTEAD OF ONLY CLEARING TO THE
*          END OF THE LINE, IT CLEARS TO THE END OF THE PAGE.
*
*****************************************************************
           SPACE     3
CLEAR      EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:CLEAR         * FOR POSSIBLE ERROR MESSAGE
           BAL,11    GET:ARGS          * GET ARGUEMENTS
          SPACE
           CI,3      0
           BE        %+2               * DONT MOVE CURSOR
           BAL,11    MOVE:CUR          * MOVE CURSERS
           SPACE
           M:WRITE   F:UC,(BUF,EOP:BUF),(SIZE,2),(BTD,0),(WAIT)
           B         *15               * BACK TO USER
           TITLE     'VIPLIB  -  HOME PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE HOME
*
*          WILL POSITION THE CURSOR IN COLUMN 1, ROW 1
*
*****************************************************************
           SPACE     3
HOME       EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:HOME          * POSSIBLE ERROR MESSAGE
           CI,14     0                 * NO ARGS, I HOPE
           BNE       ERROR:PRINT       * WHOOPS
           SPACE
           M:WRITE   F:UC,(BUF,HOME:BUF),(SIZE,2),(BTD,0),(WAIT)
           B         *15               * BACK TO USER
           TITLE     'VIPLIB  -  MOVEA PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE MOVEA (NROW,NCOL)
*
*          WILL MOVE THE CURSOR TO THE SPECIFIED ROW AND COLUMN
*          WITHIN A RANGE OF 1-24 FOR ROWS AND 1-81 FOR COLUMNS
*
*          ANYTHING ELSE IS PURE NONSENSE AND WILL KILL THE
*          USER
*
*****************************************************************
           SPACE     3
MOVEA      EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:MOVEA         * FOR A POSSIBLE ERROR
           CI,14     2                 * HOW MANY ARGUMENTS
           BNE       ERROR:PRINT       * IF NOT 2 KILL....
           LI,2      X'40'             * OKAY # OF ARGS.......
           STB,2     1                 * ONLY BAD THING CAN BE RANGE
           SPACE
           LW,3      *15               * NROWS
           AI,15     1                 * UP THE POINTER
           LW,5      *15               * NCOLS
           AI,15     1                 * OKAY, NOW ADDR IS O.K.
           SPACE
           LW,3      *3                * GET THE PASSED
           LW,5      *5                * VALUES
           SPACE
           CI,3      0                 * NROWS <=0?
           BLE       ERROR:PRINT       *
           CI,3      24                * > 24?
           BG        ERROR:PRINT
           CI,5      0                 * NCOLS <=0
           BLE       ERROR:PRINT       *
           CI,5      81                * > 81
           BG        ERROR:PRINT
           BAL,11    MOVE:CUR          * MOVE CURSORS
           B         *15               * BACK TO USER
           TITLE     'VIPLIB  -  MOVER PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          SUBROUTINE MOVER (NROWS,NCOLS)
*
*          WILL MOVE THE CURSOR (ONE ROW, OR COLUMN AR A TIME)
*          FROM ITS PRESENT POSITION TO A POSITION RELATIVE
*          TO ITS CURRENT POSITION AS SPECIFIED BY NCOLS
*          (THE NUMBER OF COLUMNS TO MOVE....+ TO THE RIGHT,
*          - TO THE LEFT) AND NROWS ( THE NUMBER OF ROWS TO
*          MOVE + MEANS UP, AND - MEANS DOWN).  THEREFORE
*          A CALL LIKE
*
*          CALL MOVER (-5,5)
*
*          WILL MOVE THE CURSOR DOWN 5 LINES AND TO THE RIGHT
*          5 COLUMNS.
*
*          THE RANGE ON ROWS IS 23 TO -23 (INCLUDING ZERO)
*          THE RANGE ON COLUMNS IS 80 TO -80 (WITH ZERO)
*          NO CHECK IS MADE TO SEE IF THE CURRENT
*          CURSOR POSITION PLUS OR MINUS THE MOVEMENT
*          WILL DRIVE THE CURSOR OFFSCREEN.
*
*****************************************************************
           SPACE     3
MOVER      EQU       %
           MTW,0     FIRSTFLAG         * FIRST TIME IN ROUTINES?
           BGZ       %+2               * NOPE?....
           BAL,11    SETTERM           * GO INITIALIZE DCBS
           LI,1      TXT:MOVER         * FOR POSSIBLE ERROR
           CI,14     2                 * SHOULD BE TWO ARGUMENTS
           BNE       ERROR:PRINT       * NOPE......DIE
           SPACE
           LI,2      X'40'             * GOT THIS FAR...SETUP FOR
           STB,2     1                 * ONLY OTHER ERRORS
           SPACE
           LW,4      *15               * GET ONE ARGUMENT
           AI,15     1                 *
           LW,6      *15               * AND THE OTHER ARGUMENT
           AI,15     1
           LW,4      *4                * GET NROWS
           LW,6      *6                * AND NCOLS
           SPACE
           LAW,8     4                 * TEST VALUE FOR ROWS
           CI,8      24                *
           BGE       ERROR:PRINT       *
           SPACE
           LAW,9     6                 * AND COLUMNS
           CI,9      80                *
           BG        ERROR:PRINT       *
           SPACE
           LI,10     UP:BUF            * GET THE POSITIVE FOR ROWS
           LW,4      4                 * TEST IF NEG...
           BEZ       TEST:HORIZ        * IF ZERO...NO MOVE
           BGZ       %+2               * IF NEGATIVE
           LI,10     DOWN:BUF          * MUST BE DOWN
           SPACE
VERT:LOOP  EQU       %
           M:WRITE   F:UC,(BUF,*10),(SIZE,2),(BTD,0),(WAIT)
           BDR,8     VERT:LOOP
           SPACE
TEST:HORIZ EQU       %
           LI,10     RIGHT:BUF         * COLUMNS + BUFFER
           LW,6      6                 * TEST R6 (COLUMNS)
           BEZ       GET:OUT           * AND EXIT IF ZERO
           BGZ       %+2
           LI,10     LEFT:BUF          *
           SPACE
HORZ:LOOP  EQU       %
           M:WRITE   F:UC,(BUF,*10),(SIZE,2),(BTD,0),(WAIT)
           BDR,9     HORZ:LOOP         *
           SPACE
GET:OUT    EQU       %
           B         *15
           TITLE     'VIPLIB  -  ERROR PROCEDURE  -  J.L.JOSEPH'
           SPACE     3
*****************************************************************
*
*          INTERNAL ROUTINE
*
*          ERROR:PRINT
*
*          DISPLAYS DETECTED ERRORS IN PASSED ARGUMENTS OR NUMBER
*          OF ARGUMENTS, DEPENDING ON CC'S IN UPPER BYTE OF REG. 1
*          REGISTER 1 CONTAINS ADDRESS OF TEXT STRING UNIQUE TO
*          ERRORED ROUTINE.......WE PRINT MESSAGES, THEN KILL USER.
*          I CHOSE TO KILL USER BECAUSE OF THERE ARE ANY ABSURD ERRORS
*          LIKE PARAMETER OUT OF RANGE OR INCORRECT NUMBER OF
*          ARGUMENTS.....THE USER MIGHT AS WELL BOTH KNOW ABOUT IT
*          AND START OVER.
*
*****************************************************************
           SPACE     3
ERROR:PRINT EQU      %
           LD,4      *1                * GET TEXT OF CALLING ROUTINE
           LI,3      2                 * INDEX INTO ERROR MSG
           STD,4     TXT:ERR1,3        * AND INTO BUFFER
           LI,2      TXT:ERR1
           LB,3      TXT:ERR1
ERROR:WRITE EQU      %
           M:WRITE   M:DO,(BUF,*2),(SIZE,*3),(BTD,1),(WAIT)
           LC        1                 * SEE WHAT IT WAS
           BCS,4     ERROR:VAL         * IF SET, VALUE OUT OF R.
           LI,2      TXT:ERR1A
           LB,3      TXT:ERR1A
           B         ERR:PRINT
ERROR:VAL  EQU       %
           LI,2      TXT:ERR1B
           LB,3      TXT:ERR1B
ERR:PRINT  EQU       %
           EXU       ERROR:WRITE
           LI,2      TXT:ERR2
           LB,3      TXT:ERR2
           EXU       ERROR:WRITE
           LI,2      TXT:ERR3
           LB,3      TXT:ERR3
           EXU       ERR:PRINT
           M:XXX                       * KILL ME
           END
