	PROGRAM SEARCH
C---------------------------------------------------------------------------
C Copyright 1988,1989,1990,1991,1992 by Brian H. Toby, E. I. du Pont de 
C Nemours and Co., and Air Products and Chemicals, Inc.
C
C Permission is granted for unlimited use, distribution and modification 
C of this manual and associated software, provided that modified software 
C and software based on this code must also be made freely available.
C---------------------------------------------------------------------------
C  SEARCH VERSION 3  -- 7/88 (B.H. Toby)
C--- 
C	This program traces it's ancestry to programs DSPACE and QUAL
C 	by R. Goehner and M. Garbauskas (& R. Harlow?). At this point
C	vary little of the original code remains.
C--- 
C   LUN 1  LI	SYS$INPUT: 	READ 
C   LUN 2  LO	SYS$OUTPUT:	(WRITE)
C   LUN 3  IN and OUT 
C   LUN 4  	JCPDS D/I FILE 
C   LUN 5  	MASTER INDEX FILE or D/I INDEX BITMAP FILE
C   LUN	21 CMDIN	FILE CONTAINING LOGIC COMMANDS
C---
C
	include '[-.shared]jcpds.parms/list'
	include 'SEARCH.cmn/list'
	include 'SEARCH.par/list'
	CHARACTER*13 fromstr/'             '/
	INTEGER*2 IQ,I,K
	REAL wavel
	CHARACTER*3 WLBL(3)/'1','2','Bar'/

	EXTERNAL ERRHAND
	LOGICAL DTOTT,TTTOD,DTOPDF,PDFTOD,DTOIND,INDTOD
	INTEGER*4 OLDHANDLER/-1/,LIB$ESTABLISH
	INTEGER STATUS,CLI$DCL_PARSE,CLI$GET_VALUE,CLI$PRESENT
	LOGICAL GET_NUMBER,flag,GET_LOGICAL,DEF_LOGICAL,GET_FNUMBER
	INTEGER  DEVCLASS, LIB$GETDVI
	EXTERNAL RMS$_EOF,SS$_NORMAL,DC$_TERM,DVI$_DEVCLASS
	EXTERNAL LIB$GET_INPUT,SEARCH_SUBCOMMANDS,DSC$K_DTYPE_F
	EXTERNAL CLI$_PRESENT,CLI$_DEFAULTED,CLI$_ABSENT,CLI$_NEGATED
	CHARACTER*20 PARM,string
	CHARACTER    head*7,fileform*40
	CHARACTER*80 filename,bitmap
	CHARACTER*80 sname,dname,pname,lsname,lssname
	INTEGER ln,s_ln,d_ln,bitmap_ln,ls_ln,lss_ln,p_ln,fln
	character name*60
	CHARACTER*4 command,ans*1
	LOGICAL EXRtst
	CHARACTER delstr*10
   	INTEGER CMDIN/21/
   	LOGICAL CMDFL/.FALSE./
   	CHARACTER*200 CMDSTR

	DEFAULT = .FALSE.
	NSTEP = 0
C initialize the file names for search results
	ls_ln = 0
	lsname = ' '
	lssname = ' ' 
	lss_ln = 0

71	format(a)
72	format(Q,a)
C-----------------------------------------------------------------------
	OPEN(unit=lo,file='sys$output',status='new')
	OPEN(unit=li,file='sys$input',status='new')
C initialize the PDF-1 database and open the files
	CALL PDF1INIT(LUNM,LPDF,LUNN,911)
C use DELETED patterns? -- check PS_DELETED
	CALL DELMODEGET(DELETED)

C-----------------------------------------------------------------------
C Check if we are running from a terminal?
	PROMPT = .FALSE.
	STATUS = LIB$GETDVI(%LOC(DVI$_DEVCLASS),,
	1	'SYS$INPUT',DEVCLASS,string,ln)
	IF (STATUS .EQ. %LOC(SS$_NORMAL) .and. DEVCLASS .eq. %LOC(DC$_TERM)) 
	1	PROMPT = .TRUE.
	BATCH = .not. PROMPT 
