C  TEST OF FETCH ROUTINE
C
C  SUBROUTINE TO DISPLAY JCPDS CARD AS PART OF "SPECPLOT"
C   WRITTEN BY RAY GOEHNER  3/82
C
C  LU-1  INDEX FILE
C  LU-2  PDF FILE
C
C   MAXBUF=5000 NEEDED TO OPEN INDEX FILE
C
      DIMENSION DSP(101)
      INTEGER INT(101),PDF,CLR(7),WSPC
      BYTE CNAME(110),NF,CL,CLB,CLA,CLG(5)
      BYTE ISP,JSP,IFL,D2(13),IDSP,ITERM
       N=0
 10    NN=NN+1
      WRITE(7,100) NN
  100 FORMAT(' PDF(',I2,')=')
      CALL PDF(5,IFILE,ICARD,IR)
      CALL RCARD(IFILE,ICARD,IER,NDI,DSP,INT,CNAME,EL,RIC,D2)
      GO TO 10
 9999 CALL CLOSE(11)
       STOP
      END

      SUBROUTINE PDF(LUTI,IFILE,ICARD,IR)
C
C  GET PDF FILE & CARD NUMBER
C  IR=3 REFRESH THE SCREEN
C
       IMPLICIT INTEGER*2 (I-N)
      BYTE INP(10)
      IR=10
      IFILE=0
      ICARD=0
C
  100 READ(LUTI,1000,END=9998) IQ,INP
 1000 FORMAT(Q,10A1)
      IF(INP(1).EQ.'R'.OR.INP(1).EQ.'#') IR=3
      IF(INP(1).EQ.'R'.OR.INP(1).EQ.'#') GO TO 9999
      IF(INP(1).EQ.' ') GO TO 9998
      IF(INP(1).LT.48.OR.INP(1).GT.57) GO TO 9999
      DO 1100 I=1,10
      IF(INP(I).EQ.','.OR.INP(I).EQ.'-') J=I
 1100 CONTINUE
      K=J-1
      DO 1200 I=1,(J-1)
      K=K-1
 1200 IFILE=IFILE+(INP(I)-48)*10**K
      K=IQ-J
      DO 1300 I=(J+1),IQ
      K=K-1
 1300 ICARD=ICARD+(INP(I)-48)*10**K
      IF(IFILE.LE.0) GO TO 100
      IF(ICARD.LE.0.OR.ICARD.GE.2500) GO TO 100
       WRITE(6,1234)IFILE,ICARD
1234	FORMAT(' IFILE, ICARD = ',2I6)
 9999 RETURN
 9998 IR=9
      RETURN
      END

         SUBROUTINE RCARD(ISET,ICARD,IER,NSINT,DSPACE,INT,CNAME,EL
     1,ICOR,D2)
C
c  subroutine to fetch pdf card from the vax diffrac 500 data base.
c  by R. L. Snyder 2/86
C
C  ************************************************************************
C
C         THIS SUBROUTINE ACCEPTS THE SET AND CARD NUMBER AND CALLS
C         UNPACK TO RETURN THE D-SPACING AND INTENSITY ARRAYS ALONG 
C         WITH THE NUMBER OF DI PAIRS, THE ELEMENT NAME AND THE
C         CHEMICAL SPECIES NAME.
C
C  ***********************************************************************
C 
        IMPLICIT INTEGER (I-N)
c  translation of specplot variables and vax unpack variables:
c specplot variables     difrac500 variables
c ISET*2			iset (changed to *2)
c ICARD*2			icard (changed from cardno as *2)
c IER*2
c NSINT*2			ndi*4
c DSPACE(101)real		idees(101)*4->dspace
c INT*2(101)			ints(101)*4
c CNAME(42)byte			mina(66)byte
c  cname(1) = cnum*2
c EL(42)byte			chem(42)byte
c  el(1) = elnum*2
c ICOR*2			iicor*4
c D2(13)byte			location of pdf file
	integer*4 icode,irfa, offset, ints(101),cheml,minl
        integer*4 iunit2,patnum, ndi, idees(101),iicor 
	byte	mina (66)
	integer*2 maxset
c  The following are the normal specplot variables
        INTEGER*2 INT(101), nsint, icor, ier, iset, icard
        REAL*4 DSPACE(101)
        BYTE CNAME(42),EL(42),D2(13)
        LOGICAL*1 NAME(32)
        DATA NAME/'S','Y','S','$','P','D','F','F','I','L','E',
	1 'S',':','J','C','P','D','S','.','D','I','R',10*' '/
C
C       FIRST OPEN DIRECTORY FILE AND BINARY MASTER FILE
C       AND READ IN THE DIRECTORY INFORMATION
C
        IER = 0
        IUNIT2 = 11
	OPEN ( UNIT=IUNIT2, NAME=NAME, TYPE='OLD', READONLY,
     +	SHARED,	ACCESS='DIRECT', RECORDSIZE=1)
	read (iunit2 ' 1) maxset		!get the maximum available
c						!SET  number
       write(6,1234) maxset
1234	format(' maxset = ',i5)
	if (iset .lt. 1 .or. iset .gt. maxset) go to 15
	read (iunit2 ' 1+iset) offset		!read offset
	read (iunit2 ' offset) maxnum		!read maximum card no.
	if (icard .lt. 1 .or. icard .gt. maxnum) go to 15
	read (iunit2 'icard+offset) irfa			!read address
	close (unit = iunit2)
c	if (irfa .lt. 0) go to 15			!yes card exists
	go to 20
15        IER = 2                             ! NONEXISTANT PATTERN
          GOTO 999
C
C         OPEN THE MASTER FILE FILE
C
20	name(20) = 'B'
       	name(22) = 'N'
	icode = 0
	patnum = iunit2				!for rsx
	call unpack (icode , patnum, name ,ndi, idees, 
     +			ints, iicor, mina)	!open packed file
	if (icode .ne. 0) then 
              	ier = 1
              	go to 999		!error opening
        endif
	if (irfa .gt. 0) go to	25		!card does not exist
22      IER = 3                                     !PATERN PROBABLY DELETED
        GOTO 999
C           
C         CLEAR BUFFERS FOR ID AND INT ARRAYS
C
25        DO 30 I=1,101
       	  idees(i) = 0
          DSPACE(I)=0.0
          INT(I)=0
30        CONTINUE
C
C         CLEAR CNAME AND EL
C
          DO 40 I=1,42
          CNAME(I)=' '
          EL(I)=' '
40        CONTINUE
	call unpack (irfa , patnum, el ,ndi, idees, 
     +			ints, iicor, mina)	!open packed file
       write(6,1235)icode, patnum,ndi
1235	format(' icode, patnum, ndi =',3i6)
	if (patnum .ne. icard) go to 22	!this should never happen
c **	push information on appropriate arrays
	icor = iicor/100.0		!i/icor value
        IF (ICOR.EQ.0.0) ICOR = 1.0
        DO 303 I=1,40
          CNAME(I)=mina(i+2)
303     CONTINUE          
        DO 304 I=1,40
          EL(I)=EL(I+2)
304     CONTINUE
        nsint = ndi
        pi = 3.14159265
	halfla = 0.770255
	do 400 i = 1, ndi			!convert d's
	
	dspace(i) = halfla/ sin((pi + (idees(i)/10000.0))/4.0)
400	continue
1000	icode = -1				!close the .bin file
	call unpack (icode , patnum, name ,ndi, idees, 
     +			ints, iicor, mina)
999	return
       END

