      subroutine tra2(i_typ_int,pqkl,pqlr,pqrl)
      use module
      use mod_script
      use mod_licost
      use mod_tijkl
      implicit real*8 (a-h,o-x,z),logical*1(y)
      integer(2),dimension(4,lblock) :: jdx4
      real(8),dimension(lblock) :: value
      real(8),allocatable,dimension(:,:) :: vv,value3
C      real(8),allocatable,dimension(:,:) :: pqkl1,pqrl1,pqlr1
      integer,allocatable,dimension(:) :: jps2,jfil2
      dimension pqkl(isym4,isym3)
      dimension pqlr(isym3,isymoa(ls))
      dimension pqrl(isymoa(ls),isym3 )
      
      character(4) c
      yw=.false. ; yw=yw.or.ywtot
      
!
!-----------------------------------------------------------
! Compute pqkl
!
! The pqrs were written as follows in splitpqrs_s
! - pair subset (p,q)=(1,1) all (r,s) written, ordered
! - pair subset (p,q)=(2,1) all (r,s) written, "
! ...
! they are splitted on nfil files containing mps pair subsets
! (length: mps*n_psrs). Each file is written by blocks of length lblock
!
! Step 1: put one pair block in memory, into the square matrix vv
! Step 2: transform vv
!
! Storing pqkl
! The computed pqkl are stored in matrix value3. value3 is as large
! as possible, depending on available memory.
! Value3 is written on nfil2 files, so that, when it will be read,
! a file can fit in memory. This condition fixes gives the value of
! nfil2.
! There are mps2 pair subsets by file.
! Value3 is a rectangular matrix (N,nfil2), where N is as large
! as possible, and is a multiple of the length of a pair subset.
! When a column ifil2 is full, it is appended on file ifil2.
!-----------------------------------------------------------
!
      
      
      call cpu_time(t_transf1)
      if(yw)print*,'ENTREE TRA2'
      if(yw)print*,'nfil,mps,n_pspq,n_psrs',nfil,mps,n_pspq,n_psrs
      if(yw)print*,'n_pspq*n_psrs',n_pspq*n_psrs
      if(yw)print*,'nijkls(i_typ_int)',nijkls(i_typ_int)
      if(yw)print*,'max_pqrs_s_mem',max_pqrs_s_mem,nfil_pair(i_typ_int)
      if(yw)print*,'shape',shape(jdx4),shape(value)
      allocate(vv(isymoa(ks),isymoa(ls)))
      if(yw)
     *print*,'length of a pair subset kl for a pq block (n_pspq)',n_pspq
! total number of pair subsets
      if(yw)print*,'total number of kl pair subsets (n_pskl)',n_pskl
! maximum number of kl pair subsets that can fit in memory
      mps2=(memb/16)/n_pspq
      if(yw)
     *print*,'maximum number of pair subsets that can fit in memory',
     *'   (mps2)',mps2
      if(yw)print*,'Max_pqrs_s_mem',max_pqrs_s_mem
      !max_pqrs_s_mem=mps2*n_pspq
      !if(yw)print*,'Max_pqrs_s_mem',max_pqrs_s_mem
      
      if(mps2==0) then
         print*,'*********************************************'
         print*,'n_psij,memb',n_psij,memb
         print*,'*********************************************'
         stop 'mps2 insufficient memory'
      endif
! number of files
      nfil2=n_pskl/mps2
      if(mod(n_pskl,mps2)/=0) nfil2=nfil2+1
      if(yw)print*,'number of files',nfil2,n_pskl,mps2
      if(yw)print*,' '
