C
$STORAGE:2
C
C
C        *******************************************************
C        *                                                     *
C        *   The following Subroutines are special modules     *
C        *   which are shared between many different programs  *
C        *                                                     *
C        *******************************************************
C
C
C
      SUBROUTINE HELP(KEY,LU)
C
C           This routine will print the HELP screen            
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER KEY*1,OPTION*25,MATCH*1,BUFF*79
      LOGICAL*2 CHECK
C
C           CALL OPTION HEADER
C
      OUNIT=3
      OPTION='Software Assistance'
      CALL HEADER(OPTION)
      OPEN(UNIT=OUNIT,FILE='HELPME.DOC',STATUS='NEW')
C
C           CHECK IF HELP FILE EXISTS           
C
      INQUIRE(UNIT=LU,OPENED=CHECK)
      IF(CHECK.EQV..TRUE.) THEN     
         REWIND LU
   50    CONTINUE
         READ(LU,'(A1)',END=900) MATCH
         IF(MATCH.EQ.KEY) THEN
            BACKSPACE LU
            GOTO 100
         ENDIF
         GOTO 50
C
C           MATCH IN KEY FOUND, SEND DATA TO RAM DISK,
C           THEN CALL ROUTINE TO DISPLAY INFORMATION
C
  100    CONTINUE
         READ(LU,'(A1,A79)',END=200) MATCH,BUFF
         IF(MATCH.EQ.KEY) WRITE(OUNIT,'(A79)') BUFF
         GOTO 100
  200    CONTINUE
         CALL SHOWIT(OUNIT)
      ENDIF
  900 CONTINUE
      CLOSE(OUNIT,STATUS='DELETE')
      RETURN
      END
C
C
C
      SUBROUTINE JUSTIF(TYPE,STRING,LEN)
C
C           This Routine will Right Justify, Left Justify or Center Data
C
      INTEGER SAVE,CHAR,HIT,SPACE,LEN
      CHARACTER STRING*80,TEMP(80)*1,BUFF*80,TYPE*6
      CHARACTER*20 FMT1,FMT2,FMT3
C
C           MOVE DATA INTO TEMPORARY ARRAY
C
      IF(LEN.GT.80) RETURN
      IF(STRING.EQ.' ') RETURN
      WRITE(BUFF,'(A2,I2,A1)',ERR=900) '(A',LEN,')'
         READ(BUFF,'(A5)',ERR=900) FMT1
      WRITE(BUFF,'(A1,I2,A3)',ERR=900) '(',LEN,'A1)'
         READ(BUFF,'(A6)',ERR=900) FMT2
      WRITE(BUFF,FMT1,ERR=900) STRING
         READ(BUFF,FMT2,ERR=900) (TEMP(K),K=1,LEN)
C
C           FIGURE OUT THE NUMBER OF SPACES & CHARACTERS IN STRING
C
      SAVE=1
      CHAR=0
      HIT =0
      SPACE=0
      DO 100 I=1,LEN
      IF(TEMP(I).NE.' ') THEN
         IF(HIT.EQ.0) HIT=I
         CHAR=CHAR+SAVE
         SAVE=1
      ELSEIF(HIT.EQ.0) THEN
         SPACE=SPACE+1
      ELSEIF(HIT.NE.0) THEN
         SAVE=SAVE+1
      ENDIF
  100 CONTINUE
      SPACE=SPACE+SAVE-1
      IF(CHAR.GE.LEN) RETURN
C
C          JUSTIFY AS REQUESTED
C
      FMT3=' '
      IF(TYPE.EQ.'LEFT') THEN
       WRITE(BUFF,'(A1,I2,A3,I2,A2)',ERR=900) '(',CHAR,'A1,',SPACE,'X)'
      ELSEIF(TYPE.EQ.'RIGHT') THEN
       WRITE(BUFF,'(A1,I2,A2,I2,A3)',ERR=900) '(',SPACE,'X,',CHAR,'A1)'
      ELSE
       IONE=SPACE/2
       ITWO=SPACE-IONE
       WRITE(BUFF,200,ERR=900) '(',IONE,'X,',CHAR,'A1,',ITWO,'X)'
  200  FORMAT(A1,I2,A2,I2,A3,I2,A2)
      ENDIF
      READ(BUFF,'(A14)',ERR=900) FMT3
      WRITE(BUFF,FMT3,ERR=900) (TEMP(K),K=HIT,HIT+CHAR-1)
         READ(BUFF,FMT1,ERR=900) STRING
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE SQUISH(STRING,LEN)
C
C           This Routine will remove multiple spaces between words
C
      INTEGER SPACE,LEN
      CHARACTER STRING*80,TEMP(80)*1,BUFF*80
      CHARACTER*20 FMT1,FMT2
