 
c PSLIB - a library of subroutines to generate postscript and idraw
c graphics primitives.
 
c Please do not distribute any part of this code.
 
c Copyright (c) 1990 by James A. D. Connolly, Institute for Mineralogy and
c Petrography, Swiss Federal Insitute of Technology, CH-8092 Zurich,
c SWITZERLAND. All rights reserved.
 
c----------------------------------------------------------------
      subroutine pselip (xor,yor,dx,dy,rline,iwidth,ifill)
 
c pselip - subroutine to generate ellipse primitives.
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1030)
 
      call psolin (rline,iwidth)
      call psoclr
      call psofil (ifill)
      call psotrn
 
      call psscpt (xor,yor,ixor,iyor)
      ix = ifix(dx * xscale)
      iy = ifix(dy * yscale)
 
      write (nps,1020) ixor,iyor,ix,iy
 
1020  format ('%I',/,4(i7,1x),' Elli',/,'End',/)
1030  format (/,'Begin %I Elli')
      end
c----------------------------------------------------------------
      subroutine psbspl (x,y,npts,rline,iwidth,ifill)
 
c psbspl - subroutine to generate open bsplines.
 
      real x(npts),y(npts)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1030)
 
      call psolin (rline,iwidth)
      call psoclr
      call psofil (ifill)
      call psotrn
      call psopts (x,y,npts)
 
      write (nps,1020) npts
 
1020  format (i5,' BSpl',/,'End',/)
1030  format (/,'Begin %I BSpl')
      end
c----------------------------------------------------------------
      subroutine psrpgn (x1,y1,rx,ry,npts,rline,iwidth,ifill)
 
c psrpgn - subroutine to generate closed polygons, rel. coordinates.
 
      real x(1000),y(1000),rx(npts),ry(npts)
 
      jpts = npts + 1
 
      if (npts.gt.999) then
         write (*,*) 'too many points in psrpgn'
         stop
      end if
 
      x(1) = x1
      y(1) = y1
 
      do 1 i = 2, jpts
         x(i) = x(i-1) + rx(i-1)
1        y(i) = y(i-1) + ry(i-1)
 
 
      call pspygn (x,y,jpts,rline,iwidth,ifill)
 
      end
c----------------------------------------------------------------
      subroutine pspygr (x,y,npts,rline,iwidth,rfill)
 
c pspygr - subroutine to generate closed polygons, abs. coordinates.
c pspygr - with gray scale fill.
 
      real x(npts),y(npts)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1030)
 
      call psolin (rline,iwidth)
      call psoclr
      call psrfil (rfill)
      call psotrn
      call psopts (x,y,npts)
 
      write (nps,1020) npts
 
1020  format (i5,' Poly',/,'End',/)
1030  format (/,'Begin %I Poly')
      end

c----------------------------------------------------------------
      subroutine pspygn (x,y,npts,rline,iwidth,ifill)
 
c pspygn - subroutine to generate closed polygons, abs. coordinates.
 
      real x(npts),y(npts)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1030)
 
      call psolin (rline,iwidth)
      call psoclr
      call psofil (ifill)
      call psotrn
      call psopts (x,y,npts)
 
      write (nps,1020) npts
 
1020  format (i5,' Poly',/,'End',/)
1030  format (/,'Begin %I Poly')
      end
c----------------------------------------------------------------
      subroutine pspyln (x,y,npts,rline,iwidth,ifill)
 
c pspyln - subroutine to generate open polylines.
 
      real x(npts),y(npts)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1030)
 
      call psolin (rline,iwidth)
      call psoclr
      call psofil (ifill)
      call psotrn
      call psopts (x,y,npts)
 
      write (nps,1020) npts
 
1020  format (i5,' MLine',/,'End',/)
1030  format (/,'Begin %I MLine')
      end
c----------------------------------------------------------------
      subroutine pscspl (x,y,npts,rline,iwidth,ifill)
 
c pscspl - subroutine to generate closed bsplines.
 
      real x(npts),y(npts)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1030)
 
      call psolin (rline,iwidth)
      call psoclr
      call psofil (ifill)
      call psotrn
      call psopts (x,y,npts)
 
      write (nps,1020) npts
 
