      SUBROUTINE tce_mo2e_zones_4a_disk_4s_new_patch_m2(rtdb,d_v2,
     1                                kax_v2_alpha_offset,size_2e)
C     $Id$
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,filename_aux
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 new offseting fro 13 and 14
      integer k_aux,l_aux,size_aux
c
c *** debug ***
c      double precision xxx,xmax
c      integer iqx
      integer ierrcode1,ierrcode2
c *************
c 
c multiple files ===============
       integer k_offset_4a_m(1000),l_offset_4a_m(1000)
       integer k_offset_3a1m_m(1000),l_offset_3a1m_m(1000)
       integer k_offset_2a2m_m(1000),l_offset_2a2m_m(1000)
       integer k_offset_1a3m_m(1000),l_offset_1a3m_m(1000)
       integer size_4a_m(1000),size_3a1m_m(1000)
       integer size_2a2m_m(1000),size_1a3m_m(1000)
       integer n_4a_files,n_3a1m_files
       integer n_2a2m_files,n_1a3m_files 
       integer handle_4a_m(1000),handle_3a1m_m(1000)
       integer handle_2a2m_m(1000),handle_1a3m_m(1000)
       integer my_file_to_write,my_file_to_read
       integer n_max_files 
c
       integer size_l(1000),n_str,size_g
       integer addr
c
c *** debug ***
       double precision xmax
c ==============================
      logical parallel
c
      INTEGER length
      INTEGER next
      INTEGER nprocs
      INTEGER count
      integer nxtask
      external nxtask
      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
      call tce_mo2e_offset_intorb_old(l_aux,
     &         k_aux,size_aux)
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
c
c
       chunk_max1=size_ic
       chunk_max2=size_ic
c
c offsets for 2
c
c
c DISK USAGE ONLY !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c 
      if(.not.parallel)
     1  call errquit('sf only for parallel runs',1,DISK_ERR)
      if(idiskl) then
c dummy for idiskl true
      else
       if(parallel) call ga_sync()
c
c Jeff: This code makes no sense because filename is not defined.
c
       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
c
c
       n_max_files=1000
       do i=1,n_max_files
        k_offset_4a_m(i)=0
        l_offset_4a_m(i)=0
        k_offset_3a1m_m(i)=0
        l_offset_3a1m_m(i)=0
        k_offset_2a2m_m(i)=0
        l_offset_2a2m_m(i)=0
        k_offset_1a3m_m(i)=0
        l_offset_1a3m_m(i)=0
        size_4a_m(i)=0
        size_3a1m_m(i)=0
        size_2a2m_m(i)=0
        size_1a3m_m(i)=0
       enddo
c
c      write(6,*)'step1'
c      call util_flush(6)
c
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ccx       call tce_1a3m_offsetyy1(l_offset_1a3m_m,k_offset_1a3m_m,   xx
ccx     &      size_1a3m_m,n_1a3m_files)                             xx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c
      do i=1,1000
       size_l(i)=0
      enddo
c
      i = 0
      DO g3b = 1,noa+nva   !k
      i=i+1
      length=0
      DO g4b = g3b,noa+nva !l
      DO g2b = 1,noa+nva   !i
      DO azone1 = 1,atpart !nu
      length = length + 1
      END DO
      END DO
      END DO
      size_l(i)=length
      END DO
      n_str=i
      n_1a3m_files=n_str
c
      do i=1,n_str
      IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname4',
     & l_offset_1a3m_m(i),k_offset_1a3m_m(i)))
     & CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_offset_1a3m_m(i)) = size_l(i)
c
c      write(6,*)'1a3m yy1 i size_l(i)',i,size_l(i)
c      call util_flush(6)
c
      enddo