! create files
      do ifil=1,nfil2
         write(c,'(i4)') ifil
         c=adjustl(c)
         if(yw)print*,'create PQKL','TEMPPQKL'//'_'//cs//'_'//c
         open(10,form='unformatted',status='replace',file=
     *   'TEMPPQKL'//'_'//cs//'_'//c)
         close(10)
      enddo
      
      allocate(jfil2(nfil2))
      allocate(jps2(nfil2))
      allocate(value3(mps2*n_pspq,nfil2))
!
!--------------------------------------------------
! Loop on pairs (p,q)
! Fill square matrix vv corresponding to pair (p,q)
! Compute pqkl
!--------------------------------------------------
!
      call cpu_time(tt0)
      ii=0
      jps2=0
      kps2=0
      ind_lec=lblock
      ifil=1
! Loop on pairs (p,q)
      if(yw)print*,'open','TEMPPQRS_S_'//cs//'_'//'1'
      open(11,file='TEMPPQRS_S_'//cs//'_'//'1',
     *form='unformatted',status='old')
      if(yw)print*,'is,js,isymoa',is,js,isymoa(is),isymoa(js)
      do p=1,isymoa(is)
         if(is==js) then
            jfin=p
         else
            jfin=isymoa(js)
         endif
         do q=1,jfin
            kps2=kps2+1
            if(yw)print*,'kps2',kps2,mps2
!
! Step 1
! Read pair subset (p,q). Put it into square matrix vv
!
            do i=1,n_psrs
               ind_lec=ind_lec+1
               if(ind_lec>lblock) then
                  ind_lec_f=ind_lec_f+lblock
                  read(11) jdx4,value
                  ind_lec=1
               endif
               if(yw)print'(a,4i4,2i6,f10.6)',
     *         'jdx4',jdx4(1:4,ind_lec),ind_lec,i,value(ind_lec)
               r=jdx4(3,ind_lec)
               if(r==0) then
                  ind_lec=lblock
                  ifil=ifil+1
                  write(c,'(i4)') ifil
                  c=adjustl(c)
                  if(yw)print*,'ouv','TEMPPQRS_S'//'_'//cs//'_'//c
                  if(ydelf) then
                     !call analf(11,'tra2 del1')
                     close(11,status='delete')
                  else
                     close(11)
                  endif
                  open(11,form='unformatted',status='old',file=
     *            'TEMPPQRS_S'//'_'//cs//'_'//c)
                  read(11) jdx4,value
                  ind_lec=1
                  r=jdx4(3,ind_lec)
               endif
               s=jdx4(4,ind_lec)
               !print*,'r,s,insoa(r),insoa(s)',r,s,insoa(r),insoa(s)
               vv(insoa(r),insoa(s))=value(ind_lec)
               if(is.eq.js) vv(insoa(s),insoa(r))=value(ind_lec)
!               if(is==2.and.js==2) then
!                  if(yw)print*,'r,s',r,s,insoa(r),
!     *            insoa(s),value(ind_lec)
!               endif
            enddo
            if(yw)print*,'pqrs for pair (p,q)=(',isymtoa(is)+p,','
     *      ,isymtoa(js)+q,')'
            if(yw)call mscript(vv)
            if(yw)print'(12f10.6)',vv
            if(yw)print*,'om3'
            if(yw)call mscript(om3(1:isymoa(ks),1:isym3))
            if(yw)print*,'om4'
            if(yw)call mscript(om4(1:isymoa(ls),1:isym4))
!
! step 2.1
! Compute pqks
!
            pqkl=0
            pqlr=0
            do s=1,isymoa(ls)
               do k=1,isym3
                  do r=1,isymoa(ks)
                     pqlr(k,s)=pqlr(k,s)+om3(r,k)*vv(r,s)
                  enddo
               enddo
            enddo
            pqrl=transpose(pqlr)
            if(yw)print*,'pqrl'
            if(yw)call mscript(pqrl)
!
! step 2.2
! Compute pqkl
!
            if(yw)print*,'isym4,isym3,shape(pqkl)',isym4,isym3,shape(pqk
     &      l)
            ips2=0
            do k=1,isym3
               if(ks==ls) then
                  lfin=k
               else
                  lfin=isym4
               endif
               do l=1,lfin
                  do s=1,isymoa(ls)
                     pqkl(l,k)=pqkl(l,k)+om4(s,l)*pqrl(s,k)
                  enddo
                  ips2=ips2+1
! (ips2 is the rank of pair (k,l))
                  ifil2=(ips2-1)/mps2+1
! ifil2 is the file corresponding to pair (k,l)
                  jps2(ifil2)=jps2(ifil2)+1
                  value3(jps2(ifil2),ifil2)=pqkl(l,k)
                  if(jps2(ifil2)==mps2*n_pspq) then
                     write(c,'(i4)') ifil2
                     c=adjustl(c)
                     jps2(ifil2)=0
                     call wpqkl('TEMPPQKL'//'_'//cs//'_'//c,
     *               value3(:,ifil2),mps2*n_pspq,lblock)
                  endif
               enddo
            enddo
!            if(yw)print*,'pqkl(1,1)',pqkl(1,1)
            if(yw)print*,'pqkl for pair (p,q)=(',isymtoa(is)+p,','
     *      ,isymtoa(js)+q,')'
            if(yw)call mscript(pqkl)
            if(yw)print'(12f10.8)',pqkl
         enddo
      enddo
      if(ydelf) then
                     !call analf(11,'tra2 del2')
         close(11,status='delete')
      else
         close(11)
      endif
      call cpu_time(tt1)
!
! Write end of files pqkl
!
      do ifil2=1,nfil2
         write(c,'(i4)') ifil2
         c=adjustl(c)
         long=jps2(ifil2)
         call wpqkl('TEMPPQKL'//'_'//cs//'_'//c,
     *   value3(:,ifil2),long,lblock)
      enddo
      deallocate(vv,value3,jps2,jfil2)
      call cpu_time(t_transf2)
      t_transf=t_transf2-t_transf1
      !print*,'t_transf',t_transf
      call cpu_time(t_reor1)
      call reorder2(pqkl,pqrl,pqlr)
      call cpu_time(t_reor2)
      !print*,'t_transf,t_reor2-t_reor1',t_transf,t_reor2-t_reor1
      t_reor=t_reor+t_reor2-t_reor1
      return
      end
       subroutine reorder2(pqkl,pqrl,pqlr)
      use module
      use mod_tijkl
      use mod_licost
      use mod_script
      implicit real*8 (a-h,o-x,z),logical*1(y)
      integer(2),dimension(4,lblock) :: jdx
      integer(2),allocatable,dimension(:,:) :: jdx1
      integer,allocatable,dimension(:,:) :: lim_ps
      real(8),dimension(lblock) :: value
      real(8),allocatable,dimension(:) :: value1
      character(4) c
      dimension pqkl(isym3,isym4)
      dimension pqlr(isym4,isymoa(ks))
      dimension pqrl(isym3,isymoa(ls))
      yw=.false. ; yw=yw.or.ywtot
      allocate(jdx1(4,max_pqrs_s_mem))
      allocate(value1(max_pqrs_s_mem))
      if(yw)print*,'entree reorder2'
      if(yw)print*,'nfil2',nfil2
      if(yw)print*,'max_pqrs_s_mem',max_pqrs_s_mem
      if(yw)print*,'n_psrs,n_pspq,mps2',n_psrs,n_pspq,mps2,n_pspq*mps2
      
!
! lim_ps:
! the pqkl are splitted on several files TEMPPQKL_...._ifil2
! ifil2=1,nfil2
! each file a block of pqkl integrals
! where the pq blocks are complete, and (k,l) varies from
! (k1,l1) to (k2,l2)
! definition: lim_ps(1,ifil2)=k2 lim_ps(2,ifil2)=l2
! and then: lim_ps(1:2,0)=(1,0)
!
      allocate (lim_ps(2,0:nfil2))
      call cal_lim_ps(lim_ps,nfil2,ks,ls,isym3,isym4,mps2)
      
      n=0
      nadr=0
!
! read TEMPPQKL_...._ifil2 one by one
!
      do ifil2=1,nfil2
         write(c,'(i4)') ifil2
         c=adjustl(c)
         if(yw)print*,'ouv','TEMPPQKL'//'_'//cs//'_'//c
         if(yw)print*,'nadr',nadr
         open(11,form='unformatted',status='old',file=
     *   'TEMPPQKL'//'_'//cs//'_'//c)
! compute nlec, number of record to be read
         nlec=mps2*n_pspq/lblock
         if(ifil2==nfil2) then
            nlec=mod(n_psrs*n_pspq,mps2*n_pspq)/lblock
            if(nlec==0) then
               nlec=mps2*n_pspq
            else
               nlec=nlec+1
            endif
         endif
         if(yw)print*,'nlec',nlec,n_psrs*n_pspq,mps2*n_pspq,
     *   mod(n_psrs*n_pspq,mps2*n_pspq)
         ifin=0
         ijkl=0
         ijkltmp=lblock
         kdeb=lim_ps(1,ifil2-1)
         kfin=lim_ps(1,ifil2)
         if(lim_ps(2,ifil2-1)==isym4) kdeb=kdeb+1
!
! Loop of full block pq
!
         do p=1,isymoa(is)
            if(is==js) then
               jfin=p
            else
               jfin=isymoa(js)
            endif
            do q=1,jfin
!
! loop on partial block kl
!
               !do k=lim_ps(1,ifil2-1),lim_ps(1,ifil2)
               do k=kdeb,kfin
!                  if(yw)print*,'k',k,kdeb,kfin
                  if(k==kdeb) then
                     ldeb=lim_ps(2,ifil2-1)+1
                     if(ldeb>isym4) ldeb=1
                  else
                     ldeb=1
                  endif
                  if(k==kfin) then
                     lfin=lim_ps(2,ifil2)
                  else
                     if(ks==ls) then
                        lfin=k
                     else
                        lfin=isym4
                     endif
                  endif
               if(yw)print'(a,10i5)','p,q,k,kdeb,kfin,ldeb,lfin'
     *         ,p,q,k,kdeb,kfin,ldeb,lfin
                  do l=ldeb,lfin
                     if(ijkltmp==lblock) then
                        read(11) value
                        ijkltmp=0
                     endif
                     ijkltmp=ijkltmp+1
                     ijkl=ijkl+1
!                     if(yw)print'(a,4i4,i8,f12.8,i8)','p,q,k,l',p,q,k,l,
!     *               ijkl,value(ijkltmp)
                     call adr3(iadr,k,l,n_pspq)
!                     call adr3(iadr,p,q,k,l,is,js,ks,ls,n_pspq)
                     iadr=iadr-nadr
                     value1(iadr)=value(ijkltmp)
                     if(yw)print'(a,4i4,i8,f12.8,i8)','p,q,k,l',p,q,k,l,
     *               ijkl,value(ijkltmp),iadr
                     n=n+1
                  enddo
               enddo
            enddo
         enddo
         if(ydelf) then
                     !call analf(11,'tra2 del3')
            close(11,status='delete')
         else
            close(11)
         endif
 1       continue
         nadr=n
         long=iadr
         call cpu_time(t_transf1)
         call trapqij(value1,long,lim_ps,ifil2,pqkl,pqrl,pqlr)
         call cpu_time(t_transf2)
         t_transf=t_transf+t_transf2-t_transf1
         t_reor=t_reor-(t_transf2-t_transf1)
      enddo
      deallocate(jdx1,value1,lim_ps)
       !if(is==2.and.js==2)stop
      return
      end
       subroutine trapqij(value1,long,lim_ps,ifil2,ijkl,iqkl,qikl)
      use module
      use mod_tijkl
      use mod_licost
      use mod_script
      implicit real*8 (a-h,o-x,z),logical*1(y)
      real(8),dimension(long) :: value1
      real(8),allocatable,dimension(:,:) :: vv
      dimension lim_ps(2,0:nfil2)
      real(8) ijkl(isym1,isym2),ijkl2
      real(8) qikl(isym1,isymoa(js))
      real(8) iqkl(isymoa(js),isym1)
      logical cond
      yw=.false. ; yw=yw.or.ywtot
      if(yw)print*,'entree trapqij'
      if(yw)print*,'long',long
      allocate(vv(isymoa(is),isymoa(js)))
!
!--------------------------------------------------
! Loop on pairs (k,l)
! Fill square matrix vv corresponding to pair (k,l)
! Compute ijkl
!--------------------------------------------------
!
!
! loops on k,l
!
      ijfin=0
      kdeb=lim_ps(1,ifil2-1)
      kfin=lim_ps(1,ifil2)
      if(lim_ps(2,ifil2-1)==isym4) kdeb=kdeb+1
      do k=kdeb,kfin
!         if(yw)print*,'k',k,kdeb,kfin
         if(k==kdeb) then
            ldeb=lim_ps(2,ifil2-1)+1
            if(ldeb>isym4) ldeb=1
         else
            ldeb=1
         endif
         if(k==kfin) then
            lfin=lim_ps(2,ifil2)
         else
            if(ks==ls) then
               lfin=k
            else
               lfin=isym4
            endif
         endif
         do l=ldeb,lfin
            ll=numom4(l)
      
!
! Fill square matrix vv corresponding to pair (k,l)
!
            ij=ijfin
            ijfin=ijfin+n_pspq
            do p=1,isymoa(is)
               if(is==js) then
                  jfin=p
               else
                  jfin=isymoa(js)
               endif
               do q=1,jfin
                  ij=ij+1
                  vv(p,q)=value1(ij)
                  if(is==js) vv(q,p)=value1(ij)
                  !print*,'p,q,ij',p,q,ij
               enddo
            enddo
            if(yw)print*,'pqkl for pair (k,l)=(',numom3(k),','
     *      ,numom4(l),')','is,js=',is,js
            if(yw)call mscript(vv)
            if(yw)print'(12f12.8)',transpose(vv)
            if(yw)print*,'ldeb,lfin',ldeb,lfin
      
! Compute iqkl
            ijkl=0
            qikl=0
! variation of i:
! if pairs (i,j) and (k,l) are equivalent ( (i,j) ~ (k,l) ),
! i varies from k to isym1 (ideb=k, otherwise, ideb=1)
! In parts 0,3-6, (i,j) and (k,l) have same activity. Then:
! (i,j) ~ (k,l)   <==>   is==ks
! In part 2, is/=ks. Then: (i,j) /~ (k,l)
! So, one may write, except for part 1:
! (i,j) ~ (k,l)   <==>   is==ks
!
! For part 1, i can be non active (ideb=1) or active (i>k)
! the i to be skipped are the i, i active, i>k
!
            ideb=i_deb(k,is==ks)
            do q=1,isymoa(js)
               do i=ideb,isym1
                  do p=1,isymoa(is)
                     qikl(i,q)=qikl(i,q)+om1(p,i)*vv(p,q)
                  enddo
               enddo
            enddo
            iqkl=transpose(qikl)
            if(yw)print*,'iqkl'
            if(yw)call mscript(iqkl)
! step 2.2
! Compute ijkl
!
! Variation of j:
! 1. jfin
! if is==js i>=j (jfin=i). Otherwise, jfin=isym2
! 2. jdeb
! if i==k, j>=l, if js==ls, jdeb=l, else (js/=ls) jdeb=1
! i==k  ==>  jdeb=l
! Then, for all parts,      i==k  ==>  jdeb=l
            kk=numom3(k)
            do i=ideb,isym1
               ii=numom1(i)
               jfin=i_fin(i,isym2,is==js)
               jdeb=i_deb(l,ii==kk)
               if(ii==kk) jdeb=l
               if(yw)print*,'i,jdeb,jfin',i,jdeb,jfin
               do j=jdeb,jfin
                  do q=1,isymoa(js)
                     ijkl(i,j)=ijkl(i,j)+om2(q,j)*iqkl(q,i)
                        !if(yw)print*,'ijkl',i,j,ijkl(i,j)
                        !,om2(q,j),iqkl(q,i)
                  enddo
               enddo
               call wijkl2(ijkl(i,:),i,k,l,jdeb,jfin)
            enddo
            if(yw)print*,'ijkl for pair (k,l)=(',numom3(k),','
     *      ,numom4(l),')','is,js=',is,js
            if(yw)call mscript(ijkl)
            if(yw)print'(12f12.8)',ijkl
            !call wijkl(ijkl,k,l,ideb)
         enddo
      enddo
      deallocate(vv)
      return
      end
       subroutine wijkl2(ijkl,i,k,l,jdeb,jfin)
      use module
      use mod_script
      use mod_licost
      use mod_tijkl
      use mod_sto
      implicit real*8 (a-h,o-x,z),logical*1(y)
      real(8) ijkl(isym2)
      character(16) cc
      yw=.false. ; yw=yw.or.ywtot
      if(yw)print*,'entree wijkl2',ycln
      ywsemia=.false.
!      if(ycln) then
      do j=jdeb,jfin
               !write(73,'(4i4,d20.12)')
!     *         numom1(i),numom2(j),
!     *         numom3(k),numom4(l),ijkl(j)
         call stoijkl(numom1(i),numom2(j),numom3(k),numom4(l)
     *   ,ijkl(j),72)
         if(yw)write(6,'(a,4i4,d20.12)') 'IJKL'
     *   ,numom1(i),numom2(j),numom3(k),numom4(l)
     *   ,ijkl(j)
      enddo
!      else
!         call stoijkl(numom1(i),numom2(j),numom3(k),numom4(l)
!     *   ,ijkl(j))
!      endif
      return
      end
       subroutine wpqkl(file,value,long,lblock)
      character(*) file
      real(8) value(long)
      logical yw
      yw=.false.
      zero=0
      if(yw)print*,'wpqkl file',file
      open(10,form='unformatted',status='old',file=file)
      do
         read(10,end=10)
      enddo
 10   continue
      nbrec=long/lblock
      if(yw)print*,'nbrec',nbrec,long,lblock
      if(mod(long,lblock)/=0) nbrec=nbrec+1
      ifin=0
      do irec=1,nbrec
         ideb=ifin+1
         ifin=ifin+lblock
         if(yw)print*,'ecriture 10',ideb,ifin
         if(ifin>long) then
            write(10) value(ideb:long),(0.d0,k=long+1,ifin)
         else
            write(10) value(ideb:ifin)
         endif
      enddo
      close(10)
      return
      end
       subroutine cal_lim_ps(lim_ps,nfil2,ks,ls,isym3,isym4,mps2)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      dimension lim_ps(2,0:nfil2)
      logical yw
      num1(i)=i*(i-1)/2
      yw=.false. ; yw=yw.or.ywtot
!
!---------------------------------------------------------------
! computes lim_ps, limits of a block of pqkl integrals that may fit
! in memory
! Block 1 (file 1) starts at k==1 and l==1, i.e. 
! lim_ps(1,0) and lim_ps(2,0)+1
! and ends at lim_ps(2,1) and lim_ps(2,1)
! Block ifil2 (file 1) starts lim_ps(1,ifil2-1) and lim_ps(2,ifil2-1)+1
! and ends at lim_ps(2,ifil2) and lim_ps(2,ifil2)
!
! Input values: symmetries ks,ls. nfil2: number of files.
!               isym3,isym4 nb of orb of ks and ls symmetries
! Output values: lim_ps 
!---------------------------------------------------------------
!
      
      l=0
      lim_ps=0
      lim_ps(1,0)=1
      lim_ps(2,0)=0
      if(yw)print*,'entree cal_lim_psnfil2',nfil2,isym3,isym4
      if(ks==ls) then
!
! (k,l) form a triangular matrix
!                                        *
!                                        * *
!                                        * * *
!                                        * * * *
!                                        * X * * *
!                                        * * * * * *
! In the example here, X have the rank 12 in the triangular matrix (I=12)
! we need to know lim_ps(1,ifil2) and lim_ps(2,ifil2) 
! (the line and column of X, k and l, which are here 5 and 2)
! The rank of the last element of the preceeding line (here 4,4) is
! R=k*(k-1)/2
! We have therefore the relation k*(k-1)/2+l=I
! which gives, by solving the 2nd grade equation:
! k=(1+sqrt[1+8*(-l+I)])/2
! For the numerical values we have here: k=(1+sqrt(1+8*(-2+12))/2=5
! Actually, l is unknown. But k must be integer
! One can show that taking l=0 gives un upper value of k, but lower than 
! k+1, except if k==l.
! The integer value gives therefore the correct value of k, the k==l case
! beeing treated as special.
! k=(1+sqrt[1+8*(I)])/2, k integer
! l is then easily obtained
! l=I_k*(k-1)/2
!
         do ifil2=1,nfil2-1
            l=l+mps2
            if(yw)print*,'l',l
            a=(1.d0+dsqrt(8.d0*l+1.d0))/2
            if(yw)print*,'a',a
            lim_ps(1,ifil2)=a
            lim_ps(2,ifil2)=l-num1(lim_ps(1,ifil2))
            if(yw)print*,'1lim_ps',ifil2,lim_ps(:,ifil2)
            if(lim_ps(2,ifil2)==0) then
               lim_ps(1,ifil2)=lim_ps(1,ifil2)-1
               lim_ps(2,ifil2)=lim_ps(1,ifil2)
            endif
            if(yw)print*,'lim_ps',ifil2,lim_ps(:,ifil2)
         enddo
         lim_ps(1,nfil2)=isym3
         lim_ps(2,nfil2)=isym3
      else
!
! (k,l) form a rectangular (isym3,isym4) matrix
! lim_ps(1,ifil2)=k, lim_ps(2,ifil2)=l
!                                                * * * * * * * *
!                                                * * * * * * * *
!                                                * * * * * * * *
!                                                * * X * * * * *
!                                                * * * * * * * *
! here: k=4,l=3, I=14, isym3=5, isym4=8, I=14
! ia=I/isym3=14/5=2. lim_ps(2,ifil2)=ia+1=3 (=l)
! lim_ps(1,ifil2)=I-ia*isym3=14-2*5=4 (=k)
! once again, the case k==isym3 must be treated appart
! 
         do ifil2=1,nfil2-1
            l=l+mps2
            ia=l/isym4
            if(yw)print*,'ia,l,isym4',ia,l,isym4
            lim_ps(1,ifil2)=ia+1
            lim_ps(2,ifil2)=l-ia*isym4
            if(lim_ps(2,ifil2)==0) then
               lim_ps(1,ifil2)=ia
               lim_ps(2,ifil2)=isym4
            endif
            if(yw)print*,'lim_ps',ifil2,lim_ps(:,ifil2)
         enddo
         lim_ps(1,nfil2)=isym3
         lim_ps(2,nfil2)=isym4
      endif
      if(yw) then
         print'(a,10i4)','isym3,isym4,ks,ls',isym3,isym4,ks,ls
         do kk=0,nfil2
            print*,'LIM_PS',kk,lim_ps(:,kk)
         enddo
      endif
      return
      end
       function i_deb(k,test)
      logical test
      if(test) then
         i_deb=k
      else
         i_deb=1
      endif
      return
      end
       function i_fin(k,ival,test)
      logical test
      if(test) then
         i_fin=k
      else
         i_fin=ival
      endif
      return
      end
