      SUBROUTINE tce_ao2e_cholesky_orb(rtdb,d_v2,kax_v2_alpha_offset,
     1                                 size_2e)
C     $Id: tce_ao2e_cholesky_orb.F 19706 2010-10-29 17:52:31Z d3y133 $
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
C     t ( p1 p2 h3 h4 )_t
      IMPLICIT NONE
#include "rtdb.fh"
#include "global.fh"
#include "mafdecls.fh"
#include "stdio.fh"
#include "util.fh"
#include "bas.fh"
#include "schwarz.fh"
#include "sym.fh"
#include "sf.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
c
c
      integer rtdb                 ! Run-time database
      integer d_v2                 ! MO integrals
      integer kax_v2_alpha_offset  ! MO integrals offset
      integer size_2e              ! 2e file size
c
      INTEGER size_2g2a,l_2g2a,k_2g2a
      INTEGER azone1,azone2,azone3,azone4
      INTEGER g1b,g2b,g3b,g4b
      INTEGER igi1,igi2,igi3,igi4
      INTEGER ii,i,j,k,l,N,ipos1,ipos2,ipos3,ipos4
      INTEGER del1,del2,p1rel,p2rel
      INTEGER size_4a,l_4a,k_4a
c
      integer mu,nu,rho,sigma
      integer mu_lo,mu_hi
      integer nu_lo,nu_hi
      integer rho_lo,rho_hi
      integer sigma_lo,sigma_hi
      integer mu_range
      integer nu_range
      integer rho_range
      integer sigma_range
      integer mu1,nu1,rho1,sigma1
      integer shift_mu,shift_nu
      integer shift_rho,shift_sigma
      integer work1,work2          ! Work array sizes
      integer l_work1,k_work1      ! Work array 1
      integer l_work2,k_work2      ! Work array 2
      integer imu1,inu1,irho1,isigma1
c
      integer l_movecs_orb,k_movecs_orb
      integer l_gpair,k_gpair
      integer len_pair,g12_shift
c ATTENTION,ACHTUNG,UWAGA 2000 - max # of CPU
c
      integer size_2g2z,l_2g2z,k_2g2z
      integer tot_azone1_sh,tot_azone2_sh
      integer tot_azone3_sh,tot_azone4_sh
      integer ixi,jxi,point_pair
c
      integer iha,ihb !number of corr. alpha, beta holes
      integer ipa,ipb !number of corr. alpha, beta particles
c compression
      integer max_size_temp,size_temp,sumx
      double precision wall,cpu,wall1,cpu1,wall2,cpu2,wall3,cpu3
c
      double precision tot_zone(1000)
c
      integer l_3a1m_offset,k_3a1m_offset,size_3a1mf
      integer l_1a3m_offset,k_1a3m_offset,size_1a3mf
      integer d_1a3m,d_3a1m
      integer size_3a1m
      integer l_3a1m,k_3a1m
      integer size_amc
      integer key_3a1m,offset_3a1m
      integer l_4a_sort,k_4a_sort
      integer size_2a2m,l_2a2m,k_2a2m
      integer l_3a1m_sort,k_3a1m_sort
      integer l_2a2m_aux,k_2a2m_aux
      integer key_1a3m,offset_1a3m
      integer l_1a3m,k_1a3m,size_1a3m 
      integer l_1a3m_sort,k_1a3m_sort
      INTEGER IROW,ICOL,IRES
      INTEGER INDEX_PAIR
      integer l_4m,k_4m,size_4m,key_4m,offset_4m
      integer sf3a1m_chunk,sf1a3m_chunk
c
      integer l_integral,l_coeff
      integer k_integral,k_coeff
      integer size_ic,size_icc,size_integral,size_coeff,max_na
c 
      integer l_4af_offset,k_4af_offset,d_4af
      integer k_2a2m_offset,l_2a2m_offset
      integer sf_chunk,request
      integer key_4af,offset_4af,size_4af
      integer sf2a2m_chunk,key_2a2m,offset_2a2m
      integer d_2a2m,size_2a2mf
      character*255 filename
c
      integer size_max1,size_max2,ip_max1,ip_max2
      integer chunk_max1,chunk_max2,i_from_x,i_to_x
      integer isizef(5),imaxch(5)
      integer d_max1,d_max2
c
      integer l_a4_offset,k_a4_offset
      integer offset_bl4a,size_bl4a,a4_ini,a4_fin
      integer offset_ismall,length_a4,key_ini 
      integer l_a3_offset,k_a3_offset
      integer length_a3,offset_bl3a1m,size_bl3a1m
      integer size_3a1mi,a3_ini,a3_fin
c
      integer l_a2_offset,k_a2_offset,length_a2
      integer offset_bl2a2m,size_bl2a2m,a2_ini,a2_fin
      integer size_1a3mi,size_2a2mi
c
      integer length_a1
      integer l_a1_offset,k_a1_offset
      integer offset_bl1a3m,size_bl1a3m,a1_ini,a1_fin
c I/O improvements
      integer handle_4a,handle_3a1m,handle_2a2m,handle_1a3m
c
c *** debug ***
      double precision xxx,xmax
c      integer iqx
      integer ierrcode1,ierrcode2
c *************
c 
      logical parallel
c
      INTEGER length
      INTEGER NXTASK
      INTEGER next
      INTEGER nprocs
      INTEGER count
      EXTERNAL NXTASK
      integer nxtval
      external nxtval
      logical nodezero
      logical idiskl
c
c
c
ccx      idisk=.true.
      if(idisk.eq.0) then
       idiskl=.false.
      else
       idiskl=.true.
      end if
c
      parallel = .true.
c
c
      max_size_temp=imaxsize**4
c
c
      do ii=1,1000
       tot_zone(ii)=0.0d0
      enddo
      if(atpart.gt.1000) 
     &  call errquit('tce_zones: atpart too big',1,MA_ERR)
      sumx=0
      do ii=1,atpart
       tot_zone(ii)=sumx
       sumx=sumx+nalength(ii)
      enddo
c
      nodezero=(ga_nodeid().eq.0)
c
c *** debug ***
c      if(nodezero) then
c        write(6,*)'--------- NEW LOOP STRUCTURE --------' 
c        call util_flush(6)
c      end if
c *************
c
c this module is called only if intorb = .true.
c N is the number of correlated orbitals
        N = nmo(1) - nfc(1) - nfv(1)
        iha = nocc(1)-nfc(1)
        ihb = nocc(ipol)-nfc(ipol)
        ipa = nmo(1)-nocc(1)-nfv(1)
        ipb = nmo(ipol)-nocc(ipol)-nfv(ipol)
c
      sf_chunk=(imaxsize+10)**4
      sf3a1m_chunk=((imaxsize+10)**3)*tile_dim
      sf2a2m_chunk=((tile_dim)**2)*((imaxsize+10)**2)
      sf1a3m_chunk=((tile_dim)**3)*(imaxsize+10)
c
c l_integral and l_coeff local files are opened here
c ATTENTION,ACHTUNG,UWAGA - "manually" defined
cc      size_ic=2*(imaxsize+10)**4
cc      size_ic=2*(imaxsize)**4
      max_na=0
      do ixi=1,atpart
       if(nalength(ixi).gt.max_na) max_na=nalength(ixi)
      enddo
c     it was
cc      size_ic=2*(max_na)**4+1
c it is
        size_ic=2*((max_na)**4)+1
        size_icc=tile_dim*max_na
c
       if(nodezero) then
        write(6,*)'2_EL_BATCH AND COEFF MATRIX'
        write(6,*)'size_ic',size_ic
        write(6,*)'size_icc',size_icc
        write(6,*)'tile_dim',tile_dim
        write(6,*)'max_na',max_na
        call util_flush(6)
       end if
c
      if (.not.ma_push_get(mt_dbl,size_ic,'l_int',
     1  l_integral,k_integral))
     1  call errquit('tce_4s: MA problem l_int',0,MA_ERR)
c
      if (.not.ma_push_get(mt_dbl,size_icc,'l_coeff',
     1  l_coeff,k_coeff))
     1  call errquit('tce_4s: MA problem l_coeff',0,MA_ERR)
c
       call tce_4a_offsetx2(l_4af_offset,k_4af_offset,size_4af)
       call tce_3a1m_offsetx2(l_3a1m_offset,k_3a1m_offset,size_3a1mf)
       call tce_2a2m_offsetx2(l_2a2m_offset,k_2a2m_offset,size_2a2mf)
       call tce_1a3m_offsetx2(l_1a3m_offset,k_1a3m_offset,size_1a3mf)
c
c choose two largeast size_4af,size_3a1mf,size_2a2mf,size_1a3mf,size_2e
c size_max1 > size_max2
       size_max1=0
       size_max2=0
c
       chunk_max1=0
       chunk_max2=0 
c     
       isizef(1)=size_4af
       isizef(2)=size_3a1mf
       isizef(3)=size_2a2mf
       isizef(4)=size_1a3mf
       isizef(5)=size_2e
c
       imaxch(1)=sf_chunk
       imaxch(2)=sf3a1m_chunk
       imaxch(3)=sf2a2m_chunk
       imaxch(4)=sf1a3m_chunk
       imaxch(5)=tile_dim**4
c 
       do i=1,5
        if(isizef(i).gt.size_max1) then
         size_max1=isizef(i)
         ip_max1=i
         chunk_max1=imaxch(i)
        end if
       enddo
       do i=1,5
       if(i.eq.ip_max1) go to 771
        if(isizef(i).gt.size_max2) then
         size_max2=isizef(i)
         ip_max2=i
         chunk_max2=imaxch(i)
        end if
 771   continue
       enddo
c
c CHUNK_SIZE IS PROPERLY DEFINED HERE
c
       chunk_max1=size_ic
       chunk_max2=size_ic