C
C           MOVE DATA INTO TEMPORARY ARRAY
C
      IF(LEN.GT.80) RETURN
      IF(STRING.EQ.' ') RETURN
      WRITE(BUFF,'(A2,I2,A1)',ERR=900) '(A',LEN,')'
         READ(BUFF,'(A5)',ERR=900) FMT1
      WRITE(BUFF,'(A1,I2,A3)',ERR=900) '(',LEN,'A1)'
         READ(BUFF,'(A6)',ERR=900) FMT2
      WRITE(BUFF,FMT1,ERR=900) STRING
         READ(BUFF,FMT2,ERR=900) (TEMP(K),K=1,LEN)
C
C           SEARCH ENTIRE STRING, REMOVING MULTIPLE SPACES
C
      I=0
      M=0
      SPACE=0
  100 CONTINUE      
      M=M+1
      I=I+1
      IF(M.GE.LEN) GOTO 800
      IF(TEMP(I).EQ.' ') THEN
         SPACE=SPACE+1
         IF(SPACE.GT.1 .AND. SPACE.LT.LEN) THEN
            SPACE=SPACE-1
            DO 200 K=I,LEN-1
            TEMP(K)=TEMP(K+1)
  200       CONTINUE
            I=I-1
            TEMP(K)=' '
         ENDIF
      ELSE
         SPACE=0
      ENDIF
      GOTO 100
C
C          MOVE DATA BACK INTO ORIGINAL VARIABLE
C
  800 CONTINUE
      WRITE(BUFF,FMT2,ERR=900) (TEMP(K),K=1,LEN)
         READ(BUFF,FMT1,ERR=900) STRING
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE DATETD(DATE,TODAY)
C
C        This routine will convert numeric data to alpha
C
      CHARACTER DATE*8,RAMDSK*80,TYPE*6,TODAY*28
      CHARACTER MONTH(12)*9,DAY(7)*10
      DATA MONTH/'January  ','February ','March    ','April    ',
     A           'May      ','June     ','July     ','August   ',
     B           'September','October  ','November ','December '/
      DATA DAY/'Sunday,   ','Monday,   ','Tuesday,  ','Wednesday,',
     A         'Thursday, ','Friday,   ','Saturday, '/
C
C        FIND OUT DAY-OF-WEEK
C
      TODAY=' '
      IF(DATE.EQ.' ') RETURN
      CALL DATEDW(DATE,IDOW)
      IF(IDOW.EQ.-1) RETURN
C
C        EXTRACT MONTH, DAY & YEAR, THEN COMBINE
C
      WRITE(RAMDSK,'(A8)',ERR=900) DATE
      READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMON,IDAY,IYEAR
      WRITE(RAMDSK,100) DAY(IDOW),MONTH(IMON),IDAY,',',IYEAR+1900
  100 FORMAT(A10,1X,A9,I3,A1,I4)
C
C        FINALLY, REMOVE ALL SPACES, AND RIGHT JUSTIFY 
C
      CALL SQUISH(RAMDSK,28)
      TYPE='RIGHT '
      CALL JUSTIF(TYPE,RAMDSK,28)
      READ(RAMDSK,'(A28)',ERR=900) TODAY
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE DATEDY(DATE,IDIFF)
C
C        This routine will pass back the number of days since 1/1/60
C
      CHARACTER DATE*8,RAMDSK*80
      REAL JIL
      INTEGER DAYS(12)
      DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
C
C        BREAKUP DATE INTO MONTH, DAY, YEAR
C
      IDIFF=-1
      WRITE(RAMDSK,'(A8)',ERR=900) DATE
      READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMM,IDD,IYY
      IF(IMM.LE.0 .OR. IMM.GT.12) GOTO 900
      IF(IYY.LE.0 .OR. IYY.GT.99) GOTO 900
      IF(IDD.LE.0 .OR. IDD.GT.31) GOTO 900
