C-----------------------------------------------------------------------
C       Linear Least Squares Derivation of Orientation Matrix
C
C  The routine is called from the terminal with the MM command, or
C  internally from re-orientation during data-collection with OZ.
C
C  The data is obtained from ORIENT.DA beginning at record 250.
C  There are 10 reflections per record 
C     h    k    l  2theta omega  chi   phi       in the arrays 
C    IHK,NREFB,ILA,BCOUNT,BBGR1,BBGR2,BTIME,BPSI 
C  The 81st variable NBL is the number of reflections in the record.
C  If NBL = 10 the block is full, if not it is the last record.
C
C-----------------------------------------------------------------------
      SUBROUTINE LSORMT
      INCLUDE 'COMDIF'
      DIMENSION RHX(3,3),RHH(3,3),IHI(3),XOBS(3),XCNEW(3),XCOLD(3),
     $          RHHI(3,3),DEL(3),RNEW(3,3),
     $          IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10),
     $          BPHI(10)
      CHARACTER ANS0*1
      MARK = 0
      AVEANG = 0.0
      DO 100 I = 1,3
        DO 100 J = 1,3
          ROLD(I,J) = R(I,J)/WAVE
  100 CONTINUE
      ANS0 = 'N'
      DO 110 I = 1,3
        DO 110 J = 1,3
          RHX(I,J) = 0.0
          RHH(I,J) = 0.0
  110 CONTINUE
      IF (IORNT .EQ. 1) THEN
        IHSV = IH
        IKSV = IK
        ILSV = IL
        NBSV = NB
        GO TO 200
      ENDIF
      IF (KI .EQ. 'OP') GO TO 200
      WRITE (COUT,10000)
      CALL GWRITE (ITP,' ')
      WRITE (COUT,13000) WAVE
      CALL FREEFM (ITR)
      IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1)
C-----------------------------------------------------------------------
C  Read from the terminal or from the Idata file
C-----------------------------------------------------------------------
      WRITE (COUT,15000)
      CALL YESNO ('N',ANS)
      IF (ANS .EQ. 'Y') THEN
        CALL TERMRD
      ENDIF
C-----------------------------------------------------------------------
C  Print the current MM data if wanted
C-----------------------------------------------------------------------
  115 WRITE (COUT,16000)
      CALL FREEFM (ITR)
      IOPSHN = IFREE(1)
      IF (IOPSHN .EQ. 0)  IOPSHN = 3
      IF (IOPSHN .EQ. 4) THEN
        KI = ' '
        RETURN
      ENDIF
      IF (IOPSHN .EQ. 1) LLIST = LPT
      IF (IOPSHN .EQ. 2) THEN
        LLIST = IOUNIT(10)
        CALL IBMFIL ('MMDATA.DA',LLIST,80,'SU',IERR)
        WRITE (LLIST,16100) WAVE
      ENDIF
      IF (IOPSHN .EQ. 1 .OR. IOPSHN .EQ. 2) THEN
        NBLOKO = 250
  120   READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,
     $                        BPSI,NBL
        NBLOKO = NBLOKO + 1
        IF (NBL .NE. 0) THEN
          DO 130 I = 1,NBL
            IDR = BPSI(I) + 0.1
            WRITE (LLIST,17000) IBH(I),IBK(I),IBL(I),BTHETA(I),
     $                          BOMEGA(I),BCHI(I),BPHI(I),IDR
  130     CONTINUE
          GO TO 120
        ENDIF
        IF (IOPSHN .EQ. 2) CALL IBMFIL ('MMDATA.DA',-LLIST,80,'SU',IERR)
        GO TO 115
      ENDIF
C-----------------------------------------------------------------------
C  Routine to Delete(1) or Restore(0) reflections from LS
C-----------------------------------------------------------------------
      WRITE (COUT,19000)
      CALL GWRITE (ITP,' ')
  140 WRITE (COUT,29000)
      CALL FREEFM (ITR)
      JHD = IFREE(1)
      KD  = IFREE(2)
      LD  = IFREE(3)
      IDR = IFREE(4)