c
c
c
       if(nodezero) then
        write(6,*)'INTERMEDIATE FILES'
        write(6,*)'size_4af',size_4af
        write(6,*)'size_3a1mf',size_3a1mf
        write(6,*)'size_2a2mf',size_2a2mf
        write(6,*)'size_1a3mf',size_1a3mf
        write(6,*)'size_2e',size_2e
       end if 
c
c DISK USAGE ONLY !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c 
      if(idiskl) then
        if(.not.parallel) 
     1       call errquit('sf only for parallel runs',1,DISK_ERR)
cx        if(parallel) call ga_sync()
cx        call util_file_name('max1',.false.,.false.,filename)
cx        if (sf_create(filename,dfloat(bytes)*dfloat(size_max1),
cx     1    dfloat(bytes)*dfloat(size_max1),chunk_max1,d_max1).ne.0)
cx     2    call errquit('4-index: sf problem a',0,DISK_ERR)
c
cx        call util_file_name('max2',.false.,.false.,filename)
cx        if (sf_create(filename,dfloat(bytes)*dfloat(size_max2),
cx     1    dfloat(bytes)*dfloat(size_max2),chunk_max2,d_max2).ne.0)
cx     2    call errquit('4-index: sf problem b',0,DISK_ERR)
c
c       call createfile(filename,d_v2,size_2e)
c       call ga_zero(d_v2)
c
      else
       if(.not.parallel)
     1       call errquit('sf only for parallel runs',1,DISK_ERR)
       if(parallel) call ga_sync()
        if(size_4af.le.size_max2) then        
         call createfile(filename,d_max1,size_max1)
         call reconcilefile(d_max1,size_max1)
         call ga_zero(d_max1)
         call createfile(filename,d_max2,size_max2)
         call reconcilefile(d_max2,size_max2)
         call ga_zero(d_max2)
        else
         call createfile(filename,d_max2,size_max2)
         call reconcilefile(d_max2,size_max2)
         call ga_zero(d_max2)
         call createfile(filename,d_max1,size_max1)
         call reconcilefile(d_max1,size_max1)
         call ga_zero(d_max1)
        end if
      end if 
c
c
c alpha orbitals only
c
      if (.not.ma_push_get(mt_dbl,nbf*(iha+ipa)
     1  ,"sorted MO coeffs",
     2  l_movecs_orb,k_movecs_orb))
     3  call errquit('tce_mo2e_zone: MA problem 1',0,
     2    BASIS_ERR)
      call dfill(nbf*(iha+ipa),0.0d0, dbl_mb(k_movecs_orb), 1)
      do i=1,iha
      do isigma1=1,nbf
       dbl_mb(k_movecs_orb+(i-1)*nbf+isigma1-1)=
     & dbl_mb(k_movecs_sorted+(i-1)*nbf+isigma1-1)
      enddo
      enddo
      do i=iha+1,iha+ipa
      do isigma1=1,nbf
       dbl_mb(k_movecs_orb+(i-1)*nbf+isigma1-1)=
     & dbl_mb(k_movecs_sorted+(i+ihb-1)*nbf+isigma1-1)
      enddo
      enddo
c
c
      call int_mem_2e4c(work1,work2)
      if (.not.ma_push_get(mt_dbl,work1,'work1',l_work1,k_work1))
     1  call errquit('tce_ao2e: MA problem work1',0,MA_ERR)
      if (.not.ma_push_get(mt_dbl,work2,'work2',l_work2,k_work2))
     1  call errquit('tce_ao2e: MA problem work2',1,MA_ERR)
c
c
c 
c 4af file formed here
c
ccx      if(size_4af.le.size_max2) then
ccx       i_to_x=d_max2
ccx      else
ccx       i_to_x=d_max1
ccx      end if
c
c DISK CHANGES =============== 4A
c opening handle_4a file
c ** debug **
      if(nodezero) then
        write(6,*)'before sf_create'
        call util_flush(6)
      end if  
c
      if(idiskl) then
        call util_file_name('4af',.false.,.false.,filename)
        if (sf_create(filename,dfloat(bytes)*dfloat(size_4af),
     1    dfloat(bytes)*dfloat(size_4af),chunk_max1,handle_4a).ne.0)
     2    call errquit('4-index: sf problem opening 4af',0,DISK_ERR)
        i_to_x=handle_4a
      end if
c
      if(nodezero) then
        write(6,*)'after sf_create'
        call util_flush(6)
      end if
c ============================ 

             cpu1 = - util_cpusec()
             wall1 = - util_wallsec()
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      DO azone3 = 1,atpart      !sigma
      DO azone4 = azone3,atpart !rho
      IF (next.eq.count) THEN
c ---------------------------
        size_4a = nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
        if(.not.ma_push_get(mt_dbl,size_4a,'4a',l_4a,k_4a))
     1     call errquit('tce_4af_zones1: MA problem',0,MA_ERR)
        call dfill(size_4a, 0.0d0, dbl_mb(k_4a), 1)
         shift_mu = 0
         do mu    = a2length(azone2)+1,a2length(azone2+1)
            if (.not.bas_cn2bfr(ao_bas_han,mu,mu_lo,mu_hi))
     1      call errquit('tce_ao2e: basis fn range problem 1',0,
     2      BASIS_ERR)
            mu_range = mu_hi - mu_lo + 1
         shift_nu = 0
         do nu    = a2length(azone1)+1,a2length(azone1+1)
            if (.not.bas_cn2bfr(ao_bas_han,nu,nu_lo,nu_hi))
     1      call errquit('tce_ao2e: basis fn range problem 1',0,
     2      BASIS_ERR)
            nu_range = nu_hi - nu_lo + 1
         shift_rho = 0
         do rho   = a2length(azone4)+1,a2length(azone4+1)
            if (.not.bas_cn2bfr(ao_bas_han,rho,rho_lo,rho_hi))
     1      call errquit('tce_ao2e: basis fn range problem 1',0,
     2      BASIS_ERR)
            rho_range = rho_hi - rho_lo + 1
         shift_sigma = 0
         do sigma = a2length(azone3)+1,a2length(azone3+1)
            if (.not.bas_cn2bfr(ao_bas_han,sigma,sigma_lo,sigma_hi))
     1      call errquit('tce_ao2e: basis fn range problem 1',0,
     2      BASIS_ERR)
            sigma_range = sigma_hi - sigma_lo + 1
            if (schwarz_shell(rho,sigma)*schwarz_shell(mu,nu)
     1          .ge. tol2e) then
            call int_2e4c(ao_bas_han,mu,nu,ao_bas_han,rho,sigma,
     1           work2,dbl_mb(k_work2),work1,dbl_mb(k_work1))
            i=0
             do mu1     = 1,mu_range
             do nu1     = 1,nu_range
             do rho1    = 1,rho_range
             do sigma1  = 1,sigma_range
            i=i+1
            inu1=nu1+shift_nu
            isigma1=sigma1+shift_sigma
            imu1=mu1+shift_mu
            irho1=rho1+shift_rho
c (isigma1,irho1|inu1, imu1)
c differnce with other versiosn
c here 
            ipos1=(((inu1-1)*nalength(azone2)+imu1-1)*
     1            nalength(azone3)+isigma1-1)*nalength(azone4)
     2            +irho1 
            dbl_mb(k_4a+ipos1-1)=dbl_mb(k_work1+i-1)
            enddo
            enddo
            enddo
            enddo
            end if !schwarz  screening
         shift_sigma = shift_sigma + sigma_range
         enddo !sigma
         shift_rho   = shift_rho + rho_range
         enddo !rho
         shift_nu    = shift_nu + nu_range
         enddo !nu
         shift_mu    = shift_mu + mu_range
         enddo !mu
c
c fixing offsets and sf_writing
         key_4af=azone4 - 1 + atpart * (azone3 - 1 +
     &          atpart * (azone2 - 1 + atpart * (azone1 - 1)))
         call tce_hash(int_mb(k_4af_offset),key_4af,offset_4af)
      if(idiskl) then !----
        ierrcode1=sf_write(i_to_x,dfloat(bytes)*dfloat(offset_4af),
     1    dfloat(bytes)*dfloat(size_4a),dbl_mb(k_4a),request)
ccx        if (sf_write(i_to_x,dfloat(bytes)*dfloat(offset_4af),
ccx     1    dfloat(bytes)*dfloat(size_4a),dbl_mb(k_4a),request).ne.0)
ccx     1    THEN
        if(ierrcode1.ne.0) then
          write(6,8154)ierrcode1
          write(6,8155)ga_nodeid(),key_4af,offset_4af,size_4a
          call util_flush(6)
          call errquit('zones put: sf problem2x1',1,DISK_ERR)
        end if 
        ierrcode2=sf_wait(request)
ccx        if (sf_wait(request).ne.0) 
        if(ierrcode2.ne.0) then       
           write(6,8153)ierrcode2
           call util_flush(6)
           call errquit('zones put: sf problem3x1',2,DISK_ERR)
        end if 
      else
        call ga_put(i_to_x,offset_4af+1,offset_4af+size_4a,1,1,
     1    dbl_mb(k_4a),1)
      end if          !----
c closing l_4a file
        if (.not.ma_pop_stack(l_4a))
     1   call errquit('tce_mo2e_4af2: l_4a',15,MA_ERR)
c ---------------------------
      next = NXTASK(nprocs, 1)
      END IF
      count = count + 1
      ENDDO !azone4
      ENDDO !azone3
      ENDDO !azone2
      ENDDO !azone1
c
c
       call ga_sync()
       next = nxtval(-nprocs)
c
c
c
      if(nodezero) then
        write(6,*)'STEP2 4index'
        call util_flush(6)
      end if
