C	PROGRAM CENTRO/NON-CENTRO SYSMETRIC
C
C	SELECTION BY SPACE GROUP NUMBER

	INTEGER*4 TABLE(2000),NTABLE,MASK
	INTEGER*2 NSPGC
        INTEGER*4 CENTRO(230),NON_CENTRO(230)
        INTEGER*4 COUNT_CENTRO
	CHARACTER*46 STUFF
        CHARACTER*1 ANS
        CHARACTER*1 SYSTEM(230)
        CHARACTER*13 SPACE_GROUP(230)
        DO 4455 I=1,230
        CENTRO(I)=0
        NON_CENTRO(I)=0
4455    CONTINUE
C
      WRITE(6,123)
123   FORMAT(' VAX VERSION AUG 30, 1988'/
     1  10X,'GERALD G. JOHNSON JR., MRL/PSU'/
     1  10X,'RICHARD L. HARLOW, I, DUPONT'/
     1  10X,'PROGRAM TO SEARCH CRYSTAL DATA FILE FOR SPACE GROUP'/
     1  10X,'TO MATCH CENTRO / NONCENTRO SYMMETRIC, DIFFRACTION'
     1   1x,'ASPECTS'/10x,'POLAR / NONPOLAR,'
     1  1X,'PIEZOELECTRIC, OR PYROELECTRIC SPACE GROUPS.'/
     1  10x,'PROPER SPACE GROUPS GIVEN BY D. K. SMITH AND C. M. FORIS'/)
11233 WRITE(6,11234)
11234 FORMAT(/' SINCE THE CHEMICAL ELEMENTS ARE "INDEXED", SEARCHES'/
     1  10X,'ON ELEMENTS ARE VERY FAST.  SEARCHES ON FUNCTIONAL'/
     2  10X,'GROUPS, SPACE GROUPS, SYSTEM, AND/OR CENTRO NONCENTRO'/
     3  10X 'SYMMETRIC SPACE GROUPS, MUST SEARCH THE'/
     3  10X,'FILE IN A SEQUENTIAL MANNER, SO THESE TYPES OF SEARCHES'/
     4  10X,'SHOULD BE DONE AFTER THE OTHER RESTRICTIVE SEARCHES'/
     5  10X,'ARE COMPLETED.'//
     6  10X,'DO YOU WANT TO CONTINUE (Y/N) ?  ',$)
      READ(5,11235) ANS
11235 FORMAT(1A1)
      KEY=STR$UPCASE(ANS,ANS)
      IF(ANS.EQ.'N') go to 20
      IF(ANS.NE.'Y') GO TO 11233
      CALL ERASE
      NUMANS=0
      CALL GET(TABLE,ISIZE,NSIZE)
      IF(ISIZE.EQ.59613) KEY=1
      IF(ISIZE.EQ.56140) KEY=2
      IF(KEY.EQ.1) THEN
                   OPEN(UNIT=20,STATUS='OLD',ACCESS='DIRECT',
     1             READONLY,SHARED,FORM='UNFORMATTED',RECL=32,
     2             FILE='LATTICEI',ERR=99112)
      ENDIF
      IF(KEY.EQ.2) THEN
                   OPEN(UNIT=20,STATUS='OLD',ACCESS='DIRECT',
     1             READONLY,SHARED,FORM='UNFORMATTED',RECL=32,
     2             FILE='LATTICEO',ERR=99112)
      ENDIF
      WRITE(6,11556)
11556 FORMAT(/' THE FOLLOWING CHOICES MAY BE OF USE FOR SEARCHES'/
     1   10X,'             INORGANIC         ORGANIC'/
     1   10X,'CENTRO         38814            37817'/
     1   10X,'NONCENTRO       9079            16639'/
     1   10X,'DIFF. ASPECT    2427              911'/
     1   10X,'NONE GIVEN     11720             1684'/
     1   10x,'POLAR           4976                 '/
     1   10x,'NONPOLAR       42391                 '/
     1   10X,'PIEZOELECTRIC                        '/
     1   10X,'PYROELECTRIC                         '//
     1   10X,'0 EXIT'/
     2   10X,'1 CENTROSYMMETRIC SPACE GROUPS'/
     3   10X,'2 NONCENTROSYMMETRIC SPACE GROUPS'/
     4   10X,'3 DIFFRACTION ASPECT'/ 
     5   10X,'4 NO SPACE GROUP NUMBER OR ASPECT GIVEN'/
     6   10X,'5 POLAR SPACE GROUPS'/
     7   10X,'6 NONPOLAR SPACE GROUPS'/
     8   10X,'7 PIEZOELECTRIC SPACE GROUPS'/
     9   10X,'8 PYROELECTRIC SPACE GROUPS'/)
