C C VERSION: NOV. 1982 C C THIS VERSION HAS BEEN CONVERTED FROM PERKIN-ELMER ANSI '77 C FORTRAN (R04) TO DEC LSI FORTRAN. C C WHEN COMPILED, CREATE A LIBRARY OF THESE ROUTINES AS :- C C LIB/CREATE PLOT LSIPLOT,BUFOUT,PACK C C C R.J. Morales C BLOCK DATA MPLTBK C C PARAMETER INDX=2, LUPLOT=8, LTHPLT=80 C INTEGER*2 PTR(16), PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) C DATA NPLOTS/0/ C END C C************************ SUBROUTINE PLOTS ************************ C CPROG PLOTS C SUBROUTINE PLOTS (DUMY1,DUMY2,DUMY3) C C SUBROUTINE TO INITIALIZE PLOTTER IN TWO SENSES: C 1- INITIALIZE THE PLOT FRAME C 2- GENERATE CODE TO INITIALIZE THE PLOT DEVICE C LOGICAL*1 ASGN INTEGER*4 RCL,DEVCOD DIMENSION IDAT(3) C INTEGER*4 ASERR(10) BYTE RNAME(30),DUMY1(30) C C PARAMETER INDX=2, LUPLOT=8, LTHPLT=80 C INTEGER*2 PTR(16), PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) C DATA BLANK /' '/ DATA ASERR /' ERR','OR: ','PLOT',' LUX','XX N','OT A', 1 'SSIG','NED.',' ',' '/ C IS THIS THE VERY FIRST PLOT? C LUPLOT =8 LTHPLT =80 C C NPLOTS=0 IMPLIES THAT THIS IS INDEED THE FIRST PLOT. C D9990 FORMAT (' ********** SUBR PLOTS **********') IF (NPLOTS.NE.0) GO TO 50 C C THIS IS THE FIRST PLOT. C C C OPEN THE FILE AS REQUIRED FOR UNFORMATTED I/O. C IF (DUMY1(1).LT.36) GOTO 15 CALL ERRSET(29,.TRUE.,,.TRUE.,.FALSE.) CALL ERRSET(30,.TRUE.,,.TRUE.,.FALSE.) CALL ERRSET(43,.TRUE.,,.FALSE.,.FALSE.) OPEN (UNIT=LUPLOT,FORM='UNFORMATTED',RECORDSIZE=20, 1 NAME=DUMY1,ACCESS='DIRECT',TYPE='NEW',ERR=15) CALL ERRTST(43,I) IF (I.EQ.1)GOTO 15 GOTO 32 15 CALL ERRSET(29,.TRUE.,,.TRUE.,.TRUE.) CALL ERRSET(30,.TRUE.,,.TRUE.,.TRUE.) CALL ERRSET(43,.TRUE.,,.FALSE.,.TRUE.) TYPE 20 20 FORMAT ('$Enter name of IPF file ->') ACCEPT 25,RNAME 25 FORMAT (30A1) RNAME(30)=0 C 30 OPEN (UNIT=LUPLOT,FORM='UNFORMATTED',RECORDSIZE=20, 1 NAME=RNAME,ACCESS='DIRECT',TYPE='NEW') D OPEN (UNIT=7,FORM='FORMATTED',RECORDSIZE=80,NAME='PTEST.LU7', D 1 ACCESS='SEQUENTIAL',TYPE='NEW') C 32 PLTPTR =2 NPLOTS =1 LASTR =1 PTR(1) =2 C C WRITE AN ALL-BLANKS GLOBAL RECORD. C CALL FILBYT (BLANK,0,BUFF(1),0,LTHPLT) WRITE (LUPLOT'1) BUFF GO TO 60 C C HERE IF THIS IS NOT THE FIRST PLOT. C 50 PLTPTR =LASTR+1 NPLOTS =NPLOTS+1 C C READ GLOBAL (FIRST) RECORD. C READ (LUPLOT'1) BUFF C C PLACE DATE AND TIME INTO GLOBAL RECORD AREA. C 60 CALL IDATE (IDAT(1),IDAT(2),IDAT(3)) ENCODE (8,62,BUFF) IDAT 62 FORMAT (I2,1H/,I2,1H/,I2) CALL TIME (BUFF(4)) C C UPDATE THE NUMBER OF PLOTS IN THE FILE. C BUFF(6) =NPLOTS C C FOR COMPATIBILITY WITH P-E VERSION, PLACE 0'S INTO HIGH-ORDER C 2 BYTES OF THIS 4-BYTE ELEMENT. C CALL FILBYT ("00,0,BUFF(1),22,2) C C INSERT THIS PLOT'S FIRST-RECORD POINTER. C PTR(NPLOTS) =PLTPTR C WRITE (LUPLOT'1) BUFF C C INITIALIZE THIS PLOT'S EXTREME VALUES. C XMAX =0. XMIN =0. YMAX =0. YMIN =0. C C INITIALIZE PLOT OFFSETS AND SCALE FACTORS. C XCURR = 0. YCURR = 0. FAC = 1. XORGIN= 0. YORGIN= 0. XFAC = 1. YFAC = 1. XOFF = 0. YOFF = 0. XMIN = 0. YMIN = 0. XMAX = 0. YMAX = 0. C C INITIALIZE THE BUFFER PACKING AND OUTPUT SUBROUTINE. C THIS WILL ALSO GENERATE THE PLOT INITIALIZATION STRING. C CALL BUFPAK (1,FC,0,0) C RETURN END C C*************** SUBROUTINE PLOT ******************* C CPROG PLOT C SUBROUTINE PLOT (EX,EY,NPEN) C C PLOT SUBROUTINE WITH 'CALCOMP' SPECIFICATIONS. C C X =X-DISTANCE IN CM. C Y =Y-DISTANCE IN CM. C NPEN = PEN AND OFFSET CONTROL: C UNITS POSITION = 2 IMPLIES PEN DOWN (BRIGHT VECTOR) C UNITS POSITION = 3 IMPLIES PEN UP (DARK VECTOR) C TENS POSITION = 1 IMPLIES ADD OFFSETS TO EACH COORD. C NPEN < 0 IMPLIES REDEFINE ORIGIN. C NPEN =999 IMPLIES TERMINATE PLOT FRAME. C DIMENSION NOK (10) INTEGER*4 ERRN(11) C C PARAMETER INDX=2, LUPLOT=8, LTHPLT=80 C INTEGER*2 PTR(16), PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) C DATA NOK /2,3,-2,-3,12,13,-12,-13,-13,-13/ DATA ERRN/' ERR','OR I','N TH','IRD ','ARGU','MENT',' TO ', 1 'SUBR',' PLO','T:XX','XXX.'/ C LUPLOT =8 C D WRITE (7,9990) EX,EY,NPEN D9990 FORMAT (' ********** PLOT **********',2F7.2,I3) C X =EX Y =EY C C IS THIS PLOT TERMINATION? C IF (NPEN.EQ.999) GO TO 60 C C IT IS AN ORDINARY PLOT MOVEMENT. C RANGE CHECK THE ARGUMENT. C DO 20 I=1,10 20 IF (NPEN.EQ.NOK(I)) GO TO 30 C C ERROR: 'NPEN' IS OUT OF RANGE. C ENCODE (43,25,ERRN) NPEN 25 FORMAT (38X,I5) C CALL CONMSG(44,ERRN) C CALL EXIT (LUPLOT) C C SET THE CURRENT COORDINATE VALUES C 30 XCURR =X YCURR =Y C C ARE TEMPORARY OFFSETS TO BE APPLIED? C IF (IABS(NPEN).LT.10) GO TO 40 C C APPLY THE TEMPORARY OFFSETS. C X =X*XFAC+XOFF Y =Y*YFAC+YOFF C C APPLY THE GLOBAL OFFSETS C 40 X =X*FAC+XORGIN Y =Y*FAC+YORGIN C C UPDATE THE PLOT EXTREMA. C IF (X.LT.XMIN) XMIN =X IF (X.GT.XMAX) XMAX =X IF (Y.LT.YMIN) YMIN =Y IF (Y.GT.YMAX) YMAX =Y C C SEE IF THE ORIGIN IS TO BE REDEFINED. C IF (NPEN.GT.0) GO TO 50 C C REDEFINE THE ORIGIN C XORGIN =X YORGIN =Y C C IS THE PEN UP? C 50 NTEMP =IABS (NPEN) NTEMP =MOD(NTEMP,10) IF (NTEMP.EQ.2) FC ='D' IF (NTEMP.EQ.3) FC ='C' C C SEND THIS TO THE PLOT LU. C CALL BUFPAK (2,FC,X,Y) C GO TO 100 C C THIS PLOT FRAME IS TO BE TERMINATED. C CALL THE BUFFER PACKING AND OUTPUT ROUTINE TO GENERATE THE C PLOT-DOWN INSTRUCTIONS, THEN FLUSH THE BUFFER. C 60 CALL BUFPAK (3,FC,0.,0.) C C NOW UPDATE THIS PLOT'S HEADER INFORMATION. C READ (LUPLOT'PLTPTR) BUFF C ENCODE (32,65,BUFF) XMIN,XMAX,YMIN,YMAX 65 FORMAT (4F8.2) C WRITE (LUPLOT'PLTPTR) BUFF C 100 RETURN END C C----------SUBROUTINE--SCALE-------------------------- C CPROG SCALE C SUBROUTINE SCALE(ARRAY,AXLEN,NPTS,INC) C C C COPYRIGHT INTERDATA AUSTRALIA FEB 1976 C C PROGRAM IS WRITTEN IN FORTRAN 5 C C C SCALE IS USED TO OBTAIN SCALING PARAMETERS FOR AXIS, LINE C C CONSULT USER MANUAL (29-800198) FOR ARGUMENT MEANINGS C C DIMENSION ARRAY(NPTS),ACTINT(7) C C DAXIS DEFINES THE DISTANCE BETWEEN TICK MARKS C DATA DAXIS/2.5/ C C TABLE OF REASONABLE SCALES DATA ACTINT/1.,2.,4.,5.,8.,10.,20./ C ACTINT MAY BE MODIFIED IF REQUIRED BUT NINT (AND DIMENSION) C STATEMENT SHOULD ALSO BE MODIFIED C NOTE THAT ACTINT(NINT-1) MUST = ACTINT(1)*10. C AND ACTINT( NINT) MUST = ACTINT(2)*10. DATA NINT/7/ C DO SET UP OF INDICES INCA=INC IF (INCA) 1,2,3 1 INCA=-INCA GO TO 3 2 INCA=1 3 IMAX=1+(NPTS-1)*INCA IFRSTV=IMAX+INCA IDLTAV=IFRSTV+INCA C GET MIN AND MAX OF DATA VALUES DMIN=ARRAY(1) DMAX=DMIN DO 5 I=1,IMAX,INCA DMAX=AMAX1(DMAX,ARRAY(I)) DMIN=AMIN1(DMIN,ARRAY(I)) 5 CONTINUE C GET FIRST GUESS INTERVAL IN FORM TINTVL*(10**IPOW) FNTICK=INT(AXLEN/DAXIS) TINTVL=(DMAX-DMIN)/FNTICK ALGINT=ALOG10(TINTVL) IPOW=ALGINT IF (ALGINT.LT.0.) IPOW=IPOW-1 TINTVL=10.**(ALGINT-FLOAT(IPOW)) C NOW SELECT ACTUAL VALUE INTERVAL FROM TABLE DO 10 I=1,NINT IF (TINTVL.LE.ACTINT(I)) GOTO 12 10 CONTINUE C HAVE SELECTED ACTINT(I)*(10.**IPOW)-CHECK IT 12 TINTVL=ACTINT(I)*(10.**IPOW) C GET MINIMUM AXIS VALUE TMIN=FLOAT(INT(DMIN/TINTVL))*TINTVL IF (DMIN.LT.0.) TMIN=TMIN-TINTVL C GET MAXIMUM AXIS VALUE TMAX=FNTICK*TINTVL+TMIN C CHECK IF MAX IS SUFFICIENT IF (TMAX.GE.DMAX) GO TO 20 C NOT SUFFICIENT - INCREMENT INT RVAL I=I+1 GO TO 12 C SET PARAMETERS FOR POSITIVE/NEGATIVE GOING AXIS AND EXIT 20 IF (INC) 40,30,30 C POSITIVE GOING 30 ARRAY(IFRSTV)=TMIN ARRAY(IDLTAV)=TINTVL RETURN C NEGATIVE GOING 40 ARRAY(IFRSTV)=TMAX ARRAY(IDLTAV)=-TINTVL RETURN C END C C----------SUBROUTINE--AXIS---------------------------- C CPROG AXIS C$TRACE C SUBROUTINE AXIS(XPAGE,YPAGE,IBCD,NCHAR,AXLEN,ANGLE,FIRSTV,DELTAV) C C C COPYRIGHT INTERDATA AUSTRALIA FEB 1976 C C PROGRAM IS WRITTEN IN FORTRAN 5 C C C AXIS IS USED TO PLOT AXIS WITH NUMBERING AND LABELING C C DIMENSION IBCD(1) C C THE LAYOUT OF THE AXIS IS CONTROLLED BY THE FOLLOWING C PARAMETERS C C DAXIS - DISTANCE BETWEEN TICK MARKS DATA DAXIS/2.5/ C DTICK - LENGTH OF TICK MARK DATA DTICK/0.18/ C DNUM - DISTANCE FROM BOTTOM OF TICK MARK TO TOP OF NUMBER DATA DNUM /0.072/ C HNUM - HEIGHT OF NUMBERS DATA HNUM/0.3/ C DLAB - DISTANCE FROM BOTTOM OF NUMBERS TO TOP OF EXPONENT DATA DLAB /0.072/ C HEXP - HEIGHT OF EXPONENT CHARACTERS DATA HEXP /0.18/ C HLAB - HEIGHT OF LABEL CHARACTERS DATA HLAB/0.56/ D WRITE (7,9990) D9990 FORMAT (' ********** AXIS **********') D WRITE (7,9991) XPAGE,YPAGE,NCHAR,AXLEN,ANGLE,FIRSTV,DELTAV D9991 FORMAT (' AXIS ARGS:',2F5.1,I5,4F5.1) C C SEND A 'START AXIS' FUNCTION CODE. C CALL PUTFC ('J') C C SET UP THINGS NTICK=AXLEN/DAXIS SIDE=1. SIDEDN=0. NCHARA=NCHAR IF (NCHARA) 40,41,41 40 SIDE=-1. SIDEDN=-1. NCHARA=-NCHARA 41 CONTINUE STICK=SIDE*DTICK COSINE=COS(ANGLE/57.295791) SINE=SIN(ANGLE/57.295791) C MOVE PEN TO START OF AXIS CALL PLOT(XPAGE,YPAGE,3) C PLOT AXIS C C PLOT INITIAL TICK MARK XN=XPAGE-STICK*SINE YN=YPAGE+STICK*COSINE CALL PLOT(XN,YN,2) CALL PLOT(XPAGE,YPAGE,2) C DO REST DO 1 I=1,NTICK C PLOT AXIS TO NEXT TICK MARK XT = FLOAT(I)*DAXIS XP = XPAGE+XT*COSINE YP = YPAGE+XT*SINE CALL PLOT(XP,YP,2) C PLOT TICK MARK XN = XP-STICK*SINE YN = YP+STICK*COSINE CALL PLOT(XN,YN,2) CALL PLOT(XP,YP,2) 1 CONTINUE C FINISH AXIS BEYOND LAST TICK POINT XP=XPAGE+AXLEN*COSINE YP=YPAGE+AXLEN*SINE CALL PLOT(XP,YP,2) C CHECK NUMBERING INCREMENT AND SCALE TO C GET INCREMENT LESS THAN 100 AND GREATER THAN 0.01 C C INITIALISE EXPONENT AND GET ABS VALUE OF INCREMENT FEXP = 0. DLTAV1= DELTAV 2 DLTAVA= ABS(DLTAV1) C CHECK SIZE OF INCREMENT IF(DLTAVA.GE.100.)GO TO 3 IF(DLTAVA.GE.0.01)GO TO 4 C INCREMENT TOO SMALL - ADJUST UPWARDS AND RECHECK FEXP=FEXP-1. DLTAV1=DLTAV1*10. GO TO 2 C INCREMENT TOO BIG - ADJUST DOWNWARDS AND RECHECK 3 FEXP=FEXP+1. DLTAV1=DLTAV1/10. GO TO 2 C INCREMENT NOW OK -ADJUST NUMBER ON FIRST TICK 4 FRSTV1=FIRSTV/(10.**FEXP) C SET UP NO DIGITS FOLLOWING DECIMAL POINT C NONE (AND NO DECIMAL PT) IF INTERVAL >= 1. C 2 IF INTERVAL < 0.1 C 1 OTHERWISE NDEC =-1 IF (DLTAVA.GE.1.)GO TO 5 NDEC=1 IF (DLTAVA.GE.0.1) GO TO 5 NDEC =2 5 CONTINUE C FIND STARTING Y POSITION OF NUMBERS YN=(DTICK+DNUM)*SIDE+HNUM*SIDEDN C PLOT NUMBERS NTICK1=NTICK+1 DO 10 I=1,NTICK1 C GET X POSITION OF START OF NUMBER RELATIVE TO AXIS XN=FLOAT(I-1)*DAXIS-HNUM/2. C HENCE WITH AXIS ROTATION POSITION IS XP=XPAGE+XN*COSINE-YN*SINE YP=YPAGE+XN*SINE+YN*COSINE C NOW GET NUMBER AND PLOT IT FPN=FRSTV1+FLOAT(I-1)*DLTAV1 10 CALL NUMBER(XP,YP,HNUM,FPN,ANGLE,NDEC) D WRITE (7,9992) XP,YP,HNUM,FPN,ANGLE,NDEC D9992 FORMAT (' XP,YP,HNUM,FPN,ANGLE,NDEC: ',5F6.1,I6) C C FIND STARTING POSITION OF LABEL C GET LABEL LENGTH INCLUDING *10 FOR MULTIPLIER IF REQUIRED NCHARB=NCHARA IF (FEXP)20,21,20 20 NCHARB=NCHARB+5 21 XL=AXLEN/2.-FLOAT(NCHARB)*HLAB/2. YL=(DTICK+DNUM+HNUM+DLAB)*SIDE+(HLAB+HEXP)*SIDEDN C WITH ROTATION POSITION IS XP = XPAGE+XL*COSINE-YL*SINE YP = YPAGE+XL*SINE+YL*COSINE C PLOT CALLERS LABEL CALL SYMBOL(XP,YP,HLAB,IBCD,ANGLE,NCHARA) C PLOT MULTIPLIER IF REQUIRED IF(FEXP)25,30,25 25 CALL SYMBOL(999.,999.,HLAB,5H *10,ANGLE,5) C PLOT EXPONENT CALL NUMBER(999.,(HLAB-HEXP/2),HEXP,FEXP,ANGLE,-1) C LIFT PEN AND EXIT 30 CALL WHERE(XP,YP,XL) CALL PLOT(XP,YP,3) C C SEND THE 'AXIS STOP' FUNCTION CODE. C CALL PUTFC ('K') C RETURN END C C C----------SUBROUTINE--LINE------------------------------- C CPROG LINE C$TRACE C SUBROUTINE LINE(XARRAY,YARRAY,NPTS,INC,LINTYP,INTEQ) C C C LINE IS USED TO PLOT X/Y DATA IN 2 ARRAYS C C COPYRIGHT INTERDATA AUSTRALIA FEB 1976 C C PROGRAM IS WRITTEN IN FORTRAN 5 C C C FOR MEANINGS OF ARGUMENTS SEE PLOT UTILITY PACKAGE MANUAL 29-800198 C C INTEGER*2 INTQ C DIMENSION XARRAY(NPTS),YARRAY(NPTS) C THE FOLLOWING DATA STATEMENTS DEFINE THE ANGLE AND SIZE OF THE C SPECIAL SYMBOL WHICH MAY BE PLOTTED DATA SYMANG/0./ DATA SYMHT/0.35/ C C SINCE LINE MAY BE USED TO PLOT DATA USING C SCALING PARAMETERS PREPARED BY SCALE, LINE MUST C KNOW THE DISTANCE BETWEEN TICK MARKS (DAXIS) C USED BY SCALE IN COMPUTING THE SCALING FACTORS. C DAXIS IS SET BY THE FOLLOWING DATA STATEMENT C DATA DAXIS/2.5/ D WRITE (7,9990) D9990 FORMAT (' ********** LINE **********') C C MAKE LAST ARGUMENT INTEGER*2 C INTQ =INTEQ C DAXIS1=DAXIS GO TO 20 C C THE FOLLOWING ENRTY POINT IS PROVIDED TO ALLOW C LINE TO BE USED WITH SCALING PARAMETERS SET BY THE C USER, RATHER THAN BY SCALE. IN THIS CASE THE EFFECTIVE C DISTANCE BETWEEN TICK MARKS IS 1. I.E. DELTAV C GIVES THE NUMBER OF DATA UNITS PER CENTIMETER. C C THE ENTRY STATEMENT IS NOT SUPPORTED BY THIS FORTRAN. C C C GET SCALING PARAMETERS 20 I=NPTS*INC+1 C C SEND THE 'LINE START' FUNCTION CODE. C CALL PUTFC ('N') C C GET SYMBOL ADJUSTMENT FACTORS C YS =SYMHT/2. XS =SYMHT*.357 C REMOVE FOLLOWING TWO LINES FOR DRUM PLOTTERS. XPAGE=0.0 YPAGE=0.0 XFRSTV=XARRAY(I) YFRSTV=YARRAY(I) I=I+INC XDLTAV=ABS(XARRAY(I))/DAXIS1 YDLTAV=ABS(YARRAY(I))/DAXIS1 C MOVE TO START POINT XP=XPAGE+(XARRAY(1)-XFRSTV)/XDLTAV YP=YPAGE+(YARRAY(1)-YFRSTV)/YDLTAV CALL PLOT(XP,YP,3) C SET UP PEN CONTROL LNTYPA=LINTYP IF(LINTYP)1,2,2 1 IPEN=3 IPENSY=-1 LNTYPA=-LNTYPA GOTO 4 2 IPEN=2 IPENSY=-2 4 CONTINUE C C PLOT LINE/SYMBOL AS REQUIRED I=1-INC DO 10 J=1,NPTS I=I+INC XP=XPAGE+(XARRAY(I)-XFRSTV)/XDLTAV YP=YPAGE+(YARRAY(I)-YFRSTV)/YDLTAV C IF (LINTYP) 5,6,5 5 IF (MOD(J,LNTYPA)) 6,7,6 6 CALL PLOT(XP,YP,IPEN) GO TO 10 7 CALL SYMBOL(XP,YP,SYMHT,INTQ,SYMANG,IPENSY) 10 CONTINUE C LIFT PEN AND EXIT CALL PLOT(XP,YP,3) C C SEND THE 'LINE STOP' FUNCTION CODE. C CALL PUTFC ('O') C END C C----------SUBROUTINE--NUMBER-------------------------- C CPROG NUMBER C$TRACE C SUBROUTINE NUMBER(XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC) C C C NUMBER CONVERTS AND THEN PLOTS A FLOATING POINT NUMBER C C COPYRIGHT INTERDATA AUSTRALIA FEB 1976 C C PROGRAM IS WRITTEN IN FORTRAN 5 C C C FOR MEANINGS OF ARGUMENTS SEE PLOT UTILITY PACKAGE MANUAL 29-800198 C C INTEGER*2 IARRAY(20) DIMENSION P(11) DATA P(1),P(2),P(3),P(4),P(5),P(6)/1.E10,1.E9,1.E8,1.E7,1.E6,1.E5/ DATA P(7),P(8),P(9),P(10),P(11)/1.E4,1.E3,1.E2,1.E1,1.E0/ DATA MINUS,LDT,LBLNK,L0/45,46,32,48/ D WRITE (7,9990) D9990 FORMAT (' ********** NUMBER **********') C C SEND 'NUMBER START' FUNCTION CODE. C CALL PUTFC ('H') C J = 0 FPN1 = FPN NDEC1 = NDEC INDIC = 1 C NDEC1 MUSTN'T BE > 9. IF (NDEC1.GT.9) NDEC1 = 9 IF (NDEC1.LT.-9) NDEC1 = -9 C INDIC IS FOR DEC. PT. OR NOT C CHECK FOR FPN1<0 IF (FPN1) 10,20,20 10 FPN1 = -FPN1 J = J + 1 IARRAY(J) = MINUS C ROUND FPN1 + TRUNCATE IF NECESSARY. THE ORDER OF THESE C INSTR'S CAN BE CHANGED IF THE USER SO WISHES. C MANT + 1 WILL GIVE NO. OF DIGITS TO LEFT OF DEC. PT. 20 IF (NDEC1) 30,40,40 30 FPN1 = FPN1 + 0.5 FPN1 = FPN1 / P(NDEC1 + 12) INDIC = 0 GO TO 50 40 KK = -NDEC1 + 11 FPN1 = FPN1 + 0.5 / P(KK) 50 MANT = INT(ALOG10(FPN1)) IF (MANT) 60,70,70 60 MANT = 0 70 KK = -MANT + 10 FPN1 = FPN1 / P(KK) LMT = MANT + 1 IF (NDEC1.GT.0) LMT = LMT + NDEC1 C LOOP LIMIT 'LMT' SHOULD NOW BE FIXED CORRECTLY. C NOW CONVERT THE FL. PT. NO. TO A CHAR. STRING. DO 80 I = 1,LMT FPN1 = FPN1 * 10. LCH = INT(FPN1) FPN1 = FPN1 - FLOAT(LCH) J = J + 1 IARRAY(J) = LCH + L0 D WRITE (7,9992) J,IARRAY(J) D9992 FORMAT (' IARRAY(',I2,') = ',A1) IF (I.NE.(MANT+1)) GO TO 80 IF (INDIC.EQ.0) GO TO 80 J = J + 1 IARRAY(J) = LDT 80 CONTINUE C SHOULD NOW HAVE CHARACTER STRING IN ARRAY UNPACKED. C GO INTO A 'PACKING' LOOP. C N.B. J = NO. OF CHARS. TO BE PLOTTED. IARRAY(J+1) = 0 C C PACK THE ASCII STRING INTO CONTIGUOUS BYTES IN THE ARRAY. C NOTE THAT THIS IS A MODIFICATION FROM THE ORIGINAL P-E CODING. C DO 90 I=0,J 90 CALL CPYBYT (IARRAY,I*2,IARRAY,I,1) C C CALL SYMBOL ROUTINE WITH IARRAY + J. D WRITE (7,9991) FPN,FPN1,NDEC,NDEC1,MANT,LMT,(IARRAY(I),I=1,3) D9991 FORMAT (' NUMBDIAG:',2F8.2,4I5/11X,5A2) CALL SYMBOL(XPAGE,YPAGE,HEIGHT,IARRAY,ANGLE,J) C C SEND 'NUMBER STOP' FUNCTION CODE. C CALL PUTFC ('I') C RETURN END C C----------SUBROUTINE--SYMBOL------------------------------ C CPROG SYMBOL C$TRACE C SUBROUTINE SYMBOL(XPAGE,YPAGE,HEIGHT,IBCD,ANGLE,NCHAR) C C C COPYRIGHT INTERDATA AUSTRALIA FEB 1976 C C C PROGRAM HAS BEEN CONVERTED TO RUN UNDER F7D COMPILER. C IMBEDDED CAL CODE HAS BEEN REPLACED BY ALL FORTRAN. C R.J. MORALES, FEB 1979 C C C SYMBOL IS USED TO PLOT CHARACTERS C C PLOT CHARACTER IS SPECIAL IF NCHAR<0 C LOGICAL SPC1,SPC2,NEGNCH LOGICAL EQBYT C INTEGER*2 IBCD(1),ICH,FF INTEGER*2 CHM1,CHM2,CHM3,CHM4,CHM5,CHM5A,CHM6 C INTEGER*4 ICHMVE(4,79) DIMENSION CHM1(8,14),CHM2(8,16),CHM3(8,10),CHM4(8,7),CHM5(8,20) DIMENSION CHM5A (8,6) DIMENSION CHM6(8,6) C EQUIVALENCE (CHM1(1,1),ICHMVE(1,1)),(CHM2(1,1),ICHMVE(1,15)) EQUIVALENCE (CHM3(1,1),ICHMVE(1,31)),(CHM4(1,1),ICHMVE(1,41)) EQUIVALENCE (CHM5(1,1),ICHMVE(1,48)),(CHM6(1,1),ICHMVE(1,74)) EQUIVALENCE (CHM5A(1,1),ICHMVE(1,68)) C DATA ICH/0/, ICHM/0/, MASK/"000007/, FF/"177777/ C C A FULLER DESCRIPTION OF THE FOLLOWING CHARACTERS CAN BE C FOUND IN THE P-E 8/32 VERSION OF THIS PROGRAM. C C FIRST 14 ARE SPECIAL NON-ASCII CHARACTERS. C DATA CHM1 /"052104,"040140,"062124,"051377, 2 "177777,"177777,"177777,"177777, S "052114,"041501,"044130,"060543, 2 "056124,"051377,"177777,"177777, S "052101,"060524,"051377,"177777, 2 "177777,"177777,"177777,"177777, S "052122,"041122,"050122,"061122, 2 "177777,"177777,"177777,"177777, S "042122,"040122,"060122,"062122, 2 "177777,"177777,"177777,"177777, S "052102,"050142,"052122,"177777, 2 "177777,"177777,"177777,"177777, S "052102,"061124,"050122,"177777, 2 "177777,"177777,"177777,"177777, S "040144,"042140,"051377,"177777, 2 "177777,"177777,"177777,"177777, S "040140,"021102,"002144,"051377, 2 "177777,"177777,"177777,"177777, S "042122,"062122,"050122,"177777, 2 "177777,"177777,"177777,"177777, S "062133,"045504,"045511,"040111, 2 "054540,"054533,"051377,"177777, S "052004,"060020,"051142,"022100, 2 "001122,"177777,"177777,"177777, S "062104,"060100,"051377,"177777, 2 "177777,"177777,"177777,"177777, S "052120,"051377,"177777,"177777, 2 "177777,"177777,"177777,"177777/ C C SOME SPECIAL ASCII CHARACTERS C DATA CHM2 /"020377,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "010520,"054131,"050432,"057377, 2 "177777,"177777,"177777,"177777, S "006116,"013124,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "053056,"054054,"042002,"065377, 2 "177777,"177777,"177777,"177777, S "000510,"054141,"061133,"045504, 2 "042516,"057145,"057130,"044116, S "063026,"047115,"052526,"010520, 2 "054131,"050777,"177777,"177777, S "020105,"047136,"062544,"055513, 2 "041101,"044130,"060542,"055777, S "013124,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "014112,"046136,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "004132,"056116,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "000545,"012521,"020505,"001543, 2 "177777,"177777,"177777,"177777, S "010525,"001543,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "004121,"051112,"044521,"177777, 2 "177777,"177777,"177777,"177777, S "001543,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "004120,"050511,"044377,"177777, 2 "177777,"177777,"177777,"177777, S "063377,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777/ C C DIGITS 0-9 C DATA CHM3 /"004101,"042516,"057145,"060530, 2 "044145,"177777,"177777,"177777, S "002126,"050100,"060377,"177777, 2 "177777,"177777,"177777,"177777, S "002516,"057145,"062101,"040140, 2 "177777,"177777,"177777,"177777, S "000510,"054141,"061133,"045533, 2 "062145,"057116,"042777,"177777, S "014136,"041502,"061377,"177777, 2 "177777,"177777,"177777,"177777, S "000510,"054141,"061133,"041506, 2 "063377,"177777,"177777,"177777, S "001533,"061141,"054110,"040505, 2 "047136,"062777,"177777,"177777, S "063106,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "005504,"042516,"057145,"062133, 2 "045502,"040510,"054141,"061133, S "000510,"054141,"062536,"047105, 2 "042113,"061777,"177777,"177777/ C C SOME SPECIAL ASCII CHARACTERS C DATA CHM4 /"004512,"051121,"044414,"046525, 2 "052114,"177777,"177777,"177777, S "004121,"051112,"044521,"011524, 2 "046113,"051777,"177777,"177777, S "014103,"057377,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "000541,"002144,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "055506,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "004510,"050121,"044422,"051533, 2 "062145,"057116,"042777,"177777, S "014110,"040505,"047136,"062542, 2 "051124,"062377,"177777,"177777/ C C ALPHABETICS: A-Z C DATA CHM5 /"042516,"057145,"061503,"061540, 2 "177777,"177777,"177777,"177777, S "043136,"062544,"055503,"055542, 2 "060530,"040377,"177777,"177777, S "022536,"047105,"040510,"054141, 2 "177777,"177777,"177777,"177777, S "043136,"062541,"054100,"177777, 2 "177777,"177777,"177777,"177777, S "023106,"041533,"041500,"060377, 2 "177777,"177777,"177777,"177777, S "023106,"041533,"041500,"177777, 2 "177777,"177777,"177777,"177777, S "022536,"047105,"040510,"054141, 2 "061533,"177777,"177777,"177777, S "043103,"061546,"060377,"177777, 2 "177777,"177777,"177777,"177777, S "007136,"053120,"044130,"177777, 2 "177777,"177777,"177777,"177777, S "000510,"050131,"057146,"043377, 2 "177777,"177777,"177777,"177777, S "043046,"041540,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "003100,"060377,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "043124,"063140,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "043140,"063377,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "004101,"042516,"057145,"060530, 2 "044377,"177777,"177777,"177777, S "043136,"062544,"055503,"177777, 2 "177777,"177777,"177777,"177777, S "004101,"042516,"057145,"060530, 2 "044022,"060377,"177777,"177777, S "043136,"062544,"055503,"045540, 2 "177777,"177777,"177777,"177777, S "000510,"054141,"061133,"045504, 2 "042516,"057145,"177777,"177777, S "003146,"053120,"177777,"177777, 2 "177777,"177777,"177777,"177777/ C DATA CHM5A/"003101,"044130,"060546,"177777, 2 "177777,"177777,"177777,"177777, S "003120,"063377,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "003100,"051140,"063377,"177777, 2 "177777,"177777,"177777,"177777, S "063006,"060377,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "003124,"063124,"050377,"177777, 2 "177777,"177777,"177777,"177777, S "003146,"040140,"177777,"177777, 2 "177777,"177777,"177777,"177777/ C C MORE SPECIAL ASCII CHARACTERS C DATA CHM6 /"014100,"043136,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "003140,"177777,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "054136,"043377,"177777,"177777, 2 "177777,"177777,"177777,"177777, S "010126,"042126,"062377,"177777, 2 "177777,"177777,"177777,"177777, S "005103,"046103,"061777,"177777, 2 "177777,"177777,"177777,"177777, S "060146,"043100,"063106,"060377, 2 "177777,"177777,"177777,"177777/ D WRITE (7,9992) XPAGE,YPAGE,HEIGHT,IBCD(1),ANGLE,NCHAR D9992 FORMAT (' ********** SYMBOL **********'/ D 1 3F8.2,A2,F8.2,I4) C C SEND THE 'SYMBOL START' FUNCTION CODE. C CALL PUTFC ('F') C C C SET SPECIAL CHARACTER SWITCHES C C NEGNCH .TRUE. IF NCHAR<0, INDICATING SPECIAL CHARACTER C SPC1 .TRUE. IF SPECIAL CHAR IS NON-ASCII (IBCD(1)<14) C SPC2 .TRUE. IF SPECIAL CHAR IS ASCII (IBCD(1)>13) C SPC1 =.FALSE. SPC2 =.FALSE. NEGNCH =.FALSE. C IF (NCHAR.GE.0) GO TO 65 NEGNCH =.TRUE. C C RANGE CHECK SYMBOL INTEGER C IF (IBCD(1).LT.0.OR.IBCD(1).GT.77) IBCD(1)=78 IF (IBCD(1).LT.14) SPC1 =.TRUE. IF (IBCD(1).GE.14) SPC2 =.TRUE. C C CALCULATE CONSTANTS 65 SINE=SIN(ANGLE/57.295791) COSINE=COS(ANGLE/57.295791) SIZE=HEIGHT/6. C ADJUST FOR CONTINUATION IF REQUIRED XP=0. YP=0. CALL WHERE(CURX,CURY,XFACT) D WRITE (7,9996) CURX,CURY,XFACT D9996 FORMAT (' CURX,CURY,XFACT',3F10.2) XC=CURX YC=CURY TESTY=ABS(YPAGE-999.) C CONTINUATION IN X ? IF (ABS(XPAGE-999.).GT.0.001) GO TO 90 C YES - CONTINUATION IN Y ALSO ? IF (TESTY.LE.0.001) GO TO 92 C NO - JUST X YP=YPAGE GO TO 92 C NO CONTINUATION IN X - IS THERE CONTINUATION IN Y ? 90 IF (TESTY.GT.0.001) GO TO 91 C YES XP=XPAGE GO TO 92 C NO CONTINUATION AT ALL 91 XC=XPAGE YC=YPAGE 92 XPAGE1=XC+XP*COSINE-YP*SINE YPAGE1=YC+XP*SINE+YP*COSINE D WRITE (7,9997) XC,YC,XP,YP,SINE,COSINE D9997 FORMAT (' XC,YC,XP,YP,SINE,COSINE:',6F8.2) D WRITE (7,9998) XPAGE1,YPAGE1 D9998 FORMAT (' XPAGE1,YPAGE1:',2F10.2) C IF IS SPECIAL CHAR MOVE TO START POSN WITH PEN C UP OR DOWN AS REQUIRED IPEN=3 IF (.NOT.NEGNCH) GO TO 3 IF (NCHAR.EQ.-1) GO TO 2 IPEN=2 2 CALL PLOT(XPAGE1,YPAGE1,IPEN) C ALSO ADJUST CHARACTER SIZING FACTOR FOR SPECIAL NON-ASCII SYMBOLS IF (SPC1) SIZE =HEIGHT/4 C INITIALISE X COORD OF START POSN WITHIN STRING 3 XCHAR=0. C C SET UP PLOT LOOP C NCH =1 ICH =0 C IF (NCHAR) 100,120,110 C C NCHAR < 0 C 100 ICH =IBCD(1)+1 ICHPT =0 GO TO 130 C C NCHAR > 0 IMPLIES MULTI-CHARACTER STRING C 110 NCH =NCHAR C POINT TO 1ST BYTE OF THE ELEMENT ICHPT =0 GO TO 130 C C NCHAR =0 IMPLIES 1 ORDINARY CHARACTER. C 120 ICHPT =0 C C ********************************* C * * C * CHARACTER PLOT LOOP * C * * C ********************************* C 130 DO 180 ICHPLT =1,NCH D WRITE (7,9990) NCH,ICHPLT,IBCD(1),ICH,ICHPT D9990 FORMAT (' DO 180:',2I5,5X,A2,2I5) C C ZEROIZE MOVE COUNTER C IM =0 C IF (NCHAR.LT.0) GO TO 140 ICH =0 CALL CPYBYT (IBCD(1),ICHPT,ICH,0,1) D WRITE (7,9999) SIZE,ICH,ICHFT D9999 FORMAT (' SIZE,ICH:',F8.2,2I8) IF (ICH.LT.32) ICH =96 IF (ICH.GT.95) ICH =96 ICH =ICH-17 C C ICH NOW HAS THE INTEGER EQUIVALENT OF THE C CHARACTER BEING DRAWN C C ******************************** C * * C * CHARACTER MOVE LOOP * C * * C ******************************** C 140 DO 160 ICHMOV =0,15 C ICHFOV =ITRAN2(ICHMOV) C C C CHARACTER X'FF' SIGNIFIES END OF CHARACTER PLOT MOVES C IF (EQBYT (ICHMVE(1,ICH),ICHFOV,FF,0,1)) GO TO 175 C CALL CPYBYT (ICHMVE(1,ICH),ICHFOV,ICHM,0,1) D WRITE (7,9991) ICHMVE(1,ICH),ICHM,ICH,ICHFOV C C UNPACK THE BYTE. BIT PATTERN IS: 0PXXXYYY C WHERE: P IS SET/RESET FOR PEN UP/DOWN C XXX IS X COORDINATE C YYY IS Y COORDINATE C WITHIN THE 5X7 GRID TO WHICH THE PEN IS TO BE MOVED. C C SET IPEN: = 2 (DOWN) IF P BIT=1 C = 3 (UP) IF P BIT=0 C IPEN =3 IBIT =IAND(ICHM,"000100) IF (IBIT.NE.0) IPEN=2 C C LOGICAL AND TO ISOLATE 3 LOW-ORDER BITS (YYY) C IY =IAND (ICHM,MASK) C C SHIFT RIGHT 3 BITS C ICHM =ISHFT (ICHM,-3) C C LOGICAL AND TO GET XXX C IX =IAND (ICHM,MASK) C C IF SPECIAL CHARACTER ADJUST IX,IY FOR CENTERED CHARS C D WRITE (7,9991) IX,IY,IPEN,ICHMOV,ICH D9991 FORMAT (' DO 160:',5I6) IF (.NOT.SPC1) GO TO 145 IX =IX-2 IY =IY-2 GO TO 150 C 145 IF (.NOT.SPC2) GO TO 150 IX =IX-2 IY =IY-3 C C MOVE COORDINATES (UNSCALED AND UNROTATED) RELATIVE TO C BOTTOM LEFT (CENTRE FOR SPECIAL SYMBOL) OF CHARACTER C POSITION NOW IN IX,IY. PEN CONTROL IN IPEN. C C CHECK FOR FIRST MOVE OF NORMAL CHARACTER 150 IF (IM.NE.0) GO TO 10 C YES IT IS - IS PEN DOWN THIS MOVE ? IF (IPEN.EQ.3) GO TO 10 C YES IT IS - MOVE PEN TO BOTTOM LEFT OF CHAR POSN C THIS IS NECESSARY BECAUSE PEN DOWN ON THE FIRST MOVE C FOR A NORMAL CHARACTER IMPLIES THAT THE PEN C IS ALREADY POSITIONED TO THE BOTTOM LEFT OF THE CHARACTER POSN. C THIS IS DONE THE SHORTEN THE PACKED MOVE TABLE AND TO MINIMISE C THE PEN MOVES WHEN PLOTTING CHARACTER STRINGS (SINCE THE PEN C IS LEFT AT THE FINAL POSITION IN THE PREVIOUS CHARACTER). XP=XPAGE1+XCHAR*COSINE YP=YPAGE1+XCHAR*SINE IF (.NOT.SPC2) GO TO 9 C GET RELATIVE COORDINATES OF NEW CORNER XD =-2*SIZE YD =-3*SIZE C ROTATE THE POINT ABOUT THE CENTER OF THE CHARACTER XT =XD*COSINE-YD*SINE YT =XD*SINE+YD*COSINE C ROTATED POINT DEFINES NEW LOWER LEFT CORNER XP =XP+XT YP =YP+YT D WRITE (7,9993) XP,YP D9993 FORMAT (' PLOT:',2F10.2,5X,'3') 9 CALL PLOT(XP,YP,3) C 10 CONTINUE C X,Y COORDINATES RELATIVE TO START POSN OF CHAR STRING ARE XC=XCHAR+FLOAT(IX)*SIZE YC=FLOAT(IY)*SIZE C GET COORDINATES AFTER ROTATION RELATIVE TO REAL ORIGIN XP=XPAGE1+XC*COSINE-YC*SINE YP=YPAGE1+XC*SINE+YC*COSINE C NOW PLOT MOVE D WRITE (7,9994) XP,YP,IPEN D9994 FORMAT (' PLOT:',2F10.2,I5) CALL PLOT(XP,YP,IPEN) IM =IM+1 160 CONTINUE C C INCREMENT "XCHAR" FOR THE X COORDINATE OF THE NEXT CHARACTER C 175 XCHAR =XCHAR+HEIGHT ICHPT =ICHPT+1 D WRITE (7,9995) XCHAR,ICHPT D9995 FORMAT (' XCHAR=',F8.2,5X,'ICHPT=',,I6) 180 CONTINUE C C HAVE NOW PLOTTED ALL CHARS C IF NOT SPECIAL CHAR, POSN TO BOTTOM LEFT OF NEXT C CHARACTER POSITION IF (NEGNCH) RETURN XP=XPAGE1+XCHAR*COSINE YP=YPAGE1+XCHAR*SINE CALL PLOT(XP,YP,3) C C SEND THE 'SYMBOL STOP' FUNCTION CODE. C CALL PUTFC ('G') C RETURN END SUBROUTINE WHERE(X,Y,FACT) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR D WRITE (7,9990) D9990 FORMAT (' ********** WHERE **********') C X=XCURR Y=YCURR FACT=FAC RETURN END C C ---------------- SUBROUTINE--DSHLIN------------------- C CPROG DSHLIN C C SUBROUTINE DSHLIN (XARRAY,YARRAY,NPTS,INC,LPAT) C C SUBROUTINE TO PLOT A DASH/DOT LINE PATTERN BETWEEN THE C POINTS DEFINED BY XARRAY AND YARRAY. C C R.J. MORALES C MAY 1982 C C ARGUMENTS ARE: C XARRAY -CONTAINS "NPTS" X VALUES, FOLLOWED BY TWO ELEMENTS, C "FIRSTV" AND "DELTAV", AS DESCRIBED IN THE "LINE" C SUBROUTNE. C YARRAY -CONTAINS THE CORRESPONDING "NPTS" Y VALUES, FOLLOWED BY C "FIRSTV" AND "DELTAV", AS DESCRIBED IN THE "LINE" C SUBROUTINE. C NPTS -IS THE NUMBER OF POINTS. C INC -IS THE INCREMENT, OR "JUMP" FACTOR FOR FINDING THE C POINTS IN THE ARRAYS. C LPAT -DEFINES THE DOT-DASH PATTERN: C LPAT PATTERN C ------ ------------------------ C -1 NO LINE C 0 A SOLID LINE C 1 A DOTTED LINE C 2 A DASH-DOT LINE C 3 A SHORT-DASHED LINE C 4 A LONG-DASHED LINE C 5,6,... DEFINES A PATTERN ACCORDING TO C THE DIGITS MAKING UP THE NUMBER. C FOR "LPAT" GREATER THAN 4, SUCCESSIVE DIGITS (10 MAX) ARE C INTERPRETED AS FOLLOWS: C INTEGER RESULT C ------- --------------------------- C 1 .2 MM, VISIBLE C 2 .2 MM, INVISIBLE C 3 .4 MM, VISIBLE C 4 .4 MM, INVISIBLE C 5 1.0 MM, VISIBLE C 6 1.0 MM, INVISIBLE C 7 2.0 MM, VISIBLE C 8 2.0 MM, INVISIBLE C 9 THIS IS FORMALLY UNDEFINED, BUT C WILL IN FACT RESULT IN 2.0 C DIMENSION XARRAY(NPTS), YARRAY(NPTS) DIMENSION CIRLST (12) C C GET THE SCALING FACTORS. D WRITE (7,9990) D9990 FORMAT (' ********** DSHLIN **********') C C NOTE THAT LOCATION OF SCALING PARAMETERS IS AS DEFINED IN C SUBROUTINE 'LINE'. C XFRSTV =XARRAY(NPTS*INC+1) YFRSTV =YARRAY(NPTS*INC+1) XDLTAV =XARRAY(NPTS*INC+1+INC) C C SEND THE 'START DSHLIN' FUNCTION CODE. C CALL PUTFC ('L') C YDLTAV =YARRAY(NPTS*INC+1+INC) C C MOVE, PEN UP, TO STARTING POSITION. C XI =(XARRAY(INC)-XFRSTV)/XDLTAV*2.5 YI =(YARRAY(INC)-YFRSTV)/YDLTAV*2.5 CALL PLOT (XI,YI,3) C C SET UP THE CIRCULAR LIST OF PATTERN SEGMENTS. C LPATRN =LPAT CALL SETLST (CIRLST,LPATRN) C C GET THE INITIAL LENGTH OF SEGMENT AND PEN CONDITION. C CALL REMLST (CIRLST,SEGLTH,IPEN) C C******************* MAIN LOOP ******************** C DO 50 I=1,NPTS-1,INC C C CALCULATE THE CURRENT POINT C XI =(XARRAY(I)-XFRSTV)/XDLTAV*2.5 YI =(YARRAY(I)-YFRSTV)/YDLTAV*2.5 C C COMPUTE DISTANCES ALONG THE AXES. C XJ =(XARRAY(I+INC)-XFRSTV)/XDLTAV*2.5 YJ =(YARRAY(I+INC)-YFRSTV)/YDLTAV*2.5 C XDIFF =XJ-XI YDIFF =YJ-YI C C COMPUTE THE ABSOLUTE DISTANCE BETWEEN THE POINTS. C DIST =SQRT (XDIFF*XDIFF+YDIFF*YDIFF) C C IF THE DISTANCE IS TOO SMALL IGNORE THE NEW POINT. C IF (ABS(DIST).LT.1.0E-20) GO TO 50 C C COMPUTE AXIS RATIOS FOR LATTER STEPPING. C XRATIO =XDIFF/DIST YRATIO =YDIFF/DIST C C COMPARE DISTANCE TO NEXT POINT WITH LENGTH OF PATTERN SEGMENT. C 10 IF (DIST.LE.SEGLTH) GO TO 20 C C C DISTANCE TO THE NEXT POINT IS GREATER THAN THE PATTERN C SEGMENT LENGTH. C EXHAUST THE SEGMENT LENGTH ALONG THE LINE TO THE NEXT POINT. C DELTAX =SEGLTH*XRATIO DELTAY =SEGLTH*YRATIO C XI =XI+DELTAX YI =YI+DELTAY CALL PLOT (XI,YI,IPEN) C C DECREMENT THE REMAINING DISTANCE TO THE POINT. C DIST =DIST-SEGLTH C C GET THE NEXT PATTERN SPECIFICATION FROM THE CIRCULAR LIST. C CALL REMLST (CIRLST,SEGLTH,IPEN) C GO TO 10 C C DISTANCE TO THE NEXT POINT IS .LE. PATTERN SEGMENT LENGTH. C MOVE IN DEFINED PEN STATE TO NEXT POINT. C 20 CALL PLOT (XJ,YJ,IPEN) C C DECREMENT THE PATTERN SEGMENT LENGTH. C SEGLTH =SEGLTH-DIST C C IF THE SEGMENT LENGTH IS EXHAUSTED SEE THE NEXT ONE. C IF (SEGLTH.LE.0) CALL REMLST(CIRLST,SEGLTH,IPEN) C 50 CONTINUE C C C SEND THE 'STOP DSHLIN' FUNCTION CODE. C CALL PUTFC ('M') C RETURN END SUBROUTINE SETLST(CIRLST,LPAT) C C SUBROUTINE TO DEFINE AND CHARGE CIRCULAR LIST "CIRLST" C ACCORDING TO INTEGER "LPAT". C INTEGER*2 DIGIT(10) C DIMENSION CIRLST(12), SEG(9) C DIMENSION PATRN(10,7) C C THE ABSOLUTE VALUE OF EACH ELEMENT REPRESENTS THE DISTANCE C TO BE MOVED IN CM. C NEGATIVE VALUES REPRESENT PEN UP, POSITIVE VALUES REPRESENT C PEN DOWN. C DATA PATRN / 1 10*-10., 2 10*10., 3 .1,-.2,8*0., 4 .4,-.2,.1,-.2,6*0., 5 .2,-.2,8*0., 6 2.,-.2,8*0., 7 10*0. 8 / C C NOTE THAT A DIGIT VALUE OF 9, THOUGH UNDEFINED IN THE SUBROUTINE C DESCRIPTION, WILL BE SET TO 2. C DATA SEG /.2,-.2,.4,-.4,1.,-1.,2.,-2.,2./ D WRITE (7,9990) D9990 FORMAT (' ********** SETLST **********') C C INITIALIZE ARRAY ELEMENTS. C DO 5 I=1,10 PATRN(I,7) =0 5 DIGIT(I) =0 C C DEFINE THE CIRCULAR LIST C CALL DEFLST (CIRLST,10) C C IS IT A USER-DEFINED PATTERN? C IF (LPAT.GT.4) GO TO 20 C IF (LPAT.LT.-1) STOP 19 C IPAT =LPAT+2 GO TO 50 C 20 DO 25 IPOS =1,10 DIGIT(IPOS) =MOD(LPAT,10) IF (DIGIT(IPOS).EQ.0) GO TO 27 LPAT =LPAT/10 25 CONTINUE 27 CONTINUE C C NOW USE THESE DIGITS TO SET UP CIRCULAR ARRAY VALUES. C NOTE THAT THEY ARE IN REVERSE ORDER. C IPOS =1 DO 40 I=10,1,-1 IF (DIGIT(I).EQ.0) GO TO 40 PATRN(IPOS,7) =SEG(DIGIT(I)) IPOS =IPOS+1 40 CONTINUE C IPAT =7 C C THE PATTERN HAS BEEN DEFINED AND SELECTED. C PUSH THE NUMBERS INTO THE CIRCULAR LIST. C 50 DO 55 I=1,10 VALUE =PATRN(I,IPAT) IF (VALUE.EQ.0) GO TO 60 55 CALL ABL (VALUE,CIRLST,ISTAT) C 60 RETURN END SUBROUTINE REMLST(CIRLST,SEGLTH,IPEN) C C SUBROUTINE TO: C 1. REMOVE THE NEXT PATTERN VALUE FROM THE CIRCULAR LIST (CIRLST) C 2. SET "IPEN" ACCORDING TO THE VALUE: C IF VALUE < 0, IPEN=3 (PEN UP) C OTHERWISE, IPEN=2 (PEN DOWN) C 3. SET SEGLTH TO THE ABSOLUTE OF "VALUE". C DIMENSION CIRLST(12) C C REMOVE AN ITEM, THEN POP IT INTO THE OTHER END. C D WRITE (7,9990) D9990 FORMAT (' ********** REMLST **********') CALL RTL (VALUE,CIRLST,ISTAT) CALL ABL (VALUE,CIRLST,ISTAT) C C SET THE PEN VALUE. C IPEN =3 IF (VALUE.GE.0) IPEN=2 C C SET THE SEGMENT LENGTH. C SEGLTH =ABS(VALUE) C RETURN END C C----------SUBROUTINE--FACTOR------------------------------------------- C CPROG FACTOR C C SUBROUTINE FACTOR(FACT) C * THIS ROUTINE ALLOWS THE USER TO SCALE A PLOT. A CALL TO THIS C * ROUTINE WITH A FACT OF .5 WILL APPEAR HALF THE SIZE AS A C * PLOT MADE AFTER A CALL TO FACTOR WITH A FACT OF 1. C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C D WRITE (7,9990) D9990 FORMAT (' ********** FACTOR **********') FAC=FACT RETURN END C******************** SUBROUTINE COLOR ******************** C SUBROUTINE COLOR(ICOL) C C SUBROUTINE FOR REQUESTING PEN COLOR. C INTEGER*2 PTR(16),PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, 1 XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, 2 PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) C C RANGE CHECK THE PEN NUMBER. C IF (ICOL.GT.0.AND.ICOL.LT.256) GO TO 20 C C RANGE ERROR ON PEN COLOR NUMBER. C CALL CONMSG (34,'ERROR IN ARGUMENT TO SUBR "COLOR".') PAUSE RETURN C C SEND THE INFORMATION TO THE IPF. C 20 FC ='P' CALL BUFPAK (2,FC,0.,ICOL) C RETURN END C*********************** SUBROUTINE PAUSE ************************ C CPROG PAUSE C$TRACE C SUBROUTINE PAUSE (NCHAR,MESG) C C SUBROUTINE DESIGNED TO ENABLE OPERATOR INTERVENTION DURING C HARDCOPY PLOTTING AS FOLLOWS: C 1. PAUSE MOVEMENT ON THE HARDCOPY DEVICE. C 2. LOG OF MESSAGE TO CONSOLE (E.G. ATTACH RED PEN). C C THE MESSAGE OF 'NCHARS' BYTES IS IN BUFFER 'MESG' IN C ASCII. (0 < NCHARS <= 64) C C DIMENSION MESG(1) C INTEGER*4 NERR1(12) C C PARAMETER INDX=2, LUPLOT=8, LTHPLT=80 C INTEGER*2 PTR(16), PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) C DATA NERR1 /' ERR','OR F','ROM ','SUBR',' PAU','SE: ','"NCH', 1 'ARS"',' MUS','T BE',' 1-6','4. '/ C D WRITE (7,9990) D9990 FORMAT (' ********** PAUSE **********') LUPLOT =8 LTHPLT =80 C C DE-COUPLE THE ARGUMENT C NCHARS =NCHAR C C RANGE CHECK THE NUMBER OF CHARACTERS IN THE MESSAGE. C IF (NCHARS.GE.0) GO TO 10 C C RANGE ERROR ON 'NCHARS'. C CALL CONMSG (46,NERR1) GO TO 100 C 10 IF (NCHARS.LE.64) GO TO 20 C C RANGE ERROR ON 'NCHARS'. C CALL CONMSG (46,NERR1) C NCHARS =64 C C PLACE THE FUNCTION CODE 'E' INTO THE OUTPUT BUFFER. C 20 BBUFF(BYTPTR) = 'E' BYTPTR =BYTPTR+1 C C PLACE THE NUMBER OF CHARACTERS INTO THE BUFFER. C CALL CPYBYT (NCHARS,0,BUFF,BYTPTR-1,4) BYTPTR =BYTPTR+4 C C INITIALIZE THE NUMBER-OF-CHARACTERS-TRANSFERRED COUNTER. C NTRAN =0 C C COMPUTE CAPACITY OF THE OUTPUT BUFFER. C KAPA =LTHPLT-BYTPTR+1 C C CAN THE BUFFER HOLD THE ENTIRE MESSAGE? C IF (NCHARS.LE.KAPA) GO TO 40 C C THE BUFFER CAN HOLD ONLY PART OF THE MESSAGE C CALL CPYBYT (MESG,0,BUFF,BYTPTR-1,KAPA) BYTPTR =BYTPTR+KAPA C NTRAN =KAPA C C WRITE THE BUFFER C LASTR =LASTR+1 WRITE (LUPLOT'LASTR) BUFF CALL FILBYT (' ',0,BUFF(1),0,80) BYTPTR =1 C C TRANSFER REST OF MESSAGE TO BUFFER. C 40 CALL CPYBYT (MESG,NTRAN,BUFF,BYTPTR-1,NCHARS-NTRAN) BYTPTR =BYTPTR+NCHARS-NTRAN C C IS THERE ROOM IN THE BUFFER FOR AN ORDINARY 9-BYTE INSTR. SET? C IF (BYTPTR+8 .LE. LTHPLT) GO TO 100 C C NO ROOM. C PUSH OUT THIS BUFFER. C LASTR =LASTR+1 WRITE (LUPLOT'LASTR) BUFF CALL FILBYT (' ',0,BUFF(1),0,80) BYTPTR =1 C 100 RETURN END C C*************** SUBROUTINE PUTFC ********************** C CPROG PUTFC C SUBROUTINE PUTFC (FC) C C SUBROUTINE TO INSERT A ONE-CHARACTER FUNCTION CODE (FC) C INTO THE INTERMEDIATE PLOT FILE BUFFER. C C PARAMETER INDX=2, LUPLOT=8, LTHPLT=80 C INTEGER*2 PTR(16), PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) D WRITE (7,9990) D9990 FORMAT (' ********** PUTFC **********') C LUPLOT =8 LTHPLT =80 C C PACK THE FUNCTION CODE INTO THE BUFFER C BBUFF(BYTPTR) =FC BYTPTR =BYTPTR+1 C C IF THE BUFFER IS NOT 'FULL' RETURN. C IF (BYTPTR+8.LE.LTHPLT) GO TO 20 C C THE BUFFER IS 'FULL'. C OUTPUT THE BUFFER. C C INCREMENT THE RECORD POINTER. C LASTR =LASTR+1 C C WRITE THE RECORD C WRITE (LUPLOT'LASTR) BUFF CALL FILBYT (' ',0,BUFF(1),0,20) C C SET THE BYTE POINTER TO THE START OF THE BUFFER. C BYTPTR =1 C 20 RETURN END C C****************** SUBROUTINE BUFPAK ************** C CPROG BUFPAK C SUBROUTINE BUFPAK (IFUNC,FC,X,Y) C C SUBROUTINE TO PACK PLOT FILE BUFFER WITH GENERAL PLOT C COMMANDS, ACCORDING TO 'IFUNC': C IFUNC =1 IMPLIES BRING PLOTTER UP C IFUNC =2 IMPLIES PASS COMMANDS FC,X,Y TO PLOT BUFFER C IFUNC =3 IMPLIES BRING PLOTTER DOWN C INTEGER*4 FERR(11) C C PARAMETER INDX=2, LUPLOT=8, LTHPLT=80 C INTEGER*2 PTR(16), PLTPTR,BYTPTR LOGICAL*1 FC INTEGER*4 BUFF(20) LOGICAL*1 BBUFF(80) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C EQUIVALENCE (PTR(1),BUFF(13)), (BBUFF(1),BUFF(1)) C DATA FERR /' ERR','OR: ','FUNC','TION',' COD','E TO',' SUB', 1 'R BU','FPAK','=XXX','X. '/ C LUPLOT =8 LTHPLT =80 C D WRITE (7,9990) D9990 FORMAT (' ********** SUBR BUFPAK **********') D WRITE (7,9991) IFUNC,FC,X,Y D9991 FORMAT (8X,I5,5X,A2,2F10.2) C C IS IT A PLOT-INITIALIZE FUNCTION? C IF (IFUNC.NE.1) GO TO 20 C C IT IS A PLOT INITIALIZE C CALL FILBYT (' ',0,BUFF(1),0,80) C C THE FOLLOWING IS NOT COMPATIBLE WITH P-E VERSION: BYTPTR SET TO C 50 INSTEAD OF 100 BECAUSE LSI IPF IS ONLY 80 BYTES, VS. 256 FOR P-E. C BYTPTR =50 C C SET THE PLOT FUNCTION CODE TO 'PLOTTER UP' C FC ='A' D WRITE (7,9993) FC D9993 FORMAT (8X,'FC=',A1) GO TO 30 C C IS IT AN ORDINARY PLOT? C 20 IF (IFUNC.NE.2) GO TO 40 C C PACK THE FC,X,Y C 30 BBUFF(BYTPTR) =FC BYTPTR =BYTPTR+1 CALL CPYBYT (X,0,BUFF,BYTPTR-1,4) BYTPTR =BYTPTR+4 CALL CPYBYT (Y,0,BUFF,BYTPTR-1,4) BYTPTR =BYTPTR+4 D WRITE (7,9992) BYTPTR,LASTR,BUFF D9992 FORMAT (8X,2I5,5X,10A4/23X,10A4) C C IF THE BUFFER IS NOT FULL RETURN C IF (BYTPTR+8.LE.LTHPLT) GO TO 80 GO TO 70 C C ENSURE THAT THE FUNCTION IS 3: TERMINATE THE PLOT FRAME. C 40 IF (IFUNC.EQ.3) GO TO 60 C C ERROR: FUNCTION CODE WAS NOT 1,2, OR 3. C ENCODE (42,55,FERR) IFUNC 55 FORMAT (37X,I4) CALL CONMSG(42,FERR) PAUSE STOP C C PACK FUNCTION CODE 'B': PLOTTER DOWN. C 60 BBUFF(BYTPTR) ='B' BYTPTR =BYTPTR+1 C C INCREMENT THE RECORD POINTER C 70 LASTR =LASTR+1 C C WRITE THE RECORD C WRITE (LUPLOT'LASTR) BUFF CALL FILBYT (' ',0,BUFF(1),0,80) C C SET THE BYTE POINTER TO START OF BUFFER C BYTPTR =1 C 80 RETURN END C----------SUBROUTINE--OFFSET------------------------------------------- C CPROG OFFSET C SUBROUTINE OFFSET(XFSET,XFACT,YFSET,YFACT) C COMMON /MURPLT/ FAC,XFAC,YFAC,XOFF,YOFF,XORGIN,YORGIN, + XCURR,YCURR,XMAX,YMAX,XMIN,YMIN,NPLOTS, + PLTPTR,LASTR,BUFF,BYTPTR C D WRITE (7,9990) D9990 FORMAT (' ********** OFFSET **********') XOFF=XFSET YOFF=YFSET XFAC=XFACT YFAC=YFACT RETURN END C C*************** SUBROUTINE PLOTUP ********************** C CPROG PLOTUP SUBROUTINE PLOTUP C C SUBROUTINE TO INITIALIZE PLOT DEVICE 'IDEV', WHERE: C IDEV = 1 IS A TEKTRONIX 4006-1 VDU (38.1 CM X 25.4 CM.) C IDEV = 2 IS A TEKTRONIX 4662 FLATBED (38.1 CM X 25.4 CM.) C IDEV = 3 IS AN IBM 1627 DRUM PLOTTER (1200 IN. X 29 IN.) C C R.J. MORALES C AUG 1981 C INTEGER*2 CANCEL(2), RESET(2), ISYNC(2) C COMMON /MRDOK/ IDEV,NERR C DATA CANCEL /"042033,"005125/ DATA RESET /"006033,"000035/ DATA ISYNC /"013026,"013026/ D WRITE (7,9990) D9990 FORMAT (' ********** PLOTUP **********') C C INITIALIZE THE ERROR COUNTER. C NERR =0 C C VDU AND HARDCOPY ARE TREATED DIFFERENTLY C IF (IDEV.EQ.1) GO TO 50 C C HARDCOPY PLOTTER C ---------------- C C SET BYPASS CANCEL CHARACTER TO ZERO TO SUPPRESS C ECHO FROM COMPUTER TO PLOTTER. C SEND: ESC DEV U LF C WHERE: DEV=68 C CALL BUFOUT (4,CANCEL,0) CALL BUFOUT (-1,0,0) C C NOTE: CALL BUFOUT (NBYTES,BUFF,IBLK) C WHERE: NBYTES = NUMBER OF BYTES TO BE SENT TO PLOTTER C BUFF = BUFFER CONTAINING BYTES TO BE SENT C IBLK = CONTINUOUS/BLOCK MODE FLAG: C 0 = PLOTTER IS IN CONTINUOUS MODE C 1 = PLOTTER (TEK 4662) IS IN BLOCK MODE. GO TO 80 C C VDU PLOTTER C ----------- C C MASTER RESET: ERASE SCREEN AND GO TO HOME POSITION C SEND: ESC FF C 50 CALL BUFOUT (3,RESET,0) C C LOOP TO GIVE ENOUGH TIME TO ERASE THE SCREEN. C DO 60 I=1,10 CALL BUFOUT (4,ISYNC,0) CALL BUFOUT (-1,0,0) 60 CONTINUE C 80 CONTINUE C RETURN END C C************** SUBROUTINE PLOTDN ********************* C CPROG PLOTDN SUBROUTINE PLOTDN C C SUBROUTINE TO TERMINATE THE PLOT DEVICE C INTEGER ALPHA C DIMENSION BUFF(30) C COMMON /MRDOK/ IDEV,NERR C DATA ALPHA /"37/ D WRITE (7,9990) D9990 FORMAT (' ********** PLOTDN **********') C C VDU AND HARDCOPY DEVICES ARE TREATED DIFFERENTLY C IF (IDEV.NE.1) GO TO 10 C C IT IS A VDU. C C MOVE THE CURSOR TO THE 'HOME' POSITION. C CALL PACK1 (0,975,0,BUFF,NBYTES) CALL BUFOUT (NBYTES,BUFF,0) C C VDU: PLACE THE VDU IN ALPHA MODE, WHERE PLOTTING ENDED. C SEND: US C CALL BUFOUT (1,ALPHA,0) C CALL BUFOUT (-1,0,0) C GO TO 20 C C HARDCOPY: C MOVE PEN TO LOAD POSITION C 10 CALL PENMOV (38.,25.35,0) C C FLUSH OUT THE ADE BUFFER IN 'BUFOUT'. C CALL BUFOUT (-1,0,1) C C REPORT ANY COORDINATE RANGE ERRORS. C 20 IF (NERR.EQ.0) RETURN C ENCODE (50,25,BUFF) NERR 25 FORMAT (' WARNING: There were',I5,' coordinate range errors.') CALL CONMSG(50,BUFF) C RETURN C END C C***************** SUBROUTINE PENMOV ******************** C CPROG PENMOV SUBROUTINE PENMOV (X,Y,IPEN) C C SUBROUTINE TO MOVE THE PEN TO COORDINATES X,Y IN INCHES: C IPEN = 0 = PEN UP C IPEN = 1 = PEN DOWN C C PARAMETER (CMXMAX=38.07) C PARAMETER (CMYMAX=25.38) C PARAMETER (SFAC1=26.89) C PARAMETER (SFAC2=107.56) C DIMENSION BUFF(30) C COMMON /MRDOK/ IDEV,NERR C D WRITE (7,9990) D9990 FORMAT (' ********** PENMOV **********') CMXMAX =38.07 CMYMAX =25.38 SFAC1 =26.89 SFAC2 =107.56 C C UNTIL REQUIRED SOFTWARE IS WRITTEN, FORCE IPEN=3 C (REDEFINE ORIGIN) TO IPEN=0 (MOVE WITH PEN UP). C IF (IPEN.EQ.-3) IPEN =0 C C CONSIDER ONLY DEVICE TYPES 1 AND 2 C TYPE 1 = TEKTRONIX 4006-1 C TYPE 2 = TEKTRONIX 4662 C IF (IDEV.EQ.1.OR.IDEV.EQ.2) GO TO 15 C C ERROR: DEVICE CODE OUT OF RANGE. C ENCODE (39,10,BUFF) IDEV 10 FORMAT (' PENMOV: DEVICE CODE NOT 1 OR 2, =',I5,' ') CALL CONMSG (39,BUFF) C C RANGE CHECK X AND Y: C FOR BOTH DEVICES X IS (0,15) AND Y IS (0,10) C 15 IF (X.LT.0.OR.X.GT.CMXMAX) GO TO 28 IF (Y.GE.0.AND.Y.LE.CMYMAX) GO TO 30 C C ERROR: X OR Y OUT OF RANGE C C SET VALUES TO LIMIT C 28 IF (X.LT.0.) X =0. IF (X.GT.CMXMAX) X =CMXMAX IF (Y.LT.0.) Y =0. IF (Y.GT.CMYMAX) Y =CMYMAX C C INCREMENT THE ERROR COUNTER. C NERR =NERR+1 C C NOW TRANSFORM X AND Y COORDINATES TO DEVICE UNITS C AND PACK THE COORDINATES FOR TRANSMISSION TO THE PLOTTER. C 30 IF (IDEV.EQ.2) GO TO 40 C C 4006-1 VDU C IX =X*SFAC1+0.5 IY =Y*SFAC1+0.5 C CALL PACK1 (IX,IY,IPEN,BUFF,NBYTES) C C SEND THE COMMAND BYTES TO THE PLOTTER C CALL BUFOUT (NBYTES,BUFF,0) C RETURN C C 4662 FLATBED C 40 IX =X*SFAC2+0.5 IY =Y*SFAC2+0.5 C CALL PACK2 (IX,IY,IPEN,BUFF,NBYTES) C C TRANSMIT THESE BYTES TO THE PLOTTER C CALL BUFOUT (NBYTES,BUFF,1) C RETURN END SUBROUTINE DEFLST (LSTCIR,ISIZE) C C SUBROUTINES DFSLT, ABL, RTL PARTIALLY SIMULATE C THE P-E CIRCULAR LIST FORTRAN SUBROUTINES. C C LSTCIR IS THE CIRCULAR LIST ARRAY. C ISIZE IS THE CAPACITY OF THE CIRCULAR LIST C DIMENSION LSTCIR (1) C COMMON /CRLST/ NUM, LSTSIZ D WRITE (7,9990) D9990 FORMAT (' ********** DEFLST **********') C C NUM = THE CURRENT NUMBER OF ELEMENTS IN THE CIRCULAR LIST C LSTSIZ = THE CAPACITY OF THE CIRCULAR LIST. C NUM = 0 C LSTSIZ =ISIZE C RETURN END SUBROUTINE ABL (IVALUE, LSTCIR,ISTAT) C C SUBROUTINE TO ADD "IVALUE" TO BOTTOM OF LIST "LSTCIR". C C "ISTAT" IS THE RETURN STATUS C DIMENSION LSTCIR(1) C COMMON /CRLST/ NUM, LSTSIZ C NUM = NUM+1 D WRITE (7,9990) D9990 FORMAT (' ********** ABL **********') IF (NUM.LE.LSTSIZ) GO TO 10 C C LIST IS FULL C ISTAT =1 GO TO 20 C 10 CALL CPYWRD (IVALUE,LSTCIR(NUM),1) ISTAT =0 C 20 RETURN END SUBROUTINE RTL (IVALUE,LSTCIR,ISTAT) C C SUBROUTINE TO REMOVE AN ITEM FROM THE TOP OF "LSTCIR" C AND PLACE IT INTO "IVALUE". ISTAT IS THE RETURN STATUS. C DIMENSION LSTCIR (1) C COMMON /CRLST/ NUM, LSTSIZ D WRITE (7,9990) D9990 FORMAT (' ********** RTL **********') C IF (NUM.GE.1) GO TO 20 C C ERROR: THE LIST IS ALREADY EMPTY. C ISTAT =2 GO TO 30 C 20 CALL CPYWRD (LSTCIR(1),IVALUE,1) C NUM = NUM-1 C C MOVE ALL OF THE ITEMS IN THE LIST UP ONE POSITION. C DO 25 I=1,NUM 25 LSTCIR(I) =LSTCIR(I+1) C IF (NUM.EQ.0) ISTAT =0 IF (NUM.NE.0) ISTAT =1 C 30 RETURN END SUBROUTINE CONMSG(NUM,MSG) CTRACE C C SUBROUTINE TO SIMULATE P-E "CONSOLE MESSAGE" SUBROUTINE C FOR LOGGING TO THE CONSOLE. C C NUM = NUMBER OF BYTES IN THE MESSAGE (NUM<=64) C MSG = ARRAY CONTAINING THE MESSAGE. C DIMENSION MSG(1) C INTEGER*2 MBUFF(32) D WRITE (7,9990) D9990 FORMAT (' ********** CONMSG **********') C CALL FILBYT (' ',0,MBUFF(1),0,64) CALL CPYBYT (MSG(1),0,MBUFF(1),0,NUM) C TYPE 10,MBUFF 10 FORMAT (1H ,32A2) C RETURN END FUNCTION ITRAN2(I) D WRITE (7,9990) I D9990 FORMAT (' ********** ITRAN2 **********',I5) C C FUNCTION TO TRANSLATE BYTE ORDERING (0,1,2,3,....) TO CONFORM TO C LSI BYTE ORDERING FOR "INTEGER*2" ENTITIES (1,0,3,2,5,4,....) C J =MOD(I,2) IF (J.EQ.0) ITRAN2 =I+1 IF (J.EQ.1) ITRAN2 =I-1 C RETURN END