C*******************************************************************
C
C   PROGRAM ELF
C
C   RETRIEVE AND DISPLAY X-RAY LINES FROM NIH ELEMENTAL DATA BASE
C         PACKED AS DIRECT ACCESS FILE 'POWD:[PUBLIC.BASE.XRF]LAMBDA.NIH'
C         OR ABSORPTION EDGES PACKED IN 'POWD:[PUBLIC.BASE.XRF]EDGES.NIH'
C
C    COPYRIGHT 1982 GENERAL ELECTRIC CO.
C       WRITTEN APRIL 1982   M.F.GARBAUSKAS
C
C    DATA BASE RESTRICTIONS:
C     LINES:
C     NO. OF LINES PER ELEMENT: 75
C     MAX. WAVELENGTH PACKED: 25 ANGSTROMS
C     MIN. RELATIVE INTENSITY: .06
C     ABSORPTION EDGES:
C     NO. OF EDGES PER ELEMENT: 15
C     MAX.WAVELENGTH PACKED: 25 ANGSTROMS
C
C     LOGICAL UNIT DESIGNATIONS:
C       LUNP:  PROMPTING DEVICE
C       LUNI:  INPUT DEVICE
C       LUNO:  OUTPUT DEVICE
C       LNIH:  'POWD:[PUBLIC.BASE.XRF]LAMBDA.NIH'   ELEMENTAL DATA BASE
C              'POWD:[PUBLIC.BASE.XRF]EDGES.NIH'   ABSORPTION EDGES
C
C      EXTERNAL SUBROUTINES REFERENCED:
C        RDNIH  ANGLE  ENERGY  WAVE  ZSYM  ASIN  SHOW  GET2D  RDEDGE
C
C      TASKBUILD OPTIONS:
C        MAXBUF=1100.
C
C*************************************************************************
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75)
	DATA LUNI/5/,LUNO/5/,LUNP/5/,LNIH/1/
100	WRITE(LUNP,9100)
9100	FORMAT('$ ENTER ELEMENT SYMBOL <CTRL Z> WHEN DONE>')
	READ(LUNI,9110,END=999)ISYM
9110	FORMAT(A2)
	IF(ISYM.EQ.'  ')GO TO 999
	IZ=0
	CALL ZSYM(IZ,ISYM,LUNO)
	IF(IZ.LT.8.OR.IZ.GT.98)GO TO 100
110	WRITE(LUNP,9115)
9115	FORMAT('  INFORMATION: 1: LINES',/15X,'2: ABSORPTION EDGES')
	WRITE(LUNP,9122)
	READ(LUNI,*,END=999)INFO
	IF(INFO.NE.1.AND.INFO.NE.2)GO TO 110
	IF(INFO.EQ.1)CALL RDNIH(IZ,LNIH,LUNO,LINE,WL,RELINT,NLINE)
	IF(INFO.EQ.2)CALL RDEDGE(IZ,LNIH,LUNO,LINE,WL,NLINE)
120	WRITE(LUNP,9120)
9120	FORMAT('  DISPLAY MODE: 1: WAVELENGTH',/16X,'2: ENERGY',/16X
     %	 ,'3: TWO-THETA')
	WRITE(LUNO,9122)
9122	FORMAT('$ >')
	READ(LUNI,*,END=999)MODE
	IF(MODE.LT.1.OR.MODE.GT.3)GO TO 120
	IF(MODE.EQ.1)CALL WAVE(IZ,ISYM,LUNO,LINE,WL,RELINT,NLINE)
	IF(MODE.EQ.2)CALL ENERGY(IZ,ISYM,LUNO,LINE,WL,RELINT,NLINE)
	IF(MODE.EQ.3)CALL ANGLE(IZ,ISYM,LUNI,LUNO,LUNP,LINE,WL
     %	 ,RELINT,NLINE)
	IF(INFO.EQ.1)CALL SHOW(LUNO,LINE,WL,RELINT,NLINE)
	IF(INFO.EQ.2)CALL SHOW2(LUNO,LINE,WL,NLINE)
	READ(LUNI,9900,END=999)IANS
9900	FORMAT(A2)
	GO TO 100
999	STOP
	END
	SUBROUTINE ANGLE(IZ,ISYM,LUNI,LUNO,LUNP,LINE,WL,RELINT,NLINE)
C
C  OUTPUTS DATABASE INFO AS 2-THETA
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75)
	CALL GET2D(LUNI,LUNP,TWOD)
	WRITE(LUNP,9000)
9000	FORMAT('$ ENTER ORDER DESIRED [ D:1  MAX:9 ]>')
	READ(LUNI,9010,END=999)NORD
9010	FORMAT(I1)
	IF(NORD.EQ.0)NORD=1
	DO 100 I=1,NLINE
	X=NORD*WL(I)/TWOD
	IF(X.GE.0.AND.X.LE.1.)GO TO 110
	WL(I)=0.
	GO TO 100
110	WL(I)=2.*57.296*ASIN(X)
100	CONTINUE
	WRITE(LUNO,9100)ISYM,IZ,TWOD,NORD
9100	FORMAT(1X,' ELEMENT: ',A2,3X,' AT.NO.: ',I3,3X,'TWO-THETA'
     %	 ,3X,'2D= ',F6.3,3X,'ORDER= ',I1)
	RETURN
999	STOP
	END
	SUBROUTINE ENERGY(IZ,ISYM,LUNO,LINE,WL,RELINT,NLINE)
C
C  OUTPUTS DATABASE INFO AS ENERGY (KEV)
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75)
	WRITE(LUNO,9100)ISYM,IZ
9100	FORMAT(1X,' ELEMENT: ',A2,3X,' AT.NO.: ',I3,3X,'ENERGY (KEV)')
	DO 100 I=1,NLINE
	WL(I)=12.396/WL(I)
