C***********************************************************************
C     MCYBIMAT
C***********************************************************************
C
      SUBROUTINE mcybimat(BM,BI,AMASS,U,GM,REDM,NATOM,NINT,
     *                    MAXINT,MAXCAR)
C
C     CALCULATES THE INVERSE OF BM
C
C     This is a slightly modified version of subroutine ybimat in Tinkerate.
C     The main change consists in changing the passing of the MAXINT and 
C     MAXCAR which is done now through the parameter list rather than
C     through the parameter include file. Another change is the call to
C     MCYMATINV instead of YMATINV.
C     (Titus V Albu January 2002)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.0D0)
C
      DIMENSION BM(MAXINT,MAXCAR), BI(MAXCAR,MAXINT)
C
      DIMENSION BMBMT(MAXINT,MAXINT),BINV(MAXINT,MAXINT)
      DIMENSION INDX(MAXINT),U(MAXCAR,MAXCAR)
      DIMENSION AMASS(MAXCAR),UB(MAXCAR,MAXINT)
C
      DIMENSION GM(MAXINT,MAXINT)
C
      NCAR=3*NATOM
C
C  FORM MATRIX THE U MATRIX
C
      DO 20 I = 1,MAXCAR
      DO 10 J = 1,MAXCAR
         U(I,J) = ZERO
   10 CONTINUE
   20 CONTINUE
C
      DO 25 I = 1,NCAR
         U(I,I) = ONE/(REDM*AMASS(I)*AMASS(I))
   25 CONTINUE
C
C     CONSTRUCT BM*U*BMT
C
      DO 30 I=1,NCAR
      DO 30 J=1,NINT
      SUM=ZERO
      DO 40 K=1,NCAR
   40 SUM=SUM+U(I,K)*BM(J,K)
      UB(I,J)=SUM
   30 CONTINUE
C
      DO 100 I=1,NINT
      DO 100 J=1,NINT
      SUM=ZERO
      DO 110 K=1,NCAR
  110 SUM=SUM+BM(I,K)*UB(K,J)
      BMBMT(I,J)=SUM
      GM(I,J) = SUM
  100 CONTINUE
C
C   CONSTRUCT (BM*U*BMT)-1
C
      CALL MCYMATINV(BMBMT,NINT,MAXINT,INDX,BINV)
C
C     CALCULATE THE MATRIX A
C
      DO 400 I=1,NCAR
      DO 400 J=1,NINT
      SUM=ZERO
      DO 500 K=1,NINT
  500 SUM=SUM+UB(I,K)*BINV(K,J)
  400 BI(I,J)=SUM
C
C     ALL DONE
C
      RETURN
      END
C***********************************************************************
C     MCYBIMAT2
C***********************************************************************
C
      SUBROUTINE mcybimat2(BM,BI,AMASS,U,GM,GGI,FLGM,
     >                     EGNM,REDM,NATOM,NINT,MAXINT,MAXCAR)
C
C     CALCULATES THE GENERALIZED INVERSE OF BM, a spinoff from bimat
C     applied to the redundant internal coordinate case.
C
C     This is a slightly modified version of subroutine ybimat2 in Tinkerate.
C     The main change consists in changing the passing of the MAXINT and
C     MAXCAR which is done now through the parameter list rather than
C     through the parameter include file.
C     (Titus V Albu January 2002)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.0D0)
c
c     some of them are returned with the exact dimension i.e. BM,BI,GM
c
      DIMENSION BM(MAXINT,MAXCAR), BI(MAXCAR,MAXINT)
      DIMENSION BMBMT(MAXINT,MAXINT),BINV(MAXINT,MAXINT)
      DIMENSION U(MAXCAR,MAXCAR)
      DIMENSION AMASS(MAXCAR),UB(MAXCAR,MAXINT)
      DIMENSION GM(MAXINT,MAXINT),GGI(MAXINT,MAXINT)
      DIMENSION FLGM(MAXINT),EGNM(MAXINT,MAXINT)

