C PROGRAM 'PSLAUE'
C ================
C
C OUTPUT LAUE PATTERN SIMULATIONS (FROM A LAUE .GE1 FILE) TO A
C COLOUR POSTCRIPT FILE
C
C
C====== Specification statements
C
      LOGICAL SPAT, NODAL
      CHARACTER*80 FILEGE
      CHARACTER*80 FILEPS
      CHARACTER*80 TEXT
      CHARACTER*80 TITLE(3)
      REAL DUMMY(17)
      REAL SPRAD
      REAL R(8), G(8), B(8)
      DATA R /0.60, 0.30, 0.30, 0.30, 0.68, 0.83, 1.00, 1.00/
      DATA G /0.70, 0.85, 0.86, 1.00, 0.86, 0.83, 0.80, 0.40/
      DATA B /1.00, 0.84, 0.65, 0.30, 0.30, 0.20, 0.40, 0.40/
      DATA SPDIAM /0.4/
C
C====== Initialisations
C
      IUN = 5
      ILP = 6
      LUNGE = 1
      LUNPS = 2
      CENTRX = 298.0
      CENTRY = 421.0
C
C====== Get File Names
C
100   WRITE (ILP, 1001)
      READ (IUN,1100) FILEGE
      IF (FILEGE.EQ.' ') STOP
      IFAIL = 1
      CALL CCPOPN (-LUNGE, FILEGE, 5, 4, 19, IFAIL)
      IF (IFAIL.LT.0) THEN
         WRITE (ILP, 2001)
         GO TO 100
      ENDIF
200   WRITE (ILP,1002)
      READ (IUN,1100) FILEPS
      IF (FILEPS.EQ.' ') GO TO 200
      IFAIL = 1
      CALL CCPOPN (-LUNPS, FILEPS, 1, 1, 0, IFAIL)
      IF (IFAIL.LT.0) THEN
         WRITE (ILP, 2001)
         GO TO 200
      ENDIF
C
C====== Get type of plot required
C
250   ITYPE = 1
      WRITE (ILP, 1003)
      CALL FFREAD (IUN, TEXT, 80, ILP, .FALSE.)
      IF (TEXT.NE.' ') THEN
         CALL IVALUE (ITYPE)
         IF (ITYPE.LT.1.OR.ITYPE.GT.6) THEN
            WRITE (ILP, 2002)
            GO TO 250
         ENDIF
      ENDIF
C
C====== Get lambda start/increment if required
C  
      IF (ITYPE.LE.4) THEN
         ALMIN = 0.25
         ALMAX = 2.5
         WRITE (ILP, 1004)
         CALL FFREAD (IUN, TEXT, 80, ILP, .FALSE.)
         IF (TEXT.NE.' ') THEN
            CALL FVALUE (ALMIN)
            CALL FVALUE (ALMAX)
            IF (ALMAX.EQ.0.0) ALMAX = 2.5
         ENDIF
      ENDIF
C
C====== Get spatials treatment type
C
300   ISTYPE = 1
      WRITE (ILP, 1005)
      CALL FFREAD (IUN, TEXT, 80, ILP, .FALSE.)
      IF (TEXT.NE.' ') THEN
         CALL IVALUE (ISTYPE)
         IF (ISTYPE.LT.1.OR.ISTYPE.GT.3) THEN
            WRITE (ILP, 2003)
            GO TO 300
         ENDIF
      ENDIF
C
C====== Get spot diameter for A4 plot
C
      WRITE (ILP,1006)
      CALL FFREAD (IUN, TEXT, 80, ILP, .FALSE.)
      IF (TEXT.NE.' ') CALL FVALUE (SPDIAM)
      SPRAD = (SPDIAM*72.0)/(2.0*25.4)
C
C====== Get annonation type
C
350   IANNOT = 1
      WRITE (ILP, 1007)
      CALL FFREAD (IUN, TEXT, 80, ILP, .FALSE.)
      IF (TEXT.NE.' ') THEN
         CALL IVALUE (IANNOT)
         IF (IANNOT.LT.1.OR.IANNOT.GT.3) THEN
            WRITE (ILP, 2004)
            GO TO 350
         ENDIF
      ENDIF
      IF (IANNOT.EQ.3) CENTRY = CENTRY + 100.0
