c***********************************************************************
c     mccene
c***********************************************************************
c
      subroutine mccene(e1,e2,e12,v,icomplex)         
c
c     This subroutine combine the three terms in a MCMM energy
c     calculation and returns the MCMM energy. It is a duplicate
c     of subroutine cevben in Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      if (icomplex.eq.0) then
        v=0.5D0*((e1+e2)-dsqrt((e1-e2)**2.d0+4.d0*e12**2.d0))
        goto 1000
      else
        ee=(e1-e2)**2.d0
        ee1=4.d0*e12
c        delta=0.0000001d0
c         delta=25.d0
      if (e12.lt.0.d0) then
         if (abs(ee1).GE.ee) then
           beta=ee/(4.d0*abs(e12))
           rt=ee+4.d0*e12*beta
            if (rt.lt.10e-5) then
            rt=0.d0
            endif
           v=0.5D0*((e1+e2)-dsqrt(rt))
           goto 1000
         endif
         v=0.5D0*((e1+e2)-dsqrt(ee+4.d0*e12))
      else
          v=0.5D0*((e1+e2)-dsqrt(ee+4.d0*e12))
      endif
c
      endif
1000      return
c      write (*,*) "MCCENE2:e1,e2,e12,v",e1,e2,e12,v,icomplex
      end
C
c***********************************************************************
c     mccene
c***********************************************************************
c
      subroutine mccene3(e1,e2,e12,v,icomplex)         
c
c     This subroutine combine the three terms in a MCMM energy
c     calculation and returns the MCMM energy. It is a duplicate
c     of subroutine cevben in Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      if (icomplex.eq.0) then
        v=0.5D0*((e1+e2)-dsqrt((e1-e2)**2.d0+4.d0*e12**2.d0))
c        write (*,*) "YY",e12,icomplex
        goto 1000
      else
      ee=(e1-e2)**2.d0
      ee1=4.d0*e12
        delta=0.0000001d0
      if (e12.lt.0.d0) then
        if (ee.LT.abs(ee1)) then
          beta=0.d0
        else
          beta=dexp(-abs(e12)*delta/ee)
        endif
         v=0.5D0*((e1+e2)-dsqrt(ee+4.d0*e12*beta))
      else
           beta=1.d0
c          beta=dexp(-abs(e12)*delta/ee)
          v=0.5D0*((e1+e2)-dsqrt(ee+4.d0*e12))
      endif
c      write (*,*) 'mcene:beta:', beta,icomplex
c      write (*,*) "MCCENE:e1,e2,e12,v",e1,e2,e12,v
c
      endif
1000      return
      end
C
c***********************************************************************
c     mccgra
c***********************************************************************
c
      subroutine mccgra(e1,e2,e12,g1,g2,g12,dxii,mcmcar,icomplex)         
c
c     This subroutine combine the three terms in MCMM gradients
c     calculation and returns the MCMM gradients. It is a modification
c     of subroutine cevbgr in Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension dxii(mcmcar), dbeta2dx(mcmcar)
      dimension g1(mcmcar), g2(mcmcar), g12(mcmcar)
c
c zero out the gradients
c
c
      do i=1,mcmcar
        dxii(i)=0.d0
        dbeta2dx(i)=0.d0
      enddo
      sum1=0.d0
      dif1=0.d0
      fctor2=0.d0
      fctor1=0.d0
c
c If e12=0, then take dxii as the g1 (if e1<e2) or g2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, dxii is the
c gradient calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (e12.eq.0.d0) then                                            
         if (e1.lt.e2) then
            do i=1,mcmcar
              dxii(i)=g1(i)
            enddo
         else if (e2.lt.e1) then
            do i=1,mcmcar
              dxii(i)=g2(i)
            enddo
c
c If e12=0 and e1=e2 (which I think is impossible, unless the calculation
c is completely screwed up) dxii is the sum of the two gradients, g1 and g2
c
         else
            do i=1,mcmcar
c              dxii(i)=g2(i)+g1(i)
c 1028HL03s
c I think it is the averaged value rather than the sum                  1201HL03
              dxii(i)=g2(i)*0.5d0+g1(i)*0.5d0                           1201HL03
c 1028HL03e
            enddo          
         endif
      else    
               if (icomplex.eq.0) then                        
c
c If e12 is not 0, calculate dxii using the MCMM formula
c
         fctor1=dsqrt((e1-e2)**2.D0+4.d0*e12**2.D0)
c
         do i=1,mcmcar
            sum1=g1(i)+g2(i)
            dif1=g1(i)-g2(i)
            fctor2=(e1-e2)*dif1+4.d0*e12*g12(i) 
c
c calculate the gradient 
c
            dxii(i)=0.5d0*(sum1-fctor2/fctor1)
         enddo
c      endif
        goto 1000
              else
c
c        delta=0.0000001d0
        ee1=4.d0*e12
        diffe=e1-e2
        diffes=diffe**2.0
      if (e12.lt.0.d0) then
        if (abs(ee1).GE.diffes) then
          do i=1,mcmcar
          dxii(i)=0.5d0*(g1(i)+g2(i))
          enddo
          goto 1000
        else
         fctor1=dsqrt(diffes+4.d0*e12)
         do i=1,mcmcar
            sum1=g1(i)+g2(i)
            dif1=g1(i)-g2(i)
         fctor2=(e1-e2)*dif1+2.d0*g12(i)
         dxii(i)=0.5d0*(sum1-fctor2/fctor1)
         enddo
         goto 1000
        endif
       else
         fctor1=dsqrt(diffes+4.d0*e12)
         do i=1,mcmcar
            sum1=g1(i)+g2(i)
            dif1=g1(i)-g2(i)
cc            fctor2=(e1-e2)*dif1+4.d0*e12*g12(i)
              fctor2=(e1-e2)*dif1+2.d0*g12(i)
            dxii(i)=0.5d0*(sum1-fctor2/fctor1)
         enddo
c          
       endif
       endif
       endif
c
1000      return
      end
c***********************************************************************
c     mccgra(old)
c***********************************************************************
c
      subroutine mccgraHerm(e1,e2,e12,g1,g2,g12,dxii,mcmcar)         
