	SUBROUTINE WINDEX(*)
C
C Subroutine to produce index listings
C
	include 'logic.common'
	INTEGER STATUS,CLI$DCL_PARSE,CLI$GET_VALUE,CLI$PRESENT
	LOGICAL GET_NUMBER,flag,GET_LOGICAL,DEF_LOGICAL,GET_FNUMBER
	integer*2 sortinfo(5)/1,0,0,4,4/
	integer SOR$PASS_FILES,SOR$BEGIN_SORT,SOR$SORT_MERGE,SOR$END_SORT
	EXTERNAL DSC$K_DTYPE_F
	logical sortf,printf,maxd
	INTEGER*2 ISET,ICARD
	INTEGER*4 NAMREC,FULREC,DIREC,ISEQ,JCARD
	BYTE CHFORM(200),CHNAME(205)
	INTEGER*2 LCHFORM,LCHNAME
	CHARACTER*1 QM,STRING*60
	DIMENSION dsp(200),DSSUB(20)
	EQUIVALENCE (dsp,DSSUB)
	INTEGER*2 INT(200),INTSUB(20)
	EQUIVALENCE (INT,INTSUB)

	PRINTF = .false.
	IF (CLI$PRESENT('PRINT')) PRINTF = .true.
	MAXD = .false.
	IPERMUT=0
	IF (CLI$PRESENT('MAXD')) THEN 
	  FLAG = GET_NUMBER('MAXD',IPERMUT)
	  MAXD = .true.
	  goto 772
	ELSEIF (CLI$PRESENT('HANAWALT')) THEN 
	  FLAG = GET_NUMBER('HANAWALT',IPERMUT)
	  goto 772
	ELSEIF (CLI$PRESENT('NAMES')) THEN 
	  GOTO 771
	ELSE
	  WRITE(lo,760) 
760	  FORMAT(/'$Enter listing type: H-Hanawalt, N-Names, M-MaxD ',
	1	'(default=N): ')
	  READ(LI,fmt='(A1)',end=3) ans
	  MAXD = .false.
	  IF (ANS .EQ. 'M' .or. ANS .EQ. 'm') THEN
	    MAXD = .true.
	    goto 769
	  ENDIF
	  IF (ANS .EQ. 'H' .or. ANS .EQ. 'h') THEN
769	    WRITE(lo,761) 
761	FORMAT(/' Enter N, the number of lines to be sorted'/
	1  10X,'if N = 0, then the index is sorted by pdf number'/
	2  10x,'if N >=1, then the index is sorted by the N strongest lines.'/
	2  10x,'N.B. For N >=2, the index increases in length by a factor'
	3  ' of N',/,'$Enter a value for N (default=0): ')
	    READ(LI,fmt='(I)',end=3) IPERMUT
	    FLAG = .false.
	    GOTO 772	    
	  ENDIF
	  GOTO 771
	ENDIF

C---------------------------------------------------------------------------
772	type *,'creating output list...'
!	OPEN (UNIT=LPDF,NAME='PS_JCPDS:DI.library',STATUS='OLD',READONLY,
!	1	FORM='UNFORMATTED',ACCESS='DIRECT',SHARED)
	OPEN (UNIT=LINDX,NAME='PS_TMP:INDEX.TEMP',FORM='UNFORMATTED'
	1	,TYPE='NEW',DISPOSE='DELETE',RECL=140,RECORDTYPE='FIXED')
	npcnt = 0

	SORTF = .false.
	IF (.not. FLAG .and. IPERMUT .GT. 0) SORTF = .true.
	DO 10 N=N_Lwords,1,-1
	  NTABLE = TABLE(N)
	  IF (NTABLE.EQ.0) GOTO 10
	  DO J=31,0,-1
	    IF (IBITS(NTABLE,J,1).EQ.1) THEN
C	convert bit# and word# to seq#
	      ISEQ = 32*(N-1) + J + 1
C 	get record numbers from seq#
	      READ (LUNM,rec=ISEQ) JCARD,NAMREC,FULREC,DIREC
	      ISET = JCARD / 10000
	      ICARD = MOD(JCARD,10000)
C	get D/I info
	      CALL READDI(DIREC,dsp,INT,NDSINT,LPDF,wave0,200)
C	for MAXD listing sort lines: min angle (max D) to max angle (min D)
	      IF (MAXD .and. wave0 .eq. 0.0) then
		CALL DSORT(dsp,INT,NDSINT)
	      ELSEIF (MAXD) then
		CALL TSORT(dsp,INT,NDSINT)
	      ELSE
