C 
C CalComp-PostScript interface
C
C Version: 5.20
C Date: 1998, November 9
C
C Coded by: Ludek Klimes
C     Department of Geophysics, Charles University Prague,
C     Ke Karlovu 3, 121 16 Praha 2, Czech Republic,
C     E-mail: klimes@seis.karlov.mff.cuni.cz
C
C.......................................................................
C
C This file contains the CalComp plotting routines
C     PLOTS
C     PLOT
C     NEWPEN
C     SYMBOL
C     NUMBER
C supplemented with additional filename-specification entry
C     PLOTN
C and with additional area filling routine
C     FILL
C coded in the ANSI X3.9-1978 FORTRAN77 standard full language.
C The graphical output is generated in the form of ASCII files coded in
C the PostScript Level 2 Language - Encapsulated PostScript File Format
C Version 3.0.
C
C Whereas the original CalComp routines are conformable to the ANSI
C X3.10-1966 FORTRAN standard, the dummy argument text of the subroutine
C SYMBOL is declared here as
C     CHARACTER*(*) TEXT
C in order to conform to the ANSI X3.9-1978 FORTRAN77 standard.  In this
C way, the subroutine SYMBOL is not conformal to the original CalComp
C specification.
C
C Possible input file - CalComp colour table file 'calcops.rgb':
C     The file is taken into account if exists in the current directory.
C     If there is no 'calcops.rgb' file, default colours are used.
C     The file is read by list-directed (free format) input, and
C     consists of lines defining individual colours.  Each line contains
C     four numbers:
C K,R,G,B
C     K...    Index of the colour to be defined.  Non-negative integer.
C             Colours greater than MCOLOR (see include file
C             'calcops.inc') are not taken into account.
C             calcops.inc
C     R...    Content of the red colour.  Real between 0 and 1.
C     G...    Content of the green colour.  Real between 0 and 1.
C     B...    Content of the blue colour.  Real between 0 and 1.
C Example of colour table file 'calcops.rgb'
C
C OUTPUT PostScript files 'plot00.ps', 'plot01.ps', ..., 'plot99.ps':
C     Each invocation of subroutine PLOTS creates new output PostScript
C     file named 'plot**.ps', where ** is the smallest one of values
C     00, 01, 02, ..., 99, such that the corresponding file has not been
C     present in the current directory.
C
C=======================================================================
C
C     
C
      SUBROUTINE PLOTS(I1,I2,I3)
      INTEGER I1,I2,I3
C
C Input:
C     I1,I2,I3... Dummy parameters - ignored.
C No output.
C
C Common block /PLOTC/:
      INCLUDE 'calcops.inc'
C     calcops.inc
C
C No subroutines and external functions required.
C
C Date: 1998, September 12
C Coded by Ludek Klimes
C
C.......................................................................
C
C     
C
C     ENTRY PLOTN(FILE,INCR)
      CHARACTER*(*) FILE
      INTEGER INCR
C
C Entry designed to store the name of the output PostScript file to be
C opened during the next invocation of subroutine PLOTS.  If PLOPN is
C not called before PLOTS, the first non-existing file of name
C 'plot00.ps', 'plot01.ps', 'plot02.ps', ..., 'plot99.ps' is opened for
C output.
C
C Input:
C     FILE... Name of the output PostScript file to be opened during the
C             next invocation of subroutine PLOTS.
C     INCR... If INCR is positive, the given filename is modified as
C             follows: All digits found in the filename are considered
C             to form an integer number and INCR is added to the number,
C             creating the new filename to be used by subroutine PLOTS.
C
C The input parameters are not altered.
C
C No output.
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      CHARACTER*80 FILEPS
      INTEGER IERR,I,K,N
      REAL RK,GK,BK
      SAVE FILEPS
      DATA FILEPS/' '/
C
C.......................................................................
C
C     Colours:
C     Default white:
      R(0)=1.
      G(0)=1.
      B(0)=1.
C     Default blacks:
      DO 10 K=1,MCOLOR
        R(K)=0.
        G(K)=0.
        B(K)=0.
   10 CONTINUE
