      subroutine listes
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Liaisons entre orbitales pour la liste des determinants
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!--------------------------
! Liaisons avec les actives
!--------------------------
! nlc nombre d'OL liees au CAS
! nlco nombre d'OL occupees liees au CAS
! nlcv nombre d'OL virtuelles liees au CAS
! ilc(1:nlc) = orbitales liees au CAS
! ilc1(1:norb) = numero de l'orb dans la liste des occ liees, puis
! dans la liste des virt liees
!
!----------------------------------------------------------
! Liaisons avec occ et virt, avant ajout des paires formees
! des orbitales liees au CAS
!----------------------------------------------------------
! nlpairp = nombre de paires o/v
! ilp(noc,nvirt) = numero de la liaison entre occ et virt
! il(noc,nvirt) = numero de la liaison entre occ et virt

!----------------------------------------------------------
! Liaisons avec occ et virt, apres ajout des paires formees
! des orbitales liees au CAS
!----------------------------------------------------------
! nlpair = nombre de paires o/v
! ilp(noc,nvirt) = numero de la liaison entre occ et virt
! il(noc,nvirt) = numero de la liaison entre occ et virt
! ilpair(1,1:nlpair) = numero de l'occ d'une paire
! ilpair(2,1:nlpair) = numero de la virt d'une paire
!(ilp, il et ilpair sont ici la suite des listes du paragraphe precedent
!cad  avant ajout des paires formees des orbitales liees au CAS)


!----------------------------------------------------------
! Liaisons entre occ 
!----------------------------------------------------------
! nlpairoo =  nombre de paires o/o
! iloo(noc,noc) = numero de la liaison entre occ

!----------------------------------------------------------
! Liaisons entre virt
!----------------------------------------------------------
! nlpairvv =  nombre de paires v/v
! ilpp(nvirt,nvirt) = numero de la liaison entre virt
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Liaisons entre orbitales pour la liste des integrales
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! sli est le seuil pour tout type de liaison (o/o o/v v/v)
! y
      use module
      use mod_lirint
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      allocatable ilpair1(:,:),ilctmp(:),nbv(:),nbvp(:)
      character(100000) namel
      allocatable izone(:),isl(:)