C-----------------------------------------------------------------------
C  Find the reflection to be changed
C-----------------------------------------------------------------------
      IF (JHD .NE. 0 .OR. KD .NE. 0 .OR. LD .NE. 0) THEN
        NBLOKO = 250
  150   READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,
     $                        BPHI,BPSI,NBL
        NBLOKO = NBLOKO + 1
        IF (NBL .EQ. 0) GO TO 140
C-----------------------------------------------------------------------
C  Find the reflection, change its status, write back and get the next
C-----------------------------------------------------------------------
        DO 160 NB = 1,NBL
          IF (IBH(NB) .EQ. JHD .AND. IBK(NB) .EQ. KD .AND.
     $        IBL(NB) .EQ. LD) THEN
            BPSI(NB) = IDR
            NBLOKO = NBLOKO-1
            WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,
     $                             BPHI,BPSI,NBL
            NBLOKO = NBLOKO + 1
            GO TO 140
          ENDIF
  160   CONTINUE
        GO TO 150
      ENDIF
C-----------------------------------------------------------------------
C  Insert new reflections
C-----------------------------------------------------------------------
      WRITE (COUT,23000)
      CALL YESNO ('N',ANS)
      IF (ANS .EQ. 'Y') THEN
        NBLOKO = 250
  170   READ (ISD,REC=NBLOKO) (JUNK,I = 1,80),NBL
        NBLOKO = NBLOKO + 1
        IF (NBL .NE. 0) GO TO 170
        NBLOKO = NBLOKO - 1
        WRITE (COUT,24000) NBLOKO
        CALL GWRITE (ITP,' ')
        CALL TERMRD
      ENDIF
C-----------------------------------------------------------------------
C  Get the zero values of omega and chi and possibly use them
C-----------------------------------------------------------------------
      CALL WCZERO (ZOMEGA,ZCHI)
      WRITE (COUT,24100)
      CALL YESNO ('Y',ANS0)
      IF (ANS0 .EQ. 'Y') THEN
        DOMEGA = DOMEGA + ZOMEGA
        DCHI   = DCHI   + ZCHI
        WRITE (COUT,24200) DOMEGA,DCHI
        CALL GWRITE (ITP,' ')
      ENDIF
C-----------------------------------------------------------------------
C  Start of the Least Squares Procedure
C  Data is read from the file twice
C    MARK =  0  when making and solving the normal equations
C    MARK = -1 when forming the deltas for the e.s.d.'s
C-----------------------------------------------------------------------
  200 NRF = 0
      NBLOKO = 250
      IF (MARK .EQ. -1) WRITE (LPT,25000)
  210 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,
     $                      BPHI,BPSI,NBL
      NBLOKO = NBLOKO + 1
      IF (NBL .NE. 0) THEN
        DO 250 NB = 1,NBL
          IF (BPSI(NB) .EQ. 0.0) THEN
            NRF = NRF + 1
            IHI(1) = IBH(NB)
            IHI(2) = IBK(NB)
            IHI(3) = IBL(NB)
            TH = 2.0*SIN(0.5*BTHETA(NB)/DEG)/WAVE
            IF (ANS0 .EQ. 'Y') THEN
              BOMEGA(NB) = BOMEGA(NB) - ZOMEGA
              BCHI(NB)   = BCHI(NB)   - ZCHI
            ENDIF
            CCH = COS(BCHI(NB)/DEG)
            SCH = SIN(BCHI(NB)/DEG)
            COM = COS(BOMEGA(NB)/DEG)
            SOM = SIN(BOMEGA(NB)/DEG)
            CPH = COS((BPHI(NB))/DEG)
            SPH = SIN((BPHI(NB))/DEG)
            XOBS(1) = TH*(CCH*CPH*COM - SOM*SPH)
            XOBS(2) = TH*(CCH*SPH*COM + SOM*CPH)
            XOBS(3) = TH*SCH*COM
