C 
C CalComp-GKS interface
C
C Date: 1998, October 6
C Coded by Ludek Klimes
C
C This file contains the CalComp plotting routines
C     PLOTS, PLOT, NEWPEN, SYMBOL and NUMBER
C     PLOTS
C     PLOT
C     NEWPEN
C     SYMBOL
C     NUMBER
C coded in the ANSI X3.9-1978 FORTRAN77 standard full language employing
C the ANSI X3.124-1985 GKS (Graphical Kernel System) Level 0b
C subroutines.  Whereas the original CalComp routines are conformable to
C the ANSI X3.10-1966 FORTRAN standard, the dummy argument text of the
C subroutine 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 CalComp configuration:
C     INTERACTIVE WORKSTATION... Identifier of the interactive
C             workstation, i.e. the workstation at which the user is
C             asked to confirm or reset the configuration.  The plot
C             on the interactive workstation is not erased before the
C             user's confirmation.  The identifier of the interactive
C             workstation may be changed only by means of editing the
C             configuration file.  Zero or none identifier leads to the
C             batch mode in which all plots are made without asking the
C             user for confirmation.
C             Note, that in this interface, the workstation identifier,
C             connection identifier, and workstation type are the same
C             integer referred in the GKS configuration file kernel.sys.
C     OPEN WORKSTATIONS... Identifiers of the workstations which are to
C             be opened for plotting.  The list open workstations may be
C             changed through the interactive workstation before
C             starting each plot, or by means of editing the
C             configuration file.
C     CALCOMP PLOT WINDOW... The dimensions of picture in the CalComp
C             units.  The CalComp plot window is mapped onto the largest
C             rectangle within the workstation viewport, having the same
C             aspect ratio as the CalComp plot window.  The CalComp plot
C             window may be reset through the interactive workstation
C             before starting each plot, or by means of editing the
C             configuration file.
C             Note that the workstation viewport is the maximum plot
C             area of the workstation.
C     COLOUR REPETITION... If this integer is set to N, colours 2 to N
C             are periodically repeated representing also colour indices
C             N+1 to 2*N-1, 2*N to 3*N-2, 3*N-1 to 4*N-3, and so on.
C             This unimportant option may be set only by means of
C             editing the configuration file.
C     'COLOUR TABLE'... String representing the name of the disk file
C             containing the colour table.  If blank (default),
C             no colour table is read and 16 default colours 0 to 15,
C             defined in subroutine PLOTS, are used.  Otherwise, the
C             colours specified in the disk file are redefined or
C             defined in addition to the default colours.  See the
C             description of the CalComp colour table file below.
C
C CalComp configuration file 'calcomp.cfg':
C     When the CalComp configuration is changed, this interface creates
C     file calcomp.cfg containing the new configuration in the current
C     directory.  As long as the file calcomp.cfg lives in the current
C     directory, the CalComp configuration is taken from calcomp.cfg.
C     Thus, to return to the default CalComp configuration, simply
C     delete calcomp.cfg.
C
C Error listing file 'calcomp.lst':
C     File calcomp.lst is created in the current directory in order to
C     contain the GKS error messages.
C
C CalComp colour table file:
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     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
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 'calcomp.inc'
C     calcomp.inc
C
C Subroutines and external functions required:
      REAL RNUM
      EXTERNAL RNUM,NEWPEN,NUMBER
      EXTERNAL GOPKS,GOPWK,GACWK,GCLRWK,GDAWK,GCLWK,GSWKWN,GQOPWK,GQEWK
      EXTERNAL GQWKCA,GQWKCL,GQDSP,GSCHH,GSCR,GSTXCI,GTX,GINST,GRQST
