      SUBROUTINE SUMS
*
*  Subroutine to assign derivatives for different space groups
*  and sum the least squares equations and set up 
*  for matrix solution of parameter corrections
*
      common/qmod/qj(3),mmin,mmax,qmodul,qrefin,nq,iqtyp,iq(3)
      COMMON/RECP/Z(10),Q,AR(3),X(4),VR,U(3),W(3),VRO
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/SCRT/E(9),ee(9,9),NH(4),qh(3),f(9),ff(9,10)
      COMMON/BLKA/A(54),UO(3),B(9),bb(9,9)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(1000,4),DCM(1000),NR,DMIN
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON /ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),ialfl(13),CSC(8),cscl(8)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN,prthtse
      COMMON/CBLKC/JA
      COMMON/BLKF/SW(200),WL(200)
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CBLKG/IHEAD
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/BLKJ/TOLMN
      COMMON/ALL/N,NUMCYC,ntot
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      logical qmodul
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED,ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF, ialfl, JA, IALF12
      CHARACTER*5  CSC,cscl
      CHARACTER*68 IHEAD
      EQUIVALENCE (RSMX,RSDMAX),(IRSD,MAXM)
      ICYCLE=ICYCLE+1
*      ntout = 6
      IF(NUMOBS .LT. 1) GO TO 999
C
C-----TEST IF WEIGHTS ARE TO BE CHANGED AFTER IWCYC CYCLES
C
      IF(IWCYC.EQ.0) GOTO 100
      IF(ICYCLE.LT.IWCYC) GOTO 100
      DO L=1,NUMOBS
        SW(L) = 1.0
      enddo
*
* set previous standard deviation
*
      prthtse = thtse
*
*  set initial values of f and ff arrays to zero
*
 100  do i=1,ntot
        f(i) = 0.0
        aa(i) = 0.0
        do j=1,ntot
          ff(i,j) = 0.0
        enddo
      enddo
C
C-----ATTEMPTS TO INDEX REFLECTIONS NOT ALREADY INDEXED
C
      IRSD=0
      SUM=0.0
      RSDMAX=0.0
      TOLP = TOLTH
*      IF (ITHT .EQ. 0) 
      TOLP = TOLP + TOLP
      IF (IDOLSQ .EQ. 0) GO TO 110
      IF (IPHKL .NE. 2) WRITE(NTOUT,2) ICYCLE,IHEAD,IALF12,TOLP
    2 FORMAT(6H1cycle,I3,4X,A80,4X,/1H0,A2,17HTheta tolerance =,F9.5)
C
C-----ROUTINE TO CHECK FOR BAD HKL'S
C
      NUM = 1
      IF ((NCYC + 1) .LE. ICYCLE) CALL BADHKL(NUMOBS,NUM)
      if(qmodul)then
        IF (IPHKL .EQ. 0) WRITE(NTOUT,3)
      else 
        IF (IPHKL .EQ. 0) WRITE(NTOUT,4)
      endif
 3    FORMAT(4H0  n,5X,1Hh,3X,1Hk,3X,1Hl,3X,1Hm,10x,12H2-theta calc,
     *  4X,11H2-theta obs,3X,12H2-theta diff)
 4    FORMAT(4H0  n,5X,1Hh,3X,1Hk,3X,1Hl,14x,12H2-theta calc,
     *  4X,11H2-theta obs,3X,12H2-theta diff)
 110  CONTINUE
      DO L=1,IMN
        A(L)=0.0
      enddo
      NUMCYC = 0
C
C-----BEGIN SEARCH FOR CLOSEST D-CALC TO D-OBS
C
      TOL  =TOLTH
      IHP=1
      DO 120 IGP=1,NUMOBS
        JA=IALF(7)
        SWT = SW(IGP)
        THOBS=OBSTH(IGP)
        DO L=1,4
          NH(L)=IH(IGP,L)
        enddo
        PWL = WL(IGP)
        DOBS=DSP(IGP)
        DMNDF=ABS(DCM(IHP)-DOBS)
        JHP=IHP+1
 130    IF(JHP .GT. NR)GO TO 140
        IF(ABS(DCM(JHP)-DOBS) .GT. DMNDF) GO TO 140
        DMNDF=ABS(DCM(JHP)-DOBS)
        JHP=JHP+1
        GO TO 130
 140    IHP=JHP-1
        IOC(IGP)=IHP
