      subroutine frdel
!
! Frozen and deleted orbitals
! modify potnuc and one-electron integrals
!
      use chol_X
      use mod_script
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer(8) ll,llv
      yw=.false.
      call titre('There are Frozen Orbitals#',50)

! define frozen and deleted orbitals by yfrdel(i)=.true.

      ii=0
      do is=1,nsym
         do i=1,frozen(is)
            ii=ii+1
            yfrdel(ii)=.true.
            yfr(ii)=.true.
         enddo
         do i=1+frozen(is),isym(is)-delete(is)
            ii=ii+1
            yfrdel(ii)=.false.
            yfr(ii)=.false.
         enddo
         do i=isym(is)-delete(is)+1,isym(is)
            ii=ii+1
            yfrdel(ii)=.true.
            yfr(ii)=.false.
         enddo
      enddo
!      print*,'           yfr     yfrdel'
!      do i=1,norb
!         print'(i4,2l10)',i,yfr(i),yfrdel(i)
!      enddo

! Modify potnuc
      !print*,'potnuc',potnuc
      do i=1,norb
         if(yfr(i)) then
            potnuc=potnuc+one(i,i)*2
            !print*,'potnuc1',potnuc,one(i,i),i,norb
         endif
      enddo
      do i=1,norb
         !print*,'i,norb',i,norb
         if(yfr(i)) then
            potnuc=potnuc+ai(i,i,i,i)
            !print*,'potnuc2',potnuc,ai(i,i, i,i),i,norb
         endif
      enddo
      do i=1,norb
         if(yfr(i)) then
            do j=1,i-1
               if(yfr(j)) then
                  potnuc=potnuc+ai(i,i,j,j)*4-ai(i,j,i,j)*2
                  !print*,'potnuc3',potnuc,i,j,ai(i,i,j,j),ai(i,j,i,j)
               endif
            enddo
         endif
      enddo
      print'(a,f15.8)','Enuc after freezing',potnuc

! Modify One-El Integrals
      !print*,'ai(1,1,2,3)',ai(1,1,2,3),ai(1,1,3,2)
      !print*,'ONE avant modif gel'
      !call mscript(one)
      print*,'Begin modifying One-El Integrals'
      icpu1=itemps(idum)
      do k=1,norb
         if(yfr(k)) then
            do i=1,norb
               if(yfr(i)) cycle
               do j=1,i
                  if(itsym(i)/=itsym(j)) cycle
                  if(yfr(j)) cycle
                  one(i,j)=one(i,j)+ai(k,k,i,j)*2-ai(k,i,k,j)
                  one(j,i)=one(i,j)
               enddo
            enddo
         endif
      enddo
      icpu2=itemps(idum)
      print*,'End modifying One-El Integrals. cpu:',icpu2-icpu1,' sec.'
      print*,' '
      !print*,'ONE apres modif gel'
      !call mscript(one)

! 
! Modify all current data to take account of freezing
!
      call frdel2
      end



       subroutine frdel2
! 
! Modify all current data to take account of freezing
!
      use chol_X
      use mod_script
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer isymg(8)
      integer,allocatable :: idum(:)
      integer(8) :: numcho_is12
      integer(8) ll,llv
      yw=.false.
      

      isymg(1:nsym)=isym(1:nsym)-frozen(1:nsym)-delete(1:nsym)
      if(yw)print*,'fermi avant g',fermi
      !fermi(1:nsym)=fermi(1:nsym)-frozen(1:nsym)
      norbg=sum(isymg(1:nsym))
      if(yw)print*,'isymG',isymg
      if(yw)print*,'norbG',norbg
      
! shift ONE
      if(yw)print*,'ONE avant shift'
      if(yw)call mscript(one)
      ii=0
      do i=1,norb
         if(yfrdel(i)) cycle
         ii=ii+1
         one(:,ii)=one(:,i)
      enddo
      ii=0
      do i=1,norb
         if(yfrdel(i)) cycle
         ii=ii+1
         one(ii,:)=one(i,:)
      enddo
      if(yw)print*,'ONE apres shift'
      if(yw)call mscript(one)

!from isym and fermi, compute iord
      deallocate(iord,iord1)
      allocate(iord(norbg),iord1(norbg))
      !call caliord(nsym,isymg,fermi,iord,iord1,norbg)
      call caliord(nsym,isymg,inact,act,iord,iord1,norbg)
      !yw=.true.
      if(yw)print'(a)','IordG'
      if(yw)print'(20i4)',iord
      if(yw)print'(20i4)',iord1

!
! Compute itsym (symmetry of orbitals)
!
      deallocate (itsym)
      allocate(itsym(norbg))
      call calitsym(nsym,itsym,isymg,norbg)
      if(yw)print'(a)','itsymG'
      if(yw)print'(20i4)',itsym
      if(yw)print'(20i4)',itsym(iord)
!
! compute mpq (number of rows of the Cholesky matrix of symm is1,is2)
!
      call calmpq(nsym,L_Chol,mpq,isymg,numcho)
      if(yw)print'(a,8i6)',' isymG',isymg(1:nsym)
      if(yw) print'(a,8i6)','MpqG '
      if(yw) call mscript(mpq)
!
! address Cholesky Vectors
!
      call adr_chol(nsym,isymg,iadr_chol,numcho,norbg)

!
! shift Cholesky Vectors
!


      ll=1
      llv=1
      do is12=1,nsym
         numcho_is12=numcho(is12)
         do is1=1,nsym
            is2=iEOR(is12-1,is1-1) + 1
            if(is2<is1) cycle
            if(is1==is2) then
               do iii=1,isym(is1)
                  i=sum(isym(1:is1-1))+iii
                  do jj=1,iii
                     j=sum(isym(1:is2-1))+jj
                     if(yfrdel(i).or.yfrdel(j)) then
                        llv=llv+numcho_is12
                        cycle
                     endif
! shift chol_vec                     
                     chol_vec(ll:ll+numcho_is12 -1)=
     *               chol_vec(llv:llv+numcho_is12 -1)
! increment indices                     
                     ll=ll+numcho_is12 
                     llv=llv+numcho_is12 
                  enddo
               enddo
            else
               do jj=1,isym(is2)
                  j=sum(isym(1:is2-1))+jj
                  do iii=1,isym(is1)
                     i=sum(isym(1:is1-1))+iii
                     if(yfrdel(i).or.yfrdel(j)) then
                        llv=llv+numcho_is12 
                        cycle
                     endif
! shift chol_vec                     
                     chol_vec(ll:ll+numcho_is12 -1)=
     *               chol_vec(llv:llv+numcho_is12 -1)
! increment indices                     
                     ll=ll+numcho_is12 
                     llv=llv+numcho_is12 
                  enddo
               enddo
            endif
         enddo
      enddo
      print*,'length of cholesky vector before freezing',llv-1
      print*,'length of cholesky vector after freezing ',ll-1
      L_Chol=ll-1
      isym=isymg
      norb=norbg

! shorten vectors
      allocate(idum(norb))

      idum=iord(1:norb)
      deallocate (iord)
      allocate(iord(norb))
      iord=idum
      
      idum=iord1(1:norb)
      deallocate (iord1)
      allocate(iord1(norb))
      iord1=idum
      
      idum=itsym(1:norb)
      deallocate (itsym)
      allocate(itsym(norb))
      itsym=idum
      
      deallocate(idum)




      end
