C CALCOMP-GKS INTERFACE
C
C THIS FILE CONTAINS THE CALCOMP PLOTTING ROUTINES
C     PLOTS, PLOT, NEWPEN, SYMBOL AND 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     CARACTER*(*) 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 WORRKSTATION IS NOT ERASED BEFORE THE
C             USER'S CONFIRMATION.  THE IDENTIFIER OF THE INTERACTIVE
C             WORKSTATION MAY BE CHANGED ONLY BY MEANS OF EDITTING 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 PLOTING.  THE LIST OPEN WORKSTATIONS MAY BE
C             CHANGED THROUGH THE INTERACTIVE WORKSTATION BEFORE
C             STARTING EACH PLOT, OR BY MEANS OF EDITTING 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 EDITTING 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 SET ONLY BY MEANS OF EDITTING
C             THE CONFIGURATION FILE.
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 DECLARATION OF THE COMMON MEMORY STORAGE LOCATIONS:
      BLOCK DATA PLOTB
C     ------------------------------------------------------------------
      INTEGER MOPEN,MCOUNT
      PARAMETER (MOPEN=9)
      PARAMETER (MCOUNT=1024)
      INTEGER IUSER,IOPEN(MOPEN),NOPEN,KOLREP,KOLOR,ICOUNT
      REAL PX(MCOUNT),PY(MCOUNT),STARTX,STARTY,OLDX,OLDY
      COMMON/PLOTC/ IUSER,IOPEN,NOPEN,KOLREP,KOLOR,ICOUNT,
     *              PX,PY,STARTX,STARTY,OLDX,OLDY
C     ------------------------------------------------------------------
      SAVE /PLOTC/
      END
C
C     IUSER...IDENTIFIER OF THE INTERACTIVE WORKSTATION.
C     IOPEN...ARRAY CONTAINING THE IDENTIFIERS OF THE OPEN WORKSTATIONS.
C     NOPEN...NUMBER OF THE OPEN WORKSTATIONS.
C     KOLREP..FOR KOLREP.GT.1, COLOURS 2 TO KOLREP ARE PERIODICALLY
C             REPEATED.
C     ICOUNT..NUMBER OF STORED POLYLINE VERTICES.
C     PX,PY...ARRAYS TO STORE THE COORDINATES OF POLYLINE VERTICES.
C     STARTX,STARTY... ORIGIN OF CALCOMP COORDINATES IN WORLD
C             COORDINATES.
C     OLDX,OLDY... POINT REFERRED DURING THE PREVIOUS INVOCATION OF A
C             CALCOMP SUBROUTINE, IN CALCOMP COORDINATES.
C
C DATE: 1993, OCTOBER 23
C CODED BY LUDEK KLIMES
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/:
      INTEGER MOPEN,MCOUNT
      PARAMETER (MOPEN=9)
      PARAMETER (MCOUNT=1024)
      INTEGER IUSER,IOPEN(MOPEN),NOPEN,KOLREP,KOLOR,ICOUNT
      REAL PX(MCOUNT),PY(MCOUNT),STARTX,STARTY,OLDX,OLDY
      COMMON/PLOTC/ IUSER,IOPEN,NOPEN,KOLREP,KOLOR,ICOUNT,
     *              PX,PY,STARTX,STARTY,OLDX,OLDY
C
C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED:
      REAL RNUM
      EXTERNAL PLOTB,RNUM,NEWPEN,NUMBER
      EXTERNAL GOPKS,GOPWK,GACWK,GCLRWK,GDAWK,GCLWK,GSWKWN,GQOPWK,GQEWK
      EXTERNAL GQWKCA,GQWKCL,GQDSP,GSCR,GSTXCI,GTX,GINST,GRQST
C     PLOTB.. BLOCK DATA SUBROUTINE OF THIS FILE.
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: 1993, DECEMBER 18
C CODED BY LUDEK KLIMES
C
C-----------------------------------------------------------------------
C
C     AUXILIARY STORAGE LOCATIONS:

      CHARACTER*80 STR(1)
      INTEGER LUCFG,LUERR,IERR,LENGTH,IC1,IC2,I,J,K,N,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,AUX
C
C     STR...  TEMPORARY STRING STORAGE LOCATION.
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     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     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
        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
    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
          PAUSE ' CALCOMP: ERROR WHEN OPENING INTERACTIVE WORKSTATION'
          STOP
        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.67*YH
        Y=1.-YH
        CALL GSCR(IUSER,0,0.0,0.6,0.0)
        IC1=1
        IC2=5
        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.
                  ELSE
                    STR(1)='  '
                    AUX=AMAX1(XMAX/RX,YMAX/RY)
                    RX=RX*AUX
                    RY=RY*AUX
                  END IF
                  CALL NUMBER(X3,Y,HEIGHT,RX,0.,2)
                  CALL GTX(X4,Y,'*')
                  CALL NUMBER(X5,Y,HEIGHT,RY,0.,2)
                  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-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,
     *  'PRESS ''ENTER'' TO CONTINUE.')
        Y=Y-2.*YH
        CALL GTX(X1,Y,
     *  'AFTER PLOTTING, PRESS ''ENTER'' AGAIN TO CONTINUE.')
