      PROGRAM SEEK
C  COPYRIGHT GENERAL ELECTRIC CO.  1982
C
C  SEEK IS AN ADAPTATION FOR FLUORESCENCE ANALYSIS OF THE PROGRAM FIND
C    USED IN DIFFRACTION ANALYSIS
C  THE PEAK FINDING SECTION OF THE PROGRAM USES PORTIONS OF SPECPLOT
C  SPECPLOT ROUTINES USED:  DATA  RBKGR  INSCH  OPEN8  SEARCH NORM
C  OTHER ROUTINES USED: SFNAME
C  WRITTEN BY RAY GOEHNER  2/82
C  ADAPTED FOR XRF BY MARY GARBAUSKAS 4/82
C
C  LU-1  XF1:SEEKQED.INP   INPUT FILE QED
C  LU-2  ERROR RETURN  TI:
C  LU-3  SPECPLOT TYPE DATA FILE     XF2:Snnnnn.RAW
C  LU-4  FILE OF SPECPLOT DATA FILES TO BE REDUCED XF1:SEEKFILE.INP
C  LU-5  INPUT FILE FOR  BKGR & SEARCH PARAMETERS ETC   XF1:SEEK.INP
C  LU-6  NIH ELEMENTAL DATA BASE
C  LU-7  NULL DEVICE NL0:
C  LU-8  SP0:Snnnnn.SPC  RESULT FILE RESULT FILE FROM SEARCH
C  LU-9  SP0:Snnnnn.QED  RESULT FILE FROM SEARCH/MATCH
C  LU-10 SCRATCH FILE USED IN SEARCH/MATCH
C  LU-11 SCRATCH FILE USED IN SEARCH/MATCH OUTPUT
C
C  IFLAG=0  IF FILENAME NOT FOUND
C  ICOUNT   MAX TIME BUFFER
C
C
      DIMENSION TIT(12),B(4096),INST(2),IPX(100),IWDR(10),IWDL(10)
      INTEGER SNUM,DATE,YEAR
      BYTE FILE(30),DSN(30)
C
      ICOUNT=0
      NFILE=1
C
      OPEN(UNIT=5,NAME='XF1:SEEK.INP',TYPE='OLD',ACCESS='SEQUENTIAL'
     1,FORM='FORMATTED',ERR=9999,SHARED)
      OPEN(UNIT=1,NAME='XF1:SEEKQED.INP',TYPE='OLD'
     1,ACCESS='SEQUENTIAL',FORM='FORMATTED',SHARED,ERR=98)
C
  100 CONTINUE
C
      OPEN(UNIT=4,NAME='XF1:SEEKFILE.INP;1',TYPE='OLD',SHARED,
     1ACCESS='SEQUENTIAL',FORM='FORMATTED',ERR=999)
      READ(4,*,END=99) NUMBER
C
      AM=0.0
      ISKIP=1
      JSH=1
      IOP8=1
      ISM=0
C
      CALL SFNAME(SNUM,MON,DATE,YEAR,INST,TIT,T0,DX,DY,CRY
     1,DSPACE,ITG,XL,NFILE,IFLAG,ICOUNT,FILE)
      IF(IFLAG.EQ.0) GO TO 100
C
      IN=INST(1)
      YCR=1.0/DY
C
      CALL DATA(B,N,NMAX,YMIN,YMAX,IE,IEND,ISKIP,IYMIN)
C
C   SDB CALCULATED FROM AM IN SEARCH
      IF(IYMIN.GT.2.AND.IYMIN.LT.(N-1)) AM=AM+(B(YMIN-1)+B(IYMIN)
     1+B(IYMIN+1))/3.0
      IF(IYMIN.LE.2) AM=AM+(B(2)+B(3)+B(4))/3.0
      IF(IYMIN.GE.(N-1)) AM=AM+(B(2)+B(3)+B(4))/3.0
C
      CALL RBKGR(B,N,YMIN,YMAX,NF,NB,7)
C
      CALL INSCH(ND2,DR2L,NUM,NWD,IWDL,IWDR,DX,T0,IPF,ITG,XL,ISM,
     1DR2M,IN)
C
      CALL OPEN8X(IOP8,SNUM,MON,DATE,YEAR,INST,TIT,T0,DX,DY,CRY,DSPACE
     1,ITG,XL,ISM,ITGKA2,ND2,DR2L,NUM,IPF,JSH,FILE,NF,NB)
C
      CALL SEARCH(B,N,DX,YCR,T0,DY,IPX,IWDL,IWDR,NWD,IN,ND2,DR2L
     1,NUM,IPF,ITG,DSPACE,ISM,NF,NB,ITGKA2,AM)
C
C
C
      CALL QED(FILE)
C
      REWIND 5
      REWIND 1
800   CALL CLOSE(4)
      CALL CLOSE(3)
      IF(NFILE.LE.NUMBER) GO TO 100
      CLOSE(UNIT=1)
C
      STOP
 9999 WRITE(2,20)
   20 FORMAT(1X,'XF1:SEEK.INP NOT FOUND CHECK OTHER UIC')
      STOP
  999 WRITE(2,30)
   30 FORMAT(1X,'XF1:SEEKFILE.INP  NOT FOUND')
      STOP
   99 WRITE(2,40)
   40 FORMAT(1X,'XF1:SEEKFILE.INP   IS EMPTY')
      STOP
   98 WRITE(2,50)
   50 FORMAT(1X,'XF1:SEEKQED.INP  NOT OPENED')
      STOP
      END
	SUBROUTINE BSORT(W,INT,LINE,NLINE)
C
C  BUBBLE SORT BASED UPON INTENSITY
C
	REAL*8 LINE(75),TTEMP
	DIMENSION W(75)
	INTEGER INT(75)
	N=NLINE-1
100	NSWAP=0
	DO 300 K=1,N
	IF(INT(K).GE.INT(K+1))GO TO 300
	ITEMP=INT(K+1)
	INT(K+1)=INT(K)
	INT(K)=ITEMP
	TEMP=W(K+1)
	W(K+1)=W(K)
	W(K)=TEMP
	TTEMP=LINE(K+1)
	LINE(K+1)=LINE(K)
	LINE(K)=TTEMP
	NSWAP=1
300	CONTINUE
	IF(NSWAP.NE.0)GO TO 100
	RETURN
	END

      SUBROUTINE DATA(B,N,NMAX,YMIN,YMAX,IE,IEND,ISKIP,IYMIN)