C-----------------------------------------------------------------------
C  MARK =  0  Form the RHH and RHX elements
C  MARK = -1  For IORNT = 1, i.e. re-orientation, 
C             form the calcd values of X with the old and new matrices; 
C             then form the differences and hence the angular deviation.
C             For IORNT = 0, i.e. normal MM,
C             form the calcd value of X at the observed phi,
C             and then the differences between the obs and calcd X and
C             then the angular deviation.
C-----------------------------------------------------------------------
            IF (MARK .EQ. 0) THEN
              DO 220 I = 1,3
                DO 220 J = 1,3
                  RHH(I,J) = RHH(I,J) + IHI(I)*IHI(J)
                  RHX(I,J) = RHX(I,J) + IHI(I)*XOBS(J)
  220         CONTINUE
            ELSE
              IH = IHI(1)
              IK = IHI(2)
              IL = IHI(3)
              DO 230 I = 1,3
                XCOLD(I) = 0.0
                XCNEW(I) = 0.0
                DO 230 J = 1,3
                  XCNEW(I) = XCNEW(I) + RNEW(I,J)*IHI(J)
                  XCOLD(I) = XCOLD(I) + ROLD(I,J)*IHI(J)
  230         CONTINUE
              PHI = BPHI(NB)
              CALL ANGPHI (XCNEW)
C-----------------------------------------------------------------------
C  Work out the sums for the average angular deviation 
C  Keep or re-orientation, keep the new R matrix if AVEANG .gt. REOTOL
C-----------------------------------------------------------------------
              TOP = 0.0
              BOT = 0.0
              DO 240 I = 1,3
                IF (IORNT .EQ. 1) THEN 
                  DELTA = XCOLD(I) - XCNEW(I)
                ELSE
                  DELTA = XOBS(I) - XCNEW(I)
                ENDIF
                DELTA = DELTA*DELTA
                DEL(I) = DEL(I) + DELTA
                TOP = TOP + DELTA
                BOT = BOT + XCNEW(I)*XCNEW(I)  
  240         CONTINUE
              ANGLE = DEG*RATAN2(SQRT(TOP),SQRT(BOT))
              AVEANG = AVEANG + ANGLE
C-----------------------------------------------------------------------
C  Write the results for this reflection
C-----------------------------------------------------------------------
              OMG = OMEGA
              IF (OMG .GT. 359.995) OMG = 0.0
              WRITE (LPT,26000)             
     $               IHI,BTHETA(NB),BOMEGA(NB),BCHI(NB),BPHI(NB),
     $               THETA,OMG,CHI,PHI,ANGLE
            ENDIF
          ENDIF
  250   CONTINUE
        IF (ANS0 .EQ. 'Y' .AND. MARK .EQ. -1) THEN
          NBLOKO = NBLOKO - 1
          WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,
     $                           BPHI,BPSI,NBL
          NBLOKO = NBLOKO + 1
        ENDIF
        GO TO 210
      ENDIF
C-----------------------------------------------------------------------
C  Solve for R matrix elements
C-----------------------------------------------------------------------
      IF (MARK .EQ. 0) THEN
        CALL MATRIX (RHH,RHHI,RHHI,RHHI,'INVERT')
        DO 270 I = 1,3
          DO 260 J = 1,3
            R(I,J) = 0.0
            DO 260 KK = 1,3
              R(I,J) = R(I,J) + RHHI(J,KK)*RHX(KK,I)
  260     CONTINUE
  270   CONTINUE
        DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) -
     $        R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) +
     $        R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1))
        IF (NRC*DET .GT. 0) THEN
          WRITE (LPT,27000) NRF
        ELSE
          WRITE (LPT,28000) NRF
        ENDIF
C-----------------------------------------------------------------------
C  Extract the real and reciprocal cell parameters
C-----------------------------------------------------------------------
        CALL GETPAR
