C     CHEMISTRY PROGRAMLN
C
C	THIS PROGRAM HAS BEEN EXTENSIVELY REWRITTEN TO MAKE USE OF 
C	THE ENCODED CHEMISTRY FILE FOR RAPID SEARCHING.
C

	INTEGER*2 ISYM(40),CHSYM(104),FSYM(40)
	INTEGER*4 TABLE(2000),CHEM(2000),TABLE1(2000),TMP(2000)
	BYTE ANS,YES/'Y'/,NO/'N'/
	BYTE LINE(80)
	EQUIVALENCE (LINE(1),LOGIC)
	INTEGER*2 LOGIC


      DATA CHSYM/'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     1'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti','V ',
     2'Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',
     3'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In',
     4'Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','
     5Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re','O
     6s','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra',
     7'Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md',
     8 'No','Lw','Ln'/


      WRITE(6,123)
123   FORMAT(' VAX VERSION NOV 2, 1988'/
     1	10X,'RICHARD L. HARLOW, I, DUPONT'/
     1  10X,'PROGRAM TO SEARCH CRYSTAL DATA FILE USING CHEMISTRY.'//)


      CALL GET(TABLE,ISIZE,NSIZE)
      IF(ISIZE.EQ.59613) KEY=1
      IF(ISIZE.EQ.56140) KEY=2
      IF(KEY.EQ.1) THEN
	OPEN (UNIT=1,NAME='LATTICEI',STATUS='OLD',SHARED,
	1 ACCESS='DIRECT',FORM='UNFORMATTED',READONLY,RECL=32)
	OPEN (UNIT=2,NAME='CD:CHEMI.BIN',STATUS='OLD',SHARED,
	1 ACCESS='DIRECT',FORM='UNFORMATTED',READONLY,RECL=2000)
      ENDIF
      IF(KEY.EQ.2) THEN
	OPEN (UNIT=1,NAME='LATTICEO',STATUS='OLD',SHARED,
	1 ACCESS='DIRECT',FORM='UNFORMATTED',READONLY,RECL=32)
	OPEN (UNIT=2,NAME='CD:CHEMO.BIN',STATUS='OLD',SHARED,
	1 ACCESS='DIRECT',FORM='UNFORMATTED',READONLY,RECL=2000)
      ENDIF


	DO 90 I=1,2000
90	TABLE1(I)=TABLE(I)


	WRITE (6,100)
100	FORMAT (//' SEARCHES CAN BE MADE USING "AND", "OR", "ONLY",'
	1 ' AND "NOT" LOGIC.'/' A SEARCH IS CONDUCTED BY FIRST ENTERING '
	2 'THE LOGIC TYPE'/' AND THEN THE ELEMENTS IN UPPER/LOWER CASE,'
	3 ' e.g. Li Al Fe (Ln = Lanthanide).')
101	WRITE (6,102)
102	FORMAT(/' PLEASE ENTER LOGIC TYPE (AND/OR/ONLY/NOT/<CR>=QUIT'
	1 '/HELP)'/
     1  10X,'ENTER 2 CHARACTERS--FOR A SINGLE ELEMENT IT DOES NOT'/
     1  10X,'MATTER AS TO WHETHER YOU ENTER "AND"/"OR"   '$)
	READ (5,103,END=500) LOGIC
103	FORMAT (A2)
	IF (LOGIC.EQ.'  ') GO TO 500
	CALL UPCASE(LOGIC,LOGIC,2)
        IF(LOGIC.EQ.'AN' .OR. LOGIC.EQ.'OR' .OR. LOGIC.EQ.'ON' .OR.
     1     LOGIC.EQ.'NO' .OR. LOGIC.EQ.'HE') GO TO 10003
        GO TO 101
10003   CONTINUE
	IF (LOGIC.EQ.'HE') GO TO 300
	IF (LOGIC.EQ.'OR') THEN
	LOG=2
	GO TO 105
	ENDIF
	IF (LOGIC.EQ.'NO') THEN
	LOG=3
	GO TO 105
	ENDIF
	IF (LOGIC.EQ.'ON') THEN
	LOG=4
	GO TO 105
	ENDIF
	LOG=1
105     CONTINUE
	LN=0
C       GGJJ CHANGE HERE --REMOVED 105 OFF NEXT LINE
C            LN WAS NEVER RESET TO 0. ONLY IF LOGIC TYPE (LOG=1)
C            WAS IT RESET
10555	WRITE (6,107)
107	FORMAT ('$PLEASE ENTER ELEMENTS: (U/L CASE -- ALL ON ONE LINE) ')
	READ (5,108,END=500) LINE
108	FORMAT (80A1)
	L=LENGTH(LINE,80)
	IF (L.EQ.0) GO TO 500

D	WRITE (6,112) LOG,(LINE(I),I=1,L)
D112	FORMAT (/' LOG = ',I3,10X,' FOR LINE:'/1X,80A1)


	CALL ELEMENTS (L,LINE,NCH,FSYM)
D	WRITE (6,777) NCH,(FSYM(I),I=1,NCH)
D777	FORMAT (' NCH, FSYM = ',I5,20(A2,2X))
	IF (NCH.EQ.0) GO TO 400

C	CHECK TO SEE THAT THE SYMBOLS ARE ELEMENTS.
C
	DO 140 I=1,NCH
	DO 128 J=1,104
	IF (FSYM(I).EQ.CHSYM(J)) THEN
	ISYM(I)=J
	IF(J.EQ.104) LN=1
	GO TO 140
	ENDIF
128	CONTINUE
	WRITE (6,130) FSYM(I)
130	FORMAT (' NO MATCH FOR SYMBOL 'A2)
	NCH=NCH-1
	DO 132 N=I,NCH
	ISYM(N)=ISYM(N+1)
132	FSYM(N)=FSYM(N+1)
        GO TO 10555
140	CONTINUE
	IF (NCH.EQ.0) GO TO 400
D	WRITE (6,666) NCH,(FSYM(I),I=1,NCH)
D666	FORMAT (/' NCH,FSYM = 'I5/20(2X,A2))
D	WRITE (6,667) (ISYM(I),I=1,NCH)
D667	FORMAT (20(2X,I3))


	GO TO (210,220,220,210),LOG

C	AND LOGIC

210	DO 211 J=1,NSIZE
211	TMP(J)=-1
	DO 218 I=1,NCH
	READ (2,REC=ISYM(I)) CHEM
	DO 215 J=1,NSIZE
	IF (TMP(J).EQ.0) GO TO 215
	TMP(J)=IAND(TMP(J),CHEM(J))
215	CONTINUE
218	CONTINUE
	IF (LOG.EQ.4) GO TO 240
	GO TO 250
	
C	OR LOGIC

220	DO 221 J=1,NSIZE
221	TMP(J)=0
	DO 225 I=1,NCH
	READ (2,REC=ISYM(I)) CHEM
	DO 223 J=1,NSIZE
223	TMP(J)=IOR(TMP(J),CHEM(J))
225	CONTINUE
	GO TO 250

C	ONLY LOGIC

240	DO 248 K=1,103
	IF (LN.EQ.1.AND.(K.GE.57.AND.K.LE.71)) GO TO 248
	READ (2,REC=K) CHEM
	DO 242 I=1,NCH
	IF (ISYM(I).EQ.K)  GO TO 248
242	CONTINUE
	DO 244 J=1,NSIZE
	IF (TMP(J).EQ.0) GO TO 244
	CHEM(J)=NOT(CHEM(J))
	TMP(J)=IAND(TMP(J),CHEM(J))
244	CONTINUE
248	CONTINUE

250	DO 252 J=1,NSIZE
	IF (TABLE(J).EQ.0) GO TO 252
	IF (LOG.EQ.3) TMP(J)=NOT(TMP(J))
	TABLE(J)=IAND(TABLE(J),TMP(J))
252	CONTINUE

150	CALL COUNT (ISIZE,NSIZE,TABLE,KOUNT)
155	WRITE (6,160)
160	FORMAT (/'$ARE YOU SATISFIED WITH THE RESULTS ([Y]/N)? ')
	READ (5,103) ANS
	CALL UPCASE (ANS,ANS,1)
        IF(ANS.EQ.' ') ANS=YES
        IF(ANS.EQ.YES.OR.ANS.EQ.NO) GO TO 165
        GO TO 155
165	IF (ANS.NE.'N') THEN
	DO 170 I=1,2000
170	TABLE1(I)=TABLE(I)
	GO TO 101

C	IF NOT HAPPY, GO BACK TO PREVIOUS TABLE

	ELSE
	DO 180 I=1,2000
180	TABLE(I)=TABLE1(I)
	WRITE (6,190)
190	FORMAT (' REVERTING TO FORMER TABLE')
	CALL COUNT(ISIZE,NSIZE,TABLE,KOUNT)
	GO TO 101
	ENDIF




300	WRITE (6,305)
305	FORMAT (/' LOGIC HELP:',/
	1 ' AND  - ALL ELEMENTS ENTERED MUST BE PRESENT; OTHERS MAY BE'/
	2 ' OR   - AT LEAST ONE OF THE ENTERED ELEMENTS MUST BE PRESENT'
	3 '; OTHERS MAY BE'/
	4 ' ONLY - AN "AND" ON THE ELEMENTS ENTERED; A "NOT" ON ALL THE'
	5 ' OTHERS'/
	6 ' NOT  - ENTERED ELEMENTS MAY NOT BE PRESENT'/)
	GO TO 101


400	WRITE (6,402)
402	FORMAT (//' NO SYMBOLS WERE RECOGNIZED IN YOUR INPUT.',
	1 /' PLEASE INPUT CHEMICAL INFORMATION AGAIN.'/)
	GO TO 101



500   WRITE(6,502)
502   FORMAT(' TASK COMPLETED')
      CALL PUT(TABLE,ISIZE,NSIZE)
	STOP 'END OF CHEMISTRY SELECTION' 
      END




      FUNCTION LENGTH (STRING,MAXLEN)
C*********************************************************************

C          ROUTINE TO FIND THE LENGTH OF A CHARACTER STRING.
C          THE LENGTH IS DEFINED AS THE POSITION OF THE LAST
C          NON-BLANK CHARACTER.  LENGTH=0 IF STRING IS BLANK.
C
      IMPLICIT  INTEGER (A-Z)
      BYTE STRING(MAXLEN)
C
      DO 400 I=MAXLEN,1,-1
      IF(STRING(I) .NE. ' ') THEN
         LENGTH = I
         RETURN
      ENDIF
400   CONTINUE

      LENGTH = 0
      RETURN
      END




	SUBROUTINE UPCASE (LC,UC,NCHAR)
C*********************************************************************

C	CONVERT FROM LOWER CASE TO UPPER CASE.
C	STORE LOWER CASE ARRAY IN LC.
C	STORE UPPER CASE ARRAY IN UC.
C	NCHAR IS THE NUMBER OF CHARACTERS TO CONVERT.
C
	LOGICAL*1 LC(1),UC(1)
	DO 100 I=1,NCHAR
	UC(I)=LC(I)
	IF(UC(I).GE."141.AND.UC(I).LE."172) UC(I)=UC(I)-"040
100	CONTINUE
	RETURN
	END
	SUBROUTINE ELEMENTS(L,FORM,NCH,FSYM)
C
C	READS A LINE OF FORMULA AND PICKS OUT THE ELEMENTS PRESENT
C

C
      INTEGER*2 FSYM(40),MTEST
      BYTE FORM(80),ISYM(2)
      EQUIVALENCE(MTEST,ISYM)
      DO 100 K=1,20
100   FSYM(K)='  '
      J=1
      NCH=0
      ISYM(1)=' '
      ISYM(2)=' '
200   IF(FORM(J).GE.'A'.AND.FORM(J).LE.'Z')GO TO 210
      J=J+1
      IF(J.GT.L)GO TO 300
      GO TO 200
210   ISYM(1)=FORM(J)
      J=J+1
      IF(J.GT.L)GO TO 230
      IF(FORM(J).GE.'a'.AND.FORM(J).LE.'z')ISYM(2)=FORM(J)
230   IF(NCH.EQ.0)GO TO 260
      DO 250 K=1,NCH
250   IF(MTEST.EQ.FSYM(K))GO TO 270
260   NCH=NCH+1
      FSYM(NCH)=MTEST
      IF(NCH.GE.20)GO TO 300
270   ISYM(1)=' '
      ISYM(2)=' '
      J=J+1
      IF(J.GT.L) GO TO 300
      GO TO 200
300   NSYM=NCH
      RETURN
      END



	SUBROUTINE COUNT(ISIZE,NSIZE,TABLE,KOUNT)
C*********************************************************************
C
C	TALLY THE HITS

	INTEGER*4 TABLE(2000),NTABLE,MASK

       KOUNT=0
       DO 10 N=1,NSIZE
	NTABLE=TABLE(N)
	IF (NTABLE.EQ.0) GO TO 10
	DO 5 J=0,31
	MASK=IBITS(NTABLE,J,1)
	IF (MASK.EQ.1) KOUNT=KOUNT+1
5	CONTINUE
10	CONTINUE
       WRITE(6,100) KOUNT,ISIZE
100    FORMAT(' THERE ARE ',I6,' POSSIBLITIES, OUT OF A'
     1     ,1X,'FILE OF',I6)
	RETURN
	END