C 	everything else, sort from High I to Low I
		CALL ISORT(dsp,INT,NDSINT)
	      ENDIF
	      IF (IPERMUT .gt. 1) THEN
		DO I=1,MIN(NDSINT,IPERMUT,5)
		  X = DSSUB(1)
		  DSSUB(1) = DSSUB(I)
		  DSSUB(I) = X
		  JREC = INTSUB(1)
		  INTSUB(1) = INTSUB(I)
		  INTSUB(I) = JREC
		  WRITE(LINDX) ISET,ICARD,DSSUB,INTSUB,NDSINT
		  npcnt = npcnt + 1
		  X = DSSUB(1)
		  DSSUB(1) = DSSUB(I)
		  DSSUB(I) = X
		  JREC = INTSUB(1)
		  INTSUB(1) = INTSUB(I)
		  INTSUB(I) = JREC
		ENDDO
	      ELSE
		WRITE(LINDX) ISET,ICARD,DSSUB,INTSUB,NDSINT
		npcnt = npcnt + 1
	      ENDIF

	    ENDIF
	  ENDDO
10	CONTINUE

!	CLOSE(UNIT=LPDF)
C perform a sort, if a sort has been requested
	IF (sortf) then
	  CLOSE(UNIT=LINDX,DISPOSE='KEEP')
	  type *,'beginning sort...'
C	pass names of files to sort
	  status = SOR$PASS_FILES('PS_TMP:INDEX.TEMP','PS_TMP:INDEX.SORT')
	  If (.not. status) Goto 919
C	pass sort information
	  sortinfo(2) = %LOC(DSC$K_DTYPE_F)
	  status = SOR$BEGIN_SORT(sortinfo)
	  If (.not. status) Goto 919
C	perform sort 
	  status = SOR$SORT_MERGE()
	  If (.not. status) Goto 919
	  status = SOR$END_SORT()
	  If (.not. status) Goto 919
C	delete old file
	  OPEN (UNIT=LINDX,NAME='PS_TMP:INDEX.TEMP',FORM='UNFORMATTED'
	1	,TYPE='OLD',DISPOSE='DELETE')
	  CLOSE(UNIT=LINDX,DISPOSE='DELETE')
	  OPEN (UNIT=LINDX,NAME='PS_TMP:INDEX.SORT',FORM='UNFORMATTED'
	1	,TYPE='OLD',DISPOSE='DELETE')
	else
	  REWIND(UNIT=LINDX)
	endif
	  
	if (printf) goto 702
C display list on terminal
	ncol = 5
	NLINE = 22
	CALL TERASE(ICRT,lo,li)
	do ii=1,npcnt
	  READ(LINDX,end=701) ISET,ICARD,DSSUB,INTSUB,NDSINT
	  IF (wave0 .EQ. 0.0) THEN 
	    WRITE(LO,30) ISET,ICARD,(dsp(I),INT(I),
	1	    i=1,min(ncol,NDSINT))
30	    FORMAT(' [',I2.2,I4.4,'] ',10(f7.3,'(',i3,')'))
	  ELSE
	    WRITE(LO,31) ISET,ICARD,(dsp(I),INT(I),
	1	    i=1,min(ncol,NDSINT))
31	    FORMAT(' [',I2.2,I4.4,'] ',10(f7.2,'(',i3,')'))
	  ENDIF
	  IF (Mod(ii,NLINE) .EQ. 0 .and. prompt) THEN 
	    WRITE(LO,710)
710	    FORMAT('$CONTINUE? ([Yes]/No/Print): ')
	    READ(LI,fmt='(A1)',end=701) ans
	    IF (ans .eq. 'P' .or. ans .eq. 'p') goto 702
	    IF (ans .eq. 'n' .or. ans .eq. 'N') goto 701
	    CALL TERASE(ICRT,lo,li)
	  ENDIF
	enddo
701	if (PROMPT) then
	  WRITE(LO,711) 
711	  FORMAT(/,'$Do you want to print a hard copy? (Y/[N]) ')
	  READ(LI,fmt='(A1)',end=1) ans
	else
	  GOTO 704
	endif
	IF (ans .ne. 'Y' .and. ans .ne. 'y') goto 704

C display list on printer
702	ncol = 10
	NLINE = 55-cnum
	REWIND(UNIT=LINDX)
	IPAGE = 1
	CALL opnpr(lo,li,lp,'LOGIC.LIS',ncols,nlines)
	do ii=1,npcnt
	  READ(LINDX,end=703) ISET,ICARD,DSSUB,INTSUB,NDSINT
	  IF (Mod(ii,NLINE) .EQ. 1) THEN 
	    WRITE(lp,721) IPAGE
721	    FORMAT('1',120x,'Page',i4)
	    IF (wave0 .EQ. 0.0) THEN
	      WRITE(lp,811) 
811	      FORMAT(' Peak Positions as d-spaces (in Angstroms)')
	    ELSE
	      WRITE(lp,812) irad0,wave0