C-----------------------------------------------------------------------
C if this is a terminal, prompt for graphics type
	ICRT = 0
	IF (PROMPT) CALL SETCRT(ICRT,lo,li,ANSI)
C-----------------------------------------------------------------------
C Establish an alternate error handler
	IF (OLDHANDLER .eq. -1) OLDHANDLER = LIB$ESTABLISH(ERRHAND)
C determine the starting wavelength
	CALL WAVEGET(IW,IRAD,WAVEL,WAVE1,WAVE2)
C-----------------------------------------------------------------------
C Display welcome message
	write(lo,'(20x,A/)') '* * * Welcome to Program SEARCH * * *'
	CALL COPYRGT(lo,.TRUE.,.false.)
C check if SEARCH file is defined, if so read the file
	flag = GET_LOGICAL('SEARCH_FILE',filename,80,ln,lgprc)
	if (flag .and. ln .gt. 0) THEN
	  ln = lench(filename)
	  write (lo,'(A)') ' Last SEARCH Load File was: '//filename(1:ln)
	  write (lo,'(A)') '$  Do you want to load this file? ([Y]/N): '
	  read(li,'(A1)') IANS
	  if (IANS .eq. 'N' .or. IANS .eq. 'n') goto 18
	  CALL RELOAD(filename,ln,sname,s_ln,dname,d_ln,
	1	bitmap,bitmap_ln,*18,*18)
	  goto 1
	ENDIF
C no starting input or input error, get load file or set to default values
18	write (lo,'(A)') ' ',
	1	'$Do you want to read a Load File from a previous SEARCH run?'
	2	//' (Y/[N]): '
	read(li,'(A1)') IANS
	if (IANS .eq. 'Y' .or. IANS .eq. 'y') then
	  write(lo,732)
	  read (li,fmt=72,end=3) ln,filename
	  IF (filename .eq. '*') then 
	    call lib$spawn('$ dir *.sea_in;/notrail/date')
	    goto 18
	  ENDIF
	  if (ln .eq. 0) goto 18
C   LOAD in the file. The search NAME will be set by the name on the file.
	  call RELOAD(filename,ln,sname,s_ln,dname,d_ln,
	1	bitmap,bitmap_ln,*18,*18)
	  goto 1
	endif
	sname = 'SEARCH_TMP'
	s_ln = 10
	D2T = 0.1
	FFWHM = 0.2
	numob = 0
	d_ln = 0
	NSET = 0
	cnum = 0
	CALL TBLSET(TABLE1,N_cards,nph1)
	DMAX = 20
	DMIN = 1.5
	NSORT = 0
	NFOM = 0
	FLAG = DTOPDF(AMAX,DMIN)
	FLAG = DTOPDF(AMIN,DMAX)
	call exclr(extbl)
	call exset(extbl,-31416,amin,.true.)
	call exset(extbl,amax,31416,.true.)
C default setting for REDUCE/MATCH/REPORT parameters
	pimin = 5
	pindex = 70
	iimin = 1
	iindex = 50

	imin = 5

	JCMSMX = 1
	mphase = 999
	MINMATCH = 50
	IOMIN    = 25
	TITLES = ' '
C-----------------------------------------------------------------------
1	IF (.not. CMDFL) CALL TERASE(ICRT,lo,li)
	IF (wavel .eq. 0) THEN 
	  head = 'D-space'
	ELSE
	  IF (IW .eq. 0) then 
	    write(head,fmt='(a2,f5.3)') IRAD(1),wavel
	  ELSEIF (IW .eq. 1) then 
	    write(head,233) IRAD(1),'Ka 1'