C
C        CALCULATE #OF DAYS SINCE 1/1/60
C
      MDA=0
      IDIFF = ((IYY-60)*365) + IDD - 1
      IF(IMM.NE.1) THEN
         DO 30 I=1,IMM-1
         MDA=MDA + DAYS(I)
   30    CONTINUE
      ENDIF
      JIL = ((IYY-59)/4.0) + 0.90
      IDIFF = IDIFF + MDA + INT(JIL)
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE DATEDW(DATE,IDOW)
C
C       This routine will pass the day-of-week the date lands on
C
      CHARACTER DATE*8,RAMDSK*80
C
C          BREAK UP DATE INTO MOPNTH, DAY, YEAR
C
      IDOW=0
      WRITE(RAMDSK,'(A8)',ERR=900) DATE
      READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMM,IDD,IYY
      IF(IMM.LE.0 .OR. IMM.GT.12) GOTO 900
      IF(IYY.LE.0 .OR. IYY.GT.99) GOTO 900
      IF(IDD.LE.0 .OR. IDD.GT.31) GOTO 900
C
C          NOW FIGURE OUT WHAT DAY OF THE WEEK
C
      ID2=IDD
      IF(IMM.LT.3) THEN
         IM2 = IMM + 12
         IY2 = 1900 + IYY - 1
      ELSE
         IM2 = IMM
         IY2 = 1900 + IYY
      ENDIF
      IDOW = INT(REAL(IY2)*1.25) + INT(REAL(IM2-2) * 2.59)
      IDOW = IDOW + ID2 - ((IDOW + ID2 - 1) / 7) * 7
      IF((IDOW.LT.1) .OR. (IDOW.GT.7)) IDOW=0
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE DATEJL(DATE,IJUL)
C
C        This routine will pass back the julian date equivalent     
C
      CHARACTER DATE*8,RAMDSK*80
      INTEGER DAYS(12)
      REAL LEAPYR
      DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
C
C        BREAKUP DATE INTO MONTH, DAY, YEAR
C
      IJUL=0
      WRITE(RAMDSK,'(A8)',ERR=900) DATE
      READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMM,IDD,IYY
      IF(IMM.LE.0 .OR. IMM.GT.12) GOTO 900
      IF(IYY.LE.0 .OR. IYY.GT.99) GOTO 900
C
C        FIGURE OUT IF ITS A LEAP YEAR  
C
      LEAPYR=(REAL(IYY)/4.0)-INT(REAL(IYY)/4.0) 
      IF(LEAPYR .EQ. 0.0) DAYS(2)=29
      IF(IDD.LE.0 .OR. IDD.GT.DAYS(IMM)) GOTO 900
C
C        NOW, CALCULATE THE JULIAN DATE
C
      IF(IMM.GT.1) THEN
         DO 100 I=1,IMM-1
         IJUL=IJUL+DAYS(I)
  100    CONTINUE
      ENDIF
      IJUL=IJUL+IDD
  900 CONTINUE
      RETURN
      END
C
C
C
C  *************************************************************************
C  *                                                                       *
C  *   These Routines imported from the PRO-350 library                    *
C  *                                                                       *
C  *************************************************************************
C
C
C
      SUBROUTINE EDCHR(HORZ,VERT,CHR1,LEN)
C
C        THIS ROUTINE IS A FULL-SCREEN CHARACTER PSUDO EDITOR
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER CHR*80,CHR1*80,FMT1*7,FMT2*5
C
C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2'
C
      IF(LEN.LE.0 .OR. LEN.GT.80) GOTO 900
      WRITE(FMT1,'(A2,I2.2,A3)') '(A',LEN,',\)'
      WRITE(FMT2,'(A2,I2.2,A1)') '(A',LEN,')'
C
C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
C
  100 CONTINUE
      CALL UPTOP(HORZ,VERT)
      CALL RVIDEO
      WRITE(*,FMT1) CHR1
C
C          READ IN CHANGES
C
      CALL UPTOP(HORZ,VERT)
      READ(*,FMT2,ERR=100) CHR
      IF(CHR.NE.' ') CHR1=CHR
      IF(CHR.EQ.'.') CHR1=' '