C     Other colours:
      OPEN(LUCFG,FILE='calcops.rgb',STATUS='OLD',IOSTAT=IERR)
      IF(IERR.EQ.0) THEN
C       User-defined colours:
   11   CONTINUE
          K=-999
          READ(LUCFG,*,END=19) K,RK,GK,BK
          IF(K.LT.0) THEN
            GO TO 19
          ELSE IF(K.LE.MCOLOR) THEN
            R(K)=RK
            G(K)=GK
            B(K)=BK
          END IF
        GO TO 11
   19   CONTINUE
        CLOSE(LUCFG)
      ELSE
C       Default colours:
        R( 2)=1.00
        G( 2)=0.00
        B( 2)=0.00
        R( 3)=0.00
        G( 3)=1.00
        B( 3)=0.00
        R( 4)=0.00
        G( 4)=0.00
        B( 4)=1.00
        R( 5)=1.00
        G( 5)=1.00
        B( 5)=0.00
        R( 6)=0.00
        G( 6)=1.00
        B( 6)=1.00
        R( 7)=1.00
        G( 7)=0.00
        B( 7)=1.00
        R( 8)=0.90
        G( 8)=0.71
        B( 8)=0.50
        R( 9)=0.63
        G( 9)=0.63
        B( 9)=0.63
        R(10)=1.00
        G(10)=0.00
        B(10)=0.76
        R(11)=0.76
        G(11)=1.00
        B(11)=0.00
        R(12)=0.00
        G(12)=0.76
        B(12)=1.00
        R(13)=1.00
        G(13)=0.76
        B(13)=0.00
        R(14)=0.00
        G(14)=1.00
        B(14)=0.76
        R(15)=0.76
        G(15)=0.00
        B(15)=1.00
      END IF
C
C     Opening output PostScript file:
      IF(FILEPS.NE.' ') THEN
        OPEN(LUCFG,FILE=FILEPS,ERR=21)
          GO TO 29
   21   CONTINUE
C       CALCOPS-01
        CALL ERROR('CALCOPS-01: Unable to open given output PS file')
      ELSE
C       The name of the plot file is not given, using plot*.ps:
        FILEPS='plot00.ps'
        DO 28 I=0,99
          WRITE(FILEPS(5:6),'(2I1)') I/10,I-I/10*10
          OPEN(LUCFG,FILE=FILEPS,STATUS='NEW',ERR=25)
            GO TO 29
   25     CONTINUE
   28   CONTINUE
C       CALCOPS-02
        CALL ERROR('CALCOPS-02: Unable to open output PS file plot*.ps')
      END IF
   29 CONTINUE
      FILEPS=' '
C
C     Writing prolog containing definitions of procedures to be used:
      WRITE(LUCFG,'(A)')
     * '%!PS-Adobe-3.0 EPSF-3.0'
     *,'%%BoundingBox: (atend)'
     *,'%%Creator: CALCOPS'
     *,'%%EndComments'
     *,'%%BeginProlog'
     *,'%'
     *,'% General definitions:'
     *,'/C {setrgbcolor} bind def'
     *,'/M {stroke moveto} bind def'
     *,'/L {lineto} bind def'
     *,'/S {stroke} bind def'
     *,'/F {/H exch def'
     *,'    /Helvetica findfont exch scalefont setfont} bind def'
