!**************************************************************************
      subroutine chol_X2(ifilin,numac)
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      character(10000) namel
      integer,dimension(8) :: infr
      character c
      character(80) stop,pair_file
      character(4) liens
      allocatable one1(:,:)
      integer(8) npq_x_numv_int8,ll
      integer :: numac(*)
      yw=.false.
      call sto5_1(ifilin,93,'BID93_CHOL')
!
! Preliminary
!
      print*,' '
      print*,'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
      print*,' '
      
!
! Read project/prefix
!
      call system('echo $Project > PROJECT')
      open(1,file='PROJECT',status='old')
      read(1,'(a)') prefix
      prefix=trim(adjustl(prefix))//'.'
      print*,'Prefix= ',trim(prefix)
      close(1,status='delete')


!
!-------------------------------
! reading input data
!-------------------------------
!

      print*,' '
      rewind 93
      inquire(93,name=namel)
      call LECNAM('&CHOL',namel,93,ierr,1)
      if(ierr==1) stop'error in reading namelist &CHOL'
      sli=0.001
      sli1=0.001
      sli2=0.0001
      frozen=0
      delete=0
      fermi=0
      semi_active=.false.
      act=0
      inact=0
      ycl=.false.
      output_files='INT'
      yfrozenendonnee=index(namel,'FROZEN=')>0
      ydeleteendonnee=index(namel,'DELETE=')>0
      yfermiendonnee=index(namel,'FERMI=')>0
      yactendonnee=index(namel,'ACT=')>0
      call nameli(namel,FROZEN,'FROZEN',4)
      call nameli(namel,DELETE,'DELETE',4)
      call nameli(namel,FERMI,'FERMI',4)
      call namell(namel,YCL,'YCL',4)
      call namell(namel,SEMI_ACTIVE,'SEMI_ACTIVE',4)
      call namela(namel,output_files,'OUT')
      call nameli(namel,INACT,'INACT',4)
      call nameli(namel,ACT,'ACT',4)
      call namela(namel,PREFIX,'PREFIX')
      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
      endif
      stop=' '
      call namela(namel,STOP,'STOP')
      pair_file='PAIR_FILE'
      call namela(namel,PAIR_FILE,'PAIR_FILE')
      liens='KIJ'
      call namela(namel,LIENS,'LIENS')
!
!-------------------------------
! Read Info from molcost
!-------------------------------
!
!	write(6,*) "leo molcost"
! Read Info from MO_ONEINT, file created by molcost
      open(1,file='MO_ONEINT',status='old',form='unformatted')
      read(1) norb,nsym
      allocate(one(norb,norb))
      read(1) one
      read(1) isym(1:nsym),numcho(1:nsym),potnuc,nb_ijcl
      print*,'numcho',numcho
      print*,'nb_ijcl',nb_ijcl
      if(.not.yfermiendonnee) then
         read(1)fermi(1:nsym)
         print*,'Fermi is read from file MO_ONEINT'
         backspace(1)
      endif
      if(.not.yfrozenendonnee) then
         read(1)frozen(1:nsym),frozen(1:nsym)
         if(any(frozen/=0)) print*,
     *   'FROZEN is read from molcost run'
         backspace(1)
      endif
      if(.not.ydeleteendonnee) then
         read(1)delete(1:nsym),delete(1:nsym),delete(1:nsym)
         if(any(delete/=0)) print*,
     *   'DELETE is read from molcost run'
         backspace(1)
      endif
      if(.not.yactendonnee) then
         read(1)act(1:nsym),act(1:nsym),act(1:nsym),act(1:nsym)
         if(any(delete/=0)) print*,
     *   'ACT is read from molcost run'
         backspace(1)
      endif
      if(.not.yactendonnee) then
         read(1)inact(1:nsym),inact(1:nsym),inact(1:nsym),inact(1:nsym)
     *   ,inact(1:nsym)
         if(any(delete/=0)) print*,
     *   'INACT is read from molcost run'
      endif

      if(all(act==0)) then
         if(all(inact==0)) then
            inact=fermi
            print*,'No active, inact takes the value fermi'
         else
            if(any(inact/=fermi)) then
               print*,'no active, fermi/=ninac impossible'
               stop
            endif
         endif
      endif

      close(1)
      print'(a30,8i5)',"Number of orbitals per symetry",isym(1:nsym)
      print'(a30,8i5)',"Frozen Orbitals",frozen(1:nsym)
      print'(a30,8i5)',"Deleted Orbitals",delete(1:nsym)
      print'(a30,8i5)',"Fermi level",fermi(1:nsym)
      print'(a30,8i5)',"inact",inact(1:nsym)
      print'(a30,8i5)',"act",act(1:nsym)
      print'(a30,l4)',"semi_active",SEMI_ACTIVE
      print*,' '