199   WRITE(6,200)
200   FORMAT(' PLEASE ENTER THE OPTION IN WHICH'
     1   1X,'YOU ARE INTERESTED:  '$)
      READ(5,201,ERR=199,END=20) N1
201   FORMAT(1I)
      IF(N1.LT.0.OR.N1.GT.8) GOTO 199
      IF(N1.EQ.0) STOP 'JOB ABORTED--START AGAIN'
C
C
C
C
C
      write(6,2266)
2266  FORMAT(/' THE PROPER SPACE GROUPS ARE BEING LOADED'/)
      CALL LOADSG(SYSTEM,SPACE_GROUP)
C
C
C      FOLLOWING CODE LOADS THE CENTROSYMMETRIC SPACE GROUP NUMBERS
C
C
       if(n1.eq.1) then
       OPEN(UNIT=50,READONLY,SHARED,STATUS='OLD',ERR=9911,
     1 FILE='CD:CENTRO.DAT')
       DO 4456 I=1,230
       COUNT_CENTRO=I
       READ(50,4457,END=4458) CENTRO(I)
4457   FORMAT(I)
       WRITE(6,10006) CENTRO(I),SYSTEM(CENTRO(I)),
     1  SPACE_GROUP(CENTRO(I))
10006 FORMAT(I6,2X,1A1,2X,A13)
4456   CONTINUE
4458   CONTINUE
       CLOSE(UNIT=50)
       COUNT_CENTRO=COUNT_CENTRO-1
       WRITE(6,2289)
2289   FORMAT(/' THE CENTROSYMMETRIC TABLE IS COMPLETE'/)
D       WRITE(6,4477) COUNT_CENTRO
4477   FORMAT(' COUNT_CENTRO=',I10)
       endif
C
C
C      FOLLOWING CODE LOADS THE NON-CENTROSYMMETRIC SPACE GROUP NUMBERS
C
C
       if(n1.eq.2) then
       OPEN(UNIT=50,READONLY,SHARED,STATUS='OLD',ERR=9911,
     1 FILE='CD:NON_CENTRO.DAT')
       DO 14456 I=1,230
       COUNT_CENTRO=I
       READ(50,4457,END=14458) CENTRO(I)
       WRITE(6,10006) CENTRO(I),SYSTEM(CENTRO(I)),
     1  SPACE_GROUP(CENTRO(I))
14456   CONTINUE
14458   CONTINUE
       CLOSE(UNIT=50)
       COUNT_CENTRO=COUNT_CENTRO-1
       WRITE(6,12289)
12289   FORMAT(/' THE NONCENTROSYMMETRIC TABLE IS COMPLETE'/)
       endif
C
C
C     THE FOLLOWING IS FOR DIFFRACTION ASPECT
C
C
      IF(N1.EQ.3) THEN
      WRITE(6,6100)
6100  FORMAT(/' THE FOLLOWING LIST COMPRISES THOSE ENTRIES IN THE'
     1 ,1X,'CRYSTAL DATA FILE'/
     1 10X,'THAT DO NOT HAVE A SPACE GROUP CODED, BUT ONLY THE'/
     1 10X,'DIFFRACTION ASPECT.'/)
      ENDIF
C
C
C      THE FOLLOWING IS FOR 'NO SPACE GROUP GIVEN'
C
C
      IF(N1.EQ. 4) THEN
      WRITE(6,7001)
7001  FORMAT(/'THE FOLLOWING LIST COMPRISES THOSE ENTRIES IN THE'
     1  ,1X,'CRYSTAL DATA FILE'/
     2  10X,'THAT DO NOT HAVE SPACE GROUP CODED.'/)
      ENDIF
C
C
C     THE FOLLOWING IS FOR POLAR SPACE GROUPS
C
C
      IF(N1.EQ.5) THEN
      WRITE(6,7500)
7500  FORMAT(/' THE FOLLOWING LIST COMPRISES THOSE ENTRIES IN THE'
     1  ,1X,'CRYSTAL DATA FILE'/
     2  10X,'THAT ARE POLAR.')
       OPEN(UNIT=50,READONLY,SHARED,STATUS='OLD',ERR=9911,
     1 FILE='CD:POLAR.DAT')
       DO 24456 I=1,230
       COUNT_CENTRO=I
       READ(50,4457,END=24458) CENTRO(I)
       WRITE(6,10006) CENTRO(I),SYSTEM(CENTRO(I)),
     1  SPACE_GROUP(CENTRO(I))
24456   CONTINUE
24458   CONTINUE
       CLOSE(UNIT=50)
       COUNT_CENTRO=COUNT_CENTRO-1
       WRITE(6,22289)