C     FLGM   = EIGENVALUES OF THE G MATRIX = BuBT
C     EGNM   = EIGENVECTORS OF THE G MATRIX
C     FV1, FV2 = WORKING ARRAYS
C 
      DIMENSION FV1(MAXINT),FV2(MAXINT),FLVT(MAXINT,MAXINT)
      DIMENSION SONE(MAXINT,MAXINT),EGNMT(MAXINT,MAXINT)
      DIMENSION TEMPG(MAXINT*(MAXINT+1)/2),EXPAL(MAXINT,MAXINT)
      DIMENSION TFLGM(MAXINT)
C
      NCAR=3*NATOM
C
C  FORM MATRIX THE U MATRIX 
C
      DO 20 I = 1,NCAR
      DO 10 J = 1,NCAR
         U(I,J) = ZERO
   10 CONTINUE
   20 CONTINUE
C
      DO 25 I = 1,NCAR
         U(I,I) = ONE/(REDM*AMASS(I)*AMASS(I))
   25 CONTINUE
C
C     CONSTRUCT BM*U*BMT
C
      DO 30 I=1,NCAR
      DO 30 J=1,NINT
      SUM=ZERO
      DO 40 K=1,NCAR
   40 SUM=SUM+U(I,K)*BM(J,K)
      UB(I,J)=SUM
   30 CONTINUE   

      DO 100 I=1,NINT
      DO 100 J=1,NINT
      SUM=ZERO
      DO 110 K=1,NCAR
  110 SUM=SUM+BM(I,K)*UB(K,J)
      BMBMT(I,J) = SUM
      GM(I,J) = SUM
  100 CONTINUE       
C
C   CONSTRUCT (BM*U*BMT)-1  
C
      NCOUNT = 1 
      DO I = 1,NINT
         DO J = 1,I
            TEMPG(NCOUNT) = BMBMT(J,I)
            NCOUNT = NCOUNT + 1 
         ENDDO
      ENDDO
      CALL YRSPP(MAXINT,NINT,MAXINT*(MAXINT+1)/2,TEMPG,
     >          FLGM,1,EGNMT,FV1,FV2,IERR)
C
C  SETUP EIGENVECTOR MATRIX
C
      DO J = 1,NINT
         DO I = 1,NINT
            EGNM(I,J) = EGNMT(I,NINT-J+1)
         ENDDO
      ENDDO
C
C   Set up the Matrix with Eigenvalues : note the limit is set to 3N-6
c   need to generalized to 3N-5 : in descending order (of eigenvalues)
c   but EXPAL has the inverse
C
      DO I = 1,NINT
         DO J = 1,NINT
            EXPAL (I,J) = 0.0d0
         ENDDO
      ENDDO
c
      DO I = 1, NINT
         ICOUNT = NINT-I+1
         IF (FLGM(ICOUNT).gt.1.0d-10) THEN
             EXPAL(I,I) = 1.0d0/FLGM(ICOUNT)
         ELSE
             FLGM(ICOUNT) = 0.0d0
         ENDIF
         TFLGM(I)=FLGM(ICOUNT)
      ENDDO
      DO I = 1,NINT
         FLGM(I)=TFLGM(I)
      ENDDO
C
C   CALCULATE INVERSE G 
C
      DO 330 I=1,NINT
         DO 330 J=1,NINT
            SUM=ZERO
            DO 340 K=1,NINT
  340    SUM=SUM+EXPAL(I,K)*EGNM(J,K)
         FLVT(I,J)=SUM
  330 CONTINUE

      DO 300 I=1,NINT
         DO 300 J=1,NINT
            SUM=ZERO
            DO 310 K=1,NINT
  310    SUM=SUM+EGNM(I,K)*FLVT(K,J)
         BINV(I,J) = SUM
  300 CONTINUE
C
C     CHECK G*Gi; EQUIVALENT TO THE PROJECTOR FROM REDUNDANT TO NONREDUNDANT
C
      DO I=1,NINT
         DO J=1,NINT
            SUM=ZERO
            DO K=1,NINT
               SUM=SUM+GM(I,K)*BINV(K,J)
            ENDDO
            GGI(I,J)=SUM
          ENDDO
      ENDDO
C
C     CALCULATE THE A MATRIX
C
      DO I=1,NCAR
        DO J=1,NINT
          SUM=ZERO
          DO K=1,NINT
            SUM=SUM+UB(I,K)*BINV(K,J)
          ENDDO
          BI(I,J)=SUM
        ENDDO
      ENDDO