C     Character spacing is increased by: A=H-stringwidth/N
C     The whole string is shifted by:    A/2-0.15*H
     *,'/T {dup rotate exch dup stringwidth pop 4 -1 roll div H sub neg'
     *,'    dup 2 div 0.15 H mul sub dup 0 rmoveto 3 1 roll'
     *,'    exch 0 exch ashow neg 0 rmoveto neg rotate} bind def'
     *,'%'
     *,'% Centred symbols:'
     *,'/Tb {/H0 exch def /H1 H0 2 div def /H2 H1 2 div def'
     *,'   /h0 H0 neg def /h1 H1 neg def /h2 H2 neg def dup rotate} def'
     *,'/Te {neg rotate} def /BD {bind def} def /R  {rlineto}  def'
     *,'/T00 {Tb  0 H1 R h1  0 R  0 h0 R H0  0 R  0 H0 R h1  0 R       '
     *,'                                                  0 h1 R Te} BD'
     *,'/T01 {Tb  0 H1 R h2  0 R h2 h2 R  0 h1 R H2 h2 R H1  0 R       '
     *,'                 H2 H2 R  0 H1 R h2 H2 R h2  0 R  0 h1 R Te} BD'
     *,'/T02 {Tb  0 H1 R h1 h1 h2 add  R H0  0 R h1 H1 H2 add  R       '
     *,'                                                  0 h1 R Te} BD'
     *,'/T03 {Tb  0 H1 R  0 h0 R  0 H1 R h1  0 R H0  0 R h1  0 R Te} BD'
     *,'/T04 {Tb h1 H1 R H0 h0 R h1 H1 R H1 H1 R h0 h0 R H1 H1 R Te} BD'
     *,'/T05 {Tb  0 H1 R h1 h1 R H1 h1 R H1 H1 R h1 H1 R  0 h1 R Te} BD'
     *,'/T06 {Tb  0 H1 R h1 h1 R H0  0 R h1 H1 R  0 h0 R  0 H1 R Te} BD'
     *,'/T07 {Tb H1 h1 R h0 H0 R H0  0 R h0 h0 R H1 H1 R         Te} BD'
     *,'/T08 {Tb h2  0 R H1  0 R h2  0 R h1 h1 R H0  0 R h0  0 R       '
     *,'                         H0 H0 R h0  0 R H0  0 R h1 h1 R Te} BD'
     *,'/T09 {Tb h1 H1 R H1 h1 R H1 H1 R h1 h1 R  0 h1 R  0 H1 R Te} BD'
     *,'/T10 {Tb H1 H1 R h2 h2 R h1  0 R h2 H2 R H2 h2 R  0 h1 R       '
     *,' h2 h2 R H2 H2 R H1  0 R H2 h2 R h2 H2 R  0 H1 R h2 h2 R Te} BD'
     *,'/T11 {Tb h1 H1 R H0 h0 R h1 H1 R H1 H1 R h0 h0 R H1 H1 R       '
     *,'          0 H1 R  0 h0 R  0 H1 R H1  0 R h0  0 R H1  0 R Te} BD'
     *,'/T12 {Tb H1 h1 R h0  0 R H0 H0 R h0  0 R H1 h1 R         Te} BD'
     *,'/T13 {Tb  0 H1 R  0 h0 R  0 H1 R                         Te} BD'
     *,'%%EndProlog'
     *,'%'
     *,'%%BeginSetup'
     *,'%595 0 translate  90 rotate % line for landscape'
     *,' 0.0 0.0 translate  1.00 dup scale'
     *,' 1.0 setlinewidth 1 setlinecap 1 setlinejoin'
     *,'%%EndSetup'
     *,'%'
C
C     CalComp plotting initialization:
      STARTX=0.
      STARTY=0.
      XOLD=0.
      YOLD=0.
      HOLD=0.
      KOLOR=0
      B1=999.9
      B2=999.9
      B3=-99.9
      B4=-99.9
      CALL NEWPEN(1)
      RETURN
C
C-----------------------------------------------------------------------
C
      ENTRY PLOTN(FILE,INCR)
C
C.......................................................................
C
      FILEPS=FILE
C
C     Modifying the filename if INCRPS is positive
      DO 53 K=1,INCR
        N=LEN(FILEPS)
   50   CONTINUE
        DO 51 I=N,1,-1
          IF(LLE('0',FILEPS(I:I)).AND.LLE(FILEPS(I:I),'8')) THEN
            FILEPS(I:I)=CHAR(ICHAR(FILEPS(I:I))+1)
            GO TO 52
          ELSE IF(FILEPS(I:I).EQ.'9') THEN
            FILEPS(I:I)='0'
            N=I-1
            GO TO 50
          END IF
   51   CONTINUE
C         CALCOPS-03
          CALL ERROR('CALCOPS-03: Bad template name of PostScript file')