C     RNUM... Auxiliary real function converting a string into the
C             corresponding number.  This file.
C     NEWPEN,NUMBER... This file.
C     G*****... GKS standard subroutines.
C
C Date: 1998, September 20
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
C
      CHARACTER*80 STR(1),CTABLE
      INTEGER LUCFG,LUERR,IERR,LENGTH,IC1,IC2,I,J,K,N,NDEC,IDC,IX,IY
      PARAMETER (LUCFG=97)
      PARAMETER (LUERR=98)
      REAL RX,RY,XMAX,YMAX,XNDC,YNDC
      REAL X1,X2,X3,X4,X5,X6,X7,Y,YH,HEIGHT,R,G,B
      REAL RX1,RX2,RY1,RY2
C     REAL AUX
C
C     STR...  Temporary string storage location.
C     CTABLE..Name of the file containing colour table.
C     LUCFG...Logical unit number of the CalComp configuration file
C             calcomp.lst.
C     LUERR...Logical unit number of the error file calcomp.lst.
C     IERR... Error code.
C     LENGTH... Length of a string.
C     IC1,IC2... Text colour indices when writing to the display.
C     I,J,K,N... Temporary storage locations.
C     NDEC... Number of decimal places.
C     IDC...  Workstation units (0... metres, 1... relative).
C     IX,IY...Dimensions of a workstation viewport in pixels.
C     RX,RY...Dimensions of a workstation viewport in the workstation
C             units.
C     XMAX,YMAX... Dimensions of the CalComp plot window in centimeters.
C     XNDC,YNDC... Dimensions of the CalComp plot window in NDC units.
C     X1,X2,X3,X4,X5,X6,X7,Y... World coordinates.
C     YH...   Line spacing.
C     HEIGHT..Character height.
C     R,G,B,RX1,RX2,RY1,RY2,AUX...  Temporary storage locations.
C
C.......................................................................
C
C     Opening GKS:
      OPEN(LUERR,FILE='calcomp.lst')
      WRITE(LUERR,'(A)') 'GKS ERROR MESSAGES:'
      CALL GOPKS(LUERR,-1)
C
C     Reading CalComp parameters:
    1 CONTINUE
C       Default CalComp parameters
          IUSER=0
          DO 2 I=1,MOPEN
            IOPEN(I)=0
    2     CONTINUE
          XMAX=29.7
          YMAX=21.0
          KOLREP=0
          CTABLE=' '
        OPEN(LUCFG,FILE='calcomp.cfg',STATUS='OLD',IOSTAT=IERR)
        IF(IERR.EQ.0) THEN
C         Reading the parameters from the CalComp configuration file
          READ(LUCFG,*,END=4) IUSER
          READ(LUCFG,*,END=4) IOPEN
          READ(LUCFG,*,END=4) XMAX,YMAX
          READ(LUCFG,*,END=4) KOLREP
          READ(LUCFG,*,END=4) CTABLE
    4     CONTINUE
          CLOSE(LUCFG)
        ELSE
          IUSER=1
          IOPEN(1)=1
        END IF
        DO 5 I=1,MOPEN
          IF(IOPEN(I).LE.0) THEN
            NOPEN=I-1
            GO TO 6
          END IF
    5   CONTINUE
        NOPEN=MOPEN
    6   CONTINUE
        IF(IUSER.LE.0) THEN
          GO TO 20
        END IF
C
C       *** beginning of the interactive part ***
C
C       Displaying CalComp parameters:
        CALL GQOPWK(1,IERR,N,I)
        IF(IERR.EQ.0.AND.N.EQ.1.AND.IUSER.EQ.I) THEN
C         Interactive workstation already open
          CALL GCLRWK(IUSER,1)
        ELSE IF(IERR.NE.0.OR.N.EQ.0) THEN
C         Interactive workstation closed
          CALL GOPWK(IUSER,IUSER,IUSER)
          CALL GACWK(IUSER)
        ELSE
