C	PROGRAM AXIAL_RATIO
C
C	SELECTION BY AXIAL RATIO

	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 AXIAL RATIO')
11233 WRITE(6,11234)
11234 FORMAT(' SINCE THE CHEMICAL ELEMENTS ARE "INDEXED", SEARCHES'/
     1  10X,'ON ELEMENTS ARE VERY FAST.  SEARCHES ON AXIAL RATIO'
     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 AXIAL RATIO DETERMINATION ?'/
     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(' PLEASE ENTER THE SYSTEM IN WHICH YOU ARE INTERESTED'/
     1   10X,'0 QUIT'/
     1   10X,'1 ANORTHIC (TRICLINIC)'/
     1   10X,'2 MONOCLINIC'/
     1   10X,'3 ORTHORHOMIC'/
     1   10X,'4 TETRAGONAL'/
     1   10X,'5 HEXAGONAL'/
     1   10X,'6 RHOMBOHEDRAL'/
     1   10X,'7 CUBIC'/
     1   10X,'PLEASE ENTER YOUR CHOICE  ',$)
      READ(5,4445,ERR=4443) ISYSTEM
4445  FORMAT(I)
      IF(ISYSTEM.EQ.0) STOP 'JOB ABORTED--START AGAIN'
      IF(ISYSTEM.LT.0.OR.ISYSTEM.GT.7) GO TO 4443
      WRITE(6,4700)
4700  FORMAT(//' *** INFORMATION ONLY ***'/
     1 10X,'ALL CELLS, REGARDLESS OF SYMMETRY ARE BEING REVIEWED'/
     1 10X,'SINCE A TETRAGONAL CELL WITH C/A EQUAL TO 1.000'/
     1 10X,'OR A MONOCLINIC WITH A BETA OF VERY NEAR'/
     1 10X,'90 DEGRESS IS STILL POSSIBLE. IF YOU WANT ONLY TO HAVE'/
     1 10X,'A SPECIFIC SYSTEM, THEN USE THE "SELECT ON SYSTEM" FIRST.'/
     1 10X,'THIS METHOD OF "SELECTION" WILL ADDRESS THESE STRANGE'/
     1 10X,'CASES OF "HIGHER PSEUDO-SYMMETRY".'//)
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)
200   FORMAT(' PLEASE ENTER THE CELL EDGE RANGE, (A(LO), A(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (2.5 TO 100.0)  ',$)
      READ(5,201,ERR=199,END=20) ALO,AHI
201   FORMAT(2F10.5)
      IF(ALO.LT.2.5.OR.ALO.GT.100.0) GO TO 199
      IF(AHI.LT.2.5.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
5004  FORMAT(//' THE CELL EDGE RANGE WAS ',2f8.2)
      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 C/A RATIO')
4199   WRITE(6,4200)
4200   FORMAT(' PLEASE ENTER THE RATIO C/A ,(C/A(LO), C/A(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (0.1 TO 100.0)  ',$)
      READ(5,201,ERR=4199,END=20) CALO,CAHI
      IF(CALO.LT.0.1.OR.CALO.GT.100.0) GO TO 4199
      IF(CAHI.LT.0.1.OR.CAHI.GT.100.0) GO TO 4199
      IF(CALO.GT.CAHI)                 GO TO 4199
      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
        CA=AC(3)/AC(1)
	IF(CALO.LE.CA.AND.CAHI.GE.CA) THEN
                          NUMANS=NUMANS+1
                          GO TO 3901
      ENDIF
	TABLE(N)=IBCLR(TABLE(N),J)
3901  CONTINUE
4001  CONTINUE
      WRITE(6,50041) CALO,CAHI
50041 FORMAT(//' THE C/A RATIO 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
                       WRITE(6,60011)
60011  FORMAT(' ANORTHIC, MONOCLINIC AND ORTHORHOMBIC TEST'/
     1  10X,'-- JUST RATIO OF A/B AND C/B'/
     1  10X,'-- ENTER RANGES FOR A/B AND C/B RATIO')
41991  WRITE(6,42002)
42002  FORMAT(' PLEASE ENTER THE RATIO A/B, (A/B(LO), A/B(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (0.1 TO 100.0)  ',$)
      READ(5,201,ERR=4199,END=20) ABLO,ABHI
      IF(ABLO.LT.0.1.OR.ABLO.GT.100.0) GO TO 41991
      IF(ABHI.LT.0.1.OR.ABHI.GT.100.0) GO TO 41991
      IF(ABLO.GT.ABHI)                 GO TO 41991
41992  WRITE(6,42001)
42001  FORMAT(' PLEASE ENTER THE RATIO C/A, (C/B(LO), C/B(HIGH)'/
     1 10X,'IN WHICH YOU ARE INTERESTED: (0.1 TO 100.0)  ',$)
      READ(5,201,ERR=4199,END=20) CBLO,CBHI
      IF(CBLO.LT.0.1.OR.CBLO.GT.100.0) GO TO 41992
      IF(CBHI.LT.0.1.OR.CBHI.GT.100.0) GO TO 41992
      IF(CBLO.GT.CBHI)                 GO TO 41992
      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
        IF(AC(2).EQ.0.0) AC(2)=100.0
        AB=AC(1)/AC(2)
        CB=AC(3)/AC(2)
	IF(CBLO.LE.CB.AND.CBHI.GE.CB  .AND.
     1    ABLO.LE.AB.AND.ABHI.GE.AB) THEN
                          NUMANS=NUMANS+1
                          GO TO 39018
      ENDIF
	TABLE(N)=IBCLR(TABLE(N),J)
39018  CONTINUE
40018  CONTINUE
      WRITE(6,50042) ABLO,ABHI
50042 FORMAT(//' THE A/B RATIO RANGE WAS ',2f8.2)
      WRITE(6,50043) CBLO,CBHI
50043 FORMAT(//' THE C/B RATIO 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