C         The digits in the template name of the output PostScript
C         files do not allow for the generation of a new filename.
C         The number of digits should be increased.
   52   CONTINUE
   53 CONTINUE
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE PLOT(XPAGE,YPAGE,IPEN)
      REAL    XPAGE,YPAGE
      INTEGER IPEN
C
C Input:
C     XPAGE,YPAGE... Coordinates of a point, in centimetres from the
C             current reference point (origin), of the position to which
C             the pen is to be moved.
C     IPEN... A signed integer which controls pen status (up or down)
C             and the origin definition:
C             IPEN=2... The pen is down during movement, thus drawing a
C               visible line.
C             IPEN=3... The pen is up during movement.
C             IPEN=-2 OR -3... A new origin is defined at the terminal
C               position after the movement is completed as if IPEN were
C               positive.
C             IPEN=999... Output device is closed.
C No output.
C
C Common block /PLOTC/:
      INCLUDE 'calcops.inc'
C     calcops.inc
C
C No subroutines and external functions required.
C
C Date: 1996, September 30
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      REAL X,Y,XO,YO
C
C.......................................................................
C
C     Plotting the line:
      IF(IABS(IPEN).EQ.2) THEN
        X=SCALE*(STARTX+XPAGE)
        Y=SCALE*(STARTY+YPAGE)
        XO=SCALE*(STARTX+XOLD)
        YO=SCALE*(STARTY+YOLD)
        IF(-99.95.LT.X.AND.X.LT.999.95.AND.
     *     -99.95.LT.Y.AND.Y.LT.999.95) THEN
          WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'L'
        ELSE
          WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'L'
        END IF
        B1=AMIN1(B1,XO,X)
        B2=AMIN1(B2,YO,Y)
        B3=AMAX1(B3,XO,X)
        B4=AMAX1(B4,YO,Y)
      END IF
      IF(IPEN.NE.2) THEN
        X=SCALE*(STARTX+XPAGE)
        Y=SCALE*(STARTY+YPAGE)
        IF(-99.95.LT.X.AND.X.LT.999.95.AND.
     *     -99.95.LT.Y.AND.Y.LT.999.95) THEN
          WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'M'
        ELSE
          WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'M'
        END IF
      END IF
C
C     Moving the origin:
      IF(IPEN.GE.0) THEN
        XOLD=XPAGE
        YOLD=YPAGE
      ELSE
        STARTX=STARTX+XPAGE
        STARTY=STARTY+YPAGE
        XOLD=0.
        YOLD=0.
      END IF
C
C     Closing CalComp:
      IF(IPEN.GE.999) THEN
        WRITE(LUCFG,'(A)') 'S'
        WRITE(LUCFG,'(A)') '%%Trailer'
        IF(-99.95.LT.B1.AND.B1.LT.999.95.AND.
     *     -99.95.LT.B2.AND.B2.LT.999.95.AND.
     *     -99.95.LT.B3.AND.B3.LT.999.95.AND.
     *     -99.95.LT.B4.AND.B4.LT.999.95) THEN
          WRITE(LUCFG,'(A,4I4)')
     *              '%%BoundingBox:',NINT(B1),NINT(B2),NINT(B3),NINT(B4)
        ELSE
          WRITE(LUCFG,'(A,4I6)')
     *              '%%BoundingBox:',NINT(B1),NINT(B2),NINT(B3),NINT(B4)
        END IF
        WRITE(LUCFG,'(A)') 'showpage'
        WRITE(LUCFG,'(A)') '%%EOF'
C       WRITE(LUCFG,'(A)') CHAR(4)
        CLOSE(LUCFG)
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE NEWPEN(INP)
      INTEGER INP
C
C Input:
C     INP...  Number of the pen or colour index to be selected.
C No output.
C
C Common block /PLOTC/:
      INCLUDE 'calcops.inc'
