C   ALPIR
C  PROGRAM TO LIST ALL LINES POSSIBLE AT A PARTICULAR POSITION
C    FOR QUALITATIVE ELEMENTAL ANALYSIS
C
C  COPYRIGHT 1982 GENERAL ELECTRIC CO.
C    PROGRAM WRITTEN APRIL 1982 BY MARY GARBAUSKAS
C
C  PROGRAM ACCESSES NIH ELEMENTAL DATA BASE ORDERED BY WAVELENGTH
C    AND PACKED AS DIRECT ACCESS FILE powd:[public.base.xrf]WAVELH.NIH'
C
C  LOGICAL UNIT ASSIGNMENTS:
C    LUNP:  PROMPTING DEVICE
C    LUNI:  INPUT DEVVICE
C    LUNO:  OUTPUT DEVICE
C    LNIH:  ELEMENTAL DATA BASE 'XF1:[220,300]WAVELH.NIH'
C
C  EXTERNAL SUBROUTINE REFERENCES
C    CHANGE  RDWAVE  BINARY  SHOW  GET2D  ASIN
C
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RELINT(75),ISYM(75)
	DATA LUNI/5/,LUNO/5/,LUNP/5/,LNIH/1/
100	WRITE(LUNP,9100)
9100	FORMAT('$ ENTER POSITION OF LINE >')
	READ(LUNI,9105,END=999,ERR=100)PLINE
9105	FORMAT(F12.0)
	IF(PLINE.EQ.0.)GO TO 999
	WRITE(LUNP,9110)
9110	FORMAT('  UNITS FOR ENTERED POSITION: 1 - ANGSTROMS',/
     %	 30X,'2 - KEV',/30X,'3 - DEGREES (2-THETA)')
	WRITE(LUNP,9120)
9120	FORMAT('$ >')
	READ(LUNI,*,END=999)LUNITS
	WRITE(LUNP,9150)
9150	FORMAT('$ ENTER RANGE (+/-) TO BE DISPLAYED>')
	READ(LUNI,*,END=999)RANGE
	VLOW=PLINE-RANGE
	VHI=PLINE+RANGE
	IF(LUNITS.NE.2)GO TO 200
       V=VHI
	VHI=12.396/VLOW
	VLOW=12.396/V
	GO TO 300
200	IF(LUNITS.NE.3)GO TO 300
	CALL GET2D(LUNI,LUNP,TWOD)
	WRITE(LUNP,9200)
9200	FORMAT('$ ENTER ORDER [ D:1 MAX:9 ]>')
	READ(LUNI,9210,END=999)NORD
9210	FORMAT(I1)
	IF(NORD.EQ.0)NORD=1
	VLOW=TWOD*SIN(VLOW*0.0087265)/NORD
	VHI=TWOD*SIN(VHI*0.0087265)/NORD
300	WRITE(LUNP,9250)
9250	FORMAT('$ ENTER MIN. INTENSITY CUTOFF [ D:1.]>')
	READ(LUNI,9255,END=999)CUT
9255	FORMAT(F6.0)
	IF(CUT.EQ.0)CUT=1.0
	OPEN(UNIT=LNIH,NAME='POWD:[PUBLIC.BASE.XRF]WAVELH.NIH',
     %	 TYPE='OLD' ,ACCESS='DIRECT',RECORDSIZE=6,SHARED,READONLY)
CPDP11	OPEN(UNIT=LNIH,NAME='XF1:[220,300]WAVELH.NIH',TYPE='OLD'
CPD11     %	 ,ACCESS='DIRECT',RECORDSIZE=5,SHARED,READONLY)
	NUMBER=3104
	CALL BINARY(LUNO,LNIH,VLOW,NUMBER,NREC)
	CALL RDWAVE(LUNO,LNIH,VHI,NREC,LINE,WL,RELINT,ISYM,NLINE,CUT)
	CLOSE(UNIT=LNIH)
	CALL CHANGE(LUNITS,WL,NLINE,TWOD,NORD)
	IF(LUNITS.EQ.1)WRITE(LUNO,9400)PLINE,RANGE
9400	FORMAT(3X,F8.4,' +/-',F6.4,' ANGSTROMS')
	IF(LUNITS.EQ.2)WRITE(LUNO,9410)PLINE,RANGE
9410	FORMAT(3X,F8.4,' +/-',F6.4,' KEV')
	IF(LUNITS.EQ.3)WRITE(LUNO,9420) PLINE,RANGE
9420	FORMAT(3X,F7.3,' +/-',F5.3,' DEGREES 2-THETA')
	CALL SHOW3(LUNO,LINE,WL,RELINT,ISYM,NLINE)
	READ(LUNI,9900,END=999)IANS
