728 lines
24 KiB
Fortran
728 lines
24 KiB
Fortran
C--------------------------------------------------------------------
|
|
C Index Reflections found by OC
|
|
C
|
|
C The algorithm used is that described by R.A.Jacobsen in the
|
|
C program BLIND (Bravais Lattice and INdex Determination), which is
|
|
C described in Ames Lab Report IS-3469, September 1974.
|
|
C
|
|
C Adapted by P.S.White and E.J.Gabe April, 92.
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE BLIND
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE)
|
|
WRITE (COUT,10000)
|
|
CALL FREEFM (ITR)
|
|
ISELEC = IFREE(1)
|
|
IF (ISELEC .EQ. 0) THEN
|
|
ISELEC = 1
|
|
ELSE IF (ISELEC .EQ. 2) THEN
|
|
CALL EDLIST
|
|
WRITE (COUT,11000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') ISELEC = 1
|
|
ENDIF
|
|
IF (ISELEC .EQ. 1) THEN
|
|
IVALID = 0
|
|
DD = 0.080
|
|
DJ = 0.0
|
|
MJ = 0
|
|
C--------------------------------------------------------------------
|
|
C Input the data and prepare the working X, Y, Zs.
|
|
C--------------------------------------------------------------------
|
|
CALL PRPXYZ (XX,YY,ZZ,LMT)
|
|
C--------------------------------------------------------------------
|
|
C Do the indexing and reduction to a minimum cell
|
|
C--------------------------------------------------------------------
|
|
IF (IVALID .EQ. 0) THEN
|
|
CALL INDRED (LMT,XX,YY,ZZ,DD,DJ,MJ)
|
|
IF (IVALID .EQ. 0) CALL LISTER
|
|
ENDIF
|
|
ENDIF
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (' Index Reflections and derive an Orientation Matrix'/
|
|
$ ' 1) Index reflections in the list from PK '/
|
|
$ ' 2) List and edit the reflections'/
|
|
$ ' 3) Cancel'//
|
|
$ ' Enter option (1) ',$)
|
|
11000 FORMAT (' Do you want to index the reflections (Y) ? ',$)
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Do the actual indexing
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE INDRED (LMT,XX,YY,ZZ,DD,DJ,MJ)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION B(3,3)
|
|
DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE),
|
|
$ XH(3,NSIZE),A(3,3),JH(3,NSIZE)
|
|
EQUIVALENCE (BLINDR,B)
|
|
IZ = IABS(MJ)
|
|
100 DO 110 J = 1,3
|
|
B(1,J) = XX(J)
|
|
B(2,J) = YY(J)
|
|
B(3,J) = ZZ(J)
|
|
110 CONTINUE
|
|
CALL INVERT (B,A,D)
|
|
DO 120 J = 1,3
|
|
DO 120 I = 1,LMT
|
|
XH(J,I) = A(J,1)*XX(I) + A(J,2)*YY(I) + A(J,3)*ZZ(I)
|
|
120 CONTINUE
|
|
MM = 0
|
|
CALL TRYIND (XH,LMT,DD,IZ)
|
|
IF (DD .EQ. 0.100) THEN
|
|
DD = -0.010
|
|
GO TO 100
|
|
ENDIF
|
|
CALL COMPB (XX,YY,ZZ,B,XH,LMT)
|
|
CALL REDCL1 (B,A)
|
|
DO 140 I = 4,LMT
|
|
DO 130 J = 1,3
|
|
XH(J,I) = A(J,1)*XX(I) + A(J,2)*YY(I) + A(J,3)*ZZ(I)
|
|
IF (XH(J,I) .LT. 0.0) LB = XH(J,I) - 0.5
|
|
IF (XH(J,I) .GE. 0.0) LB = XH(J,I) + 0.5
|
|
IF (ABS(XH(J,I) - LB) .GT. DD) MM = 1
|
|
JH(J,I) = LB
|
|
130 CONTINUE
|
|
140 CONTINUE
|
|
IF (MM .EQ. 1) GO TO 100
|
|
IF (MJ .LT. 0) THEN
|
|
CALL INVERT (B,A,D)
|
|
IF ((DJ + 0.1) .GT. (1.0/ABS(D)) .AND.
|
|
$ (DJ - 0.1) .LT. (1.0/ABS(D))) GO TO 100
|
|
ENDIF
|
|
CALL CALCEL (B,A,D)
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 150 I = 4,LMT,4
|
|
WRITE (COUT,11000) (JH(1,J),JH(2,J),JH(3,J),J = I,I+3)
|
|
CALL GWRITE (ITP,' ')
|
|
150 CONTINUE
|
|
WRITE (COUT,12000)
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (COUT,13000) ((B(I,J),J = 1,3),I = 1,3)
|
|
CALL GWRITE (ITP,' ')
|
|
RETURN
|
|
10000 FORMAT (/4(' h k l '))
|
|
11000 FORMAT (4(3I4,4X))
|
|
12000 FORMAT (/' Orientation Matrix:')
|
|
13000 FORMAT (3F10.6/3F10.6/3F10.6/)
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Reduce the cell via REDCL2
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE REDCL1 (B,A)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION B(3,3),A(3,3),W(4),AB(3,3),V(6),L(7)
|
|
W(1) = 1.0E9
|
|
W(2) = W(1)
|
|
W(3) = W(1)
|
|
W(4) = W(1)
|
|
CALL INVERT (B,AB,D)
|
|
CALL REDCL2 (AB,V,L)
|
|
DO 120 I = 1,3
|
|
DO 110 J = 1,3
|
|
IF (V(I) .LT. W(J)) THEN
|
|
DO 100 K = 3,J,-1
|
|
W(K+1) = W(K)
|
|
L(K+1) = L(K)
|
|
100 CONTINUE
|
|
W(J) = V(I)
|
|
L(J) = I
|
|
GO TO 120
|
|
ENDIF
|
|
110 CONTINUE
|
|
120 CONTINUE
|
|
DO 130 I = 1,3
|
|
A(3,I) = AB(L(1),I)
|
|
A(1,I) = AB(L(2),I)
|
|
A(2,I) = AB(L(3),I)
|
|
130 CONTINUE
|
|
W(4) = V(5)
|
|
V(5) = V(6)
|
|
V(6) = W(4)
|
|
IF (V(L(1) + L(2) + 1) .GT. 0.0) THEN
|
|
DO 140 I = 1,3
|
|
A(1,I) = -A(1,I)
|
|
V(L(1) + L(2) + 1) = -V(L(1) + L(2) + 1)
|
|
V(L(2) + L(3) + 1) = -V(L(2) + L(3) + 1)
|
|
140 CONTINUE
|
|
ENDIF
|
|
IF (V(L(3) + L(1) + 1) .GT. 0.0) THEN
|
|
DO 150 I = 1,3
|
|
A(2,I) = -A(2,I)
|
|
V(L(3) + L(1) + 1) = -V(L(3) + L(1) + 1)
|
|
V(L(2) + L(3) + 1) = -V(L(2) + L(3) + 1)
|
|
150 CONTINUE
|
|
ENDIF
|
|
CALL INVERT (A,B,D)
|
|
IF (D .GE. 0.0) RETURN
|
|
DO 170 I = 1,3
|
|
DO 160 J = 1,3
|
|
A(I,J) = -A(I,J)
|
|
B(I,J) = -B(I,J)
|
|
160 CONTINUE
|
|
170 CONTINUE
|
|
RETURN
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Form a reduced set of cell vectors
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE REDCL2 (AB,V,L)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION AB(3,3),V(6),L(7)
|
|
100 DO 110 J = 1,6
|
|
V(J) = 0.0
|
|
110 CONTINUE
|
|
DO 130 J = 1,3
|
|
M = J + 1
|
|
IF (M .GT. 3) M = M - 3
|
|
DO 120 I = 1,3
|
|
V(J) = V(J) + AB(J,I)*AB(J,I)
|
|
V(J+3) = V(J+3) + AB(J,I)*AB(M,I)
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
DO 140 J = 1,3
|
|
M = J + 1
|
|
IF (M .GT. 3) M = M - 3
|
|
IF (V(J+3) .LT. 0.0) THEN
|
|
L(J) = (V(J+3)/V(J) - 0.498)
|
|
L(J+3) = (V(J+3)/V(M) - 0.498)
|
|
ELSE
|
|
L(J) = (V(J+3)/V(J) + 0.498)
|
|
L(J+3) = (V(J+3)/V(M) + 0.498)
|
|
ENDIF
|
|
140 CONTINUE
|
|
L(7) = 0
|
|
DO 150 J = 1,6
|
|
IF (IABS(L(J)) .GT. L(7)) THEN
|
|
L(7) = IABS(L(J))
|
|
K = J
|
|
ENDIF
|
|
150 CONTINUE
|
|
IF (L(7) .EQ. 0) RETURN
|
|
IF (K .LT. 4) THEN
|
|
DO 160 J = 1,3
|
|
M = K + 1
|
|
IF (M .GT. 3) M = M - 3
|
|
AB(M,J) = AB(M,J) - AB(K,J)*L(K)
|
|
160 CONTINUE
|
|
ELSE
|
|
DO 170 J = 1,3
|
|
M = K - 2
|
|
IF (M .GT. 3) M = M - 3
|
|
AB(K-3,J) = AB(K-3,J) - AB(M,J)*L(K)
|
|
170 CONTINUE
|
|
ENDIF
|
|
GO TO 100
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Actually do the indexing at last.
|
|
C Return with IVALID = 0 means success,
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE TRYIND (FH,LMT,DD,IZ)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION LA(NSIZE),LL(3,NSIZE),FH(3,NSIZE)
|
|
INTEGER HH(3,NSIZE),S1,S2,S3,HA,HB,HC,DA
|
|
NI = 512
|
|
DO 110 J = 1,LMT
|
|
DO 100 I = 1,3
|
|
HH(I,J) = FH(I,J) * NI
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
HA = HH(1,LMT)
|
|
HB = HH(2,LMT)
|
|
HC = HH(3,LMT)
|
|
120 DD = DD + 0.020
|
|
WRITE (COUT,10000) DD
|
|
CALL GWRITE (ITP,' ')
|
|
IF (DD .GE. 0.50) THEN
|
|
WRITE (COUT,11000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 130 J = 1,LMT
|
|
WRITE (COUT,12000) (FH(I,J),I=1,3)
|
|
CALL GWRITE (ITP,' ')
|
|
130 CONTINUE
|
|
IVALID = 1
|
|
RETURN
|
|
ENDIF
|
|
IZ = IZ + 1
|
|
DA = DD*NI
|
|
KKA = 0
|
|
DO 280 MM = 1,10
|
|
DO 270 KKK = 1,MM+1
|
|
K = KKK - 1
|
|
S1 = K * HA
|
|
DO 260 LLL = 1,MM+1
|
|
L = LLL - 1
|
|
S2 = L * HB
|
|
DO 250 MMM = 1,MM+1
|
|
M = MMM - 1
|
|
IF (K .EQ. MM .OR. L .EQ. MM .OR. M .EQ. MM) THEN
|
|
S3 = M * HC
|
|
140 IF (ITOLDD(S1+S2+S3,LB,DA) .EQ. 0) THEN
|
|
LA(1) = K
|
|
LA(2) = L
|
|
LA(3) = M
|
|
N = 2
|
|
LA(LMT) = LB
|
|
GO TO 180
|
|
ENDIF
|
|
150 IF (L .NE. 0 .AND. ITOLDD(S1-S2+S3,LB,DA) .EQ. 0) THEN
|
|
LA(1) = K
|
|
LA(2) = -L
|
|
LA(3) = M
|
|
N = 3
|
|
LA(LMT) = LB
|
|
GO TO 180
|
|
ENDIF
|
|
160 IF (K .EQ. 0) GO TO 250
|
|
IF (M .NE. 0 .AND. ITOLDD(S1+S2-S3,LB,DA) .EQ. 0) THEN
|
|
LA(1) = K
|
|
LA(2) = L
|
|
LA(3) = -M
|
|
N = 4
|
|
LA(LMT) = LB
|
|
GO TO 180
|
|
ENDIF
|
|
170 N = 5
|
|
IF (L .EQ. 0 .OR. M .EQ. 0 .OR.
|
|
$ ITOLDD(S1-S2-S3,LB,DA) .NE. 0) GO TO 240
|
|
LA(1) = K
|
|
LA(2) = -L
|
|
LA(3) = -M
|
|
N = 5
|
|
LA(LMT) = LB
|
|
180 DO 190 J = LMT-1,4,-1
|
|
IF (ITOLDD(LA(1)*HH(1,J) +
|
|
$ LA(2)*HH(2,J) +
|
|
$ LA(3)*HH(3,J),LB,DA) .NE. 0) GO TO 240
|
|
LA(J) = LB
|
|
190 CONTINUE
|
|
KKA = KKA + 1
|
|
DO 200 J = 1,LMT
|
|
LL(KKA,J) = LA(J)
|
|
200 CONTINUE
|
|
IF (KKA .EQ. 1) GO TO 240
|
|
M1 = LL(1,1)*LL(2,2) - LL(1,2)*LL(2,1)
|
|
M2 = LL(1,1)*LL(2,3) - LL(1,3)*LL(2,1)
|
|
M3 = LL(1,2)*LL(2,3) - LL(1,3)*LL(2,2)
|
|
IF (KKA .NE. 2) THEN
|
|
ID = M1*LL(3,3) - M2*LL(3,2) + M3*LL(3,1)
|
|
IF (ID .NE. 0) THEN
|
|
DO 230 J = 1,LMT
|
|
DO 220 I = 1,3
|
|
FH(I,J) = LL(I,J)
|
|
220 CONTINUE
|
|
230 CONTINUE
|
|
RETURN
|
|
ENDIF
|
|
KKA = 2
|
|
ENDIF
|
|
IF (M1 .EQ. 0 .AND. M2 .EQ. 0 .AND. M3 .EQ. 0) KKA = 1
|
|
240 GO TO (140,150,160,170,250),N
|
|
ENDIF
|
|
250 CONTINUE
|
|
260 CONTINUE
|
|
270 CONTINUE
|
|
280 CONTINUE
|
|
GO TO 120
|
|
10000 FORMAT (' Error Limit = ',F4.2)
|
|
11000 FORMAT (' Non-Integer Indices:')
|
|
12000 FORMAT (5X,3F10.4)
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Find if the tentative index is within the tolerance DD
|
|
C--------------------------------------------------------------------
|
|
FUNCTION ITOLDD (IS,LB,IDD)
|
|
LB = (IS + 256)/512
|
|
IF (IS .LT. 0) LB = (IS - 256)/512
|
|
ITOLDD = 1
|
|
IF (IABS(IS - 512*LB) .LT. IDD) ITOLDD = 0
|
|
RETURN
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Compute a B matrix from the X and H matrices.
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE COMPB (XX,YY,ZZ,B,HH,LMT)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE),
|
|
$ HH(3,NSIZE),A(3,3),B(3,3),AI(3,3)
|
|
DO 120 I = 1,3
|
|
DO 110 J = 1,3
|
|
A(I,J) = 0.0
|
|
B(I,J) = 0.0
|
|
DO 100 K = 1,LMT
|
|
B(I,J) = B(I,J) + HH(I,K)*HH(J,K)
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
120 CONTINUE
|
|
DO 140 I = 1,3
|
|
DO 130 K = 1,LMT
|
|
A(1,I) = A(1,I) + XX(K)*HH(I,K)
|
|
A(2,I) = A(2,I) + YY(K)*HH(I,K)
|
|
A(3,I) = A(3,I) + ZZ(K)*HH(I,K)
|
|
130 CONTINUE
|
|
140 CONTINUE
|
|
CALL INVERT (B,AI,D)
|
|
DO 170 I = 1,3
|
|
DO 160 J = 1,3
|
|
B(I,J) = 0.0
|
|
DO 150 K = 1,3
|
|
B(I,J) = B(I,J) + A(I,K)*AI(K,J)
|
|
150 CONTINUE
|
|
160 CONTINUE
|
|
170 CONTINUE
|
|
RETURN
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Calculate and output the cell etc.
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE CALCEL (B,AI,D)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION B(3,3),AI(3,3)
|
|
CALL INVERT (B,AI,D)
|
|
VOL = 1.0/D
|
|
A2 = AI(1,1)*AI(1,1) + AI(1,2)*AI(1,2) + AI(1,3)*AI(1,3)
|
|
B2 = AI(2,1)*AI(2,1) + AI(2,2)*AI(2,2) + AI(2,3)*AI(2,3)
|
|
C2 = AI(3,1)*AI(3,1) + AI(3,2)*AI(3,2) + AI(3,3)*AI(3,3)
|
|
DAB = AI(1,1)*AI(2,1) + AI(1,2)*AI(2,2) + AI(1,3)*AI(2,3)
|
|
DAC = AI(1,1)*AI(3,1) + AI(1,2)*AI(3,2) + AI(1,3)*AI(3,3)
|
|
DBC = AI(2,1)*AI(3,1) + AI(2,2)*AI(3,2) + AI(2,3)*AI(3,3)
|
|
D1 = SQRT(A2)
|
|
D2 = SQRT(B2)
|
|
D3 = SQRT(C2)
|
|
D4 = DBC/(D2*D3)
|
|
D5 = DAC/(D1*D3)
|
|
D6 = DAB/(D1*D2)
|
|
D4 = DEG*ATAN(SQRT(1-D4*D4)/D4)
|
|
IF (D4 .LT. 0.0) D4 = D4 + 180.0
|
|
D5 = DEG*ATAN(SQRT(1-D5*D5)/D5)
|
|
IF (D5 .LT. 0.0) D5 = D5 + 180.0
|
|
D6 = DEG*ATAN(SQRT(1-D6*D6)/D6)
|
|
IF (D6 .LT. 0.0) D6 = D6 + 180.0
|
|
WRITE (COUT,10000) D1,D2,D3,D4,D5,D6,VOL
|
|
CALL GWRITE (ITP,' ')
|
|
RETURN
|
|
10000 FORMAT (/' Cell Dimensions:'/
|
|
$ ' a',F8.3,', b',F8.3,', c',F8.3/
|
|
$ ' alpha',F7.2,', beta',F7.2,', gamma',F7.2,
|
|
$ '. Volume = ',F8.2)
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Get the input angles and form the XX, YY and ZZ arrays.
|
|
C LMT is the number of input reflections.
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE PRPXYZ (XX,YY,ZZ,LMT)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE),THETAS(NSIZE),
|
|
$ OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE),ICNTS(NSIZE)
|
|
EQUIVALENCE (ACOUNT( 1),THETAS(1)),
|
|
$ (ACOUNT( NSIZE+1),OMEGAS(1)),
|
|
$ (ACOUNT(2*NSIZE+1),CHIS(1)),
|
|
$ (ACOUNT(3*NSIZE+1),PHIS(1)),
|
|
$ (ACOUNT(4*NSIZE+1),ICNTS(1))
|
|
CALL ANGRW (0,5,NTOT,140,0)
|
|
LMT = 0
|
|
DO 100 I = 1,NTOT
|
|
IF (ICNTS(I) .GT. 0) THEN
|
|
LMT = LMT + 1
|
|
THETA = THETAS(I)/(2.0*DEG)
|
|
OMEGA = OMEGAS(I)/DEG
|
|
CHI = CHIS(I)/DEG
|
|
PHI = PHIS(I)/DEG
|
|
HM = 2.0 * SIN(THETA)/WAVE
|
|
XX(LMT) = HM*(COS(CHI)*COS(PHI)*COS(OMEGA) -
|
|
$ SIN(PHI)*SIN(OMEGA))
|
|
YY(LMT) = HM*(COS(CHI)*SIN(PHI)*COS(OMEGA) +
|
|
$ COS(PHI)*SIN(OMEGA))
|
|
ZZ(LMT) = HM*SIN(CHI)*COS(OMEGA)
|
|
ENDIF
|
|
100 CONTINUE
|
|
CALL SRCH3 (LMT,XX,YY,ZZ)
|
|
RETURN
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Sort the input list and search for the 3 shortest non-coplanar
|
|
C vectors.
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE SRCH3 (LMT,XX,YY,ZZ)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE),
|
|
$ XA(NSIZE),YA(NSIZE),ZA(NSIZE),A(3,3),B(3,3),
|
|
$ W(NSIZE+1),VV(6),L(NSIZE+1),LL(7)
|
|
VSTART = 0.5
|
|
VEND = 0.05
|
|
DO 100 I = 1,NSIZE+1
|
|
W(I) = 1.0E9
|
|
L(I) = 0
|
|
100 CONTINUE
|
|
DO 130 I = 1,LMT
|
|
HM = XX(I)*XX(I) + YY(I)*YY(I) + ZZ(I)*ZZ(I)
|
|
DO 120 J = 1,LMT
|
|
IF (HM .LT. W(J)) THEN
|
|
DO 110 K = LMT,J,-1
|
|
W(K+1) = W(K)
|
|
L(K+1) = L(K)
|
|
110 CONTINUE
|
|
W(J) = HM
|
|
L(J) = I
|
|
GO TO 130
|
|
ENDIF
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
VMIN = VSTART
|
|
135 DO 140 J = 1,LMT
|
|
XA(J) = XX(L(J))
|
|
YA(J) = YY(L(J))
|
|
ZA(J) = ZZ(L(J))
|
|
140 CONTINUE
|
|
C--------------------------------------------------------------------
|
|
C Search for a reasonable first cell.
|
|
C The actual volume of the cells selected is D, the determinant of
|
|
C the 3 vectors L formed by XA, YA, ZA. The maximum volume such a
|
|
C cell can have is V = L1*L2*L3. If D/V > VMIN (0.5) the cell of
|
|
C L1, L2 and L3 is a reasonable starting point. If not, swap out
|
|
C either L2 or L3, depending on which makes the smaller angle with
|
|
C L1, with vectors (reflections) sequentially lower in the list.
|
|
C--------------------------------------------------------------------
|
|
EL1 = SQRT(XA(1)*XA(1) + YA(1)*YA(1) + ZA(1)*ZA(1))
|
|
K = 3
|
|
150 K = K + 1
|
|
IF (K .GT. LMT) THEN
|
|
VMIN = 0.5*VMIN
|
|
IF (VMIN .LT. VEND) THEN
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
IVALID = 1
|
|
RETURN
|
|
ELSE
|
|
GO TO 135
|
|
ENDIF
|
|
ENDIF
|
|
DO 160 I = 1,3
|
|
B(I,1) = XA(I)
|
|
B(I,2) = YA(I)
|
|
B(I,3) = ZA(I)
|
|
160 CONTINUE
|
|
CALL INVERT (B,A,D)
|
|
EL2 = SQRT(XA(2)*XA(2) + YA(2)*YA(2) + ZA(2)*ZA(2))
|
|
EL3 = SQRT(XA(3)*XA(3) + YA(3)*YA(3) + ZA(3)*ZA(3))
|
|
VMAX = EL1*El2*EL3
|
|
IF (ABS(D)/VMAX .LT. VMIN) THEN
|
|
COS12 = (XA(1)*XA(2) + YA(1)*YA(2) + ZA(1)*ZA(2))/(EL1*EL2)
|
|
COS13 = (XA(1)*XA(3) + YA(1)*YA(3) + ZA(1)*ZA(3))/(EL1*EL3)
|
|
IF (ABS(COS12) .GT. ABS(COS13)) THEN
|
|
HM = XA(K)
|
|
XA(K) = XA(2)
|
|
XA(2) = XA(3)
|
|
XA(3) = HM
|
|
HM = YA(K)
|
|
YA(K) = YA(2)
|
|
YA(2) = YA(3)
|
|
YA(3) = HM
|
|
HM = ZA(K)
|
|
ZA(K) = ZA(2)
|
|
ZA(2) = ZA(3)
|
|
ZA(3) = HM
|
|
M = L(K)
|
|
L(K) = L(2)
|
|
L(2) = M
|
|
ELSE
|
|
HM = XA(K)
|
|
XA(K) = XA(3)
|
|
XA(3) = HM
|
|
HM = YA(K)
|
|
YA(K) = YA(3)
|
|
YA(3) = HM
|
|
HM = ZA(K)
|
|
ZA(K) = ZA(3)
|
|
ZA(3) = HM
|
|
M = L(K)
|
|
L(K) = L(3)
|
|
L(3) = M
|
|
ENDIF
|
|
GO TO 150
|
|
ENDIF
|
|
CALL REDCL2 (B,VV,LL)
|
|
DO 170 I = LMT,1,-1
|
|
XX(I+3) = XX(I)
|
|
YY(I+3) = YY(I)
|
|
ZZ(I+3) = ZZ(I)
|
|
170 CONTINUE
|
|
DO 180 I = 1,3
|
|
XX(I) = B(I,1)
|
|
YY(I) = B(I,2)
|
|
ZZ(I) = B(I,3)
|
|
180 CONTINUE
|
|
LMT = LMT + 3
|
|
RETURN
|
|
10000 FORMAT (' The reflections are essentially coplanar and',
|
|
$ ' indexing would be unreliable.'/
|
|
$ ' Collect more peaks and try again.')
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C Invert matrix A to AI. Determinant is D.
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE INVERT (A,AI,D)
|
|
DIMENSION A(3,3),AI(3,3)
|
|
D = A(1,1)*(A(2,2)*A(3,3) - A(2,3)*A(3,2)) -
|
|
$ A(1,2)*(A(2,1)*A(3,3) - A(2,3)*A(3,1)) +
|
|
$ A(1,3)*(A(2,1)*A(3,2) - A(2,2)*A(3,1))
|
|
IF (D .NE. 0.0) CALL MATRIX (A,AI,AI,AI,'INVERT')
|
|
RETURN
|
|
END
|
|
C--------------------------------------------------------------------
|
|
C EDLIST Edit the reflection list
|
|
C--------------------------------------------------------------------
|
|
SUBROUTINE EDLIST
|
|
INCLUDE 'COMDIF'
|
|
CHARACTER FLAG*1,REFNAM*40,LINE*80
|
|
DIMENSION THETAS(NSIZE),
|
|
$ OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE),ICNTS(NSIZE)
|
|
EQUIVALENCE (ACOUNT( 1),THETAS(1)),
|
|
$ (ACOUNT( NSIZE+1),OMEGAS(1)),
|
|
$ (ACOUNT(2*NSIZE+1),CHIS(1)),
|
|
$ (ACOUNT(3*NSIZE+1),PHIS(1)),
|
|
$ (ACOUNT(4*NSIZE+1),ICNTS(1))
|
|
C--------------------------------------------------------------------
|
|
C Read in the reflection list
|
|
C--------------------------------------------------------------------
|
|
CALL ANGRW (0,5,NTOT,140,0)
|
|
C--------------------------------------------------------------------
|
|
C Do the editing here
|
|
C--------------------------------------------------------------------
|
|
WRITE (COUT,10000) NTOT
|
|
CALL GWRITE (ITP,' ')
|
|
90 WRITE (COUT,11000)
|
|
CALL GWRITE (ITP,' ')
|
|
100 WRITE (COUT,12000)
|
|
CALL ALFNUM (LINE)
|
|
ANS = LINE(1:1)
|
|
IF (ANS .NE. 'L' .AND. ANS .NE. 'D' .AND. ANS .NE. 'R' .AND.
|
|
$ ANS .NE. 'A' .AND. ANS .NE. 'F' .AND. ANS .NE. 'E')
|
|
$ GO TO 90
|
|
C--------------------------------------------------------------------
|
|
C List the reflections in use
|
|
C--------------------------------------------------------------------
|
|
IF (ANS .EQ. 'L') THEN
|
|
IF (NTOT .GT. 0) THEN
|
|
WRITE (COUT,13000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 110, I = 1,NTOT
|
|
FLAG = ' '
|
|
IF (ICNTS(I) .LE. 0) FLAG = '*'
|
|
WRITE (COUT,14000) I,THETAS(I),OMEGAS(I),CHIS(I),
|
|
$ PHIS(I),ICNTS(I),FLAG
|
|
CALL GWRITE (ITP,' ')
|
|
110 CONTINUE
|
|
ELSE
|
|
WRITE (COUT,15000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
C--------------------------------------------------------------------
|
|
C Delete a reflection, i.e. make the count negative
|
|
C--------------------------------------------------------------------
|
|
ELSE IF (ANS .EQ. 'D') THEN
|
|
WRITE (COUT,16000)
|
|
CALL FREEFM (ITR)
|
|
INDX = IFREE(1)
|
|
IF (INDX .GE. 1 .AND. INDX .LE. NTOT) THEN
|
|
IF (ICNTS(INDX) .GT. 0) ICNTS(INDX) = -ICNTS(INDX)
|
|
WRITE (COUT,17000) INDX
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
C--------------------------------------------------------------------
|
|
C Reinsert a deleted reflection
|
|
C--------------------------------------------------------------------
|
|
ELSE IF (ANS .EQ. 'R') THEN
|
|
WRITE (COUT,16000)
|
|
CALL FREEFM (ITR)
|
|
INDX = IFREE(1)
|
|
IF (INDX .GE. 1 .AND. INDX .LE. NTOT) THEN
|
|
IF (ICNTS(INDX) .LT. 0) ICNTS(INDX) = -ICNTS(INDX)
|
|
WRITE (COUT,18000) INDX
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
C--------------------------------------------------------------------
|
|
C Add a reflection
|
|
C--------------------------------------------------------------------
|
|
ELSE IF (ANS .EQ. 'A') THEN
|
|
WRITE (COUT,19000)
|
|
CALL YESNO ('N',ANS)
|
|
120 WRITE (COUT,20000)
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .NE. 0) THEN
|
|
NTOT = NTOT + 1
|
|
THETAS(NTOT) = RFREE(1)
|
|
IF (ANS .EQ. 'N') THEN
|
|
OMEGAS(NTOT) = RFREE(2)
|
|
ELSE
|
|
OMEGAS(NTOT) = RFREE(2) - 0.5*RFREE(1)
|
|
ENDIF
|
|
CHIS(NTOT) = RFREE(3)
|
|
PHIS(NTOT) = RFREE(4)
|
|
ICNTS(NTOT) = 1000
|
|
GO TO 120
|
|
ENDIF
|
|
C--------------------------------------------------------------------
|
|
C Read reflections from the file REFL.DAT
|
|
C--------------------------------------------------------------------
|
|
ELSE IF (ANS .EQ. 'F') THEN
|
|
WRITE (COUT,18900)
|
|
REFNAM = 'DONT DO IT'//' '
|
|
CALL ALFNUM (REFNAM)
|
|
IF (REFNAM .EQ. ' ') REFNAM = 'REFL.DAT'//' '
|
|
WRITE (COUT,19000)
|
|
CALL YESNO ('N',ANS)
|
|
IREFL = IOUNIT(10)
|
|
CALL IBMFIL (REFNAM,IREFL,80,'SU',IERR)
|
|
NTOT = 0
|
|
DO 130 I = 1,NSIZE
|
|
READ (IREFL,21000,END = 140) OCHAR
|
|
CALL FREEFM (1000)
|
|
NTOT = NTOT + 1
|
|
THETAS(NTOT) = RFREE(1)
|
|
IF (ANS .EQ. 'N') THEN
|
|
OMEGAS(NTOT) = RFREE(2)
|
|
ELSE
|
|
OMEGAS(NTOT) = RFREE(2) - 0.5*RFREE(1)
|
|
ENDIF
|
|
CHIS(NTOT) = RFREE(3)
|
|
PHIS(NTOT) = RFREE(4)
|
|
ICNTS(NTOT) = 1000
|
|
130 CONTINUE
|
|
140 CALL IBMFIL (REFNAM,-IREFL,80,'SU',IERR)
|
|
DO 150 J = 40,1,-1
|
|
IF (REFNAM(J:J) .NE. ' ') GO TO 160
|
|
150 CONTINUE
|
|
160 WRITE (COUT,22000) NTOT,REFNAM(1:J)
|
|
CALL GWRITE (ITP,' ')
|
|
C--------------------------------------------------------------------
|
|
C Write the reflections to file and exit
|
|
C--------------------------------------------------------------------
|
|
ELSE IF (ANS .EQ. 'E') THEN
|
|
CALL ANGRW (1,5,NTOT,140,0)
|
|
RETURN
|
|
ENDIF
|
|
GO TO 100
|
|
10000 FORMAT (' There are ',I4,' peaks in the list')
|
|
11000 FORMAT (' (L) List the reflections;'/
|
|
$ ' (D) Delete a reflection;'/
|
|
$ ' (R) Reinsert a reflection;'/
|
|
$ ' (A) Add a reflection;'/
|
|
$ ' (F) Read reflections from a file;'/
|
|
$ ' (E) Exit.')
|
|
12000 FORMAT ( ' Command (L,D,R,A,F,E) ',$)
|
|
13000 FORMAT (' N Theta Omega Chi Phi Int'/)
|
|
14000 FORMAT (' ',I2,1X,4(F8.2),2X,I8,5X,A)
|
|
15000 FORMAT (' There are no reflections in the list')
|
|
16000 FORMAT (' Input reflection number: ')
|
|
17000 FORMAT (' Reflection ',I2,' marked unused')
|
|
18000 FORMAT (' Reflection ',I2,' marked used')
|
|
18900 FORMAT (' Type the reflection file name (REFL.DAT) ',$)
|
|
19000 FORMAT (' Subtract theta from the omega value (N) ? ',$)
|
|
20000 FORMAT (' Type 2theta, omega, chi, phi ',$)
|
|
21000 FORMAT (A)
|
|
22000 FORMAT (I4,' reflections have been read from ',A)
|
|
END
|