SUBROUTINE LIBNAM( BUF ) CHARACTER*(*) BUF BUF = 'HPLIBR' RETURN END C = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = C C SUBROUTINE PLOT ( X, Y, ICODE ) C C This subroutine moves the pen from its current position to X,Y C C If ICODE is +/-2 then the pen is down thus drawing a line. C If ICODE is +/-3 then the pen is up during the move. C C If ICODE is negative then the new pen position becomes to plot C origin (ie 0,0). C C = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE PLOT ( X, Y, ICODE ) C === C Include the HPLIBR common block of variables. C === INCLUDE 'HPLIBR.CMN' C === C Convert the user coordinates into absolute plotter units. C === IX = IFIX( X * XCONV * FACT + .5 ) + IXORG IY = IFIX( Y * YCONV * FACT + .5 ) + IYORG C === C Clip the coordinates if they are off the page. C === IF(IX.GT.IXMAX) IX = IXMAX IF(IY.GT.IYMAX) IY = IYMAX IF(IX.LT.0) IX = 0 IF(IY.LT.0) IY = 0 C === C Determine the relative corrdinates to get there from C the present pen position. C === IXR = IX - IXNOW IYR = IY - IYNOW C === C Update the current pen position to reflect this move. C === IXNOW = IX IYNOW = IY C === C If ICODE is 2 and the pen is currently up then it C must be put down prior to moving. C === IF( IABS(ICODE).EQ.2 .AND. PENUP ) THEN HPCODE = 'PD;' CALL HPINST PENUP = .FALSE. END IF C === C If ICODE is 3 and the pen is currently down then it C must be lifted prior to moving. C === IF( IABS(ICODE).EQ.3 .AND. (.NOT.PENUP) ) THEN HPCODE = 'PU;' CALL HPINST PENUP = .TRUE. END IF C === C If the last instruction to the plotter was a PR command C then we can simply append the relative coordinates to the C instruction buffer (subtract 1 from the buffer pointer which C will write over the ";"), otherwise, we must include the "PR" C command and set the plot relative flag to .TRUE. C === WRITE( HPCODE, 3000 ) IXR, IYR 3000 FORMAT( 'PR', I6, ',', I6, ';' ) PRINST = .TRUE. CALL HPINST C === C Change the origin if ICODE is negative. C === IF( ICODE.LT.0) THEN IXORG = IXNOW IYORG = IYNOW END IF C === C That's all there is to it! C === RETURN END SUBROUTINE HPINST INCLUDE 'HPLIBR.CMN' C === C Get the length of the instruction code. C === NCHAR = LENCHR( HPCODE ) C === C If the new instructions won't fit in the buffer then dump the C buffer. C === IF( IBUFP+NCHAR.GE.IBUFD ) CALL HPDUMP C === C If the HPLITR flag is set to true then don't strip the C blank characters from the instruction code (this is set C by the LABEL and HPWNDO subroutines for obvious reasons!). C === IF( HPLITR ) THEN HPBUFF(IBUFP:IBUFP+NCHAR) = HPCODE(1:NCHAR) IBUFP = IBUFP + NCHAR HPLITR = .FALSE. GOTO 2000 END IF C === C If this is a "PR" (plot relative) instruction AND the last C intruction was a "PR" then we need only append the coordinates C to the buffer. C === IF( PRINST .AND. PRLAST ) THEN HPCODE(1:2) = ' ,' IBUFP = IBUFP - 1 END IF C === C Place the contents of the instruction code into the buffer C stripping any "blanks" as we go. C === DO 1000 I=1, NCHAR IF( HPCODE(I:I).EQ.' ' ) GOTO 1000 HPBUFF(IBUFP:IBUFP) = HPCODE(I:I) IBUFP = IBUFP + 1 1000 CONTINUE 2000 IF( PRINST ) THEN PRLAST = .TRUE. PRINST = .FALSE. ELSE PRLAST = .FALSE. END IF C === C Blank-out the instruction code string. C === HPCODE = ' ' RETURN END C === C This subroutine dumps the contents of HPBUFF to C the appropriate logical unit. C === SUBROUTINE HPDUMP INCLUDE 'HPLIBR.CMN' BYTE ON(4), OFF(4) DATA ON/ 27, '[', '5', 'i'/ DATA OFF/ 27, '[', '4', 'i'/ IF (IHPOUT.EQ.6 ) GOTO 100 C === C Plotter output is to HP: or FNAME C === WRITE( IHPOUT, 1000 ) HPBUFF(1:IBUFP-1) 1000 FORMAT( A ) GOTO 200 C === C Plotter output is to printer port so we need to C turn on the port, dump the buffer, and close the port. C We must also supress the CR/LF at the end of the dump, C in order to accomplish this we will use the '+' character C as the carriage control character. C === 100 WRITE( IHPOUT, 1001 ) ON, HPBUFF(1:IBUFP-1), OFF 1001 FORMAT( '+', 4A1, A, 4A1 ) C === C Refresh the HPBUFF pointer and blank-out the HPBUFF string. C === 200 HPBUFF = ' ' IBUFP = 1 PRLAST = .FALSE. C === C Das all--back to the main program we go. C === RETURN END C === C SUBROUTINE START( X, Y, IPAPER, IERR, FNAME ) C C ROUTINE TO INITIALIZE PLOTTING PACKAGE ON C HEWLETT-PACKERD 7550 SERIES 8 PEN PLOTTERS. C === C C X,Y = Initial origin of pen in inches. C C IPAPER = 0 Small paper size (8.5"x11"). C = 1 Large paper size (11"x17"). C C IOUT = 0 Output is directed to a datafile called FNAME. C = 1 Output is directed to device HP: (ie the plotter). C = 2 Output is through the terminal printer port. C if an error occurs during the "OPEN" operation then the value C of IOUT is set to -1. C C FNAME = Name of the datafile where the plotter code is C written to. If FNAME is "HP:" the code is sent C to the plotter. If FNAME is "TT:" then the code C is sent thru the terminal printer port. C If FNAME is empty then the default file name C will be HP7550.PLT C === C HPLIBR common block definition. C === C COMMON /HPLIBR/ HPBUFF, HPCODE, IBUFP, IBUFD, IHPOUT, C 1 HPLITR, PRINST, PRLAST, PENUP, C 1 XCONV, YCONV, IXORG, IYORG, IXNOW, IYNOW, IXMAX, IYMAX, FACT, C 1 ICPEN, IUPDN, IFTYP, IFSPA, IFANG, ILTYP, ILSPA, ISYMB, C 1 CHRWD, CHRHT, CHRSL, CHRAN, LOCHR, ISPEC, IALTC C C LOGICAL*1 HPLITR, PRINST, PRLAST C C CHARACTER HPBUFF*132, HPCODE*132 C === C Description of the HPLIBR common block variables: C C HPBUFF = Instruction buffer for the plotter. C HPCODE = Character string of plotter commands to be placed C into HPBUFF via a call to HPINST. C IBUFP = Position of the last character in HPUFF. C IBUFD = Maximum length of HPBUFF string instruction (130) C C IHPOUT = I/O unit assiciated with the plotter buffer. C C XCONV = Conversion factor from user units to plotter units (X). C YCONV = Conversion factor from user units to plotter units (Y). C IXORG = Current X coordinate of user origin. C IYORG = Current Y coordinate of user origin. C IXMAX = Maximum distance in the X direction. C IYMAX = Maximum distance in the Y direction. C IXNOW = Current pen X coordinate. C IYNOW = Current pen Y coordinate. C FACT = Current scaling factor. C C PRINST = Flag set in the PLOT subroutine to indicate a plot C relative command. C PRLAST = Flag set if the last command was a plot relative one. C C HPLITR = Flag set to disable blank character stripping when the C contents of HPCODE are placed into HPBUFF. C C PENUP = Flag set if the pen is in the UP position. C C ICPEN = Current number pen in hand. C C IFTYP = Current "fill" pattern. C IFSPA = Current "fill" spacing. C IFANG = Current "fill" angle. C C ILTYP = Current "line" pattern. C ILSPA = Current "line" pattern length. C C ISYMB = Currently defined symbol number. C C CHRWD = Current character width (cm). C CHRHT = Current character height (cm). C CHWRAT = Character height:width ratio. C CHRSL = Current character slant (deg). C CHRAN = Current character label angle (deg). C CHRLO = Current label origin. C C ISPEC = If 1 then special character mode is active and 0 if not. C IALTC = Current alternate character set. C === SUBROUTINE START( X, Y) ! , IPAPER, IERR, FNAME ) !JDW C === C HPLIBR common block variables. C === INCLUDE 'HPLIBR.CMN' CC CHARACTER FNAME*(*) !JDW PARAMETER FNAME = 'HP' !JDW PARAMETER IPAPER = 0 !JDW C === C Open appropriate unit and file for plotter output. C === IF( FNAME.EQ.'HP:' .OR. FNAME.EQ.'hp:' ) GOTO 2000 IF( FNAME.EQ.'TT:' .OR. FNAME.EQ.'tt:' ) GOTO 3000 C === C Output is to directed to FNAME. C === IHPOUT = 2 IBUFD = 120 IF( FNAME.EQ.' ' ) THEN OPEN (UNIT = IHPOUT, NAME = 'HP7550.PLT', TYPE = 'NEW', 1 CARRIAGECONTROL = 'LIST', ERR = 1010 ) ELSE OPEN (UNIT = IHPOUT, NAME = FNAME, TYPE = 'NEW', 1 CARRIAGECONTROL = 'LIST', ERR = 1010 ) END IF GOTO 4000 C === C There has been an error associated with openning FNAME. C === 1010 CALL ERRSNS ( IERR, ISTS, ISTV, IHPOUT, ICON ) IF( FNAME.EQ.' ' ) THEN TYPE 1020, 7, 7, IERR, 'HP7550.PLT' ELSE TYPE 1020, 7, 7, IERR, FNAME 1020 FORMAT( /, 1 5X, 2A1, 'ERROR', I5, ' OCCURED ATTEMPTING TO 1 OPEN FILENAME: ', A, /, 1 5X, 'AS OUTPUT IN SUBROUTINE "START".' ) END IF IERR = -1 RETURN C === C Output is to directed to plotter at HP: C === 2000 IHPOUT = 2 IBUFD = 120 OPEN( UNIT=IHPOUT, NAME='HP:', TYPE='NEW', 1 CARRIAGECONTROL='NONE', ERR=2010 ) C === C Send the plotter an .( .L .) string to C output a signal when the plotter buffer is empty and we C are clear to send data to it. C === WRITE( IHPOUT, 2005 ) 27, 27, 27 2005 FORMAT( A1, '.(', A1, '.L', A1, '.)', $ ) READ( IHPOUT, *, ERR=2010 ) IDUMMY GOTO 4000 C === C There is an error openning HP: C === 2010 CALL ERRSNS ( IERR, ISTS, ISTV, IHPOUT, ICON ) IF( IERR.EQ.30 ) THEN TYPE 2020, 7, 7 2020 FORMAT( /, 5X, A1, 'Plotter is currently unavalible.', A1 ) ELSE TYPE 2030, 7, 7, IERR 2030 FORMAT( /, 5X, 2A1, 'ERROR', I5, 'OCCURED ATTEMPTING 1 TO ATTATCH HP:', 5X, 'AS OUTPUT IN SUBROUTINE "START".' ) END IF IERR = -1 RETURN C === C Output is to be directed to terminal IUNIT = 6 C === 3000 IHPOUT = 6 CALL SET_TERM( 'SAVE' ) CALL SET_TERM( 'PASTHRU' ) CALL SET_TERM( 'NOWRAP' ) CALL SET_TERM( 'NOBROADCAST' ) IBUFD = 120 GO TO 4000 C === C There is an error openning TT: C === 3010 CALL ERRSNS ( IERR, ISTS, ISTV, IHPOUT, ICON ) TYPE 3020, 7, 7, IERR 3020 FORMAT( /, 5X, 2A1, 'ERROR', I5,' OCCURED ATTEMPTING TO OPEN TT:' 1 5X, 'AS OUTPUT IN SUBROUTINE "START".' ) IERR = -1 RETURN C === C Set the buffer pointer to 1 C === 4000 IBUFP = 1 C === C Set pen position to "UP" C === PENUP = .TRUE. C === C Set PRINST to .FALSE. (ie last instruction was not a relative pen movement). C === PRLAST = .FALSE. C === C Set default scaling factor to 1. C === FACT = 1.0 C === C Set hard clip limits according to paper size. C === IF( IPAPER.EQ.1 ) THEN IXMAX = 16450 ! Limits for large paper 11"x17" IYMAX = 10170 ! availible plotting area is 16.12"x10" ELSE IXMAX = 10170 ! Limits for small paper 8.5"x11" IYMAX = 7840 ! availible plotting area is 7.7"x10" END IF C === C Conversion factor from inches to plotter unit. C === XCONV = 1016.0 YCONV = 1016.0 C === C Set the initial pen position and origin to 0,0 C === IXNOW = 0 IYNOW = 0 IXORG = 0 IYORG = 0 C === C Initialize the character cell dimensions and characteristics. C === CHRWD = 0.0 CHRHT = 0.0 CHWRAT = 0.6 CHRSL = 0.0 CHRAN = 0.0 LOCHR = 1 ISPEC = 0 IALTC = 0 C === C Set the default values for the FILL pattern. C === IFTYP = 1 IFSPA = 0 IFANG = 0 C === C Set the default values for the LINE pattern. C === ILTYP = 0 ILSPA = 4 C === C Set the pen number in hand to 0 (we ain't got one yet!!). C === ICPEN = 0 C === C Define the plotter initialization instruction string as follows: C C (1) ---> .( C (2) ---> .@2: C (3) ---> "ten null characters" C (4) ---> .T4096;4096;2048;;2048: C (5) ---> .@4050: C (6) ---> .P1: C (7) ---> IN; C (8) ---> IP; C (9) ---> PA0,0; C C Which are the following instructions: C C (1) Plotter ON code (tells the plotter to accept all C information until it encounters an .) instruction. C C (2) Forces the plotter to send an XOFF to the computer C when its buffer has 2 or more characters in it. This will force C the plotter to complete all instructions currently in its buffer C (ie finish the previous plot if it is not done yet) before it C allows any more instructions to enter its buffer. This is needed C since the next instruction (the .T one) will wipe-out all C unexicuted instructions currently in the buffer. C C (3) These 10 null characters are sent to let instruction #2 take C effect (it take a finite amount of time for the plotter to send C the Xoff character to the computer. C C (4) This is the instruction string that configures the plotter's C buffer. There are 12,800 bytes avalible which will be allocated C as follows: 4096 for physical I/O, 4096 for the polygon buffer, C 2048 for down loadable (userdefined) characters, whatever is left C over in the replot buffer (512), and 2048 for the vector buffer. C This configuration is sufficient for most plots. C C (5) Tell the plotter to send the XOFF character when its buffer C gets 4050 characters full (this resets the condition set by the C .2@: instruction). C C (6) This tells the plotter to use normal RS232 interfacing C proceedures. C C (7) Instructs the plotter to initialize itself to the "power up" C state with respect to graphics parameters. C C (8) Initialize plotter scaling units to default values. C C (9) Do an absolute move to the paper origin. C C More information on the details of these commands can be found C in the Interfacing and Programming Manual for the HP 7550A C graphics plotter (RS-232-C/CCITT V.24. This library of routines C was written from the January 1986 edition of the manual. C C === CC WRITE( HPCODE, 5000 ) 27, 27, 0,0,0,0,0,0,0,0,0,0, 27 CC5000 FORMAT( A1, '.(', A1, '.@2:', 10A1, A1, '.T4096;4096;2048;;2048:' ) C C Force the plotter to wait until previous plot is done. WRITE(HPCODE,101) 27,27,13,0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0,27 !JDW 101 FORMAT(A1,'.(',A1,'.@',17A1,'.)') !JDW C === C Put the setup string into the plotter buffer and send it. C === CALL HPINST CALL HPDUMP C === C Put the second half of the instruction string in. C === C C Initialize the handshakeing. WRITE(HPCODE,102) 27,27,27, 27,27 !JDW 102 FORMAT(A1,'.(',A1,'.@890:',A1,'.M50;;;13:', !JDW & A1,'.N10;19:',A1,'.I80;0;17:IN;IP;PA0,0;' ) !JDW CC WRITE( HPCODE, 7000 ) 27, 27 CC7000 FORMAT( A1, '.@4050:', A1, '.P1:IN;IP;PA0,0;' ) C === C Put the setup string into the plotter buffer and send it. C === CALL HPINST CALL HPDUMP C === C Move the origin to user specified position of X,Y C === CALL PLOT( X, Y, -3 ) C === C Reset the axis clipping limits for data plotting using C the PDATA subroutine. C === CALL AXCLIP( 0.0, 0.0 ) C C Grap pen # 1 CALL PEN(1) !JDW C === C Das all for now. C === IERR = 0 RETURN END C C Dummy Subroutine JDW SUBROUTINE SET_TERM RETURN END C === C SUBROUTINE AXCLIP( XAXLEN, YAXLEN ) C C This subroutine sets the plotting window limits for the PDATA C subroutine. C C === SUBROUTINE AXCLIP( XAXLEN, YAXLEN ) COMMON /AXCLIP/ XCLIP, YCLIP IF( XAXLEN.EQ.0.0 .OR. YAXLEN.EQ.0 ) THEN XCLIP = 0.0 YCLIP = 0.0 ELSE XCLIP = XAXLEN YCLIP = YAXLEN END IF RETURN END SUBROUTINE PEN( NEWP ) C INCLUDE 'HPLIBR.CMN' C === C Check for an invalid pen number or if we already have C this pen in hand. C === IF( NEWP.LT.0 .OR. NEWP.GT.8 .OR. NEWP.EQ.ICPEN ) RETURN C === C Put the new pen instruction in the plotter buffer. C === WRITE( HPCODE, 1000 ) NEWP 1000 FORMAT( 'SP', I1, ';' ) CALL HPINST ICPEN = NEWP RETURN END SUBROUTINE END C === C This subroutine wraps up the plotter subroutine calls. C === INCLUDE 'HPLIBR.CMN' C === C Put away the pen like a good boy. C === CALL PEN (0) C === C Move to the origin. C === CALL PLOT (0.0, 0.0, 3) C === C Issue the eject page command "PG" and the plotter off code ".)" C === WRITE( HPCODE, 1000 ) 27 1000 FORMAT( 'PG;', A1, '.)' ) C === C Send instruction code to the buffer. C === CALL HPINST C === C Dump the plotter buffer. C === CALL HPDUMP C === C Close the plotter I/O port. C === CLOSE (UNIT = IHPOUT) IF( IHPOUT.EQ.6 ) CALL SET_TERM( 'RECALL' ) C === C That's all folks, we be done! C === RETURN END SUBROUTINE FACTOR (FACTR) INCLUDE 'HPLIBR.CMN' IF( FACTR.LE.0.0 ) RETURN FACT = FACTR RETURN END SUBROUTINE WHERE (X, Y, FAC) INCLUDE 'HPLIBR.CMN' FAC = FACT X = (IXNOW - IXORG)/XCONV Y = (IYNOW - IYORG)/YCONV RETURN END SUBROUTINE SYMBOL( XPOS, YPOS, SIZE, TEXT, ANGLE, NCHAR ) CHARACTER TEXT*(*) IF(NCHAR.LE.0 .AND. TEXT.LT.'@') THEN ISYM = ICHAR(TEXT(1:1)) CALL SMODE( ISYM, SIZE ) CALL PLOT( XPOS, YPOS, -NCHAR ) CALL SMODE( 0, SIZE ) ELSE CALL LABEL(XPOS, YPOS, TEXT, NCHAR, SIZE, 0.0, ANGLE, 1, 0) END IF RETURN END SUBROUTINE SMODE( ISY, SIZE ) INCLUDE 'HPLIBR.CMN' ISYM = ISY IF( ISYM.LT.0 .OR. ISYM.GT.9 ) ISYM = 1 C === C If ISYM is zero then that's the signal to exit from the C symbol mode. C === IF( ISYM.EQ.0 ) GOTO 7000 C === C Set code the size of the character cell and cell angle if different C from the current character cell settings. C === CW = SIZE * XCONV * FACT / 400.0 CH = CW IF( CW.EQ.CHRWD .AND. CH.EQ.CHRHT .AND. CHRAN.EQ.0.0 ) GOTO 3000 WRITE( HPCODE, 1000 ) CW, CH 1000 FORMAT( 'DI1,0;SI', F5.3, ',', F5.3, ';' ) CALL HPINST C === C Update the current character cell parameters. C === CHRWD = CW CHRHT = CH CHRAN = 0.0 C === C If the same symbol is to be used as last symbol, or ISYM is 1 C then skip the symbol definition coding. C === 3000 IF( ISYM.EQ.ISYMB .OR. ISYM.EQ.1 ) GOTO 5000 C === C Define the specified symbol as the "0" character (ASCII code=48). C In all cases (except for ISYM=1) the symbol is defined using the C DL command. C C ISYM = 1 draw an "O". C ISYM = 2 define and draw a box. C ISYM = 3 define and draw a triangle. C ISYM = 4 define and draw an "X". C ISYM = 5 define and draw a diamond. C ISYM = 6 define and draw a cross "+". C ISYM = 7 define and inverted triangle. C ISYM = 8 define and draw an "*". C === IF( ISYM.EQ.2 ) HPCODE = 1 'DL48,0,0,32,0,32,32,0,32,0,0;' IF( ISYM.EQ.3 ) HPCODE = 1 'DL48,0,0,32,0,16,32,0,0;' IF( ISYM.EQ.4 ) HPCODE = 1 'DL48,-128,3,3,29,29,-128,3,29,29,3;' IF( ISYM.EQ.5 ) HPCODE = 1 'DL48,16,0,32,16,16,32,0,16,16,0;' IF( ISYM.EQ.6 ) HPCODE = 1 'DL48,16,32,16,0,-128,0,16,32,16;' IF( ISYM.EQ.7 ) HPCODE = 1 'DL48,0,32,32,32,16,0,0,32;' IF( ISYM.EQ.8 ) HPCODE = 1 'DL48,16,32,16,0,-128,0,16,32,16, 1-128,3,3,29,29,-128,3,29,29,3;' CALL HPINST C === C Enter the symbol mode. C === 5000 IF( ISYM.EQ.1 ) THEN HPCODE = 'CS;SM0;' ELSE HPCODE = 'CS-1;SM0;' END IF CALL HPINST GOTO 8000 C === C Cancel symbol mode and establish default character set. C === 7000 HPCODE = 'SM;CS;' CALL HPINST C === C Update the current symbol number. C === 8000 ISYMB = ISYM RETURN END C === C SUBROUTINE LABEL( X, Y, TEXT, NCHAR, SIZE, SLANT, ANGLE, ICODE, IBOLD ) C C Description of variables: C X, Y - Coordinates of label origin. C SIZE - Height (in inches) of the characters to be plotted. C TEXT - Character variable containing the C characters to be drawn. C NCHAR - Number of characters in TEXT to be C drawn, if NCHAR is 0 then the subroutine C will determine the number of characters in TEXT. C SLANT - Slant angle of characters along the line. C ANGLE - Angle of label line with respect to the page orientation. C ICODE - Postioning of the label with respect to the origin C as defined by the X,Y coordinates. C The following is a summary of the ICODE parameter: C C If ICODE = 1 the label is drawn placing the lower left C corner of the first character at X,Y C If ICODE = 4 the label is drawn centered with C respect to the X,Y coordinates. C If ICODE = 7 the label is drawn with the last character C at the X,Y coordinates. C C If ICODE is negative, all "\" characters in the label C will be converted to ASCII code 142 (shift-in) C characters so the next character will be printed C from the alternate character set in G2 of the C plotter buffer. It will also replace "{" characters C with ASCII code 10 ()'s and "{" characters C with ASCII code 11 ()'s for super and subscript C characters. C === SUBROUTINE LABEL( X, Y, TEXT, NC, SIZE, SL, AN, IC, IB ) C === C The HP common variable list. C === INCLUDE 'HPLIBR.CMN' CHARACTER TEXT*(*) PARAMETER ( RADIAN = 57.29578 ) NCHAR = NC ICODE = IABS( IC ) IBOLD = IB SLANT = SL ANGLE = AN STRING = ' ' C === C If the value of NCHAR is 0 then determine the number of characters C in TEXT, if then value of NCHAR is still 0 then just return (nothing C to plot!). C === IF( NCHAR.LE.0 ) NCHAR = LENCHR( TEXT ) IF( NCHAR.EQ.0 ) RETURN IF( NCHAR.GT.LEN( TEXT ) ) NCHAR = LEN( TEXT ) C === C Check for invalid parameters. C === IF( ICODE.LT.1 .OR. ICODE.GT.19 .OR. ICODE.EQ.10 ) ICODE = 1 IF( SLANT.GT. 80.0 ) SLANT = 80.0 IF( SLANT.LT.-80.0 ) SLANT = -80.0 C === C Move the pen to X,Y C === CALL PLOT( X, Y, 3 ) C === C Set character height. C === CALL CHRHGT( SIZE ) C === C Change label angle if different from current value. C === IF( ANGLE.NE.CHRAN ) THEN WRITE( HPCODE, 1020 ) 1 COS( ANGLE/RADIAN ), SIN( ANGLE/RADIAN ) 1020 FORMAT( 'DI', F6.3, ',', F6.3, ';' ) CALL HPINST CHRAN = ANGLE END IF C === C Change character slant if different from current value. C === IF( SLANT.NE.CHRSL ) THEN WRITE( HPCODE, 1030 ) TAN( SLANT/RADIAN ) 1030 FORMAT( 'SL', F6.3, ';' ) CALL HPINST CHRSL = SLANT END IF C === C Change label position code if different from current value. C === IF( ICODE.NE.LOCHR ) THEN WRITE( HPCODE, 1040 ) ICODE 1040 FORMAT( 'LO', I2, ';' ) CALL HPINST LOCHR = ICODE END IF C === C If IC is negative and the "special" character set has not C been loaded then load the special character set instructions. C === IF( IC.LT.0 .AND. ISPEC.EQ.0 ) THEN WRITE( HPCODE, 1050 ) 1050 FORMAT( 'CM3;DS2,5;ES0,-0.7;' ) CALL HPINST ISPEC = 1 END IF C === C Write the contents of TEXT to the instruction code. C NOTE: a carriagereturn character is inserted to put the plotter C pen back to its label origin position after printing. C === WRITE( HPCODE, 2000 ) TEXT(1:NCHAR), 13, 3 2000 FORMAT( 'BL', A, A1, A1, ';PB;' ) C === C If IC is positive then no alternate character set is C being used. C === IF( IC.GE.0 ) GOTO 2800 C === C Search the plotter label buffer for "\" characters and change C them to "shift-out" characters (ASCII code 142) to access C the alternate character set located in G2. Change all "{" to C 's and change all "}" to 's for super and subscript C characters. C === DO 2500, I=3, NCHAR+3 IF( HPCODE(I:I).EQ.'{' ) HPCODE(I:I) = CHAR( 11 ) IF( HPCODE(I:I).EQ.'}' ) HPCODE(I:I) = CHAR( 10 ) 2500 IF( HPCODE(I:I).EQ.'\' ) HPCODE(I:I) = CHAR(142 ) C === C Put the buffer label into the plotter buffer. C === 2800 HPLITR = .TRUE. CALL HPINST C === C Check to see if bolding or shading is needed. C === IF( IBOLD.EQ.0 ) GOTO 5000 C === C Shadowing has been requested, so loop through and move C the starting pen location over ~0.15" in the "X" C direction (see angle correction) each time for a maximum C of IBOLD times. C === XBOLD = 0.015 * COS( ANGLE/RADIAN ) YBOLD = 0.015 * SIN( ANGLE/RADIAN ) XPOS = X YPOS = Y DO 4000 J = 1, ABS( IBOLD ) XPOS = XPOS + XBOLD YPOS = YPOS + YBOLD CALL PLOT( XPOS, YPOS, 3 ) WRITE( HPCODE, 4500 ) 4500 FORMAT( 'PB;' ) CALL HPINST 4000 CONTINUE C === C Put the pen back to the original X,Y position. C === CALL PLOT( X, Y, 3 ) 5000 RETURN END SUBROUTINE CHRHGT( SIZE ) INCLUDE 'HPLIBR.CMN' C === C Calculate the character cell size. C === CH = ABS( SIZE ) * YCONV / 400.0 * FACT CW = CHWRAT * CH IF( SIZE.LT.0 ) CW = -CW C === C If no change is necessary, just return. C === IF( CH.EQ.CHRHT .AND. CW.EQ.CHRWD ) RETURN C === C Change character cell dimensions. C === WRITE( HPCODE, 1010 ) CW, CH 1010 FORMAT( 'SI', F6.3, ',', F6.3, ';' ) CALL HPINST CHRWD = CW CHRHT = CH RETURN END C *** SUBROUTINE NUMBER C * C * HOMEBREW NUMBER ROUTINE. FOLLOWS SAME RULES AS THOSE OF CALCOMP. C * SUBROUTINE NUMBER(XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC) C * CHARACTER LOC(20)*1, BLANK*1 ,DP*1 DATA BLANK/' '/ DATA DP/'.'/ C * C * ROUND THE FPN TO THE NEAREST NDEC DECIMAL PLACE XFPN = FPN NDXP = NDEC IF(NDEC.LT.0) NDXP = IABS( NDEC ) - 1 IF(FPN.GT.0.0) XFPN = XFPN + 0.5*10.**(-NDXP) IF(FPN.LT.0.0) XFPN = XFPN - 0.5*10.**(-NDXP) C * C ENCODE THE FLOATING POINT NUMBER INTO 'A' FORMAT. ENCODE(20,1000,LOC(1)) XFPN 1000 FORMAT(F20.6) C FIND THE FIRST NON BLANK CHARACTER. DO 10 I=1,20 10 IF(LOC(I).NE.BLANK) GO TO 15 C ALL BLANK CHARACTERS. HMMMM. PROBLEMS. GIVE IT UP. J2=20 GO TO 45 C SHIFT THE LOC ARRAY LEFT AND FIND DECIMAL POINT LOCATION. 15 K=1 IDP=20 DO 20 J=I,20 LOC(K)=LOC(J) LOC(J)=BLANK IF(LOC(K).EQ.DP) IDP=K K=K+1 20 CONTINUE C NOW PROCESS THE LOC ARRAY POINTERS FOR THE DESIRED OUTPUT. IF(NDEC) 25,35,40 C NDEC NEGATIVE. IF NDEC=-1 OUTPUT THE INTEGER PORTION OF THE NUMBER. C WITH OUT THE DECIMAL POINT. 25 IF(NDEC.NE.-1) GO TO 30 J2=IDP-1 GO TO 45 C IF NDEC<-1 OUTPUT IABS(NDEC)-1 DIGITS FROM THE NUMBER. 30 J2=IABS(NDEC)-1 C DON'T FORGET THE MINUS SIGN IF PRESENT. IF(FPN.LT.0.0) J2=J2+1 GO TO 45 C NDEC=0. PRINT OUT THE INTEGER PORTION OF THE NUMBER WITH DEC. PT. 35 J2=IDP GO TO 45 C PRINT OUT NDEC DIGITS TO THE RIGHT OF THE DECIMAL POINT. 40 J2=IDP+NDEC 45 DO 50 I=J2+1,20 LOC(I)=BLANK 50 CONTINUE CALL SYMBOL(XPAGE,YPAGE,HEIGHT,%DESCR(LOC),ANGLE,J2) RETURN END FUNCTION LENCHR( TEXT ) CHARACTER TEXT*(*) NMAX = LEN( TEXT ) DO 100 I = NMAX, 1, -1 100 IF( TEXT(I:I).NE.' ' .AND. TEXT(I:I).NE.CHAR(0) ) GOTO 200 I = 0 200 LENCHR = I RETURN END SUBROUTINE PAGE INCLUDE 'HPLIBR.CMN' WRITE( HPCODE, 1000 ) 1000 FORMAT( 'PG;PA0,0;' ) CALL HPINST CALL HPDUMP IXNOW = 0 IYNOW = 0 IXORG = 0 IYORG = 0 IF( IHPOUT.EQ.6 ) CLOSE (UNIT = IHPOUT) RETURN END SUBROUTINE AXIS(XPAGE,YPAGE,IBCD,NCHAR,AXLEN,ANGLE,FIRSTV,DELTAV) C Translate a calcomp axis call into MJH's syntax. CHARACTER IBCD*(*) IF(ANGLE.EQ.0.0) THEN CALL XAXIS1(XPAGE,YPAGE,IBCD,NCHAR,0,AXLEN,FIRSTV,DELTAV) ELSE CALL YAXIS1(XPAGE,YPAGE,IBCD,NCHAR,0,AXLEN,FIRSTV,DELTAV) ENDIF RETURN END C === C SUBROUTINE XAXIS1( XPOS, YPOS, LABEL, NCHAR, ICODE, C 1 AXLEN, FIRSTV, DELTAV ) C C This subroutine draws a linear "X" axis. C C Variables sent to subroutine: C C XPOS = X-coordinate of starting point of the axis. C YPOS = Y-coordinate of starting point of the axis. C LABEL = axis label to be centered along the axis. C NCHAR = Number of characters in label, C if NCHAR=0 then the subroutine will determine C the number of characters in LABEL. C AXLEN = Length of axis in whole inches. C FIRSTV = First value to be plotted on axis. C DELTAV = Change in axis values between 1" tick marks. C ICODE = Code specifying the type of X axis to be drawn: C 0 axis values and label are positioned C below the axis. C 1 axis values and label are positioned C above the axis. C C ================================================================= SUBROUTINE XAXIS1( XPAGE, YPAGE, AXLAB, NC, ICODE, 1 AXLEN, FIRSTV, DELTAV ) CHARACTER CLABEL*132, CVALUE*14, AXLAB*(*) C === C Length of major and minor tick marks. C === TXMAJ = 0.08 TXMIN = 0.04 IF( ICODE.EQ.1 ) THEN TXMAJ = - TXMAJ TXMIN = - TXMIN END IF C === C Height of axis values and distance from the axis. C === HGTV = 0.11 OSV = 0.1 C === C Height of axis label and distance from axis values. C === HGTL = 0.14 OSL = 0.1 C === C LABEL subroutine values for character slant and bolding factor. C === SLANT = 0.0 IBOLD = 0 C === C Blank-out the labels. C === CLABEL = ' ' CVALUE = ' ' C == C Determine the largest absolute value to C be plotted on the axis. C === IENG = 0 NEXP = 0 VAL1 = FIRSTV VAL2 = FIRSTV + DELTAV * AXLEN VAL3 = DELTAV VMAX = AMAX1( ABS(VAL1), ABS(VAL2), ABS(VAL3) ) C === C Check to see if the maximum value is within C the 5 character limit. if not then adjust C axis values according to scientific notation. C C If axis values are too large (>= 10,000) C modify them by units of 10** 3,6,9,12 etc. C === 100 IF ( ABS(VMAX).LT.10000.0 .AND. IENG.EQ.0 ) GOTO 200 150 IF ( ABS(VMAX).LT.100.0 ) GOTO 300 NEXP = NEXP + 3 VAL1 = VAL1 * 10.0**(-3) VAL2 = VAL2 * 10.0**(-3) VAL3 = VAL3 * 10.0**(-3) VMAX = VMAX * 10.0**(-3) IENG = 1 GOTO 150 C === C Axis values are too small (<= 0.01) C modify them by units 10** -3,-6,-9,-12 ETC. C === 200 IF ( ABS(VMAX).GE.0.01 .AND. IENG.EQ.0 ) GOTO 300 250 IF ( ABS(VMAX).GE.1.0 ) GOTO 300 NEXP = NEXP - 3 VAL1 = VAL1 * 10.0**(+3) VAL2 = VAL2 * 10.0**(+3) VAL3 = VAL3 * 10.0**(+3) VMAX = VMAX * 10.0**(+3) IENG = 1 GOTO 250 C === C Determine the number of decimal places to be C displayed along the axis. C NDEC = 0 if integers are best C NDEC = 1,2, or 3 for all other cases. C === 300 X1 = ABS(VAL1) X3 = ABS(VAL3) NDEC = 0 350 F1 = AMOD( ABS(X1), 1.0 ) F3 = AMOD( ABS(X3), 1.0 ) IF ( ( ( F1.LT.0.001 .OR. F1.GT.0.999 ) .AND. 1 ( F3.LT.0.001. OR. F3.GT.0.999 ) ) .OR. 1 ( NDEC.GE.3 ) ) GOTO 400 NDEC = NDEC + 1 X1 = F1 * 10.0 X3 = F3 * 10.0 GOTO 350 C === C Move to the starting position and make a major tick mark. C === 400 X = XPAGE Y = YPAGE CALL PLOT( X, Y, 3 ) CALL PLOT( X, Y+TXMAJ , 2 ) CALL PLOT( X, Y, 3 ) C === C Draw the axis with tickmarks. C === DO 500 I = 1, INT( AXLEN ) X = X + 0.5 CALL PLOT( X, Y, 2 ) CALL PLOT( X, Y+TXMIN, 2 ) CALL PLOT( X, Y, 3 ) X = X + 0.5 CALL PLOT( X, Y, 2 ) CALL PLOT( X, Y+TXMAJ, 2 ) CALL PLOT( X, Y, 3 ) 500 CONTINUE C === C If NC is negative then just axis was to be drawn. C === IF( NC.LT.0 ) RETURN C === C Determine the IPOS value for the LABEL subroutine C for drawing the axis values. C === IF( ICODE.EQ.0 ) THEN DY = -OSV IPOS = 6 ELSE DY = OSV IPOS = 4 END IF C === C Draw the axis values at the major tick marks. C === X = XPAGE Y = YPAGE + DY NMAX = 0 ANGLE = 0.0 DO 600 I = 0, INT( AXLEN ) VALUE = VAL1 + I * VAL3 CALL CVNUM( VALUE, NDEC, CVALUE, NCHAR ) CALL LABEL( X, Y, CVALUE, NCHAR, HGTV, SLANT, ANGLE, IPOS, IBOLD ) IF( NCHAR.GT.NMAX ) NMAX = NCHAR X = X + 1.0 600 CONTINUE C === C Determine the number of characters in the axis label. C === NCHAR = NC IF( NCHAR.EQ.0 ) NCHAR = LENCHR( AXLAB ) CLABEL(1:NCHAR) = AXLAB(1:NCHAR) C === C Modify the axis label with "x10" if an adjustment was made C to the axis values. C === IF( IENG.EQ.0 ) GOTO 700 CALL CVNUM( FLOAT(NEXP), 0, CVALUE, N ) WRITE( CLABEL(NCHAR+1:), 660 ) CVALUE(1:N) 660 FORMAT( ' x10{', A, '}' ) NCHAR = NCHAR + N + 7 C === C Determine the appropriate IPOS value and X position for the C LABEL subroutine to draw the axis label. C === 700 DY = HGTV + OSV + OSL IF( IENG.NE.0 .AND. ICODE.EQ.0 ) DY = DY + HGTL/2.0 IF( ICODE.EQ.0 ) THEN IPOS = 6 DY = -DY ELSE IPOS = 4 END IF ANGLE = 0.0 C === C Draw the axis label. C === X = XPAGE + AXLEN/2.0 Y = YPAGE + DY CALL LABEL( X, Y, CLABEL, NCHAR, HGTL, SLANT, ANGLE, -IPOS, IBOLD ) C === C We be done!! C === RETURN END C === C SUBROUTINE YAXIS1( XPOS, YPOS, LABEL, NCHAR, ICODE, C 1 AXLEN, FIRSTV, DELTAV ) C C This subroutine draws a linear "Y" axis. C C Variables sent to subroutine: C C XPOS = X-coordinate of starting point of the axis. C YPOS = Y-coordinate of starting point of the axis. C LABEL = axis label to be centered along the axis. C NCHAR = Number of characters in label, C if NCHAR=0 then the subroutine will determine C the number of characters in LABEL. C AXLEN = Length of axis in whole inches. C FIRSTV = First value to be plotted on axis. C DELTAV = Change in axis values between 1" tick marks. C ICODE = Code specifying the type of Y axis to be drawn: C 0 axis values and label are positioned C to the left of the axis. C 1 axis values and label are positioned C to the right of the axis. C C ================================================================= SUBROUTINE YAXIS1( XPOS, YPOS, AXLAB, NC, ICODE, 1 AXLEN, FIRSTV, DELTAV ) CHARACTER CLABEL*132, CVALUE*14, AXLAB*(*) C === C Length of major and minor tick marks. C === TXMAJ = 0.08 TXMIN = 0.04 IF( ICODE.EQ.1 ) THEN TXMAJ = - TXMAJ TXMIN = - TXMIN END IF C === C Height of axis values and distance from the axis. C === HGTV = 0.11 OSV = 0.1 C === C Height of axis label and distance from axis values. C === HGTL = 0.14 OSL = 0.1 C === C LABEL subroutine values for character slant and bolding factor. C === SLANT = 0.0 IBOLD = 0 C === C Blank-out the labels. C === CLABEL = ' ' CVALUE = ' ' C == C Determine the largest absolute value to C be plotted on the axis. C === IENG = 0 NEXP = 0 VAL1 = FIRSTV VAL2 = FIRSTV + DELTAV * AXLEN VAL3 = DELTAV VMAX = AMAX1( ABS(VAL1), ABS(VAL2), ABS(VAL3) ) C === C Check to see if the maximum value is within C the 5 character limit. if not then adjust C axis values according to scientific notation. C C If axis values are too large (>= 10,000) C modify them by units of 10** 3,6,9,12 etc. C === 100 IF ( ABS(VMAX).LT.10000.0 .AND. IENG.EQ.0 ) GOTO 200 150 IF ( ABS(VMAX).LT.100.0 ) GOTO 300 NEXP = NEXP + 3 VAL1 = VAL1 * 10.0**(-3) VAL2 = VAL2 * 10.0**(-3) VAL3 = VAL3 * 10.0**(-3) VMAX = VMAX * 10.0**(-3) IENG = 1 GOTO 150 C === C Axis values are too small (<= 0.01) C modify them by units 10** -3,-6,-9,-12 ETC. C === 200 IF ( ABS(VMAX).GE.0.01 .AND. IENG.EQ.0 ) GOTO 300 250 IF ( ABS(VMAX).GE.1.0 ) GOTO 300 NEXP = NEXP - 3 VAL1 = VAL1 * 10.0**(+3) VAL2 = VAL2 * 10.0**(+3) VAL3 = VAL3 * 10.0**(+3) VMAX = VMAX * 10.0**(+3) IENG = 1 GOTO 250 C === C Determine the number of decimal places to be C displayed along the axis. C NDEC = 0 if integers are best C NDEC = 1,2, or 3 for all other cases. C === 300 X1 = ABS(VAL1) X3 = ABS(VAL3) NDEC = 0 350 F1 = AMOD( ABS(X1), 1.0 ) F3 = AMOD( ABS(X3), 1.0 ) IF ( ( ( F1.LT.0.001 .OR. F1.GT.0.999 ) .AND. 1 ( F3.LT.0.001. OR. F3.GT.0.999 ) ) .OR. 1 ( NDEC.GE.3 ) ) GOTO 400 NDEC = NDEC + 1 X1 = F1 * 10.0 X3 = F3 * 10.0 GOTO 350 C === C Move to the starting position and make a major tick mark. C === 400 X = XPOS Y = YPOS CALL PLOT( X, Y, 3 ) CALL PLOT( X+TXMAJ, Y, 2 ) CALL PLOT( X, Y, 3 ) C === C Draw the axis with tickmarks. C === DO 500 I = 1, INT( AXLEN ) Y = Y + 0.5 CALL PLOT( X, Y, 2 ) CALL PLOT( X+TXMIN, Y, 2 ) CALL PLOT( X, Y, 3 ) Y = Y + 0.5 CALL PLOT( X, Y, 2 ) CALL PLOT( X+TXMAJ, Y, 2 ) CALL PLOT( X, Y, 3 ) 500 CONTINUE C === C If NC is negatice then just axis was to be drawn. C === IF( NC.LT.0 ) RETURN C === C Determine the IPOS value for the LABEL subroutine C for drawing the axis values. C === IF( ICODE.EQ.0 ) THEN DX = -OSV C IPOS = 8 IPOS = 4 ELSE DX = OSV C IPOS = 2 IPOS = 4 END IF C === C Draw the axis values at the major tick marks. C === X = XPOS + DX Y = YPOS NMAX = 0 C ANGLE = 0.0 ANGLE = 90.0 DO 600 I = 0, INT( AXLEN ) VALUE = VAL1 + I * VAL3 CALL CVNUM( VALUE, NDEC, CVALUE, NCHAR ) CALL LABEL( X, Y, CVALUE, NCHAR, HGTV, SLANT, ANGLE, IPOS, IBOLD ) IF( NCHAR.GT.NMAX ) NMAX = NCHAR Y = Y + 1.0 600 CONTINUE C === C Determine the number of characters in the axis label. C === NCHAR = NC IF( NCHAR.EQ.0 ) NCHAR = LENCHR( AXLAB ) CLABEL(1:NCHAR) = AXLAB(1:NCHAR) C === C Modify the axis label with "x10" if an adjustment was made C to the axis values. C === IF( IENG.EQ.0 ) GOTO 700 CALL CVNUM( FLOAT(NEXP), 0, CVALUE, N ) WRITE( CLABEL(NCHAR+1:), 660 ) CVALUE(1:N) 660 FORMAT( ' x10{', A, '}' ) NCHAR = NCHAR + N + 7 C === C Determine the appropriate IPOS value and X position for the C LABEL subroutine to draw the axis label. C === 700 DX = NMAX * HGTV * 0.9 + OSV + OSL IF( IENG.NE.0 ) DX = DX + 0.5 * OSL IF( ICODE.EQ.0 ) THEN IPOS = 4 DX = -DX ELSE IPOS = 6 END IF ANGLE = 90.0 C === C Draw the axis label. C === X = XPOS + DX Y = YPOS + AXLEN/2.0 CALL LABEL( X, Y, CLABEL, NCHAR, HGTL, SLANT, ANGLE, -IPOS, IBOLD ) C === C We be done!! C === RETURN END C === C SUBROUTINE CVNUM( VALUE, NDEC, CHAR, NCHAR ) C C This subroutine converts the number VALUE into the character C variable CHAR with NDEC number of decimal places. The number C of character placed in CHAR is returned as NCHAR. C If NDEC is 0 then the number will appear as an integer with C no decimal point. C === SUBROUTINE CVNUM( V, NDEC, CHAR, NCHAR ) CHARACTER CHAR*14 VALUE = V C === C Determine the number of characters to the left of the C decimal point. C === IF( VALUE.EQ.0 ) THEN NLEFT = 1 ELSE IF( ABS(VALUE).LE.1.0 ) THEN NLEFT = 1 ELSE NLEFT = IFIX( LOG10( ABS( VALUE ) ) ) + 1 END IF C === C If the number is negative then there is one more character. C === IF( VALUE.LT.0.0 ) NLEFT = NLEFT + 1 C === C Determine the number of characters to the right of the C decimal point. C === IF( NDEC.EQ.0 ) THEN NRIGHT = 0 ELSE NRIGHT = NDEC + 1 END IF C === C Do the conversion of VALUE to CHAR. C === IF( NDEC.EQ.0 ) THEN WRITE( CHAR, 1000 ) inINT( VALUE ) ELSE WRITE( CHAR, 2000, ERR=9000 ) VALUE END IF 1000 FORMAT( I ) 2000 FORMAT( F. ) C === C And finally, put the number of character into NCHAR and return. C === NCHAR = NLEFT + NRIGHT RETURN 9000 TYPE 9010, VALUE, NDEC, NLEFT, NRIGHT 9010 FORMAT( //, 5X, 'ERROR IN CVNUM AT LINE: 41', /, 1 5X, 'VALUE:', G, /, 1 5X, 'NDEC =', I, ' NLEFT =', I, ' NRIGHT =', I ) RETURN END SUBROUTINE TICKS(X,Y,XAL,YAL) C C PROGRAMMER: C.L. MALLORY C ALFRED UNIVERSITY C C ROUTINE TO PLACE TICK MARKS ON RIGHT AND TOP SIDES OF GRAPH BOX. C C ARGUMENT DEFINITIONS: C C X,Y - LOCATION OF THE POINT IN COMMON BETWEEN THE C CURRENT X AND Y AXIS TO BE TICKED. C XAL,YAL - X AXIS AND Y AXIS LENGTHS. C C LOCAL VARIABLES: C TL - THE LENGTH OF THE TICK MARK TO BE USED. C C C EXTERNAL SUBROUTINES REQUIRED: C PLOT C IXAL=INT( XAL * 2. + .5 ) IYAL=INT( YAL * 2. + .5 ) TL=0.07 C TICK THE RIGHT HAND AXIS A=1.0 TK=TL/2.0 TL=TL-TK X1=X+XAL CALL PLOT(X1,Y,3) DO 10 I=1,IYAL Y1=Y+0.5*I CALL PLOT(X1,Y1,2) CALL PLOT(X1-TL,Y1,2) CALL PLOT(X1,Y1,2) TL=TL+A*TK A=-1.0*A 10 CONTINUE C TICK THE TOP AXIS. TL=0.07 TK=TL/2.0 TL=TL-TK A=1.0 Y1=Y+YAL CALL PLOT(X1,Y1,3) DO 15 I=IXAL-1,0,-1 X1=X+0.5*I CALL PLOT(X1,Y1,2) CALL PLOT(X1,Y1-TL,2) CALL PLOT(X1,Y1,2) TL=TL+A*TK A=-1.0*A 15 CONTINUE RETURN END