c
      i = 0
      DO g3b = 1,noa+nva   !k
        i=i+1
        addr=0
        size_g=0
        length=size_l(i)
      DO g4b = g3b,noa+nva !l
      DO g2b = 1,noa+nva   !i
      DO azone1 = 1,atpart !nu
      addr = addr + 1
      int_mb(k_offset_1a3m_m(i)+addr)=azone1-1+atpart*(g2b-1+(noa+nva)*
     &  (g4b-1+(noa+nva)*(g3b-1)))
      int_mb(k_offset_1a3m_m(i)+length+addr) = size_g
      size_g = size_g +
     &   int_mb(k_range_alpha+g3b-1) * int_mb(k_range_alpha+g4b-1)
     &      * int_mb(k_range_alpha+g2b-1) *  nalength(azone1)
      END DO
      END DO
      END DO
        size_1a3m_m(i)=size_g
      END DO
c
c
c
c
c      write(6,*)'step2 n_1a3m_files',n_1a3m_files
c      call util_flush(6)
c
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 
cxxxxx       call tce_2a2m_offsetyy1(l_offset_2a2m_m,k_offset_2a2m_m, xx
cxxxxx     &      size_2a2m_m,n_2a2m_files)                           xx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c
      do i=1,1000
       size_l(i)=0
      enddo
c
      i = 0
      DO g3b = 1,noa+nva   !k
      i=i+1
      length=0
      DO g4b = g3b,noa+nva !l
      DO azone1 = 1,atpart !nu
      DO azone2 = azone1,atpart !mu
      length = length + 1
      END DO
      END DO
      END DO
      size_l(i)=length
      END DO
      n_str=i
      n_2a2m_files=n_str
c
      do i=1,n_str
      IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname3',
     & l_offset_2a2m_m(i),k_offset_2a2m_m(i)))
     & CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_offset_2a2m_m(i)) = size_l(i)
c
c      write(6,*)'2a2m yy1 i size_l(i)',i,size_l(i)
c      call util_flush(6)
c
      enddo
c
      i = 0
      DO g3b = 1,noa+nva   !k
        i=i+1
        addr=0
        size_g=0
        length=size_l(i)
      DO g4b = g3b,noa+nva !l
      DO azone1 = 1,atpart !nu
      DO azone2 = azone1,atpart !mu
      addr = addr + 1
      int_mb(k_offset_2a2m_m(i)+addr)=azone2 - 1 + atpart*( azone1 - 1 +
     & atpart*(g4b - 1 + (noa+nva) * (g3b-1)))
      int_mb(k_offset_2a2m_m(i)+length+addr) = size_g
      size_g = size_g +
     &   int_mb(k_range_alpha+g3b-1) * int_mb(k_range_alpha+g4b-1)
     &      *  nalength(azone1) * nalength(azone2)
      END DO
      END DO
      END DO
        size_2a2m_m(i)=size_g
      END DO
c
c
c
c      write(6,*)'step3,n_2a2m_files',n_2a2m_files
c      call util_flush(6)
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ccx       call tce_3a1m_offsetyy1(l_offset_3a1m_m,k_offset_3a1m_m,   xxx
ccx     &      size_3a1m_m,n_3a1m_files)                             xxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c      write(6,*)'step4 n_3a1m_files'
c      call util_flush(6)
c
      do i=1,1000
       size_l(i)=0
      enddo
c
      i=0
      DO azone1 = 1,atpart      !nu
      i=i+1
      length=0
      DO azone2 = azone1,atpart !mu
      DO g4b    =  1,noa+nva    !g2b
      DO azone3 = 1,atpart      !sigma
      length = length + 1
      END DO
      END DO
      END DO
      size_l(i)=length
      END DO
      n_str=i
      n_3a1m_files=n_str
c *** debug ***
c      write(6,*)'from 3a1m'
c      do i=1,n_str
c       write(6,*)'size_l(i) i',size_l(i),i
c       call util_flush(6)
c      enddo
c      write(6,*)
c *************
c
      do i=1,n_str
      IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname2',
     & l_offset_3a1m_m(i),k_offset_3a1m_m(i)))
     & CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_offset_3a1m_m(i)) = size_l(i)
c
c      write(6,*)'3a1m yy1 i size_l(i)',i,size_l(i)
c      call util_flush(6)
c
      enddo