C         CALCOMP-01
          CALL ERROR
     *        ('CALCOMP-01: Error when opening interactive workstation')
        END IF
        X1=0.00
        X2=0.22
        X3=0.50
        X4=0.64
        X5=0.67
        X6=0.82
        X7=0.94
        YH=0.04
        HEIGHT=0.65*YH
        CALL GSCHH(HEIGHT)
        Y=1.-YH
        IC1=1
        IC2=5
        CALL GSCR(IUSER,  0,0.0,0.6,0.0)
        CALL GSCR(IUSER,IC1,1.0,1.0,1.0)
        CALL GSCR(IUSER,IC2,1.0,1.0,0.0)
        CALL GSTXCI(IC1)
        CALL GTX(X1,Y,'FORTRAN77 CalComp to GKS conversion software.')
        Y=Y-2.*YH
        CALL GTX(X1,Y,'Workstation:')
        CALL GTX(X2,Y,'Classification:')
        CALL GTX(X3,Y,'Viewport size:')
        CALL GTX(X6,Y,'Units:')
        CALL GTX(X7,Y,'Status:')
        CALL GQEWK(1,IERR,N,K)
        IF(IERR.EQ.0) THEN
          DO 15 J=1,N
            CALL GQEWK(J,IERR,N,K)
            IF(IERR.EQ.0) THEN
              CALL GQWKCA(K,IERR,I)
              IF(IERR.EQ.0.AND.(I.EQ.0.OR.I.EQ.2.OR.I.EQ.4)) THEN
C               Workstation is of the category: OUTPUT, OUTIN or MO.
                Y=Y-YH
C               (1) Workstation
                CALL NUMBER(X1,Y,HEIGHT,FLOAT(K),0.,-1)
C               (2) Classification
                CALL GQWKCL(K,IERR,I)
                IF(IERR.EQ.0) THEN
                  IF(I.EQ.0) THEN
                    STR(1)='VECTOR'
                  ELSE IF(I.EQ.1) THEN
                    STR(1)='RASTER'
                  ELSE
                    STR(1)='OTHER'
                  END IF
                  CALL GTX(X2,Y,STR(1))
                END IF
C               (3-6) Viewport size and its units
                CALL GQDSP(K,IERR,IDC,RX,RY,IX,IY)
                IF(IERR.EQ.0) THEN
                  IF(IDC.EQ.0) THEN
                    STR(1)='cm'
                    RX=RX*100.
                    RY=RY*100.
                    NDEC=2
                  ELSE
                    STR(1)='  '
C                   AUX=AMAX1(XMAX/RX,YMAX/RY)
C                   RX=RX*AUX
C                   RY=RY*AUX
                    IF(RX.LT.0.99995) THEN
                      RX=RX*100.
                      RY=RY*100.
                      NDEC=2
                    ELSE
                      IF(IX.LT.9999) THEN
                        RX=FLOAT(IX)
                        RY=FLOAT(IY)
                        NDEC=-1
                      ELSE
                        IF(RX.LT.99.95) THEN
                          NDEC=1
                        ELSE
                          NDEC=-1
                        END IF
                      END IF
                    END IF
                  END IF
                  CALL NUMBER(X3,Y,HEIGHT,RX,0.,NDEC)
                  CALL GTX(X4,Y,'*')
                  CALL NUMBER(X5,Y,HEIGHT,RY,0.,NDEC)
                  CALL GTX(X6,Y,STR(1))
                END IF