C
C          RE-DISPLAY CHARACTER
C
      CALL UPTOP(HORZ,VERT)
      CALL OFF
      WRITE(*,FMT1) CHR1
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE EDNUM(HORZ,VERT,VAL1,LEN)
C
C          FULL SCREEN EDIT ROUTINE FOR INTEGER VALUES
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER FMT1*7,FMT2*8,FMT3*5,TEMP*80,HOLD*1
C
C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2,FMT3'
C
      IF(LEN.LE.0 .OR. LEN.GT.80) GOTO 900
      WRITE(FMT1,'(A2,I2.2,A3)') '(I',LEN,',\)'
      WRITE(FMT2,'(A5,I2.2,A1)') '(BN,I',LEN,')'
      WRITE(FMT3,'(A2,I2.2,A1)') '(A',LEN,')'
C
C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
C
  100 CONTINUE
      CALL UPTOP(HORZ,VERT)
      CALL RVIDEO
      WRITE(*,FMT1) VAL1
C
C          READ INPUT USING A CHARACTER VARIABLE
C          IF THE ASCII EQUIV. IS 32, THEN NO CHANGE MADE
C
      CALL UPTOP(HORZ,VERT)
      READ(*,FMT3,ERR=100) TEMP
      HOLD=TEMP
      IF(ICHAR(HOLD).NE.32) READ(TEMP,FMT2,ERR=100) VAL1
C
C          RE-WRITE THE VALUE
C
      CALL UPTOP(HORZ,VERT)
      CALL OFF
      WRITE(*,FMT1) VAL1
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE EDREL(HORZ,VERT,VAL1,LEN)
C
C          FULL SCREEN EDIT ROUTINE FOR REAL VALUES
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER FMT1*9,FMT2*11,FMT3*5,TEMP*80,HOLD*1
      REAL VAL1
C
C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2,FMT3'
C
      IF(LEN.LE.0 .OR. LEN.GT.80) GOTO 900
      WRITE(FMT1,'(A2,I2.2,A5)') '(F',LEN,'.2,\)'
      WRITE(FMT2,'(A5,I2.2,A4)') '(BN,F',LEN,'.0,)'
      WRITE(FMT3,'(A2,I2.2,A1)') '(A',LEN,')'
C
C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
C
  100 CONTINUE
      CALL UPTOP(HORZ,VERT)
      CALL RVIDEO
      WRITE(*,FMT1) VAL1
C
C          READ INPUT USING A CHARACTER VARIABLE
C          IF THE ASCII EQUIV. IS 32, THEN NO CHANGE MADE
C
      CALL UPTOP(HORZ,VERT)
      READ(*,FMT3,ERR=100) TEMP
      HOLD=TEMP
      IF(ICHAR(HOLD).NE.32) READ(TEMP,FMT2,ERR=100) VAL1
C
C          RE-WRITE THE VALUE
C
      CALL UPTOP(HORZ,VERT)
      CALL OFF
      WRITE(*,FMT1) VAL1
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE EDATE(HORZ,VERT,DATE)
C
C          FULL SCREEN EDITOR FOR DATE VARIABLES
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER CHR*8,DATE*8,FMT1*6,FMT2*4
C
C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2'
C
      FMT1='(A8,\)'
      FMT2='(A8)'
C
C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
C
  100 CONTINUE
      CALL UPTOP(HORZ,VERT)
      CALL RVIDEO
      WRITE(*,FMT1) DATE
C
C          READ IN CHANGES 
C
      CALL UPTOP(HORZ,VERT)
      READ(*,FMT2,ERR=100) CHR
      IF(CHR.EQ.'.') THEN
         DATE=' ' 
      ELSEIF(CHR.NE.' ') THEN
C
C             USE THE DAY-OF-WEEK SUBROUTINE TO TEST FOR VALID DATE
C
         CALL DATEDW(CHR,IDOW)
         IF(IDOW.EQ.0) THEN
            CALL UPTOP(HORZ,VERT)
            CALL BELL
            GOTO 100
         ELSE
            DATE=CHR
         ENDIF
      ENDIF
C
C          RE-DISPLAY CHARACTER
C
      CALL UPTOP(HORZ,VERT)
      CALL OFF                      
      WRITE(*,FMT1) DATE
      RETURN
      END
