systemheader:(PW )# # ############################################################## # # # # *** PLTPAT *** # # # # PROGRAM TO GENERATE A POWDER PATTERN DIAGRAM # # # # ############################################################## # # last change gjk 16oct95 include:(XMACRO)# # macro:(lrppha:,3)# macro:(lrpwav:,4)# macro:(lrplim:,5)# macro:(lrppat:,6)# macro:(up:,3.)# macro:(dn:,2.)# macro:(m72:,incr:(arith:(71,/,mxchwd:)))# # extrude:(PWCOMN)# # string:(XLABEL,30)# ## x axis label string:(YLABEL,12)# ## y axis label REAL PNAMES(10)# ## Phase names REAL TTHMIN,TTHMAX# ## Two theta min, max REAL YMIN,YMAX# ## Intensity min, max REAL DIVX(11),DIVY(6)## scale division values REAL SCFX,SCFY# ## pat to plot scaling factors x, y REAL CHSIZE,NUSIZE# ## charcter, number size (in) REAL XLO,XHI,YLO,YHI,YOBS,YCAL,YBAC,YDIF,YPAT## plot baselines INTEGER DISPLAY(6,3)# ## display settings INTEGER GRID# ## Display grid lines flag INTEGER SCTYPE# ## Scale type INTEGER ISHIFT# ## Shift cal pattern up flag INTEGER NPHASE# ## Number of phases # COMMON/COMCPW/XLABEL,YLABEL# COMMON/COMIPW/DISPLAY,GRID,ISHIFT,SCTYPE,NPHASE# COMMON/COMFPW/PNAMES,TTHMIN,TTHMAX,YMIN,YMAX,DIVX,DIVY,SCFX,SCFY,# CHSIZE,NUSIZE,XLO,XHI,YLO,YHI,YOBS,YCAL,YBAC,YDIF,YPAT# endext:# # systemheader:(PW00)# Main program # ################################################################ # # # # PW00 # # # # ################################################################ # SUBROUTINE PW00# G j kruger nov 1991 # include:(AACOMN)# include:(PWCOMN)# # CALL PW10# Process pltpat parameters CALL PW20# Read lrplim CALL PW30# Read control lines CALL PW40# Scale & make frame CALL PW50# Read lrppat (pattern) & plot RETURN# END# systemheader:(PW10)# Process pltpat parameters # ################################################################ # # # # PW10 # # # # ################################################################ # SUBROUTINE PW10# # include:(AACOMN)# include:(PWCOMN)# chardata:(PW1,INP OUT )# chardata:(PW2,' PLTPAT Control Parameters-')# chardata:(PW3,' Input powder bdf extension ')# chardata:(PW4,' Output plot file extension ')# datastuff:# # # SET MEMORY # ---------- # FILEXT(IOUNIT(3))='PAT'# Binary powder pattern file FILEXT(IOUNIT(4))='PPP'# Powder pattern plot file IOMARK(3)=QXSTR# Start of input bdf buffer IOMARK(4)=IOMARK(3)+bdfbuf:# Start of plot file buffer incrqx:(I,IOMARK(4)+bdfbuf:,PW1005)# Start of data array # # SET DEFAULT VALUES # ------------------ # XLABEL(1^30)=" Degrees Two Theta "# X axis label YLABEL(1^12)="Intensity "# Y axis label FOR(J=1;J<=6;J=J+1)# Default displays $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 DISPLAY(J,1)=0# Display flag DISPLAY(J,2)=J# Colour DISPLAY(J,3)=MOD(J-1,3)+1# Line type $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 GRID=no:# No grid line display SCTYPE=1# Linear scale type ISHIFT=no:# Ovrlay obs and cal patterns # # PROCESS PROGRAM LINE # -------------------- # FOR(I=1;BUFIN(I)>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 stringlim:(I,M,N)# Get string position compchar:(CHRIN,M,PW1,1,3,4,NPW1,L)# Identify string IF(L==0) iquit:(PW1001)# Unidentifiable control # IF(L==1)# Input file ext $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 I=I+1; stringlim:(I,M,N)# Get ext limits FILEXT(IOUNIT(3))=CHRIN(M^M+N-1)# File ext max 3 char $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 IF(L==2)# Output file ext $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 4 I=I+1; stringlim:(I,M,N)# Get ext limits FILEXT(IOUNIT(4))=CHRIN(M^M+N-1)# File ext max 3 char $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 4 $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 2 # # PRINT CONTROL PARAMETERS # ------------------------ # movechar:(PW2,NPW2,CHROT,2,NPW2-2,2)# Insert header under line writeline:(1,PW2,NPW2-1,2,3)# Print controls header movechar:(FILEXT(IOUNIT(3)),1,PW3,32,3,0)# Insert input file ext writeline:(0,PW3,NPW3,3,3)# Print input file ext movechar:(FILEXT(IOUNIT(4)),1,PW4,32,3,0)# Insert output file ext writeline:(0,PW4,NPW4,3,3)# Print output file ext # RETURN# END# systemheader:(PW20)# Read lrplim, set limit default # ################################################################ # # # # PW20 # # # # ################################################################ # SUBROUTINE PW20# # include:(AACOMN)# include:(PWCOMN)# # INTEGER I,J# INTEGER IP# ## pointer in bdf array INTEGER PACK# ## packet size in bdf array # chardata:(PW1,' x Phase names on BDF-')# chardata:(PW2," Two theta min max xxx.xxx xxx.xxx")# chardata:(PW3," Ybdf min max xxxxxxx xxxxxxx")# chardata:(PW4,' Pattern limits on BDF-')# datastuff:# # readwpkt:(3,lrppha:,PACK,IP,0)# Read phase record NPHASE=INT(QX(IP+1))# Number of phases DO I=1,NPHASE; PNAMES(I)=QX(IP+I+1)# Extract phase names # readwpkt:(3,lrpwav:,PACK,IP,0)# Read lrpwav packet # readwpkt:(3,lrplim:,PACK,IP,0)# Read lrplim packet IF(IP<=0) iquit:(PW2005)# Record lrplim missing TTHMIN=QX(IP+1)# Two theta min - pattern TTHMAX=QX(IP+2)# Two theta max - pattern STEP=QX(IP+3)# Two theta stepsize YOMIN=QX(IP+4)# Obs intensity minimum YOMAX=QX(IP+5)# Obs intensity maximum YCMIN=QX(IP+6)# Cal intensity minimum YCMAX=QX(IP+7)# Cal intensity maximum YMIN=MIN(YCMIN,YOMIN)# YMAX=MAX(YCMAX,YOMAX)# # # PRINT FILE INFORMATION # ---------------------- # movechar:(PW1,NPW1,CHROT,2,NPW1-2,2)# Insert header under line ncodefld:(FLOAT(NPHASE),1,PW1,20113.,1)# Format nr phases writeline:(1,PW1,NPW1,2,3)# Print names header movertoc:(PNAMES,1,CHROT,2,NPHASE*8,0)# Insert phase names writeline:(0,0,0,1,3)# Print phase names movechar:(PW4,NPW4,CHROT,2,NPW4-2,2)# Insert header under line writeline:(1,PW4,NPW4-1,2,3)# Print limits header ncodefld:(TTHMIN,1,PW2,310932.,1)# Format 2theta min ncodefld:(TTHMAX,1,PW2,400932.,1)# Format 2theta max writeline:(0,PW2,NPW2,3,3)# Print 2theta limits ncodefld:(YMIN,1,PW3,310913.,1)# Format yobs min ncodefld:(YMAX,1,PW3,400913.,1)# Format yobs max writeline:(0,PW3,NPW3,3,3)# Print yobs limits # RETURN# END# systemheader:(PW30)# Read control lines # ################################################################ # # # # PW30 # # # # ################################################################ # SUBROUTINE PW30# # include:(AACOMN)# include:(PWCOMN)# # chardata:(PW1, END PLTLIM DISPLA SCALE XLABEL YLABEL)# datastuff:# # # PROCESS CONTROL LINES # --------------------- # REPEAT# Loop over input lines $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 readline:(PW1,NPW1)# Read next input line IF(LINID==1) BREAK# End ELSE IF(LINID==2) CALL PW31# Pltlim line ELSE IF(LINID==3) CALL PW32# Display line ELSE IF(LINID==4) CALL PW33# Scale line ELSE IF(LINID==5) XLABEL(1^30)=CHRIP(8^37)# Xlabel line ELSE IF(LINID==6) YLABEL(1^12)=CHRIP(8^19)# Ylabel line ELSE iquit:(PW3005)# Unknown control line $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 END# # systemheader:(PW31)# Process pltlim line # ################################################################ # # # # PW31 # # # # ################################################################ # SUBROUTINE PW31# # include:(AACOMN)# include:(PWCOMN)# # chardata:(PW1,TMIN TMAX YMIN YMAX)# chardata:(PW2," Two theta min max xxx.xxx xxx.xxx")# chardata:(PW3," Yplt min max xxxxxxx xxxxxxx")# chardata:(PW4,' Plot limits selected-')# datastuff:# # FOR(I=1;BUFIN(I)>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 stringlim:(I,M,N); N=MIN0(4,N-M)# Use up to 4 chars compchar:(CHRIN,M,PW1,1,N,5,NPW1,L)# Test for match IF(L==0) iquit:(PW3105)# Unknown pltlim parameter I=I+1# Numerical field IF(BUFIN(I)<=voidflg:)iquit:(PW3110)# Non-numerical value ELSE IF(L==1) TTHMIN=BUFIN(I)# ELSE IF(L==2) TTHMAX=BUFIN(I)# ELSE IF(L==3) YMIN=BUFIN(I)# ELSE IF(L==4) YMAX=BUFIN(I)# $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 # movechar:(PW4,NPW4,CHROT,2,NPW4-2,2)# Insert header under line writeline:(1,PW4,NPW4-1,2,3)# Print limits header ncodefld:(TTHMIN,1,PW2,310932.,1)# Format 2theta min ncodefld:(TTHMAX,1,PW2,400932.,1)# Format 2theta max writeline:(0,PW2,NPW2,3,3)# Print 2theta limits ncodefld:(YMIN,1,PW3,310913.,1)# Format yobs min ncodefld:(YMAX,1,PW3,400913.,1)# Format yobs max writeline:(0,PW3,NPW3,3,3)# Print yobs limits # RETURN# END# # systemheader:(PW32)# Process display line # ################################################################ # # # # PW32 # # # # ################################################################ # SUBROUTINE PW32# # include:(AACOMN)# include:(PWCOMN)# # # ## display flags in array DISPLAY(L,K) # # ## if DISPLAY(1,1) .ne. 0 - Display observed pattern # ## if DISPLAY(2,1) .ne. 0 - Display calculated pattern # ## if DISPLAY(3,1) .ne. 0 - Display background # ## if DISPLAY(4,1) .ne. 0 - Display difference pattern # ## if DISPLAY(5,1) .ne. 0 - Display reflection markers # ## if DISPLAY(6,1) .ne. 0 - Display grid lines # ## DISPLAY(L,2) contains colour code # ## DISPLAY(L,3) contains linetype code # chardata:(PW1,OBS CAL BAC DIF HKL GRI SHI )# chardata:(PW2," Display xxx Colour x Linetype x")# chardata:(PW3," Calculated pattern shift requested")# datastuff:# # FOR(I=1;BUFIN(I)>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 stringlim:(i,M,N);N=MIN0(3,N-M)# Max string length 3 compchar:(CHRIN,M,PW1,1,N,4,NPW1,L)# Get pattern type IF(L==O) iquit:(PW3205)# Pattern type unknown IF(L==6) GRID=yes:# Display grid lines # IF(L==7)# Shift selected $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 ISHIFT=yes:# Shift cal pattern up # writeline:(0,PW3,NPW3,3,3)# Print shift request NEXT# No display settings $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 2 # DISPLAY(L,1)=1# Turn display flag on if(BUFIN(I+1)>voidflg:)# numeric field $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 I=I+1# DISPLAY(L,2)=BUFIN(I)# Colour code $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 if(BUFIN(I+1)>voidflg:)# numeric field $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 4 I=I+1# DISPLAY(L,3)=BUFIN(I)# Linetype code $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 4 movechar:(PW1,4*L-3,PW2,10,3,0)# Pattern type ncodefld:(FLOAT(DISPLAY(L,2)),1,PW2,210213.,1)# Colour code ncodefld:(FLOAT(DISPLAY(L,3)),1,PW2,320213.,1)# Line type code writeline:(1,PW2,NPW2,3,3)# Print display item $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 # RETURN# END# systemheader:(PW33)# Process scale lines # ################################################################ # # # # PW33 # # # # ################################################################ # SUBROUTINE PW33# # include:(AACOMN)# include:(PWCOMN)# # chardata:(PW1,LIN LOG SQR )# chardata:(PW2," Scale type - xxx")# datastuff:# # stringlim:(1,M,N); N=MIN0(3,N-M)# Max string length 3 compchar:(CHRIN,M,PW1,1,N,4,NPW1,L)# Get scale type IF (L==0) iquit:(PW3305)# Scale type unknown SCTYPE=L# Set scale type J=4*SCTYPE-3# Point to scale type movechar:(PW1,J,PW2,15,3,0)# Scale type writeline:(0,PW2,NPW2,3,3)# Print scale type # RETURN# END# systemheader:(PW40)# Scale and plot frame # ################################################################ # # # # PW40 # # # # ################################################################ # SUBROUTINE PW40# # include:(AACOMN)# include:(PWCOMN)# # REAL PH,PW# ## Height and width of diagram REAL MARGIN# ## margin between pattern and diagram edges REAL RTITL(m72:)## real title array REAL X,Y# ## Coordinates REAL XC,YC# ## Coordinates of center INTEGER IOBS,ICAL,IBAC,IDIF,IHKL# Display flags chardata:(PW1," Log Sqr x 10** ")# chardata:(PW3,"Obs Calc Back Diff hkl Grid ")# datastuff:# # # INITIALIZATIONS # --------------- # PW=12.# Plot width PH=11.# Plot height XC=.5*PW; YC=.5*PH# Centre MARGIN=1.0# YLO=MARGIN; YHI=PH-MARGIN# Pattern vert box limits XLO=MARGIN; XHI=PW-MARGIN# Pattern horiz box limits J=0; DO I=1,4; J=J+DISPLAY(I,1)# IF(J<=0) DISPLAY(1,1)=1# Default obs pattern IF(DISPLAY(1,1)>0) IOBS=yes:# Display observed pattern IF(DISPLAY(2,1)>0) ICAL=yes:# Display calculated pattern IF(DISPLAY(3,1)>0) IBAC=yes:# Display background IF(DISPLAY(4,1)>0) IDIF=yes:# Display difference pattern IF(DISPLAY(5,1)>0) IHKL=yes:# Display reflection markers # # SET UP PLOT LAYOUT # ------------------ # YOBS=YLO# Pattern takes all space IF(IHKL==yes:) YOBS=YOBS+0.5*NPHASE# Nphase hkl marker lines YDIF=YOBS+1.0# Diff pattern centre posn IF(IDIF==yes:) YOBS=YOBS+2.0# Move obs patt above diff YBAC=YOBS; YCAL=YOBS# Bac & cal patt on obs posn IF(ISHIFT==yes:) YCAL=YOBS+0.5# Shift cal pattern posn YPAT=(YHI-YCAL)# Space left for a pattern # # SET Y SCALE FACTOR # ------------------ # IX=1+INT(LOG10(YMAX)); FAC2=10.0**IX# Int labels scale # IF(SCTYPE==2)# Log scale $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 IF(YMIN==0.0) YMIN=1.# Zero not allowed YMIN=SIGN(LOG10(ABS(YMIN)),YMIN)# Accomodate neg values YMAX=SIGN(LOG10(ABS(YMAX)),YMAX)# Accomodate neg values $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 IF(SCTYPE==3)# Sqrt scale $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 YMIN=SIGN(SQRT(ABS(YMIN)),YMIN)# Accomodate neg values YMAX=SIGN(SQRT(ABS(YMAX)),YMAX)# Accomodate neg values $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 2 DEL=YMAX-YMIN# SCFY=DEL/YPAT# Ypat inches for int pattern FAC1=0.2*YPAT*SCFY# Five divs in ypat inches # # SET TWO THETA SCALE FACTOR # -------------------------- # DEL=TTHMAX-TTHMIN# SCFX=DEL/10.# Ten inches for two theta # # SCALE DIVISION LABELS # --------------------- # FOR(I=0;I<=10;I=I+1) DIVX(I+1)=TTHMIN+(I*SCFX)# Two theta labels FOR(I=0;I<=5;I=I+1)# Intensity labels $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 IF(SCTYPE==1) DIVY(I+1)=(YMIN+I*FAC1)/FAC2# Linear scale IF(SCTYPE==2) DIVY(I+1)=(10.**(YMIN+I*FAC1))/FAC2# Log scale IF(SCTYPE==3) DIVY(I+1)=((YMIN+I*FAC1)**2)/FAC2# Sqrt scale $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 # # PLOT BORDERS # ------------ # CALL PW60(0.,0.,0.,0.,0.,0.,1)# Start of plot CALL PW60(0.,0.,0.,0.,0.,0.,2)# Advance frame CALL PW60(PW,PH,1.,1.,PW,PH,6)# Plot borders # # DRAW AXES # --------- # CALL PW60(XLO,YLO,0.,0.,0.,up:,3)# Pen up CALL PW60(XLO,YHI,0.,0.,-6000.,dn:,3)# Pen down CALL PW60(XHI,YHI,0.,0.,-6000.,dn:,3)# Pen down CALL PW60(XHI,YLO,0.,0.,-6000.,dn:,3)# Pen down CALL PW60(XLO,YLO,0.,0.,-6000.,dn:,3)# Pen down CALL PW60(0.,0.,XLO,YOBS,0.,up:,3)# Pen up CALL PW60(0.,0.,XHI,YOBS,-6000.,dn:,3)# Pattern baseline # # DRAW TITLE AND LABELS # --------------------- # movector:(TITLE,59,RTITL,1,30,0)# Pack title to real CHSIZE=.3# Character size X=XLO+2.0; Y=YHI+.4# Start of title CALL PW60(X,Y,CHSIZE,0.,30.,RTITL(1),5)# Regular title CHSIZE=.20# Character size NUSIZE=0.15# Number size movector:(BLANK,1,RTITL,1,30,1)# Blank out real array I=4*SCTYPE-3# Label pointer movector:(PW1,I,RTITL,1,3,0)# Move scale type to real X=XLO+.2; Y=YHI-.4# Scale type start CALL PW60(X,Y,CHSIZE,0.,3.,RTITL(1),5)# Scale type label # movector:(YLABEL,1,RTITL,1,12,0)# Move y label to real Y=YHI+.5# Y axis label start CALL PW60(XLO,Y,CHSIZE,0.,12.,RTITL(1),5)# Y axis label movector:(BLANK,1,RTITL,1,8,1)# Blank out real array ncodefld:(FLOAT(IX),1,PW1,200213.,1)# Encode power of ten movector:(PW1,13,RTITL,1,8,0)# Move scale exp to real Y=YHI+.2# Scale exp start CALL PW60(XLO,Y,CHSIZE,0.,8.,RTITL(1),5)# Scale exp label movector:(BLANK,1,RTITL,1,25,1)# Blank out real array # movector:(XLABEL,1,RTITL,1,30,0)# Move x label to real X=XLO+2.5; Y=YLO-.9# X axis label start CALL PW60(X,Y,CHSIZE,0.,30.,RTITL(1),5)# X axis label # # DRAW AXIS DIVISION MARKERS # -------------------------- # COLOUR=DISPLAY(6,2)# Grid line colour FOR(I=1;I<=11;I=I+1)# X (two theta) axis $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 4 X=XLO+FLOAT(I-1); Y=YLO# Ten one inch divisions CALL PW60(X,Y,0.,0.,0.,up:,3)# Pen up IF(GRID==no:)CALL PW60(0.,.1,X,Y,-6000.,dn:,3)# Draw tick ELSE CALL PW60(0.,0.,X,YHI,COLOUR,dn:,3)# Vert grid line $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 4 # FOR(I=1;I<=6;I=I+1)# Y (intensity) axis $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 5 X=XLO; Y=YOBS+FLOAT(I-1)*YPAT*0.2# Five div tick posns CALL PW60(X,Y,0.,0.,0.,up:,3)# Pen up IF(GRID==no:)CALL PW60(.1,0.,X,Y,-6000.,dn:,3)# Draw tick ELSE CALL PW60(0.,0.,XHI,Y,COLOUR,dn:,3)# Horiz grid line $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 5 # # LABEL AXIS DIVISION MARKERS # --------------------------- # FOR(I=1;I<=11;I=I+1)# X (two theta) axis $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 6 X=XLO+FLOAT(I-1)-1.0; Y=YLO-.25# Angle value positions CALL PW60(0.,0.,X,Y,0.,up:,3)# Pen up IF(SCFX<=10.) CALL PW60(X,Y,NUSIZE,DIVX(I),0.,1.,4)# One dec digit ELSE CALL PW60(X,Y,NUSIZE,DIVX(I),0.,0.,4)# No dec digit $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 6 # FOR(I=1;I<=6;I=I+1)# Y (intensity) axis $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 7 X=XLO-1.5; Y=YOBS+FLOAT(I-1)*YPAT*0.2# Intensity value positions CALL PW60(0.,0.,X,Y,0.,up:,3)# Pen up CALL PW60(X,Y,NUSIZE,DIVY(I),0.,2.,4)# Two dec digits $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 7 # # PATTERN LABELS # -------------- # IF(IHKL==yes:)# Write phase names at markers $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 8 X=XHI+.1# FOR(I=1;I<=NPHASE;I=I+1)# Nphase hkl marker lines $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 9 Y=YLO+.2+FLOAT(I-1)*.5# CALL PW60(X,Y,CHSIZE,0.,6.,PNAMES(I),5)# Phase name $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 9 $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 8 # IF(IDIF==yes:)# Difference pattern $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 10 CALL PW60(0.,0.,XLO,YDIF,0.,up:,3)# Pen up CALL PW60(0.,0.,XHI,YDIF,-6000.,dn:,3)# Dif line movector:(PW3,16,RTITL,1,3,0)# Move dif to real X=XHI+.1# CALL PW60(X,YDIF,CHSIZE,0.,3.,RTITL(1),5)# Dif label $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 10 # IF(IOBS==yes:)# $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 11 movector:(PW3,1,RTITL,1,3,0)# Move obs to real X=XHI+.1# CALL PW60(0.,0.,X,YOBS,0.,up:,3)# Pen up CALL PW60(X,YOBS,CHSIZE,0.,3.,RTITL(1),5)# Obs label $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 11 # IF(ICAL==yes:)# Calculated pattern $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 12 movector:(PW3,6,RTITL,1,3,0)# Move cal to real X=XHI+.1; Y=YOBS+0.5# CALL PW60(0.,0.,X,Y,0.,up:,3)# Pen up CALL PW60(X,Y,CHSIZE,0.,3.,RTITL(1),5)# Cal label $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 12 # IF(IBAC==yes:)# Background pattern $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 13 movector:(PW3,11,RTITL,1,3,0)# Move bac to real X=XHI+.1; Y=YOBS+1.0# CALL PW60(0.,0.,X,Y,0.,up:,3)# Pen up CALL PW60(X,Y,CHSIZE,0.,3.,RTITL(1),5)# Bac label $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 13 # CALL PW60(0.,0.,XLO,YLO,0.,up:,3)# Pen up RETURN# END# systemheader:(PW50)# Read lrppat and plot data # ################################################################ # # # # PW50 # # # # ################################################################ # SUBROUTINE PW50# # include:(AACOMN)# include:(PWCOMN)# # # READ & PLOT LRPPAT FOR ALL PATTERNS REQUESTED # --------------------------------------------- # FOR(I=1;I<=5;I=I+1)# Loop over pattern types $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 IF(DISPLAY(I,1)==0) NEXT# Only if requested write(6,'(a5,3i5)') ' disp',(display(i,j),j=1,3)# COLOUR=DISPLAY(I,2)# Line colour LTYPE=DISPLAY(I,3)# Line type (solid, etc) # # POSITION FILE AT TTHMIN # ----------------------- # CALL PW51(2,I,X,Y,IEOF)# IF(IEOF==yes:) iquit:(PW5005)# No lrec lrppat CALL PW60(X,Y,XLO,0.,0.,up:,3)# Pen up to line start # # READ PATTERN AND PLOT # --------------------- # REPEAT# $(# 1>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 CALL PW51(1,I,X,Y,IEOF)# Read packet of data IF(IEOF==yes:) BREAK# End of data or tthmax IF(I<=4) CALL PW60(X,Y,XLO,0.,COLOUR,dn:,3)# Plot line segment ELSE IF(I==5 & Y>0.0)# Display reflection markers $(# 2>>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 do j=1,nphase# scan all phases present $(# 2>>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 intunpak:(y,n,j-1,1)# get phase indicator if(n<=0) next# skip, not this phase Y=0.5*(j-1)+0.2# Shift to phase indicated CALL PW60(X,Y,XLO,YLO,0.,up:,3)# Pen up to marker start Y=Y+0.2# Marker length CALL PW60(X,Y,XLO,YLO,COLOUR,dn:,3)# Plot marker $)# 2<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 $)# 2<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 2 CALL PW60(0.,0.,XLO,ylo,0.,up:,3)# Pen up $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 # # CLOSE FILES # ----------- # CALL PW51(3,0,X,Y,IEOF)# Close pattern bdf CALL PW60(0.,0.,0.,0.,0.,2.,10)# Finish off plot file # RETURN# END# # systemheader:(PW51)# Powder pattern file read/write # #################################################################### # # PW51 # # #################################################################### SUBROUTINE PW51(I,J,X,Y,IEOF)# include:(AACOMN)# include:(PWCOMN)# # INTEGER I,IEOF# INTEGER IP# ## pointer in bdf array INTEGER PACK# ## packet size in bdf array # chardata:(PW1," BDF EOF ERROR - ")# realdata:(FMT,[180832.,260832.,340832.,420832.])# datastuff:# # # READ NEXT PATTERN STEP # ---------------------- # IF(I==1)# Read next step $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 readwpkt:(3,lrppat:,PACK,IP,0)# Read step packet IF(IP<=0)IEOF=yes:# Eof reached TTH=QX(IP+1)# Two theta $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 # # REWIND AND REPOSITION PATTERN FILE AT STEP AFTER TTHMIN # ------------------------------------------------------- # IF(I==2)# Rewind,reposition file $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 rewindbdf:(3)# Rewind input powder file IEOF=no:# Set flag: not yet at eof TTH=0.0# Dummy value WHILE(TTH>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 readwpkt:(3,lrppat:,PACK,IP,0)# Read obs pattern file IF(IP>0) TTH=QX(IP+1)# Two theta ELSE# Abnormal eof, report, quit $(# 2>>>>>>>>>>>>>>>>>>>>>>>>>>>> 4 ncodefld:(QX(IP+1),1,chrot,FMT(1),1)# Tth ncodefld:(QX(IP+2),1,chrot,FMT(2),1)# Obs ncodefld:(QX(IP+5),1,chrot,FMT(3),1)# Cal ncodefld:(QX(IP+6),1,chrot,FMT(4),1)# Bac writeline:(0,PW1,NPW1,3,1)# Print - abnormal eof reached IEOF=yes:# Set flag - eof reached BREAK# Quit read loop $)# 2<<<<<<<<<<<<<<<<<<<<<<<<<<<< 4 $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 2 # # FINISH OFF PATTERN FILE # ------------------------ # IF(I==3)# $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 5 rewindbdf:(3)# Rew pattern files RETURN# $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 5 # # EXTRACT DATA REQUESTED # ---------------------- # IF(TTH>=TTHMAX) IEOF=yes:# Max two theta reqd X=(TTH-TTHMIN)/SCFX# Set x-coordinate # IF(J==5)# Display reflection markers $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 6 Y=QX(IP+7)# Display & phase marker RETURN# $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 6 # IF (J==1) Y=QX(IP+2)# Display observed pattern ELSE IF(J==2) Y=QX(IP+5)# Display calculated pattern ELSE IF(J==3) Y=QX(IP+6)# Display background ELSE IF(J==4) Y=QX(IP+2)-QX(IP+5)# Display difference pat n # IF(SCTYPE==2)# Log scale $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 7 IF(Y==0.0) Y=1.# Zero not allowed Y=SIGN(LOG10(ABS(Y)),Y)# Log scale $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 7 IF(SCTYPE==3) Y=SIGN(SQRT(ABS(Y)),Y)# Sqrt scale IF(Y>YMAX) Y=YMAX# Crop to ymax IF(J==4) Y=Y/SCFY# Scale difference plot ELSE Y=(AMAX1(Y,YMIN)-YMIN)/SCFY# crop to ymin and Scale # IF (J==1) Y=Y+YOBS# Position observed pattern ELSE IF(J==2) Y=Y+YCAL# Position calculated pattern ELSE IF(J==3) Y=Y+YBAC# Position background ELSE IF(J==4) Y=Y+YDIF# Position difference pattern # RETURN# END# systemheader:(PW60)# Write packet to plot file # ############################################################### # # # # PW60 # # # # ############################################################### # SUBROUTINE PW60(P1,P2,P3,P4,P5,P6,KEY)# R. olthof-hazekamp # December 1986 include:(AACOMN)# # INTEGER I# ## INTEGER IP# ## Pointer in output buffer INTEGER KEY# ## 1=start of plot # ## 2=FRAME ADVANCE SIGNAL # ## 3=PEN MOVEMENT # ## 4=DRAW NUMBER # ## 5=DRAW CHARACTER STRING # ## 6=PLOT SCALE # ## 10=END OF PLOT REAL P1,P2,P3,P4,P5,P6(m72:)## Parameters CHARACTER*70 BUF# # writepkt:(4,23,7,IP)# Init for new packet QX(IP+1)=P1# Parameter 1 QX(IP+2)=P2# Parameter 2 QX(IP+3)=P3# Parameter 3 QX(IP+4)=P4# Parameter 4 QX(IP+5)=P5# Parameter 5 QX(IP+6)=P6(1)# Parameter 6 QX(IP+7)=FLOAT(KEY)# Function key # IF(KEY==5)# Character string $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1 QX(IP+6)=0.# Dummy N=NINT(P5); M=7*mxchwd:# Nr of words in string FOR(I=0;I>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 writepkt:(4,23,7,IP)# Init for next packet L=MIN0(M,N-I)# Length of packet BUF=' '# Blank the buffer movertoc:(P6,I+1,BUF,1,L,0)# Move string to buffer movector:(BUF,1,QX(IP+1),1,M,0)# Move buffer to packet $)# 1<<<<<<<<<<<<<<<<<<<<<<<<<<<< 2 $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1 # IF(KEY==10)# End plot $(# 0>>>>>>>>>>>>>>>>>>>>>>>>>>>> 3 writepkt:(4,endrecord:,5,IP)# Write end of plot record ^^ $)# 0<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 # RETURN# END# pmacro:([no:])#