Initial revision

difrac/reindx.f

@@ -0,0 +1,105 @@
+C-----------------------------------------------------------------------
+C  This subroutine either :--
+C  1. for RS, finds the direct cell by reindexing 3 reflections;
+C  2. for CH, chooses reflections from the PK list to use with M2 or M3.
+C-----------------------------------------------------------------------
+      SUBROUTINE REINDX
+      INCLUDE 'COMDIF'
+      DIMENSION IOLD(3,3),INEW(3,3),INDICS(3)
+      DIMENSION THETAS(NSIZE),OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE)
+      EQUIVALENCE (ACOUNT(        1),THETAS(1)),
+     $            (ACOUNT(  NSIZE*1),OMEGAS(1)),
+     $            (ACOUNT(2*NSIZE+1),CHIS(1)),
+     $            (ACOUNT(3*NSIZE+1),PHIS(1))
+      IF (KI .EQ. 'RS') THEN
+        WRITE (COUT,10000)
+        CALL YESNO ('Y',ANS)
+        IF (ANS .EQ. 'Y') THEN
+          DO 110 I = 1,3
+  100       WRITE (COUT,11000) I
+            CALL FREEFM (ITR)
+            IOLD(I,1) = IFREE(1)
+            IOLD(I,2) = IFREE(2)
+            IOLD(I,3) = IFREE(3)
+            INEW(I,1) = IFREE(4)
+            INEW(I,2) = IFREE(5)
+            INEW(I,3) = IFREE(6)
+            NN = -1
+            ISTAN = 0
+            IH = IOLD(I,1)
+            IK = IOLD(I,2)
+            IL = IOLD(I,3)
+            IF ((IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) .OR.
+     $          (INEW(I,1) .EQ. 0 .AND. INEW(I,2) .EQ. 0 .AND. 
+     $           INEW(I,3) .EQ. 0)) THEN
+              WRITE (COUT,11100)
+              CALL GWRITE (ITP,' ')
+              GO TO 100
+            ENDIF
+            IPRVAL = 1
+            CALL ANGCAL
+            IF (IVALID .NE. 0) THEN
+              WRITE (COUT,12000)
+              CALL YESNO ('Y',ANS)
+              IF (ANS .EQ. 'N') GO TO 100
+            ENDIF
+            WRITE (COUT,13000) 
+     $            (IOLD(I,KK),KK = 1,3),THETA,OMEGA,CHI,PHI,
+     $            (INEW(I,KK),KK = 1,3)
+            CALL GWRITE (ITP,' ')
+            IHK(I)    = INEW(I,1)
+            NREFB(I)  = INEW(I,2)
+            ILA(I)    = INEW(I,3)
+            BCOUNT(I) = THETA
+            BBGR1(I)  = OMEGA
+            BBGR2(I)  = CHI
+            BTIME(I)  = PHI
+  110     CONTINUE
+          CALL ORMAT3
+        ENDIF
+C-----------------------------------------------------------------------
+C  Choose PK reflections for M2 or M3
+C-----------------------------------------------------------------------
+      ELSE IF (KI .EQ. 'CH') THEN
+        WRITE (COUT,14000)
+        CALL YESNO ('Y',ANS)
+        IF (ANS .EQ. 'Y') THEN
+          WRITE (COUT,15000)
+          CALL GWRITE (ITP,' ')
+C-----------------------------------------------------------------------
+C  Bring in the peaks from PK
+C-----------------------------------------------------------------------
+          READ (ISD, REC=140) NGOOD
+          CALL ANGRW (0,4,NGOOD,140,0)
+          DO 120 I = 1,3
+            WRITE (COUT,16000) I
+            CALL FREEFM (ITR)
+            IOC = IFREE(1)
+            INDICS(1) = IFREE(2)
+            INDICS(2) = IFREE(3)
+            INDICS(3) = IFREE(4)
+            IF (IOC .EQ. 0) THEN
+              KI = ' '
+              RETURN
+            ENDIF
+            IHK(I)   = INDICS(1)
+            NREFB(I) = INDICS(2)
+            ILA(I)   = INDICS(3)
+            BCOUNT(I) = THETAS(IOC)
+            BBGR1(I) = OMEGAS(IOC)
+            BBGR2(I) = CHIS(IOC)
+            BTIME(I) = PHIS(IOC)
+  120     CONTINUE
+        ENDIF
+      ENDIF
+      KI = ' '
+      RETURN
+10000 FORMAT (' Reindex 3 Reflections (Y) ? ',$)
+11000 FORMAT (' Reflection',I3,'. Type OLD indices then NEW indices ',$)
+11100 FORMAT (' 0,0,0 indices not allowed.  Try again.')
+12000 FORMAT (' The OLD indices are Invalid. Use them anyway (Y) ? ',$)
+13000 FORMAT (2X,3I3,4F8.2,' New indices  ',3I3)
+14000 FORMAT (' Choose reflections from OC for M2 or M3 (Y) ? ',$)
+15000 FORMAT (' Sequence number in OC and indices')
+16000 FORMAT (' Reflection ',I1,' ',$)
+      END