c
c
c
c
c
ccx       i_from_x=i_to_x
ccx       if(i_from_x.eq.d_max1) then
ccx        i_to_x=d_max2 
c size check-out
ccx        if(size_max2.lt.size_3a1mf) 
ccx     1    call errquit('tce_4s: 1a',15,MA_ERR)
ccx       else
ccx        i_to_x=d_max1
c size check-out
ccx        if(size_max1.lt.size_3a1mf)
ccx     1    call errquit('tce_4s: 1b',15,MA_ERR)
ccx       end if
c
c DISK CHANGES =============== 3A1M
c closing/reopening handle_4a file
c opening handle_3a1m file
      if(idiskl) then
c       
        if(sf_rwtor(handle_4a).ne.0)
     2    call errquit('4-index: sf_rwtor 4a',0,DISK_ERR)
c *** debug ***
c        if(nodezero) then
c          write(6,*)'STEP2 tests'
c          write(6,*)'handle_4a',handle_4a
c          call util_flush(6)
c        endif
c *************
c
        call util_file_name('3a1mf',.false.,.false.,filename)
        if (sf_create(filename,dfloat(bytes)*dfloat(size_3a1mf),
     1    dfloat(bytes)*dfloat(size_3a1mf),chunk_max1,handle_3a1m).ne.0)
     2    call errquit('4-index: sf problem opening 3a1mf',0,DISK_ERR)
        i_from_x=handle_4a
        i_to_x=handle_3a1m
c *** debug ***
c        if(nodezero) then
c         write(6,*)'i_from_x=',i_from_x
c         write(6,*)'i_to_x=',i_to_x
c         write(6,*)'handle_4a=',handle_4a
c         write(6,*)'handle_3a1m=',handle_3a1m
c         write(6,*)'size_3a1mf=',size_3a1mf
c         write(6,*)'size_4af=',size_4af
c         call util_flush(6)
c        end if
c *************
      end if
c ============================

c
c 3A1M part here
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      DO g4b = 1,noa+nva        !k
      DO azone3 = 1,atpart      !sigma
ccx      DO g4b = 1,noa+nva        !k
c
      IF (next.eq.count) THEN
c
      size_3a1m=int_mb(k_range_alpha+g4b-1)
     1          *nalength(azone1)*nalength(azone2)*nalength(azone3)
      if (.not.ma_push_get(mt_dbl,size_3a1m,'3a1m',l_3a1m,k_3a1m))
     1    call errquit('tce_4ind: step1_1',0,MA_ERR)
      call dfill(size_3a1m, 0.0d0, dbl_mb(k_3a1m), 1)
c 
c    routine for offset 
c
      call a4_offset(azone1,azone2,azone3,size_ic,
     &           l_a4_offset,k_a4_offset)
c      
      length_a4=int_mb(k_a4_offset) 
      DO ii=1,length_a4
       a4_ini      = int_mb(k_a4_offset+ii)
       a4_fin      = int_mb(k_a4_offset+length_a4+ii)
       key_ini=a4_ini - 1 + atpart * (azone3 - 1 +
     &          atpart * (azone2 - 1 + atpart * (azone1 - 1)))
       call tce_hash(int_mb(k_4af_offset),key_ini,offset_bl4a)
c
       size_bl4a   = int_mb(k_a4_offset+2*length_a4+ii) 
      if(idiskl) then !---------
        ierrcode1=sf_read(i_from_x,dfloat(bytes)*dfloat(offset_bl4a),
     1    dfloat(bytes)*dfloat(size_bl4a),dbl_mb(k_integral),
     1    request)
ccx        if (sf_read(i_from_x,dfloat(bytes)*dfloat(offset_bl4a),
ccx     1    dfloat(bytes)*dfloat(size_bl4a),dbl_mb(k_integral),
ccx     1    request).ne.0) THEN
         if(ierrcode1.ne.0) THEN
          write(6,*)'STEP2_step1'
          write(6,8153)ierrcode1 
          write(6,8155)ga_nodeid(),key_ini,offset_bl4a,size_bl4a
          write(6,*)'length_a4',length_a4
          write(6,*)'ii=',ii
          write(6,*)'i_from_x',i_from_x
          call util_flush(6)
          call errquit('zones put: sf problem2x2',1,DISK_ERR)
        end if
        ierrcode2=sf_wait(request)
ccx        if (sf_wait(request).ne.0)
        if (ierrcode2.ne.0) then
           write(6,8154)ierrcode2
           call util_flush(6)
           call errquit('zones put: sf problem3x2',2,DISK_ERR)
        end if 
      else
        call ga_get(i_from_x,offset_bl4a+1,offset_bl4a+size_bl4a,1,1,
     1    dbl_mb(k_integral),1)
      end if !--------------
c
      offset_ismall=0
      do i=a4_ini,a4_fin ! over small i ------------------
      tot_azone4_sh=tot_zone(i)
      j=0
      do irho1   =  1,nalength(i)
      do igi4=1,int_mb(k_range_alpha+g4b-1)
       j=j+1
       ipos1=(int_mb(k_offset_alpha+g4b-1)+igi4-1)*nbf+tot_azone4_sh
     &       +irho1
       dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1)
      enddo
      enddo
c C(g4b irho)* v(irho,isigma,imu,inu)
      call dgemm('N','N',
     &   int_mb(k_range_alpha+g4b-1),
     &   nalength(azone1)*nalength(azone2)*nalength(azone3),
     &   nalength(i),
     &   1.0d0,dbl_mb(k_coeff),int_mb(k_range_alpha+g4b-1),
     &   dbl_mb(k_integral+offset_ismall),nalength(i),1.0d0,
     &   dbl_mb(k_3a1m),int_mb(k_range_alpha+g4b-1))
c
       offset_ismall=offset_ismall+nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(i)
       enddo ! over small i ----------------------
c
      ENDDO  ! over ii
        if (.not.ma_pop_stack(l_a4_offset))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
c
c
c
c
      DO azone4 = 1, azone3-1  ! second part ----
c getting piece of 4a
        size_4a = nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
       if(azone3.le.azone4) then
         key_4af=azone4 - 1 + atpart * (azone3 - 1 +
     &          atpart * (azone2 - 1 + atpart * (azone1 - 1)))
       else
         key_4af=azone3 - 1 + atpart * (azone4 - 1 +
     &          atpart * (azone2 - 1 + atpart * (azone1 - 1)))
       end if 
         call tce_hash(int_mb(k_4af_offset),key_4af,offset_4af)
      if(idiskl) then !---------
        ierrcode1=sf_read(i_from_x,dfloat(bytes)*dfloat(offset_4af),
     1 dfloat(bytes)*dfloat(size_4a),dbl_mb(k_integral),request)
ccx        if (sf_read(i_from_x,dfloat(bytes)*dfloat(offset_4af),
ccx     1 dfloat(bytes)*dfloat(size_4a),dbl_mb(k_integral),request).ne.0)
ccx     1    THEN
        if(ierrcode1.ne.0) then
          write(6,*)'STEP2-step1b'
          write(6,8153)ierrcode1
          write(6,8155)ga_nodeid(),key_4af,offset_4af,size_4a
          call errquit('zones put: sf problem2x3',1,DISK_ERR)
        end if
        ierrcode2=sf_wait(request)
ccx        if (sf_wait(request).ne.0)
        if(ierrcode2.ne.0) then
           write(6,8154)ierrcode2
           call util_flush(6)
           call errquit('zones put: sf problem3x3',2,DISK_ERR)
        end if
      else
        call ga_get(i_from_x,offset_4af+1,offset_4af+size_4a,1,1,
     1    dbl_mb(k_integral),1)
      end if !--------------
c
      if(azone4.lt.azone3) then
        if(.not.ma_push_get(mt_dbl,size_4a,'4a_s',l_4a_sort,k_4a_sort))
     1     call errquit('tce_4af_zones1: MA problem',0,MA_ERR)
      CALL TCE_SORT_4KG_(dbl_mb(k_integral),dbl_mb(k_4a_sort),
     & nalength(azone3),nalength(azone4),
     & nalength(azone2),nalength(azone1),
     &2,1,3,4,1.0d0)
      do i=1,size_4a
       dbl_mb(k_integral+i-1)=dbl_mb(k_4a_sort+i-1)
      enddo
        if (.not.ma_pop_stack(l_4a_sort))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
      end if 
c
c  C(g4b irho) ==> l_2g2z
c
      size_amc=int_mb(k_range_alpha+g4b-1) *
     1         nalength(azone4)
      i=0
      tot_azone4_sh=tot_zone(azone4)
      do irho1   =  1,nalength(azone4)
      do igi4=1,int_mb(k_range_alpha+g4b-1)
       i=i+1
       ipos1=(int_mb(k_offset_alpha+g4b-1)+igi4-1)*nbf+tot_azone4_sh
     &       +irho1
       dbl_mb(k_coeff+i-1)=dbl_mb(k_movecs_orb+ipos1-1)
      enddo
      enddo  
c C(g4b irho)* v(irho,isigma,imu,inu)
      call dgemm('N','N',
     &   int_mb(k_range_alpha+g4b-1),
     &   nalength(azone1)*nalength(azone2)*nalength(azone3),
     &   nalength(azone4),
     &   1.0d0,dbl_mb(k_coeff),int_mb(k_range_alpha+g4b-1),
     &   dbl_mb(k_integral),nalength(azone4),1.0d0,
     &   dbl_mb(k_3a1m),int_mb(k_range_alpha+g4b-1))
c
      ENDDO
c write to file
          key_3a1m =  azone3-1+atpart*(g4b-1+(noa+nva)*
     &    (azone2 - 1 + atpart * (azone1 - 1)))
         call tce_hash(int_mb(k_3a1m_offset),key_3a1m,offset_3a1m)
       if(idiskl) then ! --------
        ierrcode1=sf_write(i_to_x,dfloat(bytes)*dfloat(offset_3a1m),
     r    dfloat(bytes)*dfloat(size_3a1m),dbl_mb(k_3a1m),request)
        if (ierrcode1.ne.0) then
          write(6,*)'WRITE STEP3'
          write(6,8156) ierrcode1
          write(6,*)'offset_3a1m=',offset_3a1m
          write(6,*)'size_3a1m=',size_3a1m
          write(6,*)'i_to_x',i_to_x 
          call util_flush(6)
          call errquit('zones put: sf problem21-b',1,DISK_ERR)
        end if
        ierrcode2=sf_wait(request)
