-+-+-+-+-+-+-+-+ START OF PART 166 -+-+-+-+-+-+-+-+
X      INTEGER IP, IT, IS
X*
X*  ALGORITHM
X*  ---------
X*     The integer is assumed to be of 31 bits significance. It
X*     is packed 7 bits at a time into STR - least significant part first.
X*     Only 3 bits of the last character are used: 31-7*4 =3. This
X*     Leaves the 4th bit (8=2**3) to be used for the sign.
X*
X*  COMMENT
X*  -------
X*     This routine is only used by OPREC. Other packing
X*     routines are used elsewhere.
X*
X*---------------------------------------------------------------------
X*  Detach the sign
X      IF (N.LT.0) THEN
X        IP = -N
X        IS = 8
X      ELSE
X        IP = N
X        IS = 0
X      ENDIF
X*  Pull the integer apart - least significant part first
X      IT = IP
X      IP = IT / 128
X      STR(1) = CHAR(IT-IP*128)
X      IT = IP
X      IP = IT / 128
X      STR(2) = CHAR(IT-IP*128)
X      IT = IP
X      IP = IT / 128
X      STR(3) = CHAR(IT-IP*128)
X      IT = IP
X      IP = IT / 128
X      STR(4) = CHAR(IT-IP*128)
X      STR(5) = CHAR(IP+IS)
X      END
$ CALL UNPACK [.FORTRAN.SOURCE.BINDING]PKPREI.FOR;1 2034262915
$ create 'f'
X      SUBROUTINE PKUREI ( STR, N )
X*
X* (C) COPYRIGHT ICL & SERC  1987
X*
X*---------------------------------------------------------------------
X*
X*  RUTHERFORD / ICL GKS SYSTEM
X*
X*  Type of routine:    Utility
X*  Author:             CJC
X*
X*  PURPOSE OF THE ROUTINE
X*  ----------------------
X*     Unpack a string back into an integer for the data record utility
X*     GUREC. This is the inverse of GKPREI.
X*
X*  MAINTENANCE LOG
X*  ---------------
X*     22/01/87  CJC   IS conversion. GUREC rewritten to IS specification
X*                        - required an unpack utility
X*     10/03/87  CJC  Stabilisation of new version.
X*
X*      include '`5B-.include`5DCHECK.INC'
X*
X*  EXTERNAL FUNCTION DEFINITION
X*  ----------------------------
X      INTEGER ICHAR
X*
X*  ARGUMENTS
X*  ---------
X*     INP   STR    The string to be upacked
X*     OUT   N      The integer to return it in
X      CHARACTER STR(5)
X      INTEGER N
X*
X*  COMMENT
X*  -------
X*     This routine is only used by GUREC.
X*
X*---------------------------------------------------------------------
X      N = (((MOD(ICHAR(STR(5)),8)*128 + ICHAR(STR(4)))*128
X     :     + ICHAR(STR(3)))*128 + ICHAR(STR(2)))*128 + ICHAR(STR(1))
X      IF ( ICHAR(STR(5)).GE.8 ) N = -N
X      END
X
$ CALL UNPACK [.FORTRAN.SOURCE.BINDING]PKUREI.FOR;1 1766006093
$ create 'f'
X      SUBROUTINE PPREC(IL, IA, IRL, RA, ISL, LSTR, STR, MLDR, IER, LDR,
X     :                DATREC)
X*
X* (C) COPYRIGHT ICL & SERC  1984
X*
X`20
X*---------------------------------------------------------------------
X*
X*  RUTHERFORD / ICL GKS SYSTEM
X*
X*  Type of routine:    Front end
X*  Author:             CJW
X*
X
X*
X*  PURPOSE OF THE ROUTINE
X*  ----------------------
X*   Packs a data record.
X*
X*  MAINTENANCE LOG
X*  ---------------
X*     10/05/83  CJW  Original version stabilized
X*     27/06/83  CJW  Implement revised error handling precedure
X*                    (No change required)
X*     28/09/83  AS   Change subroutine name
X*     21/04/86  RMK  Changed use of Fortran ICHAR to GKS GKNA1 (S103).
X*     23/01/87  CJC  IS conversion. Complete rewrite to IS spec.
X*     10/03/87  CJC  Stabilisation of new version.
X*     23/03/87  RMK  Re-ordered declarations of IA and IL (S247).
X*
X*  ARGUMENTS
X*  ---------
X*     INP   IL     Number of integer entries
X*     INP   IA     Array of integer entries
X*     INP   IRL    Number of real entries
X*     INP   RA     Array of real entries
X*     INP   ISL    Number of character string entries
X*     INP   LSTR   Array of lengths - one for each character string
X*                  entry
X*     INP   STR    Array of character string entries
X*     INP   MLDR   Dimension of data record array
X*     OUT   IER    Error indicator
X*     OUT   LDR    Number of array elements used in DATREC
X*     OUT   DATREC Data record - declared internally *1 for convenience
X*
X      INTEGER IL, IA(*), IRL, ISL, LSTR(*), MLDR, IER, LDR
X      REAL RA(*)
X      CHARACTER STR(*)*(*), DATREC(80*MLDR)*1
X*
X*  LOCALS
X*  ------
X*     I, J   Loop indices
X*     ICH    Character index
X*     NCH    Number of characters available
X*     REA    A real - equivalenced to INTG
X*     INTG   An integer used for packing of reals
X*
X      REAL REA
X      INTEGER I, ICH, INTG, J, NCH
X      EQUIVALENCE (INTG, REA)
X*
X*  COMMENTS
X*  --------
X*     The routine makes assumptions about the sizes of variables. This
X*     version converts a real into an integer by EQUIVALENCE. It also
X*     assumes that integers 0-127 can be put in a character (see PKPREI)
X*
X*                       SYSTEM DEPENDENT
X*
X*---------------------------------------------------------------------
X`20
X`20
X*     Number of characters available
X      NCH = MLDR*80
X      ICH = 1
X*
X*     Count of integers followed by the integers themselves
X`20
X      IF(NCH.LT.ICH+4+MAX(0,IL)*5)GOTO 90
X      CALL PKPREI(IL,DATREC(ICH))
X      ICH = ICH+5
X      DO 10 I = 1, IL
X        CALL PKPREI(IA(I),DATREC(ICH))
X        ICH = ICH+5
X   10 CONTINUE
X*
X*     Count of reals followed by reals themselves.
X*     NOTE: use of equivalence between integers and reals - messy
X`20
X      IF(NCH.LT.ICH+4+MAX(0,IRL)*5)GOTO 90
X      CALL PKPREI(IRL,DATREC(ICH))
X      ICH = ICH+5
X      DO 20 I = 1, IRL
X        REA = RA(I)
X        CALL PKPREI(INTG,DATREC(ICH))
X        ICH = ICH+5
X   20 CONTINUE
X*
X*     Count of character strings followed by length of each string and
X*     the string itself
X`20
X      IF(NCH.LT.ICH+4)GOTO 90
X      CALL PKPREI(ISL,DATREC(ICH))
X      ICH = ICH+5
X`20
X      DO 40 I = 1, ISL
X        IF(NCH.LT.ICH+4+MAX(0,LSTR(I)))GOTO 90
X        CALL PKPREI(LSTR(I),DATREC(ICH))
X        ICH = ICH+5
X`20
X        DO 30 J = 1, LSTR(I)
X          DATREC(ICH) = STR(I)(J:J)
X          ICH = ICH+1
X   30   CONTINUE
X`20
X   40 CONTINUE
X*
X*     Calculate the number of 80 character array elements used - ICH
X*     points to an unused element so ICH=81 maps onto LDR=1
X`20
X      LDR = (ICH+78)/80
X      IER = 0
X      GOTO 99
X`20
X*     Too little room in the data record for the data
X`20
X   90 IER = 2001
X`20
X   99 RETURN
X      END
X`20
$ CALL UNPACK [.FORTRAN.SOURCE.BINDING]PPREC.FOR;1 958420910
$ create 'f'
X      SUBROUTINE PUREC(LDR, DATREC, IDL, IDRL, IDSL, IER, IL, IA, IRL,
X     :                  RA, ISL, LSTR, STR)
X*
X* (C) COPYRIGHT ICL & SERC  1984
X*
X`20
X*---------------------------------------------------------------------
X*
X*  RUTHERFORD / ICL GKS SYSTEM
X*
X*  Type of routine:    Front end
X*  Author:             CJW
X*
X*      include '`5B-.include`5DCHECK.INC'
X*
X*  PURPOSE OF THE ROUTINE
X*  ----------------------
X*   Unpacks a data record.
X*
X*  MAINTENANCE LOG
X*  ---------------
X*     10/05/83  CJW  Original version stabilized
X*     27/06/83  CJW  Implement revised error handling precedure
X*                    (No change)
X*     28/09/83  AS   Change subroutine name
X*     21/04/86  RMK  Changed use of Fortran CHAR to GKS GKAN1 (S103).
X*     23/01/87  CJC  IS conversion. Complete rewrite to IS spec.
X*     23/03/87  RMK  Re-ordered declarations of IA and IDL (S247).
X*
X*  ARGUMENTS
X*  ---------
X*     INP   LDR    Number of array elements in DATREC
X*     INP   DATREC Data record - declared internally *1 for convenience
X*     INP   IDL    Dimension of integer array
X*     INP   IDRL   Dimension of real array
X*     INP   IDSL   Dimension of character array
X*     OUT   IER    Error indicator
X*     OUT   IL     Number of integer entries
X*     OUT   IA     Array containing integer entries
X*     OUT   IRL    Number of real entries
X*     OUT   RA     Array containing real entries
X*     OUT   ISL    Number of character string entries
X*     OUT   LSTR   Length of each character string entry
X*     OUT   STR    Array containing character string entries
X*
X      INTEGER IDL, IA(*), IDRL, IDSL, IER, IL, IRL, ISL, J,
X     : LDR, LSTR(*)
X      REAL RA(*)
X      CHARACTER DATREC(80*LDR)*1, STR(*)*(*)
X*
X*  LOCALS
X*  ------
X*     I, J   Loop indices
X*     ICH    Character index
X*     NCH    Number of integers required to store character string
X*     REA    A real - equivalenced to INTG
X*     INTG   An integer used for packing of reals
X*
X      REAL REA
X      INTEGER I, ICH, INTG, NCH
X      EQUIVALENCE (INTG, REA)
X*
X*  COMMENTS
X*  --------
X*     The routine makes assumptions about the sizes of variables. This
X*     version converts a real into an integer by EQUIVALENCE. It also
X*     assumes that integers 0-127 can be put in a character (see PKUREI)
X*
X*                       SYSTEM DEPENDENT
X*
X*---------------------------------------------------------------------
X`20
X`20
X`20
X*     Calculate number of characters that may be unpacked
X      NCH = LDR*80
X      ICH = 1
X`20
X*     Unpack the number of integers - check room - then unpack integers
X      IF(NCH.LT.ICH+4)GOTO 93
X      CALL PKUREI(DATREC(ICH),IL)
X      ICH = ICH+5
X`20
X      IF(IL.GT.IDL)GOTO 91
X      IF(NCH.LT.ICH+MAX(0,IL)*5-1)GOTO 93
X      DO 10 I = 1, IL
X        CALL PKUREI(DATREC(ICH),IA(I))
X        ICH = ICH+5
X  10  CONTINUE
X*
X*     Unpack the number of reals - check room - unpack the reals
X*     themselves using equivalence to transfer the real bit pattern from
X*     an integer to a real (INTG to REA)
X      IF(NCH.LT.ICH+4)GOTO 93
X      CALL PKUREI(DATREC(ICH),IRL)
X      ICH = ICH+5
X`20
X      IF(IRL.GT.IDRL)GOTO 91
X      IF(NCH.LT.ICH+MAX(0,IL)*5-1)GOTO 93
X      DO 20 I = 1, IRL
X        CALL PKUREI(DATREC(ICH),INTG)
X        ICH = ICH+5
X        RA(I) = REA
X   20 CONTINUE
X*
X*     Unpack the number of strings followed by each string length and
X*     the string
X      IF(NCH.LT.ICH+4)GOTO 93
X      CALL PKUREI(DATREC(ICH),ISL)
X      ICH = ICH+5
X      IF(ISL.GT.IDSL)GOTO 91
X      DO 40 I = 1, ISL
X        IF(NCH.LT.ICH+4)GOTO 93
X        CALL PKUREI(DATREC(ICH),LSTR(I))
X        ICH = ICH+5
X        IF(LSTR(I).GT.LEN(STR(1)))GOTO 91
X        IF(NCH.LT.ICH+LSTR(I)-1)GOTO 93
X*       Copy the string - one character at a time so that there is
X*       no problem on machines that only allow short strings.
X        DO 30 J = 1, LSTR(I)
X          STR(I)(J:J) = DATREC(ICH)
X          ICH = ICH+1
X   30   CONTINUE
X`20
X   40 CONTINUE
X`20
X      IER = 0
X      GOTO 99
X`20
X*     Output array too small
X   91 IER = 2001
X      GOTO 99
X`20
X*     Invalid packed string
X   93 IER = -2004
X`20
X   99 RETURN
X      END
$ CALL UNPACK [.FORTRAN.SOURCE.BINDING]PUREC.FOR;1 122135146
$ create 'f'
XC---------------------------------------------------------------------------
V`20
X
XC Program name: Colour naming scheme test program.
X
XC Author: Gareth Williams
X
XC Description:
X
XC Modification history : (Version), (Date), (Name), (Description).
X
XC 1.0, 18th February 1991, G. Williams, First Version.
X
XC---------------------------------------------------------------------------
V-
X
X       PROGRAM cnstest
X
X       implicit none
X
X       include '`5B`5Dvmsphigs77.for'
X       include '`5B`5Dvmsptk77.for'
X
XC     open PHIGS`20
X       print *,('Testing the colour naming scheme of the`20
X     : PHIGS Toolkit...')
X       print *,('Opening DEC PHIGS...')
X
X       call popph(0, 0)
X`20
XC     create the workstation type (either tool or canvas)`20
X             `20
XC     open the workstation`20
X      `20
X       call popwk(1, 0, 0)
X
X       call psdus(1, PWAITD, PNIVE)
X
X       call ptkf_inithashtables()
X       call ptkf_createhashtable('colourindex', 1, 256)
X        `20
X       call ptkf_setcolourrep(1, 'RED')
X
X       call ptkf_drawcolourtable(1, 1, 1) `20
X       call ppost(1, 1, 0.0)
X
X       call prst(1, PALWAY)
X        `20
X       call options()
X        `20
X       print *,('Closing PHIGS...')
X       call pclwk(1)
X       call pclph()
X
X       STOP
X       END
X
XC--------------------------------------------------------------------------
X     `20
X       SUBROUTINE outputcolourvalues(inum, colourname, rgb)
X       INTEGER inum
X       CHARACTER*(*) colourname
X       REAL rgb(3)
X       REAL hsv(3), hsl(3)
X
X       print *, inum, ') RGB value of ', colourname, ' is ',
X     : rgb(1), rgb(2), rgb(3)
X       call ptkf_rgbtohsv(rgb, hsv)
X       print *, inum, ') HSV value of ', colourname, ' is ',`20
X     : hsv(1), hsv(2), hsv(3)`20
X       call ptkf_rgbtohsl(rgb, hsl)
X       print *, inum, ') HSL value of ', colourname, ' is ',`20
X     : hsl(1), hsl(2), hsl(3)`20
X
X       RETURN
X       END
X     `20
XC--------------------------------------------------------------------------
X     `20
X       SUBROUTINE options()
X       CHARACTER*50 colourname
X       INTEGER lencolourname
X       LOGICAL cnsquit
X       REAL echoarea(4)
X       REAL rgb(3)
X       REAL devx, devy
X
X       include '`5B`5Dvmsphigs77.for'
X
X       cnsquit = .FALSE.
X       call ptkf_inqmaxdevicecoords(1, devx, devy)
X       call ptkf_limit(0.0, 0.5 * devx, 0.0, 0.05 * devy, echoarea)
X 10    call ptkf_readstring(1, 'white', 'Input colourname (white) >',
X     : echoarea, 50 , colourname, lencolourname)
X       if (colourname(1:lencolourname) .eq. 'quit') then
X         cnsquit = .TRUE.
X       else
X         print *,('Testing ptkf_cnstorgb()...')
X         call ptkf_cnstorgb(colourname, rgb)
X         call pscr(1, 1, rgb(1), rgb(2), rgb(3))
X         call pemst(1)
X         print *,('Testing ptkf_drawcolourtable()...')
X         call ptkf_drawcolourtable(1, 1, 1)     `20
X         call outputcolourvalues(1, colourname, rgb)
X       endif
X
X       call prst(1, PALWAY)
X
X       if (cnsquit .eq. .FALSE.) then
X         goto 10
X       endif
X
X       RETURN
X       END
X
XC--------------------------------------------------------------------------
X
XC end of cnstest.f
$ CALL UNPACK [.FORTRAN.SOURCE.DEMO]CNSTEST.FOR;2 1097350574
$ create 'f'
XC---------------------------------------------------------------------------
V`20
X
XC Program name: Menus test program.
X
XC Author: Gareth Williams
X
XC Description:
X
XC Modification history : (Version), (Date), (Name), (Description).
X
+-+-+-+-+-+-+-+-  END  OF PART 166 +-+-+-+-+-+-+-+-