C
C     SETTING COORDINATE TRANSFORMATION:
      CALL GSVP(1,0.,XNDC,0.,YNDC)
      CALL GSWN(1,0.,XMAX,0.,YMAX)
      CALL GSELNT(1)

C       CHANGING CALCOMP PARAMETERS:
        CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY)
        CALL GINST(IUSER,IUSER,14,'YOUR ANSWER:  ',
     *        1,0.,RX,0.,RY,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,0.,RX,0.,RY,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,0.,RX,0.,RY,80,27,1,STR)
          CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1))
          YMAX=RNUM(STR(1),LENGTH)
        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'
        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(IUSER,1)
          CALL GSWKWN(IUSER,0.,XNDC,0.,YNDC)
C         DISPLAY 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
          CALL GSCR(IUSER, 0,0.00,0.00,0.00)
          CALL GSCR(IUSER, 1,1.00,1.00,1.00)
          CALL GSCR(IUSER, 2,1.00,0.00,0.00)
          CALL GSCR(IUSER, 3,0.00,0.90,0.00)
          CALL GSCR(IUSER, 4,0.00,0.00,1.00)
          CALL GSCR(IUSER, 5,1.00,0.90,0.00)
          CALL GSCR(IUSER, 6,0.00,0.80,0.90)
          CALL GSCR(IUSER, 7,0.90,0.00,0.90)
          CALL GSCR(IUSER, 8,0.90,0.63,0.50)
          CALL GSCR(IUSER, 9,0.63,0.63,0.63)
          CALL GSCR(IUSER,10,0.95,0.00,0.71)
          CALL GSCR(IUSER,11,0.71,0.85,0.00)
          CALL GSCR(IUSER,12,0.00,0.63,0.95)
          CALL GSCR(IUSER,13,0.95,0.63,0.00)
          CALL GSCR(IUSER,14,0.00,0.85,0.71)
          CALL GSCR(IUSER,15,0.71,0.00,0.95)
        ELSE
          CALL GOPWK(IOPEN(I),IOPEN(I),IOPEN(I))
          CALL GACWK(IOPEN(I))
          CALL GSWKWN(IOPEN(I),0.,XNDC,0.,YNDC)
        END IF
   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     CALCOMP PLOTTING INITIALISATION:
      ICOUNT=0
      STARTX=0.
      STARTY=0.
      OLDX=0.
      OLDY=0.
      KOLOR=0
      CALL NEWPEN(1)
      RETURN
      END
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
      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/:
      INTEGER MOPEN,MCOUNT
      PARAMETER (MOPEN=9)
      PARAMETER (MCOUNT=1024)
      INTEGER IUSER,IOPEN(MOPEN),NOPEN,KOLREP,KOLOR,ICOUNT
      REAL PX(MCOUNT),PY(MCOUNT),STARTX,STARTY,OLDX,OLDY
      COMMON/PLOTC/ IUSER,IOPEN,NOPEN,KOLREP,KOLOR,ICOUNT,
     *              PX,PY,STARTX,STARTY,OLDX,OLDY
C
C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED:
      EXTERNAL GDAWL,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
      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/:
      INTEGER MOPEN,MCOUNT
      PARAMETER (MOPEN=9)
      PARAMETER (MCOUNT=1024)
      INTEGER IUSER,IOPEN(MOPEN),NOPEN,KOLREP,KOLOR,ICOUNT
      REAL PX(MCOUNT),PY(MCOUNT),STARTX,STARTY,OLDX,OLDY
      COMMON/PLOTC/ IUSER,IOPEN,NOPEN,KOLREP,KOLOR,ICOUNT,
     *              PX,PY,STARTX,STARTY,OLDX,OLDY
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
      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/:
      INTEGER MOPEN,MCOUNT
      PARAMETER (MOPEN=9)
      PARAMETER (MCOUNT=1024)
      INTEGER IUSER,IOPEN(MOPEN),NOPEN,KOLREP,KOLOR,ICOUNT
      REAL PX(MCOUNT),PY(MCOUNT),STARTX,STARTY,OLDX,OLDY
      COMMON/PLOTC/ IUSER,IOPEN,NOPEN,KOLREP,KOLOR,ICOUNT,
     *              PX,PY,STARTX,STARTY,OLDX,OLDY
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: 1993, DECEMBER 18
C CODED BY LUDEK KLIMES
C
C-----------------------------------------------------------------------
C
C     AUXILIARY STORAGE LOCATIONS:
      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
      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