C-----------------------------------------------------------------------
C  Clear the esds array
C-----------------------------------------------------------------------
        DO 290 J = 1,3
          DEL(J) = 0.0
  290   CONTINUE
C-----------------------------------------------------------------------
C  Store new R matrix times Wavelength
C-----------------------------------------------------------------------
        DO 300 I = 1,3
          DO 300 J = 1,3
            RNEW(I,J) = R(I,J)
            R(I,J) = R(I,J)*WAVE
  300   CONTINUE
        MARK = MARK - 1
        GO TO 200
      ENDIF
C-----------------------------------------------------------------------
C  S.D.'s of the R matrix elements from the diagonal elements of the 
C  inverted (RHHI) matrix.
C  Print the matrix and its e.s.ds
C-----------------------------------------------------------------------
      DO 310 I = 1,3
        DO 310 J = 1,3
          SR(I,J) = SQRT(RHHI(J,J)*DEL(I)/(NRF - 3))
  310 CONTINUE
        WRITE (LPT,28100) ((RNEW(I,J),J=1,3),(SR(I,J),J=1,3),I = 1,3)
C-----------------------------------------------------------------------
C  Call CELLSD to find the s.d.'s of the cell parameters
C-----------------------------------------------------------------------
      CALL CELLSD
      IF (IORNT .EQ. 1) THEN
        AVEANG = AVEANG/NRF
        IH = IHSV
        IK = IKSV
        IL = ILSV
        NB = NBSV
        IF (AVEANG .LT. REOTOL) THEN
          WRITE (COUT,30000) AVEANG
          CALL GWRITE (ITP,' ')
          WRITE (LPT,30000) AVEANG
          DO 320 I = 1,3
            DO 320 J = 1,3
              R(I,J) = ROLD(I,J)*WAVE
  320     CONTINUE
          RETURN
        ELSE
          WRITE (COUT,31000) AVEANG
          CALL GWRITE (ITP,' ')
          WRITE (LPT,31000) AVEANG
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  Calculate the SINABS matrix
C-----------------------------------------------------------------------
      IF (KI .NE. 'MM' .AND. KI .NE. 'OP') THEN
        ISYS = 1
        CALL SINMAT
      ENDIF
      RETURN
10000 FORMAT (20X,' Least Squares Orientation Matrix')
13000 FORMAT (' Reflection data can be on file or from the terminal.'/ 
     $        ' Wavelength (',F7.5,') ',$)
14000 FORMAT (/10X,' Reflections in the Alignment List')
15000 FORMAT (' Read the data from the terminal (N) ? ',$)
16000 FORMAT (' The following options are available :--'/
     $        ' 1. List the MM data on the printer for editting, or'/
     $        ' 2. Write the MM data to the ASCII file MMDATA.DA, or'/
     $        ' 3. Proceed to the next step, or'/
     $        ' 4. Exit from MM.'/
     $        ' Which do you want (3) ? ',$)
16100 FORMAT (' MM data from DIFRAC'/F10.6)
17000 FORMAT (3I4,4F8.3,I3)
19000 FORMAT (' Reflections may be deleted or restored to the list',
     $        ' by typing :--',/,
     $        ' h,k,l,1 for Delete  or h,k,l,0 for Restore (End)')
23000 FORMAT (' Do you wish to insert reflections (N) ? ',$)
24100 FORMAT (' Do you want to include these zero values (Y) ? ',$)
24200 FORMAT (' The new zeroes for Omega and Chi are',2F7.3)
24000 FORMAT (' First non-written record: ',I4)
25000 FORMAT (/,22X,'Observed',22X,'Calculated',10X,'Angular'/
     $        '   h   k   l 2Theta  Omega    Chi    Phi  ',
     $                    ' 2Theta  Omega    Chi    Phi ',
     $                    'Deviation')