C
C====== Get title lines if required
C
      IF (IANNOT.GT.1) THEN
         TITLE(1) = ' '
         TITLE(2) = ' '
         TITLE(3) = ' '
         WRITE (ILP, 1008)
         WRITE (ILP, 1009)
         READ (IUN, 1100) TITLE(1)
         WRITE (ILP, 1009)
         READ (IUN, 1100) TITLE(2)
         WRITE (ILP, 1009)
         READ (IUN, 1100) TITLE(3)
      ENDIF
C
C====== Get some details from .ge1 file header
C
      READ (LUNGE, REC=4) DUMMY, RAD
      SCPLOT = 250.0/RAD
      READ (LUNGE, REC=10) IPACK, NSPOT
      WRITE (ILP,1201) NSPOT
      NRCMAX = 10+NSPOT
C
C====== Write Postscript File Header and Colour Set-ups
C
      CALL PSHEAD (LUNPS, SPRAD)
      CALL PSCOLR (LUNPS, R, G, B)
      WRITE (LUNPS, 1501)
C
C====== Output Patterns to Postscript File
C====== ==================================
C
      IF (ITYPE.LE.4) THEN
C
C====== Colur coded by wavelength (Options 1 to 4)
C
         DO 520 I=1,8
            WRITE (LUNPS, 1502) I
            DO 500 IREC=11,NRCMAX
               CALL RDLREF(LUNGE,IREC,IH,IK,IL,X,Y,ALBDA,IMULT,
     +                     NODAL,SPAT)
               IF (ITYPE.EQ.2.AND.IMULT.GT.1) GO TO 500
               IF (ITYPE.EQ.3.AND.IMULT.GT.1) GO TO 500
               IF (ITYPE.EQ.4.AND.IMULT.LT.2) GO TO 500
               IF (ALBDA.LT.ALMIN.OR.ALBDA.GT.ALMAX) GO TO 500
               IF (IRANGE(ALBDA,ALMIN,ALMAX,8).NE.I) GO TO 500
               IF (ISTYPE.EQ.2.AND.SPAT) GO TO 500
               IF (ISTYPE.EQ.3.AND..NOT.SPAT) GO TO 500
               XOUT = CENTRX + SCPLOT*X
               YOUT = CENTRY + SCPLOT*Y
               IF (XOUT.LT.0.OR.XOUT.GT.592) GO TO 500
               IF (YOUT.LT.0.OR.YOUT.GT.842) GO TO 500
               WRITE (LUNPS, 1510) XOUT, YOUT
500         CONTINUE
520      CONTINUE
         IF (ITYPE.EQ.2) THEN
            WRITE (LUNPS,1501)
            DO 530 IREC=11,NRCMAX
               CALL RDLREF(LUNGE,IREC,IH,IK,IL,X,Y,ALBDA,IMULT,
     +                     NODAL,SPAT)
               IF (IMULT.EQ.1) GO TO 530
               IF (ALBDA.LT.ALMIN.OR.ALBDA.GT.ALMAX) GO TO 530
               IF (ISTYPE.EQ.2.AND.SPAT) GO TO 530
               IF (ISTYPE.EQ.3.AND..NOT.SPAT) GO TO 530
               XOUT = CENTRX + SCPLOT*X
               YOUT = CENTRY + SCPLOT*Y
               IF (XOUT.LT.0.OR.XOUT.GT.592) GO TO 530
               IF (YOUT.LT.0.OR.YOUT.GT.842) GO TO 530
               WRITE (LUNPS, 1510) XOUT, YOUT
530         CONTINUE
        ENDIF
C
C====== Nodals versus non-nodals
C
      ELSE IF (ITYPE.EQ.5) THEN
         WRITE (LUNPS, 1502) 2
         DO 540 IREC=11,NRCMAX
            CALL RDLREF(LUNGE,IREC,IH,IK,IL,X,Y,ALBDA,IMULT,
     +                  NODAL,SPAT)
            IF (NODAL) GO TO 540
            IF (ISTYPE.EQ.2.AND.SPAT) GO TO 540
            IF (ISTYPE.EQ.3.AND..NOT.SPAT) GO TO 540
            XOUT = CENTRX + SCPLOT*X
            YOUT = CENTRY + SCPLOT*Y
            IF (XOUT.LT.0.OR.XOUT.GT.592) GO TO 540
            IF (YOUT.LT.0.OR.YOUT.GT.842) GO TO 540
            WRITE (LUNPS, 1510) XOUT, YOUT