C
C
C
      SUBROUTINE WORKIN(HORZ,VERT)
C
C       This routine will display a blinking WORKING message
C       at the specified screen position.
C
      INTEGER HORZ,VERT

      IF(HORZ.LT.1 .OR. HORZ.GT.80) GOTO 900
      IF(VERT.LT.1 .OR. VERT.GT.24) GOTO 900

      CALL UPTOP(HORZ,VERT)
      CALL BOLD
      CALL BLINK
         WRITE(*,'(1X,A13,\)') ' Working ... '
      CALL OFF
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE SHOWIT(UNIT)
C
C          This routine will display, one screen at a time,
C          data from any file already OPENED.
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER DATA(50)*79,DIRECT*1,FMT*10
      CHARACTER CMD*5,LCMD*5
C
C             First, define the scrolling region
C
      CALL MOVEIT(1,6)
      WRITE(*,'(1X,A1,A1,I1,A1,I2,A1)') 27,'[',6,';',21,'r'
C
C             Now, draw the prompt line
C
      CALL UPTOP(1,22)
      CALL BOLD
      CALL ULINE
      WRITE(*,50) 
   50 FORMAT(80(' '))
      CALL OFF
C
C             Now, read the file and display one screen at a time
C
      DIRECT=' '
      CALL KEYOFF
      CALL WORKIN(1,24)
      CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
      LSTART=START
C
      K=0
      M=0
      LNUM=15
      WAY=1
      CMD='D    '
C
C          START BY SAVING THE 'LAST COMMAND' (EITHER UP OR DOWN)
C
  100 CONTINUE
      LCMD=CMD
C
C          NOW, TEST WERE I AM, AND OPERATE ON THAT CONDITION
C          ... IF THE COUNTER K IS GREATER THAN THE NUMBER OF
C              LINES TO SCROLL, THEN PROMPT FOR ANOTHER COMMAND
C
      IF(K.GE.LNUM) THEN
         K=0
  110    CONTINUE
            CALL BOLD
            CALL KEYON
            CALL UPTOP(1,24)
            WRITE(*,'(A9,A1,A3,\)') 'Command [',CMD,']: '
            READ(*,'(A1,I3)',ERR=110) CMD,LNUM
            IF(LNUM.LE.0 .OR. LNUM.GT.200) LNUM=15
         CALL OFF
            CALL UPTOP(1,24)
            WRITE(*,'(A1,A3,A19,\)') 27,'[0K','Wait ...           '
         CALL KEYOFF

         IF(CMD.EQ.'Q' .OR. CMD.EQ.'q') THEN
            GOTO 900
         ELSEIF(CMD.EQ.'P' .OR. CMD.EQ.'p') THEN
            CMD=LCMD
            CALL UPTOP(1,24)
            WRITE(*,'(A19,\)') 'Wait ...           '
            CALL BELL
            CALL BOLD
            CALL UPTOP(40,24)
            WRITE(*,'(A38,\)') 'Printing Requested Document           '
            CALL OFF
            CALL PLOCAL(UNIT,FMT)
            CALL BELL
            CALL UPTOP(40,24)
            WRITE(*,'(A38,\)') 'Document Printing Completed           '
            GOTO 110
         ELSEIF(CMD.EQ.'U' .OR. CMD.EQ.'u') THEN
            CMD='U'
            WAY=-1
            IF(LCMD.EQ.'D') THEN
               IF(MAX.GT.14) THEN
                  M=M-14
               ELSE
                  M=M-MAX+1
               ENDIF
            ENDIF
         ELSEIF(CMD.EQ.'D' .OR. CMD.EQ.'d') THEN
            CMD='D'
            WAY=1
            IF(LCMD.EQ.'U') THEN
               IF(MAX.GT.14) THEN
                  M=M+14
               ELSE
                  M=M+MAX-1
               ENDIF
            ENDIF
         ELSEIF(CMD.EQ.'T' .OR. CMD.EQ.'t') THEN
            CMD='D'
            M=-100
            WAY=1
            LNUM=15
            CALL WIPE
         ELSEIF(CMD.EQ.'B' .OR. CMD.EQ.'b') THEN
            CMD='D'
            M=-102
            WAY=1
            LNUM=15
            CALL WIPE
         ELSEIF(LCMD.EQ.'D') THEN
            CMD='D'
            WAY=1
         ELSEIF(LCMD.EQ.'U') THEN
            CMD='U'
            WAY=-1
         ENDIF
      ENDIF