ccx        if (sf_wait(request).ne.0)
        if(ierrcode2.ne.0) then
          write(6,8157)ierrcode2
          call errquit('zones put: sf problem31-b',2,DISK_ERR)
        end if 
       else
        call ga_put(i_to_x,offset_3a1m+1,offset_3a1m+size_3a1m,1,1,
     1    dbl_mb(k_3a1m),1)
       end if ! ---------
c
      if (.not.ma_pop_stack(l_3a1m))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
c
      next = NXTASK(nprocs, 1)
      END IF
      count = count + 1
      ENDDO
      ENDDO
      ENDDO
      ENDDO
c 3A1P fully done here
      call ga_sync()
      next = nxtval(-nprocs)
c
c
c
c
      if(nodezero) then
        write(6,*)'STEP3 4index'
        call util_flush(6)
      end if
c
c
c
c
c
c 2A2M part here
c
ccx       i_from_x=i_to_x
ccx       if(i_from_x.eq.d_max1) then
ccx        i_to_x=d_max2
c size check-out
ccx        if(size_max2.lt.size_2a2mf)
ccx     1    call errquit('tce_4s: 2a',15,MA_ERR)
ccx       else
ccx        i_to_x=d_max1
c size check-out
ccx        if(size_max1.lt.size_2a2mf)
ccx     1    call errquit('tce_4s: 2b',15,MA_ERR)
ccx       end if
c
c
c DISK CHANGES =============== 2A2M
c destroying handle_4a
c closing/reopening handle_3a1m file
c opening handle_2a2m file
      if(idiskl) then
c
       if (sf_destroy(handle_4a).ne.0)
     1   call errquit('tce_sf_destroy: sf problem handle_4a',15,MA_ERR)
c
        if(sf_rwtor(handle_3a1m).ne.0) 
     2    call errquit('4-index: sf_rwtor 3a1m',0,DISK_ERR)
c *** debug ***
c      if(nodezero) then
c       write(6,*)'handle_3a1m',handle_3a1m
c      end if 
c *************
c
        call util_file_name('2a2mf',.false.,.false.,filename)
        if (sf_create(filename,dfloat(bytes)*dfloat(size_2a2mf),
     1    dfloat(bytes)*dfloat(size_2a2mf),chunk_max1,handle_2a2m).ne.0)
     2    call errquit('4-index: sf problem opening 2a2mf',0,DISK_ERR)
        i_from_x=handle_3a1m
        i_to_x=handle_2a2m
      end if
c *** debug ***
       if(nodezero) then
        write(6,*)'STEP3 test'
c        write(6,*)'handle_2a2m=',handle_2a2m 
c        write(6,*)'size_2a2mf=',size_2a2mf
c        write(6,*)'i_from_x=',i_from_x
c        write(6,*)'i_to_x=',i_to_x
        call util_flush(6)
       end if
c *************
c ============================
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c
      DO g3b = 1,noa+nva   !k
      DO g4b = g3b,noa+nva !l
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
ccx      DO g3b = 1,noa+nva   !k
ccx      DO g4b = g3b,noa+nva !l
c
      IF (next.eq.count) THEN
c
      size_2a2m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     1          *nalength(azone1)*nalength(azone2)
      if (.not.ma_push_get(mt_dbl,size_2a2m,'2a2m',l_2a2m,k_2a2m))
     1    call errquit('tce_4ind: step1_1',0,MA_ERR)
      call dfill(size_2a2m, 0.0d0, dbl_mb(k_2a2m), 1)
c
      call a3_offset(azone1,azone2,g3b,size_ic,
     &           l_a3_offset,k_a3_offset)
      length_a3=int_mb(k_a3_offset)
c 
      DO ii=1,length_a3     ! ii---loop

       a3_ini    = int_mb(k_a3_offset+ii)
       a3_fin    = int_mb(k_a3_offset+length_a3+ii)
       key_ini   = a3_ini-1+atpart*(g3b-1+(noa+nva)*
     &    (azone2 - 1 + atpart * (azone1 - 1)))
       call tce_hash(int_mb(k_3a1m_offset),key_ini,offset_bl3a1m)
c
       size_bl3a1m   = int_mb(k_a3_offset+2*length_a3+ii)
c
c
       if(idiskl) then ! -------
        ierrcode1=sf_read(i_from_x,dfloat(bytes)*dfloat(offset_bl3a1m),
     2    dfloat(bytes)*dfloat(size_bl3a1m),
     2    dbl_mb(k_integral),request)
         if(ierrcode1.ne.0) then
          write(6,*)'STEP3-step1a'
          write(6,8153) ierrcode1
          write(6,*)'offset_bl3a1m=',offset_bl3a1m
          write(6,*)'size_bl3a1m=',size_bl3a1m
          write(6,*)'ii=',ii
          write(6,*)'length_a3=',length_a3
          call util_flush(6)
          call errquit('zones put: sf problem21-b',1,DISK_ERR)
         end if 
         ierrcode2=sf_wait(request)
         if(ierrcode2.ne.0) then 
          write(6,*)'STEP3-step1a'
          write(6,8154) ierrcode2
          call util_flush(6)
          call errquit('zones put: sf problem31-b',2,DISK_ERR)
         end if
       else 
        call ga_get(i_from_x,offset_bl3a1m+1,offset_bl3a1m+size_bl3a1m,
     1       1,1,dbl_mb(k_integral),1) 
       end if ! -------
      offset_ismall=0
      do i=a3_ini,a3_fin ! over small i ------------------
      size_3a1mi=nalength(azone1)*nalength(azone2)*
     1            nalength(i)*int_mb(k_range_alpha+g3b-1)
      if (.not.ma_push_get(mt_dbl,size_3a1mi,'3a1m',
     1 l_3a1m_sort,k_3a1m_sort))
     1    call errquit('tce_4ind: step1_1',0,MA_ERR)
      CALL TCE_SORT_4KG_(dbl_mb(k_integral+offset_ismall),
     & dbl_mb(k_3a1m_sort),
     & int_mb(k_range_alpha+g3b-1),nalength(i),
     & nalength(azone2),nalength(azone1),
     &2,1,3,4,1.0d0)
      do j=1,size_3a1mi
       dbl_mb(k_integral+offset_ismall+j-1)=dbl_mb(k_3a1m_sort+j-1)
      enddo
      if (.not.ma_pop_stack(l_3a1m_sort))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
c  C(g4b isigma)
      j=0
      tot_azone3_sh=tot_zone(i)
      do isigma1   =  1,nalength(i)
      do igi4=1,int_mb(k_range_alpha+g4b-1)
       j=j+1
       ipos1=(int_mb(k_offset_alpha+g4b-1)+igi4-1)*nbf+tot_azone3_sh
     &       +isigma1
       dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1)
      enddo
      enddo
c C(g4b isigma)* v(isigma,g3b,imu,inu)
      call dgemm('N','N',
     &   int_mb(k_range_alpha+g4b-1),
     &   nalength(azone1)*nalength(azone2)*int_mb(k_range_alpha+g3b-1),
     &   nalength(i),
     &   1.0d0,dbl_mb(k_coeff),int_mb(k_range_alpha+g4b-1),
     &   dbl_mb(k_integral+offset_ismall),nalength(i),1.0d0,
     &   dbl_mb(k_2a2m),int_mb(k_range_alpha+g4b-1))
c
      offset_ismall=offset_ismall+nalength(azone1)*nalength(azone2)*
     1            nalength(i)*int_mb(k_range_alpha+g3b-1)
      enddo ! over small i ----------------------
      ENDDO                 ! ii---loop
c
        if (.not.ma_pop_stack(l_a3_offset))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
c write to file
          key_2a2m= azone2 - 1 + atpart*( azone1 - 1 +
     & atpart*(g4b - 1 + (noa+nva) * (g3b-1)))
         call tce_hash(int_mb(k_2a2m_offset),key_2a2m,offset_2a2m)
       if(idiskl) then ! -------
        ierrcode1=sf_write(i_to_x,dfloat(bytes)*dfloat(offset_2a2m),
     2    dfloat(bytes)*dfloat(size_2a2m),dbl_mb(k_2a2m),request)
        if(ierrcode1.ne.0) then 
         write(6,*)'STEP3 write'
         write(6,8156) ierrcode1
         write(6,*)'offset_2a2m=',offset_2a2m
         write(6,*)'size_2a2m=',size_2a2m
         write(6,*)'key_2a2m=',key_2a2m
         write(6,*)'i_to_x=',i_to_x
         call util_flush(6) 
         call errquit('zones put: sf problem21-b',1,DISK_ERR)
        end if 
        ierrcode2=sf_wait(request)
        if(ierrcode2.ne.0) then
         call errquit('zones put: sf problem31-b',2,DISK_ERR)
        end if
       else 
        call ga_put(i_to_x,offset_2a2m+1,offset_2a2m+size_2a2m,1,1,
     1    dbl_mb(k_2a2m),1)
       end if  ! --------
c
      if (.not.ma_pop_stack(l_2a2m))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
c
      next = NXTASK(nprocs, 1)
      END IF
      count = count + 1
      ENDDO
      ENDDO
      ENDDO
      ENDDO
c 2A2P fully done here
      call ga_sync()
      next = nxtval(-nprocs)
c
c
c
c
c
      if(nodezero) then
        write(6,*)'STEP4 4index'
        call util_flush(6)
      end if