1020  format (i5,' CBSpl',/,'End',/)
1030  format (/,'Begin %I CBSpl')
      end
c----------------------------------------------------------------
      subroutine psopts (x,y,npts)
 
c psopts - subroutine to output points.
 
      real x(npts),y(npts)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,*) '%I ',npts
      write (nps,1010) ( ifix((x(i) - xmn) * xscale),
     *                   ifix((y(i) - ymn) * yscale),
     *                   i = 1, npts)
 
1010  format (10(i7,1x))
 
      end
c----------------------------------------------------------------
      subroutine psscpt (x,y,ix,iy)
 
c psscpt - subroutine to scale and fix real coordinates.
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      ix = ifix((x - xmn) * xscale)
      iy = ifix((y - ymn) * yscale)
 
      end
c----------------------------------------------------------------
      subroutine psstrn (xs,ys,xt,yt,theta)
 
c psstrn - subroutine to set transformation matrix.

c                                 RST transformation, theta is
c                                 the angle (degrees)
C                                 counterclockwise
c
      common/ trans /a,b,c,d,xxt,yyt

      rad = theta*0.01745329251994

      c0 = cos (rad)
      s0 = sin (rad)
c                                 set lower limit for rotation
c                                 to 0.02 degree to avoid overflow
c                                 errors in adobe and coreldraw
      if (abs(c0).lt.3.5e-4) c0 = 0.
      if (abs(s0).lt.3.5e-4) s0 = 0.
 
      a = xs * c0
      b = ys * s0
      c = -xs * s0
      d = ys * c0
 
      xxt = xt
      yyt = yt
 
      end
c----------------------------------------------------------------
      subroutine psssc1 (ymin,ymax,xmin)
 
c psssc1 - subroutine to set scaling by y axis length
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      ymn = ymin
      xmn = xmin
      yscale = 3000./(ymax-ymin)
      xscale = yscale
 
      end
c----------------------------------------------------------------
      subroutine psssc2 (xmin,xmax,ymin,ymax)
 
c psssc2 - subroutine to set scaling of axes independently
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      ymn = ymin
      xmn = xmin
      yscale = 3000./(ymax-ymin)
      xscale = 3000./(xmax-xmin)
 
      end
c----------------------------------------------------------------
      subroutine pssscm (xfac, yfac)
 
c pssscm - subroutine to modify scaling
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      yscale = yscale * yfac
      xscale = xscale * xfac
 
      end
c----------------------------------------------------------------
      subroutine psotrn
 
c psotrn - subroutine to output transformation matrix.
 
      common/ trans /a,b,c,d,xt,yt
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1000) a,b,c,d,xt,yt
 
1000  format ('%I t',/,'[',6(g9.3,1x),'] concat')
 
      end
c----------------------------------------------------------------
      subroutine psoclr
 
c psoclr - subroutine to output color choice.
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1000)
 
1000  format ('%I cfg Black',/,
     *        '0 0 0 SetCFg',/,
     *        '%I cbg White',/,
     *        '1 1 1 SetCBg')
 
      end
c----------------------------------------------------------------
      subroutine psolin (rline,iwidth)
 
c psolin - subroutine to ouput line header.
 
c iwidth - integer width of line in points (i think).
c rline  - real line style indicator:
c
c      0 - no line
c      1 - solid line
c      2 - short dashed line
c      3 - uneven dashed line
c      4 - very sparse dotted line
c      5 - long even dashed line
c      6 - dashed line
c      7 - very short dashed line
c      8 - sparse dotted
c      9 - heavily dotted
c     10 - ultra sparse
c
c  for rline gt 9.0 relies on the idraw to generate a
c  line pattern from the value of rline which when converted
c  to hexadecimal gives the bit pattern for the line.
c
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      character plines(10)*28
 
      integer ilines(10)
 
      save ilines, plines
 
      data ilines/ 65535, 61680, 65080, 32896, 65520,
     *             65280, 52428, 34952, 43690, 32768/
 
      data plines/' 0 0 [] 0                 ',
     *            ' 0 0 [4 4 4 4] 17         ',
     *            ' 0 0 [7 3 3 3] 17         ',
     *            ' 0 0 [1 7 1 7] 17         ',
     *            ' 0 0 [12 4] 17            ',
     *            ' 0 0 [8 8] 17             ',
     *            ' 0 0 [2 2 2 2 2 2 2 2] 17 ',
     *            ' 0 0 [1 3 1 3 1 3 1 3] 17 ',
     *            ' 0 0 [1] 0                ',
     *            ' 0 0 [1 15] 17            '/
 
      istyl = ifix(rline)
 
      if (istyl.eq.0) then
 
         write (nps,1000)
 
      else if (istyl.gt.0.and.istyl.lt.11) then
 
         write (nps,1020) ilines(istyl),iwidth,plines(istyl)
 
      else
 
          write (nps,1010) istyl, iwidth
 
      end if
 
