C	PROGRAM AXIS
C
C	SELECTION BY UNIQUE AXIS

	INTEGER*4 TABLE(2000),NTABLE,MASK
        INTEGER*2 IAC(6)
        REAL AC(6)
	CHARACTER*24 STUFF
        CHARACTER*1 ANS

      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 CELL EDGES')
11233 WRITE(6,11234)
11234 FORMAT(' SINCE THE CHEMICAL ELEMENTS ARE "INDEXED", SEARCHES'/
     1  10X,'ON ELEMENTS ARE VERY FAST.  SEARCHES ON CELL EDGES'
     1   1X,'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') STOP 'JOB ABORTED--START AGAIN'
      IF(ANS.NE.'Y') GO TO 11233
299   WRITE(6,300)
300   FORMAT(/' WOULD YOU LIKE TO SEE INFORMATION FROM THE BOOK'/
     1 10X,'CRYSTAL DATA, REGARDING THE UNIQUE CELL EDGES ?'/
     2 10X,'PLEASE GIVE YOUR RESPONSE ([Yes]/No/Exit)  ',$)
      READ(5,11236) NCR,ANS
11236 FORMAT(Q,1A1)
      IF(NCR.EQ.0) ANS='Y'
      KEY=STR$UPCASE(ANS,ANS)
      IF(ANS.EQ.'E') STOP 'JOB ABORTED--START AGAIN'
      IF(ANS.EQ.'N') GO TO 460
      IF(ANS.EQ.'Y') THEN
         KEY=LIB$SPAWN('$ TYPE CD:AXIAL_RATIO.TXT')
         GO TO 460
      ENDIF
      GO TO 299
460   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')
      ENDIF
      IF(KEY.EQ.2) THEN
                   OPEN(UNIT=20,STATUS='OLD',ACCESS='DIRECT',
     1             READONLY,SHARED,FORM='UNFORMATTED',RECL=32,
     2             FILE='LATTICEO')
      ENDIF