c
c     This subroutine combine the three terms in MCMM gradients
c     calculation and returns the MCMM gradients. It is a modification
c     of subroutine cevbgr in Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension dxii(mcmcar)
      dimension g1(mcmcar), g2(mcmcar), g12(mcmcar)
c
c zero out the gradients
c
      do i=1,mcmcar
        dxii(i)=0.d0
      enddo
      sum1=0.d0
      dif1=0.d0
      fctor2=0.d0
      fctor1=0.d0
c
c      do i=1,12
c      write (*,*) "Three gradients:",g1(i),g2(i),g12(i)
c      enddo
c 
c If e12=0, then take dxii as the g1 (if e1<e2) or g2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, dxii is the
c gradient calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (e12.eq.0.d0) then                                            
         if (e1.lt.e2) then
            do i=1,mcmcar
              dxii(i)=g1(i)
            enddo
         else if (e2.lt.e1) then
            do i=1,mcmcar
              dxii(i)=g2(i)
            enddo
c
c If e12=0 and e1=e2 (which I think is impossible, unless the calculation
c is completely screwed up) dxii is the sum of the two gradients, g1 and g2
c
         else
            do i=1,mcmcar
c              dxii(i)=g2(i)+g1(i)
c 1028HL03s
c I think it is the averaged value rather than the sum                  1201HL03
              dxii(i)=g2(i)*0.5d0+g1(i)*0.5d0                           1201HL03
c 1028HL03e
            enddo          
         endif
      else                            
c
c If e12 is not 0, calculate dxii using the MCMM formula
c
cc         fctor1=dsqrt((e1-e2)**2.D0+4.d0*e12**2.D0)
c
cccc       if (e12.gt.0.d0) then
         fctor1=dsqrt((e1-e2)**2.D0+4.d0*e12)
c
         do i=1,mcmcar
            sum1=g1(i)+g2(i)
            dif1=g1(i)-g2(i)
cc            fctor2=(e1-e2)*dif1+4.d0*e12*g12(i) 
              fctor2=(e1-e2)*dif1+2.d0*g12(i)
c
c calculate the gradient
c
            dxii(i)=0.5d0*(sum1-fctor2/fctor1)
         enddo
c
cccc        else if (e12.lt.0.d0) then
cccc         fctor1=dsqrt((e1-e2)**2.D0-4.d0*e12)
c
cccc        do i=1,mcmcar
cccc            sum1=g1(i)+g2(i)
cccc            dif1=g1(i)-g2(i)
cccc             fctor2=(e1-e2)*dif1-2.d0*g12(i)
c
c calculate the gradient 
c
            dxii(i)=0.5d0*(sum1-fctor2/fctor1)
cccc         enddo
cccc        endif
      endif
c
      return
      end
c***********************************************************************
c     mcches
c***********************************************************************
c
      subroutine mcches(e1,e2,e12,g1,g2,g12,h1,h2,h12,fmat,mcmcar,
     * icomplex)
c
c     This subroutine combine the three terms in MCMM hessian
c     calculation and returns the MCMM Hessian. It is a modification
c     of subroutine cevbhs in Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension g1(mcmcar), g2(mcmcar), g12(mcmcar)
      dimension h1(mcmcar,mcmcar), h2(mcmcar,mcmcar)
      dimension h12(mcmcar,mcmcar)
      dimension fmat(mcmcar,mcmcar)
c
c zero out the hessian
c
      do i=1,mcmcar
        do j=1,mcmcar
          fmat(i,j)=0.d0
        enddo
      enddo 
c
c      do i=1,12
c        do j=1,12
c         write (*,*) "Three Hessians",h1(i,j),h2(i,j),h12(i,j)
c        enddo
c      enddo
c
c If e12=0, then take the hessian as the h1 (if e1<e2) or h2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, the hessian is 
c the one calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (e12.eq.0.d0) then                         
         if (e1.lt.e2) then
            do i=1,mcmcar
              do j=1,mcmcar
                 fmat(i,j)=h1(i,j)
              enddo
           enddo            
         else if (e2.lt.e1) then
            do i=1,mcmcar
              do j=1,mcmcar
                fmat(i,j)=h2(i,j)
              enddo
            enddo
         else
c
c although unlikely, just in case e1 = e2 and e12=0 , fmat=h1+h2
c
            do i=1,mcmcar
               do j=1,mcmcar
c                 fmat(i,j)=h2(i,j)+h1(i,j)
c 1028HL03s    
c I think it is the averaged value rather than the sum                  1201HL03
                 fmat(i,j)=h2(i,j)*0.5d0+h1(i,j)*0.5d0                  1201HL03
c 1028HL03e
               enddo
            enddo                   
         endif
      else
c
        if (icomplex.eq.0) then
c
         dife=e1-e2
         fctor1=dsqrt(dife**2.D0+4.d0*e12**2.D0)
c
         do i=1,mcmcar
           sumgi=g1(i)+g2(i)
           difgi=g1(i)-g2(i)
           fctor2=(e1-e2)*difgi+4.d0*e12*g12(i) 
           do j=1,mcmcar
              sumgj=g1(j)+g2(j)
              difgj=g1(j)-g2(j)
              sumh=h1(i,j)+h2(i,j)
              difh=h1(i,j)-h2(i,j)
              fmat(i,j)=
     &                 0.5d0*(sumh+
     &              fctor2*(dife*difgj+4.d0*g12(j)*e12)/(fctor1**3.d0)
     &                 -(difgi*difgj+dife*difh
     &                 +4.d0*(g12(i)*g12(j)+e12*h12(i,j)))/fctor1)
           enddo
         enddo
c      endif
        goto 1000
        else
c
        ee1=4.d0*e12
        diffe=e1-e2
        diffes=diffe**2.0d0
        diffec=diffe**3.0d0
      if (e12.lt.0.d0.and.diffes.LT.abs(ee1)) then
c
         do i=1,mcmcar
           sumgi=g1(i)+g2(i)
           difgi=g1(i)-g2(i)