c
      i=0
      DO azone1 = 1,atpart      !nu
        i=i+1
        addr=0
        size_g=0
        length=size_l(i)
      DO azone2 = azone1,atpart !mu
      DO g4b    =  1,noa+nva    !g2b
      DO azone3 =  1,atpart     !sigma
      addr = addr + 1
      int_mb(k_offset_3a1m_m(i)+addr)=azone3-1+atpart*(g4b-1+(noa+nva)*
     &    (azone2 - 1 + atpart * (azone1 - 1)))
      int_mb(k_offset_3a1m_m(i)+length+addr) = size_g
      size_g = size_g + nalength(azone1) * nalength(azone2) *
     &  nalength(azone3) * int_mb(k_range_alpha+g4b-1)
      END DO
      END DO
      END DO
        size_3a1m_m(i)=size_g
      END DO
c
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxx       call tce_4a_offsetyy1(l_offset_4a_m,k_offset_4a_m,   xxxx
cxx     &      size_4a_m,n_4a_files)                           xxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c
      do i=1,1000
       size_l(i)=0
      enddo
c
      i = 0
      DO azone1 = 1,atpart      !nu
      i=i+1
      length=0
      DO azone2 = azone1,atpart !mu
      DO azone3 = 1,atpart      !sigma
      DO azone4 = azone3,atpart !rho
      length = length + 1
      END DO
      END DO
      END DO
      size_l(i)=length
      END DO
      n_str=i
      n_4a_files=n_str
c
      do i=1,n_str
      IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname1',
     & l_offset_4a_m(i),k_offset_4a_m(i)))
     & CALL ERRQUIT('tce_t2_offset',0,MA_ERR)
      int_mb(k_offset_4a_m(i)) = size_l(i)
c
c      write(6,*)'4a yy1 i size_l(i)',i,size_l(i)
c      call util_flush(6)
c
      enddo
c
      i=0
      DO azone1 = 1,atpart      !nu
        i=i+1
        addr=0
        size_g=0
        length=size_l(i)
      DO azone2 = azone1,atpart !mu
      DO azone3 = 1,atpart      !sigma
      DO azone4 = azone3,atpart !rho
      addr = addr + 1
      int_mb(k_offset_4a_m(i)+addr)=azone4 - 1 + atpart * (azone3 - 1 +
     &  atpart * (azone2 - 1 + atpart * (azone1 - 1)))
      int_mb(k_offset_4a_m(i)+length+addr) = size_g
      size_g = size_g + nalength(azone1) * nalength(azone2) *
     &  nalength(azone3) * nalength(azone4)
      END DO
      END DO
      END DO
        size_4a_m(i)=size_g
      END DO
c
c
c
c
c
c      write(6,*)'step5 n_4a_files',n_4a_files
c      call util_flush(6)
c debug *******
c        stop 
c *************
c
c *** debug ***
c          if(nodezero) then
c           write(6,*)'n_4a_files',n_4a_files
c           write(6,*)'n_3a1m_files',n_3a1m_files
c           write(6,*)'n_2a2m_files',n_2a2m_files
c           write(6,*)'n_1a3m_files',n_1a3m_files
c           write(6,*)'atpart',atpart
c           write(6,*)'noa+nva',noa+nva
c           write(6,*)'noa',noa
c           write(6,*)'nva',nva 
c           call util_flush(6)
c          end if
c *************
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

      if(nodezero) then
        write(6,*)'before sf_create'
        write(6,*)'n_4a_files',n_4a_files
        write(6,*)'sizes:'
        do i=1,n_4a_files
         write(6,301) i,size_4a_m(i)
        enddo 
        write(6,*)'-----------------'
  301   format('size_4a_m(i)',2x,i4,2x,i10)
        call util_flush(6)
      end if
c
      if(idiskl) then
       do i=1,n_4a_files
ccx        call tce_filenameindexed(i,'a4f',filename_aux)
ccx        call util_file_name(filename_aux,.false.,.false.,filename)
        call tce_filename_4ind(i,'a4f',filename)