233	    format(a2,1x,a4)
	  ELSEIF (IW .eq. 2) then 
	    write(head,233) IRAD(1),'Ka 2'
	  ELSEIF (IW .eq. 3) then 
	    write(head,233) IRAD(1),'Ka b'
	  ELSE
	    head = 'W = ???'
	  ENDIF
	ENDIF
	IF (Deleted) then
	  DELSTR = 'Deleted   '
	ELSEIF (ANSI) then
	  DELSTR = '   '
	ELSE
	  DELSTR = 'No Deleted'
	ENDIF
   	IF (.NOT. CMDFL) then
	  IF (ANSI) then
	    write (LO,'(5a1)') '$',"33,'[','7','m'
	    write (LO,231) "33,'#','3',ver_no,fromstr,delstr(:2),head,
	1		   "33,'#','4',ver_no,fromstr,delstr(:2),head
231	    FORMAT(1x,3a1,'SEARCH ',a5,1x,a13,2x,a3,1x,a7)
 	    write (LO,'(5a1)') '$',"33,'[','0','m'
	  elseif (prompt) then
232	    FORMAT(a1,72('-'),/,2x,'SEARCH ',a5,1x,a13,10x,a10,15x,
	1	A7,/,1x,72('-'),/)
	    write (LO,232) ' ',ver_no,fromstr,delstr,head
	  else
	    write (LO,232) '1',ver_no,fromstr,delstr,head
	  endif
	  WRITE (LO,'(a)') ' Search Name: '//SNAME(1:s_ln)
	  write (LO,'(A)') ' Title:       '//
	1	titles(:min(lench(titles),60))

	  IF (NSTEP.EQ.1) THEN
	    WRITE(lo,'(/a,i6,a)') 
	1	' REDUCE step has reduced the search scope to',
	1	nph2,' entries'
	  ELSEIF (NSTEP .EQ. 2 .or. NSTEP .eq. 3) THEN
	    WRITE(lo,'(/a,i6,a)') ' MATCH step has located ',nphase,
	1	' entries'
	  ELSE
	    WRITE(LO,171) nph1
171	    format(' Program will search',i7,' entries')
	  ENDIF
	ENDIF
C------------------------------------------------------------------------
C Get a command
3	IF (.NOT. CMDFL) THEN
	  WRITE(LO,71) ' ',' Enter a SEARCH command (or HELP)' 
	  STATUS = CLI$DCL_PARSE(%VAL(0),SEARCH_SUBCOMMANDS
	1	,LIB$GET_INPUT,LIB$GET_INPUT,'SEARCH> ')
	ELSE
	  CMDSTR = '-'
	  LN = 1
C loop reading for lines continued (with a trailing -)
	  DO WHILE(CMDSTR(LN:LN) .EQ. '-' .and. ln .lt. 200)
	    READ (21,'(a)',ERR=321) CMDSTR(LN:)
	    LN = LENCH(CMDSTR)
	  ENDDO
	  WRITE(LO,'(2A)') ' SEARCH> ',CMDSTR(:LN)
	  STATUS = CLI$DCL_PARSE(CMDSTR(:LN),SEARCH_SUBCOMMANDS
	1	,LIB$GET_INPUT,,)
	endif	
	
	IF (STATUS .eq. %LOC(RMS$_EOF)) then
	  IF (CMDFL) goto 321
	  goto 45
	ELSEIF (.not. STATUS) then
	  WRITE(LO,'(A)') ' *** ILLEGAL COMMAND ***'
	  IF (CMDFL) goto 321
	  IF (PROMPT) WRITE(LO,'(A)') 
	1	' Press ^B to edit your last command or enter HELP for '//
	2	'more information.',
	3	' Use the EXIT command to leave the program.',' '
	  goto 3
	ELSE
	  STATUS = CLI$GET_VALUE('$VERB',COMMAND)
	  IF (.not. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
	ENDIF
C-----------------------------------------------------------------------
C*** HELP SUBCOMMAND ***
	IF (COMMAND .eq. 'HELP') then
	  STATUS = CLI$GET_VALUE('p1',parm,ln)
	  CALL TERASE(ICRT,lo,li)
	  call help(parm(1:ln),'SEARCH_HLP',prompt)

C*** FILE SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'FILE') then
	  STATUS = CLI$GET_VALUE('file_name',filename,ln)