C
C           INCREMENT, THEN CHECK ARRAY LOCATION POINTER
C
      M=M+WAY
C
C           M=-99 MEANS A REQUEST FOR TOP OF FILE
C           M=-101 MEANS REQUEST FOR BOTTOM OF FILE
C
      IF(M.EQ.-99) THEN
         DIRECT='T'
         CALL WORKIN(1,24)
         CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
         M=1
      ELSEIF(M.EQ.-101) THEN
         DIRECT='B'
         CALL WORKIN(1,24)
         CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
         M=37
      ELSEIF((M.GT.50) .OR. (M.GT.STOP)) THEN
         IF(STOP.GE.MAX) THEN
            CALL BELL
            K=LNUM+1
            M=M-WAY
            GOTO 100
         ELSE
            DIRECT='D'
            LSTART=START
            CALL WORKIN(1,24)
            CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
            M=START-LSTART+1
         ENDIF
      ELSEIF(M.LT.1) THEN
         IF(START.LE.1) THEN
            CALL BELL
            K=LNUM+1
            M=M-WAY
            GOTO 100
         ELSE
            DIRECT='U'
            LSTART=START
            CALL WORKIN(1,24)
            CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
            M=LSTART-START
         ENDIF
      ENDIF
C
C         INCREMENT LINE COUNTER, MAKE SCREEN SCROLL EITHER UP OR DOWN
C         THEN DISPLAY THE NEXT LINE OF DATA
C
      K=K+1
      IF(CMD.EQ.'D') THEN
         CALL UPTOP(1,21)
         WRITE(*,'(1X,A,\)') DATA(M)
      ELSEIF(CMD.EQ.'U') THEN
         CALL UPTOP(1,6)
         WRITE(*,'(1X,A1,A1,\)') 27,'M'
         CALL UPTOP(1,6)
         WRITE(*,'(1X,A,\)') DATA(M)
      ENDIF
      GOTO 100
C
C             Reset all terminal attributes, close print file
C
  900 CONTINUE
      CALL KEYON
      WRITE(*,'(1X,A1,A1,I1,A1,I2,A1)') 27,'[',1,';',24,'r'
      RETURN
      END
C
C
C
      SUBROUTINE WIPE
C
C           WIPES THE SCROLLING REGION CLEAN
C
      CALL UPTOP(1,5)
      WRITE(*,'(1X,A1,A3)') 27,'[2K'
      DO 200 K=1,16
      WRITE(*,'(1X,A1,A3)') 27,'[2K'
  200 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
C
C          This routine will grab 50 lines of data from a file
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER DATA(50)*79,DIRECT*1,PAGE*1,FMT*10
C
C        IF THIS IS THE FIRST TIME IN, FIND THE BOTTOM OF THE FILE
C        OTHERWISE, SET NEW LOCATION POINTER
C
      IF(DIRECT.EQ.' ') THEN
         INC=0
         MAX=0
         CLOC=0
         START=0
         STOP=0
         FMT='(1X,A)'
         REWIND UNIT
   10    CONTINUE
         READ(UNIT,'(A1)',END=20) PAGE
         IF(PAGE.NE.' ' .AND. PAGE.NE.'1') FMT='(A)'
         MAX=MAX+1
         GOTO 10
   20    CONTINUE
      ELSEIF(DIRECT.EQ.'T') THEN
         CLOC=0
         INC=0
      ELSEIF(DIRECT.EQ.'B') THEN
         CLOC=MAX-49
         INC=0
      ELSEIF(DIRECT.EQ.'U') THEN
         INC=75
      ELSE
         INC=25
      ENDIF

      CLOC=CLOC-INC
      IF(CLOC.LE.0) CLOC=1
C
C         LOG THE NEW STARTING POSTITION, AND IF IT IS
C         NOT=1, THEN BACKUP FROM THE CURRENT POSTITION
C         TO THE NEW STARTING POSITION
C
      START=CLOC
      REWIND UNIT
      IF(START.GT.1) THEN
         DO 50 I=1,START-1
         READ(UNIT,'(1X)')
   50    CONTINUE
      ENDIF
