400 lines
18 KiB
Fortran
400 lines
18 KiB
Fortran
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<b<c
|
|
C-----------------------------------------------------------------------
|
|
IF (ISYS .EQ. 5) GO TO 480
|
|
C-----------------------------------------------------------------------
|
|
C Put the rhombohedral lattice in obverse setting
|
|
C-----------------------------------------------------------------------
|
|
IF (ISYS .NE. 3) GO TO 370
|
|
DO 360 JJ = 1,2
|
|
CALL MATRIX(MAT(1,1,I),ATM1,CRAP,CRAP,'TRNSPS')
|
|
CALL MATRIX(TEST,ATM1,RESULT,CRAP,'VMMULT')
|
|
DO 330 J = 1,3
|
|
ITEST = ABS(RESULT(J)) + .1
|
|
IF (ABS(ITEST - ABS(RESULT(J))) .GT. .1) GO TO 340
|
|
330 CONTINUE
|
|
GO TO 370
|
|
340 DO 350 JA = 1,2
|
|
DO 350 J = 1,3
|
|
MAT(J,JA,I) = -MAT(J,JA,I)
|
|
350 CONTINUE
|
|
360 CONTINUE
|
|
GO TO 220
|
|
C-----------------------------------------------------------------------
|
|
C Get the cell angles
|
|
C-----------------------------------------------------------------------
|
|
370 DO 380 J = 1,3
|
|
L = MOD(J,3) + 1
|
|
CALL MATRIX(VEC(1,L,I),VEC(1,6 - J - L,I),SCAL,CRAP,'SCALPR')
|
|
ALP(J) = (180./3.141593)*ACOS(SCAL)
|
|
380 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Get the lattice type of the conventional cell
|
|
C-----------------------------------------------------------------------
|
|
CALL LATMOD (MAT(1,1,I),MODE)
|
|
C-----------------------------------------------------------------------
|
|
C Output system and lattice type
|
|
C-----------------------------------------------------------------------
|
|
NTMATS = NTMATS + 1
|
|
WRITE (COUT,10000) NTMATS,(PSUDO(K,IP),K = 1,2),
|
|
$ (SYSTEM(K,ISYS),K = 1,2),MODE,AANG(MATMAX)
|
|
CALL GWRITE (IOUT,' ')
|
|
WRITE (LPT,10000) NTMATS,(PSUDO(K,IP),K = 1,2),
|
|
$ (SYSTEM(K,ISYS),K = 1,2),MODE,AANG(MATMAX)
|
|
C-----------------------------------------------------------------------
|
|
C Get the original axes of the conventional cell
|
|
C-----------------------------------------------------------------------
|
|
CALL MATRIX(MAT(1,1,I),ATM1,CRAP,CRAP,'TRNSPS')
|
|
CALL MATRIX(ATM1,TRANS,ATM2,CRAP,'MATMUL')
|
|
C-----------------------------------------------------------------------
|
|
C Get the original indices of the conventional reciprocal axes
|
|
C-----------------------------------------------------------------------
|
|
CALL MATRIX(ATM2,ATM1,CRAP,CRAP,'INVERT')
|
|
C-----------------------------------------------------------------------
|
|
C Output the original indices of conventional axes,
|
|
C cell edges and angles
|
|
C-----------------------------------------------------------------------
|
|
WRITE (COUT,11000) (T1(J),(ATM2(J,K),K = 1,3),ENGTH(J,I),T2(J),
|
|
$ ALP(J),T3(J),(ATM1(K,J),K = 1,3),J = 1,3)
|
|
CALL GWRITE (IOUT,' ')
|
|
WRITE (LPT,11000) (T1(J),(ATM2(J,K),K = 1,3),ENGTH(J,I),T2(J),
|
|
$ ALP(J),T3(J),(ATM1(K,J),K = 1,3),J = 1,3)
|
|
C-----------------------------------------------------------------------
|
|
C Save the transformation matrix, and system & lattice mode pointers
|
|
C for use in LISTER at the end of OC
|
|
C The system pointer here and for use in LISTER translate as :--
|
|
C System Cub Hex HexR Tet Ort Mon Tri Mode P A B C I F R
|
|
C ISYS (FNDSYS) 1 2 3 4 5 6 7
|
|
C ISYS (LISTER) 7 5 6 4 3 2 1 1 2 3 4 5 6 7
|
|
C-----------------------------------------------------------------------
|
|
DO 385 J = 1,3
|
|
DO 385 K = 1,3
|
|
TMATS(J,K,NTMATS) = ATM1(K,J)
|
|
385 CONTINUE
|
|
IF (ISYS .EQ. 1) ISYSF = 7
|
|
IF (ISYS .EQ. 2) ISYSF = 5
|
|
IF (ISYS .EQ. 3) ISYSF = 6
|
|
IF (ISYS .EQ. 4) ISYSF = 4
|
|
IF (ISYS .EQ. 5) ISYSF = 3
|
|
IF (ISYS .EQ. 6) ISYSF = 2
|
|
IF (ISYS .EQ. 7) ISYSF = 1
|
|
IFSYS(NTMATS) = ISYSF
|
|
WRITE (CMODE,'(A4)') MODE
|
|
IF (CMODE .EQ. 'P') IMODE = 1
|
|
IF (CMODE .EQ. 'A') IMODE = 2
|
|
IF (CMODE .EQ. 'B') IMODE = 3
|
|
IF (CMODE .EQ. 'C') IMODE = 4
|
|
IF (CMODE .EQ. 'I') IMODE = 5
|
|
IF (CMODE .EQ. 'F') IMODE = 6
|
|
IF (CMODE .EQ. 'R') IMODE = 7
|
|
IFMODE(NTMATS) = IMODE
|
|
C-----------------------------------------------------------------------
|
|
C Give up the search if an exact solution has been found
|
|
C-----------------------------------------------------------------------
|
|
IF (IP .EQ. 1) RETURN
|
|
NPSUDO = MATMAX - 1
|
|
C-----------------------------------------------------------------------
|
|
C Monoclinic + triclinic are treated separately because their
|
|
C conventional axes are not determined by symmetry
|
|
C-----------------------------------------------------------------------
|
|
IF (ISYS .EQ. 6) GO TO 390
|
|
C-----------------------------------------------------------------------
|
|
C Resume the search for a better solution
|
|
C-----------------------------------------------------------------------
|
|
GO TO 100
|
|
C-----------------------------------------------------------------------
|
|
C The monoclinic case
|
|
C-----------------------------------------------------------------------
|
|
390 IF (NPSUDO .LT. 1) GO TO 450
|
|
ISYS = 6
|
|
IF (NPSUDO .GT. 2) NPSUDO = 2
|
|
N = NPSUDO
|
|
MATMAX = N
|
|
IP = 2
|
|
IF (AANG(N) .LT. EXPER) IP = 1
|
|
CALL MATRIX (PMESH(1,1,N),MAT(1,1,1),CRAP,CRAP,'COPVEC')
|
|
CALL MATRIX (RH(1,N),MAT(1,2,1),CRAP,CRAP,'COPVEC')
|
|
CALL MATRIX (PMESH(1,2,N),MAT(1,3,1),CRAP,CRAP,'COPVEC')
|
|
CALL MATRIX (MAT(1,1,1),MAT(1,2,1),MAT(1,3,1),DET2,'DETERM')
|
|
IF (DET2 .GT. 0.) GO TO 410
|
|
DO 400 I1 = 1,3
|
|
MAT (I1,2,1) = -MAT (I1,2,1)
|
|
400 CONTINUE
|
|
410 DO 420 KA = 1,3
|
|
CALL MATRIX (AA,MAT(1,KA,1),VEC(1,KA,1),CRAP,'MATVEC')
|
|
CALL MATRIX (AA,MAT(1,KA,1),ENGTH(KA,1),CRAP,'LENGTH')
|
|
420 CONTINUE
|
|
I = 1
|
|
GO TO 370
|
|
C-----------------------------------------------------------------------
|
|
C-----triclinic
|
|
C-----------------------------------------------------------------------
|
|
450 ISYS = 7
|
|
IP = 1
|
|
I = 1
|
|
MATMAX = 20
|
|
AANG(20) = 0
|
|
DO 470 N = 1,3
|
|
DO 460 J = 1,3
|
|
MAT(J,N,1) = 0
|
|
MAT(N,N,1) = 1
|
|
460 CONTINUE
|
|
CALL MATRIX(AA,MAT(1,N,1),VEC(1,N,1),CRAP,'MATVEC')
|
|
CALL MATRIX(AA,MAT(1,N,1),ENGTH(N,1),CRAP,'LENGTH')
|
|
470 CONTINUE
|
|
GO TO 370
|
|
C-----------------------------------------------------------------------
|
|
C Rank a<b<c in orthorhombic
|
|
C-----------------------------------------------------------------------
|
|
480 IPERM = 0
|
|
DO 500 J = 1,2
|
|
IF (ENGTH(J,I) .LE. ENGTH(J + 1,I)) GO TO 500
|
|
IPERM = 1
|
|
SAVE = ENGTH(J,I)
|
|
ENGTH(J,I) = ENGTH(J + 1,I)
|
|
ENGTH(J + 1,I) = SAVE
|
|
DO 490 KA = 1,3
|
|
SAVE = MAT(KA,J,I)
|
|
MAT(KA,J,I) = MAT(KA,J + 1,I)
|
|
MAT(KA,J + 1,I) = SAVE
|
|
SAVE = VEC(KA,J,I)
|
|
VEC(KA,J,I) = VEC(KA,J + 1,I)
|
|
VEC(KA,J + 1,I) = SAVE
|
|
MAT(KA,5 - 2*J,I) = -MAT(KA,5 - 2*J,I)
|
|
VEC(KA,5 - 2*J,I) = -VEC(KA,5 - 2*J,I)
|
|
490 CONTINUE
|
|
500 CONTINUE
|
|
IF (IPERM .NE. 0) GO TO 480
|
|
GO TO 370
|
|
10000 FORMAT (' #',I2,5X,2A6,2A6,1X,A1,' Max Delta',F10.3)
|
|
11000 FORMAT (1X,A4,3F5.1,F10.4,2X,A6,F10.3,2X,A4,3F8.3)
|
|
END
|