C is there a valid file name here?
322	  if ((.not. STATUS) .or. ln .le. 0) THEN
	    write(lo,'(a)') 
	1	'$Enter the file name root (default type = .CMD): '
	    read (li,fmt='(q,a)',end=3) ln,filename
	  endif
	  OPEN(unit=CMDIN,file=filename(:ln),defaultfile='.cmd',
	1	readonly,shared,status='old',err=323)
	  CMDFL = .true.
	  INQUIRE(unit=CMDIN,name=filename)
	  ln = lench(filename)
	  WRITE(LO,'(3A)') ' Opening command file ',filename(:ln)
	1	,'...'
	  GOTO 1
323	  WRITE(LO,'(2A)') ' Unable to open file ',filename(:ln)
	  STATUS = .FALSE.
	  IF (PROMPT) GOTO 322
	  GOTO 3

C*** QUIT SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'QUIT') then
46	  IF (PROMPT) then
	    write (lo,71) '$Are you sure you want to quit? (Y/[N]): '
	    read (li,71,end=146) ans
	    if (ans .ne. 'Y' .and. ans .ne. 'y') goto 3
146	    call TERASE(ICRT,lo,li)
	  endif
	  call exit

C*** EXIT SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'EXIT') then
45	  call TERASE(ICRT,lo,li)
	  IF (numob .gt. 0)
	1	call wrload(sname,s_ln,dname,d_ln,bitmap,bitmap_ln,*3)
	  call exit

C*** DCL SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'DCL ') then
	  if (PROMPT) then
	    CALL TERASE(ICRT,lo,li)
	    WRITE(LO,71) ' Spawning to DCL, type LOG to return to SEARCH'
	    CALL LIB$SPAWN(,,,,,,,,,,'(SEARCH)$ ')
	  ELSE
	    WRITE(LO,71) ' Sorry, you can spawn DCL only '//
	1	'while running interactively'
	  ENDIF

C*** LOGIC SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'LOGI') then
	  IF (.not. PROMPT) then 
	    type *,'Action not allowed in batch mode'
	    goto 3
	  ELSEIF (NSTEP .eq. 0) then
	    write (lo,71) ' Sorry, there has been no current search'
	    goto 3
	  ELSEIF (NSTEP .eq. 1) then
	    write (lo,71) ' There has been no current MATCH command,'
	1	//'  using the REDUCE result.'
	    IF (PROMPT) then
	      write(lo,71) '$Continue? ([Y]/N) '
	      read(li,'(a1)') ans
	      if (ans .eq. 'N' .or. ans .eq. 'n') goto 3
	    ENDIF
	    CALL WRBIT(table2,SNAME,S_LN,bitmap,bitmap_ln,dname,d_ln,
	1	filename,ln,*3)
	    flag = DEF_LOGICAL('LOGIC_FILE',filename,ln,1,lgprc)
	  ELSEIF (NSTEP .eq. 3 .and. ls_ln .gt. 0 .and. lss_ln .gt. 0) then
330	    write (lo,71) ' Choose the file to pass:',
	1	'   (1) '//lsname(:ls_ln)//' (all matches)',
	2	'   (2) '//lssname(:lss_ln)//' (results from REPORT)',
	3	'$Enter 1 or 2: '
	    READ(li,'(I)',err=330,end=3) i
	    IF (i .eq. 1) goto 331
	    IF (i .eq. 2) goto 332
	    goto 330
	  ELSEIF (ls_ln .gt. 0) then
331	    flag = DEF_LOGICAL('LOGIC_FILE',lsname,ls_ln,1,lgprc)
	  ELSEIF (lss_ln .gt. 0) then