1000  format ('none SetB %I b n')
1010  format ('%I b ',i5,/,i2,' 0 0 [] 0 SetB')
1020  format ('%I b ',i5,/,i2,a28,'SetB')
 
      end
c----------------------------------------------------------------
      subroutine psrfil (rfill)
 
c psrfil - subroutine to output gray scale fill 
 
      common/ scales /xscale,yscale,xmn,ymn,nps

      write (nps,1010) rfill
 
1010  format ('%I p',/,f6.4,' SetP')
 
      end

c----------------------------------------------------------------
      subroutine psofil (ifill)
 
c psofil - subroutine to output fill type
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      character*30 fill(15)
 
      save fill
c
c                               first seven fills vary in intensity
c                               from white to black
      data fill/'1','0.95','0.85','0.75','0.5','0.25','0',
c                               next 8 fills are patterned
c
     *          '< 11 22 44 88 11 22 44 88 > -1',
     *          '< 88 44 22 11 88 44 22 11 > -1',
     *          '< ff 00 00 00 ff 00 00 00 > -1',
     *          '< 88 88 88 88 88 88 88 88 > -1',
     *          '< ff 88 88 88 ff 88 88 88 > -1',
     *          '< 88 55 22 55 88 55 22 55 > -1',
     *          '< cc cc 33 33 cc cc 33 33 > -1',
     *          '< 77 bb ee dd 77 bb ee dd > -1'/
 
      if (ifill.eq.0) then
          write (nps,1000) 
      else if (ifill.le.15) then
         write (nps,1010) fill(ifill)
      else
         write (*,*) 'invalid fill choice'
      end if
 
1000  format ('none SetP %I p n')
1010  format ('%I p',/,a30,' SetP')
 
      end
 
c----------------------------------------------------------------
      subroutine psclos
 
c psclos subroutine to output epilogue and close LUN nps.
 
      character*1 record(80)
 
      common/ scales /xscale,yscale,xmn,ymn,nps
c                                     copy epilog file
      open (70,file='epi.ps',err=75,status='old')
      goto 74
75    write (*,*) '**ERROR** no epilog file epi.ps'
      goto 99
74    read (70,1000,end=76) record
      call pschct (nchar,80,record)
      write (nps,1000) (record(i), i = 1, nchar)
      goto 74
 
76    close (70)
 
99    close (nps)
 
1000  format (80a1)
 
      end
c----------------------------------------------------------------
      subroutine psopen (fname,ier)
 
c psopen - subroutine to read/write prologue and open LUN nps
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      character fname*80, record(80)*1
 
      nps = 60
 
      read (fname,1000) (record(i), i=1,80)
 
      ict = 0
      ier = ict
 
      call pschct (nchar,80,record)
 
      if (nchar.gt.77) nchar = 77
 
      record(nchar) = '.'
      record(nchar+1) = 'p'
      record(nchar+2) = 's'
 
      write (fname,1000) (record(i), i = 1, nchar + 2)
 
      write (*,1010) fname
 
      open (nps,file=fname,status='unknown')
c                                     copy prolog
      open (70,file='pro.ps',err=71,status='old')
      goto 72
71    write (*,*) '**ERROR** no prolog file pro.ps'
      ier = 1
      goto 99