540      CONTINUE
         WRITE (LUNPS, 1502) 8
         DO 550 IREC=11,NRCMAX
            CALL RDLREF(LUNGE,IREC,IH,IK,IL,X,Y,ALBDA,IMULT,
     +                  NODAL,SPAT)
            IF (.NOT.NODAL) GO TO 550
            IF (ISTYPE.EQ.2.AND.SPAT) GO TO 550
            IF (ISTYPE.EQ.3.AND..NOT.SPAT) GO TO 550
            XOUT = CENTRX + SCPLOT*X
            YOUT = CENTRY + SCPLOT*Y
            IF (XOUT.LT.0.OR.XOUT.GT.592) GO TO 550
            IF (YOUT.LT.0.OR.YOUT.GT.842) GO TO 550
            WRITE (LUNPS, 1510) XOUT, YOUT
550      CONTINUE
C
C====== Colour coded by multiplicity
C
      ELSE IF (ITYPE.EQ.6) THEN
         DO 570 I=1,4
            WRITE (LUNPS, 1502) 2*I
            DO 560 IREC=11,NRCMAX
               CALL RDLREF(LUNGE,IREC,IH,IK,IL,X,Y,ALBDA,IMULT,
     +                     NODAL,SPAT)
               IF (I.LE.3.AND.IMULT.NE.I) GO TO 560
               IF (I.EQ.4.AND.IMULT.LE.3) GO TO 560
               IF (ISTYPE.EQ.2.AND.SPAT) GO TO 560
               IF (ISTYPE.EQ.3.AND..NOT.SPAT) GO TO 560
               XOUT = CENTRX + SCPLOT*X
               YOUT = CENTRY + SCPLOT*Y
               IF (XOUT.LT.0.OR.XOUT.GT.592) GO TO 560
               IF (YOUT.LT.0.OR.YOUT.GT.842) GO TO 560
               WRITE (LUNPS, 1510) XOUT, YOUT
560         CONTINUE
570      CONTINUE
      ENDIF
C
C====== Annotate as required
C
      CALL PSKEYS (LUNPS, IANNOT, ITYPE, ISTYPE, TITLE, ALMIN, ALMAX)
C
C====== Finish
C
      WRITE (LUNPS, 1600)
      CLOSE (LUNGE)
      CLOSE (LUNPS)
      STOP
C
C====== Format Statements
C
1001  FORMAT(' Name of .ge1 file (including extension): ',$)
1002  FORMAT(' Name of output postscript file: ',$)
1003  FORMAT(/,' Type of plot required :- ',/,
     *       ' Reflections colour coded by wavelength;',
     *       ' highest wavelength for multiples (1)',/,
     *       ' Reflections colour coded by wavelength; multiples',
     *       ' coded white (2)',/,
     *       ' Singles only; colour coded by wavelength (3)',/,
     *       ' Multiples only; colour coded by highest wavelength (4)',
     *       /,
     *       ' Plot of nodals versus non-nodals (5)',/,
     *       ' Plot colour coded by multiplicity (6)',/,
     *       ' [1]: ',$)
1004  FORMAT(/,' Minimum and maximum lambda values [0.25 2.5]: ',$)
1005  FORMAT(/,' Treatment of spatial overlaps :- ',/,
     *       ' Spatial overlaps included (1)',/,
     *       ' Spatial overlaps excluded (2)',/,
     *       ' Spatial overlaps only (3)',/,
     *       ' [1]: ',$)
1006  FORMAT(/,' Diameter, in mm, for plot spots (on A4 page) [0.4]: ',
     *       $)       
1007  FORMAT(/,' Annotation option :-',/,
     *       ' No annotation (1)',/,
     *       ' Print title (2)',/,
     *       ' Print title and key (3)',/,
     *       ' [1]: ',$)
1008  FORMAT(/,' Enter 1 to 3 title lines :-')
1009  FORMAT(' : ',$)
1100  FORMAT (A)
1201  FORMAT(/,'Number of spots in the .ge1 file =',I5)
1501  FORMAT('setwhite')
1502  FORMAT('color',I1)
1510  FORMAT(2F8.3,' spot')
1600  FORMAT('showpage')
C
2001  FORMAT(/, ' **Unable to open the file**')
2002  FORMAT(/, ' **Invalid option, must be 1-5**')
2003  FORMAT(/, ' **Invalid type, must be 1-3**')
2004  FORMAT(/, ' **Invalid type, must be 1-3**')
      END