c *** debug ***
c        write(6,*)'filename=',filename,i,ga_nodeid()
c        write(6,*)'size_4a_m(i)',size_4a_m(i),i,ga_nodeid()
c
c *************
        if (sf_create(filename,dble(bytes)*dble(size_4a_m(i)),
     1   dble(bytes)*dble(size_4a_m(i)),chunk_max1,handle_4a_m(i))
     1   .ne.0)
     2   call errquit('4-index: sf problem opening 4af',0,DISK_ERR)
       enddo
      end if
c
      if(nodezero) then
        write(6,*)'after sf_create'
        call util_flush(6)
      end if
c
c ============================ 
c
             cpu = - util_cpusec()
             wall = - util_wallsec()
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c attention: I have interchanged the orderign 
c from    azone1 azone2 azone3 azone4
c to      azone3 azone4 azone1 azone2
c      DO azone1 = 1,atpart      !nu
c      DO azone2 = azone1,atpart !mu
      DO azone3 = 1,atpart      !sigma
      DO azone4 = azone3,atpart !rho
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
      IF (next.eq.count) THEN
c ---------------------------
        my_file_to_write=azone1
c(atpart*(atpart+1))/2-
c     1   ((atpart-azone1+1)*(atpart-azone1))/2-
c     1   (atpart-azone2+1)+1
        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_offset_4a_m(my_file_to_write)),
     &          key_4af,offset_4af)
      if(idiskl) then !----
c *** debug ***
c       xmax=0.0d0
c       do i=1,size_4a
c        xmax=xmax+dbl_mb(k_4a+i-1)
c       enddo
c       write(6,200) azone4,azone3,azone2,azone1,xmax
c 200   format('4A ',4i5,3x,f19.8)
c       call util_flush(6)
c *************
        ierrcode1=sf_write(handle_4a_m(my_file_to_write),
     1    dble(bytes)*dble(offset_4af),
     1    dble(bytes)*dble(size_4a),dbl_mb(k_4a),request)
ccx        if (sf_write(i_to_x,dble(bytes)*dble(offset_4af),
ccx     1    dble(bytes)*dble(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),size_4a)
      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 = nxtask(-nprocs,1)
c
      cpu = cpu + util_cpusec()
      wall = wall + util_wallsec()
      if(nodezero) then
       write(6,*)'4A integrals cpu,wall ',cpu,wall
       call util_flush(6)
      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
c
      if(nodezero) then
        write(6,*)'STEP2 4index'
        call util_flush(6)
      end if
c
c
c
c
c
c DISK CHANGES =============== 3A1M
c closing/reopening handle_4a_m files
c opening handle_3a1m_m files
      if(idiskl) then
c       
      do i=1,n_4a_files
        if(sf_rwtor(handle_4a_m(i)).ne.0)
     2    call errquit('4-index: sf_rwtor 4a',0,DISK_ERR)
      enddo 
c
       do i=1,n_3a1m_files
ccx        call tce_filenameindexed(i,'3a1mf',filename_aux)
ccx        call util_file_name(filename_aux,.false.,.false.,filename)
        call tce_filename_4ind(i,'3a1mf',filename)
        if (sf_create(filename,dble(bytes)*dble(size_3a1m_m(i)),
     1   dble(bytes)*dble(size_3a1m_m(i)),chunk_max1,
     1   handle_3a1m_m(i)).ne.0)
     2   call errquit('4-index: sf problem opening 3a1mf',0,DISK_ERR)
       enddo
c
      end if ! idiskl
c ============================
c
      cpu = - util_cpusec()
      wall = - util_wallsec()
c
c 3A1M part here
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c
c changed ordering 
c from: 
c      azone1 azone2 g4b azone3
c to:
c      g4b azone3 azone1 azone2 
c
c      DO azone1 = 1,atpart      !nu
c      DO azone2 = azone1,atpart !mu
      DO g4b = 1,noa+nva        !k
      DO azone3 = 1,atpart      !sigma
      DO azone1 = 1,atpart      !nu
      DO azone2 = azone1,atpart !mu
ccx      DO g4b = 1,noa+nva        !k
c
      IF (next.eq.count) THEN
c
        my_file_to_read=azone1
c(atpart*(atpart+1))/2-
c     1   ((atpart-azone1+1)*(atpart-azone1))/2-
c     1   (atpart-azone2+1)+1
        my_file_to_write=azone1
c(atpart*(atpart+1))/2-
c     1   ((atpart-azone1+1)*(atpart-azone1))/2-
c     1   (atpart-azone2+1)+1
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_offset_4a_m(my_file_to_read)),
     &          key_ini,offset_bl4a)