C               (7) Status
                STR(1)='CLOSED'
                DO 14 I=1,NOPEN
                  IF(IOPEN(I).EQ.K) THEN
                    STR(1)='OPEN'
                  END IF
   14           CONTINUE
                CALL GSTXCI(IC2)
                CALL GTX(X7,Y,STR(1))
                CALL GSTXCI(IC1)
              END IF
            END IF
   15     CONTINUE
        END IF
        Y=Y-2.*YH
        CALL GTX(X1,Y,'CalComp plotting window:')
        CALL GSTXCI(IC2)
        CALL NUMBER(X3,Y,HEIGHT,XMAX,0.,2)
        CALL GSTXCI(IC1)
        CALL GTX(X4,Y,'*')
        CALL GSTXCI(IC2)
        CALL NUMBER(X5,Y,HEIGHT,YMAX,0.,2)
        CALL GSTXCI(IC1)
        CALL GTX(X6,Y,'cm')
        Y=Y-YH
        CALL GTX(X1,Y,'Colour-table filename:')
        IF(CTABLE.EQ.' ') THEN
          CALL GTX(X3,Y,'NONE')
        ELSE
          CALL GSTXCI(IC2)
          CALL GTX(X3,Y,CTABLE)
          CALL GSTXCI(IC1)
        END IF
        Y=Y-2.*YH
        CALL GTX(X1,Y,
     *  'Enter a digit to open/close the corresponding workstation,')
        Y=Y-YH
        CALL GTX(X1,Y,
     *  'Enter ''W'' to change the CalComp plotting window,')
        Y=Y-YH
        CALL GTX(X1,Y,
     *  'Enter ''C'' to change the colour-table filename,')
        Y=Y-YH
        CALL GTX(X1,Y,
     *  'Press ''ENTER'' to continue.')
        Y=Y-2.*YH
        CALL GTX(X1,Y,
     *  'After plotting, press ''ENTER'' again to continue.')
C
C       Changing CalComp parameters:
        CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY)
        RX1=0.00*RX
        RX2=1.00*RX
        RY1=0.01*RY
        RY2=0.99*RY
        CALL GINST(IUSER,IUSER,14,'YOUR ANSWER:  ',
     *        1,RX1,RX2,RY1,RY2,80,14,1,STR)
        CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1))
        IF(LLE('1',STR(1)(14:14)).AND.LLE(STR(1)(14:14),'9')) THEN
          DO 17 J=1,NOPEN
            IF(IOPEN(J).EQ.ICHAR(STR(1)(14:14))-ICHAR('0')) THEN
              NOPEN=NOPEN-1
              DO 16 I=J,NOPEN
                IOPEN(I)=IOPEN(I+1)
   16         CONTINUE
              GO TO 18
            END IF
   17     CONTINUE
          NOPEN=NOPEN+1
          IOPEN(NOPEN)=ICHAR(STR(1)(14:14))-ICHAR('0')
   18     CONTINUE
        ELSE IF(STR(1)(14:14).EQ.'W'.OR.STR(1)(14:14).EQ.'w') THEN
          CALL GINST(IUSER,IUSER,33,'ENTER HORIZONTAL DIMENSION:      ',
     *          1,RX1,RX2,RY1,RY2,80,29,1,STR)
          CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1))
          XMAX=RNUM(STR(1),LENGTH)
          CALL GINST(IUSER,IUSER,33,'ENTER VERTICAL DIMENSION:        ',
     *          1,RX1,RX2,RY1,RY2,80,27,1,STR)
          CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1))
          YMAX=RNUM(STR(1),LENGTH)
        ELSE IF(STR(1)(14:14).EQ.'C'.OR.STR(1)(14:14).EQ.'c') THEN
          CALL GINST(IUSER,IUSER,33,'ENTER COLOUR TABLE FILENAME:     ',
     *          1,RX1,RX2,RY1,RY2,80,30,1,STR)
          CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1))
          CTABLE=STR(1)(INDEX(STR(1),':')+2:LEN(STR(1)))
        ELSE
          GO TO 20
        END IF
C
C       Writing CalComp parameters into the CalComp configuration file:
        OPEN(LUCFG,FILE='calcomp.cfg')
        WRITE(LUCFG,*) IUSER,               ' / INTERACTIVE WORKSTATION'
        WRITE(LUCFG,*) (IOPEN(I),I=1,NOPEN),' / OPEN WORKSTATIONS'
        WRITE(LUCFG,*) XMAX,YMAX,           ' / CALCOMP PLOT WINDOW'
        WRITE(LUCFG,*) KOLREP,              ' / COLOUR REPETITION'
        I=LEN(CTABLE)+1
   19   CONTINUE
          I=I-1
        IF(I.GT.1.AND.CTABLE(I:I).EQ.' ') GO TO 19
        WRITE(LUCFG,*) '''',CTABLE(1:I),  ''' / COLOUR-TABLE FILE'
        CLOSE(LUCFG)
      GO TO 1