C
C    CHECK FOR INVERSE
C
       DO I=1,NINT
         DO J=1,NINT
           SUM=ZERO
           DO K=1,NCAR
              SUM=SUM+BM(I,K)*BI(K,J)
           ENDDO
           SONE(I,J)=SUM
         ENDDO
       ENDDO
C
C     ALL DONE
C
      RETURN
      END
C***********************************************************************
C      MCYBMAT
C***********************************************************************
C
      SUBROUTINE mcybmat(NBL,NBA,NTO,NLBE,IBL,IBA,ITO,ILBE,X,Y,Z,NATOM,
     >                NINT,BM,T,NATOMS,MAXINT,MAXCAR)
C
C     CALCULATES THE MATRIX DR/DX
C
C     This is a slightly modified version of subroutine ybmat in Tinkerate.
C     The main change consists in changing the passing of the NATOMS,
C     MAXINT, and MAXCAR which is done now through the parameter list rather
C     than through the parameter include file.
C     (Titus V Albu January 2002)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION BM(MAXINT,MAXCAR)
      DIMENSION X(NATOMS),Y(NATOMS),Z(NATOMS),
     > IBL(2,MAXINT),IBA(3,MAXINT),ITO(4,MAXINT),ILBE(3,MAXINT)
      DIMENSION PX(3),PY(3),PZ(3),V(3),T(3,3),BMTE(3)
C
      IROW=0
      DO 30 IJ=1,NBL
      IROW=IROW+1
      I=IBL(1,IJ)
      J=IBL(2,IJ)
      RIJ1=X(J)-X(I)
      RIJ2=Y(J)-Y(I)
      RIJ3=Z(J)-Z(I)
      RIJ=YDIST(I,J,X,Y,Z,NATOMS)
      BM(IROW,3*I-2)=-RIJ1/RIJ
      BM(IROW,3*I-1)=-RIJ2/RIJ
      BM(IROW,3*I)=-RIJ3/RIJ
      BM(IROW,3*J-2)=RIJ1/RIJ
      BM(IROW,3*J-1)=RIJ2/RIJ
      BM(IROW,3*J)=RIJ3/RIJ
   30 CONTINUE
C
      DO 40 IJK=1,NBA
      IROW=IROW+1
      I=IBA(1,IJK)
      J=IBA(2,IJK)
      K=IBA(3,IJK)
      RIJ1=X(J)-X(I)
      RIJ2=Y(J)-Y(I)
      RIJ3=Z(J)-Z(I)
      RJK1=X(K)-X(J)
      RJK2=Y(K)-Y(J)
      RJK3=Z(K)-Z(J)
      RIJ=YDIST(I,J,X,Y,Z,NATOMS)
      RJK=YDIST(J,K,X,Y,Z,NATOMS)
      PIJK=YANGL(I,J,K,X,Y,Z,NATOMS)
      CIJK=YCOSE(PIJK)
      SIJK=YSINE(PIJK)
      BM(IROW,3*I-2)=(-CIJK*RIJ1*RJK-RIJ*RJK1)/(SIJK*RIJ**2*RJK)
      BM(IROW,3*I-1)=(-CIJK*RIJ2*RJK-RIJ*RJK2)/(SIJK*RIJ**2*RJK)
      BM(IROW,3*I)=(-CIJK*RIJ3*RJK-RIJ*RJK3)/(SIJK*RIJ**2*RJK)
      BM(IROW,3*J-2)=
     > (-RIJ*RIJ1*RJK+CIJK*RIJ1*RJK**2-CIJK*RIJ**2*RJK1+RIJ*RJK*RJK1)
     > /(SIJK*RIJ**2*RJK**2)
      BM(IROW,3*J-1)=
     > (-RIJ*RIJ2*RJK+CIJK*RIJ2*RJK**2-CIJK*RIJ**2*RJK2+RIJ*RJK*RJK2)
     > /(SIJK*RIJ**2*RJK**2)
      BM(IROW,3*J)=
     > (-RIJ*RIJ3*RJK+CIJK*RIJ3*RJK**2-CIJK*RIJ**2*RJK3+RIJ*RJK*RJK3)
     > /(SIJK*RIJ**2*RJK**2)
      BM(IROW,3*K-2)=(RIJ1*RJK+CIJK*RIJ*RJK1)/(SIJK*RIJ*RJK**2)
      BM(IROW,3*K-1)=(RIJ2*RJK+CIJK*RIJ*RJK2)/(SIJK*RIJ*RJK**2)
      BM(IROW,3*K)=(RIJ3*RJK+CIJK*RIJ*RJK3)/(SIJK*RIJ*RJK**2)
   40 CONTINUE