C      character(18),allocatable,dimension(:) :: tipo
      character(300) aa
      dimension ibid(8)
      integer a,b
      logical ytest
      yw=.false.
      call titre(' Topologie #Lien='//trim(liens)//'#',40)
      !
      ! La variable liens dit comment on definit les orbitales liees
      !
      allocate(ilpair1(2,noc*nvirt))
      allocate(iloo(noc,noc))
      allocate(ilpp(noc+1:norb,noc+1:norb))
      allocate(il(noc,noc+1:norb))
      il=0
      allocate(ilp(noc,noc+1:norb))
      if(igener>0) then
         allocate(ilc(ninac+nvirt),ilc1(norb))
         ilc=0
         ilc1=0
      endif
      allocate(izone(norb))
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-------------------------------------------------------
! liaisons lues sur un fichier TOPO
!-------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      if(liens=='FILE') then
         open(1,file=topo1,form='unformatted',status='old')
C         call LECNAM('&TOPO',namel,1,ierr,1)
C         if(ierr==1) then
C            print*,'pas de namelist TOPO'
C            stop
C         endif
         allocate(ilctmp(ninac+nvirt))
         ilctmp=0
         ilpair1=0
         nlc=norb
         read(1)
         read(1) ilctmp
         read(1) nlpairp,ilpair1(:,1:nlpairp)
         do k=1,norb
            if(ilctmp(k)==0) then
               nlc=k-1
               exit
            endif
         enddo
         ! nlc=nb de liaisons avec le CAS
         call reor(nlc,ilctmp,idum)
         do k=1,noc*nvirt
            if(ilpair1(1,k)==0) then
               nlpairp=k-1
               exit
            else
               if(ilpair1(1,k)>noc.or.ilpair1(2,k)<=noc) then
                  print*,'erreur dans la paire',ilpair1(:,k)
                  stop
               endif
            endif
         enddo
         !
         ! Verif : les indices de ilc et ilpair ne doivent pas etre des
         ! orb actives
         !
         do k=1,nlc
            if(yac(ilctmp(k))) then
               print'(a,i3,a,i3,a)',
     *         'ilc(k) for k=',k,'   (=',ilctmp(k),') is active'
               stop
            endif
         enddo
         do k=1,nlpairp
            if(yac(ilpair1(1,k)).or.yac(ilpair1(2,k))) then
               print'(a,i3,a,2i3,a)',
     *         'ilpair(k) for k=',k,'   (=',ilpair1(:,k),') is active'
               stop
            endif
         enddo
         ilc(1:nlc)=ilctmp(1:nlc)
         ! On calcule nlco et nlcv
         nlco=0
         do k=1,nlc
            if(ilc(k)<=noc) nlco=nlco+1
         enddo
         nlcv=nlc-nlco
         ! nlco=nb de liaisons avec le CAS jusqu'au du niveau de Fermi
         ! nlcv=nb de liaisons avec le CAS au-dessus du niveau de Fermi
         deallocate(ilctmp)
         read(1) iloo
         read(1) ilpp
         allocate (yl(norb,norb))
         read(1) yl
         close(1)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-------------------------------------------------------
! Calcul LOCCI, all_linked
!-------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      else if(ylocci.and.all_linked) then
         allocate(loinfo(norb))
         open(99,file=trim(prefix)//'LOinfo',status='old')
         read(99,'(a)') aa
         do k=1,norb
            read(99,'(a)') aa
            read(aa(5:8),'(i4)') i_ijkloc
            loinfo(i_ijkloc)=aa
         enddo
         close(99)
         call calzones(izone,nbzones)
         print*,' '
         print*,'Calcul LOCCI, all_linked'
         print*,'slid'
         do jz=0,nbzones-1
            print'(a,i3,3x,3d18.8)','zone',jz,slid(jz)
         enddo
         sl=slid
         sl2=slid
         sli=slid
         print*,' '
!-------------------------------------
         ! liaison orbitale/CAS (determinants)
         ! Paire occ/virt (determinants)
!-------------------------------------
         nlc=0
         nlco=0
         nlcv=0
         nlpairp=0
! appel lienkij pour la zone 0.
! en entree, sl. En sortie mat de liens ilc1 et ilpair1
         call lienkij(0,sl,ilpair1,izone,nbzones)
         if(zone(0)/=' ') then
            print*,' '
            print*,'Differentes zones de seuils :'
            print'(/,a)','nlco : liens occ/CAS,     '//
     *      'nlcv : liens virt/CAS'
            print'(a,2i6,a,i10)',
     *      'zone  0  nlco,nlcv =',nlco,nlcv,
     *      '         nlpairp ',nlpairp
            nlco_old=nlco
            nlcv_old=nlcv
            nlpairp_old=nlpairp
            do jz=1,nbzones-1
! appel lienkij. en entree, sl(1:nbzones), zones.
! En sortie mat de liens ilc1 et ilpair1
               call lienkij(jz,sl,ilpair1,izone,nbzones)
               print'(a,i3,a,2i6,a,i10)',
     *         'zone',jz,'  nlco,nlcv =',nlco-nlco_old,nlcv-nlcv_old,
     *         '         nlpairp ',nlpairp-nlpairp_old
               nlco_old=nlco
               nlcv_old=nlcv
               nlpairp_old=nlpairp
            enddo
         endif
         ilc(nlco+1:nlco+nlcv)=ilc(ninac+1:ninac+nlcv)
         ilc(nlco+nlcv+1:ninac+nvirt)=0
         ilc1=0
!         do k=1,nlc
!            print*,'ilc',k,ilc(k)
!         enddo
         do k=1,nlco
            ilc1(ilc(k))=k
         enddo
         do k=1,nlcv
            ilc1(ilc(k+nlco))=k
         enddo
         call reor(nlco+nlcv,ilc,isgn)
!         do k=1,norb
!            print*,'ilc1',k,ilc1(k)
!         enddo
!-------------------------------------
         ! Paire occ/occ   virt/virt
!-------------------------------------
         nlpairoo=0
         iloo=0
         ilpp=0
         do jz=0,nbzones-1
            do io=1,ninac
               io1=numin(io)
               do jo=1,io-1
                  jo1=numin(jo)
                  if(iloo(io1,jo1)/=0) cycle
                  call cal_ytest(ytest,io1,jo1,izone,jz,sl2,sl_loc_1)
                  if(ytest) then
                     nlpairoo=nlpairoo+1
                     iloo(io1,jo1)=nlpairoo
                     iloo(jo1,io1)=nlpairoo
                     if(yw)print*,'iloo',io1,jo1,nlpairoo,jz
                  endif
               enddo
            enddo
            nlpairvv=0
            do iv=1,nvirt
               iv1=numvir(iv)
               do jv=1,iv-1
                  jv1=numvir(jv)
                  if(ilpp(iv1,jv1)/=0) cycle
                  call cal_ytest(ytest,iv1,jv1,izone,jz,sl2,sl_loc_1)
                  if(ytest) then
                     nlpairvv=nlpairvv+1
                     ilpp(iv1,jv1)=nlpairvv
                     ilpp(jv1,iv1)=nlpairvv
                     if(yw)print*,'ilpp',iv1,jv1,nlpairvv,jz
                  endif
               enddo
            enddo
         enddo
         deallocate(loinfo)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-------------------------------------------------------
! liaisons definies par les integrales d'echange
!-------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      else if(liens=='KIJ') then
         allocate(loinfo(norb))
         open(99,file=trim(prefix)//'LOinfo',status='old')
         read(99,'(a)') aa
         do k=1,norb
            read(99,'(a)') aa
            read(aa(5:8),'(i4)') i_ijkloc
            loinfo(i_ijkloc)=aa
         enddo
         close(99)
         call calzones(izone,nbzones)
         print*,' '
         print*,'liaisons definies par les integrales d''echange'
         if(itest(29)==0) then
            print*,'itest(29)==0: seuil(O1,O2)=min(seuil(O1),seuil(O2))'
         else if(itest(29)==1) then
            print*,'itest(29)==1: seuil(O1,O2)=max(seuil(O1),seuil(O2))'
         else if(itest(29)==2) then
            print*,'itest(29)==2: seuil(O1,O2)=moy(seuil(O1),seuil(O2))'
         endif
         print*,' '
         print*,
     *   '(liens=''KIJ'', sl                sl2               sli'
         do jz=0,nbzones-1
            print'(a,i3,3x,3d18.8)',' zone',jz,sl(jz),sl2(jz),sli(jz)
         enddo
C         if(itest(27)==0) then
C            print*,'***********************************************'
C            print*,'ATTENTION   ATTENTION   ATTENTION   ATTENTION   '
C            print*,'Modif du programme concernant sli :'
C            print*,'les orbitales actives sont maintenant considerees'//
C     *      ' comme toutes liees'
C            print*,'Pour revenir a la version precedente,'//
C     *      ' donner itest(27)=1'
C            print*,'***********************************************'
C         endif
         !call script(ajk,norb,norb,norb,norb)
         print*,' '
!-------------------------------------
         ! liaison orbitale/CAS
         ! Paire occ/virt
!-------------------------------------
         nlc=0
         nlco=0
         nlcv=0
         nlpairp=0
! appel lienkij pour la zone 0.
! en entree, sl. En sortie mat de liens ilc1 et ilpair1
         call lienkij(0,sl,ilpair1,izone,nbzones)
         if(zone(0)/=' ') then
            print*,' '
            call titre('Differentes zones de seuils :#',300)
            print'(/,a)',' nlco : liens occ/CAS,     '//
     *      'nlcv : liens virt/CAS'
            print'(a,/,a)',' nlpairp for zone z: occ/virt pair, '
     *      ,' one orb in zone z, one orb in a higher zone z1 (z1>z)'
            print'(a,2i6,a,i10)',
     *      ' zone  0  nlco,nlcv =',nlco,nlcv,
     *      '         nlpairp ',nlpairp
            nlco_old=nlco
            nlcv_old=nlcv
            nlpairp_old=nlpairp
            do jz=1,nbzones-1
! appel lienkij. en entree, sl(1:nbzones), zones.
! En sortie mat de liens ilc1 et ilpair1
               call lienkij(jz,sl,ilpair1,izone,nbzones)
               print'(a,i3,a,2i6,a,i10)',
     *         'zone',jz,'  nlco,nlcv =',nlco-nlco_old,nlcv-nlcv_old,
     *         '         nlpairp ',nlpairp-nlpairp_old
               nlco_old=nlco
               nlcv_old=nlcv
               nlpairp_old=nlpairp
            enddo
         endif
         ilc(nlco+1:nlco+nlcv)=ilc(ninac+1:ninac+nlcv)
         ilc(nlco+nlcv+1:ninac+nvirt)=0
         ilc1=0
!         do k=1,nlc
!            print*,'ilc',k,ilc(k)
!         enddo
         do k=1,nlco
            ilc1(ilc(k))=k
         enddo
         do k=1,nlcv
            ilc1(ilc(k+nlco))=k
         enddo
         call reor(nlco+nlcv,ilc,isgn)
!         do k=1,norb
!            print*,'ilc1',k,ilc1(k)
!         enddo
!-------------------------------------
         ! Paire occ/occ   virt/virt
!-------------------------------------
         nlpairoo=0
         iloo=0
         ilpp=0
         do jz=0,nbzones-1
            do io=1,ninac
               io1=numin(io)
               do jo=1,io-1
                  jo1=numin(jo)
                  if(iloo(io1,jo1)/=0) cycle
                  call cal_ytest(ytest,io1,jo1,izone,jz,sl2,sl_loc_1)
!                 if(itest(29)==0) then
!                    ytest=min(izone(io1),izone(jo1))==jz
!                    ytest=ytest.and.
!    *               abs(ajk(min(io1,jo1),max(io1,jo1)))>=sl2(jz)
!                 else
!                    stop'valeur non prevue pour itest(29)'
!                 endif
                  if(ytest) then
                     nlpairoo=nlpairoo+1
                     iloo(io1,jo1)=nlpairoo
                     iloo(jo1,io1)=nlpairoo
                     if(yw)print*,'iloo',io1,jo1,nlpairoo,jz
                  endif
               enddo
            enddo
            nlpairvv=0
            do iv=1,nvirt
               iv1=numvir(iv)
               do jv=1,iv-1
                  jv1=numvir(jv)
                  if(ilpp(iv1,jv1)/=0) cycle
                  call cal_ytest(ytest,iv1,jv1,izone,jz,sl2,sl_loc_1)
!                 if(itest(29)==0) then
!                    ytest=min(izone(iv1),izone(jv1))==jz
!                    ytest=ytest.and.
!    *               abs(ajk(min(iv1,jv1),max(iv1,jv1)))>=sl2(jz)
!                 else
!                    stop'valeur non prevue pour itest(29)'
!                 endif
                  if(ytest) then
                     nlpairvv=nlpairvv+1
                     ilpp(iv1,jv1)=nlpairvv
                     ilpp(jv1,iv1)=nlpairvv
                     if(yw)print*,'ilpp',iv1,jv1,nlpairvv,jz
                  endif
               enddo
            enddo
         enddo
         deallocate(loinfo)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-------------------------------------------------------
! Toutes orbitales liees
!-------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      else if(liens=='ALL') then
         nlc=ninac+nvirt
         nlco=ninac
         nlcv=nvirt
         ilc(1:ninac)=(/(numin(k),k=1,ninac)/)
         ilc(ninac+1:ninac+nvirt)=(/(numvir(k),k=1,nvirt)/)
         nlpairp=0
         do io=1,ninac
            do iv=1,nvirt
               nlpairp=nlpairp+1
               ilpair1(1,nlpairp)=numin(io)
               ilpair1(2,nlpairp)=numvir(iv)
            enddo
         enddo
         ycaspair=.true.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-------------------------------------------------------
! liaisons definies par un critere de distance  
!-------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      else if(liens(1:4)=='DIST') then
         call liens_dist(ilpair1)
      else if(liens(1:4)=='ATOM') then
! non implemente
         call atomliens(ilpair1)
      else if(liens(1:4)=='CAS0') then
         print*,'Il n''y a pas de liens car gener==CAS'
      else
         print*,'liens a une valeur invalide  ',liens
         stop
      endif
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-------------------------------------------------------
! Fin des differentes possibilites de definir les liaisons
!-------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      print*, ' '
      print*,'liens avec actives (occ et virt)',nlc
      if(nlc>0)print'(20i4)',ilc(1:nlc)
      nclo_old=nlco
      if(igener>0) then
!
!--------------------------------------------------------
! On definit ilc1, matrice des liaisons avec les actives
!--------------------------------------------------------
!
         ilc1=0
         do k=1,nlco
            ilc1(ilc(k))=k
         enddo
         do k=1,nlcv
            ilc1(ilc(k+nlco))=k
         enddo
!
! ex:
!		orb	nlc
!		1	0
!		2	0
!		3	1  (3 est la 1ere orb liee au CAS)
!		4	0
!		11	2  (11 est la 2eme orb liee au CAS)
!		12	0
!		13	3
!		14	4
!		15	5
!		16	0

!          ilc(2)=11      ilc1(11)=2
!
!
!--------------------------------------------------------
! On definit il et ilp, matrices des liaisons T/P
!--------------------------------------------------------
!
         il=0
         do k=1,nlpairp
            il(ilpair1(1,k),ilpair1(2,k))=k
         enddo
         ilp=il
!  ex
! 		T	P	nlp
!		1	11      0
!		1	12      0
!		1	13      1
!		1	14      0
!		2	11      2
!		2	12      0
!		2	13      3
!		2	14      4
!		3	11      5
!		3	12      0
!		3	13	6
!		3	14	0
!      ilpairp(1,5)=3   le Trou de la 5eme paire est l'orb 3
!      ilpairp(2,5)=11  la Part de la 5eme paire est l'orb 11    
!      il(3,11)=5       les t,p 3,11 forment la 5eme paire

!
!----------------------------------------------------
! On rajoute les paires ou T et P sont liees au CAS
!----------------------------------------------------
!
         nlpairv=nlpairp
         nlpair=nlpairp
         do k=1,nlco
            do l=nlco+1,nlc
               if(il(ilc(k),ilc(l)).ne.0) cycle
               nlpair=nlpair+1
            enddo
         enddo
         allocate(ilpair(2,nlpair))
         ilpair(:,1:nlpairv)=ilpair1(:,1:nlpairv)
         if(allocated(ilpair1)) deallocate(ilpair1)
         nlpair=nlpairv
         do k=1,nlco
            do l=nlco+1,nlc
               if(il(ilc(k),ilc(l)).ne.0) cycle
               nlpair=nlpair+1
               ilpair(:,nlpair)=(/ilc(k),ilc(l)/)
               il(ilc(k),ilc(l))=nlpair
            enddo
         enddo
! 
! Si ycaspair==T, on prend toujours les paires liees au CAS
!
         if(ycaspair) then
            nlpairp=nlpair
            ilp=il
         endif
         print*, ' '
         print*,
     *   'paires occ/virt avec l''addition des paires liees au CAS',
     *   nlpair
         print*,
     *   'paires occ/virt sans l''addition des paires liees au CAS',
     *   nlpairp
         if(nlpair<50) then
            print*,'paires'
            print'(5(2i4,3x))',ilpair(:,1:nlpairp)
            print*,'... + paires liees au CAS'
            if(nlpairp<nlpair)
     *      print'(5(2i4,3x))',ilpair(:,nlpairp+1:nlpair)
         endif
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!--------------------------------------------------------
! cal_yl : liaisons entre orbitales pour les integrales
!--------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      if(liens=='KIJ'.and.gener/='CAS'.and.gener/='SEL') 
     *call cal_yl(izone,nbzones)
      !call mscript(yl)
!
! Ecriture d'un fichier TOPO (Matrice des liaisons)
!
         if(liens/='FILE') then
            open(1,file=topo1,form='unformatted',status='unknown')
            write(1)ninac,noac,nvirt,noc,norb
            write(1) ilc
            write(1) nlpairp,ilpair(:,1:nlpairp)
            write(1) iloo
            write(1) ilpp
            write(1) yl
            close(1)
         endif
      endif
      if(stop=='TOPO') call titre('stop=TOPO#',30)
      if(stop=='TOPO') stop
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!--------------------------------------------------------
! Dimensions maximales lors de l'ajout de TP
!--------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
 1000 format(a,20(20i6,/))
 2000 format(a,/,20(10i4,2x,10i4,/))
 2001 format(20(10i4,2x,10i4,/))
 2002 format(20(10i8,/))
      maxdim=0
      if(igener>0) then
         !nombre de voisins pour chaque orbitale
         print*,' '
         print*,'nombre de voisins pour chaque orbitale'
         allocate(nbv(norb))
         nbv=0
         do k=1,nlpair
            nbv(ilpair(1,k))=nbv(ilpair(1,k))+1
            nbv(ilpair(2,k))=nbv(ilpair(2,k))+1
         enddo
         allocate(nbvp(norb))
         nbvp=0
         do k=1,nlpairp
            nbvp(ilpair(1,k))=nbvp(ilpair(1,k))+1
            nbvp(ilpair(2,k))=nbvp(ilpair(2,k))+1
         enddo
         print 2000,'grande liste (avec paires liees au CAS)',nbv
         print 2000,'petite liste (sans paires liees au CAS)',nbvp
         print*,'nombre de paires occ/virt ', sum(nbvp(1:ninac))
         !
         ! Allocations des vecteurs contenant les adresses TP
         if(w2)print*,
     *   'Allocations des vecteurs contenant les adresses TP'
         !
         if(yw)print*,'passage listes igener,gener',igener,gener
         nbvo=maxval(nbv(1:noc))
         nbvv=maxval(nbv(noc+1:norb))
         nbvpo=maxval(nbvp(1:noc))
         nbvpv=maxval(nbvp(noc+1:norb))
         if(w2)print 1000,'nbvo,nbvv,nbvpo,nbvpv',nbvo,nbvv,nbvpo,nbvpv
         ! on ajoute 1 trou lie au CAS
         maxdim=max(maxdim,nlco)
         if(w2)print 1000,'maxdim',maxdim,nlco
         ! on ajoute 1 part liee au CAS
         maxdim=max(maxdim,nlcv)
         if(w2)print 1000,'maxdim',maxdim,nlcv
         ! on ajoute une paire
         maxdim=max(maxdim,nlpair)
         ! on ajoute 1 trou lie a 1 part ou
         ! on ajoute 1 part liee a 1 trou
         maxdim=max(maxdim,maxval(nbv))
         if(w2)print 1000,'maxdim1',maxdim,maxval(nbv)
         if(igener>1) then
            if(w2)print 1000,'maxdim2',maxdim,nlpair
            ! on ajoute deux trous lies au CAS
            maxdim=max(maxdim,num1(nlco+1))
            if(w2)print 1000,'maxdim3',maxdim,nlco
            ! on ajoute deux part liees au CAS
            maxdim=max(maxdim,num1(nlcv+1))
            if(w2)print 1000,'maxdim4',maxdim,nlcv
            if(igener>2) then
               ! on ajoute 1 trou lie au CAS et 1 trou lie a 1 part
               maxdim=max(maxdim,nlco*nbvpo)
               if(w2)print 1000,'maxdim5',maxdim,nlco,nbvpo
               ! on ajoute 1 part liee au CAS et 1 part liee a 1 trou
               maxdim=max(maxdim,nlcv*nbvpv)
               if(w2)print 1000,'maxdim6',maxdim,nlcv,nbvpv
               ! on ajoute 1 trou lie au CAS et 1 paire
               maxdim=max(maxdim,nlco*nlpairp)
               if(w2)print 1000,'maxdim7',maxdim,nlco*nlpairp
               ! on ajoute 1 part liee au CAS et 1 paire
               maxdim=max(maxdim,nlcv*nlpairp)
               if(w2)print 1000,'maxdim8',maxdim,nlcv*nlpairp
               if(igener==4) then
                  ! on ajoute 1 trou lie a 1 part et 1 paire
                  maxdim=max(maxdim,nbvpo*nlpairp)
                  if(w2)print 1000,'maxdim9',maxdim,nbvpo*nlpairp
                  ! on ajoute 1 part liee a 1 trou et 1 paire
                  maxdim=max(maxdim,nbvpv*nlpairp)
                  if(w2)print 1000,'maxdim10',maxdim,nbvpv*nlpairp
               endif
            endif
         endif
         allocate(itp1(maxdim))
         allocate(itp2(maxdim))
         allocate(itp3(maxdim))
         allocate(itp4(maxdim))
         allocate(ltp1(maxdim))
         deallocate(nbv,nbvp)
      endif
      

!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!--------------------------------------------------------
! Calculs de paires (active/paire TP) et des paires de paires TP
!--------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      if(igener>=3) call lispc
      if(igener==4) call lispp
!
!-------------------------------------------------------------
! lis_cond : calculs de quelques tableaux pour accelerer
! les boucles internes 
!-------------------------------------------------------------
!
      call lis_cond
!
!-------------------------------------------------------------
! corr_ord : calculs de quelques tableaux pour calculer
! les adresses
!-------------------------------------------------------------
!
      call corr_ord
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!--------------------------------------------------------
! Fin de la subroutine : eventuellement, details en sortie
!--------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      allocate(isl(norb))
      if(liens=='KIJ'.and.gener/='CAS'.and.gener/='SEL') then
         call titre('Nombre de voisins des orbitales'//
     *   ' pour les differents seuils#',60)
         do k=1,ninac
            n=0
            do l=1,ninac
               if(yl(k,l)) n=n+1
               !if(yl(k,l)) print*,'yloo',k,l
            enddo
            isl(k)=n
         enddo
         print*,' '
         print*,'INTEGRALES : Liaisons entre occupees'
         print 2001,isl(1:ninac) 
         print*,' '
         do k=1+ninac+noac,norb
            n=0
            do l=1+ninac+noac,norb
               if(yl(k,l)) n=n+1
            enddo
            isl(k)=n
         enddo
         print*,'INTEGRALES : Liaisons entre virtuelles'
         print 2001,isl(1+ninac+noac:norb) 
         print*,' '
         do k=1,ninac
            n=0
            do l=1+ninac+noac,norb
               if(yl(k,l)) n=n+1
            enddo
            isl(k)=n
         enddo
         print*,'INTEGRALES : Liaisons entre occupees et virtuelles'
         print 2001,isl(1:ninac) 
         print*,' '
         do k=1,ninac
            n=0
            do l=1,ninac
               if(iloo(k,l)>0) n=n+1
            enddo
            isl(k)=n
         enddo
         print*,'DETERMINANTS : Liaisons entre occupees'
         print 2001,isl(1:ninac) 
         print*,' '
         do k=1+ninac+noac,norb
            n=0
            do l=1+ninac+noac,norb
               if(ilpp(k,l)>0) n=n+1
            enddo
            isl(k)=n
         enddo
         print*,'DETERMINANTS : Liaisons entre virtuelles'
         print 2001,isl(1+ninac+noac:norb)
      endif
      if(itest(28)==1) then
         if(igener==4) then
            print*,' '
            print*,'Analyse des paires de paires'
            isl=0
            ipp1=0
            do ip1=1,nlpairp
               i=ilpair(1,ip1)
               a=ilpair(2,ip1)
               do ip2=1,ip1
                  j=ilpair(1,ip2)
                  b=ilpair(2,ip2)
                  ipp1=ipp1+1
                  if(ipp(ipp1)==0) cycle
                  if(i/=j.and.a/=b) then
                     isl(i)=isl(i)+1
                     isl(j)=isl(j)+1
                     isl(a)=isl(a)+1
                     isl(b)=isl(b)+1
                  endif
               enddo
            enddo
         endif
         print*,'izone'
         print 2001, izone
         !print*,'nombre de paires de paires',npp
         print*,'presence d''une orb dans une int bielectronique'
         print 2002,isl(1:ninac)
         print*,' '
         print 2002,isl(1+ninac+noac:norb)
      endif
      deallocate(isl)
      deallocate(izone)
      if(itest(28)==1) then
! Detail de la liaison des orbitales
         call titre('Detail de la liaison des orbitales#',40)
         allocate(loinfo(norb))
         call open_chose_number(ifil_loinfo,trim(prefix)//'LOinfo',
     *   'old','formatted')
         read(ifil_loinfo,'(a)')
         do i=1,norb
            read(ifil_loinfo,'(a300)') aa
            read(aa(5:8),'(i4)') i_ijkloc
            loinfo(i_ijkloc)=aa
         enddo
         print*,'liaisons pour les determinants (OCC/VIRT)'
         print*,' '
         do i=1,ninac
            print'(2a,i5,a)','liaisons de l''orbitale occupee ',
     *      trim(loinfo(i)(10:28)),i,'  avec les virtuelles'
            do j=ninac+noac+1,norb
               if(ilp(i,j)>0) 
     *         print'(a,i5,3x,a)',loinfo(j)(10:28),j,loinfo(j)(29:31)
            enddo
            print'(2a,i5,a)','liaisons de l''orbitale occupee ',
     *      trim(loinfo(i)(10:28)),i,'  avec les occupees'
            do j=1,ninac
               if(iloo(i,j)>0) 
     *         print'(a,i5,3x,a)',loinfo(j)(10:28),j,loinfo(j)(29:31)
            enddo
         enddo
         print*,' '
         print*,'liaisons pour les determinants (VIRT/OCC)'
         print*,' '
         do i=ninac+noac+1,norb
            print'(2a,i5,a)','liaisons de l''orbitale virtuelle ',
     *      trim(loinfo(i)(10:28)),i,'  avec les occupees'
            do j=1,ninac
               if(ilp(j,i)>0) 
     *         print'(a,i5,3x,a)',loinfo(j)(10:28),j,loinfo(j)(29:31)
            enddo
         enddo
         print*,' '
         print*,'liaisons pour les determinants (OCC/OCC)'
         print*,' '
         do i=1,ninac
         enddo
         print*,' '
         print*,'liaisons pour les determinants (VIRT/VIRT)'
         print*,' '
         do i=ninac+noac+1,norb
            print'(2a,i5,a)','liaisons de l''orbitale virtuelle ',
     *      trim(loinfo(i)(10:28)),i,'  avec les virtuelles'
            do j=ninac+noac+1,norb
               if(ilpp(i,j)>0) 
     *         print'(a,i5,3x,a)',loinfo(j)(10:28),j,loinfo(j)(29:31)
            enddo
         enddo
         print*,' '
         print*,'liaisons pour les integrales'
         print*,' '
         do i=1,norb
            print'(2a,i5,2x,a)','INTEGRALES : liaisons de l''orbitale ',
     *      trim(loinfo(i)(10:28)),i,loinfo(i)(29:31)
            do j=1,norb
               if(yl(i,j))print'(a,i5,2x,a)',
     *         trim(loinfo(j)(10:28)),j,loinfo(j)(29:31)
            enddo
         enddo
         deallocate(loinfo)
      endif
      if (stop=='SL') stop
      return
      end
       subroutine lispc
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Paires de (paire, orb liee au CAS)
      !
      ! ipc(paire,orb liee au CAS) = numero de la paire a 3 indices 
      ! (paire,orb liee au CAS)
      ! npc = nombre de paires a 3 indices
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      if(.not.allocated(ipc)) allocate(ipc(nlpairp,nlc))
      yw=.false.
      ipc=0
      npc=0
      npctot=0
      ! Paires a 3 indices differents
      if(itest(28)==1)print*,'Paires a 3 indices differents'
! Paire(1 occ liee au CAS/(1 paire d'occ/virt))
      do k=1,nlco
         do l=1,nlpairp
            if(ilc(k).ne.ilpair(1,l)) then
               ! tous les indices sont differents
               call lispc2(k,l,yld)
               if(.not.yld) cycle
               ill1=ilc1(ilpair(1,l))
               ill2=ilp(ilc(k),ilpair(2,l))
               if(ill1.ne.0.and.ill2.ne.0) then
                  ! l'autre paire (obtenue par permutation des
                  ! indice) est aussi liee, et l'autre occupee est liee
                  ! au CAS
                  if(ipc(ill2,ill1).ne.0) then
                     ! l'autre ipc a ete aussi deja vue
                     ipc(l,k)=-ipc(ill2,ill1)
                  else
                     npc=npc+1
                     ipc(l,k)=npc
                  endif
               else
                  npc=npc+1
                  ipc(l,k)=npc
               endif
            endif
!            if(yw)print'(a6,2i4,2x,i4,2X,2i4,i8)',
!     *      'pcaaat',k,l,ilc(k),ilpair(:,l),ipc(l,k)
             if(itest(28)==1)print'(a,2i4,2x,i4,2X,2i4,i8)',
     *    'o k,l,ilc(k),ilpair(:,l),ipc',k,l,ilc(k),ilpair(:,l),ipc(l,k)
         enddo
      enddo
      npcoov=npc
      print*,'npcoov',npcoov
      npctot=npctot+npc
      npc=0
! Paire(1 virt liee au CAS/(1 paire d'occ/virt))
      do k=nlco+1,nlc
         do l=1,nlpairp
            if(ilc(k).ne.ilpair(2,l)) then
               ! tous les indices sont differents
               call lispc3(k,l,yld)
               if(.not.yld) cycle
               ill1=ilc1(ilpair(2,l))
               ill2=ilp(ilpair(1,l),ilc(k))
               if(ill1.ne.0.and.ill2.ne.0) then
                  ill1=ill1+nlco
                  ! l'autre paire (obtenue par permutation des
                  ! indice) est aussi liee, et l'autre occupee est liee
                  ! au CAS
                  if(ipc(ill2,ill1).ne.0) then
                     ! l'autre ipc a ete aussi deja vue
                     ipc(l,k)=-ipc(ill2,ill1)
                     if(yw)print*,'copie',ill2,ill1
                  else
                     npc=npc+1
                     ipc(l,k)=npc
                  endif
               else
                  npc=npc+1
                  ipc(l,k)=npc
               endif
            endif
            if(itest(28)==1)print'(a,2i4,2x,i4,2X,2i4,i8)',
     *    'v k,l,ilc(k),ilpair(:,l),ipc',k,l,ilc(k),ilpair(:,l),ipc(l,k)
         enddo
      enddo
      npcovv=npc
      npctot=npctot+npc
      npc=npcoov
!      print*,'npcovv',npcovv
! on rajoute les cas ou 2 occupees sont identiques
      do k=1,nlco
         do l=1,nlpairp
            if(ilc(k).eq.ilpair(1,l)) then
               ! les indices T sont egaux
               ill1=ilc1(ilpair(1,l))
               ill2=ilp(ilc(k),ilpair(2,l))
               if(ill1.ne.0.and.ill2.ne.0) then
                  ! l'autre paire (obtenue par permutation des
                  ! indices) est aussi liee, et l'autre occupee est liee
                  ! au CAS
                  if(ipc(ill2,ill1).ne.0) then
                     ! l'autre ipc a ete aussi deja vue
                     ipc(l,k)=-ipc(ill2,ill1)
                  else
                     npc=npc+1
                     ipc(l,k)=npc
                  endif
               else
                  npc=npc+1
                  ipc(l,k)=npc
               endif
            endif
!            if(yw)print'(a6,2i4,2x,i4,2X,2i4,i8)',
!     *      'pcaba',k,l,ilc(k),ilpair(:,l),ipc(l,k)
            if(itest(28)==1)print'(a,2i4,2x,i4,2X,2i4,i8)',
     *      '2O l,k,ilc(k),ilpair(:,l),ipc(l,k)',
     *       l,k,ilc(k),ilpair(:,l),ipc(l,k)
         enddo
      enddo
      npcoov_te=npc-npcoov
      print*,'npcoov_te',npcoov_te
      npctot=npctot+npc
      npc=npcovv
      ! on rajoute les cas ou 2 virtuelles sont identiques
      do k=nlco+1,nlc
         do l=1,nlpairp
            if(ilc(k).eq.ilpair(2,l)) then
               ! les indices P sont egaux
               ill1=ilc1(ilpair(2,l))
               ill2=ilp(ilpair(1,l),ilc(k))
               if(ill1.ne.0.and.ill2.ne.0) then
                  ill1=ill1+nlco
                  ! l'autre paire (obtenue par permutation des
                  ! indices) est aussi liee, et l'autre occupee est liee
                  ! au CAS
                  if(ipc(ill2,ill1).ne.0) then
                     ! l'autre ipc a ete aussi deja vue
                     ipc(l,k)=-ipc(ill2,ill1)
                  else
                     npc=npc+1
                     ipc(l,k)=npc
                  endif
               else
                  npc=npc+1
                  ipc(l,k)=npc
               endif
            endif
!            if(yw)print'(a6,2i4,2x,i4,2X,2i4,i8)',
!     *      'pcaab',k,l,ilc(k),ilpair(:,l),ipc(l,k)
            if(itest(28)==1)print'(a,2i4,2x,i4,2X,2i4,i8)',
     *      '2V l,k,ilc(k),ilpair(:,l),ipc(l,k)',
     *       l,k,ilc(k),ilpair(:,l),ipc(l,k)
         enddo
      enddo
      npctot=npctot+npc
      npcovv_pe=npc-npcovv
      print*,'npcovv_pe',npcovv_pe
      print*,'nombre de paires a 3 indices(occ/paire + virt/paire) '
     *, npcoov+npcovv+npcoov_te+npcovv_pe
      return
      end
       subroutine lispp
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      !
      !!!!!!!!!!!!!!!!!!!
      ! Paires de paires
      if(w2)print*,'Paires de paires'
      !
      ! ipp(k*(k-1)/2) = numero de la paire de paires k et l
      ! 
      ! nppaaaa = nombre de paires de paires a 4 indices differents
      ! npp_pe  = nombre de paires de paires a indices part identiques
      ! npp_pete  = nombre de paires de paires a trou et part identiques
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      !!!!!!!!!!!!!!!!!!!
      !
      if(.not.allocated(ipp)) allocate(ipp(nlpairp*(nlpairp+1)/2))
      if(w2)
     *print*,'allocate ipp',nlpairp*(nlpairp+1)/2,nlpairp*(nlpairp-1)/2
      yw=.false.
      ipp=0
      npp=0
      npp0=0
      ! Tous indices differents
      do k=1,nlpairp
         do l=1,k
            npp0=npp0+1
            if(ilpair(1,k).ne.ilpair(1,l).and.
     *      ilpair(2,k).ne.ilpair(2,l)) then
               ! tous les indices sont differents
               ! appel a lispp2, pour eliminer toutes
               ! les interactions a longue distance
               call lispp2(k,l,yld)
               if(.not.yld) cycle
               ill1=ilp(ilpair(1,k),ilpair(2,l))
               ill2=ilp(ilpair(1,l),ilpair(2,k))
               if(ill1.ne.0.and.ill2.ne.0) then
                  ! les 2 autres paires (obtenues par permutation des
                  ! indices) sont aussi liees
                  illmin=min(ill1,ill2)
                  illmax=max(ill1,ill2)
                  npp1=(illmax-1)*(illmax)/2+illmin
                  if(ipp(npp1).ne.0) then
                     ! les 2 autres paires (liees) ont deja ete vues
                     ipp(npp0)=-ipp(npp1)
                  else
                     npp=npp+1
                     ipp(npp0)=npp
                  endif
               else
                  npp=npp+1
                  ipp(npp0)=npp
               endif
            endif
!            print'(a6,i6,2i4,2X,2i4,i8)',
!     *      'ppaaaa',npp0,ilpair(:,k),ilpair(:,l),ipp(npp0)
         enddo
      enddo
      nppaaaa=npp
      !print*,'Tous indices differents : npp0',npp0
      !print*,'nombre de paires de paires',npp
      ! on rajoute les cas ou les particules sont egales
      npp0=0
      do k=1,nlpairp
         do l=1,k
            npp0=npp0+1
            !print*,'ilpair2',ilpair(:,k),ilpair(:,l)
            if(ilpair(1,k).ne.ilpair(1,l).and.
     *      ilpair(2,k).eq.ilpair(2,l)) then
               ill1=ilp(ilpair(1,k),ilpair(2,l))
               ill2=ilp(ilpair(1,l),ilpair(2,k))
               if(ill1.ne.0.and.ill2.ne.0) then
                  illmin=min(ill1,ill2)
                  illmax=max(ill1,ill2)
                  npp1=(illmax-1)*illmax/2+illmin
                  if(ipp(npp1).ne.0) then
                     ! les 2 autres paires (liees) ont deja ete vues
                     ipp(npp0)=-ipp(npp1)
                  else
                     npp=npp+1
                     ipp(npp0)=npp
                  endif
               else
                  npp=npp+1
                  ipp(npp0)=npp
               endif
            endif
!            print'(a6,i6,2i4,2X,2i4,i8)',
!     *      'ppabaa',npp0,ilpair(:,k),ilpair(:,l),ipp(npp0)
         enddo
      enddo
      npp_pe=npp-nppaaaa
      !print*,' apres ajout des particules egales '
      !print*,'nombre de paires de paires',npp
      ! on rajoute les cas ou les trous sont egaux
      npp0=0
      do k=1,nlpairp
         do l=1,k
            npp0=npp0+1
            if(ilpair(1,k).eq.ilpair(1,l).and.
     *      ilpair(2,k).ne.ilpair(2,l)) then
               ill1=ilp(ilpair(1,k),ilpair(2,l))
               ill2=ilp(ilpair(1,l),ilpair(2,k))
               if(ill1.ne.0.and.ill2.ne.0) then
                  illmin=min(ill1,ill2)
                  illmax=max(ill1,ill2)
                  npp1=(illmax-1)*illmax/2+illmin
                  if(ipp(npp1).ne.0) then
                     ! les 2 autres paires (liees) ont deja ete vues
                     ipp(npp0)=-ipp(npp1)
                  else
                     npp=npp+1
                     ipp(npp0)=npp
                  endif
               else
                  npp=npp+1
                  ipp(npp0)=npp
               endif
            endif
!            print'(a6,i6,2i4,2X,2i4,i8)',
!     *      'ipp',npp0,ilpair(:,k),ilpair(:,l),ipp(npp0)
         enddo
      enddo
      npp_te=npp-nppaaaa-npp_pe
!      print*,' apres ajout des trous egaux '
!      print*,'nombre de paires de paires',npp0
      ! on rajoute les cas ab dans les occupees et virtuelles
      do k=1,nlpairp
         npp0=k*(k+1)/2
         npp=npp+1
         ipp(npp0)=npp
         !print*,'paires identiques',npp0,ipp(npp0)
      enddo
      npp_tepe=npp-nppaaaa-npp_pe-npp_te
!      print*,' apres ajout des T et P egaux'
      print*,'nombre de paires de paires',npp
      !/////////////////
      ! Ecriture des ipp
      !/////////////////
      npp0=0
      do k=1,nlpairp
         do l=1,k
            npp0=npp0+1
            if(w2)print'(a6,i6,2i4,2X,2i4,i8)',
     *      'ipp',npp0,ilpair(:,k),ilpair(:,l),ipp(npp0)
         enddo
      enddo
      return
      end
       subroutine corr_ord
      use module
      use mod_script
      corr_ttg=num1(nlco+2)
      corr_ppg=num1(nlcv+2)
      corr_ttl=0
      corr_ppl=0
      corr_tte=num1(nlco+1)
      corr_ppe=num1(nlcv+1)
      corr_ttgp=npcoov_te+npcoov
      corr_ppgt=npcovv_pe+npcovv
      corr_ttlp=0
      corr_pplt=0
      corr_ttep=0
      corr_ppet=0
      corr_ttgaa=nppaaaa+npp_te
      corr_ppgaa=nppaaaa+npp_pe
      corr_ttlaa=0
      corr_pplaa=0
      corr_tteaa=-npp_pe
      corr_ppeaa=0
      corr_ttgbb=nppaaaa+npp_te
      corr_ppgbb=nppaaaa+npp_pe
      corr_ttlbb=0
      corr_pplbb=0
      corr_ttebb=-npp_pe
      corr_ppebb=0
      npp=npp_pe+npp_te+npp_tepe
      corr_ttgppg=nppaaaa*3+npp
      corr_ttgppl=nppaaaa*2+npp
      corr_ttlppg=nppaaaa+npp
      corr_ttlppl=0
      corr_tteppg=nppaaaa*3+npp
      corr_tteppl=0
      corr_ttgppe=nppaaaa*3+npp
      corr_ttlppe=0
      corr_tteppe=0
      ! Rem : les variables corr_... ne sont plus utilisees ailleurs
      ! dans les autres subroutines
      !
      ! 0    0
      ! +    1
      ! -   -1
      ! +<+  2   aa
      ! -<- -2   bb
      ! +<-  3   ttl  ppl
      ! -<+ -3   ttg  ppg
      ! +=-  4   tte  ppe
      corr_tp=0
      corr_tp(-3,0)=corr_ttg
      corr_tp(0,-3)=corr_ppg
      corr_tp(4,0)=corr_tte
      corr_tp(0,4)=corr_ppe
      corr_tp(-3,1)=corr_ttgp
      corr_tp(-3,-1)=corr_ttgp
      corr_tp(1,-3)=corr_ppgt
      corr_tp(-1,-3)=corr_ppgt
      corr_tp(-3,2)=corr_ttgaa
      corr_tp(2,-3)=corr_ppgaa
      corr_tp(-3,-2)=corr_ttgbb
      corr_tp(-2,-3)=corr_ppgbb
      corr_tp(4,2)=corr_tteaa
      corr_tp(4,-2)=corr_ttebb
      corr_tp(-3,-3)=corr_ttgppg
      corr_tp(-3,3)=corr_ttgppl
      corr_tp(3,-3)=corr_ttlppg
      corr_tp(4,-3)=corr_tteppg
      corr_tp(-3,4)=corr_ttgppe
      if(w2)print*,'mat corr_tp'
      if(w2)call mscript(corr_tp)

      return
      end
       subroutine lis_cond
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      allocatable liscondtmp(:)
      allocate(idebliscond(norb+1))
      allocate(ifinliscond(norb))
      allocate(liscondtmp(norb*norb))
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Listes conditionnelles
      if(w2)print*,'Listes conditionnelles'
      !
      ! liscond(idebliscond(i):idebliscond(i+1)-1) =
      ! listes des paires contenant l'orbitale i (liste longue)
      ! liscond(idebliscond(i):ifinliscond(i)) =
      ! listes des paires contenant l'orbitale i (liste courte)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      yw=.false.
      !print*,'nlpair,nlpairp',nlpair,nlpairp
      kk=0
      ! Trous
      ifinliscond=0
      do k=1,noc
         idebliscond(k)=kk+1
         if(yac(k)) cycle
         do i=1,nlpair
            if(ilpair(1,i)==k) then
               kk=kk+1
               liscondtmp(kk)=i
            endif
            if(i==nlpairp) ifinliscond(k)=kk
         enddo
      enddo
      ! Particules
      do k=noc+1,norb
         idebliscond(k)=kk+1
         if(yac(k)) cycle
         do i=1,nlpair
            if(ilpair(2,i)==k) then
               kk=kk+1
               liscondtmp(kk)=i
            endif
            if(i==nlpairp) ifinliscond(k)=kk
         enddo
      enddo
      idebliscond(norb+1)=kk+1
      !
      ! On recopie dans liscond
      allocate(liscond(kk))
      liscond=liscondtmp(1:kk)
      deallocate (liscondtmp)
      if(yw) then
         do k=1,norb
         if(w2)print'(a,3i5)',
     *      'liste cond longue, k,idebliscond(k),idebliscond(k+1)-1'
     *      ,k,idebliscond(k),idebliscond(k+1)-1
            if(w2)print'(a,3i5)',
     *      'liste cond courte, k,idebliscond(k),ifinliscond(k)    '
     *      ,k,idebliscond(k),ifinliscond(k)
            do l=idebliscond(k),idebliscond(k+1)-1
               if(l>nlpairp) then
                  if(w2)
     *            print*,'====long====== l,liscond(l)',l,liscond(l)
               else
                  if(w2)
     *            print*,'====court===== l,liscond(l)',l,liscond(l)
               endif
            enddo
         enddo
      endif
      return
      end
       subroutine lispp2(k,l,yld)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer i,j,a,b
      i=ilpair(1,k)
      j=ilpair(1,l)
      a=ilpair(2,k)
      b=ilpair(2,l)
      if(all_linked) then
         yld=iloo(i,j)/=0.and.ilpp(a,b)/=0.and.ilp(i,b)/=0.and.
     *   ilp(j,a)/=0
      else
         yld=.false.
         if(iloo(i,j)/=0) yld=.true.
         if(ilpp(a,b)/=0) yld=.true.
         if(ilp(i,b)/=0) yld=.true.
         if(ilp(j,a)/=0) yld=.true.
      endif
      return
      end
       subroutine lispc2(k,l,yld)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer i,j,a,b
      j=ilpair(1,l)
      b=ilpair(2,l)
      i=ilc(k)
      if(all_linked) then
         yld=iloo(i,j)/=0.and.ilp(i,b)/=0
      else
         yld=.false.
         if(iloo(i,j)/=0) yld=.true.
         if(ilp(i,b)/=0) yld=.true.
      endif
      return
      end
       subroutine lispc3(k,l,yld)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer i,j,a,b
! itest(83) : (10 mai 2011)
! Il y a une erreur dans casdiloc :
! dans lispc2, on impose que i, lie au CAS, soit lie (par sl2) a la
! paire (j,b)
! j'ai oublie de faire l'equivalent pour les particules
! correction : c'est fait ici, dans lispc3
! itest(83)==0 : cette correction n'est pas prise en compte
      if(itest(83)==0) then
         yld=.true.
         return
      endif
      j=ilpair(1,l)
      b=ilpair(2,l)
      a=ilc(k)
      if(all_linked) then
         yld=ilpp(a,b)/=0.and.ilp(j,a)/=0
      else
         yld=.false.
         if(ilpp(a,b)/=0) yld=.true.
         if(ilp(j,a)/=0) yld=.true.
      endif
      return
      end
       subroutine cal_yl(izone,nbzones)
      use module
      use mod_lirint
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      logical yll,ytest
      dimension izone(norb)
      allocate (yl(norb,norb))
      yl=.false.
      do jz=0,nbzones-1
         do i=1,ninac
            ii=numin(i)
            do j=1,i-1
               jj=numin(j)
               if(yl(ii,jj)) cycle
               call cal_ytest(ytest,ii,jj,izone,jz,sli,sl_loc_1)
!              if(itest(29)==0) then
!                 ytest=min(izone(ii),izone(jj))==jz
!                 ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sli(jz)
!              else
!                 stop'valeur non prevue pour itest(29)'
!              endif
               yl(ii,jj)=ytest
               yl(jj,ii)=ytest
               if(itest(28)==1.and.yl(jj,ii)) print'(a,i3,a,2i5)',
     *         'zone',jz,'  Int: paire OO',ii,jj
            enddo
            do j=1,nvirt
               jj=numvir(j)
               if(yl(ii,jj)) cycle
               call cal_ytest(ytest,ii,jj,izone,jz,sli,sl_loc_1)
!              if(itest(29)==0) then
!                 ytest=min(izone(ii),izone(jj))==jz
!                 ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sli(jz)
!              else
!                 stop'valeur non prevue pour itest(29)'
!              endif
               yl(ii,jj)=ytest
               yl(jj,ii)=ytest
               if(itest(28)==1.and.yl(jj,ii)) print'(a,i3,a,2i5)',
     *         'zone',jz,'  Int: paire OV',ii,jj
            enddo
            do j=1,noac
               jj=numac(j)
               if(yl(ii,jj)) cycle
               call cal_ytest(ytest,ii,jj,izone,jz,sli,sl_loc_1)
!              if(itest(29)==0) then
!                 ytest=min(izone(ii),izone(jj))==jz
!                 ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sli(jz)
!              else
!                 stop'valeur non prevue pour itest(29)'
!              endif
               if(ytest) then
                  do k=1,noac
                     kk=numac(k)
                     yl(kk,ii)=.true.
                     yl(ii,kk)=.true.
                     if(itest(28)==1.and.yl(ii,kk)) print'(a,i3,a,2i5)',
     *               'zone',jz,'  Int: paire OA',ii,kk
                  enddo
                  exit
               endif
               if(ytest) exit
            enddo
         enddo
         do i=1,nvirt
            ii=numvir(i)
            do j=1,i-1
               jj=numvir(j)
               if(yl(ii,jj)) cycle
               call cal_ytest(ytest,ii,jj,izone,jz,sli,sl_loc_1)
!              if(itest(29)==0) then
!                 ytest=min(izone(ii),izone(jj))==jz
!                 ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sli(jz)
!              else
!                 stop'valeur non prevue pour itest(29)'
!              endif
               yl(ii,jj)=ytest
               yl(jj,ii)=ytest
               if(itest(28)==1.and.yl(jj,ii))print'(a,i3,a,2i5,2f12.8)',
     *         'zone',jz,'  Int: paire VV',ii,jj,sli(jz)
     *         ,ajk(min(ii,jj),max(ii,jj))
            enddo
            do j=1,noac
               jj=numac(j)
               if(yl(ii,jj)) cycle
               call cal_ytest(ytest,ii,jj,izone,jz,sli,sl_loc_1)
!              if(itest(29)==0) then
!                 ytest=min(izone(ii),izone(jj))==jz
!                 ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sli(jz)
!              else
!                 stop'valeur non prevue pour itest(29)'
!              endif
               if(ytest) then
                  do k=1,noac
                     kk=numac(k)
                     yl(kk,ii)=.true.
                     yl(ii,kk)=.true.
                     if(itest(28)==1.and.yl(ii,kk)) print'(a,i3,a,2i5)',
     *               'zone',jz,'  Int: paire VA',ii,kk
                  enddo
                  exit
               endif
               if(ytest) exit
            enddo
         enddo
         
         do i=1,noac
            ii=numac(i)
            do j=1,noac
               jj=numac(j)
               if(yl(ii,jj)) cycle
               if(itest(27)==1) then
                  ytest=min(izone(ii),izone(jj))==jz
               else
                  ytest=.true.
               endif
               ! a mon avis, itest(27)==0 ou 1, c'est la meme chose !
               if(ytest) yl(ii,jj)=.true.
               if(itest(28)==1.and.yl(jj,ii)) print'(a,i3,a,2i5)',
     *         'zone',jz,'  Int: paire AA',ii,jj
            enddo
         enddo
      enddo
      return
      end
       subroutine lienkij(jz,sl_loc,ilpair1,izone,nbzones)
      use module
      use mod_lirint
      use mod_lirorb
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(4) atom
      dimension ilpair1(2,noc*nvirt)
      dimension isym_loc(8)
      character(18),allocatable :: label(:)
      dimension izone(norb)
      dimension sl_loc(0:maxsl)
      logical ytest
      yw=.false.
        
!----------------------------------
         ! Liens avec les actives
         ! (on remplit ilc(nlc)=i : 
         ! l'indice occupe de la liaison n° nlc est i)
!----------------------------------
!----------------------------------
         ! liaison orbitale/CAS
!----------------------------------

      nlc_loc=nlco
      do io=1,ninac
         i=numin(io)
         if(izone(i)/=jz) cycle
         if(ilc1(i)/=0) cycle
         do ia=1,noac
            ic=numac(ia)
c            print*,'nlco',io,ia,ajk(min(i,ic),max(i,ic)),nlc_loc
            if(abs(ajk(min(i,ic),max(i,ic)))>=sl_loc(jz)) then
               nlc_loc=nlc_loc+1
               ilc(nlc_loc)=i
               if(itest(28)==1) then
                  print'(a,i4,a,i2,2a,i4,5a,2f12.8)'
     *            ,'liaison orb/CAS   occ',i
     *            ,' (zone ',jz,')'
     *            ,'  avec act',ic,'   ('
     *            ,trim(loinfo(i)(10:28)),'  '
     *            ,trim(loinfo(ic)(10:28)),')  AK='
     *            ,ajk(min(i,ic),max(i,ic)),sl_loc(jz)
               endif
               exit
            endif
         enddo
      enddo
      nlco_loc=nlc_loc
      nlc_loc=nlcv
      do iv=1,nvirt
         i=numvir(iv)
         if(izone(i)/=jz) cycle
         if(ilc1(i)/=0) cycle
         do ia=1,noac
            ic=numac(ia)
            if(abs(ajk(min(i,ic),max(i,ic)))>=sl_loc(jz)) then
               nlc_loc=nlc_loc+1
               ilc(nlc_loc+ninac)=i
               if(itest(28)==1) then
                  print'(a,i4,a,i2,2a,i4,5a,2f12.8)'
     *            ,'liaison orb/CAS   virt',i
     *            ,' (zone ',jz,')'
     *            ,'  avec act',ic,'   ('
     *            ,trim(loinfo(i)(10:28)),'  '
     *            ,trim(loinfo(ic)(10:28)),')  AK='
     *            ,ajk(min(i,ic),max(i,ic)),sl_loc(jz)
               endif
               exit
            endif
         enddo
      enddo
      nlcv_loc=nlc_loc
      nlc=nlc+nlc_loc
      nlco=nlco_loc
      nlcv=nlcv_loc
      nlc=nlco+nlcv
      if(itest(28)==1)print'(a,3i20)','nlco,nlcv,nlc',nlco,nlcv,nlc
!      do k=1,ninac+nvirt
!         print*,'ilc',k,ilc(k)
!      enddo
      !
      ! On definit ilc1, matrice des liaisons avec les actives
      !
      ilc1=0
      do k=1,nlco
         ilc1(ilc(k))=k
      enddo
      do k=1,nlcv
         ilc1(ilc(k+ninac))=k
      enddo
!      do k=1,norb
!         print*,'ilc1',k,ilc1(k)
!      enddo
!----------------------------------
         ! Paire occ/virt
!----------------------------------
      do io=1,ninac
         io1=numin(io)
         do iv=1,nvirt
            iv1=numvir(iv)
            if(il(io1,iv1)/=0) cycle
            call cal_ytest(ytest,io1,iv1,izone,jz,sl_loc,sl_loc_1)
            if(ytest) then
               nlpairp=nlpairp+1
               ilpair1(:,nlpairp)=(/io1,iv1/)
               il(io1,iv1)=k
               if(itest(28)==1) then
                  print'(a,i4,a,i2,2a,i4,5a,2f12.8)'
     *            ,'liaison occ/virt   occ',io1
     *            ,' (zone ',jz,')'
     *            ,'  avec virt',iv1,'   ('
     *            ,trim(loinfo(io1)(10:28)),'  '
     *            ,trim(loinfo(iv1)(10:28)),')  AK='
     *            ,ajk(min(io1,iv1),max(io1,iv1)),sl_loc_1
               endif
!           print'(a,3i5,f10.6,i4)','paire',io1,iv1,k,
!     *     ajk(min(io1,iv1),max(io1,iv1)),jz
            endif
         enddo
      !if(itest(28)==1)print'(a,i20)','nlpairp',nlpairp
      enddo
C      close(98,status='delete')
C      close(99)
      return
      end
       subroutine calzones(izone,nbzones)
      use module
      use mod_lirint
      use mod_lirorb
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
C      character(4) atom
C      dimension ilpair1(2,noc*nvirt)
C      dimension isym_loc(8)
      dimension izone(norb)
C      character(1000) zonetmp,aa
      character(80) aa
      yw=.false.
!----------------------------------
! calcul de izone(orb), zone a laquelle appartient l'orbitale orb
!----------------------------------
      izone=-1
! nombre de zones
      do k=0,maxsl
         if(zone(k)==' ') then
            nbzones=k
            exit
         endif
      enddo
        !print*,'nbzones',nbzones;stop
      open(99,file=trim(prefix)//'LOinfo',status='old')
      if(nbzones==1) then
         izone=0
      else if(index(zone(0),':')==0) then
         call calzones_atoms(izone,nbzones)
      else
         call calzones_LOinfo(izone,nbzones)
      endif
!
! Si t_zone=.true., incrementer les diffuses (orbitales T_...) d'une zone
!
      if(t_zone) then
         rewind 99
         read(99,*)
         do i=1,norb
            read(99,'(a80)') aa
            if(aa(35:38)=='DIFF') then
               print*,'DIFF',i
               izone(i)=min(izone(i)+1,nbzones)
            endif
         enddo
      endif
! Si les seuils ne sont pas donnes, definir des seuils par defaut
      do i=1,nbzones-1
         if(sl(i)<0.d0) sl(i)=0.01d0
         if(sl2(i)<0.d0) sl2(i)=0.0d0
         if(sli(i)<0.d0) sli(i)=1.d-8
      enddo
      print*,'*********************************'
      close(99)
      end
       subroutine calzones_atoms(izone,nbzones)
      use module
      use mod_lirint
      use mod_lirorb
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(4) atom
C      dimension ilpair1(2,noc*nvirt)
      dimension isym_loc(8)
      dimension izone(norb)
      character(1000) zonetmp,aa
      character(80) aaa
      yw=.false.
! traitement des "*" dans les donnees des atomes
      do k=0,nbzones-1
         i=index(zone(k),'*')
         if(i==0) exit
         aaa=' '
         ifin=0
         j=0
         do l=i-1,1,-1
            if(zone(k)(l:l)==',') then
               j=l
               exit
            endif
         enddo
!    on a :           '....,AB*,....'
!                          |  |
!                          j  i
         do l=1,natom
            if(l>1) then
               if(atom0(l)==atom0(l-1)) cycle
            endif
            if(index6(atom0(l),zone(k)(j+1:i-1))>0) then
               ideb=ifin+1
               ifin=ifin+len_trim(atom0(l))+1
               aaa(ideb:ifin)=trim(atom0(l))//','
            endif
         enddo
         call repl(zone(k),zone(k)(j+1:i),aaa(1:ifin-1),yrepl)
      enddo
      if(yw) then
         do k=0,nbzones-1
            print*,'0 k,zone(k)',k,trim(zone(k))
         enddo
      endif
!   on rajoute une derniere zone si tous les atomes ne sont pas donnes
      ideb=1
      do k=1,natom
         if(k>1) then
            if(atom0(k)==atom0(k-1)) cycle
         endif
         ytrouve=.false.
         do jz=0,nbzones-1
            zonetmp=','//trim(zone(jz))//','
            ytrouve=index(zonetmp,','//trim(atom0(k))//',')>0
            if(yw.and.ytrouve)print*,'trouve ',atom0(k)
            if(ytrouve) exit
         enddo
         if(.not.ytrouve) then
            if(yw)print*,' NON trouve ',atom0(k)
            l=len_trim(atom0(k))
            if(index(zone(nbzones)(1:ideb+l),
     *      ','//trim(atom0(k))//',')==0)
     *         then
               ifin=ideb+l
               zone(nbzones)(ideb:ifin)=trim(atom0(k))//','
               ideb=ifin+1
            endif
         endif
      enddo
      if(zone(nbzones)/=' ') nbzones=nbzones+1
      if(yw) then
         do k=0,nbzones-1
            print*,'k,zone(k)',k,trim(zone(k))
         enddo
      endif
C      l=len_trim(zone(nbzones-1))
C      zone(nbzones-1)(l:l)=' '
      deallocate(atom0)
      if(nbzones==0) nbzones=1
      print*,'number of zones:',nbzones
      print*,' '
      print*,'*********************************'
!
! Les actives sont mises en zone zero
!
      rewind 99
      read(99,'(a)') aa
      do k=1,norb
         read(99,'(a)') aa
         read(aa(5:8),'(i4)') i_ijkloc
         if(aa(29:31)=='ACT') izone(i_ijkloc)=0
      enddo
!
!---------------------------------------------------------------------
! Assignation d'un zone a chaque orbitale izone(orb)=numero de zone
! (elle est calculee a partir de l'assignation d'une zone
! a chaque atome : donnee par zone(jz)=liste des atomes de la zone jz)
!---------------------------------------------------------------------
!
! Boucle sur les zones
!
      rewind 99
      !do jz=nbzones-1,0,-1
      do jz=0,nbzones-1
! longueur de la zone (nb de caracteres)
         lz=0
         do
            if(yw)print*,'jz,zone(jz)',jz,trim(zone(jz))
            lz=lz+1
            if(zone(jz)(lz:lz)==' ') exit
         enddo
         lz=lz-1
         if(yw)print*,'lz',lz
! boucle sur les atomes de la zone
         ideb=1
         nboz=0
         do
            ifin=index(zone(jz)(1:lz),',')-1
            if(ifin==-1) ifin=lz
            atom=zone(jz)(ideb:ifin)
            call maj(atom,4)
! on connait l'atome a chercher parmi les orbitales (c'est "atom")
! Boucle sur les orbitales : on cherche celles qui contiennent "atom"
            rewind 99
            read(99,*) norb_loc
            nboz1=0
            do k=1,norb
               read(99,'(a80)') aa
               read(aa,'(4x,i4)') kk
!               if(izone(kk)/=-1) cycle
!               print*,'aa',aa(47:80),'---',' '//trim(atom)//' ',
!     *         index(aa(47:80),' '//trim(atom)//' ')
! la liste des atomes de l'orbitale k est aa(48:)
! l'atome a chercher dans cette liste est atom
               do ip=48,1000-4,4
                  if(aa(ip:ip+3)=='    ') exit
                  if(aa(ip:ip+3)==atom) then
!                 if(index(aa(47:80),' '//trim(atom)//' ')/=0) then
                     if(izone(kk)==-1) then
                        if(stop=='TOPO'.or.stop=='SL'
     *                  .or.stop=='NDET'.or.nprint>0)
     *                  print'(a,i5,a,i3)',
     *                  atom//'trouve dans orb',kk,'  '//
     *                  aa(10:28)//'  zone',jz
                        izone(kk)=jz
                        nboz=nboz+1
                        nboz1=nboz1+1
                     endif
                  endif
               enddo
            enddo
            if(stop=='TOPO'.or.stop=='SL'
     *      .or.stop=='NDET'.or.nprint>0)
     *      print'(a,i3,3a,i5,a,i5)',' Zone',jz,':   atom ',trim(atom)
     *      ,':   found',nboz1,' orbitals    Total:',nboz
            ideb=ifin+2
            zone(jz)(ifin+1:ifin+1)=' '
            if(ifin==lz) exit
         enddo
! 
! si nboz==0, l'atome n'a ete trouve dans aucune orbitale
! il n'existe donc pas , la donnee etait mauvaise
!
         if(nboz==0) then
            if(nboz==0) call titre('L''atome#'//trim(atom)//
     *      '#n''a pas ete trouve dans la liste d''orbitales#',60)
            stop
         endif
!
! Ecriture du nombre d'orbitales par zone
!
         print'(a,i4,10x,i3,2a)',
     *   ' Zone',jz,nboz,' orb     ',trim(zone(jz))
      enddo
      return
      end

       subroutine calzones_LOinfo(izone,nbzones)
      use module
      use mod_lirint
      use mod_lirorb
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(80) aa,bb,LL
      dimension izone(norb)
      allocatable y(:)
      call titre('Zones definies par type d''orbitales#'//
     *'(Les actives sont mises en zone 0)#',60)
      yw=.false.
      allocate(y(norb))
      y=.false.
!
!---------------------------------------------------------------------
! Assignation d'un zone a chaque orbitale izone(orb)=numero de zone
! (elle est calculee a partir de l'assignation d'une zone
! a chaque donnee
!---------------------------------------------------------------------
!
! Initialisation de toutes les orbitales a la derniere zone
      izone=nbzones
!
! Les actives sont mises en zone zero
!
      rewind 99
      read(99,'(a)') ll
      nbozac=0
      do k=1,norb
         read(99,'(a)') ll
         read(ll(5:8),'(i4)') i_ijkloc
         if(ll(29:31)=='ACT') then
            izone(i_ijkloc)=0
            nbozac=nbozac+1
         endif
      enddo


!
! Boucle sur les zones
!
CEX: donnee
CEX:  zone='+typ:PI,+orb:h11,+orb:h12',
CEX: '+typ:diff_s,+typ:diff_px,+typ:diff_py,+typ:diff_pz',

      print*,'Zone       Orb       Total/zone           Donnee'
      do jz=0,nbzones-1
         nboz=0 
         if(jz==0) then
            nboz=nbozac
            rewind 99
            read(99,'(a)') ll
            do i=1,norb
               read(99,'(a)') ll
               if(ll(10:11)=='A_') y(i)=.true.
            enddo
         endif
            
! longueur de la zone (nb de caracteres)
         if(yw) print*,' '
         if(yw)print*,trim(zone(jz))

CEX: zone(0)=+typ:PI,+orb:h11,+orb:h12
CEX: zone(1)=+TYP:DIFF_S,+TYP:DIFF_PX,+TYP:DIFF_PY,+TYP:DIFF_PZ

          lz=len_trim(zone(jz))
         if(yw)print*,'lz',lz
! Lecture des donnees de la zone (separees par des ":")
         do
            nboz1=0 
            aa=' '
            ifin=index(zone(jz),',')
            if(ifin==0) ifin=len_trim(zone(jz))+1
            aa=zone(jz)(1:ifin-1)
            call maj(aa,ifin-1)

CEX: zone(0) aa=+typ:PI
CEX: zone(0) aa=+orb:h11
CEX: ...
          
            if(yw)print*,'aa',trim(aa),ifin
!   Traitement de la donnee
!   donnee LOinfo a utiliser :
            jdeb=index(aa,':')+1
            !jfin=index(aa,';')-1
            !if(jfin==-1) jfin=len_trim(aa)
            jfin=len_trim(aa)
            if(yw) print*,'jdeb,jfin',jdeb,jfin
            if(yw)print*,'AA',trim(aa)
            rewind 99
            read(99,*) norb_tmp
            if(aa(2:jdeb-2)=='TYP') then
               if(yw)print*,'Typ'
               do i=1,norb
                  read(99,'(a)') ll
                  if(y(i)) cycle
                  read(ll(5:8),'(i4)') i_ijkloc
                  if(yw)print*,'ll,aa ',trim(ll(35:43)),'/'
     *            ,aa(jdeb:jfin),i,'  |'//aa(jdeb:jfin)//'|'
                  if(trim(ll(35:43))==aa(jdeb:jfin)) then
                     if(izone(i_ijkloc)==nbzones) izone(i_ijkloc)=jz
                     if(yw)print*,'ajouter ',trim(ll),jz,i
                     nboz=nboz+1
                     nboz1=nboz1+1
                     y(i)=.true.
                  endif
               enddo
            else if(aa(2:jdeb-2)=='N') then
               if(yw)print*,'N'
               do i=1,norb
                  read(99,'(a)') ll
                  if(y(i)) cycle
                  read(ll(5:8),'(i4)') i_ijkloc
                  read(ll(5:8),'(i4)') n2
                  read(aa(jdeb:jfin),*) n1
                  if(n1==n2) then
                     if(izone(i_ijkloc)==nbzones) izone(i_ijkloc)=jz
                     if(yw)print*,'ajouter ',trim(ll),jz,i
                     nboz=nboz+1
                     nboz1=nboz1+1
                     y(i)=.true.
                  endif
               enddo
            else if(aa(2:jdeb-2)=='ORB') then
               if(yw)print*,'Orb'
               do i=1,norb
                  !print*,'i,y(i)',i,y(i)
                  read(99,'(a)') ll
                  if(y(i)) cycle
                  read(ll(5:8),'(i4)') i_ijkloc
                  if(index(ll(10:28),aa(jdeb:jfin))/=0) then
                     if(izone(i_ijkloc)==nbzones) izone(i_ijkloc)=jz
                     if(yw)print*,'ajouter ',trim(ll),jz,i
                     nboz=nboz+1
                     nboz1=nboz1+1
                     y(i)=.true.
                  endif
               enddo
            endif
!
! Ecriture du nombre d'orbitales par zone
!
C            print'(a,i4,10x,i3,2a)',
C     *      'Zone',jz,nboz,' orb     ',trim(aa(1:ifin))
            print'(i4,6x,i5,6x,i5,15x,a)',
     *      jz,nboz1,nboz,trim(aa(1:ifin))

! Si on a fini de decoder la donnee pour la zone jz, on sort
            if(yw)print*,'ifin,len_trim(zone(jz))+1',
     *      jfin,len_trim(zone(jz))+1
            if(jfin==len_trim(zone(jz))) exit

! On va a la donnee suivante de la zone jz
            zone(jz)(1:jfin+1)=' '
            zone(jz)=adjustl(zone(jz))
            if(yw)print*,'ZONE APRES MODIF',trim(zone(jz))
!
         enddo
      enddo
!
! Ecriture du nombre d'orbitales dans la derniere zone
!
      print'(i4,6x,i5,6x,i5)',
     *nbzones,count(izone==nbzones),count(izone==nbzones)
!
! Ecriture des orbitales de chaque zone
!
      print*,' '
      do kz=0,nbzones
         if(kz<nbzones) then
            print*,'Orbitals of zone',kz
         else
            print*,'Orbitals of zone',kz,'  (other then "T_..."'
         endif
         rewind 99
         read(99,*)
         ifin=0
         aa=' '
         nbT=0
         do i=1,norb
            read(99,'(4x,i4,1x,a14)') k,bb(1:14)
            if(kz==izone(k))then
               if(bb(1:1)/='T'.or.kz<nbzones) then
                  ideb=ifin+3
                  ifin=ideb+len_trim(bb(1:14))-1
                  if(ifin>=80) then
                     ideb=1
                     ifin=len_trim(bb(1:14))
                     print'(a)', aa
                     aa=' '
                  endif
               else
                  nbT=nbT+1
               endif
               aa(ideb:ifin)=trim(bb)
            endif
         enddo
         ideb=1
         ifin=len_trim(bb(1:14))
         print'(a)', aa
         if(kz==nbzones)print*,'...plus',nbT,' diffuse orbitals (T_...)'
         print'(a)',' '
         aa=' '
      enddo
!
! Si toutes les orbitales n'ont pas ete definies, augmenter
! le nb de zones de 1 (donc prendre la valeur max de izone + 1)
!
      nbzones=maxval(izone)+1
      end

       subroutine cal_ytest(ytest,ii,jj,izone,jz,sl_loc,sl_loc_1)
      use module
      use mod_lirint
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension izone(norb),sl_loc(0:maxsl)
      logical ytest
      sl_loc_1=sl_loc(jz)
      if(itest(29)==0) then
         ytest=min(izone(ii),izone(jj))==jz
         ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sl_loc(jz)
      else if(itest(29)==1) then
         ytest=max(izone(ii),izone(jj))==jz
         ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sl_loc(jz)
      else if(itest(29)==2) then
         ytest=min(izone(ii),izone(jj))==jz
         sl_loc_1=(sl_loc(izone(ii))+sl_loc(izone(jj)))/2
         ytest=ytest.and.ajk(min(ii,jj),max(ii,jj))>=sl_loc_1
      else
         stop'valeur non prevue pour itest(29)'
      endif
      if(itest(28)==1)print'(a,2i5,2f12.8,l4,4i4)','cal_ytest',
     *ii,jj,ajk(min(ii,jj),max(ii,jj)),sl_loc(jz),ytest,itest(29),
     *izone(ii),izone(jj),jz
      return
      end