26000 FORMAT (3I4,4F7.2,2X,4F7.2,F8.3)
26100 FORMAT (I4,2X,3I4,4F8.3)
27000 FORMAT (/' Right-handed Orientation Matrix from ',I4,
     $        ' Reflections')
28000 FORMAT (/' Left-handed Orientation Matrix from ',I4,
     $        ' Reflections')
28100 FORMAT (/9X,'Orientation Matrix',30X,'E.S.Ds'/(3F12.8,6X,3F12.8))
29000 FORMAT (' > ',$)
30000 FORMAT (' The angular deviation is',F6.3,'.  The old matrix will',
     $        ' be retained.')
31000 FORMAT (' The angular deviation is',F6.3,'.  The new matrix will',
     $        ' be used.')
      END
C-----------------------------------------------------------------------
C  Routine to find the zeroes of omega and chi from the alignment data
C  ZOMEGA is the average value of omega;
C  ZCHI   is half the average value of chi for pairs of +++/--- reflns 
C-----------------------------------------------------------------------
      SUBROUTINE WCZERO (ZOMEGA,ZCHI)
      INCLUDE 'COMDIF'
      DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10),
     $          BPHI(10)
C      EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)),
C     $            (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)),
C     $            (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1))
      SUMOME = 0.0
      SUMCHI = 0.0
      NOMEGA = 0
      NCHI   = 0
      NBLOKO = 250
      IH1 = 0
      IK1 = 0
      IL1 = 0
      CHI1 = 999.0
  100 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,
     $                      BPSI,NBL
      IF (NBL .NE. 0) THEN
        DO 110 NB = 1,NBL
          IF (BPSI(NB) .EQ. 0.0) THEN
            WOMEGA = BOMEGA(NB)
            IF (WOMEGA .GT. 180.0) WOMEGA = WOMEGA - 360.0
            SUMOME = SUMOME + WOMEGA
            NOMEGA = NOMEGA + 1
            IH2 = IBH(NB)
            IK2 = IBK(NB)
            IL2 = IBL(NB)
            CHI2 = BCHI(NB)
            IF (IH1 .EQ. -IH2 .AND. 
     $          IK1 .EQ. -IK2 .AND. 
     $          IL1 .EQ. -IL2) THEN
              CHI12 = CHI1 + CHI2
              IF (CHI12 .GT. 350.0) CHI12 = CHI12 - 360.0
              IF (CHI12 .GT. 350.0) CHI12 = CHI12 - 360.0
              SUMCHI = SUMCHI + CHI12
              NCHI = NCHI + 1
            ENDIF
            IH1 = IH2
            IK1 = IK2
            IL1 = IL2
            CHI1 = CHI2
          ENDIF
  110   CONTINUE
        NBLOKO = NBLOKO + 1
        GO TO 100
      ENDIF
      ZOMEGA = SUMOME/NOMEGA
      ZCHI = 0.0
      IF (NCHI .NE. 0) ZCHI = 0.5*SUMCHI/NCHI
      WRITE (COUT,10000) ZOMEGA,NOMEGA,ZCHI,NCHI
      CALL GWRITE (ITP,' ')
      WRITE (LPT,10000) ZOMEGA,NOMEGA,ZCHI,NCHI
      RETURN
10000 FORMAT (' Omega(0) is',F7.3,' from',I4,' reflections.'/
     $        ' Chi(0)   is',F7.3,' from',I4,' +/- pairs.')
      END
C-----------------------------------------------------------------------
C  Get reflection angle input from the terminal
C-----------------------------------------------------------------------
      SUBROUTINE TERMRD
      INCLUDE 'COMDIF'
      DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10),
     $          BPHI(10)