C
C     *** end of the interactive part ***
C
C     Opening and activating workstations
   20 CONTINUE
      XNDC=XMAX/AMAX1(XMAX,YMAX)
      YNDC=YMAX/AMAX1(XMAX,YMAX)
      DO 27 I=1,NOPEN
        IF(IOPEN(I).EQ.IUSER) THEN
          CALL GCLRWK(IOPEN(I),1)
        ELSE
          CALL GOPWK(IOPEN(I),IOPEN(I),IOPEN(I))
          CALL GACWK(IOPEN(I))
        END IF
        CALL GSWKWN(IOPEN(I),0.,XNDC,0.,YNDC)
C
C       Default colour representation
C       R20(dB):  1.00    0.90    0.80    0.71    0.63    0.56    0.50
C       R40(dB/2):    0.95    0.85    0.75    0.67    0.60    0.53
C       IF(IOPEN(I).EQ.IUSER) THEN
        CALL GSCR(IOPEN(I), 0,1.00,1.00,1.00)
        CALL GSCR(IOPEN(I), 1,0.00,0.00,0.00)
        CALL GSCR(IOPEN(I), 2,1.00,0.00,0.00)
        CALL GSCR(IOPEN(I), 3,0.00,0.90,0.00)
        CALL GSCR(IOPEN(I), 4,0.00,0.00,1.00)
        CALL GSCR(IOPEN(I), 5,1.00,0.90,0.00)
        CALL GSCR(IOPEN(I), 6,0.00,0.80,0.90)
        CALL GSCR(IOPEN(I), 7,0.90,0.00,0.90)
        CALL GSCR(IOPEN(I), 8,0.90,0.63,0.50)
        CALL GSCR(IOPEN(I), 9,0.63,0.63,0.63)
        CALL GSCR(IOPEN(I),10,0.95,0.00,0.71)
        CALL GSCR(IOPEN(I),11,0.71,0.85,0.00)
        CALL GSCR(IOPEN(I),12,0.00,0.63,0.95)
        CALL GSCR(IOPEN(I),13,0.95,0.63,0.00)
        CALL GSCR(IOPEN(I),14,0.00,0.85,0.71)
        CALL GSCR(IOPEN(I),15,0.71,0.00,0.95)
   27 CONTINUE
      IF(IUSER.NE.0) THEN
        DO 28 I=1,NOPEN
          IF(IOPEN(I).EQ.IUSER) THEN
            GO TO 29
          END IF
   28   CONTINUE
C         Closing the display
          CALL GDAWK(IUSER)
          CALL GCLWK(IUSER)
   29   CONTINUE
      END IF
C
C     Setting coordinate transformation:
      CALL GSVP(1,0.,XNDC,0.,YNDC)
      CALL GSWN(1,0.,XMAX,0.,YMAX)
      CALL GSELNT(1)
C
C     Reading colour table from a disk file:
      IF(CTABLE.NE.' ') THEN
        OPEN(LUCFG,FILE=CTABLE,STATUS='OLD',IOSTAT=IERR)
        IF(IERR.EQ.0) THEN
   31     CONTINUE
            K=-999
            READ(LUCFG,*,END=39) K,R,G,B
            IF(K.LT.0) THEN
              GO TO 39
            END IF
            DO 32 I=1,NOPEN
              CALL GSCR(IOPEN(I),K,R,G,B)
   32       CONTINUE
          GO TO 31
   39     CONTINUE
          CLOSE(LUCFG)
        ELSE
C         CALCOMP-51
          CALL WARN('CALCOMP-51: Colour table file not found')
        END IF
      END IF
