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