c
c
c
c
c
c
c 1A3M part here ([g4b][g3b]|[mu][nu]) =>([g4b][g3b]|[g2b][nu])
c                            [mu]>[nu] (azone2>=azone1)
c
c
cx       i_from_x=i_to_x
cx       if(i_from_x.eq.d_max1) then
cx        i_to_x=d_max2
c size check-out
cx        if(size_max2.lt.size_1a3mf)
cx     1    call errquit('tce_4s: 3a',15,MA_ERR)
cx       else
cx        i_to_x=d_max1
c size check-out
cx        if(size_max1.lt.size_1a3mf)
cx     1    call errquit('tce_4s: 3b',15,MA_ERR)
cx       end if
c
c
c
c
c DISK CHANGES =============== 1A3M
c destroying handle_3a1m
c closing/reopening handle_2a2m file
c opening handle_1a3m file
      if(idiskl) then
c
       if (sf_destroy(handle_3a1m).ne.0)
     1  call errquit('tce_sf_destroy: sf problem handle_3a1m',15,MA_ERR)
c
        if(sf_rwtor(handle_2a2m).ne.0)
     2    call errquit('4-index: sf_rwtor 2a2m',0,DISK_ERR)
c
        call util_file_name('1a3mf',.false.,.false.,filename)
        if (sf_create(filename,dfloat(bytes)*dfloat(size_1a3mf),
     1    dfloat(bytes)*dfloat(size_1a3mf),chunk_max1,handle_1a3m).ne.0)
     2    call errquit('4-index: sf problem opening 1a3mf',0,DISK_ERR)
        i_from_x=handle_2a2m
        i_to_x=handle_1a3m
      end if
c ============================
c
c
c
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c
      DO g3b = 1,noa+nva   !k
      DO g4b = g3b,noa+nva !l
      DO g2b = 1,noa+nva   !
      DO azone1 = 1,atpart      !nu
ccx      DO g3b = 1,noa+nva   !k
ccx      DO g4b = g3b,noa+nva !l
c
      IF (next.eq.count) THEN
      size_1a3m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     1         *int_mb(k_range_alpha+g2b-1)*nalength(azone1)
      if (.not.ma_push_get(mt_dbl,size_1a3m,'1a3m',l_1a3m,k_1a3m))
     1    call errquit('tce_4ind: step1_1',0,MA_ERR)
      call dfill(size_1a3m, 0.0d0, dbl_mb(k_1a3m), 1)
c azone2 >= azone1 - PART1
c
c
      call a2_offset(azone1,g4b,g3b,size_ic,
     &           l_a2_offset,k_a2_offset)
c
      length_a2=int_mb(k_a2_offset)
      DO ii=1,length_a2  !=========================================
       a2_ini      = int_mb(k_a2_offset+ii)
       a2_fin      = int_mb(k_a2_offset+length_a2+ii)
       key_ini=a2_ini - 1 + atpart*( azone1 - 1 +
     & atpart*(g4b - 1 + (noa+nva) * (g3b-1)))
       call tce_hash(int_mb(k_2a2m_offset),key_ini,offset_bl2a2m)
c
       size_bl2a2m   = int_mb(k_a2_offset+2*length_a2+ii)
      if(idiskl) then !---------
        if (sf_read(i_from_x,dfloat(bytes)*dfloat(offset_bl2a2m),
     1    dfloat(bytes)*dfloat(size_bl2a2m),dbl_mb(k_integral),
     1    request).ne.0) THEN
          write(6,8155)ga_nodeid(),key_4af,offset_4af,size_4a
          call errquit('zones put: sf problem2x4',1,DISK_ERR)
        end if
        if (sf_wait(request).ne.0)
     1     call errquit('zones put: sf problem3x4',2,DISK_ERR)
      else
        call ga_get(i_from_x,offset_bl2a2m+1,
     1    offset_bl2a2m+size_bl2a2m,1,1,dbl_mb(k_integral),1)
      end if !--------------
c
c *** debug ***
c         xmax=0.0d0
c         do i=1,size_bl2a2m
c          xmax=xmax+dbl_mb(k_integral+i-1)
c         enddo
c         if (util_print('mo2e',print_debug)) write(6,411) 
c     &       azone1,g2b,g4b,g3b,a2_ini,a2_fin,size_bl2a2m,key_ini,xmax
c 411     format('    1A3M part1 ',4i3,2x,2i4,2x,i9,2x,i9,f17.8)
c         call util_flush(6)
c *************
c
      offset_ismall=0
      do i=a2_ini,a2_fin ! over small i ------------------
ccc       TRANSPOZYCJA
        size_2a2mi=nalength(azone1)*nalength(i)*
     1     int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
        if (.not.ma_push_get(mt_dbl,size_2a2mi,'2a2m_sort',
     1   l_2a2m_aux,k_2a2m_aux))
     1     call errquit('tce_4ind: step1_1',0,MA_ERR)
        CALL TCE_SORT_4KG_(dbl_mb(k_integral+offset_ismall),
     &   dbl_mb(k_2a2m_aux),
     &   int_mb(k_range_alpha+g4b-1),int_mb(k_range_alpha+g3b-1),
     &   nalength(i),nalength(azone1),
     &   1,2,4,3,1.0d0)
        do j=1,size_2a2mi
         dbl_mb(k_integral+offset_ismall+j-1)=dbl_mb(k_2a2m_aux+j-1)
        enddo
        if (.not.ma_pop_stack(l_2a2m_aux))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
c  C(azone2 g2b) 
      j=0
      tot_azone2_sh=tot_zone(i)
      do igi2=1,int_mb(k_range_alpha+g2b-1)
      do imu1   =  1,nalength(i)
       j=j+1
       ipos1=(int_mb(k_offset_alpha+g2b-1)+igi2-1)*nbf+tot_azone2_sh
     &       +imu1
       dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1)
      enddo
      enddo
c  v(g4b,g3b,inu,imu) C(imu,g2b)
        size_1a3mi=int_mb(k_range_alpha+g4b-1)
     & *int_mb(k_range_alpha+g3b-1)*nalength(azone1)
     & *int_mb(k_range_alpha+g2b-1) 
        if (.not.ma_push_get(mt_dbl,size_1a3mi,'1a3m',
     1   l_1a3m_sort,k_1a3m_sort))
     1     call errquit('tce_4ind: step1_1',0,MA_ERR)
c dgemm
      call dgemm('N','N',
     &   int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     &   *nalength(azone1),
     &   int_mb(k_range_alpha+g2b-1),
     &   nalength(i),
     &   1.0d0,dbl_mb(k_integral+offset_ismall),
     &   int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     &  *nalength(azone1),
     &   dbl_mb(k_coeff),nalength(i),0.0d0,
     &   dbl_mb(k_1a3m_sort),
     &   int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     &  *nalength(azone1))
c transpose
        j=0
        do inu1=1,nalength(azone1)
        do igi2=1,int_mb(k_range_alpha+g2b-1)
        do igi3=1,int_mb(k_range_alpha+g3b-1)
        do igi4=1,int_mb(k_range_alpha+g4b-1)
        j=j+1
        ipos1=igi4+int_mb(k_range_alpha+g4b-1)*(
     &   igi3-1+int_mb(k_range_alpha+g3b-1)*(
     &   inu1-1+nalength(azone1)*(igi2-1)))
        dbl_mb(k_1a3m+j-1)=dbl_mb(k_1a3m+j-1)+
     &                     dbl_mb(k_1a3m_sort+ipos1-1)
        enddo
        enddo
        enddo
        enddo
        if (.not.ma_pop_stack(l_1a3m_sort))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
       offset_ismall=offset_ismall+nalength(azone1)*nalength(i)*
     1      int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
       enddo ! over small i ----------------------
      ENDDO  ! over ii !===========================================
        if (.not.ma_pop_stack(l_a2_offset))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
c
c
c azone2 < azone1  - PART2 

      DO azone2 = 1,azone1-1 ! PART2 two cases here only one is followed 
       size_2a2m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     1           *nalength(azone1)*nalength(azone2)
       if (.not.ma_push_get(mt_dbl,size_2a2m,'2a2m',l_2a2m,k_2a2m))
     1    call errquit('tce_4ind: step1_1',0,MA_ERR)
       if(azone2.ge.azone1) then
          key_2a2m= azone2 - 1 + atpart*( azone1 - 1 +
     & atpart*(g4b - 1 + (noa+nva) * (g3b-1)))
         call tce_hash(int_mb(k_2a2m_offset),key_2a2m,offset_2a2m)
        if(idiskl) then !------
        if (sf_read(i_from_x,dfloat(bytes)*dfloat(offset_2a2m),
     r    dfloat(bytes)*dfloat(size_2a2m),dbl_mb(k_2a2m),request).ne.0)
     2    call errquit('zones put: sf problem21-b',1,DISK_ERR)
        if (sf_wait(request).ne.0)
     1    call errquit('zones put: sf problem31-b',2,DISK_ERR)
        else
        call ga_get(i_from_x,offset_2a2m+1,offset_2a2m+size_2a2m,1,1,
     1    dbl_mb(k_2a2m),1)
        end if !-----
       else 
          key_2a2m= azone1 - 1 + atpart*( azone2 - 1 +
     & atpart*(g4b - 1 + (noa+nva) * (g3b-1)))
         call tce_hash(int_mb(k_2a2m_offset),key_2a2m,offset_2a2m)
        if(idiskl) then ! ------
        if (sf_read(i_from_x,dfloat(bytes)*dfloat(offset_2a2m),
     r    dfloat(bytes)*dfloat(size_2a2m),dbl_mb(k_2a2m),request).ne.0)
     2    call errquit('zones put: sf problem21-b',1,DISK_ERR)
        if (sf_wait(request).ne.0)
     1    call errquit('zones put: sf problem31-b',2,DISK_ERR)