332	    flag = DEF_LOGICAL('LOGIC_FILE',lssname,lss_ln,1,lgprc)
	  ELSE
	    write (lo,71) ' Sorry, no bitmap file name to pass to LOGIC --'//
	1	' Perform a search first.'
	    goto 3
	  endif
	  call wrload(sname,s_ln,dname,d_ln,bitmap,bitmap_ln,*3)
	  CALL LIB$DO_COMMAND ('@PS_EXE:SEARCH_TO_LOGIC')
	  CALL EXIT

C*** READ SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'READ') then
C is there a valid file name here?
	  STATUS = CLI$GET_VALUE('file_name',filename,ln)
	  if ((STATUS .and. ln .gt. 0) .or. prompt) THEN
	    fileform = ' '
	    IF (CLI$PRESENT('FORMAT')) 
	1	STATUS = CLI$GET_VALUE('FORMAT',fileform,fln)
	    call GETPEAKS(filename,ln,sname,s_ln,dname,d_ln,
	1	pname,p_ln,fileform,STATUS)
	    IF (STATUS .ne. 0) GOTO 3
	  ELSE
	    type *,'READ ignored --  No file to read'
	    goto 3
	  ENDIF

C*** WAVELENGTH SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'WAVE') then
	  CALL WAVESEL(IW,IRAD,wavel,WAVE1,WAVE2,*3,li,lo,prompt)

C*** DELETED SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'DELE') then
	  CALL DELMODESEL(DELETED,*3,li,lo,prompt)

C*** STARTFILE SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'STAR') then
	  call selbit(bitmap,bitmap_ln,sname,s_ln,*3)
C reset the table of hits before changing the search parameters
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  NSTEP = 0
	  IF (prompt) then
	    write (lo,445) 
445	    format(/,'$Press RETURN to continue ')
	    read (li,fmt='(a1)',end=3) ians
	  ENDIF

C*** TITLE SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'TITL') then
	  STATUS = CLI$GET_VALUE('NEW_TITLE',atitle(1) ,ln)
	  if (PROMPT .and. (ln .eq. 0 .or. .not. STATUS)) then
	    STATUS = .true.
	    write (lo,71) '$Enter a title line: '
	    read (li,72,end=3) ln,atitle(1) 
	  ENDIF
	  if (STATUS .and. ln .gt. 0) titles = atitle(1) 

C*** SHOW SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'SHOW') then
	  CALL SHOWSUB(dname,d_ln,sname,s_ln,filename,ln,
	1	bitmap,bitmap_ln,wavel)

C*** SET SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'SET ') then
C reset the table of hits before changing the search parameters
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  NSTEP = 0
	  CALL SETSUB(sname,s_ln,filename,ln)

C*** EDIT SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'EDIT') then
C reset the table of hits before changing the peak list
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  NSTEP = 0
	  CALL DIEDIT(WAVEL,*3)

C*** IGNORE SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'IGNO') then
	  call ignsub(wavel,*3)

C*** REDUCE SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'REDU') then
C  check for legal search parameters
	  IF (numob .le. 0) then
	    write(LO,71) '0There are no peaks in the list'
	    IF (PROMPT) goto 3
	    stop
	  ENDIF
	  NSTEP = 0
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  CALL reduce(wavel,bitmap_ln,bitmap,STATUS)
	  IF (.not. STATUS) GOTO 3
	  NSTEP = 1
	  IF (prompt) then
	    write (lo,445) 
	    read (li,fmt='(a1)',end=3) ians
	  ENDIF

C*** MATCH SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'MATC') then
C  check for legal search parameters
	  IF (numob .le. 0) then
	    write(LO,71) '0There are no peaks in the list'
	    IF (PROMPT) goto 3
	    stop
	  ELSEIF ((MINMATCH*numob)/100 .le. 0) then
	    write(LO,71) '0There are no peaks required to be matched'
	    IF (PROMPT) goto 3
	    stop
	  ENDIF
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  CALL find(s_ln,SNAME,bitmap_ln,bitmap,lsname,ls_ln,STATUS)
	  IF (.not. STATUS) GOTO 3
	  NSTEP = 2
	  IF (prompt) then
	    write (lo,445) 
	    read (li,fmt='(a1)',end=3) ians
	  ENDIF

