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