C
C SUBROUTINE 'RDLREF'
C ===================
C
C READ A REFLECTION FROM A LAUE 'GE' FILE
C
      SUBROUTINE RDLREF(IUN,IREC,H,IK,IL,X,Y,ALBDA,IMULT,NODAL,SPAT)
C
C PARAMETERS
C
C         IUN (I)   UNIT NUMBER OF 'GE' FILE
C        IREC (I)   RECORD NUMBER OF REFLECTION
C          IH (O)   INDICES
C          IK (O)   "
C          IL (O)   "
C           X (O)   X COORDINATE ON THE FILM
C           Y (O)   Y COORDINATE ON THE FILM
C       ALBDA (O)   WAVELENGTH
C       IMULT (O)   MULTIPLICITY
C       NODAL (O)   =.TRUE. NODAL, =.FALSE. NOT A NODAL
C        SPAT (O)   =.TRUE SPATIAL OVERLAP, =.FALSE. NOT
C
C ***NOTE*** THIS SUBROUTINE CONTAINS NON-STANDARD FORTRAN 77 CODE
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      LOGICAL NODAL, SPAT
      BYTE IB(4)
      INTEGER*2 IBWORD
      INTEGER*2 INTB(6),ISIGB(6),INTP(6),ISIGP(6)
      EQUIVALENCE (III,IB(1))
C
C READ AND INTERPRET RECORD
C -------------------------
C                                                   
      READ(IUN,REC=IREC)X,Y,INTB,ISIGB,INTP,ISIGP,IFHKL,ALBDA
C
C SEPARATE FLAGS, H, K, L
C
      III=IFHKL
      IBWORD=IB(1)
C
C CHECK MULTIPLE RELECTION, SPATIAL OVERLAP FLAGS
C     
      IMULT = IAND(IBWORD,'001F'X)
      NODAL = .FALSE.
      IF (IAND(IBWORD,'0020'X).NE.0) NODAL=.TRUE.
      SPAT = .FALSE.
      IF (IAND(IBWORD,'0040'X).NE.0)  SPAT=.TRUE.
      IH=IB(2)
      IK=IB(3)
      IL=IB(4)
      RETURN
      END  
C
C FUNCTION 'IRANGE'
C =================
C                                   
C FIND A RANGE NUMBER
C
      FUNCTION IRANGE(X,XMIN,XMAX,NX)
C
C PARAMETERS
C
C           X (I)   THE VALUE FOR WHICH THE RANGE NO. IS TO BE FOUND
C        XMIN (I)   THE MINIMUM X VALUE
C        XMAX (I)   THE MAXIMUM X VALUE
C          NX (I)   THE NUMBER OR RANGES (FROM XMIN TO XMAX)
C
C  RETURNS  IRANGE = THE RANGE NUMBER
C
C CALCULATE THE RANGE NUMBER
C --------------------------
C
       IRANGE=1
       IF(XMAX.LE.XMIN)RETURN
       IRANGE=NX*(X-XMIN)/(XMAX-XMIN)+1
       IF(IRANGE.LT.1)IRANGE=1
       IF(IRANGE.GT.NX)IRANGE=NX
       RETURN
       END
C
C SUBROUTINE 'FFREAD'  ENTRIES: 'IVALUE' 'FVALUE' 'TEXLIM'
C ========================================================
C
C THIS SUBROUTINE ENABLES FREE FORMAT INPUT OF DATA. IT IS CALLED
C ONCE TO READ IN THE TEXT BUFFER  AND CALLED VIA AN ENTRY POINT
C FOR EACH INTEGER, FLOATING POINT OR TEXT FIELD IN TURN.
C
      SUBROUTINE FFREAD(IUN,LTEXT,LMAX,LLP,LSTOP)