c           fctor2=2.d0*(2.d0*u*g12(i)+
c     &     2.d0*u*e12*(-delta*g12(i)/diffes+
c     &     2.d0*delta*e12*difgi/diffec)+diffe*difgi)
           do j=1,mcmcar
              sumgj=g1(j)+g2(j)
              difgj=g1(j)-g2(j)
              sumh=h1(i,j)+h2(i,j)
              difh=h1(i,j)-h2(i,j)
c              fmat(i,j)=
c     &     0.5d0*(sumh+fctor2*(4.d0*u*g12(j)+
c     &      4.d0*u*e12*(-delta*g12(j)/diffes+
c     &      2.d0*delta*e12*difgj/diffec)+
c     &      2.d0*diffe*difgj)
c     &     /(4.d0*(fctor1**3.d0))
c     &     -(4.d0*u*g12(i)*(-delta*g12(j)/diffes+
c     &     2.d0*delta*e12*difgj/diffe**3.d0)+
c     &     4.d0*u*g12(j)*(-delta*g12(i)/diffes+
c     &     2.d0*delta*e12*difgi/diffec)
c     &     +4.d0*u*e12*(-delta*g12(j)/diffes+
c     &     2.d0*delta*e12*difgj/diffec)*
c     &                 (-delta*g12(i)/diffes+
c     &     2.d0*delta*e12*difgi/diffec)
c     &     +2.d0*difgi*difgj+4.d0*u*h12(i,j)+
c     &     4.d0*u*e12*(2.d0*delta*g12(i)*difgj/diffe**3.d0+
c     &     2.d0*delta*g12(j)*difgi/diffec
c     &     -6.d0*delta*e12*difgi*difgj/diffe**4.d0-
c     &     delta*h12(i,j)/diffes+
c     &     2.d0*delta*e12*difh/diffec)
c     &     +2.d0*diffe*difh)/(2.d0*fctor1))
              fmat(i,j)=0.5d0*sumh
           enddo
         enddo
         goto 1000
        else
         dife=e1-e2
         diffes=dife**2.d0
         fctor1=dsqrt(diffes+4.d0*e12)
c
         do i=1,mcmcar
           sumgi=g1(i)+g2(i)
           difgi=g1(i)-g2(i)
           fctor2=(e1-e2)*difgi+2.d0*g12(i)
           do j=1,mcmcar
cc              sumgj=g1(j)+g2(j)
cc             difgj=g1(j)-g2(j)
cc              sumh=h1(i,j)+h2(i,j)
cc              difh=h1(i,j)-h2(i,j)
cc              fmat(i,j)=
cc     &                 0.5d0*(sumh+
cc     &                 fctor2*(dife*difgj+4.d0*g12(j)*e12)/fctor1**3.d0
cc     &                 -(difgi*difgj+dife*difh
cc     &                 +4.d0*(g12(i)*g12(j)+e12*h12(i,j)))/fctor1)
              sumgj=g1(j)+g2(j)
              difgj=g1(j)-g2(j)
              sumh=h1(i,j)+h2(i,j)
              difh=h1(i,j)-h2(i,j)
              fmat(i,j)=
     &                 0.5d0*(sumh+fctor2*(dife*difgj+
     &                 2.d0*g12(j))/(fctor1**3.d0)
     &                 -(difgi*difgj+dife*difh
     &                 +2.d0*h12(i,j))/fctor1)
           enddo
         enddo
c                   u=dexp(-abs(e12)*delta/diffes)
c         fctor1=dsqrt(diffe**2.D0+4.d0*e12*u)
c
c         do i=1,mcmcar
c           sumgi=g1(i)+g2(i)
c           difgi=g1(i)-g2(i)
c           fctor2=2.d0*(u*g12(i)+u*e12*(-delta*g12(i)/diffe**2.d0+
c     &     2.d0*delta*e12*difgi/diffe**3.d0)+diffe*difgi)
c           do j=1,mcmcar
c              sumgj=g1(j)+g2(j)
c              difgj=g1(j)-g2(j)
c              sumh=h1(i,j)+h2(i,j)
c              difh=h1(i,j)-h2(i,j)
c              fmat(i,j)=
c     &     0.5d0*(sumh+fctor2*(2.d0*(u*g12(j)+
c     &     u*e12*(-delta*g12(j)/diffe**2.d0+
c     &     2.d0*delta*e12*difgj/diffe**3.d0)+diffe*difgj))
c     &     /(2.d0*(fctor1**3.d0))
c     &     -(4.d0*u*g12(i)*(-delta*g12(i)/diffe**2.d0+
c     &     2.d0*delta*e12*difgi/diffe**3.d0)
c     &     +2.d0*u*e12*(-delta*g12(i)/diffe**2.d0+
c     &     2.d0*delta*e12*difgi/diffe**3.d0)*
c     &                 (-delta*g12(j)/diffe**2.d0+
c     &     2.d0*delta*e12*difgj/diffe**3.d0)
c     &     +difgi*difgj+2.d0*u*h12(i,j)+
c     &     2.d0*u*e12*(4.d0*delta*g12(j)*difgj/diffe**3.d0
c     &     -6.d0*delta*e12*difgi*difgj/diffe**4.d0-
c     &     delta*h12(i,j)/diffe**2.d0+2.d0*delta*e12*difh/diffe**3.d0)
c     &     +diffe*difh)/fctor1)
c           enddo
c         enddo
      endif
      endif
      endif
c          
1000  return
      end
c***********************************************************************
c     mcches(old)
c***********************************************************************
c
      subroutine mcchesHerm(e1,e2,e12,g1,g2,g12,h1,h2,h12,fmat,mcmcar)
c
c     This subroutine combine the three terms in MCMM hessian
c     calculation and returns the MCMM Hessian. It is a modification
c     of subroutine cevbhs in Tinkerate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension g1(mcmcar), g2(mcmcar), g12(mcmcar)
      dimension h1(mcmcar,mcmcar), h2(mcmcar,mcmcar)
      dimension h12(mcmcar,mcmcar)
      dimension fmat(mcmcar,mcmcar)