C
      DO 50 IJKL=1,NTO
      IROW=IROW+1
      I=ITO(1,IJKL)
      J=ITO(2,IJKL)
      K=ITO(3,IJKL)
      L=ITO(4,IJKL)
      RIJ1=X(J)-X(I)
      RIJ2=Y(J)-Y(I)
      RIJ3=Z(J)-Z(I)
      RJK1=X(K)-X(J)
      RJK2=Y(K)-Y(J)
      RJK3=Z(K)-Z(J)
      RKL1=X(L)-X(K)
      RKL2=Y(L)-Y(K)
      RKL3=Z(L)-Z(K)
      RIJ=YDIST(I,J,X,Y,Z,NATOMS)
      RJK=YDIST(J,K,X,Y,Z,NATOMS)
      RKL=YDIST(K,L,X,Y,Z,NATOMS)
      PIJK=YANGL(I,J,K,X,Y,Z,NATOMS)
      CIJK=YCOSE(PIJK)
      SIJK=YSINE(PIJK)
      PJKL=YANGL(J,K,L,X,Y,Z,NATOMS)
      CJKL=YCOSE(PJKL)
      SJKL=YSINE(PJKL)
      CIJKL=((-RIJ2*RJK1+RIJ1*RJK2)*(-RJK2*RKL1+RJK1*RKL2)+
     > (RIJ3*RJK1-RIJ1*RJK3)*(RJK3*RKL1-RJK1*RKL3)+
     > (-RIJ3*RJK2+RIJ2*RJK3)*(-RJK3*RKL2+RJK2*RKL3))/
     > (SIJK*SJKL*RIJ*RJK*RJK*RKL)
      SIJKL=((-RIJ3*RJK2+RIJ2*RJK3)*RKL1+(RIJ3*RJK1-RIJ1*RJK3)*RKL2+
     > (-(RIJ2*RJK1)+RIJ1*RJK2)*RKL3)/(RIJ*RJK*RKL*SIJK*SJKL)
      BM(IROW,3*I-2)=SIJKL*RIJ1/(CIJKL*SIJK**2*RIJ**2)+  
     > CIJK*SIJKL*RJK1/(CIJKL*SIJK**2*RIJ*RJK)+  
     > (RJK3*RKL2-RJK2*RKL3)/(CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*I-1)=SIJKL*RIJ2/(CIJKL*SIJK**2*RIJ**2)+  
     > CIJK*SIJKL*RJK2/(CIJKL*SIJK**2*RIJ*RJK)+  
     > (-RJK3*RKL1+RJK1*RKL3)/(CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*I)=SIJKL*RIJ3/(CIJKL*SIJK**2*RIJ**2)+  
     > CIJK*SIJKL*RJK3/(CIJKL*SIJK**2*RIJ*RJK)+  
     > (RJK2*RKL1-RJK1*RKL2)/(CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*J-2)=-(SIJKL*RIJ1/(CIJKL*SIJK**2*RIJ**2))+  
     > CIJK*SIJKL*(RIJ1-RJK1)/(CIJKL*SIJK**2*RIJ*RJK)-  
     > SIJKL*RJK1/(CIJKL*RJK**2)+SIJKL*RJK1/(CIJKL*SIJK**2*RJK**2)+  
     > SIJKL*RJK1/(CIJKL*SJKL**2*RJK**2)+  
     > CJKL*SIJKL*RKL1/(CIJKL*SJKL**2*RJK*RKL)+  
     > (-RIJ3*RKL2-RJK3*RKL2+RIJ2*RKL3+RJK2*RKL3)/  
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*J-1)=-SIJKL*RIJ2/(CIJKL*SIJK**2*RIJ**2)+  
     > CIJK*SIJKL*(RIJ2-RJK2)/(CIJKL*SIJK**2*RIJ*RJK)-  
     > SIJKL*RJK2/(CIJKL*RJK**2)+SIJKL*RJK2/(CIJKL*SIJK**2*RJK**2)+  
     > SIJKL*RJK2/(CIJKL*SJKL**2*RJK**2)+  
     > CJKL*SIJKL*RKL2/(CIJKL*SJKL**2*RJK*RKL)+  
     > (RIJ3*RKL1+RJK3*RKL1-RIJ1*RKL3-RJK1*RKL3)/  
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*J)=-SIJKL*RIJ3/(CIJKL*SIJK**2*RIJ**2)+  
     > CIJK*SIJKL*(RIJ3-RJK3)/(CIJKL*SIJK**2*RIJ*RJK)-  
     > SIJKL*RJK3/(CIJKL*RJK**2)+SIJKL*RJK3/(CIJKL*SIJK**2*RJK**2)+  
     > SIJKL*RJK3/(CIJKL*SJKL**2*RJK**2)+  
     > (-RIJ2*RKL1-RJK2*RKL1+RIJ1*RKL2+RJK1*RKL2)/  
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)+  
     > CJKL*SIJKL*RKL3/(CIJKL*SJKL**2*RJK*RKL)
      BM(IROW,3*K-2)=-CIJK*SIJKL*RIJ1/(CIJKL*SIJK**2*RIJ*RJK)+  
     > SIJKL*RJK1/(CIJKL*RJK**2)-SIJKL*RJK1/(CIJKL*SIJK**2*RJK**2)-  
     > SIJKL*RJK1/(CIJKL*SJKL**2*RJK**2)+  
     > CJKL*SIJKL*(RJK1-RKL1)/(CIJKL*SJKL**2*RJK*RKL)+  
     > SIJKL*RKL1/(CIJKL*SJKL**2*RKL**2)+  
     > (RIJ3*RJK2-RIJ2*RJK3+RIJ3*RKL2-RIJ2*RKL3)/  
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*K-1)=-CIJK*SIJKL*RIJ2/(CIJKL*SIJK**2*RIJ*RJK)+  
     > SIJKL*RJK2/(CIJKL*RJK**2)-SIJKL*RJK2/(CIJKL*SIJK**2*RJK**2)-  
     > SIJKL*RJK2/(CIJKL*SJKL**2*RJK**2)+  
     > CJKL*SIJKL*(RJK2-RKL2)/(CIJKL*SJKL**2*RJK*RKL)+  
     > SIJKL*RKL2/(CIJKL*SJKL**2*RKL**2)+  
     > (-RIJ3*RJK1+RIJ1*RJK3-RIJ3*RKL1+RIJ1*RKL3)/  
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)
      BM(IROW,3*K)=-CIJK*SIJKL*RIJ3/(CIJKL*SIJK**2*RIJ*RJK)+  
     > SIJKL*RJK3/(CIJKL*RJK**2)-SIJKL*RJK3/(CIJKL*SIJK**2*RJK**2)-  
     > SIJKL*RJK3/(CIJKL*SJKL**2*RJK**2)+  
     > (RIJ2*RJK1-RIJ1*RJK2+RIJ2*RKL1-RIJ1*RKL2)/  
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)+  
     > CJKL*SIJKL*(RJK3-RKL3)/(CIJKL*SJKL**2*RJK*RKL)+  
     > SIJKL*RKL3/(CIJKL*SJKL**2*RKL**2)
      BM(IROW,3*L-2)=-CJKL*SIJKL*RJK1/(CIJKL*SJKL**2*RJK*RKL)+  
     > (-RIJ3*RJK2+RIJ2*RJK3)/(CIJKL*SIJK*SJKL*RIJ*RJK*RKL)-  
     > SIJKL*RKL1/(CIJKL*SJKL**2*RKL**2)
      BM(IROW,3*L-1)=-CJKL*SIJKL*RJK2/(CIJKL*SJKL**2*RJK*RKL)+  
     > (RIJ3*RJK1-RIJ1*RJK3)/(CIJKL*SIJK*SJKL*RIJ*RJK*RKL)-  
     > SIJKL*RKL2/(CIJKL*SJKL**2*RKL**2)
      BM(IROW,3*L)=(-RIJ2*RJK1+RIJ1*RJK2)/
     > (CIJKL*SIJK*SJKL*RIJ*RJK*RKL)-  
     > CJKL*SIJKL*RJK3/(CIJKL*SJKL**2*RJK*RKL)-  
     > SIJKL*RKL3/(CIJKL*SJKL**2*RKL**2)
   50 CONTINUE