4443  WRITE(6,4444)
4444  FORMAT(' FOR ALL CASES, YOU MUST ENTER A, B, C.'/
     1   10X,'THIS METHOD OF ENTRY WILL ALLOW YOU TO SELECT'/
     1   10X,'ON CELLS THAT HAVE PSEUDOSYMMETRY--THAT IS WITHIN'/
     1   10X,'THE EXPERIMENTAL ERROR, CELL EDGES ARE NEARLY THE'/
     1   10X,'SAME. IF YOU REALLY WANT TO ELIMINATE CERTAIN SYSTEMS,'/
     1   10X,'THEN DO THE "SELECTION ON SYSTEM" AS WELL.'//)
D4444  FORMAT(' PLEASE ENTER THE SYSTEM IN WHICH YOU ARE INTERESTED'/
D     1   10X,'0 QUIT'/
D     1   10X,'1 ANORTHIC (TRICLINIC)'/
D     1   10X,'2 MONOCLINIC'/
D     1   10X,'3 ORTHORHOMIC'/
D     1   10X,'4 TETRAGONAL'/
D     1   10X,'5 HEXAGONAL'/
D     1   10X,'6 RHOMBOHEDRAL'/
D     1   10X,'7 CUBIC'/
D     1   10X,'PLEASE ENTER YOUR CHOICE  ',$)
D      READ(5,4445,ERR=4443) ISYSTEM
D4445  FORMAT(I)
D      IF(ISYSTEM.EQ.0) STOP 'JOB ABORTED--START AGAIN'
D      IF(ISYSTEM.LT.0.OR.ISYSTEM.GT.7) GO TO 4443
      ISYSTEM=1
C
C
C     CUBIC CASE FOLLOWS:
C
C
      IF(ISYSTEM.EQ.7)THEN 
      WRITE(6,4000)
4000  FORMAT(' CUBIC TEST--JUST CELL EDGE A')
199   WRITE(6,200)
      READ(5,201,ERR=199,END=20) ALO,AHI
201   FORMAT(2F10.5)
      IF(ALO.LT.2.0.OR.ALO.GT.100.0) GO TO 199
      IF(AHI.LT.2.0.OR.AHI.GT.100.0) GO TO 199
      IF(ALO.GT.AHI)                 GO TO 199
      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,IAC
        DO 10001 I12=1,6
        AC(I12)=0.01*IAC(I12)
10001    CONTINUE
D        WRITE(6,55112) AC
55112   FORMAT(6F10.5)
        A=AC(1)
	IF(ALO.LE.A.AND.AHI.GE.A) THEN
                          NUMANS=NUMANS+1
                          GO TO 390
      ENDIF
	TABLE(N)=IBCLR(TABLE(N),J)
390	CONTINUE
400   CONTINUE
401   WRITE(6,5004) ALO,AHI
      WRITE(6,402)
6000  CONTINUE
      ENDIF
C
C
C     TETRA, HEX AND RHOMB CASE
C
C
      IF(ISYSTEM.EQ.6.OR.ISYSTEM.EQ.5.OR.ISYSTEM.EQ.4) THEN
                       WRITE(6,6001)
6001  FORMAT(' RHOMBOHEDRAL, HEXAGONAL AND TETRAGONAL TEST'/
     1 10X,'-- JUST RATIO OF C/A'/ 
     1 10X,'-- ENTER RANGE FOR A AND C')
5444  WRITE(6,200)
      READ(5,201,ERR=199,END=20) ALO,AHI
      IF(ALO.LT.2.0.OR.ALO.GT.100.0) GO TO 5444
      IF(AHI.LT.2.0.OR.AHI.GT.100.0) GO TO 5444
      IF(ALO.GT.AHI)                 GO TO 5444
64199 WRITE(6,4200)
4200   FORMAT(' PLEASE ENTER THE RANGE OF C ,(C(LO), C(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (2.0 TO 100.0)  ',$)
      READ(5,201,ERR=64199,END=20) CLO,CHI
      IF(CLO.LT.2.0.OR.CLO.GT.100.0) GO TO 64199
      IF(CHI.LT.2.0.OR.CHI.GT.100.0) GO TO 64199
      IF(CLO.GT.CHI)                 GO TO 64199
      DO 4001 N=1,NSIZE
	DO 4051 K=0,31
	I=(N-1)*32+(K+1)
      IF(MOD(I,1000).EQ.0) WRITE(6,1000) I,NUMANS
4051	CONTINUE
	NTABLE=TABLE(N)
	IF (NTABLE.EQ.0) GO TO 4001
	DO 3901 J=0,31
	I=(N-1)*32+(J+1)
	MASK =IBITS(NTABLE,J,1)
	IF (MASK.EQ.0) GO TO 3901
	READ (20,REC=I,ERR=401) STUFF,IAC
        DO 10002 I12=1,6
        AC(I12)=0.01*IAC(I12)
10002    CONTINUE
D        WRITE(6,55112) AC
        A=AC(1)
        C=AC(3)
	IF((ALO.LE.A.AND.AHI.GE.A)  .AND.
     1      (CLO.LE.C.AND.CHI.GE.C)) THEN
                          NUMANS=NUMANS+1
                          GO TO 3901
      ENDIF
	TABLE(N)=IBCLR(TABLE(N),J)
3901  CONTINUE
4001  CONTINUE
      WRITE(6,5004) ALO,AHI
      WRITE(6,50041) CLO,CHI
5004  FORMAT(//' THE A CELL EDGE RANGE WAS ',2f8.2)
50041 FORMAT(//' THE C CELL EDGE RANGE WAS ',2f8.2)
      ENDIF
C
C
C     ANORTHIC, MONOCLINIC, AND ORTHO CASES
C
C
      IF(ISYSTEM.EQ.3.OR.ISYSTEM.EQ.2.OR.ISYSTEM.EQ.1) THEN
D                       WRITE(6,60011)
D60011  FORMAT(' ANORTHIC, MONOCLINIC AND ORTHORHOMBIC TEST'/
D     1  10X,'--VALUES FOR A, B, AND C ARE NEEDED'//)
444   WRITE(6,200)
200   FORMAT(' PLEASE ENTER THE RANGE OF A, (A(LO), A(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (2.0 TO 100.0)  ',$)
      READ(5,201,ERR=444,END=20) ALO,AHI
      IF(ALO.LT.2.0.OR.ALO.GT.100.0) GO TO 444
      IF(AHI.LT.2.0.OR.AHI.GT.100.0) GO TO 444
      IF(ALO.GT.AHI)                 GO TO 444
41991  WRITE(6,42002)
42002  FORMAT(' PLEASE ENTER THE RANGE OF B, (B(LO), B(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (2.0 TO 100.0)  ',$)
      READ(5,201,ERR=41991,END=20) BLO,BHI
      IF(BLO.LT.2.0.OR.BLO.GT.100.0) GO TO 41991
      IF(BHI.LT.2.0.OR.BHI.GT.100.0) GO TO 41991
      IF(BLO.GT.BHI)                 GO TO 41991
4199   WRITE(6,4200)
      READ(5,201,ERR=4199,END=20) CLO,CHI
      IF(CLO.LT.2.0.OR.CLO.GT.100.0) GO TO 4199
      IF(CHI.LT.2.0.OR.CHI.GT.100.0) GO TO 4199
      IF(CLO.GT.CHI)                 GO TO 4199
      DO 40018 N=1,NSIZE
	DO 40518 K=0,31
	I=(N-1)*32+(K+1)
      IF(MOD(I,1000).EQ.0) WRITE(6,1000) I,NUMANS
40518	CONTINUE
	NTABLE=TABLE(N)
	IF (NTABLE.EQ.0) GO TO 40018
	DO 39018 J=0,31
	I=(N-1)*32+(J+1)
	MASK =IBITS(NTABLE,J,1)
	IF (MASK.EQ.0) GO TO 39018
	READ (20,REC=I,ERR=401) STUFF,IAC
        DO 10008 I12=1,6
        AC(I12)=0.01*IAC(I12)
10008    CONTINUE
D        WRITE(6,55112) AC
        A=AC(1)
        B=AC(2)
        C=AC(3)
	IF(BLO.LE.B.AND.BHI.GE.B  .AND.
     1     CLO.LE.C.AND.CHI.GE.C  .AND.
     1     ALO.LE.A.AND.AHI.GE.A) THEN
                          NUMANS=NUMANS+1
                          GO TO 39018
      ENDIF
	TABLE(N)=IBCLR(TABLE(N),J)
39018  CONTINUE
40018  CONTINUE
      WRITE(6,5004)  ALO,AHI
      WRITE(6,6004)  BLO,BHI
      WRITE(6,50041) CLO,CHI
6004  FORMAT(//' THE B CELL EDGE RANGE WAS ',2F8.2)
      ENDIF
      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 AXIAL RATIO SELECTION' 
      END
