      SUBROUTINE DERIVS(NEW7)
C SUBROUTINE TO COMPUTE THE DERIVATIVES OF DEPENDENT, CRYSTALLO-
C  GRAPHIC PARAMETERS WITH RESPECT TO THE SPECIAL PARAMETERS.
C
      INCLUDE 'RFINE.PRM'
      INCLUDE 'XPAR.INC'
      INCLUDE 'LSMAT.INC'
      INCLUDE 'A.INC'
      INCLUDE 'D.INC'
      INCLUDE 'E.INC'
      INCLUDE 'CNSTRS.INC'
      DIMENSION JDEGN(25000)
      EQUIVALENCE (JDEGN,A)
C
      INCLUDE 'SHIFT.INC'
C
      MDEGN=2*NDEGN
      KMAX=QQTMP-(MRANK*(MRANK+1))/2-2
      JPPA(1)=0
      DO 300 I=1,NATOM
         JPPA(I+1)=JPPA(I)+5
         IF(ISOT(I).GE.1)JPPA(I+1)=JPPA(I+1)+5
         IF(ISOT(I).GE.2)JPPA(I+1)=JPPA(I+1)+10
         IF(ISOT(I).GE.3)JPPA(I+1)=JPPA(I+1)+15
  300 CONTINUE
      IF(NPAR.EQ.0) GO TO 810
C
C FILL IN SPECIAL PARAMETER ARRAYS
C
      CALL FILLIN
C
C LOOP THROUGH CONSTRAINTS 
C
      I=-1
  310 I=I+2
C DONE IF INDEPENDENT PARAMETER IS NOT SPECIAL
      IF(I1(KDEGN(I)).NE.0)GO TO 810
C GET INDEPENDENT PARAMETER NUMBER AND ATOM NUMBER OF DEPENDENT
      II=I2(KDEGN(I))
      NA=I3(KDEGN(I))
C SKIP IF INITIALIZING CONSTANT OR DEPENDENT PARAMETER ALSO SPECIAL
      IF(II.EQ.0.OR.NA.EQ.0)GO TO 800
      NPMIN=I4(KDEGN(I))
      DO 320 J=I,MDEGN,2
      IF((J+2).GT.MDEGN.OR.I3(KDEGN(J+2)).NE.NA.OR.I2(KDEGN(J+2)).NE.II)
     1GO TO 330
  320 CONTINUE
  330 NPMAX=I4(KDEGN(J))
C I POINTS AT THE FIRST PARAMETER OF ATOM NA WHICH IS DEPENDENT ON
C  SPECIAL PARAMETER II. J POINTS AT THE LAST.
C  GET SET DESIGNATOR, CLEAR ARRAYS, AND COMPUTE TRANSFORMATION.
      IF(I1(IPAR(II)).EQ.1)GO TO 340
      IF(I1(IPAR(II)).EQ.0)GO TO 790
      CALL SPDERI(II,NA,NPMIN,NPMAX,I,J)
      GO TO 790
C SECTION FOR RIGID BODY PARAMETERS
  340 ISET=I2(IPAR(II))
C DO WE NEED TO FILL IN XYZ?
      IF(NPMIN.LE.4)GO TO 360
      DO 350 K=1,3
  350 RTEM(K)=XYZ(K,NA)-OXYZ(K,ISET)
      CALL MULMV(TTRNSI(1,1,ISET),RTEM,SXYZ(1,NA,ISET))
C     WHAT KIND IS INDEPENDENT PARAMETER?
  360 IDEN=I4(IPAR(II))
      JDEN=(IDEN+2)/3
      IF(JDEN.GE.3)CALL MULMM(XTOA,TRNS(1,1,ISET),TTRNS)
      GO TO (370,390,530,590,590,630,630,700,700,700),JDEN
C     SPECIAL ORIGIN
  370 DO 380 K=I,J,2
  380 AA(K+1)=1.
      GO TO 790
C     ORIENTATION OF SPECIAL SYSTEM WRT CRYSTAL ORTHONORMAL.
  390 K=I
      IF(IDEN-5)400,410,420
C OMEGA ANGLE
  400 CALL MULMM(XTOA,TRNSDO(1,1,ISET),TTRNS)
      GO TO 430
C CHI ANGLE
  410 CALL MULMM(XTOA,TRNSDC(1,1,ISET),TTRNS)
      GO TO 430
C PHI ANGLE
  420 CALL MULMM(XTOA,TRNSDP(1,1,ISET),TTRNS)
  430 IF(NPMIN.GE.5)GO TO 450
C DERIVATIVES OF POSITION PARAMETERS WRT OMEGA,CHI, OR PHI.
      CALL MULMV(TTRNS,SXYZ(1,NA,ISET),RTEM)
  440 KK=I4(KDEGN(K))
      IF(KK.GE.5)GO TO 460
      AA(K+1)=RTEM(KK-1)
      K=K+2
      IF(K-J)440,440,790
  450 IF(NPMIN.GE.11)GO TO 490
  460 IF(NPMAX.LE.4)GO TO 790
