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