C
C     B-matrix for linear bend  - added 09xxYC96
C
      DO 60 IJK=1,NLBE
      IROW=IROW+1
      I=ILBE(1,IJK)
      J=ILBE(2,IJK)
      K=ILBE(3,IJK) 
      RIJ=YDIST(I,J,X,Y,Z,NATOMS)
      RJK=YDIST(J,K,X,Y,Z,NATOMS)
C
C  remember C-A-B ==> K-J-I : cases of z-axis
C
C  choice #1 : Z axis is assigned as rjk
C
C      PZ(1)=X(K)-X(J)
C      PZ(2)=Y(K)-Y(J)
C      PZ(3)=Z(K)-Z(J)
C
C  choice #2 : Z axis is assigned as rij
C
C      PZ(1)=X(J)-X(I)
C      PZ(2)=Y(J)-Y(I)
C      PZ(3)=Z(J)-Z(I)
C
C  choice #3 : Z axis is assigned as rik
C
      PZ(1)=X(K)-X(I)
      PZ(2)=Y(K)-Y(I)
      PZ(3)=Z(K)-Z(I)
C
      IF (ABS(PZ(3)/RJK).NE.1) THEN
C
C     set up local coordinates
C
        V(1)=1.0d0
        V(2)=1.0d0
        V(3)=1.0d0
