linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ef5a0354f3edfc92ac90fc462f77df3478bad641
sics/difrac/burger.f
cvs fdc6b051c9 Initial revision
2000-02-07 10:38:55 +00:00

175 lines
6.5 KiB
Fortran
Raw Blame History

C-----------------------------------------------------------------------
C Buerger reduction
C-----------------------------------------------------------------------
SUBROUTINE BURGER (IOUT,A,ANG,IND)
CHARACTER COUT*132
COMMON /IOUASC/ COUT(20)
REAL IND(3,3)
DIMENSION AA(3,3),A(3),ANG(3)
DATA INUM/0/
RAD = 3.14159/180.0
C-----------------------------------------------------------------------
C Form the matrix of dot products
C-----------------------------------------------------------------------
DO 100 I = 1,3
DO 100 J = 1,3
IF (I .EQ. J) AA(I,J) = A(I)*A(I)
IF (I .NE. J) AA(I,J) = A(I)*A(J)*COS(ANG(6 - I - J)*RAD)
100 CONTINUE
C-----------------------------------------------------------------------
C Look for shorter translations in cell faces
C-----------------------------------------------------------------------
110 NUM = 0
DO 170 I = 1,3
DO 160 J = 1,3
IF (J .NE. I) THEN
IS = 1
IF (AA(I,J) .GT. 0) IS = -1
IS1 = IS
VMIN = 0
120 V = AA(I,J)*2*IS1 + AA(J,J)*IS1**2
IF (V .LT. VMIN) THEN
VMIN = V
IS1 = IS1 + IS
GO TO 120
ENDIF
C-----------------------------------------------------------------------
C Did we find a shorter translation?
C-----------------------------------------------------------------------
IS1 = IS1 - IS
IF (IS1 .NE. 0) THEN
C-----------------------------------------------------------------------
C Yes, we did. Accept it as a cell edge
C-----------------------------------------------------------------------
NUM = NUM + 1
INUM = INUM + 1
C-----------------------------------------------------------------------
C Transform the old-new indices
C-----------------------------------------------------------------------
DO 140 K = 1,3
IND(I,K) = IND(I,K) + IS1*IND(J,K)
140 CONTINUE
C-----------------------------------------------------------------------
C Modify the matrix of dot products
C-----------------------------------------------------------------------
AA(I,I) = AA(I,I) + AA(I,J)*2*IS1 + AA(J,J)*IS1**2
AA(I,J) = AA(I,J) + IS1*AA(J,J)
AA(J,I) = AA(I,J)
K = 6 - I - J
AA(I,K) = AA(I,K) + IS1*AA(J,K)
AA(K,I) = AA(I,K)
ENDIF
ENDIF
160 CONTINUE
170 CONTINUE
C-----------------------------------------------------------------------
C Look for more transformations
C-----------------------------------------------------------------------
IF (NUM .GE. 1) GO TO 110
C-----------------------------------------------------------------------
C Are the cross-terms of a same sign?
C-----------------------------------------------------------------------
180 VAR = ABS(AA(1,2)) + ABS(AA(1,3)) + ABS(AA(2,3))
IF (ABS(ABS(AA(1,2)+AA(1,3)+AA(2,3))-VAR) .GT. 0.0001*VAR) THEN
C-----------------------------------------------------------------------
C No, find the odd sign
C-----------------------------------------------------------------------
ISIGN = 1
IF (AA(1,2)*AA(1,3)*AA(2,3) .LT. 0) ISIGN = -1
C-----------------------------------------------------------------------
C Reverse two vectors to make the cell triacute or triobtuse
C-----------------------------------------------------------------------
DO 200 I = 1,2
K = I + 1
DO 190 J = K,3
IF (AA(I,J)*ISIGN .GT. 0.0) GO TO 210
190 CONTINUE
200 CONTINUE
210 K = 6 - I - J
C-----------------------------------------------------------------------
C Modify the indices and the dot products
C-----------------------------------------------------------------------
DO 220 II = 1,3
IND(I,II) = -IND(I,II)
IND(J,II) = -IND(J,II)
220 CONTINUE
AA(K,J) = -AA(K,J)
AA(J,K) = -AA(J,K)
AA(K,I) = -AA(K,I)
AA(I,K) = -AA(I,K)
ENDIF
C-----------------------------------------------------------------------
C Order the diagonal terms in increasing values
C-----------------------------------------------------------------------
INUM = 0
240 NUM = 0
DO 280 I = 1,2
IF ((AA(I,I) - AA(I+1,I+1)) .GT. 0.0) THEN
NUM = NUM + 1
INUM = INUM + 1
DO 250 J = 1,3
SAVE = AA(I,J)
AA(I,J) = AA(I + 1,J)
AA(I + 1,J) = SAVE
250 CONTINUE
DO 260 J = 1,3
SAVE = AA(J,I)
AA(J,I) = AA(J,I + 1)
AA(J,I + 1) = SAVE
260 CONTINUE
DO 270 K = 1,3
SAVE = IND(I,K)
IND(I,K) = IND(I + 1,K)
IND(I + 1,K) = SAVE
270 CONTINUE
ENDIF
280 CONTINUE
IF (NUM .NE. 0) GO TO 240
C-----------------------------------------------------------------------
C If the cell is left-handed, reverse all axes
C-----------------------------------------------------------------------
IF (MOD(INUM,2) .NE. 0) THEN
DO 290 I = 1,3
DO 290 J = 1,3
C-----------------------------------------------------------------------
C If 111 is shorter than c, call it c and re-reduce the cell
C-----------------------------------------------------------------------
IND(I,J) = -IND(I,J)
290 CONTINUE
ENDIF
IF (AA(1,1)+AA(2,2) .LT. -2*(AA(1,2)+AA(1,3)+AA(2,3))) THEN
AA(3,3) = AA(3,3) + 2*AA(3,1) + AA(1,1)
AA(3,1) = AA(3,1) + AA(1,1)
AA(1,3) = AA(3,1)
AA(3,2) = AA(3,2) + AA(1,2)
AA(2,3) = AA(3,2)
AA(3,3) = AA(3,3) + 2*AA(3,2) + AA(2,2)
AA(3,2) = AA(3,2) + AA(2,2)
AA(2,3) = AA(3,2)
AA(3,1) = AA(3,1) + AA(1,2)
AA(1,3) = AA(3,1)
DO 310 J = 1,3
IND(3,J) = IND(1,J) + IND(2,J) + IND(3,J)
310 CONTINUE
GO TO 180
ENDIF
C-----------------------------------------------------------------------
C Get the Niggli cell parameters
C-----------------------------------------------------------------------
DO 330 I = 1,3
A(I) = SQRT(AA(I,I))
330 CONTINUE
DO 340 I = 1,3
J = MOD(I,3) + 1
K = MOD(J,3) + 1
ANG(I) = ACOS(AA(J,K)/(A(J)*A(K)))/RAD
340 CONTINUE
WRITE (COUT,10000) A,ANG
CALL GWRITE (IOUT,' ')
WRITE (COUT,11000) ((IND(I,J),J = 1,3),I = 1,3)
CALL GWRITE (IOUT,' ')
RETURN
10000 FORMAT (/' The Shortest Non-coplanar Translations '/10X,6F10.3)
11000 FORMAT (' The Old-to-New Cell Matrix'/(10X,3F6.1))
END
Reference in New Issue View Git Blame Copy Permalink