      subroutine semi_active_int(namel)
      use chol_X
      use mod_script
      use mod_lirorb
!
!------------------------------------------------------------
! semi_active integrals, to perform loccascf 
!
! Cele 
!   1      J(i,j) and K(i,j) integrals, two core indices  
!          (iijj)   (ijij)
!   2      Two active and two core (equal) indices
!          (iiab)    (iaib)
!   3      J(i,j) and K(i,j) integrals, one core and one virtual indices
!          (iivv)   (iviv)
!   4      Two active and two virtual (equal) indices
!          (abvv)   (avbv)
!   5      Four active indices
!          (abcd)
!   6      One virtual and three core (2 equal) indices
!          (ijjv)   (iijv)
!   7      One virtual, two active and one core indices
!          (abiv)   (aibv)
!   8      One virtual, one active and two core (equal) indices
!          (iiav)   (iaiv)
!   9      One virtual, three active indices
!          (abcv)
!  10      One active and three core (2 equal) indices
!          (iija)   (iaij)
!  11      One core, three active indices
!          (iabc)
!--------------------------------------------------------------
!
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      character(*) namel
      include '../../param/maxlong.prm'

      call titre('Semi-Active Calculation#',60)

! Open ijcl integral file
      maxlong_modif=maxlong
      call filesplit('OPEN',1,maxlong_modif,idum,idum2)
      open(1,file=trim(prefix)//'ijcl',status='unknown',
     *form='unformatted')

! Read data concerning CAS
      call nameli(namel,INACT,'INACT',4)
      call nameli(namel,NACTEL,'NACTEL',4)
      call nameli(namel,ACT,'ACT',4)
      print'(a,8i4)','Inactive orbitals (Inact)  ',inact(1:nsym)
      print'(a,8i4)','Active orbitals (act)      ',act(1:nsym)
      print'(a,8i4)','Number of Active Electrons',nactel

! Compute isymt
      isymt=0
      do is=1,nsym-1
         isymt(is+1)=isymt(is)+isym(is)
      enddo

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

! reorder orbitals: inacttive, active, virtual
      call caliord(nsym,isym,inact,act,iord,iord1,norb)
      print*,'iord'
      print'(10i4)',iord
      print*,'iord1'
      print'(10i4)',iord1
      print*,'isym'
      print'(8i4)',isym
      print*,'isymt'
      print'(8i4)',isymt
      print*,'itsym'
      print'(10i4)',itsym
      print*,'fermi'
      print'(10i4)',fermi


! Call integral calculation
C      print*,'satout'
C      call satout
C      call stosa(0,0,0,0)
C      return



      print*,'sa1_3'
      if(ycl) write(24,'(a)') 'sa1_3'
      call sa1_3
      print*,'sa2'
      if(ycl) write(24,'(a)') 'sa2'
      call sa2
      print*,'sa4'
      if(ycl) write(24,'(a)') 'sa4'
      call sa4
      print*,'sa5'
      if(ycl) write(24,'(a)') 'sa5'
      call sa5
      print*,'sa6'
      if(ycl) write(24,'(a)') 'sa6'
      call sa6
      print*,'sa7'
      if(ycl) write(24,'(a)') 'sa7'
      call sa7
      print*,'sa8'
      if(ycl) write(24,'(a)') 'sa8'
      call sa8
      print*,'sa9_11'
      if(ycl) write(24,'(a)') 'sa9_11'
      call sa9_11
      print*,'sa10'
      if(ycl) write(24,'(a)') 'sa10'
      call sa10

      call stosa(0,0,0,0)
      end


       subroutine sa1_3