812	      FORMAT(' Peak Positions as angles for ',A2,
	1	' Radiation, wavelength =',f8.5,' (degrees 2Theta)')
	    ENDIF
	    WRITE(lp,810) (i,CONTEXT(i),i=1,cnum)
810	    FORMAT('        Commands: ',i3,')',1x,a,/,
	1	99(18x,i3,')',1x,a,:/))
	    WRITE(lp,fmt='(/)') 
	    IPAGE = IPAGE + 1
	  ENDIF

	  IF (wave0 .EQ. 0.0) THEN 
	    WRITE(LP,30) ISET,ICARD,(dsp(I),INT(I),
	1	    i=1,min(ncol,NDSINT))
	  ELSE
	    WRITE(LP,31) ISET,ICARD,(dsp(I),INT(I),
	1	    i=1,min(ncol,NDSINT))
	  ENDIF
	enddo
703	CALL CLPR(lo,li,lp)
704	CLOSE(UNIT=LINDX,DISPOSE='DELETE')
	return

C---------------------------------------------------------------------------
771	CONTINUE
!	OPEN (UNIT=LUNn,NAME='PS_JCPDS:NAME.DIRECT',STATUS='old',
!	1	READONLY,SHARED,FORM='UNFORMATTED',ACCESS='DIRECT')
	IF (PRINTF) THEN
C display list on printer
750	  PRINTF = .true. 
	  LUN = LP
	  ncol = 360
	  NLINE = 55 - cnum
	  IPAGE = 1
	  call opnpr(lo,li,lp,'LOGIC.LIS',ncols,nlines)
	  ii = 999
	ELSE
	  ii = 0
	  PRINTF = .false. 
	  ncol = 68
	  LUN = LO
	  NLINE = 22
	ENDIF
	CALL TERASE(ICRT,lo,li)
	DO 20 N=N_Lwords,1,-1
	  IF (TABLE(N).EQ.0) GOTO 20
	  DO J=31,0,-1
	    IF (IBITS(TABLE(N),J,1).EQ.1) THEN
C	convert bit# and word# to seq#
	      ISEQ = 32*(N-1) + J + 1
C 	get record numbers from seq#
	      READ (LUNM,rec=ISEQ) JCARD,NAMREC,FULREC,DIREC
	      ISET = JCARD / 10000
	      ICARD = MOD(JCARD,10000)
C	get name info
	      CALL READNAM(NAMREC,LUNN,QM,FCOR,CHFORM,LCHFORM,CHNAME,LCHNAME)
C Determine number of columns to be printed
	      LCHFORM = min(LCHFORM,ncol-3)
	      k2 = min(LCHNAME,ncol-lchform-3)
C Determine number of lines
	      ii = ii + 1 + (k2 + LCHFORM + 2)/120 
	      IF (ii .gt. NLINE .and. PRINTF) THEN
	        ii = 0 
		WRITE(lp,722) IPAGE
722	        FORMAT('1  JCPDS Database: ',
	1	'chemical formulae / compound names / mineral names',
	2	t120,'Page',i4)
	        WRITE(lp,810) (i,CONTEXT(i),i=1,cnum)
		WRITE(lp,fmt='(/)') 
		IPAGE = IPAGE + 1
	      ELSEIF (ii .ge. NLINE .and. prompt .and. .not. printf) THEN
	        ii = 0
		WRITE(LO,710)
		READ(LI,fmt='(A1)',end=751) ans
		IF (ans .eq. 'P' .or. ans .eq. 'p') goto 750
		IF (ans .eq. 'N' .or. ans .eq. 'n') goto 751
		CALL TERASE(ICRT,lo,li)
	      ENDIF

	      WRITE(LUN,32) ISET,ICARD,(CHFORM(k),k=1,LCHFORM),' ','/',' ',
	1	(CHNAME(k),k=1,k2)
32	      FORMAT(' [',I2.2,I4.4,']  ',120a1:,/,11x,120a1:,/,11x,120a1)
	    ENDIF
	  enddo
20	CONTINUE

751	if (PROMPT .and. .not. printf) then
	  WRITE(LO,711) 
	  READ(LI,fmt='(A1)',end=1) ans
	  IF (ans .eq. 'Y' .or. ans .eq. 'y') goto 750
	endif

	IF (printf) CALL CLPR(lo,li,lp)
!	CLOSE (UNIT=LUNn)
1	RETURN
*****************************************************************************
C error performing sort
919	type *,'ERROR performing sort'
	call LIB$SIGNAL(%VAL(STATUS))
	OPEN (UNIT=LINDX,NAME='PS_TMP:INDEX.TEMP',ACCESS='SEQUENTIAL'
	1	,TYPE='old',DISPOSE='DELETE')
	CLOSE(LINDX,DISPOSE='DELETE')
3	RETURN 1
	END