c *** debug ***
c         xmax=0.0d0
c         do i=1,size_2a2m
c          xmax=xmax+dbl_mb(k_2a2m+i-1)
c         enddo
c         if (util_print('mo2e',print_debug)) write(6,412)
c     &       azone1,g2b,g4b,g3b,azone2,size_2a2m,key_2a2m,xmax
c 412     format('    1A3M part2 ',4i3,2x,i4,2x,i9,2x,i9,2x,f17.8)
c         call util_flush(6)
c *************
        else
        call ga_get(i_from_x,offset_2a2m+1,offset_2a2m+size_2a2m,1,1,
     1    dbl_mb(k_2a2m),1)
        end if ! ------
        end if ! xxxxxx
       if(azone2.ge.azone1) then
ccc       TRANSPOZYCJA
        if (.not.ma_push_get(mt_dbl,size_2a2m,'2a2m_sort',
     1   l_2a2m_aux,k_2a2m_aux))
     1     call errquit('tce_4ind: step1_1',0,MA_ERR)
        CALL TCE_SORT_4KG_(dbl_mb(k_2a2m),dbl_mb(k_2a2m_aux),
     &   int_mb(k_range_alpha+g4b-1),int_mb(k_range_alpha+g3b-1),
     &   nalength(azone2),nalength(azone1),
     &   1,2,4,3,1.0d0)
        do i=1,size_2a2m
         dbl_mb(k_2a2m+i-1)=dbl_mb(k_2a2m_aux+i-1)
        enddo
        if (.not.ma_pop_stack(l_2a2m_aux))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
       end if
c
c  C(imu g2b) ==> l_2g2z
c
      size_amc=int_mb(k_range_alpha+g2b-1) *
     1         nalength(azone2)
      if (.not.ma_push_get(mt_dbl,size_amc,'2g2z',l_2g2z,k_2g2z))
     1    call errquit('tce_r2_divide3: xx-MA problem',0,MA_ERR)
      i=0
      tot_azone2_sh=tot_zone(azone2)
      do igi2=1,int_mb(k_range_alpha+g2b-1)
      do imu1   =  1,nalength(azone2)
       i=i+1
c       ipos1=(int_mb(k_offset_alpha+g2b-1)+igi2-1)*nbf+tot_azone1_sh
c     &       +inu1
       ipos1=(int_mb(k_offset_alpha+g2b-1)+igi2-1)*nbf+tot_azone2_sh
     &       +imu1
       dbl_mb(k_2g2z+i-1)=dbl_mb(k_movecs_orb+ipos1-1)
      enddo
      enddo
c  v(g4b,g3b,inu,imu) C(imu,g2b)
        if (.not.ma_push_get(mt_dbl,size_1a3m,'1a3m',
     1   l_1a3m_sort,k_1a3m_sort))
     1     call errquit('tce_4ind: step1_1',0,MA_ERR)
c dgemm
      call dgemm('N','N',
     &   int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     &   *nalength(azone1),
     &   int_mb(k_range_alpha+g2b-1),
     &   nalength(azone2),
     &   1.0d0,dbl_mb(k_2a2m),
     &   int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     &  *nalength(azone1),
     &   dbl_mb(k_2g2z),nalength(azone2),0.0d0,
     &   dbl_mb(k_1a3m_sort),
     &   int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     &  *nalength(azone1))
c transpose
        i=0
        do inu1=1,nalength(azone1)
        do igi2=1,int_mb(k_range_alpha+g2b-1)
        do igi3=1,int_mb(k_range_alpha+g3b-1)
        do igi4=1,int_mb(k_range_alpha+g4b-1)
        i=i+1
        ipos1=igi4+int_mb(k_range_alpha+g4b-1)*(
     &   igi3-1+int_mb(k_range_alpha+g3b-1)*(
     &   inu1-1+nalength(azone1)*(igi2-1)))
        dbl_mb(k_1a3m+i-1)=dbl_mb(k_1a3m+i-1)+
     &                     dbl_mb(k_1a3m_sort+ipos1-1)
        enddo
        enddo
        enddo
        enddo
c
        if (.not.ma_pop_stack(l_1a3m_sort))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
        if (.not.ma_pop_stack(l_2g2z))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
        if (.not.ma_pop_stack(l_2a2m))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
      ENDDO ! PART2 ends up here ------------------------------------------
c
c
c
c write to file
        key_1a3m= azone1-1+atpart*(g2b-1+(noa+nva)*
     &  (g4b-1+(noa+nva)*(g3b-1)))
         call tce_hash(int_mb(k_1a3m_offset),key_1a3m,offset_1a3m)
       if(idiskl) then !---------
        if (sf_write(i_to_x,dfloat(bytes)*dfloat(offset_1a3m),
     r    dfloat(bytes)*dfloat(size_1a3m),dbl_mb(k_1a3m),request).ne.0)
     2    call errquit('zones put: sf problem21-b',1,DISK_ERR)
        if (sf_wait(request).ne.0)
     1    call errquit('zones put: sf problem31-b',2,DISK_ERR)
       else
        call ga_put(i_to_x,offset_1a3m+1,offset_1a3m+size_1a3m,1,1,
     1    dbl_mb(k_1a3m),1)
       end if ! -------------
c
      if (.not.ma_pop_stack(l_1a3m))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)
c
      next = NXTASK(nprocs, 1)
      END IF
      count = count + 1
      ENDDO
      ENDDO
      ENDDO
      ENDDO
c 1A3P fully done here
      call ga_sync()
      next = nxtval(-nprocs)
c
c
c
c
c
      if(nodezero) then
        write(6,*)'STEP5 4index'
        call util_flush(6)
      end if
c
c
c
c
c 4M starts here
c
c
ccx      if(idiskl) then !----------------
ccx       i_from_x=i_to_x
ccx      else !------------------
ccx        i_from_x=i_to_x
ccx        if(i_from_x.eq.d_max1) then
ccx         i_to_x=d_max2
ccx         d_v2=i_to_x
c size check-out
ccx         if(size_max2.lt.size_2e)
ccx     1     call errquit('tce_4s: 5a',15,MA_ERR)
ccx        else
ccx         i_to_x=d_max1
ccx         d_v2=i_to_x
c size check-out
ccx         if(size_max1.lt.size_2e)
ccx     1     call errquit('tce_4s: 5b',15,MA_ERR)
ccx        end if
ccx      end if !----------------------
c
c DISK CHANGES =============== 4M
c destroying handle_2a2m
c closing/reopening handle_1a3m file
c opening handle_4m file
      if(idiskl) then
c
       if (sf_destroy(handle_2a2m).ne.0)
     1  call errquit('tce_sf_destroy: sf problem handle_2a2m',15,MA_ERR)
c
        if(sf_rwtor(handle_1a3m).ne.0) 
     2    call errquit('4-index: sf_rwtor 1a3m',0,DISK_ERR)
c
        i_from_x=handle_1a3m
      end if
c ============================
c
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c
      DO g1b = 1,noa+nva      !nu
      DO g2b = g1b,noa+nva   !
      DO g3b = 1,noa+nva   !k
      DO g4b = g3b,noa+nva !l
      IF (next.eq.count) THEN
      IF (int_mb(k_spin_alpha+g3b-1)+int_mb(k_spin_alpha+g4b-1).eq.
     &int_mb(k_spin_alpha+g1b-1)+int_mb(k_spin_alpha+g2b-1)) THEN
      IF (ieor(int_mb(k_sym_alpha+g3b-1),ieor(int_mb(k_sym_alpha+g4b-1),
     &    ieor(int_mb(k_sym_alpha+g1b-1),int_mb(k_sym_alpha+g2b-1))))
     &    .eq. irrep_v) THEN
c reversed order
      ICOL=INDEX_PAIR(g4b,g3b)
      IROW=INDEX_PAIR(g2b,g1b)
      IF(IROW.GE.ICOL) THEN
      IRES=INDEX_PAIR(IROW,ICOL)
      size_4m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
     1         *int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1)
      if (.not.ma_push_get(mt_dbl,size_4m,'4m',l_4m,k_4m))
     1    call errquit('tce_4ind: step1_1',0,MA_ERR)
      call dfill(size_4m, 0.0d0, dbl_mb(k_4m), 1)
c
      call a1_offset(g1b,g2b,g4b,size_ic,
     &           l_a1_offset,k_a1_offset)
      length_a1=int_mb(k_a1_offset)
      DO ii=1,length_a1     ! ii---loop
       a1_ini    = int_mb(k_a1_offset+ii)
       a1_fin    = int_mb(k_a1_offset+length_a1+ii)
       key_ini   = a1_ini-1+atpart*(g4b-1+(noa+nva)*
     &  (g2b-1+(noa+nva)*(g1b-1)))
       call tce_hash(int_mb(k_1a3m_offset),key_ini,offset_bl1a3m)
c
       size_bl1a3m  = int_mb(k_a1_offset+2*length_a1+ii)
       if(idiskl) then ! -------
        if (sf_read(i_from_x,dfloat(bytes)*dfloat(offset_bl1a3m),
     2    dfloat(bytes)*dfloat(size_bl1a3m),
     2    dbl_mb(k_integral),request).ne.0)
     2    call errquit('zones put: sf problem21-b',1,DISK_ERR)
        if (sf_wait(request).ne.0)
     1    call errquit('zones put: sf problem31-b',2,DISK_ERR)
       else
        call ga_get(i_from_x,offset_bl1a3m+1,offset_bl1a3m+size_bl1a3m,
     1       1,1,dbl_mb(k_integral),1)
       end if ! -------
      offset_ismall=0
      do i=a1_ini,a1_fin ! over small i ------------------
c  C(azone1 g3b)
      j=0
      tot_azone1_sh=tot_zone(i)
      do igi3=1,int_mb(k_range_alpha+g3b-1)
      do inu1   =  1,nalength(i)
       j=j+1
       ipos1=(int_mb(k_offset_alpha+g3b-1)+igi3-1)*nbf+tot_azone1_sh
     &       +inu1
       dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1)
      enddo
      enddo