c
c zero out the hessian
c
      do i=1,mcmcar
        do j=1,mcmcar
          fmat(i,j)=0.d0
        enddo
      enddo 
c      do i=1,12
c        do j=1,12
c         write (*,*) "Three Hessians",h1(i,j),h2(i,j),h12(i,j)
c        enddo
c      enddo
c
c If e12=0, then take the hessian as the h1 (if e1<e2) or h2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, the hessian is 
c the one calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (e12.eq.0.d0) then                         
         if (e1.lt.e2) then
            do i=1,mcmcar
              do j=1,mcmcar
                 fmat(i,j)=h1(i,j)
              enddo
           enddo            
         else if (e2.lt.e1) then
            do i=1,mcmcar
              do j=1,mcmcar
                fmat(i,j)=h2(i,j)
              enddo
            enddo
         else
c
c although unlikely, just in case e1 = e2 and e12=0 , fmat=h1+h2
c
            do i=1,mcmcar
               do j=1,mcmcar
c                 fmat(i,j)=h2(i,j)+h1(i,j)
c 1028HL03s    
c I think it is the averaged value rather than the sum                  1201HL03
                 fmat(i,j)=h2(i,j)*0.5d0+h1(i,j)*0.5d0                  1201HL03
c 1028HL03e
               enddo
            enddo                   
         endif
      else
c
c If e12 is not 0, calculate the hessian using the MCMM formula
c
         dife=e1-e2
cc         fctor1=dsqrt(dife**2.D0+4.d0*e12**2.D0)
         fctor1=dsqrt(dife**2.D0+4.d0*abs(e12))
c
         do i=1,mcmcar
           sumgi=g1(i)+g2(i)
           difgi=g1(i)-g2(i)
         if (e12.gt.0.d0) then
           fctor2=2.d0*(e1-e2)*difgi+4.d0*g12(i)
         else if (e12.lt.0.d0) then
           fctor2=2.d0*(e1-e2)*difgi-4.d0*g12(i)
         endif
           do j=1,mcmcar
cc              sumgj=g1(j)+g2(j)
cc             difgj=g1(j)-g2(j)
cc              sumh=h1(i,j)+h2(i,j)
cc              difh=h1(i,j)-h2(i,j)
cc              fmat(i,j)=
cc     &                 0.5d0*(sumh+
cc     &                 fctor2*(dife*difgj+4.d0*g12(j)*e12)/fctor1**3.d0
cc     &                 -(difgi*difgj+dife*difh
cc     &                 +4.d0*(g12(i)*g12(j)+e12*h12(i,j)))/fctor1)
              sumgj=g1(j)+g2(j)
              difgj=g1(j)-g2(j)
              sumh=h1(i,j)+h2(i,j)
              difh=h1(i,j)-h2(i,j)
         if (e12.gt.0.d0) then
              fmat(i,j)=
     &                 0.5d0*(sumh+fctor2*(2.d0*dife*difgj+
     &                 4.d0*g12(j))/(4.d0*(fctor1**3.d0))
     &                 -(difgi*difgj+dife*difh
     &                 +2.d0*h12(i,j))/fctor1)
         else if (e12.lt.0.d0) then
              fmat(i,j)=
     &                 0.5d0*(sumh+fctor2*(2.d0*dife*difgj-
     &                 4.d0*g12(j))/(4.d0*(fctor1**3.d0))
     &                 -(difgi*difgj+dife*difh
     &                 -2.d0*h12(i,j))/fctor1)
         endif
           enddo
         enddo
      endif
c          
      return
      end
c ************************************************************************
c     mcpgst
c ************************************************************************
c
      subroutine mcpgst(iunitp,zpr,mcn,mcm)
c
c     Subroutine to print out the an array of values in a style similar to
c     the one in a gaussian formatted checkpoint file.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension zpr(mcm)
c
      imcn = int(mcn/5)
      jmcn = mod(mcn,5)
c
c  Print the array zpr in multiples of five.
c
      do i=1,imcn
         write(iunitp,1000) (zpr(i*5-j),j=4,0,-1)
      enddo
c
      if (jmcn.eq.1) then
         write(iunitp,1100) zpr(imcn*5+1)
      else if (jmcn.eq.2) then
         write(iunitp,1200) (zpr(imcn*5+j),j=1,2)
      else if (jmcn.eq.3) then
         write(iunitp,1300) (zpr(imcn*5+j),j=1,3)
      else if (jmcn.eq.4) then
         write(iunitp,1400) (zpr(imcn*5+j),j=1,4)
      endif
c
 1000 format (5(1PE16.8))
 1100 format (1PE16.8)
 1200 format (2(1PE16.8))
 1300 format (3(1PE16.8))
 1400 format (4(1PE16.8))
c
c
      return
      end
c***********************************************************************
c     mcpici
c***********************************************************************
c
      subroutine mcpici(iunitp,mcndi,mcnan,mcnad,mcnda,
     *                         mcidi,mcian,mciad,mcida,mcmic,q)
c
c     This subroutine prints out the internal coordinates information.
c     The order in which the internal coordinates are printed should be 
c     the same as the order in which they are calculated and stored in
c     the appropriate arrays: distences, then angles, then dihedrals, 
c     then one set of degenerate angles, then the other one. this is done
c     in subroutine mctcic.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension mcidi(2,mcmic),mcian(3,mcmic)
      dimension mciad(3,mcmic),mcida(4,mcmic)
      dimension q(mcmic)