C
C PARAMETERS
C
C       IUN (I)   UNIT NUMBER FOR READ (MAY BE SET TO ZERO IF THE TEXT
C                 TO BE INTERPRETED IS ALREADY IN THE ARRAY 'ITEXT')
C     LTEXT (I/O) CHARACTER ARRAY FOR TEXT BUFFER
C      LMAX (I)   THE MAXIMUM NO. OF CHARS IN 'ITEXT' (UP TO 150)
C       LLP (I)   UNIT NUMBER FOR ERROR MESSAGES (0 IF NONE REQUIRED)
C     LSTOP (I)   LOGICAL FLAG =TRUE, STOP IF ERROR, =FALSE CONTINUE.
C
C ENTRY IVALUE(IVAL)       RETURN INTEGER VALUE 'IVAL' FROM NEXT FIELD
C -----------------
C
C ENTRY FVALUE(FVAL)       RETURN F.P. VALUE 'FVAL' FROM NEXT FIELD
C -----------------
C
C ENTRY TEXLIM(MIN,MAX)    RETURN NOS. OF FIRST AND FINAL CHARACTERS IN
C ---------------------    FIELD IN 'MIN' AND 'MAX'
C
C NOTE: ENTRY PARAMETER VALUES ARE RETURNED AS ZERO FOR BLANK FIELDS
C       OR IF CONTINUING AFTER A SYNTAX ERROR.
C
C
C SPECIFICATION STATEMENTS
C
      CHARACTER*1 ITEXT
      CHARACTER*1 ISP,IPLUS,IMINUS,IDEC,ICOMMA
      CHARACTER*1 LTEXT(*),INUM(10)
      LOGICAL LSTOP,ISTOP,ERR
      COMMON /FFRDXX/ITEXT(150)
      COMMON /FFRDYY/NMAX,ILP,ISTOP,IFLD,M
      DATA ISP/' '/,IPLUS/'+'/,IMINUS/'-'/,IDEC/'.'/,ICOMMA/','/
      DATA INUM/'0','1','2','3','4','5','6','7','8','9'/
C
      SAVE /FFRDXX/,/FFRDYY/
C
C SAVE VARIABLES FOR ENTRY POINTS
C
      NMAX=LMAX
      IF(LMAX.GT.150)GO TO 810
      ILP=LLP
      ISTOP=LSTOP
C
C INITIAL ENTRY
C
      M=0
      IFLD=0
      IF(IUN.GT.0)READ(IUN,1001)(LTEXT(N),N=1,NMAX)
      DO 1 I=1,LMAX
1     ITEXT(I)=LTEXT(I)
      RETURN
C
C ENTRIES FOR INTEGER AND FLOATING POINT VALUES
C
      ENTRY IVALUE(IVAL)
C     ==================
C
      ITYP=0
      IVAL=0
      GO TO 100
      ENTRY FVALUE(FVAL)
C     ==================
C
      ITYP=1
      FVAL=0.0
100   S=1.0
      X=0.0
      ERR=.FALSE.
      IFDEC=0
      ID=0
      IFLD=IFLD+1
200   M=M+1
      IF(M-NMAX)220,220,460
220   IF(ITEXT(M).EQ.ISP)GO TO 200
      IF(ITEXT(M).EQ.ICOMMA)GO TO 200
      IF(ITEXT(M).EQ.IPLUS)GO TO 300
      IF(ITEXT(M).NE.IMINUS)GO TO 340
      S=-1.0
300   M=M+1
      IF(M-NMAX)320,320,440
320   IF(ITEXT(M).EQ.ISP)GO TO 440
      IF(ITEXT(M).EQ.ICOMMA)GO TO 440
340   IF(ITEXT(M).NE.IDEC)GO TO 400
      IF(IFDEC.EQ.1)ERR=.TRUE.
      IFDEC=1
      GO TO 300
400   DO 410 I=1,10
      N=I-1
      IF(ITEXT(M).EQ.INUM(I))GO TO 420
410   CONTINUE
      ERR=.TRUE.
      GO TO 300
420   ID=ID+IFDEC
      X=10.0*X+N
      GO TO 300
440   X=S*X/(10.0**ID)
      IF(ERR)GO TO 800
460   IF(ITYP)480,500,480
480   FVAL=X
      RETURN
500   IF(IFDEC)800,520,800
520   IVAL=X+0.1*S
      RETURN
C
C TEXT STRINGS ENTRY
C
      ENTRY TEXLIM(MIN,MAX)
C     =====================
C
      MIN=0
      MAX=0
      IFLD=IFLD+1