C                                                           **********
C                                                           ** DATA **
C                                                           **********
C DATA IS A SUBROUTINE OF DIFPLOT WHICH READS THE DATA
C *****************************************************
C    READS UNFORMATTED DATA
C    IF IEND=9 END OF FILE
C *****************************************************
      DIMENSION B(4096),A(32)
      N=0
      IE=IE+2
      YMIN=9999.
      IYMIN=1
      YMAX=-999.
      I1=1
   10 READ(3,END=95) A
      DO 20 I=I1,32,ISKIP
      IF(A(I).LT.0) GO TO 95
      N=N+1
      T=A(I)
      B(N)=T
      IF(N.EQ.NMAX) GO TO 94
      IF(T.GT.YMAX) YMAX=T
      IF(T.LT.YMIN) YMIN=T
      IF(T.LT.YMIN) IYMIN=N
      I2=I
   20 CONTINUE
      I1=ISKIP - (32 - I2)
      GO TO 10
   94 IF(NMAX.EQ.4096) GO TO 96
   95 IEND=9
   96 CONTINUE
      CALL CLOSE(3)
D     PAUSE
D     WRITE(6,1000) (B(I),I=1,N)
D1000 FORMAT(1X,10F7.1)
      RETURN
      END

      SUBROUTINE DER2(A,D2,ND2)
C                                                           **********
C                                                           ** DER2 **
C                                                           **********
CLAB= DER2
C 2ND DERIVATIVE
C ND2=05,07,09,11,15,19,25
      INTEGER*2 ND2
      DIMENSION A(25)
      IF(ND2.NE.11) GO TO 10
      D2=15.*(A(1)+A(11))+6.*(A(2)
     &+A(10))-1.*(A(3)+A(9))
     &-6.*(A(4)+A(8))-9.*(A(5)+A(7))-10.*A(6)
      D2=D2/429.
      GO TO 26
   10 IF(ND2.NE.25) GO TO 20
      D2=92.*(A(1)+A(25))+69.*(A(2)+A(24))
     &+48.*(A(3)+A(23))+29.*(A(4)+A(22))
     &+12.*(A(5)+A(21))-3.*(A(6)+A(20))-16.*(A(7)+
     &A(19))-27.*(A(8)+A(18))-36.*(A(9)+A(17))-43.*(
     &A(10)+A(16))-48.*(A(11)+A(15))
     &-51.*(A(12)+A(14))-52.*A(13)
      D2=D2/26910.
      GO TO 26
   20 IF(ND2.NE.5) GO TO 21
      D2=2.*(A(1)+A(5))-1.*(A(2)+A(4))-2.
     &*A(3)
      D2=D2/7.0
      GO TO 26
   21 IF(ND2.NE.19) GO TO 22
      D2=51.*(A(1)+A(19))+34.*(A(2)+A(18))
     &+19.*(A(3)+A(17))+6.*(A(4)+A(16))
     &-5.*(A(5)+A(15))-14.*(A(6)+A(14))
     &-21.*(A(7)+A(13))-26.*(A(8)+A(12))
     &-29.*(A(9)+A(11))-30.*A(10)
      D2=D2/6783.
   22 IF(ND2.NE.7) GO TO 23
      D2=5.*(A(1)+A(7))-3.*(A(3)+A(5))-4.*A(4)
      D2=D2/42.0
      GO TO 26
   23 IF(ND2.NE.9) GO TO 24
      D2=28.*(A(1)+A(9))+7.*(A(2)+A(8))-8.*(A(3)+A(7))
     &-17.*(A(4)+A(6))-20.*A(5)
      D2=D2/462.0
      GO TO 26
   24 IF(ND2.NE.15) GO TO 25
      D2=91.*(A(1)+A(15))+52.*(A(2)+A(14))+19.*(A(3)+A(13))
     &-8.*(A(4)+A(12))-29.*(A(5)+A(11))-44.*(A(6)+A(10))
     &-53.*(A(7)+A(9))-56.*A(8)
      D2=D2/6188.
      GO TO 26
   25 CONTINUE
   26 RETURN
      END
	SUBROUTINE FIND(WAVE,MATCH,ERR,WMIN,WMAX,NL,LNIH,LSCR,NORD,AKV)
C
C---ROUTINE MATCHES STRONGEST LINE OF AN ELEMENT WITHIN THE MEASURED
C      RANGE TO THE MEASURED LINES
C   NO ATTEMPT IS MADE TO LOOK FOR OTHER LINES OF THAT ELEMENT
C   MATCHED ELEMENT INFO IS WRITTEN TO SCRATCH FILE FOR LATER RETRIEVAL
C---
	REAL*8 LINE(75)
	DIMENSION WAVE(100),W(75),INT(75)
C
	NREC=1
	MATCH=0
C
C  CALCULATE CUTOFF WAVELENGTH FOR ACCELERATING VOLTAGE USED
C
	CUTOFF=12.396/AKV
C
C  CALUCLUATE WAVELENGTH RANGE TO BE CONSIDERED FOR THIS ORDER
C
	WLOW=WMIN/NORD
	IF(CUTOFF.GT.WLOW)WLOW=CUTOFF
	WHIGH=WMAX/NORD
	IF(WHIGH.LT.WLOW)RETURN