C
C        READ IN 50 LINES OF DATA FROM REQUESTED LOCATION
C
      DO 75 M=1,50
      READ(UNIT,FMT,END=80) DATA(M)
      CLOC=CLOC+1
   75 CONTINUE
   80 CONTINUE
C
C         IF THE BUFFER IS NOT FULL, PAD IT WITH BLANK RECORDS
C
      STOP=CLOC-1
      IF(M.LT.50) THEN
         DO 175 K=M,50
         DATA(K)=' '
  175    CONTINUE
      ENDIF

      RETURN
      END
C
C
C
      SUBROUTINE PLOCAL(UNIT,FMT)
C
C        THIS ROUTINE SPOOLS FILE TO THE PRINTER
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER FMT*10,DATA*80,PAGE*1

      IPAGE=0
      REWIND UNIT
      OPEN(UNIT=2,FILE='PRN')

  100 CONTINUE
      IF(FMT.EQ.'(A)') THEN
         READ(UNIT,'(A80)',END=900,ERR=900) DATA
         WRITE(2,'(1X,A80)') DATA
      ELSE
         READ(UNIT,'(A1,A79)',END=900,ERR=900) PAGE,DATA
         IF(PAGE.EQ.'1') THEN
            IPAGE=IPAGE+1
            WRITE(2,'(1H1)')
            CALL UPTOP(70,24)
            IF(IPAGE.LE.99) WRITE(*,'(A4,I2,\)') 'Page',IPAGE
         ENDIF
         WRITE(2,'(1X,A79)') DATA
      ENDIF
      GOTO 100
  900 CONTINUE

      CLOSE(2)
      RETURN
      END
C
C
C
      SUBROUTINE BOX(HEIGHT,WIDTH,LEFTH,LEFTV,TITLE,TTLEN,TTATTR,BXATTR)