c
c     Print the information
c
      if (mcndi.ne.0) then
         do j = 1,mcndi
            write (iunitp,1000) j,mcidi(1,j),mcidi(2,j),q(j)
         enddo
      endif
      if (mcnan.ne.0) then
         do j = 1,mcnan
            write (iunitp,2000) j+mcndi,mcian(1,j),mcian(2,j),
     *                          mcian(3,j),q(j+mcndi)
         enddo
      endif
      if (mcnda.ne.0) then
         do j = 1,mcnda
            write (iunitp,3000) j+mcndi+mcnan,mcida(1,j),
     *                          mcida(2,j),mcida(3,j),
     *                          mcida(4,j),q(j+mcndi+mcnan)
         enddo
      endif
      if (mcnad.ne.0) then
         do j = 1,mcnad
            write (iunitp,4000) j+mcndi+mcnan+mcnda,
     *                          mciad(1,j),mciad(2,j),mciad(3,j),
     *                          q(j+mcndi+mcnan+mcnda)
         enddo
         do j = 1,mcnad
            write (iunitp,4000) j+mcndi+mcnan+mcnda+mcnad,
     *                          mciad(1,j),mciad(2,j),mciad(3,j),
     *                          q(j+mcndi+mcnan+mcnda+mcnad)
         enddo
      endif
c
 1000 format (2x,i4,')     Distance     between ',
     *           i5,1x,i5,13x,': ',f11.7,'  bohrs')
 2000 format (2x,i4,')      Angle       between ',
     *           i5,1x,i5,1x,i5,7x,': ',f11.7,' radians')
 3000 format (2x,i4,')  Dihedral angle  between ',
     *           i5,1x,i5,1x,i5,1x,i5,1x,': ',f11.7,' radians')
 4000 format (2x,i4,') Degenerate angle between ',
     *           i5,1x,i5,1x,i5,7x,': ',f11.7,' radians')
c
      return
      end
c***********************************************************************
c     mcpthd
c***********************************************************************
c
      subroutine mcpthd(iunitp)
c
c     prints out the program header to unit iunitp
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      write (iunitp,1000)
      write (iunitp,1100)
      write (iunitp,2000)
      write (iunitp,1000)
      write (iunitp,3000)
      write (iunitp,4000)
      write (iunitp,1000)
c
      return
c
 1000 format (80(1H*))
 1100 format (/20X,'MCSI version 2010-1 (October, 2010)')
c
 2000 format (/1X,'Osanna Tishchenko, Masahiro Higashi, ',
     *            'Titus V. Albu, Jose C. Corchado, Yongho Kim,',
     *        /1X,'Jordi Villa, Jianhua Xing, Hai Lin, ',
     *            'and Donald G. Truhlar',
     *        /1X,'Department of Chemistry and ',
     *            'Supercomputer Institute',
     *        /1X,'University of Minnesota, Minneapolis, ',
     *            'MN 55455-0431',/)
c
 3000 format (/1X,'MCSI is using TINKER-version 3.5mn3, which ',
     *            'is a modified version of ',
     *        /1X,'TINKER 3.5 by Jay W. Ponder ',
     *        /1X,'Department of Biochemistry & Molecular ',
     *            'Biophysics,',
     *        /1X,'Washington University School of Medicine, ',
     *            'St. Louis, MO 63110, USA')
c
 4000 format (/1X,'Publications based on results obtained with ',
     *            'this code should include',
     *        /1X,'the following references: ',
     *        /1X,'1. O. Tishchenko, M. Higashi, T. V. Albu, ',
     *            'J. C. Corchado, Y. Kim, J. Villa, ',
     *        /4X,'J. Xing, H. Lin, and D. G. Truhlar, ',
     *            'MCSI 2010-1, University of Minnesota,',
     *        /4X,'Minneapolis, MN, 2010',
     *        /1X,'2. J. W. Ponder, TINKER-version 3.5, Washington ',
     *            'University, St. Louis, MO, ',
     *        /4X,'1997',/)
c
      end
c***********************************************************************
c     mcrkic
c***********************************************************************
c
      subroutine mcrkic(iunitr,iunitp,mcmatm,mcmic,mcnic,
     *                mcndi,mcnan,mcnad,mcnda,mcidi,mcian,mciad,mcida,
     *                mcsin,mcpnd)                                      0312MH10
c
c     This subroutine read in a set of internal coordinates. It is written
c     based on the readint subroutine of Polyrate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      character * 1 a(80)
c
      logical   lbend
c      dimension ida(4)
      dimension ida(5)                                                  0312MH10
c
      dimension mcidi(2,mcmic)
      dimension mcian(3,mcmic)
      dimension mciad(3,mcmic)
      dimension mcida(4,mcmic)
      dimension mcpnd(mcmic)                                            0312MH10
c
      mcndi = 0
      mcnan = 0
      mcnad = 0
      mcnda = 0
c>>>>                                                                   0312MH10
      mcsin = 0
      do i=1,mcmic
         mcpnd(i)=0
      end do
c<<<<                                                                   0312MH10
c
c     Read the string
c
CAMBP#ifdef MPI
CAMBP 9999 continue
CAMBPc
CAMBP      if(master) read(iunitr,'(80a1)',end=100) a
CAMBP      iend=0
CAMBP      call mpi_bcast(iend, 1, mpi_integer, 0, commsander, ier) 
CAMBP      if(iend.eq.1) goto 100
CAMBP      call mpi_bcast(a, 80, mpi_character, 0, commsander, ier) 
CAMBP#else
 9999 read(iunitr,'(80a1)',end=100) a
CAMBP#endif
c
c     Transform to upper case and check if the end of the list is reached
c
      do i=1,80
         call upcas(a(i),1)
         call upcas(a(i+1),1)
         call upcas(a(i+2),1)
         if(a(i).eq.'E'.and.a(i+1).eq.'N'.and.a(i+2).eq.'D') goto 110
      enddo
c
c     Look for the data
c
      istat=0
      if(icodal(a,1).eq.0) goto 7777
      if(icodal(a,1).gt.0) then
      istat=1
      ida(1)=icodal(a,1)
      endif
c
      do 200 i=2,80
c
c     "do nothing" codes
c
      if(icodal(a,i).eq.-1.and.icodal(a,i-1).eq.-1) goto 200
      if(icodal(a,i).eq.-2.and.icodal(a,i-1).ge.0) goto 200
