SUBROUTINE TK4105(X,Y,IND) * THIS ROUTINE WILL HANDLE TEKTRONIX 4105, 4107, AND 4115 TERMINALS C C Notice of Public Domain nature of this Program C C 'This computer program is a work of the United States C Government and as such is not subject to protection by C copyright (17 U.S.C. # 105.) Any person who fraudulently C places a copyright notice or does any other act contrary C to the provisions of 17 U.S. Code 506(c) shall be subject C to the penalties provided therein. This notice shall not C be altered or removed from this software and is to be on C all reproductions.' C c c Modification #1 - 3/11/87, Dr. Joseph M. Leonard (jle) c c This modification is an attempt to alter the graphics i/o of c Stewart's DRAW program to use unformatted block i/o (a la MMADS c Graphics Library). c c Kludge #1 of Modification #1 - 3/11/87 (jle) c Partially link IND=99 to use the buffer flushing. c c Storch: verified use of unformatted i/o is ca. 88% faster c Changing TEKSTR to call TEKOUT for coordinates. c CHARACTER*1 ESC, FF, SI, SO, CAR, ASCII CHARACTER*5 TEKCOR, STEMP CHARACTER*4 TEKINT CHARACTER*80 REPLY COMMON /ASCIIC/ ASCII( 0: 255) COMMON /DEVICE/ ITYPE, ISCRN, KOROFF COMMON/ OUTPUT/ IPAPER,IPAGE LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /TK41XX/ MINX,MAXX,MINY,MAXY INTEGER PIXROW, PIXCOL, PIXEL COMMON /TERM/ IMAXR, IMAXC, PIXROW, PIXCOL, PIXEL, LCOUNT, INGRAF, . IXL, IXR, IYT, IYB, NCOLOR, MCOLOR( 64 ), ITTRM, . MARGX, MARGY * VARIABLES IN COMMON TERM: * IMAXR = MAX NUMBER OF ROWS * IMAXC = MAX NUMBER OF COLUMNS * PIXROW = NUMBER OF PIXELS PER ROW * PIXCOL = NUMBER OF PIXELS PER COLUMN * PIXEL = LESSER OF PIXROW OR PIXCOL * LCOUNT = NUMBER OF LINES CURRENTLY WRITTEN TO DIALOG AREA * INGRAF = 0=> HOST TEXT GOES TO MONITOR SPACE\\ 1=> TEXT TO GRAPHICS * IXL = LEFT MOST VALUE OF X * IXR = RIGHT MOST VALUE OF X * IYT = VALUE OF Y AT TOP OF SCREEN * IYB = VALUE OF Y AT BOTTOM OF SCREEN * NCOLOR = NUMBER OF COLORS IN MCOLOR MAP * MCOLOR = MAP OF COLORS * ITTRM = UNIQUE MODEL NUMBER OF GENERAL TERMINAL TYPE * MARGX = NUMBER OF PIXELS PADDED TO X-COORDINATE * MARGY = NUMBER OF PIXELS PADDED TO Y-COORDINATE * * EQUIVALENCE ( ESC, ASCII(27)), ( FF, ASCII(12)), (SI, ASCII(15)) EQUIVALENCE ( SO, ASCII(14)), ( CAR, ASCII(13)) * * CODES FOR IND: C * IND = 0 => REMOVE ALL GRAPHICS TO QUIT * IND = 1 => ANY ONE TIME ONLY INITIALIZATION * IND = 2 => MOVE GRAPHICS TO POINT (X,Y) -- DO NOT DRAW LINE * IND = 3 => DRAW LINE FROM LAST POINT TO NEW (X,Y) * IND = 4 => DRAW DARK LINE * IND = 5 => DRAW BRIGHT SOLID LINE * IND = 6 => INITIALIZE & SET-UP FOR NEXT PICTURE * IND = 8 => TEMPORARY RELEASE FROM GRAPHICS * IND = 9 => RETURN TO GRAPHICS FROM TEMP RELEASE * IND =10 => DONE DRAWING PICTURE * * IND =99 => SET COLOR TO VALUE IN X * * * ** FORMAT TO REDUCE EXTRA CHARACTERS 2000 FORMAT ( '+', A $) c? 2000 FORMAT ( ' ',A ) C IF (IND.EQ.0) THEN C * ALL DONE -- CLEAR TERMINAL AND WE WILL QUIT * *** CLEAR SCREEN (NEEDS TWO COMMANDS) * *** FIRST WE CLEAR THE DIALOG AREA WRITE (*,2000) ESC//'LZ' IF ( ITRRM .EQ. 4105) THEN CONTINUE ELSEIF ( ITRRM .EQ. 4107 .OR. ITRRM .EQ. 4106) THEN * if this is 4107, delete all segments STEMP = TEKINT( -1) ITEMP = INDEX( STEMP, CAR) IF ( ITEMP .GT. 0 ) THEN WRITE ( *, 2000 ) ESC//'SK'//STEMP(:ITEMP ) ELSE WRITE ( *, 2000 ) ESC//'SK'//STEMP ENDIF * delete all views and set current view to 1 STEMP = TEKINT( -1) ITEMP = INDEX( STEMP, CAR) WRITE ( *, 2000 ) ESC//'RK'//STEMP(:ITEMP-1) CALL RESCOL * RETURN THE QUEUESIZE TO 300 ELSEIF ( ITRRM .EQ. 4131) THEN * if this is 4115, delete all segments STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'SK'//STEMP(:INDEX(STEMP, CAR)-1) * delete all views and set current view to 1 STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'RK'//STEMP(:INDEX(STEMP, CAR)-1) CALL RESCOL ENDIF * *** SECOND WE CLEAR THE GRAPHIC AREA WRITE (*,2000) ESC//FF * *** SELECT GREEN TEXT IN DIALOG AREA WRITE (*,2000) ESC//'LI300' * NEED TO CLEAR DIALOG AREA ( ESPECIALLY FOR 4115b ) * *** FIRST MAKE IT INVISIBLE WRITE (*,2000) ESC//'LV0' * *** CREATE DIALOG AREA STEMP = TEKINT( 30) WRITE ( *, 2000) ESC//'LL'//STEMP(:INDEX(STEMP, CAR)-1) * *** SET BUFFER AREA FOR DIALOG AREA STEMP = TEKINT( 39) WRITE ( *, 2000) ESC//'LB'//STEMP(:INDEX(STEMP, CAR)-1) * *** ENABLE DIALOG AREA WRITE (*,2000) ESC//'KA1' * AND NOW WE MAKE IT VISIBLE AGAIN WRITE (*,2000) ESC//'LV1' * ** WE RESTORE THE ORIGINAL CODE VALUE IF ( ICODE.EQ.1 .OR. ICODE.EQ.2) THEN * *** AND BACK TO ANSI (VT-100) OR EDIT MODE WRITE( *,2000) ESC//'%!'//CHAR(ICODE+48) * *** SET EDIT MARGINS TO 1,30 WRITE (*,2000) ESC//'[1;30r' * *** INVOKE G0 CHARACTER SET AND SELECTCHARSET ASCII WRITE (*,2000) ESC//SI//'(B' INGRAF = 0 ELSEIF( ICODE.EQ. 0) THEN * *** TEK MODE IS CURRENT CONTINUE ELSEIF( ICODE.EQ.3) THEN * *** VT52 MODE WRITE( *,2000) ESC//'%!'//CHAR(ICODE+48) ELSE WRITE (*,*) 'UNKNOWN CODE VALUE IN TK4105 IND=0' ENDIF ELSEIF (IND.EQ.1) THEN * ONE TIME ONLY INITIALIZATION OF TERMINAL (IF NEEDED) * NUMBER OF LINES DISPLAYED IN DIALOG AREA IDLINE = 8 * NUMBER OF LINES BUFFERED FOR DIALOG AREA IDBUFF = 15 * DEFAULT WINDOW CORNERS IXL = 0 IXR = 4095 IYT = 0 IYB = 3132 * ***** IMAXR = 30 IMAXC = 80 MARGX = 0 C?? MARGY = 800 MARGY = 800 - 800 / IPAGE c?? PIXEL = ( IYB - IYT - MARGY ) * IPAGE / 100. PIXEL = ( IYB - IYT - 1000 ) * IPAGE / 100. C * *** HAVE TERMINAL REPORT SYNTAX MODE WHICH WE'LL SAVE WRITE (*,2000) ESC//'#!0' 10 READ (*, '(A)' ) REPLY * Valid replies have form lll%!# where * lll is any number of characters and * # is a single ascii digit; 0 is TEK mode ITEMP = INDEX ( REPLY, '%!') + 2 IF ( ITEMP .LE. 2 ) GOTO 10 ICODE = ICHAR( REPLY( ITEMP+2: ITEMP+2) ) - 48 IF ( DEBUGP) THEN WRITE (*,*) 'TERMINAL CODE IS ',ICODE ENDIF * *** SWITCH TERMINAL TO TEKTRONIX MODE IF NECESSARY IF ( ICODE .NE. 0) WRITE (*,2000) ESC//'%!0' * LET'S FIND-OUT WHAT KIND OF 41xx TERMINAL WE HAVE WRITE (*,2000) ESC//'IQ?T' 11 READ (*, '( A )' ) REPLY * NOW WE SEND THE "CANCEL-BYPASS-CHARACTER" ITEMP = INDEX ( REPLY,'?T') + 2 IF ( ITEMP .LE. 2 ) GOTO 11 c! ITRRM = (ICHAR( REPLY( ITEMP: ITEMP) ) - 32 ) * 2**10 ITRRM = (ICHAR( REPLY( ITEMP: ITEMP) ) - 32 ) * 1024 c! ITRRM = ITRRM + (ICHAR( REPLY( ITEMP+1: ITEMP+1) ) - 32 )*2**5 ITRRM = ITRRM + (ICHAR( REPLY( ITEMP+1: ITEMP+1) ) - 32 )*32 ITRRM = ITRRM + (ICHAR( REPLY( ITEMP+2: ITEMP+2) ) - (32+16) ) ITTRM = ITRRM IF (DEBUGP) THEN WRITE (*,2000) ESC//'KA1' WRITE (*,*) 'terminal is TK', ITRRM ENDIF ISCRN = 26 C? KOROFF = 1 IF ( ITRRM .EQ. 4105) THEN NCOLOR = 7 ELSEIF ( ITRRM .EQ. 4107 .OR. ITRRM .EQ. 4106) THEN IF ( ITRRM .EQ. 4106 ) ISCRN=8 NCOLOR = 15 * SET THE QUEUESIZE BASED UPON TERMINAL TYPE IF ( ITRRM .EQ. 4106) THEN * SET THE QUEUESIZE TO 200 WRITE ( *, 2000 ) ESC//'NQL0' ELSE * SET THE QUEUESIZE TO 4096 WRITE ( *, 2000 ) ESC//'NQD@0' ENDIF * if this is 4107, delete all segments STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'SK'//STEMP(:INDEX(STEMP, CAR)-1) * delete all views and set current view to 1 STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'RK'//STEMP(:INDEX(STEMP, CAR)-1) * set fixup level to 2 so updates are done fast WRITE ( *, 2000 ) ESC//'RF2' CALL RESCOL ELSEIF ( ITRRM .EQ. 4131) THEN NCOLOR = 15 * if this is 4115, delete all segments STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'SK'//STEMP(:INDEX(STEMP, CAR)-1) * delete all views and set current view to 1 STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'RK'//STEMP(:INDEX(STEMP, CAR)-1) * set fixup level to 2 so updates are done fast WRITE ( *, 2000 ) ESC//'RF2' CALL RESCOL ELSE * if none of above, set default NCOLOR = 1 WRITE (*,2000) ESC//'KA1' WRITE (*,*) 'UNRECOGNIZED TERMINAL TYPE=',ITRRM ENDIF * NOW SET COLOR MAP KLOCAL = 1 DO 115 J=1, 64-NCOLOR, NCOLOR DO 115 I=1, NCOLOR MCOLOR( KLOCAL ) = I KLOCAL = KLOCAL + 1 115 CONTINUE * *** CLEAR SCREEN (NEEDS TWO COMMANDS) * *** FIRST WE CLEAR THE DIALOG AREA WRITE (*,2000) ESC//'LZ' * *** SECOND WE CLEAR THE GRAPHIC AREA WRITE (*,2000) ESC//FF * *** DISABLE DIALOG AREA WRITE (*,2000) ESC//'KA0' * *** CREATE DIALOG AREA STEMP = TEKINT( IDLINE) WRITE ( *, 2000 ) ESC//'LL'//STEMP(:INDEX(STEMP, CAR)-1) * *** SET BUFFER AREA FOR DIALOG AREA STEMP = TEKINT( IDBUFF) WRITE ( *, 2000 ) ESC//'LB'//STEMP(:INDEX(STEMP, CAR)-1) * *** SELECT GREEN TEXT IN DIALOG AREA IF ( ITTRM .EQ. 4105 ) THEN WRITE (*,2000) ESC//'LI300' ELSE WRITE (*,2000) ESC//'LI300' ENDIF * *** SELECT WHITE LINES IN DRAWING WRITE (*,2000) ESC//'ML1' * *** ENABLE DIALOG AREA WRITE (*,2000) ESC//'KA1' ELSEIF (IND.EQ.2 ) THEN * MOVE TO NEW POINT WITHOUT DRAWING LINE (PEN-UP) IXLX = X * PIXEL + MARGX IYLY = Y * PIXEL + MARGY IF (DEBUGP) THEN WRITE (*,2000) ESC//'KA1' WRITE (*,*) 'IND=2; SCALED COORD:',IXLX,IYLY ENDIF CALL TEKCRD(IXLX,IYLY,TEKCOR) c WRITE (*,2000) ESC//'LF'//TEKCOR call tekout(8,esc//'LF'//tekcor) ELSEIF (IND.EQ.3) THEN * DRAW LINE FROM LAST POINT TO NEW POINT IXLX = X * PIXEL + MARGX IYLY = Y * PIXEL + MARGY IF (DEBUGP) THEN WRITE (*,2000) ESC//'KA1' WRITE (*,*) 'IND=2; SCALED COORD:',IXLX,IYLY ENDIF CALL TEKCRD(IXLX,IYLY,TEKCOR) c WRITE (*,2000) ESC//'LG'//TEKCOR call tekout(8,esc//'LG'//tekcor) ELSEIF (IND.EQ.4) THEN c WRITE (*,2000) ESC//'ML'//CHAR(64+0)//CHAR(32+16+0) call tekout(5,esc//'ML'//char(64+0)//char(32+16+0)) ELSEIF (IND.EQ.5) THEN c WRITE (*,2000) ESC//'ML'//CHAR(64+0)//CHAR(32+16+1) call tekout(5,esc//'ML'//char(64+0)//char(32+16+1)) ELSEIF (IND.EQ.6) THEN * INITIALIZE FOR DRAWING NEXT PICTURE * NUMBER OF LINES DISPLAYED IN DIALOG AREA IDLINE = 8 * NUMBER OF LINES BUFFERED FOR DIALOG AREA IDBUFF = 15 * ***** * We must re-compute PIXEL incase user alters IPAGE MARGY = 800 - 800 / IPAGE c?? PIXEL = ( IYB - IYT - MARGY ) * IPAGE / 100. PIXEL = ( IYB - IYT - 1000 ) * IPAGE / 100. C * *** NEXT DISABLE THE DIALOG AREA SO THE * COORDINATES APPEAR IN GRAPHIC REGION WRITE (*,2000) ESC//'KA0' * *** SET WINDOW ??? I DONT KNOW WHAT SETTINGS YET * WRITE (*,2000) ESC//'RW'// * here we do special TERMINAL junk IF ( ITRRM .EQ. 4105) THEN NCOLOR = 7 ELSEIF ( ITRRM .EQ. 4107 .OR. ITRRM .EQ. 4106) THEN NCOLOR = 15 * delete all segments STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'SK'//STEMP(:INDEX(STEMP, CAR)-1) * delete all views and set current view to 1 STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'RK'//STEMP(:INDEX(STEMP, CAR)-1) * set viewport to normal value (0,0) AND (4095,3071) CALL TEKCRD( 0, 0, STEMP) CALL TEKCRD( 4095, 3071, TEKCOR) WRITE ( *, 2000 ) ESC//'RV'//STEMP//TEKCOR * AND set window to normal value (0,0) AND (4095,3136) CALL TEKCRD( 0, 0, STEMP) CALL TEKCRD( 4095, 3136, TEKCOR) WRITE ( *, 2000 ) ESC//'RW'//STEMP//TEKCOR * set pivot point to (0,0) CALL TEKCRD ( 0.0, 0.0, TEKCOR) WRITE ( *, 2000) ESC//'SP'//TEKCOR * and now we open a segment so we can zoom and pan C? STEMP = TEKINT( 1) C? WRITE ( *, 2000 ) ESC//'SE'//STEMP(:INDEX(STEMP, CAR)-1) WRITE ( *, 2000 ) ESC// 'SE1' ELSEIF ( ITRRM .EQ. 4131) THEN NCOLOR = 15 * delete all segments STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'SK'//STEMP(:INDEX(STEMP, CAR)-1) * delete all views and set current view to 1 STEMP = TEKINT( -1) WRITE ( *, 2000 ) ESC//'RK'//STEMP(:INDEX(STEMP, CAR)-1) * set viewport to normal value (0,0) AND (4095,3071) CALL TEKCRD( 0, 0, STEMP) CALL TEKCRD( 4095, 3071, TEKCOR) WRITE ( *, 2000 ) ESC//'RV'//STEMP//TEKCOR * AND set window to normal value (0,0) AND (4095,3136) CALL TEKCRD( 0, 0, STEMP) CALL TEKCRD( 4095, 3136, TEKCOR) WRITE ( *, 2000 ) ESC//'RW'//STEMP//TEKCOR * set pivot point to (0,0) CALL TEKCRD ( 0.0, 0.0, TEKCOR) WRITE ( *, 2000) ESC//'SP'//TEKCOR * and now we open a segment so we can zoom and pan STEMP = TEKINT( 1) WRITE ( *, 2000 ) ESC//'SE'//STEMP(:INDEX(STEMP, CAR)-1) ENDIF * *** WE CLEAR THE GRAPHIC AREA WRITE (*,2000) ESC//FF ELSEIF (IND.EQ.8) THEN * TEMPORARY RELEASE FROM GRAPHICS (USUALLY FOR TEXT) call tekfls WRITE (*,2000) ESC//'LV1'//ESC//'KA1' C? WRITE (*,2000) ESC//'KA1' INGRAF = 0 ELSEIF (IND.EQ.9) THEN * RETURN TO GRAPHICS FROM TEMPORARY RELEASE WRITE (*,2000) ESC//'LV0' C# WRITE (*,2000) ESC//'KA0' INGRAF = 1 ELSEIF (IND.EQ.10) THEN * DONE DRAWING PICTURE IF ( ITRRM .EQ. 4105) THEN call tekfls CONTINUE ELSEIF ( ITRRM .EQ. 4107 .OR. ITRRM .EQ. 4106) THEN * now we end the segment WRITE ( *, 2000 ) ESC//'SC' ELSEIF ( ITRRM .EQ. 4131) THEN * now we end the segment WRITE ( *, 2000 ) ESC//'SC' ENDIF WRITE (*,2000) ESC//'LV1' WRITE (*,2000) ESC//'KA1' ELSEIF (IND.EQ.99) THEN * CHANGE COLOR OF LINE ICOLOR = MAX( 1, INT( X + 0.5 ) ) ICOLOR = MIN( ICOLOR, NCOLOR ) STEMP = TEKINT( MCOLOR( ICOLOR) ) c WRITE (*, 2000) ESC//'ML'//STEMP(:INDEX(STEMP,CAR)-1) call tekout(3+index(stemp,car)-1,esc//'ML'// 1 stemp(:index(stemp,car)-1)) * ALSO CHANGE COLOR OF TEXT TO MATCH c!st WRITE (*, 2000) ESC//'MT'//STEMP(:INDEX(STEMP,CAR)-1) call tekout(3+index(stemp,car)-1,esc//'MT'// 1 stemp(:index(stemp,car)-1)) ELSE * WE HAVE AN ERROR IN IND WRITE (*,*) ' ERROR IN PLOT, IND=',IND ENDIF RETURN END CHARACTER*4 FUNCTION TEKINT( IINT) CHARACTER STEMP*4, CAR*1, NULL*1, ASCII COMMON /ASCIIC/ ASCII( 0: 255) EQUIVALENCE ( NULL, ASCII(0)), ( CAR, ASCII( 13)) ITEMP = IINT INDX = 1 ISSIGN = SIGN( 1, ITEMP ) ITEMP = ABS( ITEMP) c! I1 = ITEMP/2**10 I1 = ITEMP/1024 IF ( I1 .GT. 0 ) THEN STEMP( INDX: INDX) = ASCII( I1 + 64) INDX = INDX + 1 ENDIF c! I2 = ( MOD( ITEMP, 2**10) ) / 2**4 I2 = ( MOD( ITEMP, 1024) ) / 16 IF ( I2 .GT. 0 .OR. I1 .GT. 0 ) THEN STEMP( INDX: INDX) = ASCII( I2 + 64) INDX = INDX + 1 ENDIF c! I3 = MOD( ITEMP, 2**4) I3 = MOD( ITEMP, 16) c! IF ( ISSIGN .GT. 0) I3 = I3 + 2**4 IF ( ISSIGN .GT. 0) I3 = I3 + 16 STEMP( INDX: INDX) = ASCII( I3 + 32) INDX = INDX + 1 IF ( INDEX .LT. 4 ) THEN STEMP( INDX: INDX) = CAR TEKINT = STEMP( : INDX+1) ELSE TEKINT = STEMP ENDIF RETURN END SUBROUTINE TEKCRD( INX, INY, TEKCOR) IMPLICIT INTEGER (A-Z) INTEGER PIXROW, PIXCOL, PIXEL COMMON /TERM/ IMAXR, IMAXC, PIXROW, PIXCOL, PIXEL, LCOUNT, INGRAF, . IXL, IXR, IYT, IYB, NCOLOR, MCOLOR( 64 ), ITTRM, . MARGX, MARGY * VARIABLES IN COMMON TERM: * IMAXR = MAX NUMBER OF ROWS * IMAXC = MAX NUMBER OF COLUMNS * PIXROW = NUMBER OF PIXELS PER ROW * PIXCOL = NUMBER OF PIXELS PER COLUMN * PIXEL = LESSER OF PIXROW OR PIXCOL * LCOUNT = NUMBER OF LINES CURRENTLY WRITTEN TO DIALOG AREA * INGRAF = 0=> HOST TEXT GOES TO MONITOR SPACE\\ 1=> TEXT TO GRAPHICS * IXL = LEFT MOST VALUE OF X * IXR = RIGHT MOST VALUE OF X * IYT = VALUE OF Y AT TOP OF SCREEN * IYB = VALUE OF Y AT BOTTOM OF SCREEN * NCOLOR = NUMBER OF COLORS IN MCOLOR MAP * MCOLOR = MAP OF COLORS * ITTRM = UNIQUE MODEL NUMBER OF GENERAL TERMINAL TYPE * MARGX = NUMBER OF PIXELS PADDED TO X-COORDINATE * MARGY = NUMBER OF PIXELS PADDED TO Y-COORDINATE * * CHARACTER*5 TEKCOR * IX = INX IY = INY * FIRST CHECK FOR CLIPPING IF ( IX .LT. IXL ) THEN IX = IXL ELSEIF ( IX .GT. IXR ) THEN IX = IXR ENDIF IF ( IY .LT. IYT ) THEN IY = IYT ELSEIF ( IY .GT. IYB ) THEN IY = IYB ENDIF * NOW CALCULATE TEK4010 COORDINATE HIGHX = IX/128 LOWX = (IX - HIGHX*128)/4 EXTRAX = IX - HIGHX*128 - LOWX*4 HIGHY = IY/128 LOWY = (IY - HIGHY*128)/4 EXTRAY = IY - HIGHY*128 - LOWY*4 EXTRA = EXTRAY*4 + EXTRAX TEKCOR = CHAR(32+HIGHY)//CHAR(64+32+16+EXTRA)// . CHAR(64+32+LOWY)//CHAR(32+HIGHX)//CHAR(64+LOWX) RETURN END SUBROUTINE TEKSTR( IROW, ICOL, STRING ) * Places a string of text in GRAPHICS AREA INTEGER IROW, ICOL CHARACTER*(80) STRING CHARACTER*4 TEKINT CHARACTER*5 TEKCOR, STEMP CHARACTER*1 ESC, ASCII, CAR COMMON /ASCIIC/ ASCII( 0: 255) INTEGER PIXROW, PIXCOL, PIXEL COMMON /TERM/ IMAXR, IMAXC, PIXROW, PIXCOL, PIXEL, LCOUNT, INGRAF, . IXL, IXR, IYT, IYB, NCOLOR, MCOLOR( 64 ), ITTRM, . MARGX, MARGY * VARIABLES IN COMMON TERM: * IMAXR = MAX NUMBER OF ROWS * IMAXC = MAX NUMBER OF COLUMNS * PIXROW = NUMBER OF PIXELS PER ROW * PIXCOL = NUMBER OF PIXELS PER COLUMN * PIXEL = LESSER OF PIXROW OR PIXCOL * LCOUNT = NUMBER OF LINES CURRENTLY WRITTEN TO DIALOG AREA * INGRAF = 0=> HOST TEXT GOES TO MONITOR SPACE\\ 1=> TEXT TO GRAPHICS * IXL = LEFT MOST VALUE OF X * IXR = RIGHT MOST VALUE OF X * IYT = VALUE OF Y AT TOP OF SCREEN * IYB = VALUE OF Y AT BOTTOM OF SCREEN * NCOLOR = NUMBER OF COLORS IN MCOLOR MAP * MCOLOR = MAP OF COLORS * ITTRM = UNIQUE MODEL NUMBER OF GENERAL TERMINAL TYPE * MARGX = NUMBER OF PIXELS PADDED TO X-COORDINATE * MARGY = NUMBER OF PIXELS PADDED TO Y-COORDINATE * * EQUIVALENCE ( ESC, ASCII(27)) EQUIVALENCE ( CAR, ASCII(13)) ILEN = LEN(STRING) PIXPC = IXR / IMAXC C?? PIXPR = ( PIXEL / IMAXR ) + 1 PIXPR = ( ( IYB - IYT - 1000 ) / IMAXR ) + 1 STEMP = TEKINT(ILEN) IILEN = INDEX( STEMP, CAR)-1 IF ( IROW*ICOL .LT. 1 ) THEN IF (ILEN .LT. 1) RETURN c!st WRITE ( *, 2000) ESC//'LT'//STEMP(1:IILEN)//STRING call tekout(3+iilen+ilen, ESC//'LT'//STEMP(1:IILEN)//STRING) call tekout(8,esc//'LF'//tekcor) ELSE IXMOV = ICOL * PIXPC + MARGX C?? IYMOV = ( 29 - IROW) * PIXPR + MARGY IYMOV = ( 29 - IROW) * PIXPR + 1000 CALL TEKCRD( IXMOV, IYMOV, TEKCOR) c!st WRITE (*,2000) ESC//'LF'//TEKCOR call tekout(8, ESC//'LF'//TEKCOR ) IF (ILEN .LT. 1) RETURN c!st WRITE ( *, 2000) ESC//'LT'//STEMP(1:IILEN)//STRING call tekout(3+iilen+ilen, ESC//'LT'//STEMP(1:IILEN)//STRING) ENDIF 2000 FORMAT ( '+', A $) c? 2000 FORMAT ( ' ', A ) RETURN END SUBROUTINE RESCOL * RESETS COLOR MAPS ON TEKTRONIX TERMINALS * CHARACTER TEKINT*4, STEMP*10, ESC*1, CAR, ASCII*1 COMMON /ASCIIC/ ASCII( 0: 255) INTEGER PIXROW, PIXCOL, PIXEL COMMON /TERM/ IMAXR, IMAXC, PIXROW, PIXCOL, PIXEL, LCOUNT, INGRAF, . IXL, IXR, IYT, IYB, NCOLOR, MCOLOR( 64 ), ITTRM, . MARGX, MARGY * VARIABLES IN COMMON TERM: * IMAXR = MAX NUMBER OF ROWS * IMAXC = MAX NUMBER OF COLUMNS * PIXROW = NUMBER OF PIXELS PER ROW * PIXCOL = NUMBER OF PIXELS PER COLUMN * PIXEL = LESSER OF PIXROW OR PIXCOL * LCOUNT = NUMBER OF LINES CURRENTLY WRITTEN TO DIALOG AREA * INGRAF = 0=> HOST TEXT GOES TO MONITOR SPACE\\ 1=> TEXT TO GRAPHICS * IXL = LEFT MOST VALUE OF X * IXR = RIGHT MOST VALUE OF X * IYT = VALUE OF Y AT TOP OF SCREEN * IYB = VALUE OF Y AT BOTTOM OF SCREEN * NCOLOR = NUMBER OF COLORS IN MCOLOR MAP * MCOLOR = MAP OF COLORS * ITTRM = UNIQUE MODEL NUMBER OF GENERAL TERMINAL TYPE * MARGX = NUMBER OF PIXELS PADDED TO X-COORDINATE * MARGY = NUMBER OF PIXELS PADDED TO Y-COORDINATE * * * IDHLS :=dialog/ IGHLS :=graphic \\ H:=hue/ L:=lightness/ S:=saturation DIMENSION IDHLS( 3, 8 ), IGHLS( 3, 16 ) EQUIVALENCE ( CAR, ASCII( 13)), ( ESC, ASCII( 27)) DATA IDHLS / 0, 0, 0, 1 0, 100, 0, 2 120, 50, 100, 3 240, 50, 100, 4 330, 60, 100, 5 300, 50, 100, 6 60, 50, 100, 7 180, 50, 100 / * DATA IGHLS / 0, 0, 0, 1 0, 100, 0, 2 120, 50, 100, 3 240, 50, 100, 4 0, 50, 100, 5 300, 50, 100, 6 60, 50, 100, 7 180, 50, 100, 8 150, 50, 100, 9 210, 50, 100, A 270, 50, 100, B 330, 50, 100, C 30, 50, 100, D 90, 50, 100, E 0, 33, 0, F 0, 66, 0 / * 2000 FORMAT ( '+', A $) c? 2000 FORMAT ( ' ', A ) * SET COLOR MODE TO 'HLS' 'OPAQUE' 'ENABLE COLORS' WRITE ( *, 2000 ) ESC//'TM311' * DO 10 I= 1, 8 STEMP = TEKINT( I-1 ) K = 2 DO 8 II= 1, 3 STEMP( K:) = TEKINT( IDHLS( II, I) ) K = INDEX ( STEMP, CAR ) 8 CONTINUE WRITE ( *, 2000 ) ESC//'TF4'//STEMP( :K-1 ) 10 CONTINUE * IF ( ITTRM .EQ. 4105 ) THEN MGHLS = 8 ELSE MGHLS = 16 ENDIF DO 50 I= 1, MGHLS STEMP = TEKINT( I-1 ) K = 2 DO 48 II= 1, 3 STEMP( K:) = TEKINT( IGHLS( II, I) ) K = INDEX( STEMP, CAR ) 48 CONTINUE WRITE ( *, 2000 ) ESC // 'TG15' // STEMP( :K-1 ) 50 CONTINUE RETURN END