22289   FORMAT(/' THE POLAR TABLE IS COMPLETE'/)
       endif
C
C
C     THE FOLLOWING IS FOR NONPOLAR SPACE GROUPS
C
C
      IF(N1.EQ.6) THEN
      WRITE(6,7501)
7501  FORMAT(/' THE FOLLOWING LIST COMPRISES THOSE ENTRIES IN THE'
     1  ,1X,'CRYSTAL DATA FILE'/
     2  10X,'THAT ARE NONPOLAR.')
       OPEN(UNIT=50,READONLY,SHARED,STATUS='OLD',ERR=9911,
     1 FILE='CD:NON_POLAR.DAT')
       DO 34456 I=1,230
       COUNT_CENTRO=I
       READ(50,4457,END=34458) CENTRO(I)
       WRITE(6,10006) CENTRO(I),SYSTEM(CENTRO(I)),
     1  SPACE_GROUP(CENTRO(I))
34456   CONTINUE
34458   CONTINUE
       CLOSE(UNIT=50)
       COUNT_CENTRO=COUNT_CENTRO-1
       WRITE(6,32289)
32289   FORMAT(/' THE NONPOLAR TABLE IS COMPLETE'/)
       endif
C
C
C     THE FOLLOWING IS FOR THE PIEZOELECTRIC SPACE GROUPS
C
C
      IF(N1.EQ.7) THEN
      WRITE(6,37501)
37501  FORMAT(/' THE FOLLOWING LIST COMPRISES THOSE ENTRIES IN THE'
     1  ,1X,'CRYSTAL DATA FILE'/
     2  10X,'THAT ARE PIEZOELECTRIC.')
       OPEN(UNIT=50,READONLY,SHARED,STATUS='OLD',ERR=9911,
     1 FILE='CD:PIEZO.DAT')
       DO 44456 I=1,230
       COUNT_CENTRO=I
       READ(50,4457,END=44458) CENTRO(I)
       WRITE(6,10006) CENTRO(I),SYSTEM(CENTRO(I)),
     1  SPACE_GROUP(CENTRO(I))
44456   CONTINUE
44458   CONTINUE
       CLOSE(UNIT=50)
       COUNT_CENTRO=COUNT_CENTRO-1
       WRITE(6,42289)
42289   FORMAT(/' THE PIEZOELECTRIC TABLE IS COMPLETE'/)
       endif
C
C
C     THE FOLLOWING IS FOR THE PYROELECTRIC SPACE GROUPS
C
C
      IF(N1.EQ.8) THEN
      WRITE(6,57501)
57501  FORMAT(/' THE FOLLOWING LIST COMPRISES THOSE ENTRIES IN THE'
     1  ,1X,'CRYSTAL DATA FILE'/
     2  10X,'THAT ARE PYROELECTRIC.')
       OPEN(UNIT=50,READONLY,SHARED,STATUS='OLD',ERR=9911,
     1 FILE='CD:PYRO.DAT')
       DO 54456 I=1,230
       COUNT_CENTRO=I
       READ(50,4457,END=54458) CENTRO(I)
       WRITE(6,10006) CENTRO(I),SYSTEM(CENTRO(I)),
     1  SPACE_GROUP(CENTRO(I))
54456   CONTINUE
54458   CONTINUE
       CLOSE(UNIT=50)
       COUNT_CENTRO=COUNT_CENTRO-1
       WRITE(6,52289)
52289   FORMAT(/' THE PYROELECTRIC TABLE IS COMPLETE'/)
       endif
C
C
C
C
C
      DO 400 N=1,NSIZE
	DO 405 K=0,31
	I=(N-1)*32+(K+1)
      IF(MOD(I,1000).EQ.0) WRITE(6,1000) I,NUMANS
1000  FORMAT(' PASSING PATTERN NUMBER ',I6,' WITH TOTAL HITS =',I6)
405	CONTINUE
	NTABLE=TABLE(N)
	IF (NTABLE.EQ.0) GO TO 400
	DO 390 J=0,31
	I=(N-1)*32+(J+1)
	MASK =IBITS(NTABLE,J,1)
	IF (MASK.EQ.0) GO TO 390
	READ (20,REC=I,ERR=401) STUFF,NSPGC
C
C
C       HERE IS GOOD STUFF
C
C
        IF(N1.EQ.3.AND.NSPGC.LT.0) GO TO 6006
        IF(N1.EQ.4.AND.NSPGC.EQ.0) GO TO 6006
        nspgc=abs(nspgc)
        ihit=0
        CALL B_SEARCH(NSPGC,CENTRO,COUNT_CENTRO,IHIT)
	IF(IHIT.EQ.1) THEN