c
       size_bl4a   = int_mb(k_a4_offset+2*length_a4+ii) 
      if(idiskl) then !---------
        ierrcode1=sf_read(handle_4a_m(my_file_to_read),
     1    dble(bytes)*dble(offset_bl4a),
     1    dble(bytes)*dble(size_bl4a),dbl_mb(k_integral),
     1    request)
ccx        if (sf_read(i_from_x,dble(bytes)*dble(offset_bl4a),
ccx     1    dble(bytes)*dble(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),size_bl4a)
      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_offset_4a_m(my_file_to_read)),
     1        key_4af,offset_4af)
      if(idiskl) then !---------
        ierrcode1=sf_read(handle_4a_m(my_file_to_read),
     1 dble(bytes)*dble(offset_4af),
     1 dble(bytes)*dble(size_4a),dbl_mb(k_integral),request)
ccx        if (sf_read(i_from_x,dble(bytes)*dble(offset_4af),
ccx     1 dble(bytes)*dble(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),size_4a)
      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_offset_3a1m_m(my_file_to_write)),
     &     key_3a1m,offset_3a1m)
       if(idiskl) then ! --------
c *** debug ***
c       xmax=0.0d0
c       do i=1,size_3a1m
c        xmax=xmax+dbl_mb(k_3a1m+i-1)
c       enddo
c       write(6,201) azone3,g4b,azone2,azone1,xmax
c 201   format('3A1M ',4i5,3x,f19.8)
c       call util_flush(6)
c *************
        ierrcode1=sf_write(handle_3a1m_m(my_file_to_write),
     1    dble(bytes)*dble(offset_3a1m),
     1    dble(bytes)*dble(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),size_3a1m)
       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 = nxtask(-nprocs,1)
c
      cpu = cpu + util_cpusec()
      wall = wall + util_wallsec()
      if(nodezero) then 
       write(6,*)'3A1M integrals cpu wall',cpu,wall
       call util_flush(6)
      end if
c
c Destroying all l_offset_4a_m(n_4a_files)
c    
      if(idiskl) then
       do i=n_4a_files,1,-1
        if (.not.ma_pop_stack(l_offset_4a_m(i)))
     1   call errquit('4-ind n5: l_offset_4a_m err.',15,MA_ERR)
       enddo
      endif
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
c DISK CHANGES =============== 2A2M
c destroying handle_4a
c closing/reopening handle_3a1m file
c opening handle_2a2m file
      if(idiskl) then
c
      do i=1,n_4a_files
       if (sf_destroy(handle_4a_m(i)).ne.0)
     1   call errquit('tce_sf_destroy: sf problem handle_4a',15,MA_ERR)
      enddo
c
      do i=1,n_3a1m_files
        if(sf_rwtor(handle_3a1m_m(i)).ne.0) 
     2    call errquit('4-index: sf_rwtor 3a1m',0,DISK_ERR)
      enddo
c
       do i=1,n_2a2m_files
ccx        call tce_filenameindexed(i,'2a2mf',filename_aux)
ccx        call util_file_name(filename_aux,.false.,.false.,filename)
        call tce_filename_4ind(i,'2a2mf',filename)
        if (sf_create(filename,dble(bytes)*dble(size_2a2m_m(i)),
     1   dble(bytes)*dble(size_2a2m_m(i)),chunk_max1,
     1   handle_2a2m_m(i)).ne.0)
     2   call errquit('4-index: sf problem opening 2a2mf',0,DISK_ERR)
       enddo