C
C     CalComp plotting initialization:
      ICOUNT=0
      STARTX=0.
      STARTY=0.
      OLDX=0.
      OLDY=0.
      KOLOR=0
      CALL NEWPEN(1)
      RETURN
      END
C
C-----------------------------------------------------------------------
C
C     
C
      REAL FUNCTION RNUM(STR,LENGTH)
      CHARACTER*(*) STR
      INTEGER LENGTH
C
C Auxiliary function to PLOTS, converting an input string to the real
C number, used in the interactive part of the PLOTS subroutine.
C
C.......................................................................
C
C     Auxiliary storage locations:
      INTEGER I
      REAL AUX1,AUX2,AUX3
C
      AUX1=0.
      AUX2=1.
      AUX3=1.
      DO 10 I=1,LENGTH
        IF(LLE('0',STR(I:I)).AND.LLE(STR(I:I),'9')) THEN
          AUX1=AUX1*10.+FLOAT(ICHAR(STR(I:I))-ICHAR('0'))
          AUX2=AUX2*AUX3
        ELSE IF(STR(I:I).EQ.'.') THEN
          AUX3=0.1
        END IF
   10 CONTINUE
      RNUM=AUX1*AUX2
      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 'calcomp.inc'
C     calcomp.inc
C
C Subroutines and external functions required:
      EXTERNAL GDAWK,GCLWK,GCLKS,GQDSP,GPL,GINST,GRQST,GESC
C     G*****... GKS standard subroutines.
C
C Date: 1993, December 18
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      CHARACTER*80 STR(1)
      INTEGER IERR,LENGTH,I,IDC,IX,IY
      REAL    RX,RY
C
C     IERR... Error code.
C     LENGTH... Length of a string.
C     I...    Loop variable.
C     IDC...  Workstation units (0... metres, 1... relative).
C     IX,IY...Dimensions of a workstation viewport in pixels.
C     RX,RY...Dimensions of a workstation viewport in the workstation
C             units.
C
C.......................................................................
C
C     Recording or plotting the polyline:
      IF(IABS(IPEN).EQ.2) THEN
    1   CONTINUE
        IF(ICOUNT.EQ.0) THEN
            ICOUNT=1
            PX(1)=STARTX+OLDX
            PY(1)=STARTY+OLDY
        END IF
        IF(ICOUNT.LT.MCOUNT) THEN
          IF(XPAGE.NE.OLDX.OR.YPAGE.NE.OLDY) THEN
            ICOUNT=ICOUNT+1
            PX(ICOUNT)=STARTX+XPAGE
            PY(ICOUNT)=STARTY+YPAGE
          END IF
        ELSE
          CALL GPL(ICOUNT,PX,PY)
          ICOUNT=0
          GO TO 1
        END IF
      END IF
      IF(IPEN.NE.2) THEN
        IF(ICOUNT.GT.0) THEN
          IF(ICOUNT.EQ.1) THEN
            ICOUNT=2
            PX(2)=PX(1)
            PY(2)=PY(1)
          END IF
          CALL GPL(ICOUNT,PX,PY)
          ICOUNT=0
        END IF
      END IF
C
C     Moving the origin:
      IF(IPEN.GE.0) THEN
        OLDX=XPAGE
        OLDY=YPAGE
      ELSE
        STARTX=STARTX+XPAGE
        STARTY=STARTY+YPAGE
        OLDX=0.
        OLDY=0.
      END IF
C
C     Closing CalComp:
      IF(IPEN.GE.999) THEN
C       Closing workstations
        DO 91 I=1,NOPEN
          IF(IOPEN(I).NE.IUSER) THEN
C           Closing batch workstations (other than the display)
            CALL GDAWK(IOPEN(I))
            CALL GCLWK(IOPEN(I))
          END IF
   91   CONTINUE
        DO 92 I=1,NOPEN
          IF(IOPEN(I).EQ.IUSER) THEN
