!*****************************************************
      subroutine cholesky
      use module
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      allocatable chol_vec(:)
      integer(8),allocatable :: iadr_chol(:)
      integer numcho(8)
      character(10000) namel
      integer,allocatable :: jtsym(:)
      integer(8) l_chol,ll,npq_numv_8
      yw=.false.


      allocate(jtsym(norb))

! prepare
      ii=0
      do is=1,nsym
         do k=1,isym(is)
            ii=ii+1
            jtsym(ii)=is
         enddo
      enddo
      call titre('Cholesky Transformation#',40)

!
! Open Cholesky vector file
!
      call open_chose_number(ifil,'CHOL_VEC',
     *'old','unformatted')

!
! read numcho
! Read length of Cholesky Vector
!
      rewind 1
      call LECNAM('&COST_MO',namel,1,ierr,0)
      call nameli(namel,NUMCHO,'NUMCHO',4)
      call nameli(namel,L_CHOL,'L_CHOL',8)

!
! Read Cholesky vector
!
      call cpu_time(t0)
      allocate(chol_vec(L_Chol))
      yw=.false.
      ll=0
      do
         read(ifil,end=1) jsym,isymp,numv,npq
         npq_numv_8=1
         npq_numv_8=npq_numv_8*Npq
         npq_numv_8=npq_numv_8*Numv
         !print*,'npq_numv_8',npq_numv_8
         !print*,'jsym,isymp,numv,npq',jsym,isymp,numv,npq
         !print*,'shape avant lire2',shape(chol_vec)
         call lire2(chol_vec(ll+1),npq_numv_8,ifil)
         !print*,'shape apres lire2',shape(chol_vec)
         !print*,'chol_vec',jsym,isymp
         if(yw)call script(chol_vec(ll+1),numv,npq,numv,npq)
         ll=ll+npq_numv_8
         !print*,'ll',ll
      enddo
 1    continue
      !print'(a,8i5)','numcho',numcho
      !print'(a,8i5)','isym',isym
      numv=numcho(1)
      if(yw)print*,'K11',ddot(numv,chol_vec,1,chol_vec,1)
      call cpu_time(t1)
      print'(a,f12.2)','Cholesky vector read    cpu',t1-t0



!
! If there are frozen or delete orbitals, shift Cholesky Vector
!

      if(any(frozen/=0).or.any(delete/=0)) then
         !print*,'l_chol avant shift',l_chol
         !print*,'shape avant appel',shape(chol_vec)
         call cpu_time(t0)
         call shift_chol_vec(chol_vec,nsym,isym,noa,frozen,delete,
     *   numcho,l_chol)
         call cpu_time(t1)
         print'(a,f12.2)','Non frozen orb shifted  cpu',t1-t0
      endif

!
! Address Cholesky Vectors
!
      call cpu_time(t0)
      allocate(iadr_chol(norb*(norb+1)/2))
      call adr_chol1(nsym,isym,iadr_chol,numcho,norb)
      call cpu_time(t1)
      print'(a,f12.2)','Cholesky vector addressed    cpu',t1-t0

!
! Compute integrals
      print*,' '
      print*,'Begin computing Integrals'
      call calint2(chol_vec,iadr_chol,L_Chol,numcho)

!
! if(ycl) write One el integrals on file IJCL
      if(ycl) then
         do i=1,norb
            do j=1,i
               write(24,1000) i,j,0,0,hmono(i,j),1
            enddo
         enddo
         write(24,1000) 0,0,0,0,enuc,0
      endif
 1000 format(4i4,d20.12,i7)
      end

!*****************************************************
       subroutine calint2(chol_vec,iadr_chol,L_Chol,numcho)
!
! Compute integrals
!
      use module
      use moddi
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      real(8) chol_vec(*)
      integer(8) :: iadr_chol(norb*(norb+1)/2)
      real(8),allocatable :: desym(:,:)
      real(8),allocatable :: locci_orb(:,:),t(:,:),ss(:,:)
      integer,allocatable :: jtsym(:)
      integer numcho(8),numchot(0:8)
      logical yw
      integer(8) l_chol
      yw=.false.
      allocate(ajk(norb,norb))
      allocate(jtsym(norb))
      !print*,'- entree calint2'

! prepare
      ii=0
      do is=1,nsym
         do k=1,isym(is)
            ii=ii+1
            jtsym(ii)=is
         enddo
      enddo     
      !print*,'jtsym'
      !print'(10i3)',jtsym
      numchot=0
      do is=1,nsym
         numchot(is)=numchot(is-1)+numcho(is)
      enddo
      ncho=sum(numcho(1:nsym))
!
! 1st step: Transformation matrix between desymorb and LOCCI orbitals
! both sets are written in desymetrized AO
! desymorb orb: symmetry orbitals, ordered by symmetry
! LOCCI orb: local orb, ordered by occupation
!

