      subroutine liens_dist(ilpair1)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Liaisons entre orbitales pour la liste des determinants
! critere base sur la distance des atomes correspondants
! aux liaisons
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      use module
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(300) aa
      character(10000) namel
      character(4) latom(maxat),latomtot(maxat),iat,jat
      dimension coor(3,maxat),coortot(3,maxat),coortmp(3),lsyat(maxat)
      character(80) symm
      character(3) sim(0:7)
      character(4),dimension(maxat) :: actl
      integer,allocatable :: itsymoa(:)
      dimension isymoa(8)
      dimension ilpair1(2,noc*nvirt)
      allocatable yacc(:)
      yw=.false.
      yw1=.false.
      
      allocate(loinfo(norb))
      allocate(yacc(norb))
      allocate (yl(norb,norb))
      ilpp=0
      iloo=0
      yl=.false.
!
! Lecture de symm
!
      if(nsym>1) then
         symm=' '
         actl=' '
         rewind(93)
         call lecnam('&LOCCI',namel,93,ierr,0)
         call namela(namel,SYMM,'SYMM')
         call namela(namel,ACTL,'ACTL')
         call maj(symm,len_trim(symm))
         if(symm==' ') then
            call titre('liens=''DIST'' : il faut donner symm'//
     *      ' comme dans ijkloc#',60)
            stop
         endif
         call symmsim(symm,sim,nsym)
      endif
!
! Lecture isym et latom
!
      call open_chose_number(ifil_info,trim(prefix)//'Info',
     *'old','formatted')
      call lecnam('&COST_MO',namel,ifil_info,ierr,0)
      call nameli(namel,isym,'ISYM',4)
      rewind ifil_info
      call lecnam('&COST_AO',namel,ifil_info,ierr,0)
      close(ifil_info)
      call nameli(namel,lnatom,'NATOM',4)
      call nameld(namel,COOR,'COOR',8)
      call namela(namel,latom,'ATOM')
      call nameli(namel,isymoa,'ISYM',4)
      call nameli(namel,nao,'NORB',4)
      allocate(itsymoa(nao))
!
! Ouverture LOinfo, lecture loinfo
!
      call open_chose_number(ifil_loinfo,trim(prefix)//'LOinfo',
     *'old','formatted')
      read(ifil_loinfo,'(a)') aa
      do is=1,nsym
         do io=1,isym(is)
            read(ifil_loinfo,'(a300)') aa
            read(aa(5:8),*) ii
            loinfo(ii)=aa
            !print'(a,3i5,2x,a)','LOinfo',is,io,ii,loinfo(ii)(9:18)
         enddo
      enddo
      close(ifil_loinfo)
!
! si actl est en donnee, modifier loinfo
!
      if(actl(1).ne.' ') call modif_loinfo_actl(loinfo,actl,norb)
!
! Coordonnees des atomes
!
      lnatomtot=0
      do k=1,lnatom
! On lit un atome. Ses corrdonnees correspondront a la symetrie 1
         if(yw)print'(a,i3,2x,a,3f10.6)','atom',k,latom(k),coor(:,k)
         lnatomtot=lnatomtot+1
         latomtot(lnatomtot)=latom(k)
         coortot(:,lnatomtot)=coor(:,k)
         lsyat(lnatomtot)=1
! On genere les atomes equivalents
         do is=1,nsym-1
            coortmp(:)=coor(:,k)
            if(index(sim(is),'X')/=0) coortmp(1)=-coortmp(1)
            if(index(sim(is),'Y')/=0) coortmp(2)=-coortmp(2)
            if(index(sim(is),'Z')/=0) coortmp(3)=-coortmp(3)
            if(yw)print'(3f10.6,a)',coortmp,sim(is)
            lnatomtot=lnatomtot+1
            latomtot(lnatomtot)=latom(k)
            coortot(:,lnatomtot)=coortmp
            lsyat(lnatomtot)=is+1
            if(yw)print*,'Nouv',is+1
         enddo
      enddo
      if(yw) then
         do k=1,lnatomtot
            print'(a,i3,2x,a,3f10.6,i3)','at',k,latomtot(k),coortot(:,k)
     *      ,lsyat(k)
         enddo
      endif
!
! calcul itsymoa
!
      ii=0
      do is=1,nsym
         do io=1,isymoa(is)
            ii=ii+1
            itsymoa(ii)=is
         enddo
      enddo
!
! Distances entre les orbitales
! Si la distance est zero, les 2 orbitales sont liees, on cree
! alors une paire d'orbitales
!
      nlc=0
      nlco=0
      nlcv=0
      nlpairp=0
      nlpairoo=0
      nlpairvv=0
      yacc=.false.