C
C  START MATCH
C
100	READ(LNIH'NREC,ERR=900)IZ,W,INT,LINE
	CALL LIMIT(W,INT,LINE,WLOW,WHIGH,NLINE)
	IF(NLINE.EQ.0)GO TO 150
	CALL BSORT(W,INT,LINE,NLINE)
	STRONG=W(1)
	STRONG=STRONG*NORD
	DO 120 N=1,NL
	DWAVE=ABS(WAVE(N)-STRONG)
	IF(DWAVE.LE.ERR)GO TO 350
120	CONTINUE
	GO TO 150
350	MATCH=MATCH+1
	WRITE(LSCR)IZ,W,INT,LINE,NLINE,NORD
150	NREC=NREC+1
	IF(NREC.LE.91)GO TO 100
900	RETURN
	END
	SUBROUTINE GET2D(LUNI,LUNP,TWOD)
C  Modified 1-FEB for Alfred Univ.
100	WRITE(LUNP,9000)
9000	FORMAT(1X,' ENTER CRYSTAL: 1 - LiF 200'/17X,'2 - RAP 100'/
     %	 17X,'3 - PET'/17X,'4 - EDDT 020'/17X,'5 - Ge'/17X,'6 - ADP'
     %	 /17X,'7 - Other')   ! JDW
	WRITE(LUNP,9010)
9010	FORMAT('$ >')
	READ(LUNI,*,END=999)ICRY
	IF(ICRY.LT.1.OR.ICRY.GT.7)GO TO 100
	IF(ICRY.EQ.1)TWOD=4.027
	IF(ICRY.EQ.2)TWOD= 26.121    ! JDW
	IF(ICRY.EQ.3)TWOD=8.742
	IF(ICRY.EQ.4)TWOD= 8.808     ! JDW
	IF(ICRY.EQ.5)TWOD=6.532
	IF(ICRY.EQ.6)TWOD=10.648
	IF(ICRY.NE.7)GO TO 800
	WRITE(LUNO,9200)
9200	FORMAT('$ ENTER 2D FOR CRYSTAL>')
	READ(LUNI,*,END=999)TWOD
800	RETURN
999	STOP
	END

      SUBROUTINE INSCH(ND2,DR2L,NUM,NWD,IWDL,IWDR
     &,DX,SS,IPF,ITG,XL,ISM,DR2M,IN)
C                                                           **********
C                                                           **INSCH **
C                                                           **********
C INPUT NEEDED BY SEARCH SUBROUTINE
      INTEGER*2 ND2,NUM,NWD,IWDL(10),IWDR(10),I
      REAL ICU,ICR,IFE,ICO,IMO,INI,IAG
      DATA ICU,ICR,IFE,ICO/1.54051,2.28962,1.93597,1.78892/
      DATA IMO,INI,IAG/0.709261,1.65791,0.55941/
      DATA JCU,JCR,JFE,JCO,JMO,JNI,JAG/'CU','CR','FE','CO','MO','NI',
     X'AG'/
      IF(IN.EQ.'XR')GO TO 27
      IF(ITG.NE.JCU)GO TO 21
   20 ITG=JCU
      XL=ICU
      GO TO 27
   21 IF(ITG.NE.JCR)GO TO 22
      XL=ICR
      GO TO 27
   22 IF(ITG.NE.JFE)GO TO 23
      XL=IFE
      GO TO 27
   23 IF(ITG.NE.JCO)GO TO 24
      XL=ICO
      GO TO 27
   24 IF(ITG.NE.JMO)GO TO 25
      GO TO 27
   25 IF(ITG.NE.JNI)GO TO 26
      XL=INI
      GO TO 27
   26 IF(ITG.NE.JAG)GO TO 20
      XL=IAG
   27 DO 16 I=1,10
      IWDL(I)=0
   16 IWDR(I)=0
      WRITE(7,63)
   63 FORMAT(1X,'NUMBER OF 2ND DERIVATIVE PTS TO BE SMOOTHED OVER')
      WRITE(7,120)
  120 FORMAT(1H$,'05,07,09,11,15,19,25 DEFAULT IS 09 > ')
      READ(5,15,END=9999) ND2
   15 FORMAT(I2)
      IF(ND2.LE.0)ND2=9
      WRITE(7,12)
   12 FORMAT(1H$,'SENSITIVITY  DEFAULT=2.0  > ')
      READ(5,11,END=9999) DR2L
   11 FORMAT(F6.0)
      IF(DR2L.LE.0) DR2L=2.0
      DR2M=DR2L
      WRITE(7,13)
   13 FORMAT(1H$,' PARABOLIC FIT-0,3,5  DEFAULT IS NO FIT  > ')
      READ(5,19,END=9999) IPF
   19 FORMAT(I1)
      WRITE(7,10)
   10 FORMAT(1H$,'SIG. NUMBER  DEFAULT-1 > ')
      READ(5,19,END=9999) NUM
      IF(NUM.LE.0)NUM=1
      WRITE(7,14)
   14 FORMAT(1H$,'NUMBER OF AREA WINDOWS 01,10  DEFAULT=00  > ')
      READ(5,15,END=9999) NWD
      IF(NWD.EQ.0) GO TO 108
      DO 105 I=1,NWD
      WRITE(7,17)
   17 FORMAT(1H$,' LEFT=')
      READ(5,11,END=9999) W
      W=W-SS
      IWDL(I)=W/DX
      WRITE(7,18)
   18 FORMAT(1H$,' RIGHT=')
      READ(5,11,END=9999) W
      W=W-SS
      IWDR(I)=W/DX
  105 CONTINUE
  108 CONTINUE
      RETURN
 9999 STOP
      END
	SUBROUTINE LIMIT(W,INT,LINE,WMIN,WMAX,NLINE)
C
C  ROUTINE DETERMINES ELEMENTS OF W THAT ARE WITHIN WMIN,WMAX RANGE
C    AND RETURNS WITH THESE LINES IN THE FIRST NLINE ELEMENTS OF W
C
	REAL*8 LINE(75),L(75)
	DIMENSION W(75),W2(75)
	INTEGER INT(75),I2(75)
	N=0
	DO 200 K=1,75
	IF(W(K).LT.WMIN)GO TO 200
	IF(W(K).GT.WMAX)GO TO 200
	N=N+1
	W2(N)=W(K)
	I2(N)=INT(K)
	L(N)=LINE(K)
200	CONTINUE
	NLINE=N
	DO 300 K=1,NLINE
	W(K)=W2(K)
	INT(K)=I2(K)
	LINE(K)=L(K)
300	CONTINUE
	RETURN
	END
	SUBROUTINE MINMAX(WAVE,WMIN,WMAX,NL)
C*** DETERMINE THE MINIMUM AND MAXIMUM WAVELENGTH OF THE MEASURED PATTERN
	DIMENSION WAVE(1)
	WMIN=WAVE(1)
	WMAX=WAVE(1)
	DO 100 I=1,NL
	IF(WAVE(I).LT.WMIN)WMIN=WAVE(I)
	IF(WAVE(I).GT.WMAX)WMAX=WAVE(I)
100	CONTINUE
	RETURN
	END
	SUBROUTINE NAME(FILE,DSN)
C
C  CHANGE EXTENSION OF FILE TO '.QED' AND RETURN IN DSN
C
	BYTE FILE(30),DSN(30)
	DO 200 I=1,30
	L=I
	DSN(I)=FILE(I)
	IF(FILE(I).EQ.'.')GO TO 210
200	CONTINUE
	DSN(1)='X'
	DSN(2)='F'
	DSN(3)='1'
	DSN(4)=':'
	DSN(5)='Q'
	DSN(6)='E'
	DSN(7)='D'
	DSN(8)='.'
	L=8
210	DSN(L+1)='Q'
	DSN(L+2)='E'
	DSN(L+3)='D'
	DSN(L+4)=0
	RETURN
	END
	SUBROUTINE NAMSPC(FILE,DSN)
C
C  CHANGE EXTENSION OF FILE TO '.SPC' AND RETURN IN DSN
C
	BYTE FILE(30),DSN(30)
	DO 200 I=1,30
	L=I
	DSN(I)=FILE(I)
	IF(FILE(I).EQ.'.')GO TO 210
200	CONTINUE
	DSN(1)='S'
	DSN(2)='P'
	DSN(3)='0'
	DSN(4)=':'
	DSN(5)='S'
	DSN(6)='P'
	DSN(7)='C'
	DSN(8)='.'
	L=8
210	DSN(L+1)='S'
	DSN(L+2)='P'
	DSN(L+3)='C'
	DSN(L+4)=0
	RETURN
	END
C   FILENAME  OPEN8X
      SUBROUTINE OPEN8X(IOP8,SNUM,MON,DATE,YEAR,INST,TIT,T0,DX,DY,CRY
     1,DSPACE,ITG,XL,ISM,ITGKA2,ND2,DR2L,NUM,IPF,JSH,FILE,NF,NB)
C
C   SUBROUTINE TO OPEN SCRATCH FILES AND TO WRITE HEADER TO ROOT.SPC
C   THIS FILE USED BY SEARCH & P,D,G,&L CURSOR COMMANDS
C
C  IOP8=1 WHEN A NEW FILE SHOULD BE OPENED LU-23
C
      INTEGER SNUM,DATE,YEAR
      DIMENSION TIT(12),INST(2)
      BYTE FILE(30)
      DO 5 I=1,30
    5 IF(FILE(I).EQ.'.') J=I
      FILE(J+1)='S'
      FILE(J+2)='P'
      FILE(J+3)='C'
      FILE(J+4)=0
C
      IN=INST(1)
C
      IF(IOP8.NE.1) RETURN
      CALL CLOSE(8)
C  SP0:R00000.DIF SHOULD BE OPENED WITH AN INITIAL SIZE OF 15 FOR RT-11
      OPEN(UNIT=8,NAME=FILE,TYPE='NEW',ACCESS='SEQUENTIAL',
     XFORM='FORMATTED')
       WRITE(8,21) SNUM,MON,DATE,YEAR,(INST(I),I=1,2)
     1,(TIT(I),I=1,12)
   21 FORMAT(1X,I5,1X,I2,'-',I2,'-',I2,1X,2A2,4X,12A4)
      IF(IN.EQ.'DI') WRITE(8,53) T0,DX,DY,ITG,XL
      IF(IN.EQ.'XR') WRITE(8,55) T0,DX,DY,CRY,DSPACE
   53 FORMAT(1X,'START ANGLE=',F8.3,'  DELTA 2THETA='
     &,F6.3,'  TIME=',F5.1,' TUBE=',A2,' LAMDA=',F6.3)
   55 FORMAT(1X,'START ANGLE=',F8.3,' STEP=',F6.3,' TIME=',F5.1
     1,' CRYSTAL=',A4,' 2D=',F6.3)
      IF(IN.EQ.'DI') WRITE(8,61) ISM,NF,NB,ITGKA2,ITG,ND2,DR2L,NUM,IPF
   61 FORMAT(1X,'SM=',I2,2X,'BKGR=',2I2,2X,'KA2=',A2,2X,'TUBE=',A2,
     X2X,'ND2=',I2,2X,'SENS=',F4.1,2X,'NUM=',I2,2X,'PF=',I1)
      IF(IN.EQ.'XR')WRITE(8,62)ISM,NF,NB,ND2,DR2L,NUM,IPF
   62 FORMAT(1X,'SM=',I2,'  BKGR=',2I2,'  ND2=',I2,'  SENS='
     1,F4.1,'  NUM=',I2,'  PF=',I1)
      IF(IN.EQ.'XR')GO TO 200
C
      IF(JSH.NE.1) RETURN
      WRITE(8,9)
    9 FORMAT(/3X,'N   2THETA   DSPACE  (1/D**2)  HEIGHT     AREA',
     X'        P       W2       W4'/)
      GO TO 205
  200 CONTINUE
      WRITE(8,202)
  202 FORMAT(/3X,'N   2THETA    LAMDA   ENERGY    HEIGHT    AREA',
     1'        P       W2       W4'/)
  205 RETURN
      END
	SUBROUTINE OUTPT(THETA,WAVE,HEIGHT,NL,LSCR,LRES,MATCH,ERR
     %	,LUNO,LOUT)
	REAL*8 LINE(75),OUTLIN(12)
	DIMENSION THETA(100),WAVE(100),HEIGHT(100),W(75)
	INTEGER INT(75),OUTSYM(12)
	BYTE ORDER(12)
	OPEN(UNIT=LOUT,ACCESS='DIRECT',TYPE='SCRATCH',RECORDSIZE=34)
	DO 100 I=1,12
	ORDER(I)=0
	OUTSYM(I)=0
	OUTLIN(I)=0
100	CONTINUE
	DO 120 I=1,NL
	II=I
120	WRITE(LOUT'II)ORDER,OUTSYM,OUTLIN
	DO 300 I=1,MATCH
	READ(LSCR)IZ,W,INT,LINE,NLINE,NORD
	ISYM='  '
	CALL ZSYM(IZ,ISYM,LUNO)
	DO 200 K=1,NLINE
	W1=W(K)*NORD
	DO 150 L=1,NL
	LPT=L
	DELW=ABS(W1-WAVE(L))
	IF(DELW.LE.ERR)GO TO 170
150	CONTINUE
	GO TO 200
170	READ(LOUT'LPT)ORDER,OUTSYM,OUTLIN
	DO 180 L=1,12
	L2=L
	IF(OUTLIN(L).EQ.0)GO TO 190
180	CONTINUE
	GO TO 200
190	IF(ISYM.EQ.OUTSYM(L2-1))GO TO 200
	OUTLIN(L2)=LINE(K)
	ORDER(L2)=NORD+"60
	IF(NORD.EQ.1)ORDER(L2)=' '
	OUTSYM(L2)=ISYM
	WRITE(LOUT'LPT)ORDER,OUTSYM,OUTLIN
200	CONTINUE
300	CONTINUE
	DO 500 K=1,NL
	KK=K
	READ(LOUT'KK)ORDER,OUTSYM,OUTLIN
C
	DO 350, J=12,1,-1
	N=J
	IF (ORDER(J).NE.0) GOTO 360
350	CONTINUE
C
360	WRITE(LRES,9500)K,THETA(K),WAVE(K),HEIGHT(K),(ORDER(J),
     %	 OUTSYM(J),OUTLIN(J),J=1,N)
9500	FORMAT('0',I3,1X,F8.3,1X,F8.3,1X,F8.0,3X,4(A1,A2,1X,A8)/
     %	 34X,4(A1,A2,1X,A8)/34X,4(A1,A2,1X,A8))
500	CONTINUE
	CLOSE(UNIT=LOUT)
	RETURN
	END
	SUBROUTINE QED(FILE)
C***** PROGRAM TO MATCH ELEMENTAL PEAKS FROM XRF ********************
C
C       COPYRIGHT 1982 GENERAL ELECTRIC CO.
C       WRITTEN MARCH 1982 M.F.GARBAUSKAS
C
C     ADAPTED FROM 'XRFQED' APRIL 1982
C
C        PROGRAM USES PART OF NIH DATA BASE PACKED INTO
C        DIRECT ACCESS FILE 'XF1:LAMBDA.NIH' BY PROGRAM
C        'PACKNIH'
C
C        CUTOFF CONSTRAINTS:
C         MINIMUM RELATIVE INTENSITY: 0.06
C         MAXIMUM NUMBER OF LINES: 75
C         MAXIMUM WAVELENGTH: 25 ANGSTROMS
C
C
C        LOGICAL UNIT ASSIGNMENTS:
C           LSPEC:  FILE FOR INPUT ENERGIES FROM 'SPECPLOT'
C                    PASSED IN 'FILE'
C           LNIH:  'POWD:[PUBLIC.BASE.XRF]LAMBDA.NIH'  ELEMENTAL DATA BASE
C           LRES:  RESULTS FILE- NAMED FROM INPUT FILE IN 'NAME'
C           LUNI:  INPUT FILE 'POWD:[PUBLIC.BASE.XRF]SEEKQED.INP'
C           LSCR:  SCRATCH FILE 'XF1:QUAL.TMP'
C           LOUT:  OUTPUT SCRATCH FILE
C
C
C         EXTERNAL SUBROUTINES CALLED:
C          MINMAX   FIND   OUTPT   BSORT   LIMIT  ZSYM  NAME
C          RECALL
C
C******************************************************************
	DIMENSION THETA(100),WAVE(100),HEIGHT(100)
	BYTE DSN(30),DUMMY(80),FILE(30)
C
C  ASSIGN LOGICAL UNIT NUMBERS
C
	LSPEC=8
	LNIH=6
	LRES=9
	LUNI=1
	LSCR=10
	LOUT=11
	LUNO=2
	CALL NAME(FILE,DSN)
	REWIND LSPEC
C
	OPEN(UNIT=LRES,NAME=DSN,TYPE='NEW')
C   
C---READ HEADER INFORMATION AND TRANSFER TO RESULTS FILE
C       GET 2D FOR CRYSTAL
C  
	READ(LSPEC,9030,END=999)DUMMY
9030	FORMAT(80A1)
	WRITE(LRES,9030)DUMMY
	READ(LSPEC,9035,END=999)(DUMMY(I),I=1,62),TWOD
9035	FORMAT(62A1,F6.3)
	WRITE(LRES,9035)(DUMMY(I),I=1,62),TWOD
	READ(LSPEC,9030,END=999)DUMMY
	WRITE(LRES,9030)DUMMY
	READ(LUNI,9310,END=999)D2T
9310	FORMAT(F6.0)
	IF(D2T.EQ.0)D2T=.1
	WRITE(LRES,9311)D2T
9311	FORMAT(1X,'ERROR(DEG)=',F6.3)
	WRITE(LRES,9315)
9315	FORMAT('0',2X,'N',3X,'2THETA',3X,'LAMBDA',3X,'HEIGHT'
     %	 ,5X,'ELEMENTAL LINES MATCHED')
	DO 280 I=1,3
	READ(LSPEC,9030,END=999)DUMMY
280	CONTINUE
C
C---READ DATA FROM INPUT FILE    NL=LINE COUNTER
C
	NL=0
	DO 290 I=1,100
285	READ(LSPEC,9140,END=300)THETA(I),WAVE(I),HEIGHT(I)
9140	FORMAT(4X,2F9.0,9X,F9.0)
	IF(WAVE(I).EQ.0)GO TO 285
	NL=NL+1
290	CONTINUE
	CLOSE(UNIT=LSPEC)
300	OPEN(UNIT=LNIH,NAME='POWD:[PUBLIC.BASE.XRF]LAMBDA.NIH',
     %  ACCESS='DIRECT',
     %	RECORDSIZE=263,TYPE='OLD',READONLY,SHARED)
C  OPEN SCRATCH FILE
	OPEN(UNIT=LSCR,NAME='QUAL.TMP',FORM='UNFORMATTED',
     %  TYPE='SCRATCH',ACCESS='SEQUENTIAL')
C
C  CALCULATE ERROR IN WAVELENGTH (ASSUME COS(THETA)=1.0)
C
	ERR=0.008727*TWOD*D2T
C
	CALL MINMAX(WAVE,WMIN,WMAX,NL)
	WMIN=WMIN-ERR
	WMAX=WMAX+ERR
C
C--GET ORDER INFORMATION
C
	READ(LUNI,9410,END=999)MAXORD
9410	FORMAT(I1)
	IF(MAXORD.EQ.0)MAXORD=2
	READ(LUNI,9423,END=999)AKV
9423	FORMAT(F5.0)
	IF(AKV.EQ.0)AKV=50.
	NORD=1
	M=0
500	CALL FIND(WAVE,MATCH,ERR,WMIN,WMAX,NL,LNIH,LSCR,NORD,AKV)
	WRITE(LUNO,9500)MATCH,NORD
9500	FORMAT('  ** ',I3,' POSSIBLE ELEMENTS IDENTIFIED - ORDER: ',I2)
	NORD=NORD+1
	M=M+MATCH
	IF(NORD.GT.MAXORD)GO TO 520
C
C  ORDERS 2 AND 6 NOT ALLOWED FOR GERMANIUM CRYSTAL
C
	IF(TWOD.NE.6.532)GO TO 500
	IF(NORD.NE.2.AND.NORD.NE.6)GO TO 500
	NORD=NORD+1
C
	IF(NORD.LE.MAXORD)GO TO 500
C
C---WRITE RESULTS OF MATCH -- MAX OF 12 ELEMENTS PER MEASURED LINE
C
520	REWIND LSCR
	CALL OUTPT(THETA,WAVE,HEIGHT,NL,LSCR,LRES,M,ERR,LUNO,LOUT)
	CLOSE(UNIT=LRES)
	CLOSE(UNIT=LNIH)
	CLOSE(UNIT=LSCR)
999	RETURN
	END
      SUBROUTINE RBKGR(B,N,YMIN,YMAX,NF,NB) 
C                                                           ********** 
C                                                           ** RBKGR ** 
C                                                           ********** 
C A LINEAR LEAST SQUARE BACKGROUND SUBTRACT PROGRAM 
C THE PROGRAM USES A SLIDING APPROACH 
C A LEAST SQUARE LINE IS FITTED TO NF PTS OF THE DATA 
C THEN THE PTS THAT ARE SIGNIFICANTLY ABOVE THIS LINE 
C ARE EXCLUDED AND ANOTHER LEAST SQUARE FIT IS MADE 
C THIS IS REPEATED UNTIL THE LINE COE 
C BACKGROUND     THE BACKGROUND IS THEN SUBTRACTED FROM 
C NF-NB PTS AND ANOTHER FIT IS STARTED.  THEREFORE THE ACTUAL 
C BACKGROUND CAN BE FITTED BY MANY LINEAR SEGMENTS 
C THE OVERLAP IS PROVIDED FOR A SMOOTH TRANSITION OVER 
C THE DATA POINTS 
C  PROGRAM WAS WRITTEN BY RAY GOEHNER 
C NF NUMBER OF POINTS TO FIT LINEAR FUNCTION 
C NB NUMBER OF PTS TO OVERLAP BETWEEN FITS 
C INT NUMBER OF INTERATIONS ALLOWED 
C ISKIP NUMBER OF PTS TO SKIP 
C SENS SENSITIVITY FOR THE EXCLUSION OF PTS IN THE 2ND AND 
C UPPER PASSES OF THE FIT 
C ******************************************************** 
C *                                                      * 
      INTEGER*2 N,NF,NB,ISKIP,INT,NS,L 
      DIMENSION B(4096),BK(64) 
   96 WRITE(7,12) 
   12 FORMAT(1H$,'NUMBER OF 50PT BLOCKS FORWARD & BACK (0501) > ') 
      READ(5,10,END=9999) NF,NB 
   10 FORMAT(2I2) 
      INT=20 
      ISKIP=1 
      NNF=50*NF 
      NNB=50*NB 
      IF(NNF.EQ.0) NNF=N 
      IF(NNB.GE.NNF) GO TO 96 
        IF(NNF.GT.100) ISKIP=2 
      IF(NNF.GT.150) ISKIP=3 
      IF(NNF.GT.200) ISKIP=4 
      IF(NNF.GT.600) ISKIP=6 
      IF(NNF.GT.1000) ISKIP=8 
      IF(NNF.GT.2000) ISKIP=10
      SENS=1.0 
      AA=0.0 
      BB=0.0 
      NN=0 
      K=0
      NS=1 
      XMIN=YMIN 
      XMAX=YMAX 
   11 A1=0.0 
      B1=0.9*(XMAX-XMIN)+XMIN 
      NN=NN+NNF 
      IF(NN.GT.N) NN=N 
      DO 13 L=1,INT 
      Y=0.0 
      X=0.0 
      XY=0.0 
      XX=0.0 
      XN=0.0 
      DO 1 I=NS,NN,ISKIP 
      BX=B(I) 
      Z=I 
      ZZ=A1*Z+B1 
      ZZ=ABS(ZZ) 
      ZZ=ZZ+SQRT(ZZ)*SENS 
      IF(BX.GT.ZZ) GO TO 1 
      Y=Y+BX 
      X=X+Z 
      XY=XY+BX*Z 
      XX=XX+Z*Z 
      XN=XN+1.0 
    1 CONTINUE 
      IF(XN.LT.5.0) GO TO 20 
      DET=X*X-XN*XX 
      AA=(X*Y-XN*XY)/DET 
      BB=(X*XY-XX*Y)/DET 
      Z=ABS(AA-A1) 
      ZZ=ABS(BB-B1) 
      IF(Z.LT.0.01.AND.ZZ.LT.1.0) GO TO 20 
      A1=AA 
   13 B1=BB 
   20 CONTINUE 
   31 FORMAT(1X,'ERROR IN BKGR') 
      L=NN-NNB 
      IF(XN.LT.5.0) GO TO 40 
      IF(NN.EQ.N) L=N 
      DO 14 I=NS,L 
      X=I 
      BG=AA*X+BB 
      BX=B(I) 
      IF(BG.LT.XMIN) BG=XMIN 
      B(I)=BX-BG 
      K=K + 1
      BK(K)=BG
      IF(K.NE.64.AND.I.NE.N)GO TO 14
      IF(K.EQ.64)GO TO 2
      GO TO 3
    2 K=0
      GO TO 14
    3 K=K + 1
      GO TO 2
   14 CONTINUE 
   40 IF(NN.EQ.N) GO TO 95 
      NN=L 
      NS=NN+1 
      GO TO 11 
   95 CONTINUE
      NF=99
      RETURN
 9999 STOP
      END 
	SUBROUTINE RECALL(LRES,DSN,IDONE)
C
C  SEE IF FILE DSN EXISTS - SET IDONE=1 IF FILE EXISTS
C
	BYTE DSN(30)
C
C  TURN OFF MESSAGE FOR 'NO SUCH FILE'
C
	CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.,31)
C
	CALL CLOSE(LRES)
	OPEN(UNIT=LRES,NAME=DSN,TYPE='OLD',ERR=900)
	CLOSE(UNIT=LRES)
	IDONE=1
	GO TO 905
900	CALL ERRTST(29,J)  !IS IT 'NO SUCH FILE' ERROR?
	IF(J.NE.1)GO TO 999   !NO - SOMETHING ELSE HAPPENED
	IDONE=0
	CALL CLOSE(LRES)
C
C  TURN MESSAGE BACK ON
C
905	CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.TRUE.,31)
C
	RETURN
999	STOP
	END

      SUBROUTINE SEARCH(B,JN,DX,YCR,SS,SENS,IPX,IWDL,IWDR,NWD,IN
     &,ND2,DR2L,NUM,IPF,ITG,XL,ISM,NF,NB,ITGKA2,AM)
C                                                           **********
C                                                           **SEARCH**
C                                                           **********
C SEARCH DOES A SECOND DIFFERENCE SEARCH FOR PEAKS
C SEARCH IS A SUBROUTINE OF DIFPLOT
C WRITTEN BY RAY GOEHNER (GE) AND MODIFIED BY TERRY QUICK (LLL)
      DIMENSION AWD(10),A(25),B(4096),IPX(100),IWDL(10),IWDR(10)
      DATA I3,I5/2*0/
      IF(IN.EQ.'XR')GO TO 200
      WRITE(7,8)
    8 FORMAT(/2X,' N 2THETA DSPACE HEIGHT   AREA    W4'/)
      GO TO 205
  200 WRITE(7,201)
  201 FORMAT(/2X,' N 2THETA LAMDA      HEIGHT    W4'/)
  205 XND2=0.0
C NDV IS NUMBER OF PTS IN DEAD VOLUME
      NDV=20
      DO 75 JJ=1,NWD
   75 AWD(JJ)=0.0
      DO 2 JJ=1,60
    2 IPX(JJ)=-1
      ALI=9999999.
      NN=0
      DRL=0.0
      DRC=0.0
      BK=0.0
      N=0
      IST=1
      IB=0
      M2=ND2/2
      L=-M2
      AREA=0.0
      M=0
      X=0.0
      AL=4100.0
      M3=M2+1
      XM2=M2
      M4=ND2-1
      JAA=0
      D2PK=0.0
      CAREA=0.0
      LSP=0
      PK=0.0
      SDB=SQRT(ABS(AM))
      SA=SDB
      DM=0.0
      SD=SDB/FLOAT(10*ND2)
      SDM=DR2L
      DR2L=-DR2L*SD

C SA STANDARD DEVIATION IN BACKGROUND (BKGR)
C AM MEAN OF BKGR
C DM MEAN OF 2ND DIFFERENCE
C SD STANDARD DEVIATION OF 2ND DIFFERENCE OVER BKGR
C SDM REAL DATA SENSITIVITY
C DR2L 2ND DIFF SENSITIVITY
C NUM NUMBER OF DECREASING PTS IN 2ND DIFF SIGNAL

C ****************************************************
C *********** WORKING PORTION ***********************
C DO LOOP IS EXECUTED ONLY 1ST TIME
C I.E. IST=ND2 AFTER 1ST TIME
C THIS IS DONE TO LOAD A FOR THE CALCULATION
C OF D2 AT M3
      JPF=IPF/2
      LPF=JN+JPF
   16 DO 18 I=IST,ND2
      NN=NN+1
      L=L+1
      IF(NN.GT.JN) GO TO 95
      A(I)=B(NN)
C ******* XC IS CURRENT X VALUE *****************
      XC=SS+DX*(X-XM2)
      X=X+1.0
   18 CONTINUE
      IST=ND2
C THE REAL DATA COULD BE SMOOTHED HERE
      CALL DER2(A,D2,ND2)
C *******************************************************
C ********************************************************
C FIND THE WINDOWED AREAS
C *************************************************
C ******  H IS HEIGHT ABOVE MEAN OF DEAD VOLUME  ***********
   66 H=A(M3)
      IF(NWD.EQ.0) GO TO 60
      DO 74 JJ=1,NWD
      IF(NN.LT.IWDL(JJ)) GO TO 74
      IF(NN.GT.IWDR(JJ)) GO TO 74
      AWD(JJ)=AWD(JJ)+H*DX*YCR
   74 CONTINUE
   60 DRC=D2
      AL=A(M3)
C ************************************************************
C FIND PEAKS BY THEIR 2ND DERIVATIVES
      IF(AL.GT.ALI) GO TO 31

C DRC  CURRENT 2ND DIFF
C DRL  LAST 2ND DIFF

      IF(DRC.LT.0.0) GO TO 20
      GO TO 31
   20 IF(DRC.GE.DRL) GO TO 30
      XX=XC
C IF YOU WANT HEIGHT AT 2ND DERIVATIVE MINIUM REMOVE
C BOTH (H.GT.PK) PK=H STATEMENTS
      IF(H.GT.PK) PK=H
C PK=H
      PPK=H
      JPK=NN-M2
      AREA=AREA+DRC
      CAREA=CAREA+H
      D2PK=DRC
      N=N+1
      GO TO 33
   30 IF(N.LT.NUM) GO TO 31
      IF(D2PK.GT.DR2L) GO TO 31
      IF(H.GT.PK) PK=H
   71 IF(PK.LE.(SDM*SA)) GO TO 31
C  NO PEAK IF LESS THAN ONE STANDARD DEVIATION OF BACKGROUND
      IF(SDM.LT.1.0.AND.PK.LT.SA) GO TO 31
      IF(AREA.GT.-1.0) GO TO 31
      P=-2.0*.51*AREA*FLOAT(N)
      IF(P.LE.(SDM*SA)) GO TO 31
      P=P*YCR
C THE AREA UNDER THE PEAK HAS TO BE > 1 COUNT
      IF(CAREA.LE.1.0) GO TO 31
C HALF BREADTH BY ZERO OF 2ND DERIVATIVE
      W2A=2.0*1.1744*DX
      W2=W2A*FLOAT(N-1)
      CAREA=W2A*YCR*CAREA
      DE=XX
C   FIND TOP OF THE PEAK
      IF(IPF.EQ.0)GO TO 76
      ZMAX=-32000.
      IJ1=JPK - 1
      IJ2=JPK + 1
      DO 77 IJP=IJ1,IJ2
      IF(B(IJP).LT.ZMAX)GO TO 77
      ZMAX=B(IJP)
      JPK=IJP
   77 CONTINUE
C  IPF CENTROID TYPE FIT
  100 IF(JPK.LE.JPF)GO TO 140
      IF(JPK.GE.LPF)GO TO 140
      IJ1=JPK-JPF !JPK PK POSITION JPF=IPF/2
      IJ2=JPK+JPF
      XI=0.0
      XX=0.0
      DO 110 I=IJ1,IJ2
      XI=XI+B(I)
  110 XX=XX+B(I)*(FLOAT(I-1)*DX+SS)
      DE=XX/XI
      GO TO 76
  140 WRITE(7,3) DE,XC
    3 FORMAT(/1X,'PEAK NEAR ',F6.3,
     X' DEG CANNOT BE FIT .'/1X,
     X'IT IS TOO CLOSE TO THE EDGE OF THE PATTERN.'/1X,
     X'A 2THETA VALUE OF ',F6.3,' DEG WILL BE USED.'/)
      DE=XC
   76 I3=0
      I5=0
      PK=PK*YCR
      IF(DE.LE.0.0) GO TO 31
      IF(DE.GE.180.0) GO TO 31
      IF(IN.EQ.'XR') GO TO 210
C  SDE BECOMES LAMDA INSTEAD OD DSPACE FOR XRF SPECTRUM
      SDE=XL/(2.0*SIN(0.008726646*DE))
      GO TO 211
  210 SDE=XL*SIN(0.008726646*DE)
  211 W4=CAREA/PK
      M=M+1
      IPX(M)=JPK
      IF(M.GT.100) GO TO 95
      IF(IN.EQ.'DI') WRITE(7,11) M,DE,SDE,PK,CAREA,W4
   11 FORMAT(1X,I3,F7.2,F7.3,F7.0,F7.1,F6.2)
      IF(IN.EQ.'XR') WRITE(7,203) M,DE,SDE,PK,W4
      Q=1.0/(SDE*SDE)
      IF(IN.EQ.'XR') Q=12.4/SDE
  203 FORMAT(1X,I3,F7.2,F7.3,F11.0,F6.2)
      WRITE(8,5) M,DE,SDE,Q,PK,CAREA,P,W2,W4
    5 FORMAT(1X,I3,F9.3,2F9.4,3F9.1,2F9.3)
   31 N=0
      AREA=0.0
      CAREA=0.0
      PK=0.0
      D2PK=0.0
C ******************************************************
   33 DO 34 I=1,M4
      J=I+1
   34 A(I)=A(J)
      DRL=DRC
      GO TO 16
   95 CONTINUE
      IF(NWD.EQ.0) GO TO 181
      WRITE(8,183)
      WRITE(7,183)
  183 FORMAT(12X,'WDL',12X,'WDR',11X,'AREA')
      DO 180 I=1,NWD
      SSA=IWDL(I)
      SSA=SS+SSA*DX
      SSD=IWDR(I)
      SSD=SS+SSD*DX
      WRITE(8,182) SSA,SSD,AWD(I)
  180 WRITE(7,182) SSA,SSD,AWD(I)
  182 FORMAT(1X,3F15.1)
  181 CONTINUE
      WRITE(7,78) AM,SA,DM,SD
   78 FORMAT(1X,'MEAN Y=',F10.3,' +OR- ',E9.3,
     &'  MEAN D2Y=',F10.4,' +OR- ',E9.3)
      RETURN
      END
      SUBROUTINE SFNAME(SNUM,MON,DATE,YEAR,INST,TIT,T0,DX,DY
     1,CRY,DSPACE,ITG,XL,NFILE,IFLAG,ICOUNT,FILE)
C
C   READ IN NEEDED INFORMATION FROM SPECPLOT TYPE FILE
C
C  IFLAG=0  IF FILENAME TO BE PROCESSED NOT IN SP0:FINDFILE.SPC
C  ICOUNT  MAXTIME COUNTER   IE DO NOT GO ON FOREVER
C
      INTEGER DATE,YEAR,SNUM
      DIMENSION TIT(12),INST(2)
      BYTE FILE(30),DSN(30)
C
      IFLAG=0
      IDONE=0
C
      REWIND 4
C
C    GET DATA FILE
C
    1 DO 10 I=1,NFILE
   10 READ(4,15,END=99) J
      READ(4,20,END=999) IQ,FILE
   15 FORMAT(A1)
   20 FORMAT(Q,30A1)
   21 FILE(IQ+1)=0
      CALL NAMSPC(FILE,DSN)
      CALL RECALL(8,DSN,IDONE)
      IF(IDONE.NE.1) GO TO 22
      NFILE=NFILE+1
      REWIND 4
      GO TO 1
   22 OPEN(UNIT=3,NAME=FILE,TYPE='OLD',ACCESS='SEQUENTIAL'
     1,FORM='UNFORMATTED',SHARED,READONLY,ERR=9999)
      READ(3,ERR=9000) SNUM,MON,DATE,YEAR,INST
C
C  FILE NOW WILL BE PROCESSED
C  
C
      IFLAG=1
      NFILE=NFILE+1
      REWIND 3
      IF(INST(1).EQ.'DI') READ(3,ERR=30) SNUM,MON,DATE,YEAR,INST,TIT
     1,T0,DX,DY,ITG,XL
      IF(INST(1).EQ.'XR') READ(3,ERR=9000) SNUM,MON,DATE,YEAR,INST
     1,TIT,T0,DX,DY,CRY,DSPACE
      ICOUNT=0
      RETURN
   30 REWIND 3
      WRITE(2,40)
   40 FORMAT(1X,'TUBE & WAVELENGHTH NOT IN FILE DEFAULT VALUES USED')
      READ(3,ERR=9000) SNUM,MON,DATE,YEAR,INST,TIT,T0,DX,DY
      ITG='CU'
      XL=1.5405981
      ICOUNT=0
      RETURN
  999 CONTINUE
      CALL CLOSE(3)
      CALL CLOSE(4)
      IFLAG=0
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.1) GO TO 9
C      CALL WAIT(5,3,ISTAT)
      RETURN
   99 WRITE(2,50)
   50 FORMAT(1X,'PROBLEM WITH SP0:FINDFILE.INP')
      WRITE(2,51) NFILE,FILE,IDONE
   51 FORMAT(1X,'NFILE=',I3,'  LAST FILE=',30A1,'  IDONE=',I2)
      STOP
    9 WRITE(2,60) ICOUNT
   60 FORMAT(1X,'PROGRAM TIMED OUT AFTER ',I2,'  WAITS')
      STOP
 9999 WRITE(2,70)
   70 FORMAT(1X,'BLANK FILE NAME')
      STOP
 9000 WRITE(2,80) FILE
   80 FORMAT(1X,'PROBLEM READING  ',2X,30A1)
      STOP
      END
      SUBROUTINE ZSYM(IZ,ELEM,LUTI)
C
C   PROGRAM TO CONVERT ELEMENT SYMBOL TO ATOMIC NUMBER IF ELEM IS BLANK
C   OR CONVERT ATOMIC NUMBER IF IZ IS ZERO
C
      INTEGER*2 IZ,ELEM,D(104)
C
      IF(IZ.EQ.0.AND.ELEM.EQ.'  ') GO TO 999
      IF(IZ.GT.104) GO TO 990
      D(1)='H '
      D(2)='HE'
      D(3)='LI'
      D(4)='BE'
      D(5)='B '
      D(6)='C '
      D(7)='N '
      D(8)='O '
      D(9)='F '
      D(10)='NE'
      D(11)='NA'
      D(12)='MG'
      D(13)='AL'
      D(14)='SI'
      D(15)='P '
      D(16)='S '
      D(17)='CL'
      D(18)='AR'
      D(19)='K '
      D(20)='CA'
      D(21)='SC'
      D(22)='TI'
      D(23)='V '
      D(24)='CR'
      D(25)='MN'
      D(26)='FE'
      D(27)='CO'
      D(28)='NI'
      D(29)='CU'
      D(30)='ZN'
      D(31)='GA'
      D(32)='GE'
      D(33)='AS'
      D(34)='SE'
      D(35)='BR'
      D(36)='KR'
      D(37)='RB'
      D(38)='SR'
      D(39)='Y '
      D(40)='ZR'
      D(41)='NB'
      D(42)='MO'
      D(43)='TC'
      D(44)='RU'
      D(45)='RH'
      D(46)='PD'
      D(47)='AG'
      D(48)='CD'
      D(49)='IN'
      D(50)='SN'
      D(51)='SB'
      D(52)='TE'
      D(53)='I '
      D(54)='XE'
      D(55)='CS'
      D(56)='BA'
      D(57)='LA'
      D(58)='CE'
      D(59)='PR'
      D(60)='ND'
      D(61)='PM'
      D(62)='SM'
      D(63)='EU'
      D(64)='GD'
      D(65)='TB'
      D(66)='DY'
      D(67)='HO'
      D(68)='ER'
      D(69)='TM'
      D(70)='YB'
      D(71)='LU'
      D(72)='HF'
      D(73)='TA'
      D(74)='W '
      D(75)='RE'
      D(76)='OS'
      D(77)='IR'
      D(78)='PT'
      D(79)='AU'
      D(80)='HG'
      D(81)='TL'
      D(82)='PB'
      D(83)='BI'
      D(84)='PO'
      D(85)='AT'
      D(86)='RN'
      D(87)='FR'
      D(88)='RA'
      D(89)='AC'
      D(90)='TH'
      D(91)='PA'
      D(92)='U '
      D(93)='NP'
      D(94)='PU'
      D(95)='AM'
      D(96)='CM'
      D(97)='BK'
      D(98)='CF'
      D(99)='ES'
      D(100)='FM'
      D(101)='MD'
      D(102)='NO'
      D(103)='LW'
      D(104)='LN'  ! ALL RARE EARTHS ALA JCPDS
C
      IF(ELEM.NE.'  ') GO TO 100
      ELEM=D(IZ)
      RETURN
  100 DO 200 I=1,104
  200 IF(ELEM.EQ.D(I)) IZ=I
      IF(ELEM.EQ.'D ')IZ=1
      RETURN
  999 WRITE(LUTI,300)
  300 FORMAT(1X,'WHICH ONE DO YOU WANT Z OR ELEM SHOULD I GUESS ?')
      STOP
  990 WRITE(LUTI,400)
  400 FORMAT(1X,'ATOMIC NUMBER OUT OF RANGE')
      STOP
      END
