      subroutine faidensch(v,u,s,ndims,orbi)
      use densch
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (maxsym=8,nfix=500)
      parameter (maxl=100)
      parameter (maxproj=10)
      dimension s(ndims,ndims),v(ndims,ndims),u(ndims,ndims)
      character*8 orbi(ndims)
c      common/densch/occ(nfix)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character*10000 namel
      double precision,dimension(:,:),allocatable :: vv
      yw=.true.
      rewind 93
      allocate(vv(1:ndims,1:ndims))
      print*,'ndims',ndims
      print*,'occ',occ(1:ndims)
      print*,'entree faidensch'
      print*,'recouvrement'
      if(yw)call scripto
     *(s(1:ndims,1:ndims),ndims,ndims,ndims,ndims,orbi)
      print*,'OAO'
      if(yw)call scripto
     *(v(1:ndims,1:ndims),ndims,ndims,ndims,ndims,orbi)
 
c     open(11,file='SCHMUD',status='unknown')
c1001 format(4D18.12)
c     write(11,'(a)')' Orbitales atomiques, occupations en donnee'
c     do is=1,nsym
c        do io=1,isym(is)
c           write(11,'(''* ORBITAL'',2i5)') is,io
c           write(11,1001)(0.d0,i=1,io-1),1.d0,(0.d0,i=io+1,ndims)
c        enddo
c     enddo
c     write(11,'(a)')' OCCUPATIONS'
c     write(11,1001) occ(1:ndims)
c     close(11)
      u=0.d0
      do k=1,ndims
         vv(k,k)=occ(k)
      enddo
      if(yw)call scripto
     *(vv(1:ndims,1:ndims),ndims,ndims,ndims,ndims,orbi)
c      u=matmul(transpose(v),s)
c      u=matmul(vv,u)
c      u=matmul(v,u)
      u=matmul(transpose(v),s)
      u=matmul(u,vv)
      u=matmul(u,v)
c      u=matmul(v,vv)
c      u=matmul(u,s)
c      u=matmul(u,transpose(v))
      u=(u+transpose(u))/2
      if(yw)call scripto
     *(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims,orbi)
 
 
      return
      end
 