C     calcops.inc
C
C No subroutines and external functions required.
C
C Date: 1995, May 20
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
      IF(INP.NE.KOLOR) THEN
        IF(0.LE.INP.AND.INP.LE.MCOLOR) THEN
          KOLOR=INP
        ELSE
          KOLOR=MCOLOR
        END IF
        WRITE(LUCFG,'(A,3(F4.2,1X),A)')
     *                               'S ',R(KOLOR),G(KOLOR),B(KOLOR),'C'
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE SYMBOL(XPAGE,YPAGE,HEIGHT,TEXT,ANGLE,NCHAR)
      REAL    XPAGE,YPAGE,HEIGHT,ANGLE
      CHARACTER TEXT*(*)
      INTEGER NCHAR
C
C Input:
C     XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand
C             corner of the first character to be produced.
C             Continuation occurs when XPAGE and YPAGE equals 999.
C     HEIGHT..Height, in centimetres, of the characters to be plotted.
C             The character width, including spacing, is normally the
C             same as the height.
C     TEXT... String containing the text to be plotted.
C     ANGLE...Angle, in degrees anticlockwise from the X-axis, at which
C             the text is to be plotted.
C     NCHAR...NCHAR.GT.0: number of characters to be drawn.
C             NCHAR.EQ.0: one character is to be drawn
C             NCHAR.LT.0: to plot a centred symbol no. ICHAR(TEXT(1:1)).
C               NCHAR.EQ.-1: the pen is up during the move.
C               NCHAR.EQ.-2: the pen is down during the move.
C No output.
C
C Common block /PLOTC/:
      INCLUDE 'calcops.inc'
C     calcops.inc
C
C No subroutines and external functions required.
C
C Date: 1998, October 25
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I
      REAL X,Y,SX,SY,UX,UY,VX,VY,WX,WY
C
C     X,Y...  Coordinates.
C     SX,SY.. Scaled coordinates.
C     UX,UY...Text path vector.
C     VX,VY...Scaled text path vector.
C
C.......................................................................
C
      IF(HEIGHT.NE.HOLD) THEN
        IF(-99.95.LT.1.37*SCALE*HEIGHT.AND.
     *               1.37*SCALE*HEIGHT.LT.999.95) THEN
          WRITE(LUCFG,'(2(F5.1,1X),A)')
     *                                1.37*SCALE*HEIGHT,SCALE*HEIGHT,'F'
        ELSE
          WRITE(LUCFG,'(2(I5,1X),A)')
     *                    NINT(1.37*SCALE*HEIGHT),NINT(SCALE*HEIGHT),'F'
        END IF
        HOLD=HEIGHT
      END IF
C
      X=XPAGE
      Y=YPAGE
      IF(ABS(X).GT.998.) THEN
        X=XOLD
        Y=YOLD
      END IF
C
      UX= HEIGHT*COS(.0174533*ANGLE)
      UY= HEIGHT*SIN(.0174533*ANGLE)
      SX=SCALE*(STARTX+X)
      SY=SCALE*(STARTY+Y)
      IF(NCHAR.GE.0) THEN
C       Standard call - text:
        IF(TEXT(1:NCHAR).NE.' ') THEN
          DO 1 I=MAX0(NCHAR,1),1,-1
            IF(TEXT(I:I).NE.' ') THEN
              GO TO 2
            END IF
    1     CONTINUE
          I=1
    2     CONTINUE
          IF(-99.95.LT.SX.AND.SX.LT.999.95.AND.
     *       -99.95.LT.SY.AND.SY.LT.999.95) THEN
            WRITE(LUCFG,'(2(F5.1,1X),A,I3,3A,I4,A)')
     *                 SX,SY,'M ',I,' (',TEXT(1:I),') ',NINT(ANGLE),' T'
          ELSE
            WRITE(LUCFG,'(2(I5,1X),A,I3,3A,I4,A)')
     *     NINT(SX),NINT(SY),'M ',I,' (',TEXT(1:I),') ',NINT(ANGLE),' T'
          END IF
          VX= SCALE*UX
          VY= SCALE*UY
          WX= VX*FLOAT(I)
          WY= VY*FLOAT(I)
          SX=SX-0.15*VX
          SY=SY-0.15*VY
          B1=AMIN1(B1,SX,SX+WX,SX-VY,SX+WX-VY)
          B2=AMIN1(B2,SY,SY+WY,SY+VX,SY+WY+VX)
          B3=AMAX1(B3,SX,SX+WX,SX-VY,SX+WX-VY)
          B4=AMAX1(B4,SY,SY+WY,SY+VX,SY+WY+VX)
        END IF
        X=X+UX*FLOAT(NCHAR)
        Y=Y+UY*FLOAT(NCHAR)
      ELSE