c
c     Invalid codes
c
      if(icodal(a,i).eq.-4) goto 7777
      if(icodal(a,i).gt.mcmatm) goto 7777
      if(icodal(a,i).eq.-3.and.icodal(a,i-1).eq.-3) goto 7777
      if(icodal(a,i).eq.-3.and.icodal(a,i-1).eq.-2) goto 7777
      if(icodal(a,i).eq.-3.and.icodal(a,i-1).eq.-1) goto 7777
      if(icodal(a,i).eq.-2.and.icodal(a,i-1).eq.-3) goto 7777
      if(icodal(a,i).eq.-1.and.icodal(a,i-1).eq.-3) goto 7777
      if(icodal(a,i).eq.-2.and.icodal(a,i-1).eq.-2) goto 7777
      if(icodal(a,i).eq.-2.and.icodal(a,i-1).eq.-1) goto 7777
      if(icodal(a,i).eq.-1.and.icodal(a,i-1).eq.-2) goto 7777
c
c     Beginning of new data
c
      if(icodal(a,i).ge.0.and.icodal(a,i-1).eq.-1) then
         if(icodal(a,i).eq.0) goto 7777
         istat=1
         ida(1)=icodal(a,i)
         ida(2)=0
         ida(3)=0
         ida(4)=0
         ida(5)=0
         lbend = .false.
      endif
c
c     Continuation of the string of numerals
c
      if(icodal(a,i).ge.0.and.icodal(a,i-1).ge.0) then
         ida(istat)=10*ida(istat)+icodal(a,i)
         if(ida(istat).gt.mcmatm) goto 7777
      endif
c
c     Next string of numerals
c    
      if((icodal(a,i).ge.0).and.((icodal(a,i-1).eq.-2).or.
     *        (icodal(a,i-1).eq.-3))) then
         if (icodal(a,i-1).eq.-3) lbend = .true.
         istat=istat+1
c         if(istat.gt.4.or.icodal(a,i).eq.0) goto 7777
         if(istat.gt.5.or.icodal(a,i).eq.0) goto 7777                   0312MH10
         ida(istat)=icodal(a,i)
      endif
c
c     End of data
c
      if(icodal(a,i).eq.-1.and.icodal(a,i-1).ge.0) then
c      goto (1,2,3,4) istat
      goto (1,2,3,4,5) istat                                            0312MH10
c
c     single atom - wrong!
c
  1   goto 7777
c
c     Bond (internuclear distance)
c    
  2   if(ida(1).eq.ida(2)) goto 7777
      mcndi=mcndi+1
      if(ida(1).gt.ida(2)) then
         do k=1,2
            mcidi(k,mcndi)=ida(k)
         enddo
      else
         do k=1,2
            mcidi(k,mcndi)=ida(3-k)
         enddo
      endif
c      goto 5
      goto 10                                                           0312MH10
c
c     angle / linear bends 
c
  3   if(ida(1).eq.ida(2).or.ida(1).eq.ida(3).or.ida(2).eq.ida(3))
     * goto 7777
      if (lbend) then
         mcnad=mcnad+1
      else
         mcnan=mcnan+1
      endif
      if(ida(1).gt.ida(3)) then
         do k=1,3
            if (lbend) then
              mciad(k,mcnad)=ida(k)
            else
              mcian(k,mcnan)=ida(k)
            endif
         enddo
      else
         do k=1,3
            if (lbend) then
              mciad(k,mcnad)=ida(4-k)
            else
              mcian(k,mcnan)=ida(4-k)
            endif
         enddo
      endif
c      goto 5
      goto 10                                                           0312MH10
c
c     dihedral angle
c
  4   if(ida(1).eq.ida(2).or.ida(1).eq.ida(3).or.ida(1).eq.ida(4))
     * goto 7777
      if(ida(2).eq.ida(3).or.ida(2).eq.ida(4).or.ida(3).eq.ida(4))
     * goto 7777
      mcnda=mcnda+1
      if(ida(1).gt.ida(4)) then
         do k=1,4
            mcida(k,mcnda)=ida(k)
         enddo
      else
         do k=1,4
            mcida(k,mcnda)=ida(5-k)
         enddo
      endif
c      goto 5
      goto 10                                                           0312MH10
c                                                                       0312MH10
c     sine of dihedral angle                                            0312MH10
c                                                                       0312MH10
 5    if(ida(2).eq.ida(3).or.ida(2).eq.ida(4).or.ida(2).eq.ida(5))      0312MH10
     * goto 7777                                                        0312MH10
      if(ida(3).eq.ida(4).or.ida(3).eq.ida(5).or.ida(4).eq.ida(5))      0312MH10
     * goto 7777                                                        0312MH10
      mcnda=mcnda+1                                                     0312MH10
      mcsin=1                                                           0312MH10
      mcpnd(mcnda)=ida(1)                                               0312MH10
      if(ida(2).gt.ida(5)) then                                         0312MH10
         do k=1,4                                                       0312MH10
            mcida(k,mcnda)=ida(k+1)                                     0312MH10
         enddo                                                          0312MH10
      else                                                              0312MH10
         do k=1,4                                                       0312MH10
            mcida(k,mcnda)=ida(6-k)                                     0312MH10
         enddo                                                          0312MH10
      endif                                                             0312MH10
c                                                                       0312MH10
 10   continue                                                          0312MH10
c
      endif
c
  200 continue
      goto 9999
c
c     End of data collection, order the atomic connectivities
c
  100 continue
CAMBP#ifdef MPI
CAMBP      if(master) then
CAMBP         iend=1
CAMBP         call mpi_bcast(iend, 1, mpi_integer, 0, commsander, ier) 
CAMBP      end if
CAMBP#endif
  110 continue
c
  300 invers=0
      do 330 i=1,mcndi-1
      icode1=mcidi(1,i)*mcmatm+mcidi(2,i)
      icode2=mcidi(1,i+1)*mcmatm+mcidi(2,i+1)
      if(icode1.eq.icode2) goto 310
      if(icode1.gt.icode2) then
      invers=invers+1 
      mcidi1=mcidi(1,i)
      mcidi2=mcidi(2,i)
      mcidi(1,i)=mcidi(1,i+1)
      mcidi(2,i)=mcidi(2,i+1)
      mcidi(1,i+1)=mcidi1
      mcidi(2,i+1)=mcidi2
      endif
  330 continue
      if(invers.gt.0) goto 300
      goto 600
  310 mcndi=mcndi-1
      write(iunitp,3000) mcidi(1,i),mcidi(2,i)
 3000 format (1x,'Warning: duplicate bonds: ',2i5)
      do 320 j=i,mcndi
      mcidi(1,j)=mcidi(1,j+1)
  320 mcidi(2,j)=mcidi(2,j+1)
      goto 300
