C----------------------------------------------------------------------- C Find the crystal system C----------------------------------------------------------------------- SUBROUTINE FNDSYS (IOUT,DIRCOS,NPSUDO) REAL LATIC,MAT CHARACTER*6 SYSTEM,PSUDO,T2 CHARACTER*4 T1,T3,CMODE CHARACTER*132 COUT(20) COMMON /IODEVS/ ITP,ITR,LPT,LPTX,NB,NBLOCK,ISD,IID, $ IBYLEN,IPR,NPR,IIP COMMON /IOUASC/ COUT COMMON /GEOM/ AA(3,3),AINV(3,3),TRANS(3,3),RH(3,20),HH(3,20), $ AANG(20),PH(3,20),PMESH(3,2,20),PERPAX(20),N2,N3, $ EXPER COMMON /TRANS/ BLINDR(3,3),TMATS(3,3,20),IFSYS(20),IFMODE(20), $ NTMATS DIMENSION LATIC(3,9,5),NDIR(5),NAMBI(5),NIND(5),TOT(2),ENGTH(3,2) DIMENSION VEC(3,3,2),MAT(3,3,2),ALP(3),PSUDO(2,2) DIMENSION CUBIC(3,9),HEXAG(3,7),RHOMB(3,4),TETRAG(3,5) DIMENSION ORTHO(3,3),NAXES(3,2,5),MATCH(20),DIRCOS(3,20) DIMENSION SYSTEM(2,7),ATM1(3,3),ATM2(3,3),TEST(3),RESULT(3) DIMENSION T1(3),T2(3),T3(3) EQUIVALENCE (LATIC(1,1,1),CUBIC(1,1)),(LATIC(1,1,2),HEXAG(1,1)) EQUIVALENCE (LATIC(1,1,3),RHOMB(1,1)),(LATIC(1,1,4),TETRAG(1,1)) EQUIVALENCE (LATIC(1,1,5),ORTHO(1,1)) C----------------------------------------------------------------------- C The number of even-order axes, of orientation ambiguities, C of symmetry-unrelated axes C----------------------------------------------------------------------- DATA NDIR/9,7,3,5,3/,NAMBI/0,1,0,1,0/,NIND/2,3,1,2,1/ C----------------------------------------------------------------------- C The possible conventional axes C----------------------------------------------------------------------- DATA NAXES/1,3,4, 0,0,0, 1,5,3, 2,6,3, 1,2,4, 0,0,0, $ 1,4,2, 5,3,2, 1,2,3, 0,0,0/ C----------------------------------------------------------------------- C The direction cosines of the even-order axes in the system C----------------------------------------------------------------------- DATA CUBIC / 1.0, 0, 0, .707,.707, 0, 0, 1, 0, $ 0, 0, 1, .707, 0,.707, 0,.707,.707, $ .707,-.707, 0, .707, 0,-.707, 0,.707,-.707/ DATA HEXAG / .5,-.866,0, .866, -.5,0, 0,0,1, $ .866, .5,0, .5,.866,0, 0,1,0, 1,0,0/ DATA RHOMB / .5,-.866,0, .5,.866,0, -1,0,0, 0,0,1/ DATA TETRAG/ 1,0,0, 0,0,1, .707,.707,0, 0,1,0, .707,-.707,0/ DATA ORTHO / 1,0,0, 0,1,0, 0,0,1/ DATA ACCEPT/.06/,TEST/.666667,.333333,.333333/ DATA PSUDO/' Metri','cally ',' P','seudo '/ DATA SYSTEM/' ',' Cubic',' Hex','agonal',' Hex','agonal', $ ' Tetr','agonal','Orthor','hombic',' Mono','clinic', $ ' Tri','clinic'/ DATA T1 /'a ','b ','c '/,T2/'Alpha ','Beta ','Gamma '/ DATA T3 /'a* ','b* ','c* '/ NTMATS = 0 100 IF (NPSUDO .LT. 3) GO TO 390 C----------------------------------------------------------------------- C Consider the C,H,R,T and O systems C----------------------------------------------------------------------- ISYS = 1 C----------------------------------------------------------------------- C Consider rows in turn and call them primary C----------------------------------------------------------------------- 110 IPRIM = 1 C----------------------------------------------------------------------- C If not enough rows are left, no solution can be found, skip C----------------------------------------------------------------------- 120 IF (NPSUDO .LT. IPRIM + NDIR(ISYS) - 1) GO TO 240 C----------------------------------------------------------------------- C Consider symmetry-unrelated primary axes to be matched with C the primary row C----------------------------------------------------------------------- IFIRST = 1 C----------------------------------------------------------------------- C Pick up a secondary row C----------------------------------------------------------------------- 130 ISEC = IPRIM + 1 C----------------------------------------------------------------------- C If not enough rows are left, skip C----------------------------------------------------------------------- 140 IF (NPSUDO .LT. ISEC + NDIR(ISYS) - 2) GO TO 230 C----------------------------------------------------------------------- C Get the angle between the two selected rows C----------------------------------------------------------------------- CALL MATRIX(DIRCOS(1,IPRIM),DIRCOS(1,ISEC),PRODOB,CRAP,'SCALPR') C----------------------------------------------------------------------- C Pick up a secondary even-order axis C----------------------------------------------------------------------- ITWO = 1 150 IF (ITWO .EQ. IFIRST) GO TO 220 C----------------------------------------------------------------------- C Calculate the angle between the primary and secondary axes C----------------------------------------------------------------------- CALL MATRIX(LATIC(1,IFIRST,ISYS),LATIC(1,ITWO,ISYS),PROCAL,CRAP, $ 'SCALPR') C----------------------------------------------------------------------- C Try to match the obs and calc angles C----------------------------------------------------------------------- IF (PRODOB*PROCAL .GE. 0.) GO TO 170 DO 160 I = 1,3 RH(I,ISEC) = -RH(I,ISEC) DIRCOS(I,ISEC) = -DIRCOS(I,ISEC) 160 CONTINUE PRODOB = -PRODOB 170 IF (ABS(PRODOB - PROCAL) .GT. ACCEPT) GO TO 220 C----------------------------------------------------------------------- C The angles match, try to associate an obs row with each axis in C the system C----------------------------------------------------------------------- DO 210 IANY = 1,NDIR(ISYS) C----------------------------------------------------------------------- C Get the hand of IFIRST, ITWO, IANY C----------------------------------------------------------------------- CALL MATRIX(LATIC(1,IFIRST,ISYS),LATIC(1,ITWO,ISYS), $ LATIC(1,IANY,ISYS),HAND1,'DETERM') C----------------------------------------------------------------------- C Calculate angle of try axis with primary and secondary axes C----------------------------------------------------------------------- CALL MATRIX(LATIC(1,IFIRST,ISYS),LATIC(1,IANY,ISYS),PROC1,CRAP, $ 'SCALPR') CALL MATRIX(LATIC(1,ITWO,ISYS),LATIC(1,IANY,ISYS),PROC2,CRAP, $ 'SCALPR') C----------------------------------------------------------------------- C Now find a row that could match this axis C----------------------------------------------------------------------- DO 200 ITRY = 1,NPSUDO IS = 1 C----------------------------------------------------------------------- C Get the hand of IPRIM, ISEC, ITRY C----------------------------------------------------------------------- CALL MATRIX(DIRCOS(1,IPRIM),DIRCOS(1,ISEC),DIRCOS(1,ITRY), $ HAND2,'DETERM') CALL MATRIX(DIRCOS(1,ITRY),DIRCOS(1,IPRIM),PROD1,CRAP, $ 'SCALPR') CALL MATRIX(DIRCOS(1,ITRY),DIRCOS(1,ISEC),PROD2,CRAP,'SCALPR') 180 IF (ABS(PROC1 - IS*PROD1) .GT. ACCEPT) GO TO 190 IF (ABS(PROC2 - IS*PROD2) .GT. ACCEPT) GO TO 190 IF (ABS(HAND2 - IS*HAND1) .GT. .1) GO TO 190 C----------------------------------------------------------------------- C This row is OK, remember it C----------------------------------------------------------------------- MATCH(IANY) = ITRY*IS GO TO 210 190 IF (IS .EQ. -1) GO TO 200 IS = -1 GO TO 180 200 CONTINUE GO TO 220 210 CONTINUE C----------------------------------------------------------------------- C We were able to associate a row with each axis in the system C----------------------------------------------------------------------- GO TO 250 220 ITWO = ITWO + 1 IF (ITWO .LE. NDIR(ISYS)) GO TO 150 ISEC = ISEC + 1 IF (ISEC .LE. NPSUDO) GO TO 140 230 IFIRST = IFIRST + 1 IF (IFIRST .LE. NIND(ISYS)) GO TO 130 IPRIM = IPRIM + 1 IF (IPRIM .LE. NPSUDO) GO TO 120 240 ISYS = ISYS + 1 IF (ISYS .LE. 5) GO TO 110 GO TO 390 C----------------------------------------------------------------------- C Find the worst-fitting row C----------------------------------------------------------------------- 250 MATMAX = 0 DO 260 I = 1,NDIR(ISYS) IF (ABS(MATCH(I)) .GT. MATMAX) MATMAX = ABS(MATCH(I)) 260 CONTINUE C----------------------------------------------------------------------- C Does it fit within experimental accuracy? C----------------------------------------------------------------------- IP = 2 IF (AANG(MATMAX) .LT. EXPER) IP = 1 C----------------------------------------------------------------------- C Find the conventional reference axes among the symmetry axes C----------------------------------------------------------------------- I = 1 270 J = 1 280 IAX = NAXES(J,I,ISYS) IF (IAX .LE. NDIR(ISYS)) GO TO 300 C----------------------------------------------------------------------- C Rhombohedral, find the three-fold axis C----------------------------------------------------------------------- DO 290 I1 = N2 + 1, N3 CALL MATRIX(DIRCOS(1,MATCH(1)),DIRCOS(1,MATCH(2)),DIRCOS(1,I1), $ DET2,'DETERM') ISG = 1 IF (DET2 .LT. 0.) ISG = -1 IF (ABS(ABS(DET2) - 0.866).GT.0.1) GO TO 290 MATCH(IAX) = I1 * ISG GO TO 300 290 CONTINUE C----------------------------------------------------------------------- C No three-fold axis, next combination of twofolds C----------------------------------------------------------------------- GO TO 220 300 NAX = IABS(MATCH(IAX)) IS = 1 IF (MATCH(IAX) .LT. 0) IS = -1 C----------------------------------------------------------------------- C Store the direction cosines and the primitive indices of the C conventional axes C----------------------------------------------------------------------- DO 310 K = 1,3 VEC(K,J,I) = IS*DIRCOS(K,NAX) MAT(K,J,I) = IS*RH(K,NAX) 310 CONTINUE C----------------------------------------------------------------------- C Get the length of the conventional cell edges C----------------------------------------------------------------------- CALL MATRIX(AA,MAT(1,J,I),ENGTH(J,I),CRAP,'LENGTH') J = J + 1 IF (J .LE. 3) GO TO 280 I = I + 1 IF (I .LE. NAMBI(ISYS) + 1) GO TO 270 C----------------------------------------------------------------------- C Keep the solution with the shortest cell edges C----------------------------------------------------------------------- TOT(2) = 1.E6 DO 320 I = 1,NAMBI(ISYS) + 1 TOT(I) = 0 DO 320 J = 1,3 TOT(I) = TOT(I) + ENGTH(J,I) 320 CONTINUE I = 1 IF (TOT(2) .LT. TOT(1)) I = 2 C----------------------------------------------------------------------- C Rank the orthorhombic axes a