C*** REPORT SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'REPO') then
	  CALL REPORT(dname,d_ln,sname,s_ln,lssname,lss_ln,wavel,
	1		bitmap,bitmap_ln,STATUS)
	  IF (.not. STATUS) GOTO 3

C*** SEARCH SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'SEAR') then
	  IF (CLI$PRESENT('BATCH')) THEN
	    ANS = 'B'
	  ELSEIF (CLI$PRESENT('INTERACTIVE')) THEN
	    ANS = 'I'
	  ELSEIF (PROMPT) then
	    write (LO,71) 
	1	'$Run search: in Batch or Interactively (default)? (B/I): '
	    read (LI,71,end=3) ANS
	  ELSE
	    ANS = 'I'
	  ENDIF
C  check for legal search parameters
	  IF (numob .le. 0) then
	    write(LO,71) '0There are no peaks in the list'
	    IF (PROMPT) goto 3
	    stop
	  ELSEIF ((MINMATCH*numob)/100 .le. 0) then
	    write(LO,71) '0There are no peaks required to be matched'
	    IF (PROMPT) goto 3
	    stop
	  ENDIF
C  start/submit search
	  IF (ANS .eq. 'B' .or. ANS .eq. 'b') then
	    call wrload(sname,s_ln,dname,d_ln,bitmap,bitmap_ln,*3)
	    CALL LIB$DO_COMMAND('@PS_EXE:SUB_SEARCH')
	    CALL EXIT
	  else
	    NSTEP = 0
	    CALL reduce(wavel,bitmap_ln,bitmap,STATUS)
	    IF (.not. STATUS) GOTO 3
	    NSTEP = 1
	    CALL find(s_ln,SNAME,bitmap_ln,bitmap,lsname,ls_ln,STATUS)
	    IF (.not. STATUS) GOTO 3
	    NSTEP = 2
	    CALL REPORT(dname,d_ln,sname,s_ln,lssname,lss_ln,wavel,
	1	bitmap,bitmap_ln,STATUS)
	    IF (.not. STATUS) GOTO 3
	    NSTEP = 3
	  endif

C*** LOAD SUBCOMMAND ***
	ELSEIF (COMMAND .eq. 'LOAD') then
C reset the table of hits before changing the search parameters
	  CALL TBLCLR(TABLE,N_Lwords,NPHASE)
	  NSTEP = 0
	  STATUS = CLI$GET_VALUE('file_name',filename,ln)
	  if ((.not. STATUS .or. ln .le. 0) .and. prompt) THEN
731	    write(lo,732)
732	    format(/' Enter the name of file to be loaded ',
	1	'(default extension=.SEA_IN)',/,
	2	'$or * for listing of the current directory: ')
	    read (li,fmt=72,end=3) ln,filename
	    IF (filename .eq. '*') then 
	      call lib$spawn('$ dir *.sea_in;/notrail/date')
	      goto 731
	    ENDIF
	  endif
	  if (ln .eq. 0) then
	    type *,'LOAD ignored --  No file to read'
	    goto 3
	  endif
C   LOAD in the file. The file will be in the default directory and
C   will have a default extension of .SEA_IN
C   The search NAME will be set by the name on the file.
	  call RELOAD(filename,ln,sname,s_ln,dname,d_ln,
	1	bitmap,bitmap_ln,*3,*18)
	ELSE
		type *,'*** UNKNOWN COMMAND: ',command
		goto 3
	ENDIF
	goto 1
C------------------------------------------------------------------------
321	CMDFL = .false.
	WRITE(LO,'(A)') ' ....Terminating command file'
	close (unit=CMDIN)
	call ps_pause(prompt)
	goto 1
C------------------------------------------------------------------------
703	WRITE (LO,71) ' ERROR -- Invalid d-space/angle range.'
	goto 3
C------------------------------------------------------------------------
911    stop 'PDF1INIT ERROR -- unable to open JCPDS PDF-1 database'
	end
