subroutine mcweeny2(norbs)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#include "divcon.dim"
#include "divcon.h"

       real*8 Pij(norbs,norbs),Pij23(norbs,norbs),Pnewij(norbs,norbs)
      character transa
      character transb
      external temps
   

       ijbond=1


       iorb = 1
  
       do i=1,natoms
        IAI = IATNUM(I)
        NORBSI = NATORB(IAI)
    
         jorb=1
         do j=1,i
        IAJ = IATNUM(J)
        NORBSJ = NATORB(IAJ)


           if (i.ne.j) then
            IJ = IJMAT(IJBOND)
            DO 130 II=iorb,NORBSI+iorb-1
              DO 120 JJ=jorb,NORBSJ+jorb-1
                PIJ(II,JJ) = PDIAT(IJ)*0.5d0
                PIJ(JJ,II) = PDIAT(IJ)*0.5d0
                PIJ23(II,JJ) = PDIAT(IJ)*0.5d0
                PIJ23(JJ,II) = PDIAT(IJ)*0.5d0
                IJ = IJ + 1
 120          CONTINUE
 130        CONTINUE
           elseif (i.eq.j) then
            IJ = IIMAT(I)
            DO 110 II=iorb,NORBSi+iorb-1
              DO 100 JJ=iorb,II
                Pij(II,JJ) = PDIAG(IJ)*0.5d0
                Pij(JJ,II) = PDIAG(IJ)*0.5d0
                Pij23(II,JJ) = PDIAG(IJ)*0.5d0
                Pij23(JJ,II) = PDIAG(IJ)*0.5d0
                IJ = IJ + 1
 100          CONTINUE
 110        CONTINUE
           endif
          
         jorb = jorb + NORBSJ
         ijbond=ijbond+1
         enddo 
         iorb = iorb + NORBSI
       enddo  
c          do i=2,norbs
c          do j =1,i
c           pij(j,i)=pij(i,j)
c          enddo
c          enddo
     
c           write(59,*)'avant'
c          do i=1,norbs
c           write(59,99)(pij(i,j),j=1,norbs)
c          enddo

       do i=1,Norbs
         do j=1,Norbs
        Pnewij(i,j)=0.0d0        
         enddo
       enddo

      c0 = temps()
      do kkk=1,1

      aalpha = -2.0d0
      bbeta = 3.0d0
      transa = 'N'
      transb = 'N'

      if (kkk.gt.1) then

       do i=1,Norbs
         do j=1,Norbs
        Pij(i,j)= Pnewij(i,j)
        Pij23(i,j)= Pnewij(i,j)        
         enddo
       enddo
       do i=1,Norbs
         do j=1,Norbs
        Pnewij(i,j)=0.0d0        
         enddo
       enddo
       endif 
      call dgemm(transa,transb,Norbs,Norbs,Norbs,aalpha,Pij,Norbs,
     &           Pij,Norbs,bbeta,Pij23,Norbs)

      aalpha = 1.0d0
      bbeta = 1.0d0
      call dgemm(transa,transb,Norbs,Norbs,Norbs,aalpha,Pij23,Norbs,
     &           Pij,Norbs,bbeta,Pnewij,Norbs)


       enddo
      c1 = temps()
      c2 = c1-c0
      write(*,'(" times = ",f8.3," seconds")') c2

c           write(59,*)'apres'
c          do i=1,norbs
c           write(59,99)(pnewij(i,j),j=1,norbs)
c          enddo 
 
         
       ijbond=1


       iorb = 1
  
       do i=1,natoms
        IAI = IATNUM(I)
        NORBSI = NATORB(IAI)
    
         jorb=1
         do j=1,i
        IAJ = IATNUM(J)
        NORBSJ = NATORB(IAJ)


           if (i.ne.j) then
            IJ = IJMAT(IJBOND)
            DO 131 II=iorb,NORBSI+iorb-1
              DO 121 JJ=jorb,NORBSJ+jorb-1
                 PDIAT(IJ)=PnewIJ(II,JJ)*2.0d0

                IJ = IJ + 1
 121         CONTINUE
 131      CONTINUE
           elseif (i.eq.j) then
            IJ = IIMAT(I)
            DO 111 II=iorb,NORBSi+iorb-1
              DO 101 JJ=iorb,II
          PDIAG(IJ)=Pnewij(II,JJ)*2.0d0
           
                IJ = IJ + 1
 101            CONTINUE
 111            CONTINUE
           endif
          
         jorb = jorb + NORBSJ
         ijbond=ijbond+1
         enddo 
         iorb = iorb + NORBSI
       enddo  
       
   
c           write(59,*)iorb,jorb
c          do i=1,norbs
c           write(59,99)(pij(i,j),j=1,norbs)
c          enddo
 99       format(18f9.6)
         END