72    read (70,1000,end=73) record
c                                   don't ask me why, but its
c                                   necessary to trim out the
c                                   blanks
      call pschct (nchar,80,record)
 
      write (nps,1000) (record(i), i = 1, nchar)
      goto 72
 
73    close (70)
 
1000  format (80a1)
1010  format (/,' PostScript will be written to file: ',a14,/)
 
99    end
c----------------------------------------------------------------
      subroutine pschct (nchar,ict,record)
 
c pschct - subroutine to count to first non-blank character.
 
      character*1 record(*)
 
      nchar = 1
 
      do 1 i = 2, ict
         if ((record(i-1).eq.' ').and.(record(i).eq.' ')) goto 99
1        nchar = nchar + 1
 
99    end
c----------------------------------------------------------------
      subroutine psrect (x1,x2,y1,y2,rline,iwidth,ifill)
 
c psrect - subroutine to output a rectangle.
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      real x(4),y(4)
 
      x(1) = x1
      x(2) = x1
      x(3) = x2
      x(4) = x2
      y(1) = y1
      y(2) = y2
      y(3) = y2
      y(4) = y1
 
      call pspygn (x,y,4,rline,iwidth,ifill)
 
      end
c------------------------------------------------------------------
      subroutine psline (x1,y1,x2,y2,rline,iwidth)
 
c psline - subroutine to output a line (absolute).
 
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      write (nps,1000)
 
      call psolin (rline,iwidth)
      call psoclr
 
      write (nps,1010)
 
      call psotrn
 
      ix1 = ifix ((x1-xmn) * xscale)
      ix2 = ifix ((x2-xmn) * xscale)
      iy1 = ifix ((y1-ymn) * yscale)
      iy2 = ifix ((y2-ymn) * yscale)
 
      write (nps,1020) ix1,iy1,ix2,iy2
 
1000  format ('Begin %I Line')
1010  format ('%I p',/,'0 SetP')
1020  format ('%I',/,4(I6,1x),' Line',/,'End',/)
 
      end
c------------------------------------------------------------------
      subroutine psmove (x1,y1)
 
c subroutine to make an absolute move.
 
      common/ posit /x,y
      x = x1
      y = y1
      end
c------------------------------------------------------------------
      subroutine psrmov (dx,dy)
 
c subroutine to make a relative move.
 
      common/ posit /x,y
      x = x + dx
      y = y + dy
      end
c------------------------------------------------------------------
      subroutine psrlin (dx,dy,rline,iwidth)
 
c psrlin - subroutine to draw a relative line.
 
      common/ posit /x,y
 
      call psline (x,y,x+dx,y+dy,rline,iwidth)
 
      x = x + dx
      y = y + dy
      end
c------------------------------------------------------------------
      subroutine pswtod (x1,y1,x2,y2)
 
c pswtod - subroutine to do something i can't remember
 
      common/ trans /a,b,c,d,xt,yt
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      x0 = ((x1-xmn) * xscale)
      y0 = ((y1-ymn) * yscale)
 
      x2 = x0 * a + y0 * c + xt
      y2 = x0 * b + y0 * d + yt
 
      end
c-------------------------------------------------------------------
      subroutine pssctr (ifont,xs,ys,theta)
 
c pssctr - subroutine to set character rotation-scale transformation
c          to be concatenated with the transformation set by psstrn
 
      common / chars /a,b,c,d,jfont
 
      jfont = ifont

      rad = theta*0.01745329251994
 
      c0 = cos (rad)
      s0 = sin (rad)

      if (abs(c0).lt.3.5e-4) c0 = 0.
      if (abs(s0).lt.3.5e-4) s0 = 0.

      a = xs * c0
      b = ys * s0
      c = -xs * s0
      d = ys * c0
 
      end
c-------------------------------------------------------------------
      subroutine pstext (x,y,text,jchar)
 
c pstext - subroutine to output text strings.
 
