      subroutine splitpqrs_s(i_typ_int)
      use module
      use mod_tijkl
      use mod_licost
      implicit real*8 (a-h,o-x,z),logical*1(y)
      integer(2),dimension(4,lblock) :: jdx4
      integer(2),allocatable,dimension(:,:,:) :: kdx4
      real(8),dimension(lblock) :: value2
      real(8),allocatable,dimension(:,:) :: value3
      integer tot_size
      integer,allocatable,dimension(:) :: ind
      character(4) c
      yw=.false.
      yw=yw.or.ywtot
!
!--------------------------------------------------------
! read the pqrs_s file corresponding to one quadruplet of
! symmetries is,js,ks,ls. (file number i_typ_int)
! the length of the file is nijkls(i_typ_int)
! being (p,q,r,s) an integral, the file is divided in
! "pair subsets"=integrals of same p,q
! the number n_pspq of pair subsets is:
! - if is==js    num1(isymoa(is)+1)
! - if is/=js    isymoa(is)*isymoa(js)
! The length n_psrs of the subsets are all equal to
! - if ks==ls    num1(isymoa(ks)+1)
! - if ks/=ls    isymoa(ks)*isymoa(ls)
! The pqrs_s file will be divided in nfil files containing a
! maximum of pair subsets (mps)
!--------------------------------------------------------
!
 
!
!tra1 : int mono atomiques   sym
!
! Find nfil 
!
      if(nprint>0)print*,' '
! total number of integrals to be stored
      max_pqrs=nijkls(i_typ_int)
      if(nprint>0)print*,'total number of integrals to be stored'
     *,max_pqrs
! max number of integrals in memory
      max_pqrs_s_mem=memb/16
      if(nprint>0)print*,'max number of integrals in memory'
     *,max_pqrs_s_mem,
     *'(max_pqrs_s_mem)'
! length of a pair subset
      if(nprint>0)print*,'length of a pair subset',n_psrs
! total number of pair subsets
      if(nprint>0)print*,'total number of pair subsets',n_pspq
! number of pair subsets that can fit in memory
      mps=max_pqrs_s_mem/n_psrs
      if(mps==0) stop 'mps insufficient memory'
      if(nprint>0)print*,
     *'number of pair subsets that can fit in memory',mps
! number of files
      nfil=n_pspq/mps
      if(mod(n_pspq,mps)/=0) nfil=nfil+1
      if(nprint>0)print*,'splitpqrs_s: number of files',nfil
      if(nprint>0)print*,' '
!
! The pqrs will now be splitted in nfil files containing mps 
! pair subsets (except the last one)
!
! One must fill rectangular matrices (kdx4,value3) for which each
! colomn corresponds to a file
! the number of columns is nfil, the number of lines (nlines) 
! is chosen as a multiple of lblock, so that the two matrices 
! are as large as possible
!
! Upper bond of nlines
      nlines=max_pqrs_s_mem/nfil
      if(yw)print*,'Upper bond of nlines',nlines,'  (max_pqrs_mem/nfil)'
! Max value of nlines (as a multiple of lblock)
      nlines=(nlines/lblock)*lblock
      
      if(yw)
     *print*,'Max value of nlines (as a multiple of lblock)',nlines
      if(nlines==0) then
         print*,'nlines=0, insufficient memory'
         stop
      endif
      allocate(kdx4(4,nlines,nfil))
      allocate(value3(nlines,nfil))
 
! compute pair_file: pair_file(p,q)=rank of the file containing
! the (p,q) pairs
 
      nn=0
      nfil=1
      ips=0
      allocate(pair_file(isymoa(is),isymoa(js)))
      if(yw)print*,'shape',shape(pair_file)
      if(yw)print*,'is,js,ks,ls',is,js,ks,ls
      do i=1,isymoa(is)
         if(is==js) then
            jfin=i
         else
            jfin=isymoa(js)
         endif
         do j=1,jfin
            ips=ips+1
            if(ips>mps) then
               nfil=nfil+1
               ips=1
            endif
            pair_file(i,j)=nfil
            if(yw)print'(a,2i4,3i8)','pair_file'
     *   ,i,j,pair_file(i,j),ips,mps
         enddo
      enddo
 
!
! open/create nfil files (PQRS_S_...._ifil) (ifil=1,nfil)
!
      write(cs,'(4i1)') is,js,ks,ls
      do i=1,nfil
         write(c,'(i4)') i
         c=adjustl(c)
         if(yw)print*,'splitpqrs_s open/create ','TEMPPQRS_S'//
     *   '_'//cs//'_'//trim(c)
         open(10,file=  'TEMPPQRS_S'//'_'//cs//'_'//trim(c),
     *   form='unformatted',
     *   status='replace')
         close(10)
      enddo
      if(yw)print'(a,4i4,i8,a)','symm'
     *,is,js,ks,ls,nfil,' file(s) opened'
 
!
! Allocate kdx4 and value3 tables that contain a maximum
! of (p,q) pairs
!
! read pqrs_s file (11)  (PQRS....)
! fill pair files  (10)  (PQRS_S_...._ifil) (ifil=1,nfil)
!
      allocate(ind(nfil))
      ind(:)=0
      open(11,file=filename(i_typ_int),status='old',
     *form='unformatted')
      if(yw)print*,'file opened:',filename(i_typ_int)
      ii=lblock
      ind(:)=0
      do
         ii=ii+1
         if(ii>lblock) then
            read(11) jdx4,value2
            ii=1
         endif
         p=jdx4(1,ii)
         if(p==0) exit
         p=insoa(p)
         q=insoa(jdx4(2,ii))
         do icas=1,2