c
      end if ! idiskl true
c ============================
c
      cpu = - util_cpusec()
      wall = - util_wallsec()
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
        my_file_to_read=azone1
c(atpart*(atpart+1))/2-
c     1   ((atpart-azone1+1)*(atpart-azone1))/2-
c     1   (atpart-azone2+1)+1
        my_file_to_write=g3b
c((noa+nva)*(noa+nva+1))/2-
c     1   ((noa+nva-g3b+1)*(noa+nva-g3b))/2-
c     1   (noa+nva-g4b+1)+1
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_offset_3a1m_m(my_file_to_read)),
     &   key_ini,offset_bl3a1m)
c
       size_bl3a1m   = int_mb(k_a3_offset+2*length_a3+ii)
c
c
       if(idiskl) then ! -------
        ierrcode1=sf_read(handle_3a1m_m(my_file_to_read),
     2    dble(bytes)*dble(offset_bl3a1m),
     2    dble(bytes)*dble(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),size_bl3a1m) 
       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_offset_2a2m_m(my_file_to_write)),
     &     key_2a2m,offset_2a2m)
       if(idiskl) then ! -------
c *** debug ***
c       xmax=0.0d0
c       do i=1,size_2a2m
c        xmax=xmax+dbl_mb(k_2a2m+i-1)
c       enddo
c       write(6,202) azone2,azone1,g4b,g3b,xmax,
c     &              my_file_to_write,ga_nodeid(),key_2a2m,
c     &              offset_2a2m
c 202   format('2A2M ',4i5,3x,f19.8,2x,2i6,2x,2i8)
c       call util_flush(6)
c *************
        ierrcode1=sf_write(handle_2a2m_m(my_file_to_write),
     2                   dble(bytes)*dble(offset_2a2m),
     2    dble(bytes)*dble(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),size_2a2m)
       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 = nxtask(-nprocs,1)
c
      cpu = cpu + util_cpusec()
      wall = wall + util_wallsec()
      if(nodezero) then
       write(6,*)'2A2M integrals cpu wall',cpu,wall
       call util_flush(6)
      end if
c
c
c Destroying all l_offset_3a1m_m(n_3a1m_files)
c
      if(idiskl) then
      do i=n_3a1m_files,1,-1
       if (.not.ma_pop_stack(l_offset_3a1m_m(i)))
     1  call errquit('4-ind n5: l_offset_3a1m_m err.',15,MA_ERR)
      enddo
      end if
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
c
c DISK CHANGES =============== 1A3M
c destroying handle_3a1m
c closing/reopening handle_2a2m file
c opening handle_1a3m file
      if(idiskl) then
c
      do i=1,n_3a1m_files
       if (sf_destroy(handle_3a1m_m(i)).ne.0)
     1  call errquit('tce_sf_destroy: sf problem handle_3a1m',15,MA_ERR)
      enddo 
c
      do i=1,n_2a2m_files
        if(sf_rwtor(handle_2a2m_m(i)).ne.0)
     2    call errquit('4-index: sf_rwtor 2a2m',0,DISK_ERR)
      enddo
c
       do i=1,n_1a3m_files
ccx        call tce_filenameindexed(i,'1a3mf',filename_aux)
ccx        call util_file_name(filename_aux,.false.,.false.,filename)
        call tce_filename_4ind(i,'1a3mf',filename)
        if (sf_create(filename,dble(bytes)*dble(size_1a3m_m(i)),
     1   dble(bytes)*dble(size_1a3m_m(i)),chunk_max1,
     1   handle_1a3m_m(i)).ne.0)
     2   call errquit('4-index: sf problem opening 1a3mf',0,DISK_ERR)
       enddo
c
      end if !idiskl
c ============================
c
      cpu = - util_cpusec()
      wall = - util_wallsec()
