      subroutine ref
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorb=500)
      common/l40/ hmono(maxorb*(maxorb+1)/2),aj(maxorb*(maxorb+1)/2)
     *,ak(maxorb*(maxorb+1)/2),f(maxorb*(maxorb+1)/2),e0
     *,ajk(maxorb*(maxorb+1)/2),escf
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      common/test/itest(50)
      num(i,j)=i*(i-1)/2+j
c
c---------------------------------------------------
c     energie de reference
c---------------------------------------------------
c
      eref=0
      do i=1,noca0
         eref=eref+hmono(num(i,i))*2+aj(num(i,i))
         do j=1,i-1
            eref=eref+(2*aj(num(i,j))-ak(num(i,j)))*2
         enddo
      enddo
      e0=0
      do ii=1,ninac
         i=numina(ii)
         e0=e0+hmono(num(i,i))*2+aj(num(i,i))
         do jj=1,ii-1
            j=numina(jj)
            e0=e0+(2*aj(num(i,j))-ak(num(i,j)))*2
         enddo
      enddo
      write(6,'('' energie de'',i3,'' orbitales occupees'',f18.8)')
     *noca0,eref
      write(6,'('' energie de'',i3,'' inactives occupees'',f18.8)')
     *ninac,e0
      write(6,'('' energie totale                  '',f18.8)')
     *eref+enuc
      if(itest(1).ne.1.and.itest(1).ne.2)write(2)eref+enuc,enuc,eref
      close(2)
      erefn=e0
      e0=e0-eref
c     write(6,'('' nouvelle energie de reference '',f18.8)') e0
c     aj13=aj(num(3,1))
c     aj23=aj(num(3,2))
c     aj33=aj(num(3,3))
c     aj43=aj(num(4,3))
c     ak13=ak(num(3,1))
c     ak23=ak(num(3,2))
c     ak43=ak(num(4,3))
c     write(6,*)'j13',aj(num(3,1))
c     write(6,*)'j23',aj(num(3,2))
c     write(6,*)'j33',aj(num(3,3))
c     write(6,*)'j43',aj(num(4,3))
c     write(6,*)'k13',ak(num(3,1))
c     write(6,*)'k23',ak(num(3,2))
c     write(6,*)'k43',ak(num(4,3))
c     h33=hmono(num(3,3))
c     write(6,*)'h33',h33
c     write(6,*)'(-aj13-aj23-aj43)*2-aj33-h33+ak13+ak23+ak43',
c    *(-aj13-aj23-aj43)*2-aj33-h33+ak13+ak23+ak43
c     write(6,*)'eref+(-aj13-aj23-aj43)*2-aj33-h33+ak13+ak23+ak43',
c    *eref+(-aj13-aj23-aj43)*2-aj33-h33+ak13+ak23+ak43
c     write(6,*)'(aj13+aj23+aj43)*2+h33-ak13-ak23-ak43',
c    *(aj13+aj23+aj43)*2+h33-ak13-ak23-ak43
c     write(6,*)'erefn+(aj13+aj23+aj43)*2+h33-ak13-ak23-ak43',
c    *erefn+(aj13+aj23+aj43)*2+h33-ak13-ak23-ak43
c     write(6,*)'aj33*2+((aj13+aj23+aj43)*2+h33-ak13-ak23-ak43)*2',
c    *aj33*2+((aj13+aj23+aj43)*2+h33-ak13-ak23-ak43)*2
c     write(6,*)'erefn+aj33+((aj13+aj23+aj43)*2+h33-ak13-ak23-ak43)*2'
c    *,erefn+aj33+((aj13+aj23+aj43)*2+h33-ak13-ak23-ak43)*2
c     stop
      return
      end