C
C     find PY perpendicular to PZ and V
C
        CALL YXPROD(V,PZ,PY)
C
C     find PX perpendicular to PY and PZ
C
        CALL YXPROD(PY,PZ,PX)
C
C     normalize
C
        PXMG=0.0d0
        PYMG=0.0d0
        DO IM=1,3
          PXMG=PXMG+PX(IM)*PX(IM)
          PYMG=PYMG+PY(IM)*PY(IM)
         ENDDO
        PXMG=SQRT(PXMG)
        PYMG=SQRT(PYMG)
        PZMG=RJK
C
C   set up transpose of transformation matrix
C
        DO IM=1,3
          T(1,IM)=PX(IM)/PXMG
          T(2,IM)=PY(IM)/PYMG
          T(3,IM)=PZ(IM)/PZMG
        ENDDO
      ELSE
        DO IM=1,3
          IF(PZ(3)/PZMG.LT.0) THEN
             T(IM,IM)=-1.0d0
          ELSE
             T(IM,IM)=1.0d0
          ENDIF
        ENDDO
      ENDIF
     
C
C   the Ry mode ; Califano + Mathematica
C
C   in Califano the molecule in C-A-B
C   here is                     K-J-I
C
      BMTE(1)= 1.0d0/RIJ 
      BMTE(2)= -(RIJ+RJK)/(RIJ*RJK)
      BMTE(3)= 1.0d0/RJK
C
C   transform back to the original coordinates
C     B = B'T(transpose)
C
      BM(IROW,3*I-2)=BMTE(1)*T(1,1)
      BM(IROW,3*I-1)=BMTE(1)*T(1,2)
      BM(IROW,3*I)  =BMTE(1)*T(1,3)
      BM(IROW,3*J-2)=BMTE(2)*T(1,1)
      BM(IROW,3*J-1)=BMTE(2)*T(1,2)
      BM(IROW,3*J)  =BMTE(2)*T(1,3)
      BM(IROW,3*K-2)=BMTE(3)*T(1,1)
      BM(IROW,3*K-1)=BMTE(3)*T(1,2)
      BM(IROW,3*K)  =BMTE(3)*T(1,3)