CC
CC
CC    Created on  :  May 19, 1987
CC    Last Updated:  June 1, 1987
CC    Written by  :  Bruce W. Roeckel
CC
CC    Description :  This routine will draw a box, using the VT100
CC                   graphic character set, at the specified position
CC                   on the screen.
CC
CC                   HEIGHT -- how tall the box is
CC                   WIDTH  -- how wide the box is
CC                   LEFTH --- the horizontal position of the left
CC                             hand corner
CC                   LEFTV --- the vertical position of the left
CC                             hand corner
CC                   TITLE --- a character variable that will be used
CC                             as the title block to the box.
CC                   TTLEN --- Length of the title (# of Characters)
CC                   TTATTR -- attributes to use for title block
CC
CC                          Box   NoBox
CC                           10     0 = Normal Characters
CC                           11     1 = inverse video
CC                           12     2 = bold
CC                           13     3 = blink
CC                           14     4 = inverse video, bold
CC                           15     5 = inverse video, blink
CC                           16     6 = bold, blink
CC                           17     7 = inverse video, bold, blink
CC
CC                   BXATTR -- box attribute. Decimal zero (0) is clear
CC                             box, one (1) is inverse video box.
CC
CC
CC
CC    Update #    Name       Date          Comments
CC    --------  ---------  --------  ----------------------------------
CC       001    Roeckel    05-22-87  Added Boxed/NoBoxed title option
CC       002    Roeckel    06-01-87  Only paints entire screen if
CC                                   inverse video box selected
CC
CC
      IMPLICIT INTEGER (A-Z)
      CHARACTER*1 TLC,TRC,BLC,BRC,VLINE(80),HLINE,RCON,LCON
      CHARACTER TEMP*80,TITLE*40,RELOC*11,FMT1*20
C
C         DEFINE THE GRAPHICS CHARACTERS
C
      TLC='l'
      TRC='k'
      BLC='m'
      BRC='j'
      HLINE='x'
      RCON='t'
      LCON='u'

      DO 10 K=1,80
      VLINE(K)='q'
   10 CONTINUE
C
C          MOVE LINE DRAWING CHARACTER SET INTO "G1"
C
      UNIT=0 
      CALL GCHAR(UNIT)
C
C          CHECK IF SELECTED POSITION IS O.K.
C
      IF((LEFTH.GE.1 .AND. LEFTH.LE.80) .AND.
     A   (LEFTV.GE.1 .AND. LEFTV.LE.24)) THEN
C
C        .... SET TERMINAL INTO GRAPHICS MODE
C
         IF(BXATTR.EQ.1) CALL RVIDEO
         CALL GPHON(UNIT)
C
C        .... STARTING AT THE LEFT HAND CORNER, DRAW THE TOP
C
         CALL LOCATE(LEFTH,LEFTV,RELOC)
         WRITE(*,50) RELOC,TLC,(VLINE(K),K=1,WIDTH-2),TRC
   50    FORMAT(A11,80A1,$)
C
C        .... NOW START DOWN THE SIDES
C
         IF(BXATTR.EQ.1) THEN

            WRITE(FMT1,'(A8,I2.2,A5)') '(A11,A1,',WIDTH-2,'X,A1)'
            DO 100 I=1,HEIGHT-2
            CALL LOCATE(LEFTH,LEFTV+I,RELOC)
            WRITE(*,FMT1) RELOC,HLINE,HLINE
  100       CONTINUE

         ELSE

            DO 110 I=1,HEIGHT-2
            CALL LOCATE(LEFTH,LEFTV+I,RELOC)
            WRITE(*,'(A11,A1)') RELOC,HLINE
            CALL LOCATE(LEFTH+WIDTH-1,LEFTV+I,RELOC)
            WRITE(*,'(A11,A1)') RELOC,HLINE
  110       CONTINUE

         ENDIF
C
C        .... AND FINALLY DRAW THE BOTTOM
C
         CALL LOCATE(LEFTH,LEFTV+HEIGHT-1,RELOC)
         WRITE(*,50) RELOC,BLC,(VLINE(K),K=1,WIDTH-2),BRC
C
C        .... SEE IF A TITLE BLOCK WAS REQUESTED
C
         IF(TTLEN.GT.0) THEN
C
C           .... CENTER THE TITLE
C
            DIFF = WIDTH/2 - (TTLEN+2)/2
            IF(DIFF.LE.0) DIFF=0
            TEMP=TITLE
            CALL JUSTIF('CENTER',TEMP,TTLEN)
C
C           .... CHECK IF TITLE SHOULD BE BOXED IN
C
            IF(TTATTR.GE.10) THEN
C
C                   MUST MOVE UP ONE LINE FOR TOP OF TITLE BOX
C
               CALL LOCATE(LEFTH+DIFF-1,LEFTV-1,RELOC)
               WRITE(*,50) RELOC,TLC,(VLINE(K),K=1,TTLEN+2),TRC
C
C                   DRAW IN THE CONNECTORS
C
               WRITE(FMT1,'(A8,I2.2,A5)') '(A11,A1,',TTLEN+2,'X,A1)'
               CALL LOCATE(LEFTH+DIFF-1,LEFTV,RELOC)
               WRITE(*,FMT1) RELOC,LCON,RCON
C
C                   DRAW THE BOTTOM OF THE TITLE BOX
C
               CALL LOCATE(LEFTH+DIFF-1,LEFTV+1,RELOC)
               WRITE(*,50) RELOC,BLC,(VLINE(K),K=1,TTLEN+2),BRC

            ENDIF
C
C           .... NOW INSERT THE TITLE
C
            CALL OFF
            CALL GPHOFF(UNIT)
            IF(TTATTR.GT.10) TTATTR=TTATTR-10
            IF(TTATTR.EQ.1 .OR. TTATTR.EQ.4 .OR. TTATTR.EQ.5 .OR.
     A         TTATTR.EQ.7) CALL RVIDEO
            IF(TTATTR.EQ.2 .OR. TTATTR.EQ.4 .OR. TTATTR.EQ.6 .OR.
     A         TTATTR.EQ.7) CALL BOLD
            IF(TTATTR.EQ.3 .OR. TTATTR.EQ.5 .OR. TTATTR.EQ.6 .OR.
     A         TTATTR.EQ.7) CALL BLINK

            WRITE(FMT1,'(A6,I2.2,A1)') '(A11,A',TTLEN,')'
            CALL LOCATE(LEFTH+DIFF+1,LEFTV,RELOC)
            WRITE(*,FMT1) RELOC,TEMP

            CALL OFF

         ELSE

            CALL GPHOFF(UNIT)
            CALL OFF

         ENDIF
      ENDIF
      RETURN
      END