!
!-------------------------------------------------------------
!   1      J(i,j) and K(i,j) integrals, two core indices  
!          (iijj)   (ijij)
!   3      J(i,j) and K(i,j) integrals, one core a one virtual indices
!          (iivv)   (iviv)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer is,js,ii,i,jj,j,jend,vv,v

      do is=1,nsym
         do js=1,nsym
            do ii=1,inact(is)
               i=isymt(is)+ii
               call endloop(is,js,ii,jend,inact,nsym)
               if(is>=js) then
                  do jj=1,jend
                     j=isymt(js)+jj
                     call stosa(i,i,j,j)
                     if(i/=j) call stosa(i,j,i,j)
                  enddo
               endif
               do vv=inact(js)+act(js)+1,isym(js)
                  v=isymt(js)+vv
                  call stosa(v,v,i,i)
                  call stosa(v,i,v,i)
               enddo
            enddo
         enddo
      enddo
      end
                  
       subroutine sa2
!
!-------------------------------------------------------------
!   2      Two active and two core (equal) indices
!          (iiab)    (iaib)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,as,a,bb,b,is,ii,i
      do is=1,nsym
         do as=1,nsym
            do ii=1,inact(is)
               i=isymt(is)+ii
               do aa=inact(as)+1,inact(as)+act(as)
                  a=isymt(as)+aa
                  do bb=inact(as)+1,aa
                     b=isymt(as)+bb
                     call stosa(a,b,i,i)
                     call stosa(a,i,b,i)
                  enddo
               enddo
            enddo
         enddo
      enddo
      end

                  
       subroutine sa4
!
!-------------------------------------------------------------
!   4      Two active and two virtual (equal) indices
!          (abvv)   (avbv)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,as,a,bb,b,vs,v,vv
      do as=1,nsym
         do vs=1,nsym
            do aa=inact(as)+1,inact(as)+act(as)
               a=isymt(as)+aa
               do bb=inact(as)+1,aa
                  b=isymt(as)+bb
                  do vv=inact(vs)+act(vs)+1,isym(vs)
                     v=isymt(vs)+vv
                     call stosa(v,v,a,b)
                     call stosa(v,a,v,b)
                  enddo
               enddo
            enddo
         enddo
      enddo
      end

                  
       subroutine sa5
!
!-------------------------------------------------------------
!   5      Four active indices
!          (abcd)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,bb,cc,dd,as,bs,cs,ds,a,b,c,d,bend,cend,dend,bas
      do as=1,nsym
         do bs=1,as
            bas=ieor(as-1,bs-1) + 1
            do cs=1,bs
               ds=ieor(cs-1,bas-1) + 1
               if(ds>cs) cycle
               do aa=inact(as)+1,inact(as)+act(as)
                  a=isymt(as)+aa
                  call endloop(as,bs,aa,bend,inact+act,nsym)
                  do bb=inact(bs)+1,bend
                     b=isymt(bs)+bb
                     call endloop(bs,cs,bb,cend,inact+act,nsym)
                     do cc=inact(cs)+1,cend
                        c=isymt(cs)+cc
                        call endloop(cs,ds,cc,dend,inact+act,nsym)
                        do dd=inact(ds)+1,dend
                           d=isymt(ds)+dd
                           call stosa(a,b,c,d)
                           if(c/=b.and.a/=d) then
                              call stosa(a,c,b,d)
                              if(d/=b.and.a/=c.and.a/=b.and.c/=d)
     *                        call stosa(a,d,b,c)
                           endif
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
      end

                  
       subroutine sa6
!
!-------------------------------------------------------------
!   6      One virtual and three core (2 equal) indices
!          (ijjv)   (jijv)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer vs,vv,v,js,jj,j,ii,i
      do vs=1,nsym
         do js=1,nsym
            do ii=1,inact(vs)
               i=isymt(vs)+ii
               do jj=1,inact(js)
                  j=isymt(js)+jj
                  do vv=inact(vs)+act(vs)+1,isym(vs)
                     v=isymt(vs)+vv
                     call stosa(v,j,max(j,i),min(j,i))
                     if(i/=j)call stosa(v,i,j,j)
                  enddo
               enddo
            enddo
         enddo
      enddo
      end

                  
       subroutine sa7