C       Special call - centred symbol:
        VX= SCALE*UX/2.
        VY= SCALE*UY/2.
        B1=AMIN1(B1,SX+VX+VY,SX-VX+VY,SX+VX-VY,SX-VX-VY)
        B2=AMIN1(B2,SY+VY+VX,SY-VY+VX,SY+VY-VX,SY-VY-VX)
        B3=AMAX1(B3,SX+VX+VY,SX-VX+VY,SX+VX-VY,SX-VX-VY)
        B4=AMAX1(B4,SY+VY+VX,SY-VY+VX,SY+VY-VX,SY-VY-VX)
        I=MIN0(ICHAR(TEXT(1:1)),13)
        IF(NCHAR.EQ.-2) THEN
          IF(-99.95.LT.SX.AND.SX.LT.999.95.AND.
     *       -99.95.LT.SY.AND.SY.LT.999.95.AND.
     *       -99.95.LT.SCALE*HEIGHT.AND.SCALE*HEIGHT.LT.999.95) THEN
            WRITE(LUCFG,'(2(F5.1,1X),A,I4,1X,F5.1,A,I2.2)')
     *                        SX,SY,'L ',NINT(ANGLE),SCALE*HEIGHT,' T',I
          ELSE
            WRITE(LUCFG,'(2(I5,1X),A,I4,1X,I5,A,I2.2)')
     *      NINT(SX),NINT(SY),'L ',NINT(ANGLE),NINT(SCALE*HEIGHT),' T',I
          END IF
          SX=SCALE*(STARTX+XOLD)
          SY=SCALE*(STARTY+YOLD)
          B1=AMIN1(B1,SX)
          B2=AMIN1(B2,SY)
          B3=AMAX1(B3,SX)
          B4=AMAX1(B4,SY)
        ELSE
          IF(-99.95.LT.SX.AND.SX.LT.999.95.AND.
     *       -99.95.LT.SY.AND.SY.LT.999.95.AND.
     *       -99.95.LT.SCALE*HEIGHT.AND.SCALE*HEIGHT.LT.999.95) THEN
            WRITE(LUCFG,'(2(F5.1,1X),A,I4,F5.1,A,I2.2)')
     *                        SX,SY,'M ',NINT(ANGLE),SCALE*HEIGHT,' T',I
          ELSE
            WRITE(LUCFG,'(2(I5,1X),A,I4,1X,I5,A,I2.2)')
     *      NINT(SX),NINT(SY),'M ',NINT(ANGLE),NINT(SCALE*HEIGHT),' T',I
          END IF
        END IF
      END IF
      XOLD=X
      YOLD=Y
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE NUMBER (XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC)
      REAL XPAGE,YPAGE,HEIGHT,FPN,ANGLE
      INTEGER NDEC
C
C Input:
C     XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand
C             corner of the first character to be produced.
C             Continuation occurs when XPAGE and YPAGE equals 999.
C     HEIGHT..Height, in centimetres, of the characters to be plotted.
C             The character width, including spacing, is normally the
C             same as the height.
C     FPN...  Floating point number to be plotted.
C     ANGLE...Angle, in degrees anticlockwise from the X-axis, at which
C             the number is to be plotted.
C     NDEC... Controls the precision of the conversion of the number
C             FPN.
C             NDEC.GE.0: number of decimal places to be drawn, after
C               rounding.
C             NDEC.EQ.-1: only the integer portion is to be plotted,
C               after rounding.
C             NDEC.LE.-2: -NDEC-1 digits are truncated from the integer
C               portion, after rounding.
C             The magnitude of NDEC should not exceed 9.
C No output.
C
C No subroutines and external functions required.
C
C Date: 1993, December 18
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER N,ILP,I,J,K
      REAL X,Y,FPV,SAMEV
      PARAMETER (SAMEV=999.)