C
C   the Rx mode 
C
      IROW=IROW+1
      BM(IROW,3*I-2)=BMTE(1)*T(2,1)
      BM(IROW,3*I-1)=BMTE(1)*T(2,2)
      BM(IROW,3*I)  =BMTE(1)*T(2,3)
      BM(IROW,3*J-2)=BMTE(2)*T(2,1)
      BM(IROW,3*J-1)=BMTE(2)*T(2,2)
      BM(IROW,3*J)  =BMTE(2)*T(2,3)
      BM(IROW,3*K-2)=BMTE(3)*T(2,1)
      BM(IROW,3*K-1)=BMTE(3)*T(2,2)
      BM(IROW,3*K)  =BMTE(3)*T(2,3)
   60 CONTINUE
C
C     ALL DONE
C
      RETURN 
      END
C***********************************************************************
C     MCYLUDCMP
C***********************************************************************
C
      SUBROUTINE mcyludcmp(A,N,NP,INDX,D)
C
C     This is a slightly modified version of subroutine yludcmp in Tinkerate.
C     The modification consists in the fact that VV dimension is defined as
C     NP which is the same as MAXINT. It is not necessary to include the 
C     parameter include file. 
C     (Titus V Albu January 2002)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (TINY=1.0D-20)
      DIMENSION A(NP,NP),INDX(N),VV(NP)
      DATA ONE/1.0D00/,ZERO/0.0D00/
C
      D=ONE
      DO 12 I=1,N
        AAMAX=0.0D0
        DO 11 J=1,N
          IF (DABS(A(I,J)).GT.AAMAX) AAMAX=DABS(A(I,J))
11      CONTINUE
        IF (AAMAX.EQ.ZERO) THEN
           WRITE(6,*) 'SINGULAR MATRIX'
           STOP
        ENDIF
        VV(I)=ONE/AAMAX
12    CONTINUE
      DO 19 J=1,N
        IF (J.GT.1) THEN
          DO 14 I=1,J-1
            SUM=A(I,J)
            IF (I.GT.1)THEN
              DO 13 K=1,I-1
                SUM=SUM-A(I,K)*A(K,J)
13            CONTINUE
              A(I,J)=SUM
            ENDIF
14        CONTINUE
        ENDIF
        AAMAX=ZERO
        DO 16 I=J,N
          SUM=A(I,J)
          IF (J.GT.1)THEN
            DO 15 K=1,J-1
              SUM=SUM-A(I,K)*A(K,J)
15          CONTINUE
            A(I,J)=SUM
          ENDIF
          DUM=VV(I)*DABS(SUM)
          IF (DUM.GE.AAMAX) THEN
            IMAX=I
            AAMAX=DUM
          ENDIF
16      CONTINUE
        IF (J.NE.IMAX)THEN
          DO 17 K=1,N
            DUM=A(IMAX,K)
            A(IMAX,K)=A(J,K)
            A(J,K)=DUM
17        CONTINUE
          D=-D
          VV(IMAX)=VV(J)
        ENDIF
        INDX(J)=IMAX
        IF(J.NE.N)THEN
          IF(A(J,J).EQ.ZERO)A(J,J)=TINY
          DUM=1.0D0/A(J,J)
          DO 18 I=J+1,N
            A(I,J)=A(I,J)*DUM
18        CONTINUE
        ENDIF
19    CONTINUE
      IF(A(N,N).EQ.ZERO)A(N,N)=TINY
      RETURN
      END
C***********************************************************************
C     MCYMATINV
C***********************************************************************
C
      SUBROUTINE mcymatinv(A,N,NP,INDX,Y)
C
C     This is a slightly modified version of subroutine ymatinv in Tinkerate.
C     The modification consists in changing the call to mcyludcmp instead of
C     yludcmp. 
C     (Titus V Albu January 2002)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION A(NP,NP),Y(NP,NP), INDX(NP)
      DATA ONE/1.0D00/,ZERO/0.0D00/
C
        DO 10 I=1,N
                DO 11 J=1,N
                    Y(I,J)=ZERO
11              CONTINUE
           Y(I,I)=ONE
10      CONTINUE
        CALL MCYLUDCMP(A,N,NP,INDX,D)
        DO 13 J=1,NP
          CALL YLUBKSB(A,N,NP,INDX,Y(1,J))
13      CONTINUE
      RETURN
      END