C DERIVATIVES OF BETAS WRT OMEGA, CHI, OR PHI.
C CORRECT SXYZ FOR LIBRATION.
      CALL CORLIB(RTEM,EL(1,1,ISET),SXYZ(1,NA,ISET))
      DO 470 L=1,6
      JK=IND2(1,L)
      JL=IND2(2,L)
  470 BTEM(L)=SKTLS(RTEM,JK,JL,T(1,1,ISET),EL(1,1,ISET),S(1,1,ISET))
      CALL TFM2(TTRNS,BTEM,BTEM)
  480 KK=I4(KDEGN(K))
      IF(KK.GE.11)GO TO 500
      AA(K+1)=BTEM(KK-4)
      K=K+2
      IF(K-J)480,480,790
  490 CALL CORLIB(RTEM,EL(1,1,ISET),SXYZ(1,NA,ISET))
  500 IF(NPMAX.LE.10)GO TO 790
C DERIVATIVES OF GAMMAS WRT OMEGA, CHI, OR PHI.
      DO 510 L=1,10
      JK=IND3(1,L)
      JL=IND3(2,L)
      JM=IND3(3,L)
  510 GTEM(L)=TKTLS(RTEM,JK,JL,JM,EL(1,1,ISET),S(1,1,ISET))
      CALL TFM3(TTRNS,GTEM,GTEM)
  520 KK=I4(KDEGN(K))
      IF(KK.GT.20)GO TO 790
      AA(K+1)=GTEM(KK-10)
      K=K+2
      IF(K-J)520,520,790
C POSITION IN SPECIAL SYSTEM
  530 K=I
      IF(NPMIN.GE.5)GO TO 550
  540 KK=I4(KDEGN(K))
      IF(KK.GT.4)GO TO 560
      AA(K+1)=TTRNS(KK-1,IDEN-6)
      K=K+2
      IF(K-J)540,540,790
C WE SHALL NOW IGNORE THE DERIVATIVES OF BETAS AND GAMMAS WRT
C  SXYZ, ZLTHOUGH THESE MAY ACTUALLY BE IMPORTANT. WE WILL FILL THEM
C  IN LATER.
  550 KK=I4(KDEGN(K))
  560 IF(KK.GT.10)GO TO 580
      AA(K+1)=0.
      K=K+2
      IF(K-J)550,550,790
  570 KK=I4(KDEGN(K))
  580 IF(KK.GT.20)GO TO 790
      AA(K+1)=0.
      K=K+2
      IF(K-J)570,570,790
C ELEMENTS OF T TENSOR. ONLY BETAS INVOLVED.
  590 K=I
      IDEN=IDEN-9
      JK=IND2(1,IDEN)
      JL=IND2(2,IDEN)
      DO 600 L=1,6
      JM=IND2(1,L)
      JN=IND2(2,L)
  600 BTEM(L)=D2KDT(JM,JN,JK,JL)
      CALL TFM2(TTRNS,BTEM,BTEM)
  610 KK=I4(KDEGN(K))
      IF(KK.GT.10)GO TO 790
      IF(KK.LT.5)GO TO 620
      AA(K+1)=BTEM(KK-4)
  620 K=K+2
      IF(K-J)610,610,790
C ELEMENTS OF L TENSOR. BETAS AND GAMMAS INVOLVED.
  630 K=I
      IDEN=IDEN-15
      JK=IND2(1,IDEN)
      JL=IND2(2,IDEN)
      CALL CORLIB(RTEM,EL(1,1,ISET),SXYZ(1,NA,ISET))
      IF(NPMIN.GT.10)GO TO 670
      DO 640 L=1,6
      JM=IND2(1,L)
      JN=IND2(2,L)
  640 BTEM(L)=D2KDL(RTEM,EL(1,1,ISET),S(1,1,ISET),JM,JN,JK,JL)
      CALL TFM2(TTRNS,BTEM,BTEM)
  650 KK=I4(KDEGN(K))
      IF(KK.GT.10)GO TO 670
      IF(KK.LT.5)GO TO 660
      AA(K+1)=BTEM(KK-4)
  660 K=K+2
      IF(K-J)650,650,790
  670 DO 680 L=1,10
      JM=IND3(1,L)
      JN=IND3(2,L)
      JP=IND3(3,L)
  680 GTEM(L)=D3KDL(RTEM,EL(1,1,ISET),S(1,1,ISET),JM,JN,JP,JK,JL)
      CALL TFM3(TTRNS,GTEM,GTEM)
  690 KK=I4(KDEGN(K))
      IF(KK.GT.20)GO TO 790
      AA(K+1)=GTEM(KK-10)
      K=K+2
      IF(K-J)690,690,790