c v(g2b,g1b,g4b,inu)*C(inu g3b)
      call dgemm('N','N',
     &   int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1)
     &   *int_mb(k_range_alpha+g4b-1),
     &   int_mb(k_range_alpha+g3b-1),
     &   nalength(i),
     &   1.0d0,dbl_mb(k_integral+offset_ismall),
     &   int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1)
     &  *int_mb(k_range_alpha+g4b-1),
     &   dbl_mb(k_coeff),nalength(i),1.0d0,
     &   dbl_mb(k_4m),
     &   int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1)
     &  *int_mb(k_range_alpha+g4b-1))
c
      offset_ismall=offset_ismall+nalength(i)
     1       *int_mb(k_range_alpha+g4b-1)
     1       *int_mb(k_range_alpha+g1b-1)*int_mb(k_range_alpha+g2b-1)
c
      enddo ! over small i ----------------------
      ENDDO                 ! ii---loop
        if (.not.ma_pop_stack(l_a1_offset))
     1   call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR)
c
c zapis
c
         key_4m=ires
         call tce_hash_n(int_mb(kax_v2_alpha_offset),key_4m,offset_4m)
      call put_block(d_v2,dbl_mb(k_4m),size_4m,
     &               offset_4m)
c
      if (.not.ma_pop_stack(l_4m))
     1  call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR)

      END IF
      END IF
      END IF
      next = NXTASK(nprocs, 1)
      END IF
      count = count + 1
      ENDDO
      ENDDO
      ENDDO
      ENDDO
c
       call ga_sync()
       next = nxtval(-nprocs)
c
c
c
c
c
c
c
c
c
      if(nodezero) then
      write(6,*)'DONE --- DONE ---- DONE ---- DONE'
      end if
c
      if (.not.ma_pop_stack(l_work2))
     1  call errquit('tce_ao2e: MA problem',14,MA_ERR)
      if (.not.ma_pop_stack(l_work1))
     1  call errquit('tce_ao2e: MA problem',15,MA_ERR)
c
      if (.not.ma_pop_stack(l_movecs_orb))
     1  call errquit('tce_ao2e: MA problem',15,MA_ERR)
c
c
c DISK CHANGES =============== AFTER 4M
c destroying handle_1a3m
      if(idiskl) then
c
       if (sf_destroy(handle_1a3m).ne.0)
     1  call errquit('tce_sf_destroy: sf problem handle_1a3m',15,MA_ERR)
c
      end if
c ============================
c
c
      if(idiskl) then
c       if (.not.sf_destroy(d_max2))
c     1   call errquit('tce_sf_destroy22: sf problem',15,MA_ERR)
c         if (parallel) call ga_sync()
c       if (.not.sf_destroy(d_max1))
c     1   call errquit('tce_sf_destroy33: sf problem',15,MA_ERR)
c         if (parallel) call ga_sync()
      else
       call deletefile(i_from_x)
       call ga_sync() 
cccx       call deletefile(d_4af)
cccx       call ga_sync()
      end if
c
      if (.not.ma_pop_stack(l_1a3m_offset))
     1  call errquit('tce_off_1a3m: MA problem',15,MA_ERR)
c
      if (.not.ma_pop_stack(l_2a2m_offset))
     1  call errquit('tce_off_2a2m: MA problem',15,MA_ERR)
c
      if (.not.ma_pop_stack(l_3a1m_offset))
     1  call errquit('tce_off_3a1m: MA problem',15,MA_ERR)
c
      if (.not.ma_pop_stack(l_4af_offset))
     1  call errquit('tce_off_4a: MA problem',15,MA_ERR)
c
c
c     closing two large local files
c
      if (.not.ma_pop_stack(l_coeff))
     1  call errquit('tce_off_4a: MA problem',15,MA_ERR)
c
      if (.not.ma_pop_stack(l_integral))
     1  call errquit('tce_off_4a: MA problem',15,MA_ERR)
c

c
      call ga_sync()
c *** debug ***
c 800  format('DGEMM1 MAX',i5,2x,3f15.5)
c 801  format('DGEMM2 ',i5,2x,3f15.5)
 8153 format('SF_READ ERROR CODE = ',2x,i10)
 8154 format('SF_READ_WAIT ERROR CODE = ',2x,i10)
 8156 format('SF_WRITE ERROR CODE = ',2x,i10)
 8157 format('SF_WRITE_WAIT ERROR CODE = ',2x,i10)
 8155 format('FU',i6,2x,3i20)
 9000 format('PART1',i4,1x,'Cpu  wall ',2(f17.12,1x),3x,'g4b g3b',2i5)
c 9001 format('PART2',i4,1x,'Cpu  wall ',2(f17.12,1x),3x,'g4b g3b',2i5)
c 9003 format('PART1-4a',i4,1x,'Cpu  wall ',2(f17.12,1x))
c 9004 format('PART1-2g2z',i4,1x,'Cpu  wall ',2(f17.12,1x))
c 9005 format('PART1-dgemm',i4,1x,'Cpu  wall ',2(f17.12,1x))
c 9010 format('  P1-mnrs',i3,1x,2i5,1x,2i5,1x,'Cpu  wall ',2(f17.12,1x))
  555  format('atom loop ',2x,i5,3x,2i5,3x,2i5,i12)
  556  format('atom time',2x,i5,3x,2i5,3x,2i5,'Cpu wall ',2(f12.7,1x))
  777  format('main do loop ',2x,i5,3x,2i5,3x,2i5)
  775  format('main loop step1 ',2x,i5,3x,2i5,3x,2i5)
  776  format('main loop step2 ',2x,i5,3x,2i5,3x,2i5)
  778  format('PART1',2x,i5,3x,2i5,3x,2i5,2x,'Cpu  wall ',2(f17.12,1x))
  779  format('PART2',2x,i5,3x,2i5,3x,2i5,2x,'Cpu  wall ',2(f17.12,1x))
  780  format('ADD BLOCK',2x,i5,3x,2i5,3x,2i5,2x,'Cpu  wall ',
     &        2(f17.12,1x))
c *************
c
      RETURN
      END
c
c
c
      SUBROUTINE tce_4a_offsetx2(l_a_offset,k_a_offset,size)
C     $Id: tce_ao2e_cholesky_orb.F 19706 2010-10-29 17:52:31Z d3y133 $
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER l_a_offset
      INTEGER k_a_offset
      INTEGER size
      INTEGER length
      INTEGER addr
      INTEGER mu
      INTEGER nu
      INTEGER rho
      INTEGER sigma
      INTEGER azone1,azone2,azone3,azone4
      length = 0
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      DO azone3 = 1,atpart      !sigma
      DO azone4 = azone3,atpart !rho
      length = length + 1
      END DO
      END DO
      END DO
      END DO
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
     &set)) CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_a_offset) = length
      addr = 0
      size = 0
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      DO azone3 = 1,atpart      !sigma
      DO azone4 = azone3,atpart !rho
      addr = addr + 1
      int_mb(k_a_offset+addr) = azone4 - 1 + atpart * (azone3 - 1 + 
     &  atpart * (azone2 - 1 + atpart * (azone1 - 1)))
      int_mb(k_a_offset+length+addr) = size
      size = size + nalength(azone1) * nalength(azone2) * 
     &  nalength(azone3) * nalength(azone4)
      END DO
      END DO
      END DO
      END DO
      RETURN
      END
c
c
      SUBROUTINE tce_3a1m_offsetx2(l_a_offset,k_a_offset,size)
C     $Id: tce_ao2e_cholesky_orb.F 19706 2010-10-29 17:52:31Z d3y133 $
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER l_a_offset
      INTEGER k_a_offset
      INTEGER size
      INTEGER length
      INTEGER addr
      INTEGER mu
      INTEGER nu
      INTEGER rho
      INTEGER sigma
      INTEGER azone1,azone2,azone3
      INTEGER g2b
      length = 0
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      DO g2b    =  1,noa+nva    !g2b
      DO azone3 = 1,atpart      !sigma
      length = length + 1
      END DO
      END DO
      END DO
      END DO
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
     &set)) CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_a_offset) = length
      addr = 0
      size = 0
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      DO g2b    =  1,noa+nva    !g2b
      DO azone3 = 1,atpart      !sigma
      addr = addr + 1
      int_mb(k_a_offset+addr) = azone3-1+atpart*(g2b-1+(noa+nva)*
     &    (azone2 - 1 + atpart * (azone1 - 1)))
      int_mb(k_a_offset+length+addr) = size
      size = size + nalength(azone1) * nalength(azone2) * 
     &  nalength(azone3) * int_mb(k_range_alpha+g2b-1)
      END DO
      END DO
      END DO
      END DO
      RETURN
      END
c
c
c
c
      SUBROUTINE tce_2a2m_offsetx2(l_a_offset,k_a_offset,size)
C     $Id: tce_ao2e_cholesky_orb.F 19706 2010-10-29 17:52:31Z d3y133 $
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER l_a_offset
      INTEGER k_a_offset
      INTEGER size
      INTEGER length
      INTEGER addr
      INTEGER g1b,g2b
      INTEGER azone1,azone2
      length = 0
      DO g1b = 1,noa+nva   !k
      DO g2b = g1b,noa+nva !l
      DO azone1 = 1,atpart !nu
      DO azone2 = azone1,atpart !mu
      length = length + 1
      END DO
      END DO
      END DO
      END DO
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
     &set)) CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_a_offset) = length
      addr = 0
      size = 0
      DO g1b = 1,noa+nva   !k
      DO g2b = g1b,noa+nva !l
      DO azone1 = 1,atpart !nu
      DO azone2 = azone1,atpart !mu
      addr = addr + 1
      int_mb(k_a_offset+addr) = azone2 - 1 + atpart*( azone1 - 1 +
     & atpart*(g2b - 1 + (noa+nva) * (g1b-1)))
      int_mb(k_a_offset+length+addr) = size
      size = size + 
     &   int_mb(k_range_alpha+g1b-1) * int_mb(k_range_alpha+g2b-1)
     &      *  nalength(azone1) * nalength(azone2)
      END DO
      END DO
      END DO
      END DO
      RETURN
      END