! On effectue une double boucle sur des paires d'OL
      do io=1,norb
         write(98,'(a)')trim(loinfo(io))
      enddo
      do io=1,norb
         read(loinfo(io)(44:46),'(i3)') inat
         read(loinfo(io)(1:4),'(i4)') i
         is=itsymoa(i)
         if(yw)print'(a,i5)','ORB 1 '//loinfo(io)(10:28),io
         do jo=io+1,norb
            d=1000000000.d0
            read(loinfo(jo)(44:46),'(i3)') jnat
            read(loinfo(jo)(1:4),'(i4)') j
            js=itsymoa(j)
            if(yw)print'(a,i5)','ORB 2 '//loinfo(jo)(10:28),jo
! Les numeros des 2 OL dans le fichier LOinfo sont io et jo
! leurs numeros dans la listes des OL de ijkloc sont io et jo
! io contient inat atomes, jo jnat atomes
! il leur sont associe les symetries is et js
! c.a.d. qu'elles sont obtenues a partie des OL de reference par
! les operations is et js
!
! On va definir la distance entre io et jo comme la distance minimale
! entre 1 atome de io et 1 atome de jo
            do ia=1,inat
               iat=loinfo(io)(48+(ia-1)*4:51+(ia-1)*4)
               do ja=1,jnat
                  jat=loinfo(jo)(48+(ja-1)*4:51+(ja-1)*4)
!                  print'(a,10i4)','io,jo,io,jo,inat,jnat'
!     *            ,io,jo,io,jo,inat,jnat,
!     *            is,js
                  d=min(adist(iat,jat,is,js,lnatomtot,latomtot,lsyat,
     *            coortot),d)
!                  print'(a,2f10.6)',iat//jat,
!     *            adist(iat,jat,is,js,lnatomtot,latomtot,lsyat,
!     *            coortot),d
                  if(d<1.d-8) d=0.d0
                  if(d==0.d0) exit
               enddo
               if(d==0.d0) exit
            enddo
! A ce niveau, d est la distance entre les OL io et jo
! les numeros de io et jo sont, io et jo dans la 
! numerotation de ijkloc. C'est cette numerotation qu'il faut stocker
!
! Appel chuligitaj, qui decide si les deux OL sont liees
            call chuligitaj(yligitaj,d,inat,jnat,
     *      loinfo(io)(48:48+inat*4-1),loinfo(jo)(48:48+jnat*4-1),io,jo,
     *      loinfo(io)(10:28),loinfo(jo)(10:28))
!
!----------------------------------------------------------------
! Liaisons entre orbitales pour les determinants
!----------------------------------------------------------------
!
! On definit :
!   ilc(nlc)=io    la NLCieme OL liees au CAS est io
!   ilpair1(:,nlpairp)=(/io,jo/)   la NLPAIRPieme paire
!   est formee des OL io,jo
            if(yligitaj) then
               if(yw)print*,'ligitaj dist',io,jo,d
               if(yw)print'(18x,a,2i3,f10.6)', loinfo(jo)(10:28),is,js,d
               if(loinfo(io)(29:31)=='ACT') then
                  if(loinfo(jo)(29:31)=='OCC') then
                     if(.not.yacc(jo)) then
                        nlc=nlc+1
                        nlco=nlco+1
                        ilc(nlc)=jo
                        yacc(jo)=.true.
                        if(yw)print*,'ILC1',nlc,jo
                     endif
                  else if(loinfo(jo)(29:31)=='VIR') then
                     if(.not.yacc(jo)) then
                        nlc=nlc+1
                        nlcv=nlcv+1
                        ilc(nlc)=jo
                        if(yw)print*,'ILC2',nlc,jo
                        yacc(jo)=.true.
                     endif
                  endif
               else if(loinfo(jo)(29:31)=='ACT') then
                  if(loinfo(io)(29:31)=='OCC')then
                     if(.not.yacc(io)) then
                        nlc=nlc+1
                        nlco=nlco+1
                        ilc(nlc)=io
                        yacc(io)=.true.
                        if(yw)print*,'ILC3',nlc,io
                     endif
                  else if(loinfo(io)(29:31)=='VIR') then
                     if(.not.yacc(io)) then
                        nlc=nlc+1
                        nlcv=nlcv+1
                        ilc(nlc)=io
                        yacc(io)=.true.
                        if(yw)print*,'ILC4',nlc,io
                     endif
                  endif
               endif
               if(loinfo(io)(29:31)=='OCC') then
                  if(loinfo(jo)(29:31)=='VIR') then
                     nlpairp=nlpairp+1
                     ilpair1(:,nlpairp)=(/io,jo/)
                     if(yw)print*,'ILPAIR1_1',io,jo,nlpairp
                  else if(loinfo(jo)(29:31)=='OCC') then
                     if(io/=jo) then
                        nlpairoo=nlpairoo+1
                        iloo(io,jo)=nlpairoo
                        iloo(jo,io)=nlpairoo
                     endif
                  endif
               else if(loinfo(io)(29:31)=='VIR') then
                  if(loinfo(jo)(29:31)=='OCC') then
                     nlpairp=nlpairp+1
                     ilpair1(:,nlpairp)=(/jo,io/)
                     if(yw)print*,'ILPAIR1_2',jo,io,nlpairp
                  else if(loinfo(jo)(29:31)=='VIR') then
                     if(io/=jo) then
                        nlpairvv=nlpairvv+1
                        ilpp(io,jo)=nlpairvv
                        ilpp(jo,io)=nlpairvv
                  !print*,'calcul ilpp',io,jo,nlpairvv
                     endif
                  endif
               endif
