********************************************************************************
*                                                                              * 
*  2DHF version 1-2003                                                         *
*  Copyright (C) 1996  Jacek Kobus, Leif Laaksonen, Dage Sundholm              *
*                                                                              *
*  This software may be used and distributed according to the terms            *
*  of the GNU General Public License, see README and COPYING.                  *
*                                                                              *
********************************************************************************
c ### toten ### 
c
c     Calculates total energy 
c
      subroutine toten (psi,pot,excp,e,f0,wgt1,wgt2,wk0,wk1,wk2,wk3)
      implicit integer*4 (i-n)
      implicit real*8 (a-h,o-z)
      include 'commons8.inc'
      dimension psi(*),pot(*),excp(*),e(*),f0(*),wgt1(*),wgt2(*),
     &     wk0(*),wk1(*),wk2(*),wk3(*)
      data eps /1.d-7/

      if (islat.ne.0) then
c        the Slater exchange approximation is used
	 call totensl (psi,pot,excp,e,f0,wgt1,wgt2,wk0,wk1,wk2,wk3)
	 return
      endif

      engt(1)=eng(1)

      call prepwexch

      engt(1)=0.d0
      
c     calculate first contributions from one particle operators and
c     coulomb potential contributions within the same shell

      if (idbg(70).ne.0) then
	 write(*,*) 'orb        t        v(n)      t+v(n)     ',
     &        ' v(c-within shell)'
      endif
      
      norb2=norb*norb
      woneel=0.d0
      wdcoul=0.d0

      vkt=0.d0
      vnt=0.d0
      
      do iorb=1,norb
         iborb=i1b(iorb)
         isiorb=i1si(iorb)
         nmut=i1mu(iorb)
         ibpot=i2b(iorb)	  
         isipot=i2si(iorb)
         if (idbg(70).ne.0) write(*,*) 'iorb,occ(iorb)',iorb,occ(iorb)
         oc=occ(iorb)

         ipe=mgx(6,iorb)
         ipex=ipe-2*(ipe/2)

c        calculate derivatives over mu and ni variables by means of matrix
c        multiplication

         if (ipex.eq.0) then
	    isym= 1
         else
	    isym=-1
         endif
     
         call fill (nni,nmut,isym,psi(iborb),wk3)
         call difni (nmut,wk3,wk0,wk1,wk2)
         call refill(nni,nmut,wk1,wk0)
         call difmu (nmut,wk3,wk2)
         call refill(nni,nmut,wk0,wk2)

c        add derivatives over mu and ni

         call add (isiorb,wk0,wk1)

c        add contribution from phi part of laplasian
c        e enters the expression with minus sign which is already
c        incorporated in e
         
         if (ipe.ne.0) then
	    w=dble(ipe*ipe)
	    call dcopy (isiorb,e,1,wk0,1)
	    if (ipe.ne.1) then
               call dscal (isiorb,w,wk0,1)
	    endif
	    call prod  (isiorb,psi(iborb),wk0)
	    call add   (isiorb,wk0,wk1)
         endif
    
         call dcopy (isiorb,wk1,1,wk2,1)
         call prod  (isiorb,psi(iborb),wk2)
         w=ddot(isiorb,wgt1,1,wk2,1)
c         write(*,'(3d22.14)') w,wk1(isiorb/2),wk2(isiorb/2)
c         write(*,'(3d22.14)') psi(iborb),psi(iborb+3*isiorb/4)
c         write(*,*) isiorb,iborb
         vk(iorb)=w
         
         call dcopy (isiorb,f0,1,wk0,1)
         call prod  (isiorb,psi(iborb),wk0)
         
         call prod2 (isiorb,psi(iborb),wk0,wk2)
         w=ddot(isiorb,wgt1,1,wk2,1)
         vn(iorb)=w

         call add (isiorb,wk0,wk1)
         call prod (isiorb,psi(iborb),wk1)

         w = ddot(isiorb,wgt1,1,wk1,1)
         woneel=woneel+oc*w

         if (nel.lt.2) then
            vkt=vkt+oc*vk(iorb)
            vnt=vnt+oc*vn(iorb)
            evt=woneel
            epott=vnt
            virrat=(epott+z1*z2/r)/vkt
            etot=evt+z1*z2/r
            return
         endif

c        contribution from coulomb interaction within the same shell
         
         if (oc.gt.1.d0) then
	    if (isipot.ne.isiorb) then
               write(iout6,*) 'coulomb potentials and orbitals',
     &              ' have to defined on the same number of subgrids'
               stop 'toten'
            endif				
            call dcopy (isipot,pot(ibpot),1,wk2,1)
            call prod  (isiorb,psi(iborb),wk2)
            call prod  (isiorb,psi(iborb),wk2)
            
            w=ddot(isiorb,wgt2,1,wk2,1)
            wdcoul=wdcoul+oc*(oc-1.d0)/2.d0*w
         endif	    
         
         vkt=vkt+oc*vk(iorb)
         vnt=vnt+oc*vn(iorb)
         
         if (idbg(70).ne.0) then
            write(*,6000) iorb, vk(iorb),vn(iorb),
     &           vk(iorb)+vn(iorb),w
         endif
 10      continue
      enddo
      
 6000 format(' ',i4,2x,4d22.14)
 6010 format(' ',i4,2x,4d22.14)
 6012 format(' ',2i4,2x,4d22.14)

c     contribution from coulomb and exchange interaction between shells
      
      wndc =0.d0
      wex1 =0.d0
      wex2 =0.d0

      do iorb1=1,norb
         