9900	FORMAT(A2)
	GO TO 100
999	STOP
	END
	SUBROUTINE BINARY(LUNO,LNIH,VLOW,NUMBER,NREC)
C
C  BINARY SEARCH OF UNIT 'LNIH' WITH 'NUMBER' DIRECT ACCESS RECORDS
C   FOR VALUE 'VLOW' - RETURNS RECORD NUMBER 'NREC'
C
C  SET UP FOR 'ALPIR'
C
	REAL*8 L
	NST=0
	NEND=NUMBER
	NOLD=0
100	IPTR=(NEND-NST)/2
	IREC=NST+IPTR
	READ(LNIH'IREC,ERR=999)IZ,IEL,L,W,R
	IF(W.EQ.VLOW)GO TO 900
	IF(IREC.EQ.NOLD)GO TO 900
	NOLD=IREC
	IF(W.GT.VLOW)NEND=IREC
	IF(W.LT.VLOW)NST=IREC
	IF(NST.EQ.NEND)GO TO 900
	GO TO 100
900	NREC=IREC
	RETURN
999	WRITE(LUNO,9900)IREC
9900	FORMAT(' ** ERROR READING RECORD NUMBER ',I6)
	STOP
	END
	SUBROUTINE CHANGE(LUNITS,WL,NLINE,TWOD,NORD)
C
C  CHANGES UNITS OF WAVELENGTH TO EITHER ENERGY OR 2-THETA DEPENDING
C   ON VALUE OF LUNITS
C
	DIMENSION WL(75)
	IF(LUNITS.EQ.1)GO TO 900   !UNITS SHOULD BE WAVELENGTH
	IF(LUNITS.EQ.3)GO TO 300
C  CHANGE TO ENERGY
	DO 200 I=1,NLINE
	WL(I)=12.396/WL(I)
200	CONTINUE
	GO TO 900
C  CHANGE TO 2-THETA
300	DO 400 I=1,NLINE
	X=NORD*WL(I)/TWOD
	IF(X.GE.0.AND.X.LE.1.)GO TO 310
	WL(I)=0.
	GO TO 400
310	WL(I)=2.*57.296*ASIN(X)
400	CONTINUE
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 RDWAVE(LUNO,LNIH,VHI,NREC,LINE,WL,RINT,ISYM,NLINE
     %	 ,CUT)
C
C  READS 'XF1:[220,300]WAVELH.NIH' FROM RECORD NREC UNTIL IT REACHES VHI
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RINT(75),ISYM(75)
	N=1
	NLINE=0
125	READ(LNIH'NREC,ERR=900)IZ,ISYM(N),LINE(N),WL(N),RINT(N)
	IF(WL(N).GT.VHI)GO TO 900
	IF(RINT(N).LT.CUT)GO TO 150
	N=N+1
	NLINE=NLINE+1
150	NREC=NREC+1
200	IF(N.LE.75)GO TO 125
	WRITE(LUNO,9300)
9300	FORMAT(' * WARNING - MAXIMUM NUMBER (75) LINES REACHED')
900	RETURN
	END
	SUBROUTINE SHOW3(LUNO,LINE,WL,RINT,IS,NLINE)
C
C  OUTPUTS DATABASE INFO 
C
	REAL*8 LINE(75)
	DIMENSION WL(75),RINT(75),IS(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)IS(I),LINE(I),WL(I),RINT(I),IS(I+23),LINE(I+23)
     %	 ,WL(I+23),RINT(I+23),IS(I+46),LINE(I+46),WL(I+46),RINT(I+46)
9200	FORMAT(1X,3(A2,1X,A6,F7.3,1X,F6.2,2X))
	GO TO 200
180	WRITE(LUNO,9210)IS(I),LINE(I),WL(I),RINT(I),IS(I+23),LINE(I+23)
     %	 ,WL(I+23),RINT(I+23),IS(I+46),LINE(I+46),WL(I+46),RINT(I+46)
9210	FORMAT('$',3(A2,1X,A6,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)IS(I),LINE(I),WL(I),RINT(I),IS(I+23),LINE(I+23)
     %	 ,WL(I+23),RINT(I+23)
	GO TO 350
330	WRITE(LUNO,9210)IS(I),LINE(I),WL(I),RINT(I),IS(I+23),LINE(I+23)
     %	 ,WL(I+23),RINT(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)IS(I),LINE(I),WL(I),RINT(I)
	GO TO 450
430	WRITE(LUNO,9210)IS(I),LINE(I),WL(I),RINT(I)
	GO TO 460
450	CONTINUE
460	RETURN
	END
