      subroutine symdet
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! generation des determinants pour trouver les
! correspondances par symetrie
! appelle les subroutines gen..., qui appellent symdet2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      use module
C     use mod_dav
      use mod_gen
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      common/ecrv/nnn
      character(40) ccc
      dimension ivzero(2048)
      yw=.false.
      write(ccc,'(a,i1,a)')'is0=',is0,'    syspin='''//syspin//''''
      call titre('symdet :#'//
     *'calcul des relations de symetries entre determinants#'//
     *trim(ccc)//'#',300)
      ysym=.true.
      msym=1
      if(is0/=0) msym=nsym
      infosyml=msym
      if(syspin/=' ') infosyml=infosyml*2
      allocate(infosym(2048,infosyml))
      allocate(yysymdeja(ndet))
      yysymdeja=.false.
      infosym=0
      open(25,file='INFOSYM',form='unformatted',status='unknown')
      open(26,file='INFOSYM2',form='unformatted',status='unknown')
      idets=0
      idets0=0
      ndetsy=0
      nn=0
      do iclc=1,nclasc
         if(.not.exist_clasc(iclc)) cycle
         !
         ! Boucle sur les det du CAS de la classe
         !
         do kc=idebc(iclc),ifinc(iclc)
         if(yw)print'(a,16l1,2x,16l1)','symdet : det CAS de depart ',
     *      (btest(ibinc(kc),k-1),k=1,32)
            !
            !
            ! Calcul selectionne : distance du string CAS
            !
            if(sel==2) jdist=icaldist(kc,ibin,ibinc,noac)
            !
            ! Boucle sur les classes TP correspondant au CAS
            !
            do jcltp=1,nc_tp(iclc)
            if(yw)
     *         print*,'symdet : classes TP iclc,kc,jcltp',iclc,kc,jcltp
               nn=nn+1
               i=ic_tp(jcltp,iclc)
               nta=icltp1(1,i)
               ntb=icltp1(2,i)
               npa=icltp1(3,i)
               npb=icltp1(4,i)
               nt=nta+ntb
               np=npa+npb
               ntnp=nt+np
               if(yw)print*,'symdet : nt,np',nt,np
               if(yw)print*,'symdet : appel aux "gen"'
               if(yw)print*,'                        '
               if(sel==2) then
                  call lim_sel(nt,np,jdist,ibon)
                  if(ibon==0) cycle
               endif
               if(ntnp==0) then
                  call gen_0
               else if(ntnp==1) then
                  if(nt==1) then
                     call gen_t
                  else
                     call gen_p
                  endif
               else if(ntnp==2) then
                  if(nt==1) then
                     call gen_tp
                  else if(nt==0) then
                     call gen_pp
                  else if(nt==2) then
                     call gen_tt
                  endif
               else if(ntnp==3) then
                  if(nt==1) then
                     call gen_tpp
                  else
                     call gen_ttp
                  endif
               else if(ntnp==4) then
                  call gen_ttpp
               endif
            enddo
         enddo
      enddo
      ysym=.false.
      write(25) infosymn,infosym
      if(yw)print*,'infosymn',infosymn
      if(yw)print*,'infosym',infosym
      !deallocate(infosym)
      !print*,'yysmdeja'
      kk=0
      nvzero=0
      do k=1,ndet
         if(.not.yysymdeja(k)) then
            kk=kk+1
            nvzero=nvzero+1
            if(kk>2048) then
               write(26) ivzero
               kk=1
            endif
            ivzero(kk)=k
         endif
      enddo
      write(26) ivzero
      print*,'Prise en compte de la symetrie : nombre de det nuls :',
     *nvzero
      print*,'fin symetrisation'
      return
      end
!*******************************************************
       subroutine symdet2
      use module
C     use mod_dav
      use mod_gen
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension iaca(16),iacb(16),y(32),ita(2),itb(2),ipa(2),ipb(2)
      dimension jaca(16),jacb(16),jta(2),jtb(2),jpa(2),jpb(2)
      dimension jt(2),jp(2),yy(16)
      dimension infosym2(16)
      yw=.false.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! En entree : le det kc,it,ip
! On genere tous les det equivalents
! On calcule les signes
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      idets0=idets0+1
      if(yysymdeja(idets0)) return
      ndetsy=ndetsy+1
      idets=idets+1
      if(yw) then
          print*,'===================================='
          print*,'entree symdet2 :'
          print*,'syspin',syspin
          print*,'determinant en entree :'
          write(6,'(a,i3,3x,32l1)',advance='no')'kc,ibinc(kc)',
     *    kc,(btest(ibinc(kc),k-1),k=1,noac)
          write(6,'(3x,32l1)')(btest(ibinc(kc),k-1),k=17,17+noac-1)
          print*,'it',it(1:nt)
          print*,'ip',ip(1:np)
          print*,' '
      endif
      if(idets>2048) then
         idets=1
         write(25) infosymn,infosym
         if(yw)print*,'ecriture 25'
         infosym=0
      endif
      i=ibinc(kc)
      naca=0
      nacb=0
      do k=1,noac
         y(k)=i==ibset(i,k-1)
         if(i==ibset(i,k-1)) then
            naca=naca+1
            iaca(naca)=numac(k)
         endif
         y(k+noac)=i==ibset(i,k+15)
         if(i==ibset(i,k+15)) then
            nacb=nacb+1
            iacb(nacb)=numac(k)
         endif
      enddo
      if(yw)print*,'det CAS transforme en logiques : ',y(1:noac+noac)
      ita(1:nta)=it(1:nta)
      if(nta<2)itb(1:ntb)=-it(nta+1:nt)
      ipa(1:npa)=ip(1:npa)
      if(npa<2)ipb(1:npb)=-ip(npa+1:np)
      infosym(idets,1)=idets0
      if(syspin.ne.' ') then
         jt(1:ntb)=itb(1:ntb)
         jt(ntb+1:nt)=-ita(1:nta)
         jp(1:npb)=ipb(1:npb)
         jp(npb+1:np)=-ipa(1:npa)
         if(yw)print*,'Y ',y(1:noac+noac)
         yy(1:noac)=y(noac+1:noac*2)
         y(noac+1:noac*2)=y(1:noac)
         y(1:noac)=yy(1:noac)
         if(yw)print*,'Y ',y(1:noac+noac)
         if(yw)print*,'jt',jt(1:nt)
         if(yw)print*,'jp',jp(1:np)
         call adrdet(y,nt,jt,np,jp,iadr)
         if(syspin=='-') iadr=-iadr
         if(yw) print*,'iadr',iadr
         infosym(idets,msym+1)=iadr
         if(yw)print*,'iadr sym spin',iadr
      endif
      if(yw)print*,'ita',ita(1:nta)
      if(yw)print*,'itb',itb(1:ntb)
      if(yw)print*,'ipa',ipa(1:npa)
      if(yw)print*,'ipb',ipb(1:npb)
      do is=2,msym
         isgn=1
         jta(1:nta)=image(ita(1:nta),is)
         jtb(1:ntb)=image(itb(1:ntb),is)
         jpa(1:npa)=image(ipa(1:npa),is)
         jpb(1:npb)=image(ipb(1:npb),is)
         if(yw)print*,' '
         if(yw) print*,'is=',is
         if(yw)print*,'is=',is,'  image: jta',image(ita(1:nta),is)
         if(yw)print*,'is=',is,'  image: jtb',image(itb(1:ntb),is)
         if(yw)print*,'is=',is,'  image: jpa',image(ipa(1:npa),is)
         if(yw)print*,'is=',is,'  image: jpb',image(ipb(1:npb),is)
         jaca(1:naca)=image(iaca(1:naca),is)
         jacb(1:nacb)=image(iacb(1:nacb),is)
         do i=1,naca
            if(.not.yac(jaca(i))) then
               print*,'*******************************************'
               print'(a,i5,3a,i2,a,i5,a,a,/,a)',
     *         'Orbital  ',jaca(i),'  ',trim(loinfo(jaca(i))),
     *         ',  image by sym',is,' of Active Orbital',
     *         iaca(i),'  ',trim(loinfo(iaca(i)))
     *         ,' is not active','Verify numerotation of actives!'
               print*,'orbital numbers must be read in column 2 '
     *         //'of LOinfo file!'
               print*,'*******************************************'
               stop
            endif
         enddo
         if(yw) then
            write(6,*)'iaca,jaca'
            write(6,'(50i4)') iaca(1:naca)
            write(6,'(50i4)') jaca(1:naca)
            write(6,*)'iacb,jacb'
            write(6,'(50i4)') iacb(1:nacb)
            write(6,'(50i4)') jacb(1:nacb)
         endif
! Signe du aux orb qui se transforment en - elle-memes
         if(yw)print*,' '
         isgn=isgn*product(images(ita(1:nta),is))
         if(yw)print*,'isgn1',isgn
         isgn=isgn*product(images(itb(1:ntb),is))
         if(yw)print*,'isgn1',isgn
         isgn=isgn*product(images(ipa(1:npa),is))
         if(yw)print*,'isgn1',isgn
         isgn=isgn*product(images(ipb(1:npb),is))
         if(yw)print*,'isgn1',isgn
         isgn=isgn*product(images(iaca(1:naca),is))
         if(yw)print*,'isgn1',isgn
         isgn=isgn*product(images(iacb(1:nacb),is))
         if(yw)print*,'isgn1',isgn
! Signe du aux orb qui se croisent par symetrie
         if(nta==2) then
            call reor(2,jta,jsgn)
            isgn=isgn*jsgn
            !if(jsgn==-1)print*,'1jsgn'
         endif
         if(ntb==2) then
            call reor(2,jtb,jsgn)
            isgn=isgn*jsgn
            !if(jsgn==-1)print*,'2jsgn'
         endif
         if(npa==2) then
            call reor(2,jpa,jsgn)
            isgn=isgn*jsgn
            !if(jsgn==-1)print*,'3jsgn'
         endif
         if(npb==2) then
            call reor(2,jpb,jsgn)
            isgn=isgn*jsgn
            !if(jsgn==-1)print*,'4jsgn'
         endif
         if(naca>1) then
            call reor(naca,jaca,jsgn)
            isgn=isgn*jsgn
            !print*,'jaca',jaca(1:naca)
            !if(jsgn==-1)print*,'5jsgn'
         endif
         if(nacb>1) then
            call reor(nacb,jacb,jsgn)
            isgn=isgn*jsgn
            !if(jsgn==-1)print*,'6jsgn'
         endif
         if(yw)print*,'isgn2',isgn
! Signe du au deplacement des trous
         if(nta==1) isgn=isgn*(1-2*mod(abs(jta(1)-ita(1)),2))
         if(ntb==1) isgn=isgn*(1-2*mod(abs(jtb(1)-itb(1)),2))
         if(nta==2) then
            isgn=isgn*(1-2*mod(abs(jta(1)-ita(1)),2))
            isgn=isgn*(1-2*mod(abs(jta(2)-ita(2)),2))
         endif
         if(ntb==2) then
            isgn=isgn*(1-2*mod(abs(jtb(1)-itb(1)),2))
            isgn=isgn*(1-2*mod(abs(jtb(2)-itb(2)),2))
         endif
         if(yw)print*,'isgn3',isgn
         if(yw)print*,' '
! On reconstitue le det T/P complet
         jt(1:nta)=jta(1:nta)
         if(nta<2)jt(1+nta:nt)=-jtb(1:ntb)
         jp(1:npa)=jpa(1:npa)
         if(npa<2)jp(1+npa:np)=-jpb(1:npb)
         y=.false.
         !print*,'jaca',jaca(1:naca)
! On reconstitue la partie active du det
         y(num_oav(jaca(1:naca)))=.true.
         y(num_oav(jacb(1:nacb))+noac)=.true.
         !print*,'sym symdet2',jaca(1:naca)
         !print*,'sym symdet2',jacb(1:nacb)
         call adrdet(y,nt,jt,np,jp,iadr)
         if(yw)print*,'adressage : iadr,is',iadr,is
         iadr=iadr*dsym(is0,is)*isgn
         infosym(idets,is)=iadr
         if(yw)print'(a,3i5)','remplissage infosym(idets,is)',
     *   idets,is,iadr
         if(syspin.ne.' ') then
            jt(1:ntb)=jtb(1:ntb)
            jt(ntb+1:nt)=-jta(1:nta)
            jp(1:npb)=jpb(1:npb)
            jp(npb+1:np)=-jpa(1:npa)
            yy(1:noac)=y(noac+1:noac*2)
            y(noac+1:noac*2)=y(1:noac)
            y(1:noac)=yy(1:noac)
            call adrdet(y,nt,jt,np,jp,iadr)
            !print*,'iadr sym spin,is',iadr,is
            iadr=iadr*dsym(is0,is)*isgn
            if(syspin=='-') iadr=-iadr
            infosym(idets,msym+is)=iadr
            ! signe
         endif
      enddo
      if(yw)print'(a,i6,3x,8i6)','infosym',idets0,infosym(idets,:)
      if(yw)print*,' '
!
! signe
!
 
!
! Combien de det differents ?
!
      infosym2(1:infosyml)=infosym(idets,1:infosyml)
      infosym(idets,2:infosyml)=0
      ii=1
      ybon=.true.
      do i=2,infosyml
         ydeja=.false.
         do j=1,ii
            if(infosym2(i)==-infosym(idets,j)) ybon=.false.
            if(infosym2(i)==infosym(idets,j)) then
               ydeja=.true.
               exit
            endif
         enddo
         if(.not.ydeja) then
            ii=ii+1
            infosym(idets,ii)=infosym2(i)
         endif
      enddo
      infosymn(idets)=ii
      if(yw)print*,'nb de det differents :',ii
      if(.not.ybon) then
          idets=idets-1
          ndetsy=ndetsy-1
          if(yw)print*,'Det non compatible avec les symetries'
          return
          infosym(idets,1:ii)=0
      endif
      !yysymdeja(abs(infosym(idets,2:ii)))=.true.
      if(yw)print*,'INFOSYM',infosym(idets,1:infosyml),infosymn(idets)
      do i=2,ii
         yysymdeja(abs(infosym(idets,i)))=.true.
      enddo
      yysymdeja(idets0)=.true.
      if(yw)print*,'sortie symdet2'
      if(yw)print*,'===================================='
      if(yw)print*,' '
      return
      end
 
       subroutine symdet3(v0)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! symetrisation du vecteur v0
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      use module
C     use mod_dav
      use mod_gen
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension v0(ndet),ivzero(2048)
      dimension isgn(16)
      yw=.false.
      if(yw)print*,'entree symdet3 ndetsy=',ndetsy
      if(yw)print*,'v0',v0(1:min(ndet,50))
      if(is0==0.and.syspin==' ') return
      rewind 25
      jdet=2048
      do idet=1,ndetsy
         jdet=jdet+1
         if(jdet>2048) then
            jdet=1
            read(25) infosymn,infosym
         endif
         if(yw)print'(a,16i12)','infosym',
     *   infosym(jdet,1:infosymn(jdet))
         if(infosym(jdet,1)==0) then
            v0(abs(infosym(jdet,1:infosymn(jdet))))=0.d0
            cycle
         endif
         if(yw)print'(a,2i8,16f12.8)','v      ',idet,ndetsy,
     *   v0(abs(infosym(jdet,1:infosymn(jdet))))
!!!!!!!!!!!!!!!!!test a supprimer!!!!!!!!!!!!!
         if(infosymn(jdet)>1) then
!            if(product(1.d0*infosym(jdet,1:infosymn(jdet)))*
!     *      product(v0(abs(infosym(jdet,1:infosymn(jdet)))))<0)
!     *      print*,'ERREUR'
!            if(product(1.d0*infosym(jdet,1:infosymn(jdet)))*
!     *      product(v0(abs(infosym(jdet,1:infosymn(jdet)))))<0) stop
            do k=1,infosymn(jdet)
               if(infosym(jdet,k)>0) then
                  isgn(k)=1
               else
                  isgn(k)=-1
               endif
            enddo
          if(.not.allocated(infosym)) stop'INFOSYM'
            a=sum(isgn(1:infosymn(jdet))
     *      *v0(abs(infosym(jdet,1:infosymn(jdet)))))/infosymn(jdet)
            v0(abs(infosym(jdet,1:infosymn(jdet))))=
     *      a*isgn(1:infosymn(jdet))
         endif
      enddo
      ! coefficients nuls par symetrie
      rewind 26
      kk=2048
      if(yw)print*,'nb de coefs nuls par symetrie',nvzero
      do k=1,nvzero
         kk=kk+1
         if(kk>2048) then
            kk=1
            read(26) ivzero
         endif
         v0(ivzero(kk))=0.d0
      enddo
      if(yw)print*,'fin symdet3'
      return
      end
 
 