c
c
c
      SUBROUTINE tce_1a3m_offsetx2(l_a_offset,k_a_offset,size)
C     $Id: tce_ao2e_cholesky_orb.F 19706 2010-10-29 17:52:31Z d3y133 $
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER l_a_offset
      INTEGER k_a_offset
      INTEGER size
      INTEGER length
      INTEGER addr
      INTEGER g1b,g2b,g4b
      INTEGER azone1,azone2
      length = 0
      DO g1b = 1,noa+nva   !k
      DO g2b = g1b,noa+nva !l
      DO g4b = 1,noa+nva   !i
      DO azone1 = 1,atpart !nu
      length = length + 1
      END DO
      END DO
      END DO
      END DO
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
     &set)) CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_a_offset) = length
      addr = 0
      size = 0
      DO g1b = 1,noa+nva   !k
      DO g2b = g1b,noa+nva !l
      DO g4b = 1,noa+nva   !i
      DO azone1 = 1,atpart !nu
      addr = addr + 1
      int_mb(k_a_offset+addr) = azone1-1+atpart*(g4b-1+(noa+nva)*
     &  (g2b-1+(noa+nva)*(g1b-1)))
      int_mb(k_a_offset+length+addr) = size
      size = size + 
     &   int_mb(k_range_alpha+g1b-1) * int_mb(k_range_alpha+g2b-1)
     &      * int_mb(k_range_alpha+g4b-1) *  nalength(azone1)
      END DO
      END DO
      END DO
      END DO
      RETURN
      END
c
      subroutine a4_offset(azone1,azone2,azone3,size_ic,
     &           l_a4_offset,k_a4_offset)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER azone1,azone2,azone3,size_ic,l_a4_offset,k_a4_offset
      INTEGER i,j,k,size_int,length_a4,azone4,a4_ini,a4_fin,offset_a4
      length_a4=0
      size_int=0
      do azone4=azone3,atpart
       size_int=size_int+nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
       if(size_int.gt.size_ic) then
        length_a4=length_a4+1 
        size_int= nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
       end if
      enddo
      if(size_int.ne.0) length_a4=length_a4+1
      IF (.not.MA_PUSH_GET(mt_int,3*length_a4+1,'noname',
     &l_a4_offset,k_a4_offset))
     & CALL ERRQUIT('tce_a4_offset',0,MA_ERR)
      int_mb(k_a4_offset) = length_a4
c     
      i=0 
      a4_ini=azone3 
      size_int=0
      do azone4=azone3,atpart
       size_int=size_int+nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
       if(size_int.gt.size_ic) then
        i=i+1
        int_mb(k_a4_offset+i)=a4_ini
        int_mb(k_a4_offset+length_a4+i)=azone4-1
        int_mb(k_a4_offset+2*length_a4+i)=size_int-
     1            nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
        size_int= nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*nalength(azone4)
        a4_ini=azone4 
       end if
      enddo
      if(size_int.ne.0) then
        i=i+1
        int_mb(k_a4_offset+i)=a4_ini
        int_mb(k_a4_offset+length_a4+i)=atpart
        int_mb(k_a4_offset+2*length_a4+i)=size_int
      end if 
      if(i.ne.length_a4) 
     & CALL ERRQUIT('tce_a4_off problems',0,MA_ERR)
      return 
      end
c
c
c
      subroutine a3_offset(azone1,azone2,g3b,size_ic,
     &           l_a3_offset,k_a3_offset)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER azone1,azone2,g3b,size_ic,l_a3_offset,k_a3_offset
      INTEGER i,j,k,size_int,length_a3,azone3,a3_ini,a3_fin,offset_a3
      length_a3=0
      size_int=0
      do azone3=1,atpart
       size_int=size_int+nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*int_mb(k_range_alpha+g3b-1)
       if(size_int.gt.size_ic) then
        length_a3=length_a3+1 
        size_int= nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*int_mb(k_range_alpha+g3b-1)
       end if
      enddo
      if(size_int.ne.0) length_a3=length_a3+1
      IF (.not.MA_PUSH_GET(mt_int,3*length_a3+1,'noname',
     &l_a3_offset,k_a3_offset))
     & CALL ERRQUIT('tce_a3_offset',0,MA_ERR)
      int_mb(k_a3_offset) = length_a3
c     
      i=0 
      a3_ini=1
      size_int=0
      do azone3=1,atpart
       size_int=size_int+nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*int_mb(k_range_alpha+g3b-1)
       if(size_int.gt.size_ic) then
        i=i+1
        int_mb(k_a3_offset+i)=a3_ini
        int_mb(k_a3_offset+length_a3+i)=azone3-1
        int_mb(k_a3_offset+2*length_a3+i)=size_int-
     1            nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*int_mb(k_range_alpha+g3b-1)
        size_int= nalength(azone1)*nalength(azone2)*
     1            nalength(azone3)*int_mb(k_range_alpha+g3b-1)
        a3_ini=azone3 
       end if
      enddo
      if(size_int.ne.0) then
        i=i+1
        int_mb(k_a3_offset+i)=a3_ini
        int_mb(k_a3_offset+length_a3+i)=atpart
        int_mb(k_a3_offset+2*length_a3+i)=size_int
      end if 
      if(i.ne.length_a3) 
     & CALL ERRQUIT('tce_a3_off problems',0,MA_ERR)
      return 
      end
c
c
c
      subroutine a2_offset(azone1,g4b,g3b,size_ic,
     &           l_a2_offset,k_a2_offset)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER azone1,g4b,g3b,size_ic,l_a2_offset,k_a2_offset
      INTEGER i,j,k,size_int,length_a2,azone2,a2_ini,a2_fin,offset_a2
      length_a2=0
      size_int=0
      do azone2=azone1,atpart
       size_int=size_int+nalength(azone1)*nalength(azone2)*
     1           int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
       if(size_int.gt.size_ic) then
        length_a2=length_a2+1 
        size_int= nalength(azone1)*nalength(azone2)*
     1         int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
       end if
      enddo
      if(size_int.ne.0) length_a2=length_a2+1
      IF (.not.MA_PUSH_GET(mt_int,3*length_a2+1,'noname',
     &l_a2_offset,k_a2_offset))
     & CALL ERRQUIT('tce_a2_offset',0,MA_ERR)
      int_mb(k_a2_offset) = length_a2
c     
      i=0 
      a2_ini=azone1
      size_int=0
      do azone2=azone1,atpart
       size_int=size_int+nalength(azone1)*nalength(azone2)*
     1          int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
       if(size_int.gt.size_ic) then
        i=i+1
        int_mb(k_a2_offset+i)=a2_ini
        int_mb(k_a2_offset+length_a2+i)=azone2-1
        int_mb(k_a2_offset+2*length_a2+i)=size_int-
     1            nalength(azone1)*nalength(azone2)*
     1       int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
        size_int= nalength(azone1)*nalength(azone2)*
     1       int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1)
        a2_ini=azone2 
       end if
      enddo
      if(size_int.ne.0) then
        i=i+1
        int_mb(k_a2_offset+i)=a2_ini
        int_mb(k_a2_offset+length_a2+i)=atpart
        int_mb(k_a2_offset+2*length_a2+i)=size_int
      end if 
      if(i.ne.length_a2) 
     & CALL ERRQUIT('tce_a2_off problems',0,MA_ERR)
      return 
      end
c
c
c
      subroutine a1_offset(g1b,g2b,g3b,size_ic,
     &           l_a1_offset,k_a1_offset)
      IMPLICIT NONE
#include "global.fh"
#include "mafdecls.fh"
#include "sym.fh"
#include "errquit.fh"
#include "tce.fh"
#include "tce_main.fh"
      INTEGER g1b,g2b,g3b,size_ic,l_a1_offset,k_a1_offset
      INTEGER i,j,k,size_int,length_a1,azone1,a1_ini,a1_fin,offset_a1
      length_a1=0
      size_int=0
      do azone1=1,atpart
       size_int=size_int+nalength(azone1)*int_mb(k_range_alpha+g1b-1)*
     1          int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g3b-1)
       if(size_int.gt.size_ic) then
        length_a1=length_a1+1 
        size_int= nalength(azone1)*int_mb(k_range_alpha+g1b-1)*
     1        int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g3b-1)
       end if
      enddo
      if(size_int.ne.0) length_a1=length_a1+1
      IF (.not.MA_PUSH_GET(mt_int,3*length_a1+1,'noname',
     &l_a1_offset,k_a1_offset))
     & CALL ERRQUIT('tce_a1_offset',0,MA_ERR)
      int_mb(k_a1_offset) = length_a1
c       
      i=0 
      a1_ini=1
      size_int=0
      do azone1=1,atpart
       size_int=size_int+nalength(azone1)*int_mb(k_range_alpha+g1b-1)*
     1        int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g3b-1)
       if(size_int.gt.size_ic) then
        i=i+1
        int_mb(k_a1_offset+i)=a1_ini
        int_mb(k_a1_offset+length_a1+i)=azone1-1
        int_mb(k_a1_offset+2*length_a1+i)=size_int-
     1        nalength(azone1)*int_mb(k_range_alpha+g1b-1)*
     1        int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g3b-1)
        size_int=nalength(azone1)*int_mb(k_range_alpha+g1b-1)*
     1        int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g3b-1) 
        a1_ini=azone1 
       end if
      enddo
      if(size_int.ne.0) then
        i=i+1
        int_mb(k_a1_offset+i)=a1_ini
        int_mb(k_a1_offset+length_a1+i)=atpart
        int_mb(k_a1_offset+2*length_a1+i)=size_int
      end if 
      if(i.ne.length_a1) 
     & CALL ERRQUIT('tce_a1_off problems',0,MA_ERR)
      return 
      end