! Read desymorb and locci orb
      allocate(desym(noa,norb))
      allocate(locci_orb(noa,norb))
      open(88,file='DESYM_LOCCI_ORB',form='unformatted',
     *status='old')
      rewind 88
      read(88) desym
      if(yw)print*,'desymorb orb'
      if(yw)call mscript(desym)
      read(88) locci_orb
      if(yw)print*,'locci_orb orb'
      if(yw)call mscript(locci_orb)
! Overlap matrix between desymetrized AO
      allocate(ss(noa,noa))
      open(99,form='unformatted',status='old',file='DESYMORB2')
      rewind 99
      read(99)
      read(99)
      read(99)
      read(99) ss(:,:)
      close(99)
! Transformation matrix
      allocate(t(norb,norb))
      t=matmul(transpose(desym),matmul(ss,locci_orb))
      if(yw)print*,'T'
      if(yw)call mscript(T)
      deallocate(desym,locci_orb,ss)
!
! 2nd step: Transformation of the Cholesky Vectors      
!******************************************************************
!      


!
! Compute 2 and 3 index integrals
!
      call cpu_time(t0)
      call int_2_3(chol_vec,iadr_chol,L_Chol,numcho,t,jtsym
     *,numchot)
      call cpu_time(t1)
      print'(a,f12.2)','2- and 3-index int computed    cpu',t1-t0
!
! Compute 4 index integrals
!
      call cpu_time(t0)
      call int_4(chol_vec,iadr_chol,L_Chol,numcho,t,jtsym
     *,numchot)
      call cpu_time(t1)
      print'(a,f12.2)','4-index int computed    cpu',t1-t0


      end
       