c        retrieve from a disk file exchange potentials involving iorb1

         if (iform.eq.0.or.iform.eq.2) then
            call  rfdexch(iorb1,excp)
         endif
         
         iborb1=i1b(iorb1)
         isiorb1=i1si(iorb1)
         nmut1=i1mu(iorb1)
         ibpot1=i2b(iorb1)
         isipot1=i2si(iorb1)	  	  
         oc1=occ(iorb1)	
         
         ipe1=mgx(6,iorb1)
         iex1 =iorb1+iorb1*(iorb1-1)/2

         call dcopy (isiorb1,psi(iborb1),1,wk0,1)
         call prod  (isiorb1,psi(iborb1),wk0)

c        calculate exchange interaction within pi, delta, etc. open shell
         
         if (ipe1.gt.0.and.abs(oc1-1.d0).gt.eps) then
            call exint (iorb1,ocx1)
            ibex=i3b(iex1)
            isiex1=i3si(iex1)
            
            ngrid=min(isiorb1,isiex1)
            call prod2  (ngrid,wk0,excp(ibex),wk1)
            w=ddot (ngrid,wgt2,1,wk1,1)
            wex1=wex1+ocx1*w
            
            if (idbg(70).ne.0) then
               write(*,6020) iorb1,w
 6020          format(' ','orb v(x-within shell) ',i4,2x,4d15.5)
            endif
            
            if (idbg(71).ne.0) then
               write(*,7020) iorn(iorb1),bond(iorb1),gut(iorb1),
     &              ipe1,ocx1
 7020          format(' ','v(x-within shell)  ',
     &              i4,1x,a8,a1,i4,f6.2)
            endif
         endif
         
         do iorb2=iorb1+1,norb
            iborb2=i1b(iorb2)
            isiorb2=i1si(iorb2)
            nmut2=i1mu(iorb2)
            ibpot2=i2b(iorb2)
            isipot2=i2si(iorb2)	  
            oc2=occ(iorb2)	

c           coulomb interaction between shells

            ngrid=min(isipot2,isiorb1)
            call prod2 (ngrid,pot(ibpot2),wk0,wk1)

            w=ddot(ngrid,wgt2,1,wk1,1)
            wndc=wndc+oc1*oc2*w

            if (idbg(70).ne.0) then
               write(*,6022) iorb1,iorb2,w
 6022          format(' ','orb1 orb2 v(c-inter shell) ',2i4,2x,4d15.5)
               write(*,*) 'wndc ',iorb1,wndc
            endif

            if (idbg(71).ne.0) then
               write(*,7022) iorn(iorb1),bond(iorb1),gut(iorb1),
     &              iorn(iorb2),bond(iorb2),gut(iorb2),oc1*oc2
 7022          format(' ','v(c-inter shell)  ',i4,1x,a8,a1,
     &              i4,1x,a8,a1,f6.2)
            endif
            
            ipe2=mgx(6,iorb2)
            iex=iorb1+iorb2*(iorb2-1)/2
            ibex=i3b(iex)	  
            isiex=i3si(iex)

c           exchange interaction between shells (same lambda)	  

            call excont (iorb1,iorb2,ocx1,ocx2)	  
            
            ngrid=min(isiorb1,isiorb2,isiex)
            call prod2 (ngrid,excp(ibex),psi(iborb1),wk1)
            call prod  (ngrid,psi(iborb2),wk1)
            
            w=ddot(ngrid,wgt2,1,wk1,1)
            wex1=wex1+ocx1*w
            
            if (idbg(70).ne.0) then
               write(*,6024) iorb1,iorb2,w
 6024          format(' ','orb1 orb2 v(x-inter shell)a',2i4,2x,4d15.5)
               write(*,*) 'wex1 ',iorb1,iorb2,w,wex1
            endif
            
            if (idbg(71).ne.0) then
               write(*,7024) iorn(iorb1),bond(iorb1),gut(iorb1),
     &              iorn(iorb2),bond(iorb2),gut(iorb2),ocx1
07024          format(' ','v(x-inter shell)a ',i4,1x,a8,a1,
     &              i4,1x,a8,a1,f6.2)
            endif
            
c           exchange interaction between shells (different lambda)
            
            if (ilc(iex).gt.1) then
               call prod2 (ngrid,excp(ibex+ngrid),psi(iborb1),wk1)
               call prod  (ngrid,psi(iborb2),wk1)
               w=ddot (ngrid,wgt2,1,wk1,1)
               wex2=wex2+ocx2*w

               if (idbg(70).ne.0) then
                  write(*,6026) iorb1,iorb2,w
 6026             format(' ','v(x-inter shell)b ',2i4,2x,4d15.5)
                  write(*,*) 'wex2 ',iorb1,iorb2,w,wex2
               endif

               if (idbg(71).ne.0) then
                  write(*,7026) iorn(iorb1),bond(iorb1),gut(iorb1),
     &                 iorn(iorb2),bond(iorb2),gut(iorb2),ocx2
 7026             format(' ','v(x-inter shell)b ',i4,1x,a8,a1,
     &                 i4,1x,a8,a1,f6.2)
               endif
               
            endif
 20         continue
         enddo
      enddo
      
      evt=woneel+wdcoul+wndc-wex1-wex2
      epott=vnt+wdcoul+wndc-wex1-wex2
      virrat=(epott+z1*z2/r)/vkt
      etot=evt+z1*z2/r
      
      engt(1)=evt
      
      if (idbg(70).ne.0) then
         write(*,*) 'total energy: ', evt
         write(*,*) 'contributions: one-electron     coulomb',
     &        '     exchange  '
         write(*,'(3d22.14)')  woneel,wdcoul+wndc,wex1+wex2
      endif
      
      return
      end