C
C     N...    Storage for (possibly modified) NDEC.
C     ILP...  Length of the integer part of the given number.
C     I...    Temporary storage.
C     J...    Loop variable.
C     K...    Digit to plot.
C     X,Y...  Coordinates.
C     FPV...  Storage for FPN and its decimal modules.
C
C.......................................................................
C
      X=XPAGE
      Y=YPAGE
      FPV=FPN
      N=MIN0(MAX0(-9,NDEC),9)
C
C     Minus sign:
      IF (FPV.LT.0) THEN
        CALL SYMBOL (X,Y,HEIGHT,'-',ANGLE,1)
        X=SAMEV
        Y=SAMEV
      END IF
C
C     To guarantee a correct rounding:
      IF (N.GE.0) THEN
        FPV=ABS(FPV)+(0.5*0.1**N)
      ELSE
        FPV=ABS(FPV)+(0.05*0.1**N)
      END IF
C
C     Integer part of the given number:
      I=INT(ALOG10(FPV)+1.0)
      IF(N.GE.-1) THEN
        ILP=I
      ELSE
        ILP=I+N+1
      END IF
      IF (ILP.LE.0) THEN
        CALL SYMBOL (X,Y,HEIGHT,'0',ANGLE,1)
        X=SAMEV
        Y=SAMEV
      ELSE
        DO 60 J=1,ILP
          K=FPV*10.**(J-I)
          CALL SYMBOL (X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1)
          FPV=FPV-(FLOAT(K)*10.**(I-J))
          X=SAMEV
          Y=SAMEV
   60   CONTINUE
      END IF
C
C     Decimal places:
      IF(N.GE.0) THEN
        CALL SYMBOL (X,Y,HEIGHT,'.',ANGLE,1)
        DO 70 J=1,N
          K=FPV*10.
          CALL SYMBOL(X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1)
          FPV=FPV*10.-FLOAT(K)
   70   CONTINUE
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE FILL(XPTS,YPTS,NPTS)
      INTEGER NPTS
      REAL    XPTS(NPTS),YPTS(NPTS)
C
C Subroutine to fill the area inside a given polygon with the colour
C specified by the last invocation of subroutine NEWPEN.
C
C Input:
C     XPTS,YPTS... Coordinates of vertices of the polygon to be filled
C             with the current colour specified by subroutine NEWPEN.
C     NPTS... Number of vertices of the polygon
C             and the origin definition:
C No output.
C
C Common block /PLOTC/:
      INCLUDE 'calcops.inc'
C     calcops.inc
C
C No subroutines and external functions required.
C
C Date: 1996, September 30
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I
      REAL X,Y
C
C.......................................................................
C
      DO 10 I=1,NPTS
        X=SCALE*(STARTX+XPTS(I))
        Y=SCALE*(STARTY+YPTS(I))
        IF(I.EQ.1) THEN
          IF(-99.95.LT.X.AND.X.LT.999.95.AND.
     *       -99.95.LT.Y.AND.Y.LT.999.95) THEN
            WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'M'
          ELSE
            WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'M'
          END IF
        ELSE IF(I.LT.NPTS) THEN
          IF(-99.95.LT.X.AND.X.LT.999.95.AND.
     *       -99.95.LT.Y.AND.Y.LT.999.95) THEN
            WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'L'
          ELSE
            WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'L'
          END IF
        ELSE
          IF(-99.95.LT.X.AND.X.LT.999.95.AND.
     *       -99.95.LT.Y.AND.Y.LT.999.95) THEN
            WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'L closepath fill'
          ELSE
            WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),
     *                                                'L closepath fill'
          END IF
        END IF
        B1=AMIN1(B1,X)
        B2=AMIN1(B2,Y)
        B3=AMAX1(B3,X)
        B4=AMAX1(B4,Y)
   10 CONTINUE
      RETURN
      END
C
C=======================================================================
C