! Once norb is known, allocate!
      allocate(iord(norb))
      allocate(iord1(norb))
      allocate(il(norb,norb))
      allocate(yfrdel(norb))
      allocate(yfr(norb))

!
!from isym and fermi, compute iord
!(correspondance between molcas order (by symmetries)
! and CI order (Occ - virt or Occ - Act -Virt)
!
      !call caliord(nsym,isym,fermi+frozen,iord,iord1,norb)
      infr=inact+frozen
      call caliord(nsym,isym,infr,act,iord,iord1,norb)
      !print'(a)','Iord'
      !print'(20i4)',iord
      !print'(20i4)',iord1
! one was not reordered in molcost, reorder here
      !call mscript(one)
      !one=one(iord(1:norb),iord(1:norb))
      !call mscript(one)

!
! Compute itsym (symmetry of orbitals)
!
      allocate(itsym(norb))
      call calitsym(nsym,itsym,isym,norb)
      !print'(a)','itsym'
      !print'(20i4)',itsym
      !print'(20i4)',itsym(iord)
C      call nameli(namel,itsym,'ITSYM',4)
      !print'(20i4)',itsym
      
!
!---------------------------------------------------------------------
! compute mpq (number of rows of the Cholesky matrix of symm is1,is2)
!---------------------------------------------------------------------
!
      call calmpq(nsym,L_Chol,mpq,isym,numcho)
      L_Chol0=L_Chol
      if(yw)print'(a,8i6)',' isym',isym(1:nsym)
      if(yw) print*,'Mpq '
!     if(yw) call mscript(mpq)
      print*,' '
      print*,'/////////////////////////////////////////////////////////'
      print*,' '
!
!------------------------
! Read Cholesky Vectors
!------------------------
!
      !write(6,*) "leo vector cholesky"
      open(20,file='CHOL_VEC',form='unformatted',status='old')
      ll=0
      numv=0
      npq=0
      print*,'memoire (en bytes) allouee pour le vecteur Cholesky : '
     *,l_chol
      allocate(Chol_Vec(L_Chol))
      size_chol_vec=l_chol
      !print*,'alloc',allocated(Chol_Vec)
      do
         ! read a block of cholesky vectors for pq pairs, where:
         ! jsym=symmetry of pq pairs
         ! isymp=symmetry of p orbitals
         ! numv=length of cholesky vetors for this blok
         ! npq=nb of pq pairs (=mpq(isymp,isymq))
         read(20,end=1) jsym,isymp,numv,npq
         ! npq*numv could overflow as integer(4). Compute npq_x_numv_int8
         npq_x_numv_int8=1
         npq_x_numv_int8=npq_x_numv_int8*npq
         npq_x_numv_int8=npq_x_numv_int8*numv
!         print*,
!     *   'jsym,isymp,numv,npq',jsym,isymp,numv,npq,npq_x_numv_int8
!         print*,'npq*numv',npq_x_numv_int8,Npq,Numv
!	 write(6,*) "chol_vec(ll+1)", chol_vec(ll+1)
         call lir(chol_vec(ll+1),npq_x_numv_int8,20)
C         call script(chol_vec(ll+1:ll+Npq*Numv),numv,npq,numv,npq)
         !write(6,*) "salgo lir"
         ll=ll+npq_x_numv_int8
      enddo
 1    continue
      if(yw) print*,'k=1 a ll par pas de 10 - ll=',ll,'chol_vec'
      if(yw) print*,'chol_vec pour k=1 a 10:  ',chol_vec(1:10)
      do k=1,ll,10
         if(yw) print'(i9,11f9.4)',k,chol_vec(k:k+9)
      enddo
      close(20)
!
! Address Cholesky Vectors
! Compute iadr_chol(i,j)
! pair (i,j)  -->  iadr_chol(i,j)=beginning of column (i,j) in
! the cholesky vectors
!
      allocate(iadr_chol(norb*(norb+1)/2))
      call adr_chol(nsym,isym,iadr_chol,numcho,norb)
      !print*,'ONE'
      !call mscript(one)
      !stop

!
!
! Frozen and deleted orbitals
! modify potnuc and one-electron integrals
! 
      if(any(frozen/=0).or.any(delete/=0)) call frdel

!
! store One-Int matrix
!
      open(1,file=trim(prefix)//'Mono',status='old',form='unformatted')
      do
         read(1,end=3)
      enddo
 3    continue
! Nadia : pour le dimere de Jesus l'appel a ecriS plante / Essai en
! ajoutant backspace et en remplacant one par one1
      backspace(1)
      allocate(one1(norb,norb))
      one1=one(1:norb,1:norb)
      call ecriS(-1,one1,norb,trim(prefix)//'Mono','Chol_X',.false.,
     *nsym,isym,iord1)
      deallocate(one1)

!    call ecriS(-1,one(1:norb,1:norb),norb,trim(prefix)//'Mono',
!         *'Chol_X',.false.,nsym,isym,iord1)
! Fin Nadia

!
! Semi_active Calculation?
!
      if(semi_active) then
         call semi_active_int(namel)
         goto 1100
      endif

      


! Compute exchange integrals


      allocate(ajk(norb,norb))
      ajk=0.d0
      do i=1,norb
            ajk(i,i)=ai(i,i,i,i)
C            print'(a,4i4,f20.8)','Int Ech',i,i,i,i,aii
         do j=1,i-1
            aii=ai(i,j,i,j)
            ajk(j,i)=ai(i,j,i,j)
C            print'(a,4i4,f20.8)','Int Ech',i,j,i,j,aii
         enddo
      enddo
      if(yw) call mscript(ajk)

!
!
! Build interacting orbital matrix
! orbital neighbouring
!
      allocate(interint(norb,norb))
      allocate(interint2(norb,norb))
      if(output_files/='CHOL') 
     *call pairs(sli1,sli2,interint,interint2,norb,ajk,pair_file,
     *liens,stop,0,numac)


!
! If output_files=='INT '(data "out" in &chol ), compute Integrals
! If output_files=='CHOL '(data "out" in &chol ), transform Cholesky 
! vectors
!

      if(output_files=='CHOL') then
         call w_exchange
      else if(output_files=='INT ') then
         call calint
      else
         print*,'OUT does not have a correct value (INT or CHOL)'
         print*,'OUT=',output_files
         stop
      endif
!
! append cost_MO namelist to Info file
!
 1100 continue

      call ecr_cost_mo

      if(ycl) then
         allocate(one1(norb,norb))
         do i=1,norb
            do j=1,norb
               one1(j,i)=one(iord(j),iord(i))
            enddo
         enddo
         !one=one(iord(1:norb),iord(1:norb))
         do i=1,norb
            do j=1,i
            if(itsym(i)==itsym(j)) write(24,1000) i,j,0,0,one1(i,j),20
            enddo
         enddo
         write(24,1000) 0,0,0,0,potnuc,21
 1000    format(4i4,d20.12,i7)
      endif

C      print*,allocated(one)
C      print*,allocated(iord)
C      print*,allocated(iord1)
C      print*,allocated(il)
C      print*,allocated(yfrdel)
C      print*,allocated(itsym)
C      print*,allocated(chol_vec)
C      print*,allocated(iadr_chol)
C      print*,allocated(ajk)
      if(output_files/='CHOL')
     *call ecrocc(nsym,isym,fermi,frozen,itsym,iord
     *,act,inact,delete,norb)


      deallocate(one,iord,iord1,il,yfrdel,itsym,Chol_Vec,iadr_chol)
      if(.not.semi_active) then
         deallocate(ajk)
         if(output_files=='INT ')
     *   deallocate(interint,interint2)
      endif
      call titre('End Chol_X#',40)
      end

!**************************************************************************
       subroutine w_exchange
      use chol_X
      use mod_script
      include '../../param/maxlong.prm'
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      logical yw
      yw=.false.
      open(23,file=trim(prefix)//'ijcl2',form='unformatted',
     *status='unknown')
      open(25,file='CHOL_VEC_ijkloc',status='unknown',
     *form='unformatted')
!
!--------------------------------------------------------------
! Symmetrize Exchange Integrals and write them to ijcl2 file
! (This is a file for ijkloc! Coulomb integrals will be computed
! later, in ijkloc)
!--------------------------------------------------------------
!
      do i=1,norb
         do j=1,i-1
            ajk(i,j)=ajk(j,i)
         enddo
      enddo
      if(yw)print*,'exch in chol_X'
      if(yw)call mscript(ajk)
      write(23) ajk
      return
      end




!**************************************************************************
       subroutine calint
      use chol_X
      use mod_script
      include '../../param/maxlong.prm'
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      logical yw
C**************************************************
      MulD2h(i,j) = iEOR(i-1,j-1) + 1
C**************************************************
      yw=.false.
      if(ycl) open(24,status='unknown',file=trim(prefix)//'IJCL')
 1000 format(4i4,d20.12,i7)
!
! Compute Coulomb Integrals
!
      call cpu_time(t0)
      open(23,file=trim(prefix)//'ijcl2',form='unformatted',
     *status='unknown')
      do i=1,norb
         do j=1,i
            aii=ai(i,i,j,j)
            ajk(i,j)=aii
         enddo
      enddo 
      if(yw)print*,'AJK'
      if(yw)call mscript(ajk)
      allocate(ajk1(norb,norb))
      do i=1,norb
         ajk1(i,i)=ajk(iord(i),iord(i))
         do j=1,i-1
            ajk1(j,i)=ajk(max(iord(i),iord(j)),min(iord(i),iord(j)))
            ajk1(i,j)=ajk(min(iord(i),iord(j)),max(iord(i),iord(j)))
         enddo
      enddo
      ajk=ajk1
      deallocate(ajk1)
      if(yw)call mscript(ajk)
      write(23) ajk
      if(ycl) then
         do i=1,norb
            do j=1,i
               write(24,1000) ((/i,i,j,j/)),ajk(j,i)
               if(i.ne.j) write(24,1000) ((/i,j,i,j/)),ajk(i,j)
            enddo
         enddo
      endif
      call cpu_time(t1)
      print'(a,f12.2)','Coulomb Integrals computed    cpu',t1-t0

!
! Compute other 2-index Integrals
!
      call cpu_time(t0)
      allocate(aijjj(norb,norb))
      do i=1,norb
         do j=1,norb
            if(itsym(i)==itsym(j)) then
               aijjj(i,j)=ai(i,j,j,j)
            else
               aijjj(i,j)=0.d0
            endif
         enddo
      enddo 
      if(yw)print*,'AIJJJ'
      if(yw)call mscript(aijjj)
      aijjj=aijjj(iord,iord)
      if(yw)call mscript(aijjj)
      write(23) aijjj
      close(23)
      if(ycl) then
         do i=1,norb
            do j=1,i-1
               if(aijjj(i,j)/=0.d0) write(24,1000) 
     *         ((/i,j,j,j/)),aijjj(i,j)
            enddo
            do j=i+1,norb
               if(aijjj(i,j)/=0.d0) write(24,1000) 
     *         ((/j,j,j,i/)),aijjj(i,j)
            enddo
         enddo
      endif
      deallocate(aijjj)
      call cpu_time(t1)
      print'(a,f12.2)','Other 2-index int computed    cpu',t1-t0

!
! Compute 3-index Integrals
!
      call cpu_time(t0)
      open(22,file=trim(prefix)//'ijcl3',form='unformatted',
     *status='unknown')
      n=0
      do j=1,norb
         do k=1,j-1
            if(itsym(k)/=itsym(j)) cycle
            do i=1,norb
               if(i==j) cycle
               if(i==k) cycle
               n=n+1
               iint(n)=i
               jnt(n)=j
               knt(n)=k
               aaint(2,n)=ai(i,j,i,k)
               aaint(1,n)=ai(i,i,j,k)
               if(yw)print'(a,3i4,2f10.6)','3 Ind:  ',i,j,k
     *         ,aaint(1:2,n)
C               print'(a,3i4,2f10.6)','3 Ind:  ',iord(i),iord(j),iord(k)
C     *         ,aaint(1:2,n)
               if(n==4096) then
                  iint=iord1(iint)
                  jnt=iord1(jnt)
                  knt=iord1(knt)
                  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),4
                           write(24,1000) ii,jj,ii,ll,aaint(2,l),5
                        else if(ii>ll) then                       
                           write(24,1000) jj,ll,ii,ii,aaint(1,l),6
                           write(24,1000) jj,ii,ii,ll,aaint(2,l),7
                        else if(ii<ll) then                       
                           write(24,1000) jj,ll,ii,ii,aaint(1,l),8
                           write(24,1000) jj,ii,ll,ii,aaint(2,l),9
                        endif
                     enddo
                  endif
                  n=0
               endif
            enddo
         enddo
      enddo
      iint(1:n)=iord1(iint(1:n))
      jnt(1:n)=iord1(jnt(1:n))
      knt(1:n)=iord1(knt(1:n))
      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=n+1
      iint(n)=0
      jnt(n)=0
      knt(n)=0
      write(22) iint,jnt,knt,aaint(1:2,:)
      close(22)
      call cpu_time(t1)
      print'(a,f12.2)','3-Index Integrals computed    cpu',t1-t0


!
! Compute 4-index Integrals
!
      call cpu_time(t0)
      n=0
      open(22,file=trim(prefix)//'ijcl4',form='unformatted',
     *status='unknown')
      maxlong_modif=maxlong
      call filesplit('OPEN',22,maxlong_modif,idum,idum2)
      call filesplit('WRITE',22,4,ichange,idum2)
      write(22) maxlong_modif
!  boucles sur les 4 indices differents
! ii,jj,kk,ll sont les indices a ecrite sur fichiers (ordonnes par occ)
! i,j,k,l sont les indices de travail de chol_X (ordonnes par sym)
      do ii=4,norb
         i=iord(ii)
         isi=itsym(i)
         do jj=3,ii-1
            j=iord(jj)
            isj=itsym(j)
            isij=muld2h(isi,isj)
            do kk=2,jj-1
               k=iord(kk)
               isk=itsym(k)
               isijk=muld2h(isij,isk)
               do ll=1,kk-1
                  l=iord(ll)
                  isl=itsym(l)
                  if(isl/=isijk) cycle
                  if(yw)
     *            print'(a,4i4,3x,4i4,3x,4i4)','isijkl',isi,isj,isk,isl
     *            ,ii,jj,kk,ll,i,j,k,l
!
! Type 1    (ijkl)    i>j>k>l
                  ystore1=.false.
                  if(interint(i,j)) then
                     if(interint(k,l)) then
                        ystore1=interint2(i,k).or.interint2(i,l).or.
     *                  interint2(j,k).or.interint2(j,l)
                     endif
                  endif
!
! Type 2    (iljk)    i>j>k>l
                  ystore2=.false.
                  if(interint(i,l)) then
                     if(interint(j,k)) then
                        ystore2=interint2(i,j).or.interint2(i,k).or.
     *                  interint2(l,j).or.interint2(l,k)
                     endif
                  endif
!
! Type 3    (ikjl)    i>j>k>l
                  ystore3=.false.
                  if(interint(i,k)) then
                     if(interint(j,l)) then
                        ystore3=interint2(i,j).or.interint2(i,l).or.
     *                  interint2(k,j).or.interint2(k,l)
                     endif
                  endif
!
! Store if one integral at least is to be kept
                  if(ystore1.or.ystore2.or.ystore3) then
                     ystore=.true.
                     n=n+1
                     iint(n)=ii
                     jnt(n)=jj
                     knt(n)=kk
                     lnt(n)=ll
                     if(ystore1) then
                        aaint(1,n)=ai(i,k,j,l)
                     else
                        aaint(1,n)=0.d0
                     endif
                     if(ystore2) then
                        aaint(2,n)=ai(i,l,j,k)
                     else
                        aaint(2,n)=0.d0
                     endif
                     if(ystore3) then
                        aaint(3,n)=ai(i,j,k,l)
                     else
                        aaint(3,n)=0.d0
                     endif
C                     if(yw)print'(a,4i4,3f12.8)','4 Ind  ',
C     *               iord(i),iord(j),iord(k),iord(l),aaint(:,n)
                     if(yw)print'(a,4i4,2x,4i4,2x,4i4,3f12.8)','4 Ind ',
     *               ii,jj,kk,ll,i,j,k,l,iord((/ii,jj,kk,ll/))
     *               ,aaint(:,n)
                     if(n==4096) then
                        call filesplit('WRITE',22,131072,
     *                  ichange,idum2)
                        if(ycl) then
                           call wcl(n,iint,jnt,knt,lnt,aaint)
                        endif
                        write(22)iint,jnt,knt,lnt,aaint
                        n=0
                     endif
                  endif
               enddo
            enddo
         enddo
      enddo
      call cpu_time(t1)
      print'(a,f12.2)','R4-Index Integrals computed    cpu',t1-t0

      if(ycl) then
         call wcl(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
      print*,'ecriture de fin',n
      close(22)

      end
!**************************************************************************
       subroutine endloop(isi,isj,iii,jend,isym,nsym)
      dimension isym(nsym)
      if(isi==isj) then
         jend=iii
      else
         jend=isym(isj)
      endif
      return
      end
      
       function ai(i,j,k,l)
      use chol_X
      implicit none
      real(8) ai,ai1
      integer i,j,k,l,isi,isj,isk,isl,isij
      isi=itsym(i)
      isj=itsym(j)
      isij=iEOR(isi-1,isj-1) + 1
      isk=itsym(k)
      isl=itsym(l)
      ai=ai1(max(i,j),min(i,j),max(k,l),min(k,l),max(isi,isj),
     *min(isi,isj),isij)
      return
      end
       function ai1(i,j,k,l,isi,isj,isij)
      use chol_X
      implicit none
      real(8) :: ai1,ddot
      integer i,j,k,l,isi,isj,isk,isl,isij
      integer(8) ij,kl
      logical yw
      yw=.false.
      ij=iadr_chol(i*(i-1)/2+j)
      kl=iadr_chol(k*(k-1)/2+l)
      if(yw)
     *write(6,'(a,4i4,3x,2i12,3x,3i8,3i12)')'AI',i,j,k,l,ij,kl
     *,numcho(isij),Mpq(isi,isj),isij,size(chol_vec)
     *,numcho(isij)+ij,numcho(isij)+kl
      call flush(6)
      if(ij>size_chol_vec) then
         print*,'ij>size(chol_vec)',ij,size_chol_vec
         stop
      endif
      if(kl>size_chol_vec) then
         print*,'kl>size(chol_vec)',kl,size_chol_vec
         stop
      endif
      if(yw)write(6,'(a)')'CV'
      if(yw)write(6,'(10f8.4)')chol_vec(ij:ij+numcho(isij)-1)
      if(yw)write(6,'(a)')'CV'
      if(yw)write(6,'(10f8.4)')chol_vec(kl:kl+numcho(isij)-1)
      
      ai1=ddot(numcho(isij),chol_vec(ij),1,chol_vec(kl),1)
      end
!**************************************************************************
       subroutine lir(v,n,ifil)
      Implicit none
      integer(8),parameter :: nblock=2048
      real(8) :: v(n)
      integer(8) :: n
      integer(8) :: ideb,ifin
      integer ifil
      ifin=0
!	write(6,*) "en lir"
      do
         ideb=ifin+1
         ifin=ifin+nblock
         if(ifin<n) then
            read(ifil) v(ideb:ifin)
         else if(ifin>=n) then
            read(ifil) v(ideb:n)
            exit
         endif
      enddo
      end
!**************************************************************************
       subroutine ecrir(v,n,ifil)
      parameter (nblock=2048)
      Implicit Real*8 (a-h,o-z)
      dimension v(n)
      do
         ideb=ifin+1
         ifin=ifin+nblock
         if(ifin<n) then
            write(ifil) v(ideb:ifin)
         else if(ifin>n) then
            write(ifil) v(ideb:n),(0.d0,k=n+1,ifin)
            exit
         else if(ifin==n) then
            write(ifil) v(ideb:ifin)
            exit
         endif
      enddo
      end


!**************************************************************************
       subroutine ecr_cost_mo
      !
      ! append cost_MO namelist to Info file
      !
      use chol_X
      Implicit Real*8 (a-h,o-z)
      character(100000) namel

      open(2,file=trim(prefix)//'Info',status='old')
      call LECNAM('&COST_AO',namel,2,ierr,0)
 1    continue
      print*,' '
      print*,'--------------------------------'
      print*,'Appending &cost_MO to Info file:'
      print*,'--------------------------------'
      print*,' '
      write(2,'(a)') ' &cost_MO'
      write(2,'(a)') ' ychol=t, '
      write(6,'(a8,8(i7,'',''))') ' numcho=',numcho(1:nsym)
      write(2,'(a8,8(i7,'',''))') ' numcho=',numcho(1:nsym)
      write(2,'(a8,i8)')' n_ijcl=',nb_ijcl
      write(6,'(a8,i8)')' n_ijcl=',nb_ijcl
      if(output_files=='CHOL') write(2,'(a,i11)') ' L_Chol=',L_Chol0
      if(output_files=='CHOL') write(6,'(a,i11)') ' L_Chol=',L_Chol0
      !write(2,'(a7,8(i3,'',''))') ' fermi=',fermi(1:nsym)
      noc=sum(fermi(1:nsym))
      !write(6,'(a7)') ' iord='
      !write(6,'(1x,40(10(i3,'',''),/,1x))')(iord(i),i=1,norb)
      !write(2,'(a7)') ' iord='
      !write(2,'(1x,40(10(i3,'',''),/,1x))')(iord(i),i=1,norb)
      write(6,'(a6,i1,a6,i4,a5,i4)')' nsym=',nsym,',norb='
     *,norb,',noc=',noc
! reorder itsym to Occ firs, virt after
      write(6,'(a7)') ' itsym=...'
      !write(6,'(1x,20(20(i1,'',''),/,1x))')(itsym(i),i=1,norb)
      itsym=(itsym(iord)) 
      !write(6,'(a7)') ' itsym='
      !write(6,'(1x,60(20(i1,'',''),/,1x))')(itsym(i),i=1,norb)
      write(2,'(a6,i1,a6,i4,a5,i4)')' nsym=',nsym,',norb='
     *,norb,',noc=',noc
      write(2,'(a7)') ' itsym='
      write(2,'(1x,60(20(i1,'',''),/,1x))')(itsym(i),i=1,norb)
! Nadia Le nb d'orbitales peut depasser la centaine... Jesus en a plus
! de 1000 / passer de i3 a i4
      write(2,'(a6,8(i4,'',''))') ' isym=',isym(1:nsym)
      write(2,'(a8,8(i4,'',''))') ' frozen=',frozen(1:nsym)
      write(2,'(a8,8(i4,'',''))') ' delete=',delete(1:nsym)
! Fin Nadia
      write(2,'(a6,d20.12)')' enuc=',potnuc
      write(6,'(a6,d20.12)')' enuc=',potnuc
      write(2,'(a5,l1)')' ycl=',ycl
      write(6,'(a5,l1)')' ycl=',ycl
      write(2,'(a5)') ' &end'
      write(6,'(a2)') ' /'
      print*,'End building Info file'
      print*,' '
      end
!**************************************************************************
       subroutine ech(i,j)
      ii=i
      i=j
      j=ii
      end
!**************************************************************************
       subroutine wcl(n,iint,jnt,knt,lnt,aaint)
      integer(2) iint(n),jnt(n),knt(n),lnt(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 ech(ii,jj)
            call ech(kk,ll)
         endif
         write(24,1000) ii,kk,jj,ll,aaint(1,k),1
         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 ech(ii,jj)
            call ech(kk,ll)
         endif
         write(24,1000) ii,ll,jj,kk,aaint(2,k),2
         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 ech(ii,kk)
            call ech(jj,ll)
         endif
         write(24,1000) ii,jj,kk,ll,aaint(3,k),3
      enddo
 1000 format(4i4,d20.12,i7)
      end


!**************************************************************************

       subroutine caliord(nsym,isym,inact,act,iord,iord1,norb)
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer isym(nsym),inact(nsym),iord(norb),iord1(norb)
      integer act(nsym)
      k=0
      l=0
      !print*,'caliord inact',inact
      !print*,'caliord act ',act 
      do is=1,nsym
         do i=1,inact(is)
            k=k+1
            l=l+1
            iord(k)=l
            !print*,'occ k,iord(k)',k,iord(k)
         enddo
         l=l+isym(is)-inact(is)
      enddo
      l=0
      do is=1,nsym
         l=l+inact(is)
         do i=inact(is)+1,inact(is)+act(is)
            k=k+1
            l=l+1
            iord(k)=l
            !print*,'act k,iord(k)',k,iord(k)
         enddo
         l=l+isym(is)-inact(is)-act(is)
      enddo
      l=0
      do is=1,nsym
         l=l+inact(is)+act(is)
         do i=inact(is)+act(is)+1,isym(is)
            k=k+1
            l=l+1
            iord(k)=l
            !print*,'vir k,iord(k)',k,iord(k)
         enddo
      enddo
      do i=1,norb
         iord1(iord(i))=i
      enddo
      !print'(a)','Iord sa'
      !print'(20i4)',iord
      !print'(20i4)',iord1
      return
      end
!**************************************************************************
       subroutine calitsym(nsym,itsym,isym,norb)
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer itsym(norb),isym(nsym)
      k=0
      do is=1,nsym
         do i=1,isym(is)
            k=k+1
            itsym(k)=is
         enddo
      enddo
      end

!**************************************************************************
       subroutine calmpq(nsym,L_Chol,mpq,isym,numcho)
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer isym(nsym),mpq(8,8),numcho(8)
      integer(8) l_chol,i8,iprod8
      MulD2h(i,j) = iEOR(i-1,j-1) + 1
      i8=1
      L_Chol=0
      do is1=1,nsym
         do is2=1,is1
            if(is1==is2) then
               mpq(is1,is2)=isym(is1)*(isym(is1)+1)/2
               !print*,'1 mpq',is1,is2,mpq(is1,is2)
            else
               mpq(is1,is2)=isym(is1)*isym(is2)
               !print*,'2 mpq',is1,is2,mpq(is1,is2)
            endif
            iprod8=i8*mpq(is1,is2)
            !print*,'iprod8',iprod8
            iprod8=iprod8*numcho(muld2h(is1,is2))
            !print*,'iprod8',iprod8
            l_chol=l_chol+iprod8
            !print*,'l_chol',l_chol
            !l_chol=l_chol+mpq(is1,is2)*numcho(muld2h(is1,is2))
!            print*,'l_chol',muld2h(is1,is2),numcho(muld2h(is1,is2)),
!     *      mpq(is1,is2)*numcho(muld2h(is1,is2)),l_chol,isym(is1)
!     *      ,isym(is2)
        enddo
      enddo
      !write(6,*) "en calmpq, l_chol=", l_chol
      end

!**************************************************************************
       subroutine adr_chol(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)
      k=1
      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
!                     print'(a,7i8,i13)',
!     *               'iadr_chol1',is12,is1,is2,i1,j1,iii,jj,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'
!                     print'(a,7i8,i13)',
!     *               'iadr_chol2',is12,is1,is2,i1,j1,iii,jj,k
                     iadr_chol(i1*(i1-1)/2+j1)=k
                     k=k+numcho(is12)
                  enddo
               enddo
            endif
         enddo
      enddo
      !print*,'fin_iadrchol',k
      end
!**************************************************************************
       subroutine pairs(sli1,sli2,jnterint,jnterint2,norb,ajk,pair_file,
     *liens,stop,noac,numac)
       !****************************************************
       ! ATTENTION ! Cette subroutine sert aussi dans ijkloc
       !****************************************************
      use mod_script
      use mod_lirorb
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      logical(1) jnterint(norb,norb),jnterint2(norb,norb)
      dimension ajk(norb,norb),numac(noac)
      allocatable nvois(:),yac(:)
      character(*) pair_file,liens,stop
      allocate(nvois(norb))
!
! computing yac, active orbtals
!
      allocate(yac(norb))
      yac=.false.
      if(noac>0) then
         yac(numac(:))=.true.
      endif
      
!
!
! Build interacting orbital matrix
! orbital neighbouring
!
C      open(21,status='unknown',file='CHOL_X_PAIRS',form='unformatted')
      print*,' '
      print*,'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
      print*,' '
      print*,'                         Pairs'
      if(liens=='KIJ') then
         print*,'                       liens=KIJ'
         jnterint=.false.
         npair=0
         npair2=0
         do i=1,norb
            do j=1,i-1
               aii=ajk(j,i)
               if(yac(i).and.yac(j)) then
                  jnterint(i,j)=.true.
                  jnterint(j,i)=.true.
                  npair=npair+1
                  jnterint2(i,j)=.true.
                  jnterint2(j,i)=.true.
                  npair2=npair2+1
                  cycle
               endif
               if(aii>sli1) then
                  jnterint(i,j)=.true.
                  jnterint(j,i)=.true.
                  npair=npair+1
               endif
               if(aii>sli2) then
                  jnterint2(i,j)=.true.
                  jnterint2(j,i)=.true.
                  npair2=npair2+1
               endif
            enddo
         enddo
         open(99,file=pair_file,status='unknown',form='unformatted')
         write(99) sli1,sli2,npair,npair2,jnterint,jnterint2
         close(99)
      else if(liens=='FILE') then
         print*,'                       liens=FILE'
         open(99,file=pair_file,status='old',form='unformatted')
         read(99) sli1,sli2,npair,npair2,jnterint,jnterint2
         close(99)
      else
         print*,"liens must have the value 'KIJ' or 'FILE'"
         print*,'liens=',liens
         stop
      endif
      print*,' '
      print*,'Number of pairs (sil1,sli2)',npair,npair2
      print*,' '
      print*,'Nombre de Voisins des orbitales'
      print*,' '
      do i=1,norb
         nvois(i)=0
         do j=1,norb
            if(j==i) cycle
            if(jnterint(i,j)) nvois(i)=nvois(i)+1
         enddo
      enddo
      print'(4(i5,a,i3,6x))',(i,':',nvois(i),i=1,norb)
      de allocate(nvois)
      print*,' '
      print*,'/////////////////////////////////////////////////////////'
      print*,' '
      if(stop=='PAIRS') then
         call titre('Stop=pairs#',40)
         stop
      endif
      end
!      integer(8) function ipro8(i,j)
!      implicit integer(8) (a-z)
!      !integer(8) :: ipro8
!      ipro8=1
!      print*,'ipro8',i,j,ipro8
!      ipro8=ipro8*i
!      print*,'ipro8',i,j,ipro8
!      ipro8=ipro8*j
!      print*,'ipro8',i,j,ipro8
!      end
!      