!
!-------------------------------------------------------------
!   7      One virtual, two active and one core indices
!          (viab)  (vabi)  (vbai)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,as,a,bb,bs,b,vv,vs,v,is,ii,i,bend,bas
      do as=1,nsym
         do bs=1,as
            bas=iEOR(as-1,bs-1) + 1
            do is=1,nsym
               vs=iEOR(is-1,bas-1) + 1
C               print'(a,20i4)','sa71sym',as,bs,is,vs
               do aa=inact(as)+1,inact(as)+act(as)
                  a=isymt(as)+aa
                  call endloop(as,bs,aa,bend,inact+act,nsym)
C                  print*,'a',a,bend,inact(bs)
                  do bb=inact(bs)+1,bend
                     b=isymt(bs)+bb
C                     print*,'b',b
                     do ii=1,inact(is)
                        i=isymt(is)+ii
C                        print*,'i',i
                        do vv=inact(vs)+act(vs)+1,isym(vs)
                           v=isymt(vs)+vv
C                           print*,'v',v
C               print'(a,20i4)','sa71',v,i,a,b,vs,as,bs,is,vv,aa,bb,ii
C     * ,inact(vs),act(vs)
C               print'(a,4i4)','sa72',v,b,a,i
C               if(a/=b)print'(a,4i4,f12.8)','sa73',v,a,b,i
C               print*,'iord1',iord1((/v,i,a,b/))
                           call stosa(v,i,a,b)
                           call stosa(v,b,a,i)
                           if(a/=b) call stosa(v,a,b,i)
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
      end

       subroutine sa8
!
!-------------------------------------------------------------
!   8      One virtual, one active and two core (equal) indices
!          (iiav)   (iaiv)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,as,vs,a,b,v,vv,is,ii,i
      do is=1,nsym
         do as=1,nsym
            do ii=1,inact(is)
               i=isymt(is)+ii
               do aa=inact(as)+1,inact(as)+act(as)
                  a=isymt(as)+aa
                  do vv=inact(as)+act(as)+1,isym(as)
                     v=isymt(as)+vv
                     call stosa(v,a,i,i)
                     call stosa(v,i,a,i)
                  enddo
               enddo
            enddo
         enddo
      enddo
      end


       subroutine sa9_11
!
!-------------------------------------------------------------
!   9      One virtual, three active indices
!          (abcv)
!  11      One core, three active indices
!          (iabc)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,bb,cc,vv,as,bs,cs,vs,a,b,c,v,bend,cend,ii,i,bas
      do as=1,nsym
         do bs=1,as
            bas=ieor(as-1,bs-1) + 1
            do cs=1,bs
               vs=ieor(bas-1,cs-1) + 1
               do aa=inact(as)+1,inact(as)+act(as)
                  a=isymt(as)+aa
                  call endloop(as,bs,aa,bend,inact+act,nsym)
                  do bb=inact(bs)+1,bend
                     b=isymt(bs)+bb
                     call endloop(bs,cs,bb,cend,inact+act,nsym)
                     do cc=inact(cs)+1,cend
                        c=isymt(cs)+cc
                        do vv=inact(vs)+act(vs)+1,isym(vs)
                           v=isymt(vs)+vv
                           call stosa(v,c,a,b)
                           if(b/=c) call stosa(v,b,a,c)
                           if(a/=c.and.a/=b) call stosa(v,a,b,c)
                        enddo
                        do ii=1,inact(vs)
                           i=isymt(vs)+ii
                           call stosa(a,b,c,i)
                           if(b/=c) call stosa(a,c,b,i)
                           if(a/=c.and.a/=b) call stosa(a,i,b,c)
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
      end
                  
       subroutine sa10
