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