home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / rainbow / msdos / decus / RB117 / utils.for < prev    next >
Text File  |  1995-05-28  |  26KB  |  1,001 lines
  1. C
  2. $STORAGE:2
  3. C
  4. C
  5. C        *******************************************************
  6. C        *                                                     *
  7. C        *   The following Subroutines are special modules     *
  8. C        *   which are shared between many different programs  *
  9. C        *                                                     *
  10. C        *******************************************************
  11. C
  12. C
  13. C
  14.       SUBROUTINE HELP(KEY,LU)
  15. C
  16. C           This routine will print the HELP screen            
  17. C
  18.       IMPLICIT INTEGER (A-Z)
  19.       CHARACTER KEY*1,OPTION*25,MATCH*1,BUFF*79
  20.       LOGICAL*2 CHECK
  21. C
  22. C           CALL OPTION HEADER
  23. C
  24.       OUNIT=3
  25.       OPTION='Software Assistance'
  26.       CALL HEADER(OPTION)
  27.       OPEN(UNIT=OUNIT,FILE='HELPME.DOC',STATUS='NEW')
  28. C
  29. C           CHECK IF HELP FILE EXISTS           
  30. C
  31.       INQUIRE(UNIT=LU,OPENED=CHECK)
  32.       IF(CHECK.EQV..TRUE.) THEN     
  33.          REWIND LU
  34.    50    CONTINUE
  35.          READ(LU,'(A1)',END=900) MATCH
  36.          IF(MATCH.EQ.KEY) THEN
  37.             BACKSPACE LU
  38.             GOTO 100
  39.          ENDIF
  40.          GOTO 50
  41. C
  42. C           MATCH IN KEY FOUND, SEND DATA TO RAM DISK,
  43. C           THEN CALL ROUTINE TO DISPLAY INFORMATION
  44. C
  45.   100    CONTINUE
  46.          READ(LU,'(A1,A79)',END=200) MATCH,BUFF
  47.          IF(MATCH.EQ.KEY) WRITE(OUNIT,'(A79)') BUFF
  48.          GOTO 100
  49.   200    CONTINUE
  50.          CALL SHOWIT(OUNIT)
  51.       ENDIF
  52.   900 CONTINUE
  53.       CLOSE(OUNIT,STATUS='DELETE')
  54.       RETURN
  55.       END
  56. C
  57. C
  58. C
  59.       SUBROUTINE JUSTIF(TYPE,STRING,LEN)
  60. C
  61. C           This Routine will Right Justify, Left Justify or Center Data
  62. C
  63.       INTEGER SAVE,CHAR,HIT,SPACE,LEN
  64.       CHARACTER STRING*80,TEMP(80)*1,BUFF*80,TYPE*6
  65.       CHARACTER*20 FMT1,FMT2,FMT3
  66. C
  67. C           MOVE DATA INTO TEMPORARY ARRAY
  68. C
  69.       IF(LEN.GT.80) RETURN
  70.       IF(STRING.EQ.' ') RETURN
  71.       WRITE(BUFF,'(A2,I2,A1)',ERR=900) '(A',LEN,')'
  72.          READ(BUFF,'(A5)',ERR=900) FMT1
  73.       WRITE(BUFF,'(A1,I2,A3)',ERR=900) '(',LEN,'A1)'
  74.          READ(BUFF,'(A6)',ERR=900) FMT2
  75.       WRITE(BUFF,FMT1,ERR=900) STRING
  76.          READ(BUFF,FMT2,ERR=900) (TEMP(K),K=1,LEN)
  77. C
  78. C           FIGURE OUT THE NUMBER OF SPACES & CHARACTERS IN STRING
  79. C
  80.       SAVE=1
  81.       CHAR=0
  82.       HIT =0
  83.       SPACE=0
  84.       DO 100 I=1,LEN
  85.       IF(TEMP(I).NE.' ') THEN
  86.          IF(HIT.EQ.0) HIT=I
  87.          CHAR=CHAR+SAVE
  88.          SAVE=1
  89.       ELSEIF(HIT.EQ.0) THEN
  90.          SPACE=SPACE+1
  91.       ELSEIF(HIT.NE.0) THEN
  92.          SAVE=SAVE+1
  93.       ENDIF
  94.   100 CONTINUE
  95.       SPACE=SPACE+SAVE-1
  96.       IF(CHAR.GE.LEN) RETURN
  97. C
  98. C          JUSTIFY AS REQUESTED
  99. C
  100.       FMT3=' '
  101.       IF(TYPE.EQ.'LEFT') THEN
  102.        WRITE(BUFF,'(A1,I2,A3,I2,A2)',ERR=900) '(',CHAR,'A1,',SPACE,'X)'
  103.       ELSEIF(TYPE.EQ.'RIGHT') THEN
  104.        WRITE(BUFF,'(A1,I2,A2,I2,A3)',ERR=900) '(',SPACE,'X,',CHAR,'A1)'
  105.       ELSE
  106.        IONE=SPACE/2
  107.        ITWO=SPACE-IONE
  108.        WRITE(BUFF,200,ERR=900) '(',IONE,'X,',CHAR,'A1,',ITWO,'X)'
  109.   200  FORMAT(A1,I2,A2,I2,A3,I2,A2)
  110.       ENDIF
  111.       READ(BUFF,'(A14)',ERR=900) FMT3
  112.       WRITE(BUFF,FMT3,ERR=900) (TEMP(K),K=HIT,HIT+CHAR-1)
  113.          READ(BUFF,FMT1,ERR=900) STRING
  114.   900 CONTINUE
  115.       RETURN
  116.       END
  117. C
  118. C
  119. C
  120.       SUBROUTINE SQUISH(STRING,LEN)
  121. C
  122. C           This Routine will remove multiple spaces between words
  123. C
  124.       INTEGER SPACE,LEN
  125.       CHARACTER STRING*80,TEMP(80)*1,BUFF*80
  126.       CHARACTER*20 FMT1,FMT2
  127. C
  128. C           MOVE DATA INTO TEMPORARY ARRAY
  129. C
  130.       IF(LEN.GT.80) RETURN
  131.       IF(STRING.EQ.' ') RETURN
  132.       WRITE(BUFF,'(A2,I2,A1)',ERR=900) '(A',LEN,')'
  133.          READ(BUFF,'(A5)',ERR=900) FMT1
  134.       WRITE(BUFF,'(A1,I2,A3)',ERR=900) '(',LEN,'A1)'
  135.          READ(BUFF,'(A6)',ERR=900) FMT2
  136.       WRITE(BUFF,FMT1,ERR=900) STRING
  137.          READ(BUFF,FMT2,ERR=900) (TEMP(K),K=1,LEN)
  138. C
  139. C           SEARCH ENTIRE STRING, REMOVING MULTIPLE SPACES
  140. C
  141.       I=0
  142.       M=0
  143.       SPACE=0
  144.   100 CONTINUE      
  145.       M=M+1
  146.       I=I+1
  147.       IF(M.GE.LEN) GOTO 800
  148.       IF(TEMP(I).EQ.' ') THEN
  149.          SPACE=SPACE+1
  150.          IF(SPACE.GT.1 .AND. SPACE.LT.LEN) THEN
  151.             SPACE=SPACE-1
  152.             DO 200 K=I,LEN-1
  153.             TEMP(K)=TEMP(K+1)
  154.   200       CONTINUE
  155.             I=I-1
  156.             TEMP(K)=' '
  157.          ENDIF
  158.       ELSE
  159.          SPACE=0
  160.       ENDIF
  161.       GOTO 100
  162. C
  163. C          MOVE DATA BACK INTO ORIGINAL VARIABLE
  164. C
  165.   800 CONTINUE
  166.       WRITE(BUFF,FMT2,ERR=900) (TEMP(K),K=1,LEN)
  167.          READ(BUFF,FMT1,ERR=900) STRING
  168.   900 CONTINUE
  169.       RETURN
  170.       END
  171. C
  172. C
  173. C
  174.       SUBROUTINE DATETD(DATE,TODAY)
  175. C
  176. C        This routine will convert numeric data to alpha
  177. C
  178.       CHARACTER DATE*8,RAMDSK*80,TYPE*6,TODAY*28
  179.       CHARACTER MONTH(12)*9,DAY(7)*10
  180.       DATA MONTH/'January  ','February ','March    ','April    ',
  181.      A           'May      ','June     ','July     ','August   ',
  182.      B           'September','October  ','November ','December '/
  183.       DATA DAY/'Sunday,   ','Monday,   ','Tuesday,  ','Wednesday,',
  184.      A         'Thursday, ','Friday,   ','Saturday, '/
  185. C
  186. C        FIND OUT DAY-OF-WEEK
  187. C
  188.       TODAY=' '
  189.       IF(DATE.EQ.' ') RETURN
  190.       CALL DATEDW(DATE,IDOW)
  191.       IF(IDOW.EQ.-1) RETURN
  192. C
  193. C        EXTRACT MONTH, DAY & YEAR, THEN COMBINE
  194. C
  195.       WRITE(RAMDSK,'(A8)',ERR=900) DATE
  196.       READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMON,IDAY,IYEAR
  197.       WRITE(RAMDSK,100) DAY(IDOW),MONTH(IMON),IDAY,',',IYEAR+1900
  198.   100 FORMAT(A10,1X,A9,I3,A1,I4)
  199. C
  200. C        FINALLY, REMOVE ALL SPACES, AND RIGHT JUSTIFY 
  201. C
  202.       CALL SQUISH(RAMDSK,28)
  203.       TYPE='RIGHT '
  204.       CALL JUSTIF(TYPE,RAMDSK,28)
  205.       READ(RAMDSK,'(A28)',ERR=900) TODAY
  206.   900 CONTINUE
  207.       RETURN
  208.       END
  209. C
  210. C
  211. C
  212.       SUBROUTINE DATEDY(DATE,IDIFF)
  213. C
  214. C        This routine will pass back the number of days since 1/1/60
  215. C
  216.       CHARACTER DATE*8,RAMDSK*80
  217.       REAL JIL
  218.       INTEGER DAYS(12)
  219.       DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
  220. C
  221. C        BREAKUP DATE INTO MONTH, DAY, YEAR
  222. C
  223.       IDIFF=-1
  224.       WRITE(RAMDSK,'(A8)',ERR=900) DATE
  225.       READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMM,IDD,IYY
  226.       IF(IMM.LE.0 .OR. IMM.GT.12) GOTO 900
  227.       IF(IYY.LE.0 .OR. IYY.GT.99) GOTO 900
  228.       IF(IDD.LE.0 .OR. IDD.GT.31) GOTO 900
  229. C
  230. C        CALCULATE #OF DAYS SINCE 1/1/60
  231. C
  232.       MDA=0
  233.       IDIFF = ((IYY-60)*365) + IDD - 1
  234.       IF(IMM.NE.1) THEN
  235.          DO 30 I=1,IMM-1
  236.          MDA=MDA + DAYS(I)
  237.    30    CONTINUE
  238.       ENDIF
  239.       JIL = ((IYY-59)/4.0) + 0.90
  240.       IDIFF = IDIFF + MDA + INT(JIL)
  241.   900 CONTINUE
  242.       RETURN
  243.       END
  244. C
  245. C
  246. C
  247.       SUBROUTINE DATEDW(DATE,IDOW)
  248. C
  249. C       This routine will pass the day-of-week the date lands on
  250. C
  251.       CHARACTER DATE*8,RAMDSK*80
  252. C
  253. C          BREAK UP DATE INTO MOPNTH, DAY, YEAR
  254. C
  255.       IDOW=0
  256.       WRITE(RAMDSK,'(A8)',ERR=900) DATE
  257.       READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMM,IDD,IYY
  258.       IF(IMM.LE.0 .OR. IMM.GT.12) GOTO 900
  259.       IF(IYY.LE.0 .OR. IYY.GT.99) GOTO 900
  260.       IF(IDD.LE.0 .OR. IDD.GT.31) GOTO 900
  261. C
  262. C          NOW FIGURE OUT WHAT DAY OF THE WEEK
  263. C
  264.       ID2=IDD
  265.       IF(IMM.LT.3) THEN
  266.          IM2 = IMM + 12
  267.          IY2 = 1900 + IYY - 1
  268.       ELSE
  269.          IM2 = IMM
  270.          IY2 = 1900 + IYY
  271.       ENDIF
  272.       IDOW = INT(REAL(IY2)*1.25) + INT(REAL(IM2-2) * 2.59)
  273.       IDOW = IDOW + ID2 - ((IDOW + ID2 - 1) / 7) * 7
  274.       IF((IDOW.LT.1) .OR. (IDOW.GT.7)) IDOW=0
  275.   900 CONTINUE
  276.       RETURN
  277.       END
  278. C
  279. C
  280. C
  281.       SUBROUTINE DATEJL(DATE,IJUL)
  282. C
  283. C        This routine will pass back the julian date equivalent     
  284. C
  285.       CHARACTER DATE*8,RAMDSK*80
  286.       INTEGER DAYS(12)
  287.       REAL LEAPYR
  288.       DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
  289. C
  290. C        BREAKUP DATE INTO MONTH, DAY, YEAR
  291. C
  292.       IJUL=0
  293.       WRITE(RAMDSK,'(A8)',ERR=900) DATE
  294.       READ(RAMDSK,'(I2,1X,I2,1X,I2)',ERR=900) IMM,IDD,IYY
  295.       IF(IMM.LE.0 .OR. IMM.GT.12) GOTO 900
  296.       IF(IYY.LE.0 .OR. IYY.GT.99) GOTO 900
  297. C
  298. C        FIGURE OUT IF ITS A LEAP YEAR  
  299. C
  300.       LEAPYR=(REAL(IYY)/4.0)-INT(REAL(IYY)/4.0) 
  301.       IF(LEAPYR .EQ. 0.0) DAYS(2)=29
  302.       IF(IDD.LE.0 .OR. IDD.GT.DAYS(IMM)) GOTO 900
  303. C
  304. C        NOW, CALCULATE THE JULIAN DATE
  305. C
  306.       IF(IMM.GT.1) THEN
  307.          DO 100 I=1,IMM-1
  308.          IJUL=IJUL+DAYS(I)
  309.   100    CONTINUE
  310.       ENDIF
  311.       IJUL=IJUL+IDD
  312.   900 CONTINUE
  313.       RETURN
  314.       END
  315. C
  316. C
  317. C
  318. C  *************************************************************************
  319. C  *                                                                       *
  320. C  *   These Routines imported from the PRO-350 library                    *
  321. C  *                                                                       *
  322. C  *************************************************************************
  323. C
  324. C
  325. C
  326.       SUBROUTINE EDCHR(HORZ,VERT,CHR1,LEN)
  327. C
  328. C        THIS ROUTINE IS A FULL-SCREEN CHARACTER PSUDO EDITOR
  329. C
  330.       IMPLICIT INTEGER (A-Z)
  331.       CHARACTER CHR*80,CHR1*80,FMT1*7,FMT2*5
  332. C
  333. C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
  334. C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2'
  335. C
  336.       IF(LEN.LE.0 .OR. LEN.GT.80) GOTO 900
  337.       WRITE(FMT1,'(A2,I2.2,A3)') '(A',LEN,',\)'
  338.       WRITE(FMT2,'(A2,I2.2,A1)') '(A',LEN,')'
  339. C
  340. C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
  341. C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
  342. C
  343.   100 CONTINUE
  344.       CALL UPTOP(HORZ,VERT)
  345.       CALL RVIDEO
  346.       WRITE(*,FMT1) CHR1
  347. C
  348. C          READ IN CHANGES
  349. C
  350.       CALL UPTOP(HORZ,VERT)
  351.       READ(*,FMT2,ERR=100) CHR
  352.       IF(CHR.NE.' ') CHR1=CHR
  353.       IF(CHR.EQ.'.') CHR1=' '
  354. C
  355. C          RE-DISPLAY CHARACTER
  356. C
  357.       CALL UPTOP(HORZ,VERT)
  358.       CALL OFF
  359.       WRITE(*,FMT1) CHR1
  360.   900 CONTINUE
  361.       RETURN
  362.       END
  363. C
  364. C
  365. C
  366.       SUBROUTINE EDNUM(HORZ,VERT,VAL1,LEN)
  367. C
  368. C          FULL SCREEN EDIT ROUTINE FOR INTEGER VALUES
  369. C
  370.       IMPLICIT INTEGER (A-Z)
  371.       CHARACTER FMT1*7,FMT2*8,FMT3*5,TEMP*80,HOLD*1
  372. C
  373. C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
  374. C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2,FMT3'
  375. C
  376.       IF(LEN.LE.0 .OR. LEN.GT.80) GOTO 900
  377.       WRITE(FMT1,'(A2,I2.2,A3)') '(I',LEN,',\)'
  378.       WRITE(FMT2,'(A5,I2.2,A1)') '(BN,I',LEN,')'
  379.       WRITE(FMT3,'(A2,I2.2,A1)') '(A',LEN,')'
  380. C
  381. C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
  382. C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
  383. C
  384.   100 CONTINUE
  385.       CALL UPTOP(HORZ,VERT)
  386.       CALL RVIDEO
  387.       WRITE(*,FMT1) VAL1
  388. C
  389. C          READ INPUT USING A CHARACTER VARIABLE
  390. C          IF THE ASCII EQUIV. IS 32, THEN NO CHANGE MADE
  391. C
  392.       CALL UPTOP(HORZ,VERT)
  393.       READ(*,FMT3,ERR=100) TEMP
  394.       HOLD=TEMP
  395.       IF(ICHAR(HOLD).NE.32) READ(TEMP,FMT2,ERR=100) VAL1
  396. C
  397. C          RE-WRITE THE VALUE
  398. C
  399.       CALL UPTOP(HORZ,VERT)
  400.       CALL OFF
  401.       WRITE(*,FMT1) VAL1
  402.   900 CONTINUE
  403.       RETURN
  404.       END
  405. C
  406. C
  407. C
  408.       SUBROUTINE EDREL(HORZ,VERT,VAL1,LEN)
  409. C
  410. C          FULL SCREEN EDIT ROUTINE FOR REAL VALUES
  411. C
  412.       IMPLICIT INTEGER (A-Z)
  413.       CHARACTER FMT1*9,FMT2*11,FMT3*5,TEMP*80,HOLD*1
  414.       REAL VAL1
  415. C
  416. C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
  417. C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2,FMT3'
  418. C
  419.       IF(LEN.LE.0 .OR. LEN.GT.80) GOTO 900
  420.       WRITE(FMT1,'(A2,I2.2,A5)') '(F',LEN,'.2,\)'
  421.       WRITE(FMT2,'(A5,I2.2,A4)') '(BN,F',LEN,'.0,)'
  422.       WRITE(FMT3,'(A2,I2.2,A1)') '(A',LEN,')'
  423. C
  424. C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
  425. C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
  426. C
  427.   100 CONTINUE
  428.       CALL UPTOP(HORZ,VERT)
  429.       CALL RVIDEO
  430.       WRITE(*,FMT1) VAL1
  431. C
  432. C          READ INPUT USING A CHARACTER VARIABLE
  433. C          IF THE ASCII EQUIV. IS 32, THEN NO CHANGE MADE
  434. C
  435.       CALL UPTOP(HORZ,VERT)
  436.       READ(*,FMT3,ERR=100) TEMP
  437.       HOLD=TEMP
  438.       IF(ICHAR(HOLD).NE.32) READ(TEMP,FMT2,ERR=100) VAL1
  439. C
  440. C          RE-WRITE THE VALUE
  441. C
  442.       CALL UPTOP(HORZ,VERT)
  443.       CALL OFF
  444.       WRITE(*,FMT1) VAL1
  445.   900 CONTINUE
  446.       RETURN
  447.       END
  448. C
  449. C
  450. C
  451.       SUBROUTINE EDATE(HORZ,VERT,DATE)
  452. C
  453. C          FULL SCREEN EDITOR FOR DATE VARIABLES
  454. C
  455.       IMPLICIT INTEGER (A-Z)
  456.       CHARACTER CHR*8,DATE*8,FMT1*6,FMT2*4
  457. C
  458. C          SET-UP FORMAT STATEMENTS BASED ON LENGTH OF VARIABLE
  459. C          AND STORE THEM IN THE CHARACTER VARIABLES 'FMT1,FMT2'
  460. C
  461.       FMT1='(A8,\)'
  462.       FMT2='(A8)'
  463. C
  464. C          DISPLAY THE NUMBER AT THE LOCATION REQUESTED
  465. C          AND PLACE THE CURSOR AT THE BEGINING OF THE FIELD
  466. C
  467.   100 CONTINUE
  468.       CALL UPTOP(HORZ,VERT)
  469.       CALL RVIDEO
  470.       WRITE(*,FMT1) DATE
  471. C
  472. C          READ IN CHANGES 
  473. C
  474.       CALL UPTOP(HORZ,VERT)
  475.       READ(*,FMT2,ERR=100) CHR
  476.       IF(CHR.EQ.'.') THEN
  477.          DATE=' ' 
  478.       ELSEIF(CHR.NE.' ') THEN
  479. C
  480. C             USE THE DAY-OF-WEEK SUBROUTINE TO TEST FOR VALID DATE
  481. C
  482.          CALL DATEDW(CHR,IDOW)
  483.          IF(IDOW.EQ.0) THEN
  484.             CALL UPTOP(HORZ,VERT)
  485.             CALL BELL
  486.             GOTO 100
  487.          ELSE
  488.             DATE=CHR
  489.          ENDIF
  490.       ENDIF
  491. C
  492. C          RE-DISPLAY CHARACTER
  493. C
  494.       CALL UPTOP(HORZ,VERT)
  495.       CALL OFF                      
  496.       WRITE(*,FMT1) DATE
  497.       RETURN
  498.       END
  499. C
  500. C
  501. C
  502.       SUBROUTINE WORKIN(HORZ,VERT)
  503. C
  504. C       This routine will display a blinking WORKING message
  505. C       at the specified screen position.
  506. C
  507.       INTEGER HORZ,VERT
  508.  
  509.       IF(HORZ.LT.1 .OR. HORZ.GT.80) GOTO 900
  510.       IF(VERT.LT.1 .OR. VERT.GT.24) GOTO 900
  511.  
  512.       CALL UPTOP(HORZ,VERT)
  513.       CALL BOLD
  514.       CALL BLINK
  515.          WRITE(*,'(1X,A13,\)') ' Working ... '
  516.       CALL OFF
  517.   900 CONTINUE
  518.       RETURN
  519.       END
  520. C
  521. C
  522. C
  523.       SUBROUTINE SHOWIT(UNIT)
  524. C
  525. C          This routine will display, one screen at a time,
  526. C          data from any file already OPENED.
  527. C
  528.       IMPLICIT INTEGER (A-Z)
  529.       CHARACTER DATA(50)*79,DIRECT*1,FMT*10
  530.       CHARACTER CMD*5,LCMD*5
  531. C
  532. C             First, define the scrolling region
  533. C
  534.       CALL MOVEIT(1,6)
  535.       WRITE(*,'(1X,A1,A1,I1,A1,I2,A1)') 27,'[',6,';',21,'r'
  536. C
  537. C             Now, draw the prompt line
  538. C
  539.       CALL UPTOP(1,22)
  540.       CALL BOLD
  541.       CALL ULINE
  542.       WRITE(*,50) 
  543.    50 FORMAT(80(' '))
  544.       CALL OFF
  545. C
  546. C             Now, read the file and display one screen at a time
  547. C
  548.       DIRECT=' '
  549.       CALL KEYOFF
  550.       CALL WORKIN(1,24)
  551.       CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
  552.       LSTART=START
  553. C
  554.       K=0
  555.       M=0
  556.       LNUM=15
  557.       WAY=1
  558.       CMD='D    '
  559. C
  560. C          START BY SAVING THE 'LAST COMMAND' (EITHER UP OR DOWN)
  561. C
  562.   100 CONTINUE
  563.       LCMD=CMD
  564. C
  565. C          NOW, TEST WERE I AM, AND OPERATE ON THAT CONDITION
  566. C          ... IF THE COUNTER K IS GREATER THAN THE NUMBER OF
  567. C              LINES TO SCROLL, THEN PROMPT FOR ANOTHER COMMAND
  568. C
  569.       IF(K.GE.LNUM) THEN
  570.          K=0
  571.   110    CONTINUE
  572.             CALL BOLD
  573.             CALL KEYON
  574.             CALL UPTOP(1,24)
  575.             WRITE(*,'(A9,A1,A3,\)') 'Command [',CMD,']: '
  576.             READ(*,'(A1,I3)',ERR=110) CMD,LNUM
  577.             IF(LNUM.LE.0 .OR. LNUM.GT.200) LNUM=15
  578.          CALL OFF
  579.             CALL UPTOP(1,24)
  580.             WRITE(*,'(A1,A3,A19,\)') 27,'[0K','Wait ...           '
  581.          CALL KEYOFF
  582.  
  583.          IF(CMD.EQ.'Q' .OR. CMD.EQ.'q') THEN
  584.             GOTO 900
  585.          ELSEIF(CMD.EQ.'P' .OR. CMD.EQ.'p') THEN
  586.             CMD=LCMD
  587.             CALL UPTOP(1,24)
  588.             WRITE(*,'(A19,\)') 'Wait ...           '
  589.             CALL BELL
  590.             CALL BOLD
  591.             CALL UPTOP(40,24)
  592.             WRITE(*,'(A38,\)') 'Printing Requested Document           '
  593.             CALL OFF
  594.             CALL PLOCAL(UNIT,FMT)
  595.             CALL BELL
  596.             CALL UPTOP(40,24)
  597.             WRITE(*,'(A38,\)') 'Document Printing Completed           '
  598.             GOTO 110
  599.          ELSEIF(CMD.EQ.'U' .OR. CMD.EQ.'u') THEN
  600.             CMD='U'
  601.             WAY=-1
  602.             IF(LCMD.EQ.'D') THEN
  603.                IF(MAX.GT.14) THEN
  604.                   M=M-14
  605.                ELSE
  606.                   M=M-MAX+1
  607.                ENDIF
  608.             ENDIF
  609.          ELSEIF(CMD.EQ.'D' .OR. CMD.EQ.'d') THEN
  610.             CMD='D'
  611.             WAY=1
  612.             IF(LCMD.EQ.'U') THEN
  613.                IF(MAX.GT.14) THEN
  614.                   M=M+14
  615.                ELSE
  616.                   M=M+MAX-1
  617.                ENDIF
  618.             ENDIF
  619.          ELSEIF(CMD.EQ.'T' .OR. CMD.EQ.'t') THEN
  620.             CMD='D'
  621.             M=-100
  622.             WAY=1
  623.             LNUM=15
  624.             CALL WIPE
  625.          ELSEIF(CMD.EQ.'B' .OR. CMD.EQ.'b') THEN
  626.             CMD='D'
  627.             M=-102
  628.             WAY=1
  629.             LNUM=15
  630.             CALL WIPE
  631.          ELSEIF(LCMD.EQ.'D') THEN
  632.             CMD='D'
  633.             WAY=1
  634.          ELSEIF(LCMD.EQ.'U') THEN
  635.             CMD='U'
  636.             WAY=-1
  637.          ENDIF
  638.       ENDIF
  639. C
  640. C           INCREMENT, THEN CHECK ARRAY LOCATION POINTER
  641. C
  642.       M=M+WAY
  643. C
  644. C           M=-99 MEANS A REQUEST FOR TOP OF FILE
  645. C           M=-101 MEANS REQUEST FOR BOTTOM OF FILE
  646. C
  647.       IF(M.EQ.-99) THEN
  648.          DIRECT='T'
  649.          CALL WORKIN(1,24)
  650.          CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
  651.          M=1
  652.       ELSEIF(M.EQ.-101) THEN
  653.          DIRECT='B'
  654.          CALL WORKIN(1,24)
  655.          CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
  656.          M=37
  657.       ELSEIF((M.GT.50) .OR. (M.GT.STOP)) THEN
  658.          IF(STOP.GE.MAX) THEN
  659.             CALL BELL
  660.             K=LNUM+1
  661.             M=M-WAY
  662.             GOTO 100
  663.          ELSE
  664.             DIRECT='D'
  665.             LSTART=START
  666.             CALL WORKIN(1,24)
  667.             CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
  668.             M=START-LSTART+1
  669.          ENDIF
  670.       ELSEIF(M.LT.1) THEN
  671.          IF(START.LE.1) THEN
  672.             CALL BELL
  673.             K=LNUM+1
  674.             M=M-WAY
  675.             GOTO 100
  676.          ELSE
  677.             DIRECT='U'
  678.             LSTART=START
  679.             CALL WORKIN(1,24)
  680.             CALL GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
  681.             M=LSTART-START
  682.          ENDIF
  683.       ENDIF
  684. C
  685. C         INCREMENT LINE COUNTER, MAKE SCREEN SCROLL EITHER UP OR DOWN
  686. C         THEN DISPLAY THE NEXT LINE OF DATA
  687. C
  688.       K=K+1
  689.       IF(CMD.EQ.'D') THEN
  690.          CALL UPTOP(1,21)
  691.          WRITE(*,'(1X,A,\)') DATA(M)
  692.       ELSEIF(CMD.EQ.'U') THEN
  693.          CALL UPTOP(1,6)
  694.          WRITE(*,'(1X,A1,A1,\)') 27,'M'
  695.          CALL UPTOP(1,6)
  696.          WRITE(*,'(1X,A,\)') DATA(M)
  697.       ENDIF
  698.       GOTO 100
  699. C
  700. C             Reset all terminal attributes, close print file
  701. C
  702.   900 CONTINUE
  703.       CALL KEYON
  704.       WRITE(*,'(1X,A1,A1,I1,A1,I2,A1)') 27,'[',1,';',24,'r'
  705.       RETURN
  706.       END
  707. C
  708. C
  709. C
  710.       SUBROUTINE WIPE
  711. C
  712. C           WIPES THE SCROLLING REGION CLEAN
  713. C
  714.       CALL UPTOP(1,5)
  715.       WRITE(*,'(1X,A1,A3)') 27,'[2K'
  716.       DO 200 K=1,16
  717.       WRITE(*,'(1X,A1,A3)') 27,'[2K'
  718.   200 CONTINUE
  719.       RETURN
  720.       END
  721. C
  722. C
  723. C
  724.       SUBROUTINE GRAB(DATA,DIRECT,START,STOP,MAX,UNIT,FMT)
  725. C
  726. C          This routine will grab 50 lines of data from a file
  727. C
  728.       IMPLICIT INTEGER (A-Z)
  729.       CHARACTER DATA(50)*79,DIRECT*1,PAGE*1,FMT*10
  730. C
  731. C        IF THIS IS THE FIRST TIME IN, FIND THE BOTTOM OF THE FILE
  732. C        OTHERWISE, SET NEW LOCATION POINTER
  733. C
  734.       IF(DIRECT.EQ.' ') THEN
  735.          INC=0
  736.          MAX=0
  737.          CLOC=0
  738.          START=0
  739.          STOP=0
  740.          FMT='(1X,A)'
  741.          REWIND UNIT
  742.    10    CONTINUE
  743.          READ(UNIT,'(A1)',END=20) PAGE
  744.          IF(PAGE.NE.' ' .AND. PAGE.NE.'1') FMT='(A)'
  745.          MAX=MAX+1
  746.          GOTO 10
  747.    20    CONTINUE
  748.       ELSEIF(DIRECT.EQ.'T') THEN
  749.          CLOC=0
  750.          INC=0
  751.       ELSEIF(DIRECT.EQ.'B') THEN
  752.          CLOC=MAX-49
  753.          INC=0
  754.       ELSEIF(DIRECT.EQ.'U') THEN
  755.          INC=75
  756.       ELSE
  757.          INC=25
  758.       ENDIF
  759.  
  760.       CLOC=CLOC-INC
  761.       IF(CLOC.LE.0) CLOC=1
  762. C
  763. C         LOG THE NEW STARTING POSTITION, AND IF IT IS
  764. C         NOT=1, THEN BACKUP FROM THE CURRENT POSTITION
  765. C         TO THE NEW STARTING POSITION
  766. C
  767.       START=CLOC
  768.       REWIND UNIT
  769.       IF(START.GT.1) THEN
  770.          DO 50 I=1,START-1
  771.          READ(UNIT,'(1X)')
  772.    50    CONTINUE
  773.       ENDIF
  774. C
  775. C        READ IN 50 LINES OF DATA FROM REQUESTED LOCATION
  776. C
  777.       DO 75 M=1,50
  778.       READ(UNIT,FMT,END=80) DATA(M)
  779.       CLOC=CLOC+1
  780.    75 CONTINUE
  781.    80 CONTINUE
  782. C
  783. C         IF THE BUFFER IS NOT FULL, PAD IT WITH BLANK RECORDS
  784. C
  785.       STOP=CLOC-1
  786.       IF(M.LT.50) THEN
  787.          DO 175 K=M,50
  788.          DATA(K)=' '
  789.   175    CONTINUE
  790.       ENDIF
  791.  
  792.       RETURN
  793.       END
  794. C
  795. C
  796. C
  797.       SUBROUTINE PLOCAL(UNIT,FMT)
  798. C
  799. C        THIS ROUTINE SPOOLS FILE TO THE PRINTER
  800. C
  801.       IMPLICIT INTEGER (A-Z)
  802.       CHARACTER FMT*10,DATA*80,PAGE*1
  803.  
  804.       IPAGE=0
  805.       REWIND UNIT
  806.       OPEN(UNIT=2,FILE='PRN')
  807.  
  808.   100 CONTINUE
  809.       IF(FMT.EQ.'(A)') THEN
  810.          READ(UNIT,'(A80)',END=900,ERR=900) DATA
  811.          WRITE(2,'(1X,A80)') DATA
  812.       ELSE
  813.          READ(UNIT,'(A1,A79)',END=900,ERR=900) PAGE,DATA
  814.          IF(PAGE.EQ.'1') THEN
  815.             IPAGE=IPAGE+1
  816.             WRITE(2,'(1H1)')
  817.             CALL UPTOP(70,24)
  818.             IF(IPAGE.LE.99) WRITE(*,'(A4,I2,\)') 'Page',IPAGE
  819.          ENDIF
  820.          WRITE(2,'(1X,A79)') DATA
  821.       ENDIF
  822.       GOTO 100
  823.   900 CONTINUE
  824.  
  825.       CLOSE(2)
  826.       RETURN
  827.       END
  828. C
  829. C
  830. C
  831.       SUBROUTINE BOX(HEIGHT,WIDTH,LEFTH,LEFTV,TITLE,TTLEN,TTATTR,BXATTR)
  832. CC
  833. CC
  834. CC    Created on  :  May 19, 1987
  835. CC    Last Updated:  June 1, 1987
  836. CC    Written by  :  Bruce W. Roeckel
  837. CC
  838. CC    Description :  This routine will draw a box, using the VT100
  839. CC                   graphic character set, at the specified position
  840. CC                   on the screen.
  841. CC
  842. CC                   HEIGHT -- how tall the box is
  843. CC                   WIDTH  -- how wide the box is
  844. CC                   LEFTH --- the horizontal position of the left
  845. CC                             hand corner
  846. CC                   LEFTV --- the vertical position of the left
  847. CC                             hand corner
  848. CC                   TITLE --- a character variable that will be used
  849. CC                             as the title block to the box.
  850. CC                   TTLEN --- Length of the title (# of Characters)
  851. CC                   TTATTR -- attributes to use for title block
  852. CC
  853. CC                          Box   NoBox
  854. CC                           10     0 = Normal Characters
  855. CC                           11     1 = inverse video
  856. CC                           12     2 = bold
  857. CC                           13     3 = blink
  858. CC                           14     4 = inverse video, bold
  859. CC                           15     5 = inverse video, blink
  860. CC                           16     6 = bold, blink
  861. CC                           17     7 = inverse video, bold, blink
  862. CC
  863. CC                   BXATTR -- box attribute. Decimal zero (0) is clear
  864. CC                             box, one (1) is inverse video box.
  865. CC
  866. CC
  867. CC
  868. CC    Update #    Name       Date          Comments
  869. CC    --------  ---------  --------  ----------------------------------
  870. CC       001    Roeckel    05-22-87  Added Boxed/NoBoxed title option
  871. CC       002    Roeckel    06-01-87  Only paints entire screen if
  872. CC                                   inverse video box selected
  873. CC
  874. CC
  875.       IMPLICIT INTEGER (A-Z)
  876.       CHARACTER*1 TLC,TRC,BLC,BRC,VLINE(80),HLINE,RCON,LCON
  877.       CHARACTER TEMP*80,TITLE*40,RELOC*11,FMT1*20
  878. C
  879. C         DEFINE THE GRAPHICS CHARACTERS
  880. C
  881.       TLC='l'
  882.       TRC='k'
  883.       BLC='m'
  884.       BRC='j'
  885.       HLINE='x'
  886.       RCON='t'
  887.       LCON='u'
  888.  
  889.       DO 10 K=1,80
  890.       VLINE(K)='q'
  891.    10 CONTINUE
  892. C
  893. C          MOVE LINE DRAWING CHARACTER SET INTO "G1"
  894. C
  895.       UNIT=0 
  896.       CALL GCHAR(UNIT)
  897. C
  898. C          CHECK IF SELECTED POSITION IS O.K.
  899. C
  900.       IF((LEFTH.GE.1 .AND. LEFTH.LE.80) .AND.
  901.      A   (LEFTV.GE.1 .AND. LEFTV.LE.24)) THEN
  902. C
  903. C        .... SET TERMINAL INTO GRAPHICS MODE
  904. C
  905.          IF(BXATTR.EQ.1) CALL RVIDEO
  906.          CALL GPHON(UNIT)
  907. C
  908. C        .... STARTING AT THE LEFT HAND CORNER, DRAW THE TOP
  909. C
  910.          CALL LOCATE(LEFTH,LEFTV,RELOC)
  911.          WRITE(*,50) RELOC,TLC,(VLINE(K),K=1,WIDTH-2),TRC
  912.    50    FORMAT(A11,80A1,$)
  913. C
  914. C        .... NOW START DOWN THE SIDES
  915. C
  916.          IF(BXATTR.EQ.1) THEN
  917.  
  918.             WRITE(FMT1,'(A8,I2.2,A5)') '(A11,A1,',WIDTH-2,'X,A1)'
  919.             DO 100 I=1,HEIGHT-2
  920.             CALL LOCATE(LEFTH,LEFTV+I,RELOC)
  921.             WRITE(*,FMT1) RELOC,HLINE,HLINE
  922.   100       CONTINUE
  923.  
  924.          ELSE
  925.  
  926.             DO 110 I=1,HEIGHT-2
  927.             CALL LOCATE(LEFTH,LEFTV+I,RELOC)
  928.             WRITE(*,'(A11,A1)') RELOC,HLINE
  929.             CALL LOCATE(LEFTH+WIDTH-1,LEFTV+I,RELOC)
  930.             WRITE(*,'(A11,A1)') RELOC,HLINE
  931.   110       CONTINUE
  932.  
  933.          ENDIF
  934. C
  935. C        .... AND FINALLY DRAW THE BOTTOM
  936. C
  937.          CALL LOCATE(LEFTH,LEFTV+HEIGHT-1,RELOC)
  938.          WRITE(*,50) RELOC,BLC,(VLINE(K),K=1,WIDTH-2),BRC
  939. C
  940. C        .... SEE IF A TITLE BLOCK WAS REQUESTED
  941. C
  942.          IF(TTLEN.GT.0) THEN
  943. C
  944. C           .... CENTER THE TITLE
  945. C
  946.             DIFF = WIDTH/2 - (TTLEN+2)/2
  947.             IF(DIFF.LE.0) DIFF=0
  948.             TEMP=TITLE
  949.             CALL JUSTIF('CENTER',TEMP,TTLEN)
  950. C
  951. C           .... CHECK IF TITLE SHOULD BE BOXED IN
  952. C
  953.             IF(TTATTR.GE.10) THEN
  954. C
  955. C                   MUST MOVE UP ONE LINE FOR TOP OF TITLE BOX
  956. C
  957.                CALL LOCATE(LEFTH+DIFF-1,LEFTV-1,RELOC)
  958.                WRITE(*,50) RELOC,TLC,(VLINE(K),K=1,TTLEN+2),TRC
  959. C
  960. C                   DRAW IN THE CONNECTORS
  961. C
  962.                WRITE(FMT1,'(A8,I2.2,A5)') '(A11,A1,',TTLEN+2,'X,A1)'
  963.                CALL LOCATE(LEFTH+DIFF-1,LEFTV,RELOC)
  964.                WRITE(*,FMT1) RELOC,LCON,RCON
  965. C
  966. C                   DRAW THE BOTTOM OF THE TITLE BOX
  967. C
  968.                CALL LOCATE(LEFTH+DIFF-1,LEFTV+1,RELOC)
  969.                WRITE(*,50) RELOC,BLC,(VLINE(K),K=1,TTLEN+2),BRC
  970.  
  971.             ENDIF
  972. C
  973. C           .... NOW INSERT THE TITLE
  974. C
  975.             CALL OFF
  976.             CALL GPHOFF(UNIT)
  977.             IF(TTATTR.GT.10) TTATTR=TTATTR-10
  978.             IF(TTATTR.EQ.1 .OR. TTATTR.EQ.4 .OR. TTATTR.EQ.5 .OR.
  979.      A         TTATTR.EQ.7) CALL RVIDEO
  980.             IF(TTATTR.EQ.2 .OR. TTATTR.EQ.4 .OR. TTATTR.EQ.6 .OR.
  981.      A         TTATTR.EQ.7) CALL BOLD
  982.             IF(TTATTR.EQ.3 .OR. TTATTR.EQ.5 .OR. TTATTR.EQ.6 .OR.
  983.      A         TTATTR.EQ.7) CALL BLINK
  984.  
  985.             WRITE(FMT1,'(A6,I2.2,A1)') '(A11,A',TTLEN,')'
  986.             CALL LOCATE(LEFTH+DIFF+1,LEFTV,RELOC)
  987.             WRITE(*,FMT1) RELOC,TEMP
  988.  
  989.             CALL OFF
  990.  
  991.          ELSE
  992.  
  993.             CALL GPHOFF(UNIT)
  994.             CALL OFF
  995.  
  996.          ENDIF
  997.       ENDIF
  998.       RETURN
  999.       END
  1000.  
  1001.