100	CONTINUE
	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 RDEDGE(IZ,LNIH,LUNO,LINE,WL,NLINE)
C
C  READS NIH ABSORPTION EDGES PACKED AS DIRECT ACCESS FILE
C     'POWD:[PUBLIC.BASE.XRF]EDGES.NIH'
C
	REAL*8 LINE(75),L(15)
	DIMENSION WL(75),W(15)
	OPEN(UNIT=LNIH,NAME='POWD:[PUBLIC.BASE.XRF]EDGES.NIH',
     %  ACCESS='DIRECT',
     %	TYPE='OLD',SHARED,READONLY,RECORDSIZE=46)
	NREC=IZ-7
	READ(LNIH'NREC,ERR=999)INO,W,L
	CLOSE(UNIT=LNIH)
	IF(INO.NE.IZ)GO TO 900
	NLINE=0
	DO 200 I=1,15
	IF(W(I).EQ.0.)GO TO 800
	NLINE=NLINE+1
	WL(I)=W(I)
	LINE(I)=L(I)
200	CONTINUE
800	RETURN
900	WRITE(LUNO,9900)IZ,INO
9900	FORMAT('0 *ERROR READING ELEMENT',I3,' FOUND ELEMENT',I3)
999	STOP
	END
	SUBROUTINE RDNIH(IZ,LNIH,LUNO,LINE,WL,RELINT,NLINE)
C
C  READS NIH ELEMENTAL DATA BASE PACKED AS DIRECT ACCESS FILE
C     'POWD:[PUBLIC.BASE.XRF]LAMBDA.NIH'
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75)
	INTEGER INT(75)
	OPEN(UNIT=LNIH,NAME='POWD:[PUBLIC.BASE.XRF]LAMBDA.NIH',
     %	 ACCESS='DIRECT',TYPE='OLD',SHARED,READONLY,RECORDSIZE=301)
	NREC=IZ-7
	READ(LNIH'NREC,ERR=999)INO,WL,INT,LINE
	CLOSE(UNIT=LNIH)
	IF(INO.NE.IZ)GO TO 900
	NLINE=0
	DO 200 I=1,75
	IF(WL(I).EQ.0.)GO TO 800
	NLINE=NLINE+1
	RELINT(I)=INT(I)/100.
200	CONTINUE
800	RETURN
900	WRITE(LUNO,9900)IZ,INO
9900	FORMAT('0 *ERROR READING ELEMENT',I3,' FOUND ELEMENT',I3)
999	STOP
	END
	SUBROUTINE SHOW(LUNO,LINE,WL,RELINT,NLINE)
C
C  OUTPUTS DATABASE INFO 
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75)
	N1=NLINE-46
	N2=NLINE-23
	IF(N1.LT.0)N1=0
	IF(N2.LT.0)N2=0
	IF(N1.LE.0)GO TO 300
	DO 200 I=1,N1
	IF(I.EQ.23)GO TO 180
	WRITE(LUNO,9200)LINE(I),WL(I),RELINT(I),LINE(I+23),WL(I+23)
     %	 ,RELINT(I+23),LINE(I+46),WL(I+46),RELINT(I+46)
9200	FORMAT(1X,3(A8,F7.3,1X,F6.2,2X))
	GO TO 200
180	WRITE(LUNO,9210)LINE(I),WL(I),RELINT(I),LINE(I+23),WL(I+23)
     %	 ,RELINT(I+23),LINE(I+46),WL(I+46),RELINT(I+46)
9210	FORMAT('$',3(A8,F7.3,1X,F6.2,2X))
	GO TO 460
200	CONTINUE
300	IF(N2.LE.0)GO TO 400
	IF(N2.GT.23)N2=23
	N1=N1+1
	DO 350 I=N1,N2
	IF(I.EQ.23)GO TO 330
	WRITE(LUNO,9200)LINE(I),WL(I),RELINT(I),LINE(I+23),WL(I+23)
     %	 ,RELINT(I+23)
	GO TO 350
330	WRITE(LUNO,9210)LINE(I),WL(I),RELINT(I),LINE(I+23),WL(I+23)
     %	 ,RELINT(I+23)
	GO TO 460
350	CONTINUE
400	NEND=23
	N2=N2+1
	IF(NLINE.LE.23)NEND=NLINE
	IF(N2.GE.NEND)GO TO 460
	DO 450 I=N2,NEND
	IF(I.EQ.23)GO TO 430
	WRITE(LUNO,9200)LINE(I),WL(I),RELINT(I)
	GO TO 450
430	WRITE(LUNO,9210)LINE(I),WL(I),RELINT(I)
	GO TO 460
450	CONTINUE
460	RETURN
	END
	SUBROUTINE SHOW2(LUNO,LINE,WL,NLINE)
C
C  DISPLAYS ABSORPTION EDGES
C
	REAL*8 LINE(75)
	DIMENSION WL(75)
	WRITE(LUNO,9000)
9000	FORMAT(10X,'ABSORPTION EDGES')
	DO 200 I=1,NLINE
	II=I
	WRITE(LUNO,9200)LINE(II),WL(II)
9200	FORMAT(3X,A8,3X,F7.3)
200	CONTINUE
	RETURN
	END
	SUBROUTINE WAVE(IZ,ISYM,LUNO,LINE,WL,RELINT,NLINE)
C
C  OUTPUTS DATABASE INFO AS WAVELENGTH
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75)
	WRITE(LUNO,9100)ISYM,IZ
9100	FORMAT(1X,' ELEMENT: ',A2,3X,' AT.NO.: ',I3,3X,'WAVELENGTHS')
	RETURN
	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
