      SUBROUTINE GEN_REDNINTRNLS(CARTCOORD, REDUNCO, INTLABEL,
     &                           IBNDTO, BMATRX, GMATRX,
     &                           TOTREDNCO, IATOMICNMBER, NRATMS,
     &                           IREDUNCO, TOTNOFBND, TOTNOFANG, 
     &                           TOTNOFDIH, BTGMIN, EIGVECTORS)
C
C Generate the famous B matrix (Molecular vibrations, Wilson, Decius 
C and Cross)  that transform the difference Cartesian corrdiantes to 
C the rectilinear nternal coordinates (the curvelinear and rectilinear 
C are identical for small displacements. The transformations matix is
C generated by using the formuals given in Pariseau et al. JCP, 2335, 
C 1965 and a good description of rec. and curv. coordinates can be 
C found in Hoy et al.. Molecular Physics, 1266, 1972.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C MXATMS     : Maximum number of atoms currently allowed
C MAXCNTVS   : Maximum number of connectivites per center
C MAXREDUNCO : Maximum number of redundant coordinates.
C
      INTEGER MXATMS, MAXCNTVS, MAXREDUNCO
      PARAMETER (MXATMS=200, MAXCNTVS = 10, MAXREDUNCO = 3*MXATMS)
c io_units.par : begin

      integer    LuOut
      parameter (LuOut = 6)

      integer    LuErr
      parameter (LuErr = 6)

      integer    LuBasL
      parameter (LuBasL = 1)
      character*(*) BasFil
      parameter    (BasFil = 'BASINF')

      integer    LuVMol
      parameter (LuVMol = 3)
      character*(*) MolFil
      parameter    (MolFil = 'MOL')
      integer    LuAbi
      parameter (LuAbi = 3)
      character*(*) AbiFil
      parameter    (AbiFil = 'INP')
      integer    LuCad
      parameter (LuCad = 3)
      character*(*) CadFil
      parameter    (CadFil = 'CAD')

      integer    LuZ
      parameter (LuZ = 4)
      character*(*) ZFil
      parameter    (ZFil = 'ZMAT')

      integer    LuGrd
      parameter (LuGrd = 7)
      character*(*) GrdFil
      parameter    (GrdFil = 'GRD')

      integer    LuHsn
      parameter (LuHsn = 8)
      character*(*) HsnFil
      parameter    (HsnFil = 'FCM')

      integer    LuFrq
      parameter (LuFrq = 78)
      character*(*) FrqFil
      parameter    (FrqFil = 'FRQARC')

      integer    LuDone
      parameter (LuDone = 80)
      character*(*) DonFil
      parameter    (DonFil = 'JODADONE')

      integer    LuNucD
      parameter (LuNucD = 81)
      character*(*) NDFil
      parameter    (NDFil = 'NUCDIP')

      integer LuFiles
      parameter (LuFiles = 90)

c io_units.par : end
C 
      PARAMETER(THRESHOLD = 5.0D00, EPSILON = 1.0D-10)
C
      INTEGER TOTREDNCO, TOTNOFBND, TOTNOFANG, TOTNOFDIH,
     &        FRAGSCR
      CHARACTER*4 INTLABEL(MAXREDUNCO)
C
C The following arrays need to be managed dynamically:
C
C BNDLENGTHS: Keep the bond lengths of atom pairs. It is
C             of length MXATMS*MXATMS
C IATOMICNMBER: Keep the atomic numbers of all atoms and
C               it is MAXATMS long.
C SMOFCOVRAD: The sum of covalent radius of pairs of atoms
C             and of MXATMS*MXATMS long.
C NCONPRCNTR: The number of connectivities for an atom. The
C             maximum number is set to 10, so this is a
C             rather small (it is not currently being
C             used, but needs in the future).
      DIMENSION CARTCOORD(3*MXATMS), BNDLENTHS(MXATMS, MXATMS), 
     &          IATOMICNMBER(MXATMS), SMOFCOVRADI(MXATMS, MXATMS),
     &          IBNDTO(MXATMS*MXATMS), NCONPRCNTR(MXATMS),
     &          IREDUNCO(4, MAXREDUNCO), BMATRX(9*MXATMS*MXATMS),
     &          GMATRX(9*MXATMS*MXATMS), REDUNCO(MAXREDUNCO),
     &          MARK_FRAGMENTS(MXATMS, MXATMS),
     &          LENGTH_FRAGMENTS(MXATMS),FRAGSCR(MXATMS*MXATMS)
      DIMENSION EIGVECTORS(MAXREDUNCO, MAXREDUNCO),
     &          BTGMIN(3*NRATMS,MAXREDUNCO),BLNGT_IJFRGS(MXATMS)
c ric_heap.com : begin

c This common block contains the heap address and array indices for
c processing RICs. New additions must be initialized to 1 in
c bd_ric_heap.F and set in init_ric_heap.F.

      external bd_ric_heap

      double precision dRICHeap(1)
      integer          z_RICHeap, z_DerBMat, z_BMat, z_GMat, z_BTGInv

      common /ric_heap_com/ dRICHeap,
     &                      z_RICHeap, z_DerBMat, z_BMat, z_GMat,
     &                      z_BTGInv
      save   /ric_heap_com/

c ric_heap.com : end
C      
      DATA  IZERO /0/
C
      TOTREDNCO = IZERO
C
C Assign Connectivities: We need this to proceed! At this point this is 
C some what experimental. We need to improve this to include hydrogen 
C bonds, dimer bonds and so on. This should be improved as we gain 
C more experience with this stuff.
C     
      Print*, "Entering assign connectivities"
      CALL ASIGN_CNTVTES(CARTCOORD, BNDLENTHS, IATOMICNMBER, 
     &                   SMOFCOVRADI, NCONPRCNTR, IBNDTO, MAXCNTVS,
     &                   NRATMS, MARK_FRAGMENTS, LENGTH_FRAGMENTS,
     &                   FRAGSCR, BLNGT_IJFRGS)
C 
C Assign bond length Coordinates.
C
      Print*, "Entering assign bonds"
      Write(6,*)

      CALL ASSIGN_BONDS(IBNDTO, IREDUNCO, TOTREDNCO, TOTNOFBND, NRATMS,
     &                  MAXREDUNCO)
C
C Assign bond angle Coordinates.
C
      Print*, "Entering assign angles"
      Print*, "Total # of bonds:", TOTNOFBND

      CALL ASSIGN_ANGLS(CARTCOORD, IBNDTO, IREDUNCO, TOTREDNCO,
     &                  TOTNOFBND, TOTNOFANG, NRATMS, MAXREDUNCO,
     &                  THRESHOLD)
C
C Assign bond dihedral angle Coordinates.
C
      Print*, "Entering assign dihedral angles"
      Print*, "Total # of Angles:", TOTNOFANG 

      CALL ASSIGN_DIHLS(IBNDTO, IREDUNCO, TOTREDNCO, TOTNOFBND,
     &                  TOTNOFANG, NRATMS, TOTNOFDIH, MAXREDUNCO)
C
C Assign dihedral angles for nearly planar structures.
C
C
C Assign Label for redundent internal coordinates.
C
      Write(6,*)
      Print*, "Entering assign lables"
      Print*, "Total # of dihedrals:", TOTNOFDIH 
      Print*, "The total redundent internal", TOTREDNCO 

      CALL ASSIGN_LABELS(IREDUNCO, TOTREDNCO, TOTNOFBND, TOTNOFANG,
     &                   TOTNOFDIH, INTLABEL)
      Print*, "The redundent internal coordinates assignments"
      Write(6,*)
      Do i = 1, TOTREDNCO
         Write(6,111) (iredunco(j, i), j=1, 4)
      Enddo
 111  Format(5X, 4(I3, 1X))

C
C Make sure the number of RICs has not increased.
C
      CALL GETREC(0,'JOBARC','REDNCORD',ITMP,0)
      IF (ITMP.GE.0) THEN
         CALL GETREC(1,'JOBARC','REDNCORD',1,ITMP)
         IF (ITMP.LT.TOTREDNCO) THEN
            WRITE(*,*) '@GEN_REDNINTRNLS: The number of internal ',
     &                 'coordinates has increased.'
            WRITE(*,*) '                  At the very least, this ',
     &                 'system has become unstable.'
            CALL ERREX
         END IF
      END IF
C
C Now built the B and G matrices.
C
      Write(6,*)
      Print*, "Entering B and G matrix generation"
      Write(6,*)
      CALL BUILT_BGMTRX(CARTCOORD, REDUNCO, IREDUNCO, TOTREDNCO,
     &                  TOTNOFBND, TOTNOFANG, TOTNOFDIH, 
     &                  NRATMS, BMATRX, GMATRX, 
     &                  EIGVECTORS,EPSILON,BTGMIN,dRICHeap(z_DerBMat))
      Write(6,*) 
      Print*, "The redundent internal coordinates:"
      write(6,*)
      Write(6, 9) (redunco(i), I=1, TOTREDNCO)
  9   Format (5(1X,F10.6))

C
C some labels for internal coords...
C   
CSSS      CALL OUTPUT(BMATRX, 1, TOTREDNCO, 1, 3*NRATMS, TOTREDNCO, 
CSSS     &            3*NRATMS, 1)
C
      RETURN
      END