600   M=M+1
      IF(M.GT.NMAX)RETURN
      IF(ITEXT(M).EQ.ISP)GO TO 600
      MIN=M
610   MAX=M        
      M=M+1
      IF(M.GT.NMAX)RETURN
      IF(ITEXT(M).NE.ISP)GO TO 610
      RETURN
C
C ERROR FOUND
C
800   IF(ILP.GT.0)WRITE(ILP,2001)IFLD,(ITEXT(I),I=1,NMAX)
      IF(ISTOP)STOP
      RETURN
810   IF(ILP.GT.0)WRITE(ILP,2002)
      STOP 810
C
C FORMAT STATEMENTS
C
1001  FORMAT(255A1)
2001  FORMAT(' **SYNTAX ERROR IN FIELD',I3,' **'/(1X,130A1/))
2002  FORMAT(' **MAXIMUM LENGTH OF TEXT ALLOWED IN FFREAD IS 150',
     *' CHARACTERS**')
      END
C
C SUBROUTINE 'PSHEAD'
C ===================
C
C WRITE POSTSCRIPT FILE HEADER
C
      SUBROUTINE PSHEAD (LUNPS, SPRAD)
C
C PARAMETERS
C
C      LUNPS (I)   UNIT NUMBER FOR OUTPUT POSTSCRIPT FILE
C      SPRAD (I)   RADIUS FOR SPOTS (in 1/72 inches)
C
C====== Write header
C
      WRITE (LUNPS, 1001)
      WRITE (LUNPS, 1002)
      WRITE (LUNPS, 1003) SPRAD
      RETURN
C
C====== Format Statements
C
1001  FORMAT('%!')
1002  FORMAT('initclip clippath 0 0 0 setrgbcolor fill')
1003  FORMAT('/spot {',F7.3,' 0 360 arc fill} def')
      END
C
C SUBROUTINE 'PSKEYS'
C ===================
C
C WRITE POSTSCRIPT FILE KEYS AND TITLE AS REQUIRED
C
      SUBROUTINE PSKEYS (LUNPS, IANNOT, ITYPE, ISTYPE, TITLE, ALMIN,
     *                   ALMAX)
C
C PARAMETERS
C
C      LUNPS (I)   UNIT NUMBER FOR OUTPUT POSTSCRIPT FILE
C     IANNOT (I)   ANNOTATION OPTION NUMBER
C      ITYPE (I)   PLOT TYPE NUMBER
C     ISTYPE (I)   TREATMENT OF SPATIALS TYPE NUMBER
C      TITLE (I)   TITLE CHARACTER STRINGS (1 TO 3)
C      ALMIN (I)   MINIMUM LAMBDA VALUE FOR PLOT TYPES 1-3
C      ALMAX (I)   MAXIMUM LAMBDA VALUE FOR PLOT TYPES 1-3
C
C====== Specification statements
C
      CHARACTER*(*) TITLE(3)
      CHARACTER*16 STR5(4)
      CHARACTER*30 SPASTR(3)
      CHARACTER*72 PLTYPE(6)
      DATA STR5/'single spots',
     *          'double spots',
     *          'triple spots',
     *          'multiplicity > 3'/
      DATA SPASTR/'Spatial overlaps included',
     *            'Spatial overlaps excluded',
     *            'Spatial overlaps only'/
      DATA PLTYPE/
     *'Colour coded by wavelength; highest wavelength for multiples',
     *'Colour coded by wavelenght; multiples coded white',
     *'Singles only; colour coded by wavelength',
     *'Multiples only; colour coded by highest wavelength',
     *'Plot of nodals versus non-nodals',
     *'Plot colour coded by multiplicity'/
C
C====== Write title if required
C
      IF (IANNOT.EQ.1) RETURN
      WRITE (LUNPS, 1001)
      WRITE (LUNPS, 1002) 
      NT = 1
      KY = 50
      IF (TITLE(2).NE.' ') THEN
         NT = 2
         KY = 56
      ENDIF
      IF (TITLE(3).NE.' ') THEN
         NT = 3
         KY = 62
      ENDIF
      DO 100 I = 1,NT
      WRITE (LUNPS, 1003) KY, TITLE(I)
      KY = KY - 16
100   CONTINUE
      IF (IANNOT.LT.3) RETURN