c     x, y - data coordinates of the label
c     text - character string to be output
c     jchar - length of character string, 0 if unknown.
 
      character*(*) text
 
      character*1 itsy(400),fonts(13)*33,ifonts(13)*33,
     *            bitsy(400)
 
      common/ trans /a,b,c,d,xt,yt
      common/ chars /ac,bc,cc,dc,ifont
      common/ scales /xscale,yscale,xmn,ymn,nps
 
      save fonts, ifonts
 
      data fonts/'/Times-Italic 14 SetF',
     *           '/Times-Bold 14 SetF',
     *           '/Times-Roman 14 SetF',
     *           '/Times-Roman 12 SetF',
     *           '/Helvetica-Oblique 14 SetF',
     *           '/Helvetica-Bold 14 SetF',
     *           '/Helvetica 14 SetF',
     *           '/Helvetica 12 SetF',
     *           '/Courier-Bold 12 SetF',
     *           '/Courier 10 SetF',
     *           '/Courier 8 SetF',
     *           '/Symbol 12 SetF',
     *           '/Symbol 14 SetF'/
 
      data ifonts/'%I f *-times-medium-i-*-140-*',
     *            '%I f *-times-bold-r-*-140-*',
     *            '%I f *-times-medium-r-*-140-*',
     *            '%I f *-times-medium-r-*-120-*',
     *            '%I f *-helvetica-medium-o-*-140-*',
     *            '%I f *-helvetica-bold-r-*-140-*',
     *            '%I f *-helvetica-medium-r-*-140-*',
     *            '%I f *-helvetica-medium-r-*-120-*',
     *            '%I f *-courier-bold-r-*-120-*',
     *            '%I f *-courier-medium-r-*-100-*',
     *            '%I f *-courier-medium-r-*-80-*',
     *            '%I f Symbol-12',
     *            '%I f Symbol-14'/
 
      if (jchar.eq.0) then
         nchar = len(text)
      else
         nchar = jchar
      end if
 
      if (nchar.gt.398) nchar = 398
 
      read (text,1020) (bitsy(i),i=2,nchar+1)
c                                 scan for '(' or ')'
      ict = 1
      do 1 i = 2, nchar + 1
         if ((bitsy(i).eq.')').or.(bitsy(i).eq.'('))then
            ict = ict + 1
c                                 the double backslash
c                                 here is necessary for SUNS
c                                 because the first is read
c                                 as an escape character. On
c                                 convex this cause a compile
c                                 time warning, and on Mac and
c                                 IBM compilers there is no
c                                 warning.
            itsy(ict) = '\\'
            ict = ict + 1
            itsy(ict) = bitsy(i)
         else
            ict = ict + 1
            itsy(ict) = bitsy(i)
         end if
1     continue
 
      if (ict.gt.399) ict = 399
 
      itsy(1) = '('
      itsy(ict+1) = ')'
 
      x0 = (x-xmn) * xscale
      y0 = (y-ymn) * yscale
 
      xtr = x0 * a + y0 * c + xt
      ytr = x0 * b + y0 * d + yt
 
      write (nps,1010) ifonts(ifont),fonts(ifont),
     *                 ac,bc,cc,dc,xtr,ytr
 
      write (nps,1020) (itsy(i),i=1,ict+1)
      write (nps,1030)
 
1010  format ('Begin %I Text',/,
     *        '%I cfg Black',/,'0 0 0 SetCFg',/,2(a33,/),
     *        '%I t',/,'[',6(g9.3,1x),'] concat',/,
     *        '%I',/,'[')
1020  format (400a1)
1030  format ('] Text',/,'End',/)
      end
c-------------------------------------------------------------------
      subroutine psublk (text,jchar)
 
c psublk - subroutine to remove double blanks from text
 
c     text - character string 
c     jchar - length of unblanked character string, 0 if unknown.
 
      character*(*) text
 
      character*1 itsy(255), bitsy(255) 
    
      if (jchar.eq.0) jchar = len(text)
 
      if (jchar.gt.255) jchar = 255
 
      read (text,1000) (bitsy(i), i = 1, jchar)
c                                 scan for double blanks:
      ict = 1
      itsy(1) = bitsy(1)

      do 10 i = 2, jchar
         if (bitsy(i-1).ne.' '.or.bitsy(i).ne.' ') then
            ict = ict + 1
            itsy(ict) = bitsy(i)
         end if 
10    continue

      jchar = ict

      write (text,1000) (itsy(i), i = 1, jchar)
 
1000  format (255a1)
      end
