Initial revision
This commit is contained in:
cvs
730
difrac/blind.f
Normal file
730
difrac/blind.f
Normal file
@@ -0,0 +1,730 @@
|
||||
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
|
||||
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 (ANS)
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user