C
C====== Write out keys
C
      WRITE (LUNPS, 1010)
      WRITE (LUNPS, 1011)
      WRITE (LUNPS, 1012)
      WRITE (LUNPS, 1013) PLTYPE(ITYPE)
      Y=220.0
      IF (ITYPE.LE.4) THEN
         DLAM = (ALMAX-ALMIN)/8.0
         DO 200 I=1,8
            Y=Y-15.0
            AL1 = ALMIN + (I-1)*DLAM
            AL2 = AL1 + DLAM
            WRITE (LUNPS, 1015) Y+4.0
            WRITE (LUNPS, 1020) I, Y+4.0
            WRITE (LUNPS, 1021) Y, AL1, AL2
200      CONTINUE
      ELSE IF (ITYPE.EQ.5) THEN
         Y=Y-15.0
         WRITE (LUNPS, 1015) Y+4.0
         WRITE (LUNPS,1030) Y+4.0
         WRITE (LUNPS,1031) Y
         Y=Y-15.0
         WRITE (LUNPS, 1015) Y+4.0
         WRITE (LUNPS,1032) Y+4.0
         WRITE (LUNPS,1033) Y
      ELSE IF (ITYPE.EQ.6) THEN
         DO 250 I=1,4
         Y=Y-15.0
         WRITE (LUNPS, 1015) Y+4.0
         WRITE (LUNPS,1040) 2*I, Y+4.0
         WRITE (LUNPS,1041) Y, STR5(I)
250      CONTINUE
      ENDIF
      Y=Y-15.0
      WRITE (LUNPS,1050) Y, SPASTR(ISTYPE)
      RETURN
C
C====== Format statements
C
1001  FORMAT('/prcolr { .8 .8 .8 setrgbcolor} def')
1002  FORMAT('/Helvetica findfont 15 scalefont setfont prcolr')
1003  FORMAT('50',I4,' moveto (',A,') show')
1010  FORMAT('/Helvetica findfont 12 scalefont setfont')
1011  FORMAT('/disc {2.5 0 360 arc fill} def')
1012  FORMAT('50 220 moveto (Key:) show')
1013  FORMAT('100 220 moveto (',A,') show')
1015  FORMAT('102.0',F6.1,' moveto')
1020  FORMAT('color',I1,' 102.0',F6.1,' disc')
1021  FORMAT('prcolr 120.0',F6.1,' moveto (',F5.3,' to ',F5.3,
     *       ' Angstroms) show')
1030  FORMAT('color2 102.0 ',F6.1,' disc')
1031  FORMAT('prcolr 120.0',F6.1,' moveto (non-nodal spots) show')
1032  FORMAT('color8 102.0 ',F6.1,' disc')
1033  FORMAT('prcolr 120.0',F6.1,' moveto (nodal spots) show')
1040  FORMAT('color',I1,' 102.0',F6.1,' disc')
1041  FORMAT('prcolr 120.0',F6.1,' moveto (',A,') show')
1050  FORMAT('prcolr 100.0',F6.1,' moveto (',A,') show')
      END
C
C SUBROUTINE 'PSCOLR'
C ===================
C
C WRITE POSTSCRIPT OUTPUT FOR COLOURS SET UP
C
      SUBROUTINE PSCOLR (LUNPS, R, G, B)
C
C PARAMETERS
C
C      LUNPS (I)   UNIT NO. FOR OUTPUT POSTSCRIPT FILE
C          R (I)   ARRAY OF THE 8 RED COMPONENTS FOR THE 8 COLOURS
C          G (I)   ARRAY OF THE 8 GREEN COMPONENTS
C          B (I)   ARRAY OF THE 8 BLUE COMPONENTS
C
C====== Specification Statements
C
      REAL R(8), G(8), B(8)
C
C====== Set up black and white
C
      WRITE (LUNPS,1001)
      WRITE (LUNPS,1002)
C
C====== Set up colours
C
      DO 100 I=1,8
         WRITE (LUNPS,1003) I, R(I), G(I), B(I)
100   CONTINUE
      RETURN
C
C====== Format Statements
C
1001  FORMAT('/setblack {0 0 0 setrgbcolor} def')
1002  FORMAT('/setwhite {1 1 1 setrgbcolor} def')
1003  FORMAT('/color',I1,' {',3F6.3,' setrgbcolor} def')
      END