C
C------TEST IF INDEXED
C
        IF(IHED(IGP).EQ.ITIH(1) .OR. IHED(IGP).EQ.ITIH(2) .OR.
     *   IHED(IGP).EQ.ITIH(3) .OR. IHED(IGP).EQ.ITIH(7)) GOTO 240
*
C-----UNINDEXED, SPACE GROUP EXTINCT OR A KNOWN IMPURITY
*
 150    CONTINUE
        D=DCM(IHP)
        DLST(IGP)=D
        CONST=0.5*PWL
        IF (D .LE. CONST) GO TO 120
        THCMP=THETA(CONST,D)
        IF (ABS((THOBS-THCMP)*SWT) .GT. TOL) GO TO 120
        J=IGP-1
        ASSIGN 180 TO JADRS
 160    IF (J .LT. 1 .OR. J .GT. NUMOBS) GO TO 170
        IF (ABS(OBSTH(J)-THOBS)*SWT .LT. TOLMN) GO TO 120
        CNST=0.5*PWL
        IF (D .LE. CNST) GO TO 170
        THTRY=THETA(CNST,D)
        IF(ABS((OBSTH(J)-THTRY)*SWT) .LE. TOL) GOTO 120
 170    GO TO JADRS,(180,190)
 180    J=IGP+1
        ASSIGN 190 TO JADRS
        GO TO 160
 190    K=IHP-1
        ASSIGN 220 TO KADRS
 200    IF (K .LT. 1 .OR. K .GT. NR) GO TO 210
        DB=DCM(K)
        IF (DB .LE. CONST) GO TO 210
        THTRY=THETA(CONST,DB)
        IF (ABS(THTRY-THCMP)*SWT .LT. TOLMN) GO TO 120
        IF (ABS(THTRY-THOBS)*SWT .LE. TOL) GO TO 120
 210    GO TO KADRS,(220,230)
 220    K=IHP+1
        ASSIGN 230 TO KADRS
        GO TO 200
 230    IF (THOBS .GT. THTMX .AND. ICYCLE .LE. NCYC) GO TO 120
        DO L=1,4
          NH(L) =IHG(IHP,L)
        enddo
        GO TO 250
*
C-----INDEXED REFLECTION - IH(IGP,4)= 'BLANK', 'M', '+' OR 'E'.
*
 240    CONST=0.5*PWL
        CALL QCOMP(NH,Z,x,u,Q)
        IF(Q.LT.0.00001) GOTO 120
        D=1.0/SQRT(Q)
        DLST(IGP)=D
        IF (CONST .GE. D) GO TO 120
        THCMP=THETA(CONST,D)
        IF (ABS((THCMP-THOBS)*SWT) .LE. TOL) GO TO 250
        JA = IALF(8)
        IF (IDOLSQ .EQ. 1) GO TO 250
        NUM = 1
        CALL BADHKL(NUM,IGP)
        GO TO 150
 250    DIFF=THCMP-THOBS
C
C-----IF WITHIN TOLERENCE AND CAN BE UNIQUELY INDEXED INCLUDE IN
C-----LEAST SQUARES EQUATION (IE, NOT 'R')
C
        IF(JA .EQ. IALF(8)) GOTO 410