!
!----------------------------------------------------------------
! Liaisons entre orbitales pour les integrales
!----------------------------------------------------------------
!
               yl(io,jo)=.true.
               yl(jo,io)=.true.
            endif
         enddo
      enddo
      call reor(nlc,ilc,jsgn)
!
! 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
      if(yw)print*,'NLC',nlc
            
      return
      end
       function adist(iat,jat,is,js,lnatomtot,latomtot,lsyat,
     *coortot)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(4) iat,jat
      character(4) latomtot(lnatomtot)
      dimension lsyat(lnatomtot)
      dimension coortot(3,lnatomtot)
      do i=1,lnatomtot
         if(latomtot(i)==iat.and.lsyat(i)==is) then
            do j=1,lnatomtot
               if(latomtot(j)==jat.and.lsyat(j)==js) then
                  !print*,'acOCCalc',i,j
                  adist=sqrt((coortot(1,i)-coortot(1,j))**2+
     *            (coortot(2,i)-coortot(2,j))**2+
     *            (coortot(3,i)-coortot(3,j))**2)
               endif
            enddo
         endif
      enddo
      return
      end
      
          
       subroutine symmsim(symm,sim,nsym)
      character(20) symm
      character(3) sim(0:7)
      symm=adjustl(symm)
      long=20
      call suppdb(symm,long)
      l=index(symm,' ')
      sim(0)='E'
      if(nsym==2) then
         sim(1)=symm(1:l-1)
      else if (nsym==4) then
         sim(1)=symm(1:l-1)
         sim(2)=symm(l+1:l+4)
         call prod_sym(sim(1),sim(2),sim(3))
      else if (nsym==8) then
         sim(1)=symm(1:l-1)
         symm(l:l)='&'
         l1=index(symm,' ')
         sim(2)=symm(l+1:l1-1)
         symm(l1:l1)='&'
         l2=index(symm,' ')
         sim(4)=symm(l1+1:l2-1)
         call prod_sym(sim(1),sim(2),sim(3))
         call prod_sym(sim(1),sim(4),sim(5))
         call prod_sym(sim(2),sim(4),sim(6))
         call prod_sym(sim(2),sim(5),sim(7))
         symm(l:l)=' '
         symm(l1:l1)=' '
      endif
      return
      end
       subroutine prod_sym(sim1,sim2,sim3)
      character(3) sim1,sim2,sim3
      character(6) c
      logical yw
      yw=.false.
      c=trim(sim1)//trim(sim2)
      nx=0
      ny=0
      nz=0
      n=0
      l=len_trim(c)
      do k=1,l
         if(index(c(k:k),'X')/=0) nx=nx+1
         if(index(c(k:k),'Y')/=0) ny=ny+1
         if(index(c(k:k),'Z')/=0) nz=nz+1
      enddo
      sim3=' '
      if(nx==1) then
         n=n+1
         sim3(n:n)='X'
      endif
      if(ny==1) then
         n=n+1
         sim3(n:n)='Y'
      endif
      if(nz==1) then
         n=n+1
         sim3(n:n)='Z'
      endif
      if(yw)print'(a,8a4)','sim1,sim2,sim3 ',sim1,sim2,sim3
      return
      end
       subroutine chuligitaj(yligitaj,d,inat,jnat,iat,jat,io,jo,lo1,lo2)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(*) iat,jat,lo1,lo2
      character(10000) namel
      character(100) atliens(maxat/2)
      character(4) at(maxat/2)
      yw=.false.
      yw1=.false.
!
!---------------------------------------------------------
! en entree :
! inat,jnat : nombre d'atomes des 2 OL (OL1,OL2)
! iat,jat : (character) liste des atomes des OL
! io,jo : numero des OL
! en sortie : 
! yligitaj (logical) T si les 2 OL sont liees, F sinon
!---------------------------------------------------------
!
      !print*,'entree chuligital',inat,jnat,iat,jat;stop
      yligitaj=.false.