C      EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)),
C     $            (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)),
C     $            (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1))
      NBLOKO = 250
      WRITE (COUT,10000)
      CALL GWRITE (ITP,' ')
  100 NBL = 0
      DO 110 I = 1,10
        WRITE (COUT,11000)
        CALL FREEFM (ITR)
        IH = IFREE(1)
        IK = IFREE(2)
        IL = IFREE(3)
        IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GO TO 120
        IBH(I) = IH
        IBK(I) = IK
        IBL(I) = IL
        BTHETA(I)  = RFREE(4)
        BOMEGA(I)  = RFREE(5)
        BCHI(I)    = RFREE(6)
        BPHI(I)    = RFREE(7)
        BPSI(I)    = 0.
        NBL = NBL + 1
  110 CONTINUE
  120 WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,
     $                       BPHI,BPSI,NBL
      NBLOKO = NBLOKO + 1
      IF (NBL .EQ. 10) GO TO 100
      NBL = 0
      WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,
     $                       BPHI,BPSI,NBL
      RETURN
10000 FORMAT (' Type h,k,l,2theta,omega,chi,phi for each refln. (End)')
11000 FORMAT (' > ',$)
      END
C-----------------------------------------------------------------------
C  Calculate chi and omega for a given phi value
C-----------------------------------------------------------------------
      SUBROUTINE ANGPHI (XC)
      INCLUDE 'COMDIF'
      DIMENSION  XC(3)
      CP = COS(PHI/DEG)
      SP = SIN(PHI/DEG)
      TOPC = XC(3)
      BOTC = CP*XC(1) + SP*XC(2)
      CHI = DEG*RATAN2(TOPC,BOTC)
      TOPO = CP*XC(2) - SP*XC(1)
      IF (CHI .EQ. 0.0) THEN
        OMEGA = 0.0
      ELSE
        BOTO = XC(3)/SIN(CHI/DEG)
        OMEGA = DEG*RATAN2(TOPO,BOTO)
      ENDIF
      TH = 0.5*WAVE*SQRT(XC(1)*XC(1) + XC(2)*XC(2) + XC(3)*XC(3))
      THETA = 2.0*DEG*ATAN(TH/SQRT(1.0 - TH*TH))
      TH = 2.0*TH/WAVE
      CC = COS(CHI/DEG)
      SC = SIN(CHI/DEG)
      CO = COS(OMEGA/DEG)
      SO = SIN(OMEGA/DEG)
      XC(1) = TH*(CC*CP*CO - SO*SP)
      XC(2) = TH*(CC*SP*CO + SO*CP)
      XC(3) = TH*SC*CO
      CALL MOD360 (CHI)
      CALL MOD360 (OMEGA)
      RETURN
      END
C-----------------------------------------------------------------------
C  Get around stupid Microsoft compiler problems
C-----------------------------------------------------------------------
      FUNCTION RATAN2 (TOP,BOT)                                        
      RA = 57.2958
      IF (BOT .EQ. 0) THEN
        X = 90.0/RA
        IF (TOP .LT. 0.0) X = 270.0/RA
      ELSE
        X = ATAN2(TOP,BOT)
      ENDIF
      RATAN2 = X
      RETURN
      END

C-----------------------------------------------------------------------
C  Extract the real and reciprocal cell parameters
C-----------------------------------------------------------------------
      SUBROUTINE GETPAR
      INCLUDE 'COMDIF'
      DIMENSION RT(3,3)
      DO 100 I = 1,3
        DO 100 J = 1,3
          RT(I,J) = R(J,I)
  100 CONTINUE
      CALL MATRIX (RT,R,GI,GI,'MATMUL')
C-----------------------------------------------------------------------
C  Use CANGS array for reciprocal angles
C-----------------------------------------------------------------------
      CALL PARAMS (GI,APS,CANGS)
C-----------------------------------------------------------------------
C  Use RT array for metric tensor G
C-----------------------------------------------------------------------
      CALL MATRIX (GI,RT,RT,RT,'INVERT')
C-----------------------------------------------------------------------
C  Use CANG array for real angles
C-----------------------------------------------------------------------
      CALL PARAMS (RT,AP,CANG)
      RETURN
      END