c
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)

      DO g2b = 1,noa+nva   !
      DO azone1 = 1,atpart      !nu
      DO g3b = 1,noa+nva   !k
      DO g4b = g3b,noa+nva !l
c
      IF (next.eq.count) THEN
        my_file_to_read=g3b
c((noa+nva)*(noa+nva+1))/2-
c     1   ((noa+nva-g3b+1)*(noa+nva-g3b))/2-
c     1   (noa+nva-g4b+1)+1
        my_file_to_write=g3b
c((noa+nva)*(noa+nva+1))/2-
c     1   ((noa+nva-g3b+1)*(noa+nva-g3b))/2-
c     1   (noa+nva-g4b+1)+1
      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
      DO azone2 = 1,atpart ! two cases here
       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_offset_2a2m_m(my_file_to_read)),
     &        key_2a2m,offset_2a2m)
        if(idiskl) then !------
        if (sf_read(handle_2a2m_m(my_file_to_read),
     &    dble(bytes)*dble(offset_2a2m),
     &    dble(bytes)*dble(size_2a2m),dbl_mb(k_2a2m),request).ne.0)
     &    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),size_2a2m)
        end if !-----
       else  ! ------------------------------------------------------------
        key_2a2m=azone1 - 1 + atpart*( azone2 - 1 +
     &  atpart*(g4b - 1 + (noa+nva) * (g3b-1)))
         call tce_hash(int_mb(k_offset_2a2m_m(my_file_to_read)),
     &                 key_2a2m,offset_2a2m)
        if(idiskl) then ! ------
        if (sf_read(handle_2a2m_m(my_file_to_read),
     &    dble(bytes)*dble(offset_2a2m),
     &    dble(bytes)*dble(size_2a2m),dbl_mb(k_2a2m),request).ne.0)
     &    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),size_2a2m)
        end if ! ------
        end if !  ---------------------------------------------------------
       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
        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
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_offset_1a3m_m(my_file_to_write)),
     &      key_1a3m,offset_1a3m)
c
       if(idiskl) then !---------
c *** debug ***
c       xmax=0.0d0
c       do i=1,size_1a3m
c        xmax=xmax+dbl_mb(k_1a3m+i-1)
c       enddo
c       write(6,203) azone1,g2b,g4b,g3b,xmax,my_file_to_write,
c     &              ga_nodeid(),key_1a3m,offset_1a3m
c 203   format('1A3M ',4i5,3x,f19.8,2x,i4,2x,i3,2x,2i8)
c       call util_flush(6)
c *************
        if (sf_write(handle_1a3m_m(my_file_to_write),
     &    dble(bytes)*dble(offset_1a3m),
     &    dble(bytes)*dble(size_1a3m),dbl_mb(k_1a3m),request).ne.0)
     &    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),size_1a3m)
       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 = nxtask(-nprocs,1)
c
      cpu = cpu + util_cpusec()
      wall = wall + util_wallsec()
      if(nodezero) then
       write(6,*)'1A3M integrals cpu wall',cpu,wall
       call util_flush(6)
      end if
c
c Destroying all l_offset_2a2m_m(n_2a2m_files)
c
      if(idiskl) then
       do i=n_2a2m_files,1,-1
        if (.not.ma_pop_stack(l_offset_2a2m_m(i)))
     1   call errquit('4-ind n5: l_offset_2a2m_m err.',15,MA_ERR)
       enddo
      end if
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
c DISK CHANGES =============== 4M
c destroying handle_2a2m
c closing/reopening handle_1a3m file
c opening handle_4m file
      if(idiskl) then
c
      do i=1,n_2a2m_files
       if (sf_destroy(handle_2a2m_m(i)).ne.0)
     1  call errquit('tce_sf_destroy: sf problem handle_2a2m',15,MA_ERR)
      enddo
c
      do i=1,n_1a3m_files
        if(sf_rwtor(handle_1a3m_m(i)).ne.0) 
     2    call errquit('4-index: sf_rwtor 1a3m',0,DISK_ERR)
      enddo
c
      end if