C           Prompting to close the display
            CALL GESC(-1,1,CHAR(7),1,LENGTH,STR)
            CALL GESC(-1,1,CHAR(7),1,LENGTH,STR)
            CALL GESC(-1,1,CHAR(7),1,LENGTH,STR)
            CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY)
            CALL GINST(IUSER,IUSER,1,' ',1,0.,RX,0.,RY,80,1,1,STR)
            CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1))
            CALL GDAWK(IUSER)
            CALL GCLWK(IUSER)
          END IF
   92   CONTINUE
        CALL GCLKS
      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 'calcomp.inc'
C     calcomp.inc
C
C Subroutines and external functions required:
      EXTERNAL GSPLCI,GSPMCI,GSTXCI,GPL
C     G*****... GKS standard subroutines.
C
C Date: 1993, December 18
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage location:
      INTEGER I
C
C     I...    Colour assigned to the input colour index.
C
C.......................................................................
C
      IF(INP.NE.KOLOR) THEN
C
C       Plotting the recorded polyline:
        IF(ICOUNT.GT.0) THEN
          IF(ICOUNT.EQ.1) THEN
            ICOUNT=2
            PX(2)=PX(1)
            PY(2)=PY(1)
          END IF
          CALL GPL(ICOUNT,PX,PY)
          ICOUNT=0
        END IF
C
C       Changing the colour indices
C       (for KOLREP.GT.1, colours 2 to KOLREP are periodically repeated)
        IF(KOLREP.GT.1) THEN
          I=MOD(INP-2,KOLREP-1)+2
        ELSE
          I=INP
        END IF
        CALL GSPLCI(I)
        CALL GSPMCI(I)
        CALL GSTXCI(I)
C
        KOLOR=INP
      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 'calcomp.inc'
C     calcomp.inc
C
C Subroutines and external functions required:
      EXTERNAL PLOT
      EXTERNAL GSCHH,GSCHUP,GTX,GSMKSC,GSMK,GPM,GPL
C     PLOT... This file.
C     G*****... GKS standard subroutines.
C
C Date: 1995, May 20
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I
      REAL X,Y,UX,UY
C
C     X,Y...  Coordinates.
C     UX,UY...Text path vector.
C
C.......................................................................
C
      X=XPAGE
      Y=YPAGE
      IF(ABS(X).GT.998.) X=OLDX
      IF(ABS(Y).GT.998.) Y=OLDY
      IF(NCHAR.EQ.-2) THEN
        CALL PLOT(X,Y,2)
      END IF
C
C     Plotting the recorded polyline:
      IF(ICOUNT.GT.0) THEN
        IF(ICOUNT.EQ.1) THEN
          ICOUNT=2
          PX(2)=PX(1)
          PY(2)=PY(1)
        END IF
        CALL GPL(ICOUNT,PX,PY)
        ICOUNT=0
      END IF
C
      UX= COS(.0174533*ANGLE)
      UY= SIN(.0174533*ANGLE)
      IF(NCHAR.GE.0) THEN
C       standard call - text:
        CALL GSCHH(HEIGHT)
        CALL GSCHUP(-UY,UX)
        DO 1 I=1,MAX0(NCHAR,1)
          CALL GTX(STARTX+X,STARTY+Y,TEXT(I:I))
          X=X+UX*HEIGHT
          Y=Y+UY*HEIGHT
    1   CONTINUE
      ELSE
C       Special call - centred symbol:
*       CALL GSMKSC(HEIGHT/'NOMINAL MARKER SIZE')
        CALL GSMK(ICHAR(TEXT(1:1)))
        PX(1)=STARTX+X
        PY(1)=STARTY+Y
        CALL GPM(1,PX,PY)
      END IF
      OLDX=X
      OLDY=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 Subroutines and external functions required:
      EXTERNAL SYMBOL
C     SYMBOL..This file.
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