C ELEMENTS OF S TENSOR.
  700 K=I
      IDEN=IDEN-21
      CALL CORLIB(RTEM,EL(1,1,ISET),SXYZ(1,NA,ISET))
      IF(IDEN.GT.6)GO TO 710
      JK=IND2(1,IDEN)
      JL=IND2(2,IDEN)
      GO TO 720
  710 JL=IND2(1,IDEN-3)
      JK=IND2(2,IDEN-3)
  720 DO 730 L=1,6
      JM=IND2(1,L)
      JN=IND2(2,L)
  730 BTEM(L)=D2KDS(RTEM,EL(1,1,ISET),JM,JN,JK,JL)
      CALL TFM2(TTRNS,BTEM,BTEM)
  740 KK=I4(KDEGN(K))
      IF(KK.GT.10)GO TO 760
      IF(KK.LT.5)GO TO 750
      AA(K+1)=BTEM(KK-4)
  750 K=K+2
      IF(K-J)740,740,790
  760 DO 770 L=1,10
      JM=IND3(1,L)
      JN=IND3(2,L)
      JP=IND3(3,L)
  770 GTEM(L)=D3KDS(RTEM,EL(1,1,ISET),S(1,1,ISET),JM,JN,JP,JK,JL)
      CALL TFM3(TTRNS,GTEM,GTEM)
  780 KK=I4(KDEGN(K))
      IF(KK.GT.20)GO TO 790
      AA(K+1)=GTEM(KK-10)
      K=K+2
      IF(K-J)780,780,790
  790 I=J
  800 IF(I+2-MDEGN)310,810,810
  810 CONTINUE
C COPY ALL EFFECTIVE CONSTRAINT RELATIONS INTO THE 'A' ARRAY WITH
C  THE INDEPENDENT PARAMETER NUMBER REPLACED BY ITS MATRIX POINTER.
C  ELIMINATE INITIALIZING CONSTANTS AND UNREFINED INDEPENDENT
C  PARAMETERS. IF ANY SPECIAL PARAMETER IS DEPENDENT ON ANOTHER
C  SPECIAL PARAMETER (LINEAR RELATIONS ONLY) THE DERIVATIVE MUST BE
C  CORRECTED TO REFLECT ALL RELATIONS. FIRST COPY THE UNALTERED LIST
C  TO A SCRATCH FILE.
      REWIND ISC5
      WRITE(ISC5)MDEGN,(KDEGN(I),I=1,MDEGN)
      IF(NPAR.NE.0.OR.NEW7.NE.0)CALL PDEGN(NEW7)
      IDEGN=0
      DO 860 I=1,MDEGN,2
        IF(IDEGN.GT.KMAX)THEN
C TOO MANY RELATIONSHIPS
          WRITE(IOUT,10)
   10     FORMAT('0RUN ABORTED FROM DERIVS. TOO MANY RELATIONS.')
          STOP
        ENDIF
        NA=I1(KDEGN(I))
        IF(NA.NE.0)GO TO 840
C SPECIAL PARAMETER OR INITIALIZING CONSTANT.
        II=I2(KDEGN(I))
C IGNORE INITIALIZATION
        IF(II.EQ.0)GO TO 860
        IPT=IRPAR(II)
C IGNORE UNREFINED PARAMETER
        IF(IPT.LE.0)GO TO 860
        JJ=I3(KDEGN(I))
        KK=I4(KDEGN(I))
        IF(JJ.NE.0)GO TO 850
C DEPENDENT PARAMETER SPECIAL. FIND ALL LINKS TO INDEPENDENT ONE.
        NJ=I+2
        DO 830 J=NJ,MDEGN,2
C DONE IF INDEPENDENT PARAMETER IS NOT SPECIAL
          IF(I1(KDEGN(J)).GT.0)GO TO 860
          IF(I2(KDEGN(J)).NE.KK)GO TO 830
          JJJ=I3(KDEGN(J))
          KKK=I4(KDEGN(J))
C REPACK CONSTRAINT POINTERS:  BITS 0-15 = ATOMIC PARAMETER LIST POINTER
C                                           TO DEPENDENT VARIABLE
C                              BITS 16-31 = REFINED PARAMETER POINTER
          KPRM=JPPA(JJJ)+KKK
          JDEGN(IDEGN+1)=IPT*65536+KPRM
          A(IDEGN+2)=AA(J+1)*AA(I+1)
C SKIP ZERO DERIVATIVES
          IF(A(IDEGN+2).NE.0.0)IDEGN=IDEGN+2
  830   CONTINUE
        GO TO 860
C INDEPENDENT PARAMETER CONVENTIONAL
  840   II=I2(KDEGN(I))
        JJ=JPPA(NA)+II
        IPT=IPARA(JJ)
C IGNORE IF PARAMETER NOT REFINED
        IF(IPT.LE.0)GO TO 860
C DEPENDENT PARAMETER CONVENTIONAL
  850   JJ=I3(KDEGN(I))
        KK=I4(KDEGN(I))
C REPACK CONSTRAINT POINTERS
        KPRM=JPPA(JJ)+KK
        JDEGN(IDEGN+1)=IPT*65536+KPRM
        A(IDEGN+2)=AA(I+1)
C IGNORE ZERO DERIVATIVES
        IF(A(IDEGN+2).NE.0.0)IDEGN=IDEGN+2
  860 CONTINUE
      MDEGN=IDEGN
      RETURN
      END