! icas==1: p,q=two first indices
! icas==2: p,q=two last indices
            ifil=pair_file(p,q)
            ind(ifil)=ind(ifil)+1
            if(icas==1) then
               kdx4(:,ind(ifil),ifil)=jdx4(:,ii)
            else
               kdx4(:,ind(ifil),ifil)=jdx4((/3,4,1,2/),ii)
            endif
            value3(ind(ifil),ifil)=value2(ii)
            if(ind(ifil)==nlines) then
               write(c,'(i4)') ifil
               c=adjustl(c)
               ind(ifil)=0
               if(yw)print*,'write on ','TEMPPQRS_S'//'_'//cs//'_'//c
               long=nlines
               call wpqrs('TEMPPQRS_S'//'_'//cs//'_'//c,
     *         kdx4(:,:,ifil),value3(:,ifil),long,lblock)
            endif
            if(is/=ks) exit
            if(jdx4(1,ii)==jdx4(3,ii).and.jdx4(2,ii)==jdx4(4,ii)) exit
            p=jdx4(3,ii)
            p=insoa(p)
            q=insoa(jdx4(4,ii))
         enddo
      enddo
!
! Write last records
!
      if(yw)print*,'last record'
      do ifil=1,nfil
         ind(ifil)=ind(ifil)+1
         kdx4(:,ind(ifil),ifil)=0
         value3(ind(ifil),ifil)=0.d0
         !long=mod(nijkls(i_typ_int),max_pqrs_s_mem)
         long=ind(ifil)
         !if(long==0) long=max_pqrs_s_mem
         write(c,'(i4)') ifil
         c=adjustl(c)
         if(yw)print*,'fwrite on ','TEMPPQRS_S'//'_'//cs//'_'//c
         call wpqrs('TEMPPQRS_S'//'_'//cs//'_'//c,
     *   kdx4(:,:,ifil),value3(:,ifil),long,lblock)
      enddo
      deallocate(kdx4,value3,ind,pair_file)
      return
      end
       subroutine reorder
      use module
      use mod_tijkl
      use mod_licost
      implicit real*8 (a-h,o-x,z),logical*1(y)
      integer(2),dimension(4,lblock) :: jdx
      integer(2),allocatable,dimension(:,:) :: jdx1
      real(8),dimension(lblock) :: value
      real(8),allocatable,dimension(:) :: value1
      character(4) c
      yw=.false.
      yw=yw.or.ywtot
!
!------------------------------------------------------
! Reorder files TEMPPQRS_S_...._ifil (ifil=1,nfil)
! (the file fits in memory)
!
!            p  q  r  s
!            1  1  all values of rs
!            2  1  all values of rs
!            ...
!------------------------------------------------------
!
      allocate(jdx1(4,max_pqrs_s_mem))
      allocate(value1(max_pqrs_s_mem))
      if(yw)print*,'entree reorder'
      if(yw)print*,'nfil',nfil
      n=0
      long=0
      nadr=0
      do ifil=1,nfil
         write(c,'(i4)') ifil
         c=adjustl(c)
         if(yw)print*,'ouv','TEMPPQRS_S'//'_'//cs//'_'//c
         open(10,form='unformatted',status='old',file=
     *   'TEMPPQRS_S'//'_'//cs//'_'//c)
         do 
            read(10) jdx,value
            long=long+lblock
            do ii=1,lblock
               p=jdx(1,ii)
               q=jdx(2,ii)
               r=jdx(3,ii)
               s=jdx(4,ii)
               if(p==0) then
                  jdx1(:,n+1-nadr)=0
                  goto 1
               endif
               call adr(iadr)
!               print'(a,4i4,3i6)',
!     *         'reorder p,q,r,s,iadr,n,nadr',p,q,r,s,iadr,n,nadr
               iadr=iadr-nadr
               n=n+1
               value1(iadr)=value(ii)
               jdx1(:,iadr)=jdx(:,ii)
               if(yw)
     *         print'(a,4i4,f12.8,i8)','reor',p,q,r,s,value(ii),iadr
            enddo
         enddo
 1       continue
         close(10,status='delete')
         open(10,form='unformatted',status='new',file=
     *   'TEMPPQRS_S'//'_'//cs//'_'//c)
         call wpqrs('TEMPPQRS_S'//'_'//cs//'_'//c,
     *   jdx1(:,:),value1(:),n+1-nadr,lblock)
         nadr=n
      enddo
      if(yw)print*,'sortie reorder'
      return
      end
       subroutine adr(iadr)
      use module
      use mod_tijkl
      use mod_licost
      if(is==js) then
         iadr1=num1(insoa(p))+insoa(q)
         iadr2=num1(insoa(r))+insoa(s)
      else
         iadr1=isymoa(js)*(insoa(p)-1)+insoa(q)
         iadr2=isymoa(ls)*(insoa(r)-1)+insoa(s)
      endif
      iadr=(iadr1-1)*n_psrs+iadr2
      !print*,'iadr,iadr1,iadr2',iadr,iadr1,iadr2
      return
      end
       subroutine adr3(iadr,k,l,n_pspqs)
      use module
      use mod_tijkl
      use mod_licost
      if(ks==ls) then
!         iadr1=num1(numadr3(k))+numadr4(l)
         iadr1=num1(k)+l
      else
!         iadr1=isym4*(numadr3(k)-1)+numadr4(l)
         iadr1=isym4*(k-1)+l
      endif
      if(ks==ls) then
!         iadr2=num1(p)+numadr2(q)
         iadr2=num1(p)+q
      else
         iadr2=isymoa(js)*(p-1)+q
      endif
      iadr=(iadr1-1)*n_pspqs+iadr2
      !print*,'iadr,iadr1,iadr2',iadr,iadr1,iadr2
      return
      end