c
  600 invers=0
      do 630 i=1,mcnad-1
      icode1=(mciad(1,i)*mcmatm+mciad(2,i))*mcmatm+mciad(3,i)
      icode2=(mciad(1,i+1)*mcmatm+mciad(2,i+1))*mcmatm+mciad(3,i+1)
      if(icode1.eq.icode2) goto 610
      if(icode1.gt.icode2) then
      invers=invers+1
      mciad1=mciad(1,i)
      mciad2=mciad(2,i)
      mciad3=mciad(3,i)
      mciad(1,i)=mciad(1,i+1)
      mciad(2,i)=mciad(2,i+1)
      mciad(3,i)=mciad(3,i+1)
      mciad(1,i+1)=mciad1
      mciad(2,i+1)=mciad2
      mciad(3,i+1)=mciad3
      endif
  630 continue
      if(invers.gt.0) goto 600
      goto 400
  610 mcnad=mcnad-1
      write(iunitp,6000) mciad(1,i),mciad(2,i),mciad(3,i)
 6000 format (1x,'Warning: duplicate degenerate angles: ',3i5)
      do 620 j=i,mcnad
      mciad(1,j)=mciad(1,j+1)
      mciad(2,j)=mciad(2,j+1)
  620 mciad(3,j)=mciad(3,j+1)
      goto 600
c
  400 invers=0
      do 430 i=1,mcnan-1
      icode1=(mcian(1,i)*mcmatm+mcian(2,i))*mcmatm+mcian(3,i)
      icode2=(mcian(1,i+1)*mcmatm+mcian(2,i+1))*mcmatm+mcian(3,i+1)
      if(icode1.eq.icode2) goto 410
      if(icode1.gt.icode2) then
      invers=invers+1 
      mcian1=mcian(1,i)
      mcian2=mcian(2,i)
      mcian3=mcian(3,i)
      mcian(1,i)=mcian(1,i+1)
      mcian(2,i)=mcian(2,i+1)
      mcian(3,i)=mcian(3,i+1)
      mcian(1,i+1)=mcian1
      mcian(2,i+1)=mcian2
      mcian(3,i+1)=mcian3
      endif
  430 continue
      if(invers.gt.0) goto 400
      goto 500
  410 mcnan=mcnan-1
      write(iunitp,4000) mcian(1,i),mcian(2,i),mcian(3,i)
 4000 format (1x,'Warning: duplicate angles: ',3i5)
      do 420 j=i,mcnan
      mcian(1,j)=mcian(1,j+1)
      mcian(2,j)=mcian(2,j+1)
  420 mcian(3,j)=mcian(3,j+1)
      goto 400
c
  500 invers=0
      do 530 i=1,mcnda-1
      icode1=
     *     ((mcida(1,i)*mcmatm+mcida(2,i))*mcmatm+mcida(3,i))*mcmatm
     *     +mcida(4,i)
      icode2=
     * ((mcida(1,i+1)*mcmatm+mcida(2,i+1))*mcmatm+mcida(3,i+1))*mcmatm
     * +mcida(4,i+1)
      if(icode1.eq.icode2) goto 510
      if(icode1.gt.icode2) then
      invers=invers+1 
      mcida1=mcida(1,i)
      mcida2=mcida(2,i)
      mcida3=mcida(3,i)
      mcida4=mcida(4,i)
      mcida(1,i)=mcida(1,i+1)
      mcida(2,i)=mcida(2,i+1)
      mcida(3,i)=mcida(3,i+1)
      mcida(4,i)=mcida(4,i+1)
      mcida(1,i+1)=mcida1
      mcida(2,i+1)=mcida2
      mcida(3,i+1)=mcida3
      mcida(4,i+1)=mcida4
c>>>>                                                                   0312MH10
      mcpnd1=mcpnd(i)
      mcpnd(i)=mcpnd(i+1)
      mcpnd(i+1)=mcpnd1
c<<<<                                                                   0312MH10
      endif
  530 continue
      if(invers.gt.0) goto 500
      goto 700
  510 mcnda=mcnda-1
      write(iunitp,5000) mcida(1,i),mcida(2,i),mcida(3,i),mcida(4,i)
 5000 format (1x,'Warning: duplicate dihedral angles: ',4i5)
      do 520 j=i,mcnda
      mcpnd(j)=mcpnd(j+1)                                               0312MH10
      mcida(1,j)=mcida(1,j+1)
      mcida(2,j)=mcida(2,j+1)
      mcida(3,j)=mcida(3,j+1)
  520 mcida(4,j)=mcida(4,j+1) 
      goto 500
c
c     Determine the number of internal coordinates
c
  700 mcnic = mcndi + mcnan + mcnda + 2*mcnad
c
c     Check if the number of internal coordinates is smaller than the 
c     maximum allowed.
c
      if (mcnic.gt.mcmic) then 
         write(iunitp,8000)
         stop 'mcrkic 1'
      endif
 8000 format (1x,'Error: Too many internal coordinates. ',
     *       /1x,'Increase the maximum number allowed and recompile.')
c
c     Check if any internal coordinates were read in
c
      if (mcnic.eq.0) then
         write(iunitp,8100)
         stop 'mcrkic 2'
      endif
 8100 format (1x,'Error: No internal coordinates read in.')
c
c     All done
c
      return
c
c     Error section
c
 7777 write(iunitp,9000)
 9000 format (1x,'Error: invalid connectivity data in defining ',
     *           'internal coordinates.')
      stop 'mcrkic 3'
c
      end
c ***************************************************************************
c     mcrlin
c ***************************************************************************
c
      subroutine mcrlin(iunitr,string,istrt,isect,iend)