6006                      NUMANS=NUMANS+1
                          GO TO 390
      ENDIF
	TABLE(N)=IBCLR(TABLE(N),J)
390	CONTINUE
400   CONTINUE
401   WRITE(6,402)
402   FORMAT(' TASK COMPLETED')
      IF(NUMANS.EQ.0) THEN
                      WRITE(6,700)
700   FORMAT(' THIS IS A VERY STRANGE RESULT--THERE ARE NO ANSWERS'/
     110X,'RATHER THAN GIVING YOU AN EMPTY SET, THIS SELECTION'/
     210X,'IS BEING IGNORED--THE RESULTS ARE BEING RESET AS BEFORE')
      CALL GET(TABLE,ISIZE,NSIZE)
      ENDIF
      CALL PUT(TABLE,ISIZE,NSIZE)
C
C
C
20    STOP 'END OF SPACE GROUP / SYMMETRIC SELECTION' 
9911  STOP 'ERROR ON DATA READ OF SPACE GROUPS'
99112 STOP 'ERROR ON LATTICE*.DAT OPEN'
      END
       SUBROUTINE LOADSG(SYSTEM,TABLE) 
       CHARACTER*13 TABLE(230),TEMP,ANS
       CHARACTER*1 SYSTEM(230)
       character*13 symbol(230,0:5)
       CHARACTER*3 STRING
       do 444 i=1,230
       do 444 j=0,5
444    symbol(i,j)='     '
       DO 1 I=1,230
1      TABLE(I)=' '
       DO 2 I=1,2
2      SYSTEM(I)='A'
       DO 3 I=3,15
3      SYSTEM(I)='M'
       DO 4 I=16,74
4      SYSTEM(I)='O'
       DO 5 I=75,142
5      SYSTEM(I)='T'
       DO 6 I=143,194
6      SYSTEM(I)='H'
       DO 7 I=195,230
7      SYSTEM(I)='C'
       OPEN (UNIT=33,FILE='U$DISK1:[XRD.POWD10]SPGR.DAT',READONLY,
     1       SHARED,STATUS='OLD',ERR=999)
       J=1
       DO 9002 I=1,1500
       READ(33,123,END=20,ERR=998) NUMBER, TEMP,icode
123    FORMAT(I4,17X,A13,26X,i2)
       if(number.eq.0) go to 9002
       if(number.lt.0) go to 9002
       IF(NUMBER.GT.230) GO TO 9002
       IF(symbol(NUMBER,icode).eq.'    ') then
d                       WRITE(6,124) NUMBER,TEMP,icode
124    FORMAT(I10,5X,A13,5X,I10)
                       symbol(NUMBER,icode)=temp
                       GO TO 9002
       ENDIF
9002   CONTINUE
20     CONTINUE
       CLOSE(UNIT=33)
9991   DO 2345 I=1,230
2345   TABLE(I)=SYMBOL(I,0)
       RETURN
998    STOP 'ERROR IN READING SPACE GROUP FILE'
999    STOP 'ERROR ON SPACE GROUP OPEN'
99112  STOP 'ERROR ON LATTICE*.DAT DATA BASE'
       END
       SUBROUTINE B_SEARCH(NSPGC,CENTRO,COUNT_CENTRO,IHIT)
       INTEGER*4 IHIT,COUNT_CENTRO
       INTEGER*4 CENTRO(230)
       INTEGER*2 NSPGC
d       WRITE(6,1000) NSPGC
1000   FORMAT(' input sg=',i10)
d       WRITE(6,1001) (CENTRO(I),I=1,COUNT_CENTRO)
1001   FORMAT(8I10)
       ILOW=1
       IHI=COUNT_CENTRO+1
       ISIZE=COUNT_CENTRO
       IHIT=0
25     IF(ISIZE.LE.0) GO TO 150
d       write(6,2277) ilow,ihi,imid
2277   format(' ilow  ihi '2i10)
       ISIZE=ISIZE/2
       MID=(ILOW+IHI)/2
       IF(NSPGC.LT.CENTRO(MID)) IHI=MID
       IF(NSPGC.GT.CENTRO(MID)) ILOW=MID
       IF(NSPGC.NE.CENTRO(MID)) GO TO 25
       IHIT=1
150    RETURN
       END
	SUBROUTINE ERASE
C
C	   Erase the CRT screen.  Now set up only for VT100 type.
C	   Will be set up to handle different terminal types based upon
C	   type of terminal.
C
C	   By: Mark Holomany     Date: 20-Oct-1985
C
C
	CHARACTER*1	ESC


	ESC = CHAR(27)
	WRITE (6, 1601) ESC,ESC
1601	FORMAT('+',A1, '[H', A1, '[J',$)

	RETURN
	END