!
!-------------------------------------------------------------
!  10      One active and three core (2 equal) indices
!          (iija)   (iaij)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,as,a,jj,j,is,ii,i
      do as=1,nsym
         do is=1,nsym
            do ii=1,inact(is)
               i=isymt(is)+ii
               do jj=1,inact(as)
                  j=isymt(as)+jj
                  do aa=inact(as)+1,inact(as)+act(as)
                     a=isymt(as)+aa
                     call stosa(a,j,i,i)
                     if(i/=j) call stosa(a,i,max(i,j),min(i,j))
                  enddo
               enddo
            enddo
         enddo
      enddo
      end



       subroutine stosa(i,j,k,l)
      use chol_X
      Implicit Real*8 (a-h,o-x,z),logical*1(y)
      integer,save :: n=0
      integer(2),save :: imt(4096),jmt(4096),kmt(4096),lmt(4096)
      real(8),dimension(4096),save :: bint
      if(i==0) then
         n=n+1
         imt(n)=0
         jmt(n)=0
         kmt(n)=0
         lmt(n)=0
         call filesplit('WRITE',1,131072,ichange,idum2)
         write(1)imt,jmt,kmt,lmt,bint
      else
         n=n+1
         imt(n)=iord1(i)
         jmt(n)=iord1(j)
         kmt(n)=iord1(k)
         lmt(n)=iord1(l)
            if(imt(n)<jmt(n)) call ech(imt(n),jmt(n))
            if(kmt(n)<lmt(n)) call ech(kmt(n),lmt(n))
            if(imt(n)<kmt(n).or.(imt(n)==kmt(n).and.jmt(n)<lmt(n))) then
               call ech(imt(n),kmt(n))
               call ech(jmt(n),lmt(n))
            endif
         bint(n)=ai(i,j,k,l)
         if(ycl) then
            i1=imt(n)
            j1=jmt(n)
            k1=kmt(n)
            l1=lmt(n)
            if(i1<j1) call ech(i1,j1)
            if(k1<l1) call ech(k1,l1)
            if(i1<k1.or.(i1==k1.and.j1<l1)) then
               call ech(i1,k1)
               call ech(j1,l1)
            endif
            write(24,'(4i4,d20.12)') 
     *      i1,j1,k1,l1,bint(n)
         endif
C         print'(4i3,2x,4i4,f12.8)'
C     *   ,i,j,k,l,imt(n),jmt(n),kmt(n),lmt(n),bint(n)
         if(n==4096) then
            call filesplit('WRITE',1,131072,ichange,idum2)
            write(1)imt,jmt,kmt,lmt,bint
            n=0
         endif
      endif
      end

   
       subroutine satout
!
!-------------------------------------------------------------
!   5      Toutes les integrales
!          (abcd)
!-------------------------------------------------------------
!
      use chol_X
      use mod_script
      use mod_lirorb
      Implicit none
      integer aa,bb,cc,dd,as,bs,cs,ds,a,b,c,d,bend,cend,dend,bas
      do as=1,nsym
         do bs=1,as
            bas=ieor(as-1,bs-1) + 1
            do cs=1,bs
               ds=ieor(cs-1,bas-1) + 1
               if(ds>cs) cycle
               do aa=1,isym(as)
                  a=isymt(as)+aa
                  call endloop(as,bs,aa,bend,isym,nsym)
                  do bb=1,bend
                     b=isymt(bs)+bb
                     call endloop(bs,cs,bb,cend,isym,nsym)
                     do cc=1,cend
                        c=isymt(cs)+cc
                        call endloop(cs,ds,cc,dend,isym,nsym)
                        !print'(a,7i4)','end',bend,cend,dend,as,bs,cs,ds
                        do dd=1,dend
                           d=isymt(ds)+dd
                           call stosa(a,b,c,d)
                           if(c/=b.and.a/=d) call stosa(a,c,b,d)
                           if(d/=b.and.c/=d.and.a/=b)
     *                     call stosa(a,d,b,c)
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
      end