*
* Assign derivatives to e(i) and ee(i,j) arrays based on
* which parameters to be refined for each space group
*
        NUMCYC=NUMCYC+1
        DIV=COS(0.017453293*THCMP)
        IF (DIV) 300,300,310
 300    NUMCYC=NUMCYC-1
        RETURN
 310    CALL Deriv           !COMPUTES PARTIAL DERIVATIVES OF D*2 
        ntot = n + nq
        GO TO (320,330,340,350,330,360,370),ITYP
 320    E(1)=B(1)+B(2)+B(3)            ! cubic
        ee(1,1) = bb(1,1) + bb(2,2) + bb(3,3)
        GO TO 380                      ! no mod allowed in cubic sg
 330    E(1)=B(1)+B(2)                 ! hexagonal/tetragonal
        E(2)=B(3)
        e(3)=b(9)                      ! mod vector only allowed in c dir
        ee(1,1) = bb(1,1) + bb(2,2)
        ee(1,2) = 0.0
        ee(1,3) = 0.0
        ee(2,1) = 0.0
        ee(2,2) = bb(3,3)
        ee(2,3) = bb(3,9)
        ee(3,1) = bb(9,1) + bb(9,2)
        ee(3,2) = bb(9,3)
        ee(3,3) = bb(9,9)
        GO TO 380
 340    DO J=1,ntot                    ! orthorhombic
          if(j.le.3)then
            E(J)=B(J)
            do k=1,ntot
              if(k.le.3)then
                ee(j,k) = bb(j,k)
              else
                l = iq(k - 3)
                ee(j,k) = bb(j,l)
              endif
            enddo
          else
            m = iq(j - 3)
            e(j) = b(m)
            do k=1,ntot
              if(k.le.3)then
                ee(j,k) = bb(m,k)
              else
                l = iq(k - 3)
                ee(j,k) = bb(m,l)
              endif
            enddo
          endif      
        enddo
        GO TO 380
 350    DO J=1,ntot                    ! monoclinic
          mono = 5
          if(j.le.3)then
            E(J)=B(J)
            do k=1,ntot
              if(k.le.3)then
                ee(j,k) = bb(j,k)
              else
                if(k.eq.4)then
                  ee(j,k) = bb(j,mono)
                else  
                  l = iq(k - 4)
                  ee(j,k) = bb(j,l)
                endif
              endif
            enddo
          else
            if(j.eq.4)then
              e(j) = b(mono)
              do k=1,ntot
                if(k.le.3)then
                  ee(j,k) = bb(mono,k)
                else
                  if(k.eq.4)then
                    ee(j,k) = bb(mono,mono)
                  else
                    l = iq(k - 4)
                    ee(j,k) = bb(mono,l)
                  endif
                endif
              enddo
            else
              m = iq(j - 4)
              e(j) = b(m)
              do k=1,ntot
                if(k.le.3)then
                  ee(j,k) = bb(m,k)
                else
                  if(k.eq.4)then
                    ee(j,k) = bb(m,mono)
                  else
                    l = iq(k - 4)
                    ee(j,k) = bb(m,l)
                  endif
                endif
              enddo
            endif
          endif      
        enddo
        GO TO 380
 360    DO J=1,ntot                    ! triclinic
          if(j.le.6)then
            E(J)=B(J)
            do k=1,ntot
              if(k.le.6)then
                ee(j,k) = bb(j,k)
              else
                l = iq(k - 6)
                ee(j,k) = bb(j,l)
              endif
            enddo
          else
            m = iq(j - 6)
            e(j) = b(m)
            do k=1,ntot
              if(k.le.6)then
                ee(j,k) = bb(m,k)
              else
                l = iq(k - 6)
                ee(j,k) = bb(m,l)
              endif
            enddo
          endif      
        enddo
        GO TO 380
 370    DO J=1,2                       ! trigonal (rhombohedral)
          E(J)=B(3*J-2)+B(3*J-1)+B(3*J)
        enddo                           ! no mod allowed in trigonal
* 380    write(ntout,20)
* 20      format(' the ee matrix is')
*        do l = 1,ntot
*          write(ntout,21)(ee(l,m),m=1,ntot)
*        enddo
* 21      format(1h 9f8.4)
 380    IF ((IPHKL .EQ. 0) .AND. (IDOLSQ .EQ. 1)) CALL HKLPR
*
*  Sum the least squares equations
*  and the derivatives of the least squares equations for the phi matrix
*  and assign f(i) values to additional column of ff(i,j) array
*  for simul solution
*
        call qcomp(nh,z,x,u,q)
        tdiff = q -(4.0/(pwl**2))*(sind(thobs)**2)
        sum = sum + tdiff**2
        do i=1,ntot
          f(i) = f(i) + tdiff*e(i)
          do j=1,ntot
            ff(i,j) = ff(i,j) +  tdiff*ee(i,j) + e(i)*e(j)
          enddo
          ff(i,ntot+1) = -f(i)
        enddo
        GO TO 120
 410    IF ((IPHKL .EQ. 0) .AND. (IDOLSQ .EQ. 1)) CALL HKLPR
 120  CONTINUE
      rsdmax = 0.0
      if(numcyc.le.0)go to 999
      do i=1,ntot
        test = abs(f(i))/numcyc
        if(test.gt.rsdmax) rsdmax = test
      enddo
 999  RETURN
      END