c
c     This subroutine is a modification of subroutine rline in Polyrate.
c     The modification consists in not including the param, common and percon
c     include files.
c     (Titus V Albu January 2002)
c
c     This subroutine finds the first non-comment and non-blank line 
c     and the location of the first character on that line.  The contents
c     of the line are placed in the variable string.  It will 
c     then change it to all lower case using the routine 'case'.
c     A flag is set if the line is the start of a new section.
c
c     Modified to read from unit iunitr       0810JC97
c
c     istrt:   location in 80 character string that is the first non-blank
c     isect:   a 1 is returned if the first non-blank character is a * 
c              signalling the start of a section
c     iend:    a 1 is returned if the end of file is encountered
c     string:  80 character string that is the contents of the current line
c
      implicit double precision (a-h,o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      character * 80 string,case
      external case
c
 1000 format(A80)
c
c       initialize variables
c
      isect = 0
      iend = 0
      iblnk = 1
c
c     read in next line in file 5 - find first non-blank character and
c     determine if it is a comment (# sign signals a comment).  Once a
c     comment is found the rest of the line is skipped (by setting the
c     counter to the last character [i=80])
c
      do while (iblnk.eq.1)
CAMBP#ifdef MPI
CAMBP         if(master) read(iunitr,1000,end=9999) string
CAMBP         call mpi_bcast(iend, 1, mpi_integer, 0, commsander, ier) 
CAMBP         if(iend.eq.1) return
CAMBP         call mpi_bcast(string, 80, mpi_character, 0, commsander, ier) 
CAMBP#else
         read(iunitr,1000,end=9999) string
CAMBP#endif
         i = 1
         do while (iblnk.eq.1.and.i.le.80)
            if (string(i:i).ne.' ') then
               if (string(i:i).ne.'#') then
                   iblnk = 0
                else
                   i = 80
                end if
            end if
            i = i+1
         end do
      end do
c
c     set location of first non-blank character
      istrt = i-1
c
c     check if it is a section header (first character a *)
c
      if (string(istrt:istrt).eq.'*') isect=1
c
c     strip of any trailing comments on the line
c
      do 1 j=istrt,80
  1     if (string(j:j).eq.'#') string(j:80) = ' '
c
c     change to lower case
c
      string = case(string)
      return
 9999 iend=1
CAMBP#ifdef MPI
CAMBP      call mpi_bcast(iend, 1, mpi_integer, 0, commsander, ier) 
CAMBP#endif
      return
      end
C**********************************************************************
C     mcrlnw
C**********************************************************************
C
      SUBROUTINE mcrlnw(IUNITR,WORD,NWORD)
C
C     This is a subroutine that read in a line and break it into words
C     in upper case. It is a modified version of readln subroutine in polyrate.
C     (Titus V Albu January 2002)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*81  LINE,STRING,UPCSE
      CHARACTER*80  WORD(40)
C
      NWORD = 0
C
10    READ(IUNITR,'(A80)') STRING
C
      IP = 0
C
C     Find the first nonblank character in a line
C
20    IP = IP + 1
      IF (STRING(IP:IP) .EQ. ' ' .AND. IP .LE. 80) GO TO 20           
C
C     If it all blank or it is a comment line then read the next line
C
      IF (IP .GT. 80 .OR. STRING(IP:IP) .EQ. '#')  GO TO 10
C
C     Convert to uppercase
C
      LINE = UPCSE(STRING)
C
C     Find the position of a comment character, if any,
C     in a nonblank noncomment line
C
      ICOM = IP 
50    ICOM = ICOM + 1
      IF (LINE(ICOM:ICOM) .NE. '#' .AND. ICOM .LE. 80)  GOTO 50
C
55    IF (IP .LT. ICOM) THEN
         IBEG = IP
60       IP = IP + 1
         IF (LINE(IP:IP) .NE. ' ' .AND. IP .LT. ICOM) GOTO 60 
         NWORD = NWORD + 1
         WORD(NWORD) = LINE(IBEG:IP-1)
70       IP = IP + 1
         IF (LINE(IP:IP) .EQ. ' ' .AND. IP .LT. ICOM) GOTO 70
         GOTO 55
      ENDIF
C
      RETURN
      END
c***********************************************************************
c     mctcic
c***********************************************************************
c
      subroutine mctcic(mcndi,mcnan,mcnad,mcnda,
     *                  mcidi,mcian,mciad,mcida,
     *                  mcmic,mcmatm,x,y,z,q)
c
c     This subroutine transforms Cartesian coordinates to internal 
c     coordinates. It is written based on the trincar subroutine of Polyrate.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      dimension mcidi(2,mcmic),mcian(3,mcmic)
      dimension mciad(3,mcmic),mcida(4,mcmic)
      dimension x(mcmatm),y(mcmatm),z(mcmatm)
      dimension q(mcmic)
c
c     Initialize the q array
c
      do i=1,mcmic
         q(i) = 0.d0
      enddo
c
c     Distances
c 
      if (mcndi.ne.0) then
         do j = 1,mcndi
            q(j)=ydist(mcidi(1,j),mcidi(2,j),x,y,z,mcmatm)
         enddo
      endif
c
c     Angles
c
      if (mcnan.ne.0) then
         do j = 1,mcnan
            q(j+mcndi)=yangl(mcian(1,j),mcian(2,j),mcian(3,j),
     *                       x,y,z,mcmatm)
         enddo
      endif
c
c     Dihedral angles
c
      if (mcnda.ne.0) then
         do j = 1,mcnda
            q(j+mcndi+mcnan)=ytors(mcida(1,j),mcida(2,j),
     *                       mcida(3,j),mcida(4,j),x,y,z,mcmatm)
         enddo
      endif
c
c     Degenerate angles
c
      if (mcnad.ne.0) then
         do j = 1,mcnad
            q(j+mcndi+mcnan+mcnda)=yangl(mciad(1,j),mciad(2,j),
     *                             mciad(3,j),x,y,z,mcmatm)
            q(j+mcndi+mcnan+mcnda+mcnad)=q(j+mcndi+mcnan+mcnda)
         enddo
      endif
c
      return
      end