c ============================
c 
      cpu = - util_cpusec()
      wall = - util_wallsec()
c
      nprocs = GA_NNODES()
      count = 0
      next = NXTASK(nprocs, 1)
c
c
c Ordering of the do-loops has been changed from:
c g1b g2b g3b g4b
c to :
c g3b g4b g1b g2b (g1b,g2b are used to define file's number)
c
cx      DO g1b = 1,noa+nva      !nu
cx      DO g2b = g1b,noa+nva   !
      DO g3b = 1,noa+nva   !k
      DO g4b = g3b,noa+nva !l
      DO g1b = 1,noa+nva      !nu
      DO g2b = g1b,noa+nva   !
      IF (next.eq.count) THEN
        my_file_to_read=g1b
c((noa+nva)*(noa+nva+1))/2-
c     1   ((noa+nva-g1b+1)*(noa+nva-g1b))/2-
c     1   (noa+nva-g2b+1)+1
      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_offset_1a3m_m(my_file_to_read)),
     &    key_ini,offset_bl1a3m)
c
       size_bl1a3m  = int_mb(k_a1_offset+2*length_a1+ii)
       if(idiskl) then ! -------
        if (sf_read(handle_1a3m_m(my_file_to_read),
     &    dble(bytes)*dble(offset_bl1a3m),
     2    dble(bytes)*dble(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),size_bl1a3m)
       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
c *** debug ***
c       xmax=0.0d0
c       do i=1,size_4m
c        xmax=xmax+dbl_mb(k_4m+i-1)
c       enddo
c       write(6,204) ires,xmax
c 204   format('4M ',i5,3x,f19.8)
c       call util_flush(6)
c *************
         key_4m=ires
         call tce_hash_n(int_mb(k_aux),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 = nxtask(-nprocs,1)
c
c
      cpu = cpu + util_cpusec()
      wall = wall + util_wallsec()
      if(nodezero) then
       write(6,*)'4M integrals cpu wall',cpu,wall
       call util_flush(6)
      end if
c
c
c
c
c
c
c
      if(nodezero) then
      write(6,*)'DONE --- DONE ---- DONE ---- DONE'
      end if
c
ccx      if (.not.ma_pop_stack(l_work2))
ccx     1  call errquit('tce_ao2e: MA problem',14,MA_ERR)
ccx      if (.not.ma_pop_stack(l_work1))
ccx     1  call errquit('tce_ao2e: MA problem',15,MA_ERR)
c
c
c Destroying all l_offset_1a3m_m(n_1a3m_files)
c
c
      do i=n_1a3m_files,1,-1
       if (.not.ma_pop_stack(l_offset_1a3m_m(i)))
     1  call errquit('4-ind n5: l_offset_1a3m_m err.',15,MA_ERR)
      enddo
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_m files
c
      if(idiskl) then
      do i=1,n_1a3m_files
       if (sf_destroy(handle_1a3m_m(i)).ne.0)
     1  call errquit('tce_sf_destroy: sf problem handle_1a3m',15,MA_ERR)
      enddo
      end if
c ============================
c
c
      if(idiskl) then
c
c dummy part
c
      else
       call deletefile(i_from_x)
       call ga_sync() 
cccx       call deletefile(d_4af)
cccx       call ga_sync()
      end if
c
ccx      if (.not.ma_pop_stack(l_1a3m_offset))
ccx     1  call errquit('tce_off_1a3m: MA problem',15,MA_ERR)
c
ccx      if (.not.ma_pop_stack(l_2a2m_offset))
ccx     1  call errquit('tce_off_2a2m: MA problem',15,MA_ERR)
c
ccx      if (.not.ma_pop_stack(l_3a1m_offset))
ccx     1  call errquit('tce_off_3a1m: MA problem',15,MA_ERR)
c
ccx      if (.not.ma_pop_stack(l_4af_offset))
ccx     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
      if (.not.ma_pop_stack(l_aux))
     1  call errquit('tce_off_4a: MA problem',15,MA_ERR)
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