!*****************************************************
       subroutine int_2_3(chol_vec,iadr_chol,L_Chol,numcho,t,jtsym
     *,numchot)
      use module
      use moddi
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      real(8) chol_vec(*)
      integer(8) l_chol,jadrk,jadrnl,mu,jadrj1,jadrj2
      integer(8) :: kadrnl,kadrj
      integer(8) :: iadr_chol(norb*(norb+1)/2)
      real(8),allocatable :: chol_vec_j(:,:),aijkk(:,:)
     *,chol_vec_k(:),chol_vec_m(:)
      real(8) t(norb,norb)
      integer jtsym(norb)
      integer numcho(8),numchot(0:8)
      integer(2) :: iint(4096),jnt(4096),knt(4096),lnt(4096)
      real(8) aaint(2,4096)
      integer loci(3)
      logical yw
      yw=.false.

      allocate(chol_vec_j(sum(numcho(1:nsym)),norb))
      allocate(chol_vec_k(sum(numcho(1:nsym))))
      allocate(chol_vec_m(sum(numcho(1:nsym))))
      allocate(aijkk(norb,norb*(norb-1)/2))

      if(ycl) open(24,file=trim(prefix)//'IJCL',status='unknown')



! Compute KIJ      
! Compute ij column of desymetrized orbitals

      call cpu_time(t0)
      do il=1,norb
         do jl=1,il
            chol_vec_k(:)=0.d0
! il,jl: indices of local orbitals (of LOCCI)            
            do inl=1,norb
               if(abs(t(inl,il))<0.1) cycle
               is=jtsym(inl)
               do jnl=1,norb
                  if(abs(t(jnl,jl))<0.1) cycle
                  js=jtsym(jnl)
                  maxnl=max(inl,jnl)
                  minnl=min(inl,jnl)
! inl,jnl: indices or symmetrical orb (DESYMORB)                  
                  ijs=iEOR(is-1,js-1) + 1
                  jadrk=iadr_chol(maxnl*(maxnl-1)/2+minnl)
                  jadrnl=numchot(ijs-1)
                  do mu=1,numcho(ijs)
! Compute one column for exchange integral
                     chol_vec_k(jadrnl+mu)=chol_vec_k(jadrnl+mu)+
     *               chol_vec(jadrk+mu-1)*t(inl,il)*t(jnl,jl)
C                     print'(45x,7i4,4f8.4)',il,jl,inl,jnl,ijs,
C     *               jadrnl+mu,jadrk+mu-1,
C     *               chol_vec_k(jadrnl+mu),chol_vec(jadrk+mu-1),
C     *               t(inl,il),t(jnl,jl)
                  enddo
               enddo
            enddo
            !print*,'chol_vec_k',il,jl,ncho
            ajk(jl,il)=ddot(ncho,chol_vec_k,1,chol_vec_k,1)
            !print*,'ajk',il,jl,ajk(jl,il)
         enddo
      enddo
      call cpu_time(t1)
      print'(a,f12.2)','KIJ integrals computed    cpu',t1-t0


! Compute JIJ      
! Compute columns ii and jj of desymetrized orbitals
! il,jl: indices of local orbitals (of LOCCI)            
! inl,jnl: indices or symmetrical orb (DESYMORB)                  
      call cpu_time(t0)
      chol_vec_j=0.d0
      do il=1,norb
         do inl=1,norb
            if(abs(t(inl,il))<0.1) cycle
            is=jtsym(inl)
            do jnl=1,norb
               if(abs(t(jnl,il))<0.1) cycle
               js=jtsym(jnl)
               ijs=iEOR(is-1,js-1) + 1
               maxnl=max(inl,jnl)
               minnl=min(inl,jnl)
               jadrj1=iadr_chol(maxnl*(maxnl-1)/2+minnl)
               jadrj2=iadr_chol(maxnl*(maxnl-1)/2+minnl)
               jadrnl=numchot(ijs-1)
               do mu=1,numcho(ijs)
                  chol_vec_j(jadrnl+mu,il)=
     *            chol_vec_j(jadrnl+mu,il)+
     *            chol_vec(jadrj1+mu-1)*t(inl,il)*t(jnl,il)
               enddo
            enddo
         enddo
      enddo
      if(yw)print*,'chol_vec_j'
      if(yw)call mscript(chol_vec_j)
      do il=1,norb
         do jl=1,il-1
            ajk(il,jl)=ddot(ncho,chol_vec_j(:,il),1,chol_vec_j(:,jl),1)
         enddo
      enddo
      if(yw)print*,'Ajk'
      if(yw)call mscript(ajk)
      call cpu_time(t1)
      print'(a,f12.2)','JIJ integrals computed    cpu',t1-t0

! Store Coulomb and Exchange integrals in ijcl2
      call cpu_time(t0)
      open(21,file=trim(prefix)//'ijclloc2',status='unknown',
     *form='unformatted')
      write(21) ajk
      call cpu_time(t1)
      print'(a,f12.2)','KIJ and JIJ Integrals stored    cpu',t1-t0

      if(ycl) then
         do i=1,norb
            do j=1,i
               write(24,1000) i,i,j,j,ajk(i,j),2
               if(i.ne.j) write(24,1000) i,j,i,j,ajk(j,i),3
            enddo
         enddo
      endif

! Compute IJJJ, IJKK
      call cpu_time(t0)
      open(22,file=trim(prefix)//'ijclloc3',status='unknown',
     *form='unformatted')
      chol_vec_k(:)=0.d0
      n=0
      do il=1,norb
         do jl=1,norb
            if(jl==il) cycle
            chol_vec_k(:)=0.d0
            do inl=1,norb
               if(abs(t(inl,il))<0.1) cycle
               is=jtsym(inl)
               do jnl=1,norb
                  if(abs(t(jnl,jl))<0.1) cycle
                  js=jtsym(jnl)
                  maxnl=max(inl,jnl)
                  minnl=min(inl,jnl)
! inl,jnl: indices or symmetrical orb (DESYMORB)                  
                  ijs=iEOR(is-1,js-1) + 1
                  jadrk=iadr_chol(maxnl*(maxnl-1)/2+minnl)
                  jadrnl=numchot(ijs-1)
                  do mu=1,numcho(ijs)
! Compute one column for exchange integral
                     chol_vec_k(jadrnl+mu)=chol_vec_k(jadrnl+mu)+
     *               chol_vec(jadrk+mu-1)*t(inl,il)*t(jnl,jl)
C                     print'(45x,7i4,4f8.4)',il,jl,inl,jnl,ijs,
C     *               jadrnl+mu,jadrk+mu-1,
C     *               chol_vec_k(jadrnl+mu),chol_vec(jadrk+mu-1),
C     *               t(inl,il),t(jnl,jl)
                  enddo
               enddo
            enddo
! IJJJ            
            ajk(il,jl)=ddot(ncho,chol_vec_k,1,chol_vec_j(:,jl),1)
            if(yw)print'(a,2i4,f8.4)','Aijjj',il,jl,ajk(il,jl)
! IJKK            
            if(jl>il) cycle
            ij=(il-1)*(il-2)/2+jl
            do kl=1,norb
               if(kl==il) cycle
               if(kl==jl) cycle
               aijkk(kl,ij)=ddot(ncho,chol_vec_k,1,chol_vec_j(:,kl),1)
               if(yw)
     *         print'(20x,a,3i4,f8.4)','Aijkk',kl,il,jl,aijkk(kl,ij)
            enddo
         enddo
      enddo
      call cpu_time(t1)
      print'(a,f12.2)','IJJJ and IJKK integrals computed    cpu',t1-t0

! Compute IKJK     
! IKJK            
      call cpu_time(t0)
      do kl=1,norb
         chol_vec_j=0.d0
! Compute norb columns for exchange integral Cholesky vectors 
! (kl,jl=1,norb)
         do jl=1,norb
            if(jl==kl) cycle
            do knl=1,norb
               if(abs(t(knl,kl))<0.1) cycle
               ks=jtsym(knl)
               do jnl=1,norb
                  if(abs(t(jnl,jl))<0.1) cycle
                  js=jtsym(jnl)
                  maxnl=max(knl,jnl)
                  minnl=min(knl,jnl)
! inl,jnl: indices of symmetrical orb (DESYMORB)                  
                  ijs=iEOR(ks-1,js-1) + 1
                  kadrj=iadr_chol(maxnl*(maxnl-1)/2+minnl)
                  kadrnl=numchot(ijs-1)
                  !print'(a,20i3)','jtsym',jtsym
                  !print'(a,20i5)','kadrnl',kadrnl
                  !print'(a,20i5)','kadrj',kadrj
                  !print'(a,20i5)','maxnl,minnl',maxnl,minnl
                  do mu=1,numcho(ijs)
                     chol_vec_j(kadrnl+mu,jl)=chol_vec_j(kadrnl+mu,jl)+
     *               chol_vec(kadrj+mu-1)*t(knl,kl)*t(jnl,jl)
C                     print'(45x,7i4,4f8.4)',il,jl,inl,jnl,ijs,
C     *               jadrnl+mu,jadrk+mu-1,
C     *               chol_vec_m(jadrnl+mu),chol_vec(jadrk+mu-1),
C     *               t(inl,il),t(jnl,jl)
                  enddo
               enddo
            enddo
         enddo
         if(yw)print*,'chol_vec_j pour indice k=',kl
         if(yw)call mscript(chol_vec_j)
! Cholesky Vectors (kl,:) have been computed
! compute integrals IKJK
         do il=1,norb
            if(kl==il) cycle
            do jl=1,il-1
               if(kl==jl) cycle
               if(yw)print'(a,20f8.4)','chol_vec_kj',
     *         chol_vec_j(1:ncho,jl)
               if(yw)print'(a,20f8.4)','chol_vec_ki',
     *         chol_vec_j(1:ncho,il)
               aii=ddot(ncho,chol_vec_j(1,il),1,
     *         chol_vec_j(1,jl),1) 
               if(yw)print'(20x,a,3i4,f12.8)','Aikjk',kl,il,jl,aii
! store 3 index integrals
               if(itest(1)==1) then
                  loci(1)=kl
                  loci(2)=il
                  loci(3)=jl
                  call locsymint3(loci,ibon)
                  if(ibon/=0) cycle
                  if(yw)print*,'GARDEEE'
               endif
               n=n+1
               iint(n)=kl
               jnt(n)=il
               knt(n)=jl
               ij=(il-1)*(il-2)/2+jl
               aaint(2,n)=aijkk(kl,ij)
               aaint(1,n)=aii
               if(n==4096) then
                  write(22) iint,jnt,knt,aaint(1:2,:)
                  if(ycl) then
                     do l=1,n
                        jj=max(jnt(l),knt(l))
                        ll=min(jnt(l),knt(l))
                        ii=iint(l)
                        if(ii>jj) then
                           write(24,1000) ii,ii,jj,ll,aaint(1,l),14
                           write(24,1000) ii,jj,ii,ll,aaint(2,l),15
                        else if(ii>ll) then                      
                           write(24,1000) jj,ll,ii,ii,aaint(1,l),16
                           write(24,1000) jj,ii,ii,ll,aaint(2,l),17
                        else if(ii<ll) then                      
                           write(24,1000) jj,ll,ii,ii,aaint(1,l),18
                           write(24,1000) jj,ii,ll,ii,aaint(2,l),19
                        endif
                     enddo
                  endif
            
                  n=0
               endif
            enddo
         enddo
      enddo
      call cpu_time(t1)
      print'(a,f12.2)','IKJK integrals computed    cpu',t1-t0
      if(ycl) then
         do l=1,n
            jj=max(jnt(l),knt(l))
            ll=min(jnt(l),knt(l))
            ii=iint(l)
            if(ii>jj) then
               write(24,1000) ii,ii,jj,ll,aaint(1,l),24
               write(24,1000) ii,jj,ii,ll,aaint(2,l),25
            else if(ii>ll) then
               write(24,1000) jj,ll,ii,ii,aaint(1,l),26
               write(24,1000) jj,ii,ii,ll,aaint(2,l),27
            else if(ii<ll) then
               write(24,1000) jj,ll,ii,ii,aaint(1,l),28
               write(24,1000) jj,ii,ll,ii,aaint(2,l),29
            endif
         enddo
      endif
      n=n+1
      iint(n)=0
      jnt(n)=0
      knt(n)=0
      write(22) iint,jnt,knt,aaint(1:2,:)
      close(22)

! Store IJJJ in ijcl2
      write(21) ajk

      if(ycl) then
         do i=1,norb
            do j=1,i-1
               if(ajk(i,j)/=0.d0) write(24,1000) i,j,j,j,ajk(i,j),30
            enddo
            do j=i+1,norb
               if(ajk(i,j)/=0.d0) write(24,1000) j,j,j,i,ajk(i,j),31
            enddo
         enddo
      endif

      deallocate(chol_vec_k,chol_vec_m,chol_vec_j)
 1000 format(4i4,d20.12,i7)
      end





!*****************************************************
      subroutine int_4(chol_vec,iadr_chol,L_Chol,numcho,t,jtsym
     *,numchot)
!
! Compute 4 index integrals
!
      use module
      use moddi
      use mod_script
      include '../../param/maxlong.prm'
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(10000) namel
      integer(8) :: iadr_chol(norb*(norb+1)/2),l_chol
      integer(8) :: mu,n,jadrk,jadrnl
      allocatable yl2(:,:)
      integer jtsym(norb)
      integer(2) :: iint(4096),jnt(4096),knt(4096),lnt(4096)
      real(8) aaint(3,4096)
      real(8) t(norb,norb)
      integer numcho(8),numchot(0:8)
      real(8) chol_vec(*)
      integer loci(4)
      character(80) aa
      character(4) liens
      character(80) pair_file
      integer,allocatable :: ityp(:)
      yw=.false.
      !print*,'entree int_4'

      allocate(yl(norb,norb))
      allocate(yl2(norb,norb))

!
! Transformation of Cholesky Vectors
! Only large vectors are stored, according to the value of Kij
! and the values of the thresholds
!

! Thresholds      
      rewind 93
      inquire(93,name=namel)
      call LECNAM('&IJKLOC ',namel,93,ierr,1)
      sli=0.000001
      sli1=0.000001
      sli2=0.000001
      if(all_linked) then
         if(index(namel,'SLID=')==0) then
            print*,'ALL_LINKED=T, please give SLID'
            stop
         endif
         call nameld(namel,slid,'SLID',8)
         sli=slid
         sli1=slid
         sli2=slid
         write(aa,'(f20.8)') slid 
         call titre('ALL_LINKED#SLID='//trim(aa)//'#',50)
      else
         if(index(namel,'SLI=')==0) then
            call nameld(namel,sli1,'SLI1',8)
            call nameld(namel,sli2,'SLI2',8)
            print'(a,d12.5)',' sli1=',sli1
            print'(a,d12.5)',' sli2=',sli2
         else
            call nameld(namel,sli,'SLI',8)
            sli1=sli
            sli2=sli
            print'(a,d12.5)',' sli= ',sli
            print'(a,d12.5)',' sli1=',sli1
            print'(a,d12.5)',' sli2=',sli2
         endif
      endif
! Read 'liens' (liens='FILE' or liens='KIJ')
      liens='KIJ'
      pair_file='PAIR_FILE'
      call namela(namel,LIENS,'LIENS')
      call namela(namel,PAIR_FILE,'PAIR_FILE')

! Orbital interaction matrix
      rewind 21
      read(21) ajk
      call pairs(sli1,sli2,yl,yl2,norb,ajk,pair_file,
     *liens,stop,noac,numac)
! Size of Cholesky matrix for localized orbitals
      n=0
      do i=1,norb
         yl(i,i)=.true.
         do j=1,i-1
         if(yw)print*,ajk(j,i),sli1,sli2
            !if(ajk(j,i)>sli1) then
            if(yl(j,i)) then
               n=n+1
            else
            endif
         enddo
      enddo
      if(yw)print*,'n',n
      print*,' '
      print*,'Allocate Cholesky Vectors'
      print*,'size:'
      print*,'nb of Cholesky vectors=',ncho
      print*,'nb of interacting pairs of local orbitals',n
      print'(a,i12,a,f10.1,a)',
     *'--> size:',ncho*n,' real*8      --> ',1.d0*(ncho*n*8)/10**6,' Mb'
      print*,' '
      allocate(chol_vec_l(ncho,n))
      allocate(iadr_chol_l(norb*(norb+1)/2))
      if(yw)call mscript(yl)
      if(yw)call mscript(t)


!*********************************************
! Transform Cholesky vectors
! Fill Cholesky vectors for localized orbitals
!*********************************************
      n=0
      do il=1,norb
         do jl=1,il-1
            if(.not.yl(il,jl)) cycle
            n=n+1
            chol_vec_l(:,n)=0.d0
! il,jl: indices of local orbitals (of LOCCI)            
            do inl=1,norb
               if(abs(t(inl,il))<0.1) cycle
               is=jtsym(inl)
               do jnl=1,norb
                  if(abs(t(jnl,jl))<0.1) cycle
                  js=jtsym(jnl)
                  maxnl=max(inl,jnl)
                  minnl=min(inl,jnl)
! inl,jnl: indices or symmetrical orb (DESYMORB)                  
                  ijs=iEOR(is-1,js-1) + 1
                  jadrk=iadr_chol(maxnl*(maxnl-1)/2+minnl)
C                  if(yw) print'(a,5i4)',
C     *            'iadr_chol',il,jl,inl,jnl,jadrk
                  jadrnl=numchot(ijs-1)
                  !print*,allocated(chol_vec)
                  do mu=1,numcho(ijs)
! Compute column n of Cholesky Vector
                     chol_vec_l(jadrnl+mu,n)=chol_vec_l(jadrnl+mu,n)
     *               +chol_vec(jadrk+mu-1)*t(inl,il)*t(jnl,jl)
C                     print'(a,3i4,2f8.4)','chol_vec_l'
C     *               ,jadrnl+mu,n,jadrk+mu-1,chol_vec(jadrk+mu-1)
C     *               ,chol_vec_l(jadrnl+mu,n)
                  enddo
               enddo
            enddo
            iadr_chol_l(il*(il-1)/2+jl)=n
            if(yw)print*,'Iadr_chol_l',il,jl,il*(il-1)/2+jl,n
         enddo
      enddo
      if(yw)print*,'iadr_chol_l'
      if(yw)print'(10i5)',iadr_chol_l
      if(yw)print*,'chol_vec_l'
      if(yw)call mscript(chol_vec_l)


!*******************************************
! Compute integrals with 4 different indices
!*******************************************

!   CIS Only?
      ycis=.false.
      call namell(namel,YCIS,'YCIS',1)
      if(ycis) then
         print*,' '
         print*,'*******  Integrals fo CI of singles only! *******'
         print*,' '
         allocate (ityp(norb))
         ityp(1:ninac)=1
         ityp(ninac+1:ninac+noac)=2
         ityp(ninac+noac+1:norb)=3
      endif

! open integral file
      open(22,file=trim(prefix)//'ijclloc4',status='unknown',
     *form='unformatted')
      if(maxlong_modif<0) maxlong_modif=maxlong

      call filesplit('OPEN',22,maxlong_modif,idum,idum2)
      n=0
      do i=4,norb
         loci(1)=i
         do j=3,i-1
            loci(2)=j
            do k=2,j-1
               loci(3)=k
               do l=1,k-1
                  loci(4)=l
                  if(ycis) then
                     ! CIS calculation
                     if(count(ityp(loci(1:4))==3)>2) print'(a,20i4)',
     * 'elim3',i,j,k,l,ityp(loci)
                     if(count(ityp(loci(1:4))==1)>2) print'(a,20i4)',
     * 'elim1',i,j,k,l,ityp(loci)
       !print'(a,20i4)','INT',i,j,k,l,ityp(loci),count(ityp(loci(1:4))>2)
                     if((count(ityp(loci(1:4))==1)>2)) cycle 
                     if((count(ityp(loci(1:4))==3)>2)) cycle 
                  endif
                  if(itest(1)==1) then
                     call locsymint(loci,ibon)
                     if(ibon/=0) cycle
                  endif
! Type 1    (ikjl)    i>j>k>l
                  ystore1=.false.
                  if(yl(i,k)) then
                     if(yl(j,l)) then
                        ystore1=yl2(i,j).or.yl2(i,l).or.
     *                  yl2(k,j).or.yl2(k,l)
                     endif
                  endif
!
! Type 2    (iljk)    i>j>k>l
                  ystore2=.false.
                  if(yl(i,l)) then
                     if(yl(j,k)) then
                        ystore2=yl2(i,j).or.yl2(i,k).or.
     *                  yl2(l,j).or.yl2(l,k)
                     endif
                  endif
!
! Type 3    (ijkl)    i>j>k>l
                  ystore3=.false.
                  if(yl(i,j)) then
                     if(yl(k,l)) then
                        ystore3=yl2(i,k).or.yl2(i,l).or.
     *                  yl2(j,k).or.yl2(j,l)
                     endif
                  endif
!
! Store if one integral at least is to be kept
                  if(all_linked) then
                      if(ystore1.and.ystore2.and.ystore3) then
                         if(yw) print'(a,4i4,3l2)','ystore',i,j,k,l,
     *                   ystore1,ystore3,ystore3
C                         ystore=.true.
                         n=n+1
                         iint(n)=i
                         jnt(n)=j
                         knt(n)=k
                         lnt(n)=l
                         aaint(1,n)=ai2(i,k,j,l)
                         aaint(2,n)=ai2(i,l,j,k)
                         aaint(3,n)=ai2(i,j,k,l)
                         if(yw)print'(a,4i4,3f12.8)','4 Ind ',
     *                   i,j,k,l,aaint(:,n)
                         if(n==4096) then
                            call filesplit('WRITE',22,131072,
     *                      ichange,idum2)
                            if(ycl) then
                               call wcl2(n,iint,jnt,knt,lnt,aaint)
                            endif
                            write(22)iint,jnt,knt,lnt,aaint
                            n=0
                         endif
                      endif
                  else
                      if(ystore1.or.ystore2.or.ystore3) then
                         if(yw) print'(a,4i4,3l2)','ystore',i,j,k,l,
     *                   ystore1,ystore3,ystore3
C                         ystore=.true.
                         n=n+1
                         iint(n)=i
                         jnt(n)=j
                         knt(n)=k
                         lnt(n)=l
                         if(ystore1) then
                            aaint(1,n)=ai2(i,k,j,l)
                         else
                            aaint(1,n)=0.d0
                         endif
                         if(ystore2) then
                            aaint(2,n)=ai2(i,l,j,k)
                         else
                            aaint(2,n)=0.d0
                         endif
                         if(ystore3) then
                            aaint(3,n)=ai2(i,j,k,l)
                         else
                            aaint(3,n)=0.d0
                         endif
                         if(yw)print'(a,4i4,3f12.8)','4 Ind ',
     *                   i,j,k,l,aaint(:,n)
                         if(n==4096) then
                            call filesplit('WRITE',22,131072,
     *                      ichange,idum2)
                            if(ycl) then
                               call wcl2(n,iint,jnt,knt,lnt,aaint)
                            endif
                            write(22)iint,jnt,knt,lnt,aaint
                            n=0
                         endif
                      endif
                  endif
               enddo
            enddo
         enddo
      enddo
      if(ycl) then
         call wcl2(n,iint,jnt,knt,lnt,aaint)
      endif
      n=n+1
      iint(n)=0
      jnt(n)=0
      knt(n)=0
      lnt(n)=0
      write(22)iint,jnt,knt,lnt,aaint
      close(22)

      print*,' '
 1000 format(4i4,d20.12,i7)
      end

!**************************************************************
       subroutine lire2(v,n,ifil)
      Implicit none
      integer(8),parameter :: nblock=2048
      real(8) v(n)
      integer(8) n,ideb,ifin,i
      integer ifil
      ifin=0
      do i=1,n,nblock
         ideb=ifin+1
         ifin=min(ifin+nblock,n)
         !print*,'i,n,ideb,ifin',i,n,ideb,ifin
         read(ifil) v(ideb:ifin)
      enddo
      end

!**************************************************************
       subroutine adr_chol1(nsym,isym,iadr_chol,numcho,norb)
!
! Address Cholesky Vectors
! orb (i,j)  -->  iadr_chol(i,j)=beginning of column (i,j) in
! the cholesky vectors
!
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer(8) iadr_chol(norb*(norb+1)/2),k
      integer isym(8),numcho(8)
      logical yw
      yw=.false.
      k=1
      kk=0
      do is12=1,nsym
         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
                     i1=max(i,j)
                     j1=min(i,j)
                     if(i1/=i) stop'i1'
                     if(j1/=j) stop'j1'
                     iadr_chol(i1*(i1-1)/2+j1)=k
                     kk=kk+1
                     if(yw)print'(a,7i3,2i6)',
     *               'iadr_chol',is12,is1,is2,i1,j1,iii,jj,kk,k
                     k=k+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
                     i1=max(i,j)
                     j1=min(i,j)
                     if(i1/=j) stop'i1'
                     if(j1/=i) stop'j1'
                     kk=kk+1
                     if(yw)print'(a,7i3,2i6)',
     *               'iadr_chol',is12,is1,is2,i1,j1,iii,jj,kk,k
                     iadr_chol(i1*(i1-1)/2+j1)=k
                     k=k+numcho(is12)
                  enddo
               enddo
            endif
         enddo
      enddo
      end
       function ai2(i,j,k,l)
      use module
      Implicit Real*8 (a-h,o-z)
      logical yw
      integer(8) :: ij,kl
      yw=.false.
      ij=iadr_chol_l(i*(i-1)/2+j)
      kl=iadr_chol_l(k*(k-1)/2+l)
      if(yw)
     *write(6,'(a,4i4,3x,2i10,3x,3i10)')'AI2',i,j,k,l,ij,kl,ncho
      if(yw)write(6,'(a)')'CV'
      if(yw)write(6,'(10f8.4)')chol_vec_l(:,ij)
      if(yw)write(6,'(a)')'CV'
      if(yw)write(6,'(10f8.4)')chol_vec_l(:,kl)
      ai2=ddot(ncho,chol_vec_l(1,ij),1,chol_vec_l(1,kl),1)
      end
!***************************************************************************
       subroutine ech2(i,j)
      ii=i
      i=j
      j=ii
      end
!***************************************************************************
       subroutine wcl2(n,iint,jnt,knt,lnt,aaint)
      integer(2) iint(*),jnt(*),knt(*),lnt(*)
      integer(8) n
      real(8) aaint(3,n)
      do k=1,n
         ii=max(iint(k),knt(k))
         kk=min(iint(k),knt(k))
         jj=max(jnt(k),lnt(k))
         ll=min(jnt(k),lnt(k))
         if(ii<jj) then
            call ech2(ii,jj)
            call ech2(kk,ll)
         endif
         write(24,1000) ii,kk,jj,ll,aaint(1,k),41
         ii=max(iint(k),lnt(k))
         ll=min(iint(k),lnt(k))
         jj=max(jnt(k),knt(k))
         kk=min(jnt(k),knt(k))
         if(ii<jj) then
            call ech2(ii,jj)
            call ech2(kk,ll)
         endif
         write(24,1000) ii,ll,jj,kk,aaint(2,k),42
         ii=max(iint(k),jnt(k))
         jj=min(iint(k),jnt(k))
         kk=max(lnt(k),knt(k))
         ll=min(lnt(k),knt(k))
         if(ii<kk) then
            call ech2(ii,kk)
            call ech2(jj,ll)
         endif
         write(24,1000) ii,jj,kk,ll,aaint(3,k),43
      enddo
 1000 format(4i4,d20.12,i7)
      end
!***************************************************************************
       subroutine isitcholesky
      use module
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      character(10000) namel
      character(80) pair_file
      character(4) liens
      logical lex
      !  print*,'entree isitcholesky'

!
! decide if this is a Cholesky run:
! ychol is given in data or not?
!
      rewind 93
      call LECNAM('&IJKLOC ',namel,93,ierr,1)
      call namela(namel,PREFIX,'PREFIX')
      if(index(namel,'YCHOL=')==0) then
         inquire(FILE='CHMOT1_',EXIST=lex)
         if(lex) then
            namel=' '
            call addchar(namel,
     *      'Ychol is not given, but file CHMOT1_ exists#')
            call addchar(namel,
     *      'This is supposed to be a Cholesky run!#')
            call titre(namel,60)
            ychol=.true.
         else
            ychol=.false.
            return
         endif
      else
         call namell(namel,YCHOL,'YCHOL',4)
         if(ychol) then
            namel=' '
            call addchar(namel,
     *      'Ychol is given in data, ychol=T#')
            call addchar(namel,
     *      'Cholesky run#')
            call titre(namel,60)
         endif
      endif
      if(.not.ychol) return
!

!
! This is a Cholesky run: Prepare data for chol_X
! write it to file IFILIN_CHOL
!
      close(94)
      open(94,file='IFILIN_CHOL',status='unknown')
      write(94,'(a)') " &chol out='CHOL' "
      inquire(93,name=namel)
      rewind 93
      call LECNAM('&IJKLOC ',namel,93,ierr,0)
      sli=0.001
      sli1=0.001
      sli2=0.0001
      if(index(namel,'SLI=')==0) then
         call nameld(namel,sli1,'SLI1',8)
         call nameld(namel,sli2,'SLI2',8)
      else
         call nameld(namel,sli,'SLI',8)
         sli1=sli
         sli2=sli
      endif
      liens='KIJ'
      call namela(namel,LIENS,'LIENS')
      call namela(namel,PREFIX,'PREFIX')
      stop=' '
      call namela(namel,STOP,'STOP')
      pair_file='PAIR_FILE'
      call namela(namel,PAIR_FILE,'PAIR_FILE')
      write(94,'(3a)') " stop='",trim(stop)//" '"
      write(94,'(3a)') " liens='",liens,"'"
      write(94,'(3a)') " pair_file='",trim(pair_file),"'"
      write(94,'(a,d12.6,a,d12.6)') " sli1=",sli1,",sli2=",sli2
      write(94,'(a)') " prefix='"//trim(prefix)//"'"
      write(94,'(a)') " /"
      rewind 94
      close(93)
!

!
! call chol_X (desymmetrisation of Cholesky vectors)
!
      call titre('call to chol_X#',50)
      call chol_X2(94,numac)

! clear
      close(94,status='delete')
      close(93)
      open(93,file='BID_IJKLOC_93',status='old')
      !  print*,'sortie 3 isitcholesky'
      end


!***************************************************************************
       subroutine shift_chol_vec(chol_vec,nsym,isym,noa,frozen,delete,
     *numcho,l_chol)
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer isym(8),isymloc(8)
      integer frozen(8)
      integer delete(8)
      integer numcho(8)
      real(8) chol_vec(*)
      !real(8) chol_vec(l_chol)
      integer(8) l_chol,ll,llv,numcho_is12
      logical(1),allocatable :: yfrdel(:)
      allocate(yfrdel(noa))
      isymloc=isym+frozen+delete
      yw=.false.

!
! shift Cholesky Vectors
!


! 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.
         enddo
         do i=1+frozen(is),isymloc(is)-delete(is)
            ii=ii+1
            yfrdel(ii)=.false.
         enddo
         do i=isymloc(is)-delete(is)+1,isymloc(is)
            ii=ii+1
            yfrdel(ii)=.true.
         enddo
      enddo
      !print*,'yfrdel',yfrdel

! shift


      ll=1
      llv=1
      !print*,'shape',shape(chol_vec)
      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,isymloc(is1)
                  i=sum(isymloc(1:is1-1))+iii
                  do jj=1,iii
                     j=sum(isymloc(1:is2-1))+jj
                     !print*,'i,j',i,j,numcho_is12 
                     if(yfrdel(i).or.yfrdel(j)) then
                        llv=llv+numcho_is12 
                        cycle
                     endif
                     !print*,'OK',ll,llv
! shift chol_vec                     
                     chol_vec(ll:ll+numcho_is12 -1)=
     *               chol_vec(llv:llv+numcho_is12 -1)
                     !print*,'chol_vec',is12,is1
                     !print'(10f8.4)',chol_vec(ll:ll+numcho_is12 -1)

! increment indices                     
                     ll=ll+numcho_is12 
                     llv=llv+numcho_is12 
                  enddo
               enddo
            else
               do jj=1,isymloc(is2)
                  j=sum(isymloc(1:is2-1))+jj
                  do iii=1,isymloc(is1)
                     i=sum(isymloc(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
      !L_Chol=ll-1
      deallocate(yfrdel)
      end