!
!---------------------------------------------------------
! 1. si d==0, les 2 OL sont liees, rien d'autre a tester
!---------------------------------------------------------
!
      if(d<1.d-6) then
         yligitaj=.true.
         return
      endif
!
!---------------------------------------------------------
! 2. d>0 On regarde si des atomes sont lies par donnee
! ex, si on a donne
! atliens='CU:N1:10.'
! toute OL contenant CU est liee avec toute OL contenant N1 si 
! d(OL1,OL2)<10.
!---------------------------------------------------------
!
! lecture de atliens
      rewind 93
      atliens=' '
      call lecnam('&LOCCI',namel,93,ierr,0)
      call namela(namel,ATLIENS,'ATL')
! boucle sur les donnees de atliens
      do i=1,maxat/2
         if(atliens(i)==' ') exit
!
         if(yw)print*,'atliens',i,trim(atliens(i))
! le character atliens a la forme : 'AT1:AT2:AT3:dist'
! ou AT1, ... sont des noms d'atomes, dist est un reel
!
! dans la donnee, 
! nb d'atomes dans atliens, liste des atomes, distance :
         nat=0
         ideb=1
         l=len_trim(atliens(i))
         do k=1,l
            if(atliens(i)(k:k)==':') then
               nat=nat+1
               at(nat)=atliens(i)(ideb:k-1)
               ifin=k-1
               if(yw)print*,'at',nat,at(nat)
               if(yw)print*,'reste',atliens(i)(ifin+2:l)
               ideb=ifin+2
               if(index(atliens(i)(ifin+2:l),':')==0) exit
            endif
         enddo
         if(yw)print*,'coucou',ideb,l,atliens(i)(ideb:l)
         read(atliens(i)(ideb:l),*) dist
         if(yw)print*,'dist',dist
! Les atomes iat (de OL1) et jat (de OL2) 
! sont-ils dans la liste atliens ?
         y1=.false.
         do k=1,nat
            do kk=1,inat
               if(iat(1+(kk-1)*4:4+(kk-1)*4)==at(k)) then
                  y1=.true.
                  exit
               endif
            enddo
         enddo
         if(yw)print*,'Y1   ',trim(lo1),'  ',trim(lo2),y1,'  '
     *   ,iat,'  ',at(1:nat)
         if(yw.and.y1)print*,'**********************************'
         if(.not.y1) cycle
         y2=.false.
         do k=1,nat
            do kk=1,jnat
               if(jat(1+(kk-1)*4:4+(kk-1)*4)==at(k)) then
                  y2=.true.
                  exit
               endif
            enddo
         enddo
         if(yw)print*,'Y2   ',trim(lo1),'  ',trim(lo2),y2
     *   ,jat,'  ',at(1:nat)
         if(.not.y2) cycle
! Les atomes iat (de OL1) et jat (de OL2) 
! sont bien dans la liste atliens
! si la distance d entre les 2 OL est < a la disttance dist en
! donnee, on declare OL1 et OL2 liees
         if(yw.and.y1)print*,'#########################################'
         if(yw1)print*,trim(lo1),'  ',trim(lo2),y1,y2,d,dist
         if(d<dist) then
            yligitaj=.true.
            print*,'liees par atliens(',i,') : ',
     *      trim(lo1),'  ',trim(lo2)
            return
         endif
      enddo
      return
      end
       subroutine modif_loinfo_actl(loinfo,actl,norb)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(300) loinfo(norb)
      character(4) actl(maxat)
      character(100000) namel
! on compte les atomes de actl
      namel=' '
      do ia=1,maxat
         call maj(actl(ia),4)
         if(actl(ia)==' ') then
            inat_aj=ia-1
            exit
         endif
      enddo
! On modifie
      ia=0
      ifin=0
      do io=1,norb
         if(loinfo(io)(29:31)=='ACT') then
            ideb=ifin+1
            read(loinfo(io)(44:46),*) inat
            ifin_ligne=47+4*inat
            write(loinfo(io)(ifin_ligne+1:),'(1000a4)') actl(1:inat_aj)
            write(loinfo(io)(44:46),'(i3)') inat+inat_aj
            namel(ideb+1:ideb+18)=loinfo(io)(10:28)
            namel(ideb+22:ideb+21+4*inat)=
     *      loinfo(io)(48:47+4*inat)
            jdeb=ideb+21+4*inat+1
            do k=1,inat_aj
               jfin=jdeb+3
               namel(jdeb:jfin)=actl(k)
               jdeb=jdeb+4
            enddo
            ifin=jfin
            namel(ifin:ifin)='#'
         endif
      enddo
      call titre(
     *'Modification du voisinage des actives (actl en donnee)##'
     *//trim(namel),70)
      return
      end
         
      
      

          
      
