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