      subroutine cd02s(in0,jn0,kn0,ln0,esp1,naa,file1
     *,io1,io2,io3,io4,idaa,iespaa,coef,aa,ind256)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |             esp1              |    si .not.yscmrs
c    |               |     esp1      |    si yscmrs
c
 
c
c------------------------------------------------------------------
c Subroutine de calcul des interactions pour les integrales
c contenant au moins un element du CAS (presque toutes)
c
c en entree : in0,jn0,kn0,ln0   indices de l'integrale
c naa : nombre d'autres integrales de meme classe (sym,type)
c que in0,jn0,kn0,ln0
c les indices de ces autres integrales sont codes dans coef
c les valeurs numeriques des naa integrales sont dans aa
c------------------------------------------------------------------
c
      use mod_ndimcs0
      include 'maxorb.prm'
      include 'cds.inc'
      common /prep/ nca0,ncb0,ic0(maxorbcas),icamun(maxorb+maxorb)
     *,numt(maxorb),nump(maxorb),nv
     *,gener,yoc(maxorb+maxorb),yrefc(maxorbcas),yac(maxorb)
     *,ygmono,ygddci,ygddc2,ygcas,ygtous
      character*4 gener
      common/dimis/ iadris,iadristp,maxsps
      common/dim/iadri ; integer(8) iadri
      common/cd02w/yww
      dimension esp1(iadri*2)
      common /icd1/ispin(2)
      common /nummrs/nummr(maxorb)
      dimension nmf(maxorbcas),nmo(maxorbcas)
      dimension ksgna0(maxorb),ksgnb0(maxorb)
      dimension jlibreo(maxorbcas)
      dimension ic1(maxorbcas)
      dimension it100(2),ip100(2),it200(2),ip200(2)
      dimension aa(naa),iespaa(idaa),coef(naadim,ind256)
      common/naadi/naadim
      character*1 coef
      character*(*) file1
      common/igen/ igener
      yww=.false.
      yw1=yscmrs
      yw1=.true.
      yw1=.false.
      iech=0
c
c     reservation de l'espace pour les matrices en entiers
c
c     on a deja des matrices qui viennent de l'amont :
c     ce sont coef et aa, dim=naa. soit un entier de dim naa*3.
c     idaa est l'espace qui reste diponible une fois stockees ces mat.
c
c     le programme a besoin ensuite, comme grandes matrices, de :
c   * iadrsp1, iadrsp2 : stockage des adresses de spin
c     dimension : n el dans m orb. =maxsps
c   * isgns : signe du a la distribution des spins
c     dimension maxsps
c   * ltf,lpf : numeros des integrales utilisees dans la
c     boucle interne. dimension naa
c     il reste :
      idaa1=(idaa-maxsps*3-naa*2)/2
      if(idaa1.lt.naa) then
         print*,'dans cd02s idaa1 trop petit'
         print*,'idaa1=',idaa1,'     naa=',naa
         print*,'idaa=',idaa,'     maxsps=',maxsps
         print*,'augmenter iadristp'
         stop
      endif
c
c   * iadrtp1,iadrtp2 : stockage des adresses de trous et part
c     dimension : naa*(nb d'adresses pour une integrale)
c     la dimension peut etre trop grande. On donne le maximum,
c     et on fera le calcul en plusieurs fois si necessaire
c
c     dimensions disponibles
c
c |*******aa*******|**coef**|**iadrsp1,iadrsp2,isgns**|**ltf,lpf**|
c  <----naa*2-----> <-naa1-> <--------maxsps*3-------> <--naa*2-->
c                           |<...........iespaa....................
c
c |***********kadrtp1****|*****kadrtp2**********|
c  <------idaa1---------> <--------idaa1------->
c  ............................................>
c
c si norb<256  naa1=naa      sinon naa1=naa*5/4
c
      jdaa2=maxsps+1
      jdaa3=jdaa2+maxsps
      jdaa4=jdaa3+maxsps
      jdaa5=jdaa4+naa
      jdaa6=jdaa5+naa
      jdaa7=jdaa6+idaa1
      if(yww)print*,'idaa1,jdaa2,jdaa3,jdaa4,jdaa5,jdaa6,jdaa7'
     *,idaa1,jdaa2,jdaa3,jdaa4,jdaa5,jdaa6,jdaa7
c
c     calcul gamma2
c
c      if(yga2.and.file1.ne.'        ') then
      if(yga2) then
         do k=1,naa
            aa(k)=1.d0
         enddo
      endif
c
c     on note les indices de l'integrale
c
      in=in0
      jn=jn0
      kn=kn0
      ln=ln0
      if(yw1) then
         print*,'*****************cd02s********************'
         print*,'in,jn,kn,ln',in,jn,kn,ln
         do k=1,naa
           if(k.eq.1) then
              ii=in0
              jj=jn0
              kk=kn0
              ll=ln0
           else
c              ii=icar(coef(k,io1))
c              jj=icar(coef(k,io2))
c              kk=icar(coef(k,io3))
c              ll=icar(coef(k,io4))
              call decods(coef(k,ind256),coef(k,io1),coef(k,io2)
     *        ,coef(k,io3),coef(k,io4),ii,jj,kk,ll,
     *        io1,io2,io3,io4,4)
           endif
           write(6,'(a2,4i4,a2,3x,2i2,f19.15,a10,i3)')
     *     ' <',ii,jj,kk,ll,' >'
     *     ,ispin,aa(k),file1,ichar(coef(k,ind256))
         print*,'direct',(ichar(coef(k,kkkk)),kkkk=1,ind256)
           yerr=ii.le.0.or.jj.le.0.or.kk.le.0.or.ll.le.0.or.
     *       ii.gt.norb.or.jj.gt.norb.or.kk.gt.norb.or.ll.gt.norb
           if(yerr) then
           print*,'yerr',ichar(coef(k,ind256))
           print*,'yerr',ichar(coef(k,io1))
           print*,'yerr',ichar(coef(k,io2))
           print*,'yerr',ichar(coef(k,io3))
           print*,'yerr',ichar(coef(k,io4))
           print*,'yerr',io1,io2,io3,io4
           endif
           if(yerr) stop
         enddo
      endif
c      write(75,*)'<',in,jn,kn,ln,'>','$'
c      call scril
c      yww=yscmrs.and.in.eq.1.and.jn.eq.3.and.kn.eq.5.and.ln.eq.6
c      yww=in.eq.5.and.jn.eq.1.and.kn.eq.3.and.ln.eq.2
c      yww=yww.or.(in.eq.5.and.jn.eq.4.and.kn.eq.7.and.ln.eq.10)
c      yww=yww.or.(in.eq.4.and.jn.eq.6.and.kn.eq.15.and.ln.eq.12)
c     *.and.yscmrs
      if(yww)print*,'iadris,iadristp,maxsps',iadris,iadristp,maxsps
      if(yww)print*,'naa,file1',naa,file1
      if(yww)print*,'ispin',ispin
c
c----------------------------------------------------------------
c     signe des orbitales en fonction de la position des indices
c----------------------------------------------------------------
c     de l'integrale
c
      do k=1,norb
         ksgna0(k)=1
         ksgnb0(k)=1
      enddo
      ii=nummr(in)
      jj=nummr(jn)
      kk=nummr(kn)
      ll=nummr(ln)
      im=min(ii,kk)
      jm=min(jj,ll)
      km=max(ii,kk)
      lm=max(jj,ll)
      if(ispin(1).eq.1) then
         do k=im+1,km-1
            ksgna0(k)=-1
         enddo
      else
         do k=im+1,km-1
            ksgnb0(k)=-1
         enddo
      endif
      if(ispin(2).eq.1) then
         do k=jm+1,lm-1
            ksgna0(k)=-ksgna0(k)
         enddo
      else
         do k=jm+1,lm-1
c           print*,'k',k
            ksgnb0(k)=-ksgnb0(k)
         enddo
      endif
      isgni0=1
      if(ispin(1).eq.ispin(2)) then
c
c        signe du a l'ordre des indices de l'integrale
c--      si i-j et k-l sont de signe opposes
c        il faudra reordonner kl, donc il y a un signe moins
 
c
         if((ii-jj)*(kk-ll).gt.0) then
            isgni0=1
         else
            isgni0=-1
c           c'est encore le cas pour les int <ijik>, mais pas
c           si i est inactive
            if(ii.eq.kk) then
               if(itype(in).eq.1) isgni0=1
            endif
            if(jj.eq.ll) then
               if(itype(jn).eq.1) isgni0=1
            endif
         endif
         if(ispin(1).eq.1) then
            ksgna0(im)=1
            ksgna0(jm)=1
            ksgna0(km)=1
            ksgna0(lm)=1
         else
            ksgnb0(im)=1
            ksgnb0(jm)=1
            ksgnb0(km)=1
            ksgnb0(lm)=1
         endif
      endif
      if(yww) then
         write(75,*)'ksgna0',(ksgna0(k),k=1,norb),'$'
         call scril
         write(75,*)'ksgnb0',(ksgnb0(k),k=1,norb),'$'
         call scril
      endif
c
c     signe du aux occupees
c
      isgnoa0=1
      isgnob0=1
      if(file1(1:1).eq.' ') then
         do k=1,ninac
            isgnoa0=isgnoa0*ksgna0(k)
            isgnob0=isgnob0*ksgnb0(k)
         enddo
      endif
c
c----------------------------------------------------------------
c     fin du calcul du signe des orbitales
c----------------------------------------------------------------
c
c------------------------------------------------------------------
c     distribution des indices de l'integrale sur les det 1 et 2
c------------------------------------------------------------------
c
      do k=1,noac
         iocc10(k)=0
         iocc20(k)=0
      enddo
      nt10=0
      nt20=0
      nc10=0
      nc20=0
      np10=0
      np20=0
      call cd03s(in,nt20,it20,nc10,ic10,np10,ip10,iocc10,
     *iplt20,iplp10,io1)
      call cd03s(jn,nt20,it20,nc10,ic10,np10,ip10,iocc10,
     *iplt20,iplp10,io2)
      call cd03s(kn,nt10,it10,nc20,ic20,np20,ip20,iocc20,
     *iplt10,iplp20,io3)
      call cd03s(ln,nt10,it10,nc20,ic20,np20,ip20,iocc20,
     *iplt10,iplp20,io4)
      if(yww) then
         write(75,*)'io1,io2,io3,io4',io1,io2,io3,io4,'$'
         call scril
         write(75,*)'it10',(it10(k),k=1,nt10),'$'
         call scril
         write(75,*)'ic10',(ic10(k),k=1,nc10),'$'
         call scril
         write(75,*)'ip10',(ip10(k),k=1,np10),'$'
         call scril
         write(75,*)'it20',(it20(k),k=1,nt20),'$'
         call scril
         write(75,*)'ic20',(ic20(k),k=1,nc20),'$'
         call scril
         write(75,*)'ip20',(ip20(k),k=1,np20),'$'
         call scril
         write(75,*)'iocc10',(iocc10(k),k=1,noac),'$'
         call scril
         write(75,*)'iocc20',(iocc20(k),k=1,noac),'$'
         call scril
         write(75,*)'iplt10,iplt20,iplp10,iplp20'
     *   ,iplt10,iplt20,iplp10,iplp20,'$'
         call scril
      endif
c
c     symetries
c
      ist10=1
      isp10=1
      do k=1,nt10
         ist10=its(ist10,itsym(it10(k)))
      enddo
      do k=1,np10
         isp10=its(isp10,itsym(ip10(k)))
      enddo
      ist20=1
      isp20=1
      do k=1,nt20
         ist20=its(ist20,itsym(it20(k)))
      enddo
      do k=1,np20
         isp20=its(isp20,itsym(ip20(k)))
      enddo
c
c     calcul sc2  on met a l'abri qques variables
c
 
 
 
c      yscmrs=.false.
c      iech=1
 
 
 
      nt100=nt10
      np100=np10
      nt200=nt20
      np200=np20
      if(yscmrs)then
         do k=1,nt10
            it100(k)=it10(k)
         enddo
         do k=1,np10
            ip100(k)=ip10(k)
         enddo
         do k=1,nt20
            it200(k)=it20(k)
         enddo
         do k=1,np20
            ip200(k)=ip20(k)
         enddo
         ist100=ist10
         isp100=isp10
         ist200=ist20
         isp200=isp20
      endif
c
      if(yww) then
         write(75,*)'ist10,isp10,ist20,isp20',ist10,isp10,ist20,isp20,'$
     &   '
         call scril
      endif
 
c
c        si in.eq.ln, on met un alpha a gauche et un beta a droite
c        dans la meme orbitale
c        on ne pourra pas ajouter d'el celibataire
c        idem pour jn et kn :
c
c        yspinalt (dim du CAS). Orbitales CAS correspondant a ce cas
c        yspinalttp (dim norb). Orbitales TP correspondant a ce cas
c
      ispinalt=0
      ispinalttp=0
      do k=1,noac
         yspinalt(k)=.false.
      enddo
      do k=1,norb
         yspinalttp(k)=.false.
      enddo
      if(ispin(1).ne.ispin(2)) then
         if(in.eq.ln) then
            if(itype(in).eq.2) then
               ispinalt=ispinalt+1
               yspinalt(itorbc(in))=.true.
            else
               ispinalttp=ispinalttp+1
               yspinalttp(in)=.true.
            endif
         endif
         if(jn.eq.kn) then
            if(itype(jn).eq.2) then
               ispinalt=ispinalt+1
               yspinalt(itorbc(jn))=.true.
            else
               ispinalttp=ispinalttp+1
               yspinalttp(jn)=.true.
            endif
         endif
      endif
      if(yww) then
         write(6,'(a15,40l2)')'yspinalttp',(yspinalttp(k),k=1,norb)
         write(6,'(a15,40l2)')'yspinalt',(yspinalt(k),k=1,noac)
      endif
c
c     on complete les parties CAS
c
      nlibref=0
      do k=1,noac
         if(iocc10(k).eq.0.and.iocc20(k).eq.0) then
            nlibref=nlibref+1
            ilibref(nlibref)=k
         endif
      enddo
      nlibreo=0
      do k=1,noac
         if(iocc10(k).ne.2.and.iocc20(k).ne.2.and..not.
     *   yspinalt(k)) then
            nlibreo=nlibreo+1
            ilibreo(nlibreo)=k
         endif
      enddo
      if(yww) then
         write(75,*)'ilibref',(ilibref(k),k=1,nlibref),'$'
         call scril
         write(75,*)'ilibreo',(ilibreo(k),k=1,nlibreo),'$'
         call scril
      endif
      nelac1=nelac-max(nc10,nc20)
c     ncfmina,ncfmaxa min et max du nombre de CF a ajouter
      iplus=2
      if(ygcas) iplus=0
      if(ygmono) iplus=1
      imoins=iplus
      if(ninac.eq.0) iplus=0
      if(nvirt.eq.0) imoins=0
      ncfmaxa=min(nlibref,(nelac1+iplus)/2)
c      ncfmina=max(0,nelac1-2-nlibref)
      ncfmina=max(0,nelac1-imoins-noac)
      if(yww)print*,'ncfmina,ncfmaxa',ncfmina,ncfmaxa
!      Dans certains cas, on va generer des det ou le nb de couches
!      ouvertes dans le CAS est trop petit pour etre augmente dans
!      les TP jusqu'a abs(ms2), qui est la valeur min pour le det.
      min_nb_co_in_det=abs(ms2)
      if(igener==1.or.igener==2) then 
         min_nb_co_in_cas=min_nb_co_in_det-2
      else
         min_nb_co_in_cas=min_nb_co_in_det-igener
      endif
c
c     boucles sur le nombre de CF et CO rajoutees au CAS
c
      do ncfa=ncfmina,min(itest(64),ncfmaxa)
         ncomaxa=min(nlibreo-ncfa,nelac1+iplus-ncfa*2)
         if(yww)print*,'nlibreo,nelac1,ncfa',nlibreo,nelac1,ncfa
         ncomina=max(0,nelac1-imoins-ncfa*2)
         if(yww)print*,'ncfa,ncomina,ncomaxa',ncfa,ncomina,ncomaxa
         do ncouva=ncomina,ncomaxa
            nc100=nc10+ncfa+ncfa+ncouva
            nc200=nc20+ncfa+ncfa+ncouva
            if(yww)print*,'nc100,nc200',nc100,nc200
            if(nc100.lt.nelac-imoins+nt100) goto 301
            if(nc200.lt.nelac-imoins+nt200) goto 301
            if(nc100.gt.nelac+iplus-np100) goto 301
            if(nc200.gt.nelac+iplus-np200) goto 301
            call combi0(nmf,nlibref,ncfa,iretf)
            goto 300
 25         call combi2(nmf,nlibref,ncfa,iretf)
 300        continue
            do l=1,noac
               iocca(l)=0
            enddo
            do l=1,ncfa
               iocca(ilibref(nmf(l)))=2
            enddo
            mlibreo=0
            do l=1,noac
               if(iocc10(l).ne.2.and.iocc20(l).ne.2
     *         .and.iocca(l).ne.2.and..not.yspinalt(l)) then
                  mlibreo=mlibreo+1
                  jlibreo(mlibreo)=l
               endif
            enddo
            call combi0(nmo,mlibreo,ncouva,ireto)
c            if(yww)print*,'apres combi0 ireto',ireto
            goto 400
 26         call combi2(nmo,mlibreo,ncouva,ireto)
c            if(yww)print*,'apres combi2 ireto',ireto
 400        continue
            nc1=nc100
            nc2=nc200
            do l=1,ncouva
               iocca(jlibreo(nmo(l)))=1
            enddo
            do l=1,noac
               iocc1(l)=iocc10(l)+iocca(l)
               iocc2(l)=iocc20(l)+iocca(l)
            enddo
            if(yww) then
               write(75,*)'iocc1',(iocc1(k),k=1,noac),'$'
               call scril
               write(75,*)'iocc2',(iocc2(k),k=1,noac),'$'
               call scril
            endif
c
c           signe du au CAS (orb doublement occupees)
c
            isgncfa1=isgnoa0
            isgncfb1=isgnob0
            do k=1,noac
               if(iocc1(k).eq.2) then
                  if(ksgna0(ninac+k).eq.-1) isgncfa1=-isgncfa1
                  if(ksgnb0(ninac+k).eq.-1) isgncfb1=-isgncfb1
               endif
            enddo
            isgncfa=isgncfa1
            isgncfb=isgncfb1
            if(.not.yscmrs)then
               isgncfa2=isgnoa0
               isgncfb2=isgnob0
               do k=1,noac
                  if(iocc2(k).eq.2) then
                     if(ksgna0(ninac+k).eq.-1) isgncfa2=-isgncfa2
                     if(ksgnb0(ninac+k).eq.-1) isgncfb2=-isgncfb2
                  endif
               enddo
            endif
            if(yww) then
               write(75,*)'isgnoa0,isgnob0,isgncfa,isgncfb',
     *         isgnoa0,isgnob0,isgncfa,isgncfb,'$'
               call scril
            endif
c
c------------------------------------------------------------------
c           on a les occupations du CAS pour les 2 determinants
c           on calcule leurs adresses CAS, puis mint,maxt...
c------------------------------------------------------------------
c
            call adrcass(iocc1,iadrs1,idum,jdum,ic1)
            ncouv=count(iocc1(1:noac)==1)
            if(ncouv<min_nb_co_in_cas) goto 500
            mixtpmrs1=ichar(tpmrs(iadrs1))
            if(yww)print*,'iadrs1,mixtpmrs1',iadrs1,mixtpmrs1
            call sptxm(mint1,maxt1,minp1,mixtpmrs1)
            if(yww) then
               write(75,*)'mint1,maxt1,minp1,maxp1',
     *         mint1,maxt1,minp1,maxp1,'$'
               call scril
            endif
            if(mint1.gt.maxt1) goto 500
            maxp1=minp1+maxt1-mint1
            call adrcass(iocc2,iadrs2,idum,jdum,ic1)
            ncouv=count(iocc2(1:noac)==1)
            if(ncouv<min_nb_co_in_cas) goto 500
            mixtpmrs2=ichar(tpmrs(iadrs2))
c            print*,'mixtpmrs2',mixtpmrs2
            call sptxm(mint2,maxt2,minp2,mixtpmrs2)
            if(yww) then
               write(75,*)'mint2,maxt2,minp2,maxp2',
     *         mint2,maxt2,minp2,maxp2,'$'
               call scril
            endif
            if(mint2.gt.maxt2.and..not.yscmrs) goto 500
            maxp2=minp2+maxt2-mint2
            nim1=nim(iadrs1)
            nim2=nim(iadrs2)
            if(yww) then
               write(75,*)
     *         'iadrs1,iadrs2,nim1,nim2',iadrs1,iadrs2,nim1,nim2,'$'
               call scril
            endif
            if(yww)print*,'avant cd15s mint1,maxt1,mint2,maxt2',
     *      mint1,maxt1,mint2,maxt2,nim1,nim2,nt1,nc1,np1,nt2,nc2,np2
c
c           valeurs possibles des trous
c
            call cd14s
c
            if(yscmrs) then
c              si le det de droite est dans l'espace,
c              et celui de gauche non, echanger
               if(iech.eq.1) then
                  nc2=nc100
                  nc1=nc200
                  nt20=nt100
                  np20=np100
                  nt10=nt200
                  np10=np200
                  do k=1,nt20
                     it20(k)=it100(k)
                  enddo
                  do k=1,np20
                     ip20(k)=ip100(k)
                  enddo
                  do k=1,nt10
                     it10(k)=it200(k)
                  enddo
                  do k=1,np10
                     ip10(k)=ip200(k)
                  enddo
                  ist20=ist100
                  isp20=isp100
                  ist10=ist200
                  isp10=isp200
                  in=kn0
                  jn=ln0
                  kn=in0
                  ln=jn0
                  isgncfa=isgncfa2
                  isgncfb=isgncfb2
                  call cd15s
               else
                  nc1=nc100
                  nc2=nc200
                  nt10=nt100
                  np10=np100
                  nt20=nt200
                  np20=np200
                  do k=1,nt10
                     it10(k)=it100(k)
                  enddo
                  do k=1,np10
                     ip10(k)=ip100(k)
                  enddo
                  do k=1,nt20
                     it20(k)=it200(k)
                  enddo
                  do k=1,np20
                     ip20(k)=ip200(k)
                  enddo
                  ist10=ist100
                  isp10=isp100
                  ist20=ist200
                  isp20=isp200
                  in=in0
                  jn=jn0
                  kn=kn0
                  ln=ln0
                  isgncfa=isgncfa1
                  isgncfb=isgncfb1
               endif
 
 
            endif
            if(yww)print*,'apres cd15s mint1,maxt1,mint2,maxt2',
     *      mint1,maxt1,mint2,maxt2,nim1,nim2,nt1,nc1,np1,nt2,nc2,np2
 
 
 
c           symetrie des CAS
            isc1=1
            isc2=1
            isolc1=0
            isolc2=0
            do k=1,noac
               if(iocc1(k).eq.1) then
                  isc1=its(isc1,itsym(numac(k)))
                  isolc1=isolc1+1
               endif
            enddo
            do k=1,noac
               if(iocc2(k).eq.1) then
                  isc2=its(isc2,itsym(numac(k)))
                  isolc2=isolc2+1
               endif
            enddo
            if(yww) then
               write(75,*)'isc1,isc2,isolc1,isolc2',
     *         isc1,isc2,isolc1,isolc2,'$'
               call scril
            endif
c
c           dans le CAS, on cherche les electrons celibataires qui
c           peuvent changer de spin, et ceux qui sont fixes (qui
c           correspondent aux indices de l'integrale)
c           kvarc : nombre d'electrons variables
c           ivarc1,ivarc2 : numeros des electrons variables parmi
c           les electrons celibataires
c
            do k=1,norb
               iint(k)=0
            enddo
            iint(kn)=ispin(1)
            iint(ln)=ispin(2)
            iint(in)=ispin(1)
            iint(jn)=ispin(2)
            kseul=0
            kvarc=0
            kfixc1=0
            do k=1,noac
               if(iocc1(k).eq.1) then
                  kseul=kseul+1
                  if(iint(numac(k)).eq.0) then
                     kvarc=kvarc+1
                     ivarc1(kvarc)=kseul
                  else
                     kfixc1=kfixc1+1
                     if(iocc2(k).ne.2.or.yspinalt(k)) then
                        ifixc1(kfixc1)=iint(numac(k))
                     else
                        ifixc1(kfixc1)=-iint(numac(k))
                     endif
                  endif
               endif
            enddo
            iint(in)=ispin(1)
            iint(jn)=ispin(2)
            iint(kn)=ispin(1)
            iint(ln)=ispin(2)
            kseul=0
            kvarc=0
            kfixc2=0
            do k=1,noac
               if(iocc2(k).eq.1) then
                  kseul=kseul+1
                  if(yww)print*,'numac(k),iint(numac(k))',
     *            numac(k),iint(numac(k)),kseul
                  if(iint(numac(k)).eq.0) then
                     kvarc=kvarc+1
                     ivarc2(kvarc)=kseul
                     if(yww)print*,'coucou4',kvarc
                  else
                     if(yww)print*,'coucou5',kvarc
                     kfixc2=kfixc2+1
                     if(iocc1(k).ne.2.or.yspinalt(k)) then
                        ifixc2(kfixc2)=iint(numac(k))
                     else
                        ifixc2(kfixc2)=-iint(numac(k))
                     endif
                  endif
               endif
            enddo
            if(yww) then
               write(75,*)'ifixc1',(ifixc1(k),k=1,kfixc1),
     *         '  ifixc2',(ifixc2(k),k=1,kfixc2),'$'
               call scril
               write(75,*)'ivarc1',(ivarc1(k),k=1,kvarc),
     *         '  ivarc2',(ivarc2(k),k=1,kvarc),'$'
               call scril
            endif
c
c------------------------------------------------------------------
c           appel aux boucles suivantes
c------------------------------------------------------------------
c
            call cd04s(in,jn,kn,ln,isgncfa,isgncfb,ksgna0,ksgnb0,
     *      isgni0,esp1,naa,idaa1,iespaa,
     *      iespaa(jdaa2),iespaa(jdaa3),iespaa(jdaa4),iespaa(jdaa5),
     *      iespaa(jdaa6),iespaa(jdaa7),
     *      coef,aa,ind256)
 
 
 
 500        continue
            do l=1,ncouva
               iocca(jlibreo(nmo(l)))=0
            enddo
c            if(yww)print*,'ireto,iretf',ireto,iretf
            if(ireto.eq.0) goto 26
            if(iretf.eq.0) goto 25
 301        continue
         enddo
      enddo
c      if(yga2.and.file1.ne.'        ') then
      if(yga2) then
         do k=1,naa
c            in=icar(coef(k,io1))
c            jn=icar(coef(k,io2))
c            kn=icar(coef(k,io3))
c            ln=icar(coef(k,io4))
            if(file1.ne.'        ')
     *      call decods(coef(k,ind256),coef(k,io1),coef(k,io2)
     *      ,coef(k,io3),coef(k,io4),in,jn,kn,ln,
     *        io1,io2,io3,io4,4)
            a=aa(k)
            if(ispin(2).eq.1) then
               call disin1(lg2p,ig2p,57,in,jn,kn,ln,a,2)
            else if(ispin(1).eq.-1) then
               call disin1(lg2m,ig2m,58,in,jn,kn,ln,a,3)
            else
               call disin1(lg2,ig2,56,in,jn,kn,ln,a,1)
            endif
c            call disin1(lg,ig,ifilg2,in,jn,kn,ln,a,icg2)
         enddo
      endif
      return
      end
       subroutine cd04s(in,jn,kn,ln,isgncfa,isgncfb,ksgna0,ksgnb0,
     *isgni0,esp1,naa,idaa1,iadrsp1,iadrsp2,isgns,ltf,lpf
     *,kadrtp1,kadrtp2,
     *coef,aa,ind256)
c
c--------------------------------------------------------
c     boucles sur le nombre de trous, isol, symetries
c--------------------------------------------------------
c
      use mod_ndimcs0
      include 'maxorb.prm'
      include 'cds.inc'
      integer,allocatable,dimension(:) :: nbaa
      common/dim/iadri ; integer(8) iadri
      common/cd02w/yww
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      dimension esp1(iadri*2)
      common/sy4/ntstot(0:maxsym),ncstot(0:maxsym),npstot(0:maxsym)
      dimension ksolt1(3),ksolt2(3),ksolp1(3),ksolp2(3)
      common /icd1/ispin(2)
      dimension ksgna0(maxorb),ksgnb0(maxorb)
      common/dfs/     idebt(3),ifint(3),idebp(3),ifinp(3)
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      common/dimis/ iadris,iadristp,maxsps
      common/naadi/naadim
      dimension aa(naa),coef(naadim,ind256)
      character*1 coef
      dimension iadrsp1(maxsps),iadrsp2(maxsps),isgns(maxsps)
      dimension ltf(naa),lpf(naa),kadrtp1(idaa1),kadrtp2(idaa1)
      icc(i)=(i-1)*i/2
      if(yww)write(75,*)'kt1',(kt1(k),k=1,nbt1),'$'
      if(yww)call scril
      a=aa(1)
      maxloop=1000
      allocate(nbaa(maxloop))
c
c     boucle sur le nombre de trous
c
      do 10 kkt1=1,nbt1
      nt1=kt1(kkt1)
c      do 10 nt1=mint1,maxt1
      if(nt1.lt.nt10) goto 10
      np1=nt1-nc1+nelac
      if(np1.lt.np10) goto 10
      nta=nt1-nt10
      nt2=nta+nt20
      npa=np1-np10
      np2=npa+np20
      if(nt2.lt.nt20) goto 10
      if(np2.lt.np20) goto 10
      if(.not.yscmrs) then
         if(nt2.lt.mint2) goto 10
         if(nt2.gt.maxt2) goto 10
      endif
      if(yww) then
         write(75,*)'/////////////////nt1,nt2,np1,np2,nta,npa',
     *   nt1,nt2,np1,np2,nta,npa,'$'
         call scril
      endif
 
c
c     boucles sur les isol
c
      call cd05s(nt10,nt20,nt1,nt2,nbsolt
     *,ksolt1,ksolt2,it10,it20,yspinalttp,
     *ninac)
c     print*,'ip10,ip20',ip10,ip20
      call cd05s(np10,np20,np1,np2,nbsolp
     *,ksolp1,ksolp2,ip10,ip20,yspinalttp,
     *nvirt)
      if(yscmrs.and.nt2.gt.2) then
         do k=1,nbsolt
            ksolt2(k)=1
         enddo
      endif
      if(yscmrs.and.np2.gt.2) then
         do k=1,nbsolp
            ksolp2(k)=1
         enddo
      endif
      if(yww) then
         write(6,*)'nbsolt,nbsolp',nbsolt,nbsolp
      endif
      do 20 ii=1,nbsolt
      isolt1=ksolt1(ii)
c      if(yscmrs.and.ii.gt.1.and.isolt1.eq.ksolt1(ii-1)) goto 20
      isolt2=ksolt2(ii)
      do 30 jj=1,nbsolp
      isolp1=ksolp1(jj)
c      if(yscmrs.and.jj.gt.1.and.isolp1.eq.ksolp1(jj-1)) goto 30
      isolp2=ksolp2(jj)
      isol1=isolt1+isolp1+isolc1
      isol2=isolt2+isolp2+isolc2
c
c     boucles sur les symetries
c
      call cd06s(minst1,maxst1,nt1,nt10,ist10,nsym,isolt1)
      if(yww) then
         write(75,*)'??????isolt1,isolt2,isolp1,isolp2,isol1,isol2',
     *   isolt1,isolt2,isolp1,isolp2,isol1,isol2,'$'
         call scril
      endif
      do 40 ist1=minst1,maxst1
      isp1=its(is0,its(ist1,isc1))
      ista=its(ist1,ist10)
      ist2=its(ist20,ista)
      ispa=its(isp1,isp10)
      isp2=its(isp20,ispa)
      if(yww) then
         write(75,*)'ist1,isp1,ista,ist2,isp2,ispa',
     *   ist1,isp1,ista,ist2,isp2,ispa,'$'
         call scril
      endif
      if(ista.ne.1.and.nta.eq.0) goto 40
      if(ispa.ne.1.and.npa.eq.0) goto 40
c      if(yww)print*,'ist1,isolt1,niits(isolt1,ist1)',
c     *ist1,isolt1,niits(isolt1,ist1)
c      if(yww)print*,'ist2,isolt2,niits(isolt2,ist2)',
c     *ist2,isolt2,niits(isolt2,ist2)
      if(niits(isolt1,ist1).eq.0) goto 40
      if(niips(np1,isolp1,isp1).eq.0) goto 40
      if(isolt2.eq.0.and.ist2.ne.1) goto 40
      if(isolp2.eq.0.and.isp2.ne.1) goto 40
      if(.not.yscmrs) then
         if(niits(isolt2,ist2).eq.0) goto 40
         if(niips(np2,isolp2,isp2).eq.0) goto 40
         iclssm2=clssm(mixtpmrs2,niips(np2,isolp2,isp2),
     *   niits(isolt2,ist2),isolc2)
      endif
      iclssm1=clssm(mixtpmrs1,niips(np1,isolp1,isp1),
     *niits(isolt1,ist1),isolc1)
      if(yww)print*,'iclssm1,iclssm2',iclssm1,iclssm2
c
c     boucles sur les symetries du 1er T et de la 1ere P ajoutes
c
      limt1=1
      if(nta.eq.2.and.isolt1.eq.2) then
         limt2=nsym
      else
         limt2=1
      endif
      limp1=1
      if(npa.eq.2.and.isolp1.eq.2) then
         limp2=nsym
      else
         limp2=1
      endif
c      if(yww) then
c         write(75,*)'limt1,limt2,limp1,limp2',limt1,limt2,limp1,limp2,'
c     &   '
c         call scril
c      endif
      do 50 isymt1=limt1,limt2
      if(nta.eq.2) then
         ist1_1=isymt1
         ist1_2=its(ista,ist1_1)
         if(ist1_2.gt.ist1_1) goto 50
         ist2_1=ist1_1
         ist2_2=ist1_2
      else
         if(nt1.eq.0) then
            ist1_1=0
            ist1_2=0
         else if(nt1.eq.1) then
            if(nta.eq.1) then
               ist1_1=ista
               ist1_2=0
            else
               ist1_1=itsym(it10(1))
               ist1_2=0
            endif
         else if(nt1.eq.2) then
            if(nta.eq.0) then
               ist1_1=itsym(it10(1))
               ist1_2=itsym(it10(2))
            else if(nta.eq.1) then
               ist1_1=min(itsym(it10(1)),ista)
               ist1_2=max(itsym(it10(1)),ista)
            endif
         endif
         if(nt2.eq.0) then
            ist2_1=0
            ist2_2=0
         else if(nt2.eq.1) then
            if(nta.eq.1) then
               ist2_1=ista
               ist2_2=0
            else
               ist2_1=itsym(it20(1))
               ist2_2=0
            endif
         else if(nt2.eq.2) then
            if(nta.eq.0) then
               ist2_1=itsym(it20(1))
               ist2_2=itsym(it20(2))
            else if(nta.eq.1) then
               ist2_1=min(itsym(it20(1)),ista)
               ist2_2=max(itsym(it20(1)),ista)
            endif
         endif
      endif
      if(yww) then
         write(75,*)'isymt1,ist1_1,ist1_2,ist2_1,ist2_2,ista'
     *   ,isymt1,ist1_1,ist1_2,ist2_1,ist2_2,ista,'$'
         call scril
      endif
      do 60 isymp1=limp1,limp2
c     symetrie des trous (individuellement)
 
c     symetrie des part (individuellement)
      if(npa.eq.2) then
         isp1_1=isymp1
         isp1_2=its(ispa,isp1_1)
         if(isp1_2.gt.isp1_1) goto 60
         isp2_1=isp1_1
         isp2_2=isp1_2
      else
         if(np1.eq.0) then
            isp1_1=0
            isp1_2=0
         else if(np1.eq.1) then
            if(npa.eq.1) then
               isp1_1=ispa
               isp1_2=0
            else
               isp1_1=itsym(ip10(1))
               isp1_2=0
            endif
         else if(np1.eq.2) then
            if(npa.eq.0) then
               isp1_1=itsym(ip10(1))
               isp1_2=itsym(ip10(2))
            else if(npa.eq.1) then
               isp1_1=min(itsym(ip10(1)),ispa)
               isp1_2=max(itsym(ip10(1)),ispa)
            endif
         endif
         if(np2.eq.0) then
            isp2_1=0
            isp2_2=0
         else if(np2.eq.1) then
            if(npa.eq.1) then
               isp2_1=ispa
               isp2_2=0
            else
               isp2_1=itsym(ip20(1))
               isp2_2=0
            endif
         else if(np2.eq.2) then
            if(npa.eq.0) then
               isp2_1=itsym(ip20(1))
               isp2_2=itsym(ip20(2))
            else if(npa.eq.1) then
               isp2_1=min(itsym(ip20(1)),ispa)
               isp2_2=max(itsym(ip20(1)),ispa)
            endif
         endif
      endif
      if(yww) then
         write(75,*)'isymp1,isp1_1,isp1_2,isp2_1,isp2_2,ispa'
     *   ,isymp1,isp1_1,isp1_2,isp2_1,isp2_2,ispa,'$'
         call scril
      endif
 
c
c     calcul de mt (voir adrdet)
c
      mt1=1
      if(nt1.eq.1)then
         mt1=nts(ist1)
      else if(nt1.eq.2)then
         if(isolt1.eq.0) then
            mt1=ninac
         else
            mt1=0
            if(ist1_1.eq.ist1_2) then
c               mt1=icc(nts(ist1_1))
               do k=1,nsym
                  mt1=mt1+icc(nts(k))
               enddo
            else
c               mt1=nts(ist1_1)*nts(ist1_2)
               do k=1,nsym
                  l=its(k,ist1)
                  if(k.gt.l)mt1=mt1+nts(k)*nts(l)
               enddo
            endif
         endif
      endif
      if(.not.yscmrs) then
         mt2=1
         if(nt2.eq.1)then
            mt2=nts(ist2)
         else if(nt2.eq.2)then
            if(isolt2.eq.0) then
               mt2=ninac
            else
               mt2=0
               if(ist2_1.eq.ist2_2) then
c                  mt2=icc(nts(ist2_1))
                  do k=1,nsym
                     mt2=mt2+icc(nts(k))
                  enddo
               else
c                  mt2=nts(ist2_1)*nts(ist2_2)
                  do k=1,nsym
                     l=its(k,ist2)
                     if(k.gt.l)mt2=mt2+nts(k)*nts(l)
                  enddo
               endif
            endif
         endif
      endif
      if(yww)print*,'mt1,mt2',mt1,mt2
c
c     si on ajoute un electron variable en T ou P la ou il y en a deja
c     un, il faut distinguer si on l'ajoute a droite ou a gauche
c     iapret=1 : il est ajoute a gauche, iapret=2 : ajoute a droite,
c     napret : borne de variation de iapret
c
c     determinant 1
c
      if(nta.eq.1.and.nt10.eq.1.and.isolt1.eq.2.and.ist1.eq.1
     *.and.isolt2.ne.0) then
         napret1=2
      else
         napret1=1
      endif
c      if(yww)print*,'napret1',napret1
      if(npa.eq.1.and.np10.eq.1.and.isolp1.eq.2.and.isp1.eq.1
     *.and.isolp2.ne.0) then
         naprep1=2
      else
         naprep1=1
      endif
c      if(yww)print*,'naprep1',naprep1
c
c     determinant 2
c
      if(yscmrs.and.nt2.gt.2) then
         napret2=1
      else
         if(nta.eq.1.and.nt20.eq.1.and.isolt2.eq.2.and.ist2.eq.1
     *   .and.isolt1.ne.0) then
            napret2=2
         else
            napret2=1
         endif
c         if(yww)print*,'napret2',napret2
      endif
      if(yscmrs.and.np2.gt.2) then
         naprep2=1
      else
         if(npa.eq.1.and.np20.eq.1.and.isolp2.eq.2.and.isp2.eq.1
     *   .and.isolp1.ne.0) then
            naprep2=2
         else
            naprep2=1
         endif
      endif
c      if(yww)print*,'naprep2',naprep2
c
c     boucles sur les positions droite/gauche des el ajoutes
c
      do 70 iapret1=1,napret1
      do 80 iapret2=1,napret2
      do 90 iaprep1=1,naprep1
      do 100 iaprep2=1,naprep2
c==================================================
c     place pour les adresses des trous et part
c==================================================
      if(yww) then
         write(75,*)'avant cd12s napret1,napret2,naprep1,naprep2',
     *   napret1,napret2,naprep1,naprep2,'$'
         call scril
         write(75,*)'avant cd12s iapret1,iapret2,iaprep1,iaprep2',
     *   iapret1,iapret2,iaprep1,iaprep2,'$'
         call scril
      endif
      naa2=naa
      call cd12s(nbadrt,
     *ninac,nta,nt10,nt20,it10,it20
     *,ista,isolt1,isolt2,ist1_1,ist1_2,ist2_1,ist2_2
     *,yspinalttp,nts,iplt10,iplt20
     *,iapret1,iapret2,naa2,coef,ltf,ind256,norb)
      if(nbadrt.eq.0) goto 100
      nbadrt2=nbadrt
      call cd12s(nbadrp,
     *nvirt,npa,np10,np20,ip10,ip20
     *,ispa,isolp1,isolp2,isp1_1,isp1_2,isp2_1,isp2_2
     *,yspinalttp,nps,iplp10,iplp20
     *,iaprep1,iaprep2,naa2,coef,lpf,ind256,norb)
      if(yww)print*,'apres cd12s nbadrt,nbadrp',nbadrt,nbadrp
      if(nbadrp.eq.0) goto 100
      nbadrp2=nbadrp
c      if(nbadrt+nbadrp.gt.idaa1) then
c         print*,'nbadrt,nbadrp,idaa1',nbadrt,nbadrp,idaa1
c         print*,'stop provisoire'
c         print*,'augmenter iadris la ou il est en parametre'
c         print*,'idaa1,jdaa2,jdaa3,jdaa4,jdaa5,jdaa6,jdaa7'
c     *   ,idaa1,jdaa2,jdaa3,jdaa4,jdaa5,jdaa6,jdaa7
c         stop
c      endif
c==================================================
c     nombre de boucles necessaires pour prendre
c     en compte toutes les integrales
c==================================================
      nbloop=0
      ltpft=0
 
 
 
c      if(itest(46).ne.0.and.yww) then
      if(itest(46).ne.0) then
         idaa1=7
c         print*,'itest(46)',itest(46)
      endif
 
 
 1    continue
      ltpft=0
      kaa0=0
      nbloop=0
      do kaa=1,naa
         ltpf=ltf(kaa)+lpf(kaa)
         if(yww)print*,'kaa,ltf(kaa),lpf(kaa),idaa1'
     *   ,kaa,ltf(kaa),lpf(kaa),idaa1
         if(ltpf.gt.idaa1) then
            print*,'ltf(kaa),lpf(kaa),idaa1',ltf(kaa),lpf(kaa),idaa1
            print*,'stop '
            print*,'augmenter iadris la ou il est en parametre'
            stop
         endif
         ltpft=ltpft+ltpf
         if(ltpft.gt.idaa1) then
            nbloop=nbloop+1
            if(nbloop<=maxloop) nbaa(nbloop)=kaa-1-kaa0
            kaa0=kaa-1
            ltpft=ltpf
         endif
      enddo
      nbloop=nbloop+1
 
 
      if(itest(46).ne.0) then
          itest(46)=max(itest(46),nbloop)
      endif
 
 
      if(nbloop<=maxloop) nbaa(nbloop)=naa-kaa0
      if(nbloop>maxloop) then
         deallocate(nbaa)
         maxloop=nbloop
         allocate(nbaa(maxloop))
         goto 1
      endif
      if(yww.and.nbloop.ne.1)print*,'nbaa',(nbaa(k),k=1,nbloop)
c==================================================
c     boucle sur le nombre de blocs d'integrales
c==================================================
      naaf=0
      nbadrt0=nbadrt
      nbadrp0=nbadrp
      if(yww)print*,'nbloop',nbloop
      do 110 iloop=1,nbloop
      if(yww)print*,'iloop',iloop
      naad=naaf+1
      naaf=naad+nbaa(iloop)-1
      naadf=nbaa(iloop)
      if(yww.and.nbloop.ne.1)print*,'naa,naad,naaf,naadf',
     * naa,naad,naaf,naadf
c==================================================
c     adresses des trous
c==================================================
      call cd07s(norb,nbadrt0,nbadrt,kadrtp1,ltf,
     *ninac,nta,nt10,nt20,it10,it20
     *,icatts,ista,isolt1,isolt2,ist1_1,ist1_2,ist2_1,ist2_2
     *,yspinalttp,nts,iplt10,iplt20
     *,iapret1,iapret2,naa,naad,naaf,naadf,coef,ind256)
      if(yww) then
         write(75,*)'kadrt1',(kadrtp1(k),k=1,nbadrt),'$'
         call scril
         write(75,*)'ltf1',(ltf(k),k=1,naa),'$'
         call scril
      endif
      if(.not.yscmrs) then
         call cd07s(norb,nbadrt0,nbadrt,kadrtp2,ltf,
     *   ninac,nta,nt20,nt10,it20,it10
     *   ,icatts,ista,isolt2,isolt1,ist2_1,ist2_2,ist1_1,ist1_2
     *   ,yspinalttp,nts,iplt20,iplt10
     *   ,iapret2,iapret1,naa,naad,naaf,naadf,coef,ind256)
         if(yww) then
            write(75,*)'kadrt2',(kadrtp2(k),k=1,nbadrt),'$'
            call scril
            write(75,*)'ltf2',(ltf(k),k=1,naa),'$'
            call scril
         endif
      endif
c      if(nbadrt.ne.nbadrt2) then
c         print*,'nbadrt,nbadrt2',nbadrt,nbadrt2
c         stop
c      endif
c==================================================
c     adresses des particules
c==================================================
      call cd07s(norb,nbadrp0,nbadrp,kadrtp1(nbadrt+1),lpf,
     *nvirt,npa,np10,np20,ip10,ip20
     *,icatps,ispa,isolp1,isolp2,isp1_1,isp1_2,isp2_1,isp2_2
     *,yspinalttp,nps,iplp10,iplp20
     *,iaprep1,iaprep2,naa,naad,naaf,naadf,coef,ind256)
      if(yww) then
         write(75,*)'kadrp1',(kadrtp1(k+nbadrt)
     *   ,k=1,nbadrp),'$'
         call scril
         write(75,*)'lpf1',(lpf(k),k=1,naa),'$'
         call scril
      endif
      if(.not.yscmrs) then
         call cd07s(norb,nbadrp0,nbadrp,kadrtp2(nbadrt+1),lpf,
     *   nvirt,npa,np20,np10,ip20,ip10
     *   ,icatps,ispa,isolp2,isolp1,isp2_1,isp2_2,isp1_1,isp1_2
     *   ,yspinalttp,nps,iplp20,iplp10
     *   ,iaprep2,iaprep1,naa,naad,naaf,naadf,coef,ind256)
         if(yww) then
            call scril
            write(75,*)'kadrp2',(kadrtp2(k+nbadrt)
     *      ,k=1,nbadrp),'$'
            call scril
            write(75,*)'lpf2',(lpf(k),k=1,naa),'$'
            call scril
         endif
      endif
c      if(nbadrp.ne.nbadrp2) then
c         print*,'nbadrp,nbadrp2',nbadrp,nbadrp2
c         stop
c      endif
c==================================================
c     calcul de ifix et ivar
c     ifix : +/-1 spin des el fixes
c     ivar : place des electrons variables parmi les el celibataires
c
c==================================================
      if(yscmrs.and.nt2.gt.2) then
         minisolt=isolt1
      else
         minisolt=min(isolt1,isolt2)
      endif
      if(yscmrs.and.np2.gt.2) then
         minisolp=isolp1
      else
         minisolp=min(isolp1,isolp2)
      endif
c      if(yww) then
c         write(75,*)'det 2 iapret1,iaprep1'
c     *   ,iapret1,iaprep1,'$'
c         call scril
c      endif
      call cd09s
     *(in,jn,kn,ln,nta,nt10
     *,kfix1,kfixc1,ifix1(1,iapret1,iaprep1),ifixc1
     *,ispin,isolt1,isolp1,npa,np10,isolt2,isolp2,it10,ip10)
      if(yww) then
         write(75,*)'ifix1'
     *   ,(ifix1(k,iapret1,iaprep1),k=1,kfix1),'$'
         call scril
      endif
      call cd08s(nta,kvarc,kvar
     *,ivarc1,ivar1(1,iapret1,iaprep1),nt10
     *,isolt1,iapret1,iaprep1,npa,np10,isolp1,isolc1
     *,minisolt,minisolp,ist10,ista,isp10,ispa)
      if(yww) then
         write(75,*)'ivar1'
     *   ,(ivar1(k,iapret1,iaprep1),k=1,kvar),'$'
         call scril
      endif
c      if(yww) then
c         write(75,*)'det 2 iapret2,iaprep2'
c     *   ,iapret2,iaprep2,'$'
c         call scril
c      endif
      if(.not.yscmrs.or.(nt2.le.2.and.np2.le.2)) then
         call cd09s
     *   (kn,ln,in,jn,nta,nt20
     *   ,kfix2,kfixc2,ifix2(1,iapret2,iaprep2),ifixc2
     *   ,ispin,isolt2,isolp2,npa,np20,isolt1,isolp1,it20,ip20)
         if(yww) then
            write(75,*)'ifix2'
     *      ,(ifix2(k,iapret2,iaprep2),k=1,kfix2),'$'
            call scril
         endif
         call cd08s(nta,kvarc,kvar
     *   ,ivarc2,ivar2(1,iapret2,iaprep2),nt20
     *   ,isolt2,iapret2,iaprep2,npa,np20,isolp2,isolc2
     *   ,minisolt,minisolp,ist20,ista,isp20,ispa)
         if(yww) then
            write(75,*)'ivar2'
     *      ,(ivar2(k,iapret2,iaprep2),k=1,kvar),'$'
            call scril
         endif
      endif
c         enddo
c      enddo
c================================================================
c     calcul du nombre d'electrons variables alpha sur chaque det
c================================================================
 
c     spin total des electrons fixes
      ispf=0
      do k=1,kfix1
         ispf=ispf+ifix1(k,iapret1,iaprep1)
      enddo
c     spin total des electrons variables
      ispv=ms2-ispf
      if(iabs(ispv).gt.kvar) goto 100
      nbela=(ispv+kvar)/2
c     on recommence pour le det 2 : on doit trouver la meme chose
c     spin total des electrons fixes
      if(.not.yscmrs) then
         ispf=0
         do k=1,kfix2
            ispf=ispf+ifix2(k,iapret2,iaprep2)
         enddo
c        spin total des electrons variables
         ispv=ms2-ispf
         if(iabs(ispv).gt.kvar) goto 100
         nbela2=(ispv+kvar)/2
         if(yww)print*,'nbela',nbela
         if(nbela.ne.nbela2) then
            print*,'nbela,nbela2',nbela,nbela2
            print*,'isol1,isol2',isol1,isol2
            stop
         endif
      endif
      call cd11s
     *(iapret1,iapret2,iaprep1,iaprep2,
     *kvar,ivar1(1,iapret1,iaprep1)
     *,ivar2(1,iapret2,iaprep2)
     *,nbela,isol1,isol2
     *,ifix1(1,iapret1,iaprep1),ifix2(1,iapret2,iaprep2)
     *,iadrsp1,iadrsp2,nbadrsp,mh1,mh2,kfix1,kfix2
     *,isgncfa,isgncfb,ksgna0,ksgnb0,iocc1,isgns,isolt1
     *,isolp1,isolt2,isolp2,nta,npa,nt10,nt20
     *,np10,np20,it10,ip10,it20,ip20,isgni0,ista,ispa,yscmrs)
      if(yww) then
         write(75,*)'iadrsp1',(iadrsp1(k),k=1,nbadrsp),'$'
         call scril
         write(75,*)'iadrsp2',(iadrsp2(k),k=1,nbadrsp),'$'
         call scril
         print*,'nbadrt,nbadrsp',nbadrt,nbadrsp
      endif
c
c           bornes de variation des indices de l'integrale
c
      if(yscmrs) then
c               print*,'avant sc10s iadri1,a',iadri1,a
c               print*,'avant sc10s esp1(73)',esp1(73)
         call sc10s(naa,
     *   kadrtp1,kadrtp1(nbadrt+1)
     *   ,iadrsp1
     *   ,a,esp1,aa)
c               print*,'apres sc10s esp1(73)',esp1(73)
      else
         call cd10s(naa,naad,naaf,naadf,ltf,lpf,
     *   kadrtp1,kadrtp1(nbadrt+1)
     *   ,kadrtp2,kadrtp2(nbadrt+1)
     *   ,iadrsp1,iadrsp2,isgns,a,esp1,esp1(iadri1),aa)
      endif
 
 
 
 110  continue
 100  continue
 90   continue
 80   continue
 70   continue
 60   continue
 50   continue
 40   continue
 30   continue
 20   continue
 10   continue
      deallocate(nbaa)
      return
      end
       subroutine cd10s(naa,naad,naaf,naadf
     *,ltf,lpf,kadrt1,kadrp1,kadrt2,kadrp2,
     *iadrsp1,iadrsp2,isgns,a,b,ab
     *,aa)
c
c--------------------------------------------------------
c     boucle interne
c--------------------------------------------------------
c
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |      ab       |
c
      use mod_ndimcs0
      parameter(maxda3=300)
      include 'maxorb.prm'
      include 'cds.inc'
      common/opt/ihab,calcul
      common/dim/iadri ; integer(8) iadri
      dimension b(iadri),ab(iadri)
      character*3 calcul
      common/cd02w/yww
      common/dfs/     idebt(3),ifint(3),idebp(3),ifinp(3)
      dimension kadrt1(nbadrt)
      dimension kadrt2(nbadrt)
      dimension kadrp1(nbadrp)
      dimension kadrp2(nbadrp)
      dimension iadrsp1(maxsps),iadrsp2(maxsps),isgns(maxsps)
      common/dimis/ iadris,iadristp,maxsps
      dimension aa(naa)
      dimension ltf(naa),lpf(naa)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      iadr10=nim1+iclssm1
      iadr20=nim2+iclssm2
c      if(yww) then
c         write(75,*)'cd10s entree boucle int mt1,mt2,mh1,mh2'
c     *   ,mt1,mt2,mh1,mh2,'$'
c         call scril
c         write(75,*)' nim1,nim2,iclssm1,iclssm2'
c     *   ,nim1,nim2,iclssm1,iclssm2,'$'
c         call scril
c         write(75,*)'boucle interne nbadrt,nbadrp,nbadrsp',
c     *   nbadrt,nbadrp,nbadrsp,'$'
c         call scril
c      endif
      !print*,'entree cds10'
      mht1=mh1*mt1
      mht2=mh2*mt2
      mm1=iadr10-mh1-mh1*mt1
      mm2=iadr20-mh2-mh2*mt2
      if(calcul.eq.'M') then
         if(naa.eq.1) then
            do kp=1,nbadrp
               iadrp1=mm1+mht1*kadrp1(kp)
               iadrp2=mm2+mht2*kadrp2(kp)
               do kt=1,nbadrt
                  iadrtp1=mh1*kadrt1(kt)+iadrp1
                  iadrtp2=mh2*kadrt2(kt)+iadrp2
                  do ksp=1,nbadrsp
                     iadr1=iadrtp1+iadrsp1(ksp)
                     iadr2=iadrtp2+iadrsp2(ksp)
                     call stover(iadr1,iadr2,a*isgns(ksp))
                     if(yga2) call stoga2(iadr1*isgns(ksp),iadr2,
     *               aa(1),ab)
c                   print*,'apres stoga2 aa(1)',aa(1)
c                     if(yww) then
c                        write(75,*)'kt,kp,adrt,adrp'
c     *                  ,kt,kp,kadrt1(kt),kadrt
c     &                  2(kt),kadrp1(kp),kadrp2(kp),'$'
c                        call scril
c                     endif
                  enddo
               enddo
            enddo
            return
         endif
         kpf=0
         kk=0
         if(yww)print*,'naad,naaf',naad,naaf
         do kaa=naad,naaf
            kk=kk+1
            kpd=kpf+1
            kpf=lpf(kk)
            if(kk.eq.1) then
               ktd=1
            else
               ktd=ltf(kk-1)+1
            endif
            ktf=ltf(kk)
            if(yww)print*,'ktd,ktf,kpd,kpf',ktd,ktf,kpd,kpf
            do kp=kpd,kpf
               iadrp1=mm1+mht1*kadrp1(kp)
               iadrp2=mm2+mht2*kadrp2(kp)
               do kt=ktd,ktf
c                  if(yww)print*,'ktd,ktf,kt',
c     *            ktd,ktf,kt,kadrt1(kt),kadrt2(kt)
c                  if(yww)call flush(6)
                  iadrtp1=mh1*kadrt1(kt)+iadrp1
                  iadrtp2=mh2*kadrt2(kt)+iadrp2
                  do ksp=1,nbadrsp
                     iadr1=iadrtp1+iadrsp1(ksp)
                     iadr2=iadrtp2+iadrsp2(ksp)
                     call stover(iadr1,iadr2,aa(kaa)*isgns(ksp))
                     if(yga2)
     *               call stoga2(iadr1*isgns(ksp),iadr2,aa(kaa),ab)
c                   print*,'apres stoga2 kaa,aa(kaa)', kaa,aa(kaa)
c                     if(yww) then
c                        write(75,*)'kt,kp,adrt,adrp'
c     *                  ,kt,kp,kadrt1(kt),kadrt
c     &                  2(kt),kadrp1(kp),kadrp2(kp),'$'
c                        call scril
c                     endif
                  enddo
               enddo
            enddo
         enddo
      else
         if(itest(12).eq.0) then
            if(naa.eq.1) then
               do kp=1,nbadrp
                  iadrp1=mm1+mht1*kadrp1(kp)
                  iadrp2=mm2+mht2*kadrp2(kp)
                  do kt=1,nbadrt
                     iadrtp1=mh1*kadrt1(kt)+iadrp1
                     iadrtp2=mh2*kadrt2(kt)+iadrp2
                     do ksp=1,nbadrsp
                        a1=a*isgns(ksp)
                        iadr1=iadrtp1+iadrsp1(ksp)
                        iadr2=iadrtp2+iadrsp2(ksp)
                        ab(iadr1)=ab(iadr1)+a1*b(iadr2)
                        ab(iadr2)=ab(iadr2)+a1*b(iadr1)
c            if(yww.or.iadr1.eq.22)write(6,*)'1AB22',iadr2,a1,b(iadr2),
c     *      a1*b(iadr2),'$'
c            if(iadr2.eq.22)write(6,*)'2AB22',iadr1,a1,b(iadr1),
c     *      a1*b(iadr1),'$'
c            if(yww.or.iadr1.eq.22.or.iadr2.eq.22) call scril
                     enddo
                  enddo
               enddo
               return
            endif
            kpf=0
            kk=0
            do kaa=naad,naaf
               kk=kk+1
               a2=aa(kaa)
               kpd=kpf+1
               kpf=lpf(kk)
               if(kk.eq.1) then
                  ktd=1
               else
                  ktd=ltf(kk-1)+1
               endif
               ktf=ltf(kk)
               do kp=kpd,kpf
                  iadrp1=mm1+mht1*kadrp1(kp)
                  iadrp2=mm2+mht2*kadrp2(kp)
                  do kt=ktd,ktf
c                     if(yww)print*,'ktd,ktf,kt',
c     *               ktd,ktf,kt,kadrt1(kt),kadrt2(kt)
c                     if(yww)call flush(6)
                     iadrtp1=mh1*kadrt1(kt)+iadrp1
                     iadrtp2=mh2*kadrt2(kt)+iadrp2
                     do ksp=1,nbadrsp
                        a1=a2*isgns(ksp)
                        iadr1=iadrtp1+iadrsp1(ksp)
                        iadr2=iadrtp2+iadrsp2(ksp)
                        ab(iadr1)=ab(iadr1)+a1*b(iadr2)
                        ab(iadr2)=ab(iadr2)+a1*b(iadr1)
c            if(yww.or.iadr1.eq.22)write(6,*)'1AB22',iadr2,a1,b(iadr2),
c     *      a1*b(iadr2),'$'
c            if(yww.or.iadr2.eq.22)write(6,*)'2AB22',iadr1,a1,b(iadr1),
c     *      a1*b(iadr1),'$'
c            if(yww.or.iadr1.eq.22.or.iadr2.eq.22) call scril
                     enddo
                  enddo
               enddo
            enddo
         else
            if(naa.eq.1) then
               do kp=1,nbadrp
                  iadrp1=mm1+mht1*kadrp1(kp)
                  iadrp2=mm2+mht2*kadrp2(kp)
                  do kt=1,nbadrt
                     iadrtp1=mh1*kadrt1(kt)+iadrp1
                     iadrtp2=mh2*kadrt2(kt)+iadrp2
                     do ksp=1,nbadrsp
                        a1=a*isgns(ksp)
                        iadr1=iadrtp1+iadrsp1(ksp)
                        iadr2=iadrtp2+iadrsp2(ksp)
                        ab(iadr1)=ab(iadr1)+a1*b(iadr2)
                        ab(iadr2)=ab(iadr2)+a1*b(iadr1)
c           if(yww.or.iadr1.eq.1336)write(6,*)'1AB22',iadr2,a1,b(iadr2),
c     *     a1*b(iadr2),'$'
c           if(yww.or.iadr2.eq.1336)write(6,*)'2AB22',iadr1,a1,b(iadr1),
c     *     a1*b(iadr1),'$'
                        do kk=1,icalc1-1
                           incr=kk*maxl0
                           jadr1=iadr1+incr
                           jadr2=iadr2+incr
                           ab(jadr1)=ab(jadr1)+a1*b(jadr2)
                           ab(jadr2)=ab(jadr2)+a1*b(jadr1)
c           if(yww.or.jadr1.eq.1336)write(6,*)'3AB22',jadr2,a1,b(jadr2),
c     *     a1*b(jadr2),'$'
c           if(yww.or.jadr2.eq.1336)write(6,*)'4AB22',jadr1,a1,b(jadr1),
c     *     a1*b(jadr1),'$'
c            if(yww.or.jadr1.eq.1336.or.jadr2.eq.22) call scril
                        enddo
                     enddo
                  enddo
               enddo
               return
            endif
            kpf=0
            kka=0
            !print*,'naad,naaf',naad,naaf
            do kaa=naad,naaf
               kka=kka+1
               a2=aa(kaa)
               kpd=kpf+1
               kpf=lpf(kka)
               if(kka.eq.1) then
                  ktd=1
               else
                  ktd=ltf(kka-1)+1
               endif
               ktf=ltf(kka)
               do kp=kpd,kpf
                  iadrp1=mm1+mht1*kadrp1(kp)
                  iadrp2=mm2+mht2*kadrp2(kp)
                  do kt=ktd,ktf
c                     if(yww)print*,'ktd,ktf,kt',
c     *               ktd,ktf,kt,kadrt1(kt),kadrt2(kt)
c                     if(yww)call flush(6)
                     iadrtp1=mh1*kadrt1(kt)+iadrp1
                     iadrtp2=mh2*kadrt2(kt)+iadrp2
                     do ksp=1,nbadrsp
                        a1=a2*isgns(ksp)
                        iadr1=iadrtp1+iadrsp1(ksp)
                        iadr2=iadrtp2+iadrsp2(ksp)
                        ab(iadr1)=ab(iadr1)+a1*b(iadr2)
                        ab(iadr2)=ab(iadr2)+a1*b(iadr1)
c            if(iadr1.eq.1336)write(6,2000)'9AB22',iadr2,a1,b(iadr2),
c     *      a1*b(iadr2),ab(iadr1),kaa
c            if(iadr2.eq.1336)write(6,2000)'0AB22',iadr1,a1,b(iadr1),
c     *      a1*b(iadr1),ab(iadr2),kaa
                        do kk=1,icalc1-1
                           incr=kk*maxl0
                           jadr1=iadr1+incr
                           jadr2=iadr2+incr
                           ab(jadr1)=ab(jadr1)+a1*b(jadr2)
                           ab(jadr2)=ab(jadr2)+a1*b(jadr1)
c            if(jadr1.eq.1336)write(6,2000)'AAB22',jadr2,a1,b(jadr2),
c     *      a1*b(jadr2),kaa
c            if(jadr2.eq.1336)write(6,2000)'BAB22',jadr1,a1,b(jadr1),
c     *      a1*b(jadr1),kaa
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         endif
 2000 format(a8,i6,4f12.8,i6)
      endif
      return
      end
       subroutine sc10s(naa,kadrt1,kadrp1
     *,iadrsp1,dum,hii
     *,aa)
c
c--------------------------------------------------------
c      SC2
c--------------------------------------------------------
c
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |               |      hii      |
c
 
      use mod_ndimcs0
      include 'maxorb.prm'
      include 'cds.inc'
      common/opt/ihab,calcul
      common/dim/iadri ; integer(8) iadri
      dimension hii(iadri)
      character*3 calcul
      common/cd02w/yww
      common/dfs/     idebt(3),ifint(3),idebp(3),ifinp(3)
      dimension kadrt1(nbadrt)
      dimension kadrp1(nbadrp)
      common/dimis/ iadris,iadristp,maxsps
      dimension aa(naa)
      dimension iadrsp1(maxsps)
      iadr10=nim1+iclssm1
      iadr20=nim2+iclssm2
      if(yww) then
         write(75,*)'entree boucle int mt1,mt2,mh1,mh2'
     *   ,mt1,mt2,mh1,mh2,'$'
         call scril
         write(75,*)' nim1,nim2,iclssm1,iclssm2'
     *   ,nim1,nim2,iclssm1,iclssm2,'$'
         call scril
         write(75,*)'boucle interne nbadrt,nbadrp,nbadrsp',
     *   nbadrt,nbadrp,nbadrsp,'$'
         call scril
      endif
      mht1=mh1*mt1
      mm1=iadr10-mh1-mh1*mt1
      do kp=1,nbadrp
         iadrp1=mm1+mht1*kadrp1(kp)
         do kt=1,nbadrt
            iadrtp1=mh1*kadrt1(kt)+iadrp1
            do ksp=1,nbadrsp
               iadr1=iadrtp1+iadrsp1(ksp)
c               print*,'sc01s',iadrtp1,iadrsp1(ksp),ksp,mh1,iadrp1,
c     *         kadrt1(kt),kt,mm1,mht1,kadrp1(kp)
c               if(iadr1.eq.1)
c               write(6,'('' iadr1,dum,hii,hii+dum'',i5,3f12.8)')
c     *         iadr1,dum,hii(iadr1),hii(iadr1)+dum
               hii(iadr1)=hii(iadr1)+dum
               if(yww)write(75,*)'int',mht1,mm1,kadrp1(kp),
     *         mh1,kadrt1(kt),iadrsp1(ksp),'$'
               if(yww)call scril
               if(yww) write(75,*)'interne',iadr1,dum,'$'
               if(yww)call scril
            enddo
         enddo
      enddo
      return
      end
 
 
 
       subroutine cd09s
     *(in,jn,kn,ln,nta,nt10,kfix1,kfixc1,ifix1,ifixc1
     *,ispin,isolt1,isolp1,npa,np10,isolt2,isolp2,it10,ip10)
c
c--------------------------------------------------------
c     place des electrons fixes parmi les electrons celibataires
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/cd02w/yww
      dimension ifixc1(4),ifix1(4),ispin(2),it10(2),ip10(2)
c      print*,'entree cd09s'
      if(nta.eq.0) then
         if(nt10.eq.0) then
            kfix1=kfixc1
            do k=1,kfixc1
               ifix1(k)=ifixc1(k)
            enddo
         else if (nt10.eq.1) then
            kfix1=kfixc1+1
            do k=1,kfixc1
               ifix1(k+1)=ifixc1(k)
            enddo
            if(itype(kn).eq.1) then
               ifix1(1)=-ispin(1)
            else if (itype(ln).eq.1) then
               ifix1(1)=-ispin(2)
            endif
         else if (nt10.eq.2) then
            if(isolt1.ne.0) then
               kfix1=kfixc1+2
               do k=1,kfixc1
                  ifix1(k+2)=ifixc1(k)
               enddo
               if(it10(1).lt.it10(2).or.ispin(1).eq.ispin(2)) then
                  ifix1(1)=-ispin(1)
                  ifix1(2)=-ispin(2)
               else
                  ifix1(1)=ispin(1)
                  ifix1(2)=ispin(2)
               endif
            else
               kfix1=kfixc1
               do k=1,kfixc1
                  ifix1(k)=ifixc1(k)
               enddo
            endif
         endif
      else if(nta.eq.1) then
         if(nt10.eq.0) then
            if(isolt2.eq.0) then
               kfix1=kfixc1+1
               do k=1,kfixc1
                  ifix1(k+1)=ifixc1(k)
               enddo
               if(itype(in).eq.1) then
                  ifix1(1)=ispin(1)
               else if (itype(jn).eq.1) then
                  ifix1(1)=ispin(2)
               endif
            else
               kfix1=kfixc1
               do k=1,kfixc1
                  ifix1(k)=ifixc1(k)
               enddo
            endif
         else if(nt10.eq.1) then
            if(isolt1.eq.0) then
               kfix1=kfixc1
               do k=1,kfixc1
                  ifix1(k)=ifixc1(k)
               enddo
            else if(isolt1.eq.2) then
               if(isolt2.eq.0) then
                  kfix1=kfixc1+2
                  do k=1,kfixc1
                     ifix1(k+2)=ifixc1(k)
                  enddo
                  if(itype(in).eq.1) then
                     ind1=in
                     ispin1=ispin(1)
                  else
                     ind1=jn
                     ispin1=ispin(2)
                  endif
                  if(itype(kn).eq.1) then
                     ind2=kn
                     ispin2=ispin(1)
                  else
                     ind2=ln
                     ispin2=ispin(2)
                  endif
c                 ind1 est l'indice qui vient directement sur le det
c                 ind2 est celui qui vient sur l'autre determinant
c                 et qui induit donc un spin oppose sur le det
c                 qu'on regarde
                  if(ind1.lt.ind2) then
                     ifix1(1)=ispin1
                     ifix1(2)=-ispin2
                  else
                     ifix1(1)=-ispin2
                     ifix1(2)=ispin1
                  endif
               else
                  kfix1=kfixc1+1
                  do k=1,kfixc1
                     ifix1(k+1)=ifixc1(k)
                  enddo
                  if(itype(kn).eq.1) then
                     ifix1(1)=-ispin(1)
                  else
                     ifix1(1)=-ispin(2)
                  endif
               endif
            endif
         endif
      else if(nta.eq.2) then
         kfix1=kfixc1
         do k=1,kfixc1
            ifix1(k)=ifixc1(k)
         enddo
      endif
      if(npa.eq.0) then
         if(np10.eq.1) then
            kfix1=kfix1+1
            if(itype(in).eq.3) then
               ifix1(kfix1)=ispin(1)
            else if (itype(jn).eq.3) then
               ifix1(kfix1)=ispin(2)
            endif
         else if (np10.eq.2) then
            if(isolp1.ne.0) then
               kfix1=kfix1+2
               if(ip10(1).lt.ip10(2).or.ispin(1).eq.ispin(2)) then
                  ifix1(kfix1-1)=ispin(1)
                  ifix1(kfix1)=ispin(2)
               else
                  ifix1(kfix1-1)=-ispin(1)
                  ifix1(kfix1)=-ispin(2)
               endif
            endif
         endif
      else if(npa.eq.1) then
         if(np10.eq.0) then
            if(isolp2.eq.0) then
               kfix1=kfix1+1
               if(itype(kn).eq.3) then
                  ifix1(kfix1)=-ispin(1)
               else if (itype(ln).eq.3) then
                  ifix1(kfix1)=-ispin(2)
               endif
            endif
         else if(np10.eq.1) then
            if(isolp1.ne.0) then
               if(isolp2.eq.0) then
                  kfix1=kfix1+2
                  if(itype(in).eq.3) then
                     ind1=in
                     ispin1=ispin(1)
                  else
                     ind1=jn
                     ispin1=ispin(2)
                  endif
                  if(itype(kn).eq.3) then
                     ind2=kn
                     ispin2=ispin(1)
                  else
                     ind2=ln
                     ispin2=ispin(2)
                  endif
                  if(ind1.lt.ind2) then
                     ifix1(kfix1-1)=ispin1
                     ifix1(kfix1)=-ispin2
                  else
                     ifix1(kfix1-1)=-ispin2
                     ifix1(kfix1)=ispin1
                  endif
               else
                  kfix1=kfix1+1
                  if(itype(in).eq.3) then
                     ifix1(kfix1)=ispin(1)
                  else
                     ifix1(kfix1)=ispin(2)
                  endif
               endif
            endif
         endif
      endif
      return
      end
 
       subroutine cd08s(nta,kvarc,kvar,ivarc1,ivar1,nt10
     *,isolt1,iapret,iaprep,npa,np10,isolp1,isolc1
     *,minisolt,minisolp,ist10,ista,isp10,ispa)
c
c--------------------------------------------------------
c     place des electrons variables parmi les electrons celibataires
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/cd02w/yww
      dimension ivarc1(maxorbcas)
      dimension ivar1(maxorbcas)
      if(nta.eq.0) then
         kvar=kvarc
         do k=1,kvarc
            ivar1(k)=ivarc1(k)+isolt1
         enddo
      else if (nta.eq.1) then
         if(minisolt.ne.0) then
            kvar=kvarc+1
            if(nt10.eq.0) then
               do k=1,kvarc
                  ivar1(k+1)=ivarc1(k)+1
               enddo
               ivar1(1)=1
            else if(nt10.eq.1) then
               kvar=kvarc+1
               do k=1,kvarc
                  ivar1(k+1)=ivarc1(k)+2
               enddo
               if(yww)print*,'iapret2',iapret,ist10,ista
               if(ist10.eq.ista) then
                  ivar1(1)=iapret
               else
                  if(ista.gt.ist10) then
                     ivar1(1)=2
                  else
                     ivar1(1)=1
                  endif
               endif
            endif
         else
            kvar=kvarc
            do k=1,kvarc
               ivar1(k)=ivarc1(k)+isolt1
            enddo
         endif
      else if (nta.eq.2) then
         kvar=kvarc+minisolt
         do k=1,kvarc
            ivar1(k+minisolt)=ivarc1(k)+isolt1
         enddo
         if(minisolt.eq.2) then
            ivar1(1)=1
            ivar1(2)=2
         endif
      endif
      if(npa.eq.1) then
         if(minisolp.ne.0) then
            kvar=kvar+1
            if(np10.eq.0) then
               if(yww)print*,'coucoua',isolt1,isolc1,kvar
               ivar1(kvar)=isolt1+isolc1+1
            else
               if(isp10.eq.ispa) then
                  ivar1(kvar)=isolt1+isolc1+iaprep
               else
                  if(ispa.gt.isp10) then
                     ivar1(kvar)=isolt1+isolc1+2
                  else
                     ivar1(kvar)=isolt1+isolc1+1
                  endif
               endif
            endif
         endif
      else if (npa.eq.2) then
         if(isolp1.eq.2) then
            kvar=kvar+2
            isoltc=isolt1+isolc1
            ivar1(kvar-1)=isoltc+1
            ivar1(kvar)=isoltc+2
         endif
      endif
      return
      end
       subroutine cd11s
     *(iapret1,iapret2,iaprep1,iaprep2,
     *kvar,ivar1,ivar2,nbela,isol1,isol2,ifix1,ifix2
     *,iadrsp1,iadrsp2,nbadrsp,mh1,mh2,kfix1,kfix2,isgncfa,isgncfb
     *,ksgna0,ksgnb0,iocc1,isgns,isolt1,isolp1,isolt2,isolp2
     *,nta,npa,nt10,nt20
     *,np10,np20,it10,ip10,it20,ip20,isgni0,ista,ispa,yscmrs)
c
c--------------------------------------------------------
c     calcul des adresses des combinaisons de spin
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common /combs/  C(0:maxorbcas+4,-1:maxorbcas+4)
      integer c
      common/cd02w/yww
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      dimension yal1(maxorbcas+4),yal2(maxorbcas+4)
      dimension ial1(maxorbcas+4),ial2(maxorbcas+4)
      dimension ial(maxorbcas+4)
      dimension iadrsp1(184756),iadrsp2(184756),isgns(184756)
      dimension ifix1(4),ifix2(4),iocc1(maxorbcas)
      dimension ivar1(maxorbcas+4),ivar2(maxorbcas+4)
      dimension ksgna0(maxorb),ksgnb0(maxorb)
      dimension it10(2),it20(2),ip10(2),ip20(2)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
 
 
 
c
c     generation des distributions de spin
c
c     nbela=nb d'el + parmi les el variables
C      nbela=(kvar+nbela_b)/2
      nbelatot1=(isol1+ms2)/2
      nbelatot2=(isol2+ms2)/2
      nbelb=kvar-nbela
      mh1=c(isol1,nbelatot1)
      mh2=c(isol2,nbelatot2)
      if(yww) then
         write(75,*)'cd11s  kvar,nbela,nbelb,nbelatot1,nbelatot2,mh1,mh2
     &   '
     *   ,kvar,nbela,nbelb,nbelatot1,nbelatot2,mh1,mh2,'$'
         call scril
      endif
c     determinant1
      do k=1,isol1
         yal1(k)=.true.
      enddo
      do k=1,kvar
         yal1(ivar1(k))=.false.
      enddo
      if(yww) then
         print*,'ivar1(1)',ivar1(1)
         write(6,'(a10,40l1)')'1 yal1  ',(yal1(k),k=1,isol1)
      endif
      kk=0
      do k=1,isol1
         if(yal1(k)) then
            kk=kk+1
            if(ifix1(kk).eq.-1) yal1(k)=.false.
         endif
      enddo
      if(yww) then
         write(6,'(a10,40l1)')'2 yal1  ',(yal1(k),k=1,isol1)
      endif
c     determinant2
      if(yscmrs) goto 1
      do k=1,isol2
         yal2(k)=.true.
      enddo
      do k=1,kvar
         yal2(ivar2(k))=.false.
      enddo
      if(yww) then
         write(6,'(a10,40l1)')'1 yal2  ',(yal2(k),k=1,isol2)
      endif
      kk=0
      do k=1,isol2
         if(yal2(k)) then
            kk=kk+1
            if(ifix2(kk).eq.-1) yal2(k)=.false.
         endif
      enddo
      if(yww) then
         write(6,'(a10,40l1)')'2 yal2  ',(yal2(k),k=1,isol2)
      endif
 1    continue
      nbadrsp=0
      call combi0(ial,kvar,nbela,iret)
      goto 300
 25   call combi2(ial,kvar,nbela,iret)
 300  continue
c
c     ial1 : place des alpha dans les celibataires (det 1)
c
      do k=1,nbela
         yal1(ivar1(ial(k)))=.true.
      enddo
      if(yww) then
         write(6,'(a10,40l1)')'3 yal1  ',(yal1(k),k=1,isol1)
      endif
      nalfa1=0
      do k=1,isol1
         if(yal1(k)) then
            nalfa1=nalfa1+1
            ial1(nalfa1)=k
         endif
      enddo
c
c     signe du CAS du aux electrons celibataires
c
      if(yscmrs) goto 5
      kk=0
      jsgnca=isgncfa
      jsgncb=isgncfb
c      if(yww)print*,'iocc1',iocc1
c      if(yww)print*,'ksgna0',ksgna0
c      if(yww)print*,'ksgnb0',ksgnb0
c      if(yww)print*,'isolt1',isolt1,ninac
      do k=1,noac
         if(iocc1(k).eq.1) then
            kk=kk+1
            if(yal1(kk+isolt1)) then
               if(ksgna0(k+ninac).eq.-1) jsgnca=-jsgnca
c               if(yww)print*,'coucou1',k
            else
               if(ksgnb0(k+ninac).eq.-1) jsgncb=-jsgncb
c               if(yww)print*,'coucou2',k
            endif
         endif
      enddo
 5    continue
c      if(yww) then
c         write(75,*)'isgncfa,isgncfb,jsgnca,jsgncb',
c     *   isgncfa,isgncfb,jsgnca,jsgncb,'$'
c         call scril
c      endif
c
c     ial2 : place des alpha dans les celibataires (det 2)
c
 
      if(yscmrs) goto 2
      do k=1,nbela
         yal2(ivar2(ial(k)))=.true.
      enddo
      if(yww) then
         write(6,'(a10,40l1)')'3 yal2  ',(yal2(k),k=1,isol2)
      endif
      nalfa2=0
      do k=1,isol2
         if(yal2(k)) then
            nalfa2=nalfa2+1
            ial2(nalfa2)=k
         endif
      enddo
 2    continue
 
      call rang3s(isol1,nalfa1,ial1,irang1)
      if(yww) then
         write(75,*)'ial1',(ial1(k),k=1,nalfa1),' Isol1,irang1',
     *   isol1,irang1,'$'
         call scril
      endif
      if(.not.yscmrs)call rang3s(isol2,nalfa2,ial2,irang2)
      if(yww.and..not.yscmrs) then
         write(75,*)'ial2',(ial2(k),k=1,nalfa2),' isol2,irang2',
     *   isol2,irang2,'$'
         call scril
      endif
      nbadrsp=nbadrsp+1
      iadrsp1(nbadrsp)=irang1
      if(.not.yscmrs)iadrsp2(nbadrsp)=irang2
      if(irang1.lt.0) then
         write(6,*)'ial1',(ial1(k),k=1,nalfa1),' isol1,irang1',
     *   isol1,irang1,'$'
      endif
      if(.not.yscmrs) then
         if(irang2.lt.0) then
            write(75,*)'ial2',(ial2(k),k=1,nalfa2),' isol2,irang2',
     *      isol2,irang2,'$'
         endif
      endif
c
c     signe du aux trous et part
c
      if(yscmrs) goto 4
      japret1=iapret1
      japret2=iapret2
      if(nt10.eq.1.and.nta.eq.1) then
         if(ista.gt.itsym(it10(1))) japret1=2
      endif
!      if(nt10.eq.1.and.nta.eq.1.and.ista.gt.itsym(it10(1))) japret1=2
      if(nt20.eq.1.and.nta.eq.1) then
         if(ista.gt.itsym(it20(1))) japret2=2
      endif
!      if(nt20.eq.1.and.nta.eq.1.and.ista.gt.itsym(it20(1))) japret2=2
      call cd13st(ksgnt,yal1,yal2,ifix1,ifix2
     *,japret1,japret2,nta,nt10,nt20,it10,it20,isolt1,isolt2
     *,ksgna0,ksgnb0)
      japrep1=iaprep1
      japrep2=iaprep2
      if(np10.eq.1.and.npa.eq.1) then
         if(ispa.gt.itsym(ip10(1))) japrep1=2
      endif
      if(np20.eq.1.and.npa.eq.1) then
         if(ispa.gt.itsym(ip20(1))) japrep2=2
      endif
!      if(np10.eq.1.and.npa.eq.1.and.ispa.gt.itsym(ip10(1))) japrep1=2
!      if(np20.eq.1.and.npa.eq.1.and.ispa.gt.itsym(ip20(1))) japrep2=2
      call cd13sp(ksgnp,yal1,yal2,ifix1,ifix2
     *,japrep1,japrep2,npa,np10,np20,isol1,isol2,kfix1,kfix2,ip10,ip20,
     *isolp1,isolp2,ksgna0,ksgnb0)
      isgns(nbadrsp)=ksgnt*ksgnp*jsgnca*jsgncb*isgni0
      if(yww) then
         print*,'nbadrsp',nbadrsp
         write(75,*)'isgns(nbadrsp),ksgnt,ksgnp,jsgnca,jsgncb,isgni0',
     *   isgns(nbadrsp),ksgnt,ksgnp,jsgnca,jsgncb,isgni0,'$'
         call scril
      endif
 4    continue
 
      do k=1,nbela
         yal1(ivar1(ial(k)))=.false.
      enddo
      if(.not.yscmrs) then
         do k=1,nbela
            yal2(ivar2(ial(k)))=.false.
         enddo
      endif
      if(iret.eq.0) goto 25
      return
      end
 
       subroutine cd13st(ksgnt,yal1,yal2,ifix1,ifix2
     *,iapret1,iapret2,nta,nt10,nt20,it10,it20,isolt1,isolt2
     *,ksgna0,ksgnb0)
c
c--------------------------------------------------------
c     signe du aux trous
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/cd02w/yww
      dimension yal1(2),yal2(2),ifix1(2),ifix2(2)
      dimension ksgna0(maxorb),ksgnb0(maxorb)
      dimension it10(2),it20(2)
      common /nummrs/nummr(maxorb)
c      if(yww)print*,'nta,nt10,nt20',nta,nt10,nt20
c      if(yww)print*,'isolt1,isolt2',isolt1,isolt2
      if(nta.eq.0) then
         ksgnt=1
      else if (nta.eq.1) then
         if(isolt1.eq.0) then
            iii=nummr(it10(1))
            if(yww)print*,'it10(1)',it10(1),iii
            if(yww)print*,'it10(1)',it10(1),iii
            ksgnt=ksgna0(iii)*ksgnb0(iii)
            return
         endif
         if(isolt2.eq.0) then
            if(nt10.eq.0) then
               iii=nummr(it20(1))
               if(ifix1(2).eq.1) then
                  ksgnt=ksgnb0(iii)
               else
                  ksgnt=ksgna0(iii)
               endif
            else
               iii1=nummr(it10(1))
               iii2=nummr(it20(1))
               if(iii1.gt.iii2) then
                  if(ifix1(1).eq.1) then
                     ksgnt=ksgnb0(iii2)
                  else
                     ksgnt=ksgna0(iii2)
                  endif
               else
                  if(ifix1(2).eq.1) then
                     ksgnt=ksgnb0(iii2)
                  else
                     ksgnt=ksgna0(iii2)
                  endif
               endif
               return
            endif
         endif
         if(nt10.eq.0) then
            if(nt20.eq.0) then
               ksgnt=1
            else if (nt20.eq.1) then
               if(iapret2.eq.1) then
                  ksgnt=1
               else if (iapret2.eq.2) then
c                 on ajoute un trou a droite de l'indice de l'int
c                 du det 2
c                 . . . a . .              . . I a . .
c                 si memes spins, signe -
                  if(.not.yal1(1).and.ifix2(1).eq.-1.or.
     *            yal1(1).and.ifix2(1).eq.1) then
                     ksgnt=-1
                  else
                     ksgnt=1
                  endif
               endif
            endif
         else if (nt10.eq.1) then
            if(nt20.eq.0) then
c               if(yww)print*,'COUCOU',iapret1
               if(iapret1.eq.1) then
                  ksgnt=1
               else
c                 . . I a . .              . . . a . .
                  if(.not.yal1(2).and.ifix1(1).eq.-1.or.
     *            yal1(2).and.ifix1(1).eq.1) then
                     ksgnt=-1
c                     if(yww)print*,'COUCOU2'
                  else
c                     if(yww)print*,'COUCOU3'
                     ksgnt=1
                  endif
               endif
            else if(nt20.eq.1) then
               if(yww)print*,'COUa'
c                 . . I . . . . .              . . . . . J . .
               if(ifix1(1).eq.ifix2(1)) then
                  if(yww)print*,'COUb'
c                 I et J ont meme spin
 
 
 
 
                  if(iapret1.eq.2) then
c                    . . I a . . . .              . . . a . J . .
c            ou      . . I . . . . a              . . . . . J . a
                     if(.not.yal1(2).and.ifix1(1).eq.-1.or.
     *               yal1(2).and.ifix1(1).eq.1) then
                        if(iapret2.eq.1) then
                           ksgnt=-1
                           if(yww)print*,'COUc'
                        else
                           ksgnt=1
                           if(yww)print*,'COUd'
                        endif
                     else
                        ksgnt=1
                        if(yww)print*,'COUe'
                     endif
                  else
 
 
                     if(.not.yal1(1).and.ifix1(1).eq.-1.or.
     *               yal1(1).and.ifix1(1).eq.1) then
                        if(iapret2.eq.1) then
                           ksgnt=1
c                           if(yww)print*,'COUC'
                        else
                           ksgnt=-1
c                           if(yww)print*,'COUD'
                        endif
                     else
                        ksgnt=1
c                        if(yww)print*,'COUE'
                     endif
 
 
 
 
                  endif
               else
                  y1_avant_2=it10(1).lt.it20(1)
                  if(yww)print*,'y1_avant_2',y1_avant_2
                  if(y1_avant_2) then
                     if(iapret1.eq.1) then
                        ksgnt=1
c                        if(yww)print*,'COUg'
c                   a . I . . . . .              a . . . . J . .
                     else
                        if(.not.yal1(2).and.ifix1(1).eq.-1.or.
     *                  yal1(2).and.ifix1(1).eq.1) then
c                          memes spins sur le det 1
c                          . . I a . . . .              . . . a . J . .
c                  ou      . . I . . . a .              . . . . . J a .
                           ksgnt=-1
c                           if(yww)print*,'COUh'
                        else
                           if(iapret2.eq.1) then
                              ksgnt=1
c                             if(yww)print*,'COUi'
                           else
                              ksgnt=-1
c                              if(yww)print*,'COUj'
                           endif
                        endif
                     endif
                  else
c                     if(yww)print*,'COU1'
                     if(iapret2.eq.1) then
c                        if(yww)print*,'COU2'
c                       a . . . . I . .              a . J . . . . .
                        ksgnt=1
                     else
c                        if(yww)print*,'COU3'
c                       . . . a . I . .              . . J a . . . .
c                 ou    . . . . . I a .              . . J . . . a .
                        if(.not.yal2(2).and.ifix2(1).eq.-1.or.
     *                  yal2(2).and.ifix2(1).eq.1) then
c                          memes spins sur le det 2
                           ksgnt=-1
c                           if(yww)print*,'COU4'
                        else
                           if(iapret1.eq.1) then
                              ksgnt=1
c                              if(yww)print*,'COU5'
                           else
                              ksgnt=-1
c                              if(yww)print*,'COU6'
                           endif
                        endif
                     endif
                  endif
               endif
            endif
         endif
      else if (nta.eq.2) then
         ksgnt=1
      endif
      return
      end
       subroutine cd13sp(ksgnp,yal1,yal2,ifix1,ifix2
     *,iaprep1,iaprep2,npa,np10,np20,isol1,isol2,kfix1,kfix2,ip10,ip20,
     *isolp1,isolp2,ksgna0,ksgnb0)
c
c--------------------------------------------------------
c     signe du aux part
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/cd02w/yww
      dimension ksgna0(maxorb),ksgnb0(maxorb)
      dimension yal1(maxorbcas+4),yal2(maxorbcas+4),ifix1(4),ifix2(4)
      dimension ip10(2),ip20(2)
      common /nummrs/nummr(maxorb)
      if(npa.eq.0) then
         ksgnp=1
      else if (npa.eq.1) then
         if(isolp1.eq.0) then
            iii=nummr(ip10(1))
            ksgnp=ksgna0(iii)*ksgnb0(iii)
            return
         endif
         if(isolp2.eq.0) then
            if(np10.eq.0) then
               iii2=nummr(ip20(1))
               if(ifix1(kfix1).eq.1) then
                  ksgnp=ksgna0(iii2)
               else
                  ksgnp=ksgnb0(iii2)
               endif
            else
               if(yww)print*,'ip10(1)',ip10(1)
               iii1=nummr(ip10(1))
               iii2=nummr(ip20(1))
               if(yww)print*,'iii1,iii2',iii1,iii2
               if(iii1.gt.iii2) then
                  if(ifix1(kfix1-1).eq.1) then
                     ksgnp=ksgna0(iii2)
                  else
                     ksgnp=ksgnb0(iii2)
                  endif
               else
                  if(ifix1(kfix1).eq.1) then
                     ksgnp=ksgna0(iii2)
                  else
                     ksgnp=ksgnb0(iii2)
                  endif
               endif
            endif
            return
         endif
         if(np10.eq.0) then
            if(np20.eq.0) then
               ksgnp=1
            else if (np20.eq.1) then
               if(iaprep2.eq.2) then
                  ksgnp=1
               else if (iaprep2.eq.1) then
c                 on ajoute une part a gauche de l'indice de l'int
c                 du det 2
c                 a . . . . .              a . I . . .
c                 si memes spins, signe -
                  if(yal1(isol1).and.ifix2(kfix2).eq.1.or.
     *            .not.yal1(isol1).and.ifix2(kfix2).eq.-1) then
                     ksgnp=-1
                  else
                     ksgnp=1
                  endif
               endif
            endif
         else if (np10.eq.1) then
            if(np20.eq.0) then
               if(iaprep1.eq.2) then
                  ksgnp=1
               else
c                 a . I . . .              a . . . . .
                  if(yal1(isol1-1).and.ifix1(kfix1).eq.1.or.
     *            .not.yal1(isol1-1).and.ifix1(kfix1).eq.-1) then
                     ksgnp=-1
                  else
                     ksgnp=1
                  endif
               endif
            else if(np20.eq.1) then
c                 . . I . . . . .              . . . . . J . .
               if(ifix1(kfix1).eq.ifix2(kfix2)) then
c                 I et J ont meme spin
                  if(iaprep2.eq.1) then
c                    a . I . . . . .              a . . . . J . .
c            ou      . . I a . . . .              . . a . . J . .
                     if(yal2(isol2-1).and.ifix2(kfix2).eq.1.or.
     *               .not.yal2(isol2-1).and.ifix2(kfix2).eq.-1) then
                        if(iaprep1.eq.2) then
                           ksgnp=-1
                        else
                           ksgnp=1
                        endif
                     else
                        ksgnp=1
                     endif
                  else
 
 
 
                     if(yal2(isol2).and.ifix2(kfix2).eq.1.or.
     *               .not.yal2(isol2).and.ifix2(kfix2).eq.-1) then
                        if(iaprep1.eq.2) then
                           ksgnp=1
                        else
                           ksgnp=-1
                        endif
                     else
                        ksgnp=1
                     endif
 
                  endif
               else
                  y1_avant_2=ip10(1).lt.ip20(1)
                  if(y1_avant_2) then
                     if(iaprep2.eq.2) then
                        ksgnp=1
c                   . . I . . . . a              . . . . . J . a
                     else
c                       . . I a . . . .              . . . a . J . .
c                  ou   a . I . . . . .              a . . . . J . .
                        if(yal2(isol2-1).and.ifix2(kfix2).eq.1.or.
     *                  .not.yal2(isol2-1).and.ifix2(kfix2).eq.-1) then
c                          memes spins sur le det 2
                           ksgnp=-1
                        else
                           if(iaprep1.eq.2) then
                              ksgnp=1
                           else
                              ksgnp=-1
                           endif
                        endif
                     endif
                  else
                     if(iaprep1.eq.2) then
c                       . . . . I a . .              . . J . . a . .
                        ksgnp=1
                     else
c                       . . . a . I . .              . . J a . . . .
c                 ou    a . . . . I . .              a . J . . . . .
                        if(yal1(isol1-1).and.ifix1(kfix1).eq.1.or.
     *                  .not.yal1(isol1-1).and.ifix1(kfix1).eq.-1) then
c                          memes spins sur le det 1
                           ksgnp=-1
                        else
                           if(iaprep2.eq.2) then
                              ksgnp=1
                           else
                              ksgnp=-1
                           endif
                        endif
                     endif
                  endif
               endif
            endif
         endif
      else if (npa.eq.2) then
         ksgnp=1
      endif
      return
      end
       subroutine cd07s(norb,nbadrt0,nbadrt,kadrt1,ltf,
     *ninac,nta,nt10,nt20,it10,it20
     *,icatts,ista,isolt1,isolt2,ist1_1,ist1_2,ist2_1,ist2_2
     *,yspinalttp,nts,iplt10,iplt20
     *,iapret1,iapret2,naa,naad,naaf,naadf,coef,ind256)
c
c--------------------------------------------------------
c     calcul des adresses des T et P
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/cd02w/yww
 
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      dimension icatts(maxsym,maxsym),yspinalttp(maxorb)
      dimension kadrt1(nbadrt0)
      dimension it10(2),it20(2),idet1(2)
      dimension nts(maxsym)
      dimension iplt10(2),iplt20(2)
      dimension ltf(naa)
c      dimension ntstot(0:maxsym)
      common/naadi/naadim
      character*1 coef(naadim,ind256)
      common /combs/  C(0:maxorbcas+4,-1:maxorbcas+4)
      integer c
      naad2=max(naad,2)
      if(yww) then
         write(75,*)'entree cd07 nt10,nta,isolt1,isolt2,',
     *   nt10,nta,isolt1,isolt2,'$'
         call scril
      endif
c
c     adresses des trous
c
      if(nta.eq.0) then
         nbadrt=naadf
         if(nt10.eq.0) then
            do k=1,naadf
               kadrt1(k)=1
               ltf(k)=k
            enddo
         else if (nt10.eq.1) then
            kk=0
            if(naad.eq.1) then
               kadrt1(1)=itorb(it10(1))
               ltf(1)=1
               kk=1
            endif
            do k=naad2,naaf
               kk=kk+1
               kkk=icar(coef(k,iplt10(1)))
               if(norb.ge.256)call decod2
     *         (kkk,coef(k,ind256),iplt10(1))
               kadrt1(kk)=itorb(kkk)
               ltf(kk)=kk
c               if(yww)print*,'coef',(icar(coef(k,kkk)),kkk=1,4)
            enddo
         else if (nt10.eq.2) then
            if(naad.eq.1) then
               it1=it10(1)
               it2=it10(2)
            else
               it1=icar(coef(naad,iplt10(1)))
               it2=icar(coef(naad,iplt10(2)))
               if(norb.ge.256)call decod2
     *         (it1,coef(naad,ind256),iplt10(1))
               if(norb.ge.256)call decod2
     *         (it2,coef(naad,ind256),iplt10(2))
            endif
            if(yww)print*,'naad,it10,it1,it2',naad,it10,it1,it2
            if(it1.eq.it2) then
               kk=0
               if(naad.eq.1) then
                  kadrt1(1)=itorbc(it1)
                  ltf(1)=1
                  kk=1
               endif
               do k=naad2,naaf
                  kk=kk+1
c                  kadrt1(kk)=itorbc(icar(coef(k,iplt10(1))))
                  kkk=icar(coef(k,iplt10(1)))
c                  print'(a4,5i6)',
c     *            'dec',ind256,k,kkk,ichar(coef(k,ind256)),iplt10(1)
c                  print'(a4,4i6)','coef',(ichar(coef(k,kkkk)),kkkk=1,4)
                  if(norb.ge.256)call decod2
     *            (kkk,coef(k,ind256),iplt10(1))
c                  print'(a4,4i6)',
c     *            'dec',kkk
                  kadrt1(kk)=itorbc(kkk)
                  ltf(kk)=kk
               enddo
            else
               if(ist1_1.eq.ist1_2) then
                  kk=0
                  if(naad.eq.1) then
                     idet1(1)=min(itorb(it1),itorb(it2))
                     idet1(2)=max(itorb(it1),itorb(it2))
                     call rang2s(nts(ist1_1),2,idet1,iadrt)
                     kadrt1(1)=iadrt+icatts(ist1_1,ist1_1)
                     ltf(1)=1
                     kk=1
                  endif
                  do k=naad2,naaf
                     kk=kk+1
                     it1v=icar(coef(k,iplt10(1)))
                     it2v=icar(coef(k,iplt10(2)))
                     if(norb.ge.256)call decod2
     *               (it1v,coef(k,ind256),iplt10(1))
                     if(norb.ge.256)call decod2
     *               (it2v,coef(k,ind256),iplt10(2))
                     idet1(1)=min(itorb(it1v),itorb(it2v))
                     idet1(2)=max(itorb(it1v),itorb(it2v))
                     call rang2s(nts(ist1_1),2,idet1,iadrt)
                     kadrt1(kk)=iadrt+icatts(ist1_1,ist1_1)
                     ltf(kk)=kk
                  enddo
               else
                  kk=0
                  if(naad.eq.1) then
                     jt1=itorb(min(it1,it2))
                     jt2=itorb(max(it1,it2))
                     js=min(ist1_1,ist1_2)
                     kadrt1(1)=jt1+(jt2-1)*nts(js)
     *               +icatts(ist1_1,ist1_2)
                     ltf(1)=1
                     kk=1
                  endif
                  do k=naad2,naaf
                     kk=kk+1
                     it1v=icar(coef(k,iplt10(1)))
                     it2v=icar(coef(k,iplt10(2)))
                     if(norb.ge.256)call decod2
     *               (it1v,coef(k,ind256),iplt10(1))
                     if(norb.ge.256)call decod2
     *               (it2v,coef(k,ind256),iplt10(2))
                     jt1=itorb(min(it1v,it2v))
                     jt2=itorb(max(it1v,it2v))
                     js=min(ist1_1,ist1_2)
                     kadrt1(kk)=jt1+(jt2-1)*nts(js)
     *               +icatts(ist1_1,ist1_2)
                     ltf(kk)=kk
                  enddo
               endif
            endif
         endif
      else if(nta.eq.1) then
         nbadrt=0
         kk=0
         do kaa=naad,naaf
            kk=kk+1
            if(kaa.eq.1) then
               jt10=it10(1)
               jt20=it20(1)
            else
               if(yww)print*,'kaa,iplt10(1)',kaa,iplt10(1)
               if(yww)call flush(6)
               if(nt10.ne.0) then
                  jt10=icar(coef(kaa,iplt10(1)))
                  if(norb.ge.256)call decod2
     *            (jt10,coef(kaa,ind256),iplt10(1))
               endif
               if(nt20.ne.0) then
                  jt20=icar(coef(kaa,iplt20(1)))
                  if(norb.ge.256)call decod2
     *            (jt20,coef(kaa,ind256),iplt20(1))
               endif
            endif
            if(yww)print*,'jt10,jt20',jt10,jt20
            if (isolt2.eq.2.and.ist2_1.eq.ist2_2) then
c           alors il y a 2 zones dans le det 2
               if(iapret2.eq.1) then
                  idebadrt2=1
                  ifinadrt2=itorb(jt20)-1
               else
                  idebadrt2=itorb(jt20)+1
                  ifinadrt2=nts(ista)
               endif
               if(yww)print*,'idebadrt2,ifinadrt2,iapret2',
     *         idebadrt2,ifinadrt2,iapret2
            else
               idebadrt2=1
               ifinadrt2=nts(ista)
            endif
            if(nt10.eq.0) then
               if(isolt2.eq.0) then
                  nbadrt=naadf
                  kadrt1(kk)=itorb(jt20)
                  ltf(kk)=kk
               else
                  do k=idebadrt2,ifinadrt2
                     nbadrt=nbadrt+1
                     kadrt1(nbadrt)=k
!                      if(naad.eq.1) then
!                         kadrt1(nbadrt)=itorbc(it10(1))
!                         ipass=1
!                      else
!                         kadrt1(nbadrt)=itorbc(icar(coef(k,iplt10(1))))
!                         ipass=2
!                      endif
                      if(k.ne.kadrt1(nbadrt)) then
                         print*,'naad,naaf,kaa',naad,naaf,kaa
                         print*,'nta',nta
                         print*,'idebadrt2,ifinadrt2',
     *                   idebadrt2,ifinadrt2
                         print*,'icar(coef(k,iplt10(1)))',
     *                   icar(coef(k,iplt10(1)))
                         if(norb.ge.256)print*,'coef5'
     *                   ,icar(coef(k,ind256))
                         print*,'it10(1)',it10(1),itorbc(it10(1))
                         print*,'itorbc',itorbc(icar(coef(k,iplt10(1))))
                         print*,'k,kadrt1(nbadrt)',k,kadrt1(nbadrt)
                         stop
                      endif
                  enddo
                  ltf(kk)=nbadrt
               endif
            else if(nt10.eq.1) then
               if(isolt1.eq.0) then
                  if(yspinalttp(it10(1))) then
                     nbadrt=0
                     return
                  endif
                  nbadrt=naadf
                  kadrt1(kk)=itorbc(jt10)
                  ltf(kk)=kk
               else if(isolt1.eq.2) then
                  if(isolt2.eq.0) then
                     nbadrt=naadf
                     if(ist1_1.eq.ist1_2) then
                        idet1(1)=min(itorb(jt10),itorb(jt20))
                        idet1(2)=max(itorb(jt10),itorb(jt20))
                        call rang2s(nts(ist1_1),2,idet1,iadrt)
                        kadrt1(kk)=iadrt+icatts(ist1_1,ist1_1)
                        ltf(kk)=kk
                        if(yww)print*,'coucou9',it10(1)
                     else
                        it1=itorb(min(jt10,jt20))
                        it2=itorb(max(jt10,jt20))
                        js=min(ist1_1,ist1_2)
                        kadrt1(kk)=it1+(it2-1)*nts(js)
     *                  +icatts(ist1_1,ist1_2)
                        ltf(kk)=kk
                        if(yww)print*,'coucou6',jt10,ist1_1,ist1_2,
     *                  kaa,it1,it2,nts(js)
     *                  ,icatts(ist1_1,ist1_2)
                     endif
                     goto 100
                  endif
                  if(isolt2.eq.1.or.ist2_1.ne.ist2_2) then
                     if(yww)print*,'ist2_1,ist2_2',ist2_1,ist2_2
                     if(ist1_1.eq.ist1_2) then
                        if(iapret1.eq.1) then
                           idebadr=1
                           ifinadr=itorb(jt10)-1
                        else
                           idebadr=itorb(jt10)+1
                           ifinadr=nts(ista)
                        endif
                     else
                        idebadr=1
                        ifinadr=nts(ista)
                     endif
                     goto 101
                  endif
c              on a alors isolt2=2
                  if(yww)print*,'coucou22',ist1_1,ist1_2,ist2_1,ist2_2
                  if(ist1_1.eq.ist1_2) then
                     if(ist2_1.eq.ist2_2) then
                        if(iapret1.eq.1) then
                           if(iapret2.eq.1) then
                              idebadr=1
                              ifinadr=min(itorb(jt10),itorb(jt20))-1
                           else
                              idebadr=itorb(jt20)+1
                              ifinadr=itorb(jt10)-1
                              if(yww)print*,'coucoucou idebadr,ifinadr,j
     &                        t10,jt20',
     *                        idebadr,ifinadr,jt10,jt20
                           endif
                        else
                           if(iapret2.eq.1) then
                              idebadr=itorb(jt10)+1
                              ifinadr=itorb(jt20)-1
                           else
                              idebadr=max(itorb(jt10),itorb(jt20))+1
                              ifinadr=nts(ista)
                           endif
                        endif
                     else
                        if(iapret1.eq.1) then
                           idebadr=1
                           ifinadr=itorb(jt10)-1
                        else
                           idebadr=itorb(jt10)+1
                           ifinadr=nts(ista)
                        endif
                     endif
                  else
                     if(ist2_1.eq.ist2_2) then
                        if(iapret2.eq.1) then
                           idebadr=1
                           ifinadr=itorb(jt20)-1
                        else
                           idebadr=itorb(jt20)+1
                           ifinadr=nts(ista)
                        endif
                     else
                        idebadr=1
                        ifinadr=nts(ista)
                     endif
                  endif
 101              continue
                  if(yww)print*,'idebadr,ifinadr',idebadr,ifinadr
                  if(yww) call flush(6)
c               nbadrt=max(0,ifinadr-idebadr+1)
c               kk=0
                  do k=idebadr,ifinadr
                     nbadrt=nbadrt+1
c                  kk=kk+1
c                  print*,'k,ist1_1,ist1_2',k,ist1_1,ist1_2
                     if(ist1_1.eq.ist1_2) then
                        it1=jt10
                        idet1(1)=min(itorb(it1),k)
                        idet1(2)=max(itorb(it1),k)
                        if(yww)print*,'it1,k',it1,k,idet1
                        call rang2s(nts(ist1_1),2,idet1,iadrt)
                        kadrt1(nbadrt)=iadrt+icatts(ist1_1,ist1_2)
                        if(yww)print*,'iadrt',iadrt
                     else
                        if(ista.eq.ist1_1)then
                           istf=ist1_2
                        else
                           istf=ist1_1
                        endif
                        if(ista.gt.istf) then
                           it1=itorb(jt10)
                           it2=k
                           kadrt1(nbadrt)=it1+(it2-1)*nts(istf)
     *                     +icatts(ist1_1,ist1_2)
                        else
                           it1=k
                           it2=itorb(jt10)
                           kadrt1(nbadrt)=it1+(it2-1)*nts(ista)
     *                     +icatts(ist1_1,ist1_2)
                        endif
                     endif
                  enddo
                  ltf(kk)=nbadrt
               endif
            endif
 100        continue
         enddo
      else if(nta.eq.2) then
         if(isolt1.eq.0) then
            nbadrt=0
            kk=0
            do kaa=naad,naaf
               kk=kk+1
               do k=1,ninac
                  nbadrt=nbadrt+1
                  kadrt1(nbadrt)=k
                  ltf(kk)=nbadrt
               enddo
            enddo
         else
c           dans ce cas, on est dans une boucle sur la sym du
c           1er  trou (isymt1)
            if(ista.eq.1) then
               nn=nts(ist1_1)
               nbadrt1=nn*(nn-1)/2
            else
               nbadrt1=nts(ist1_1)*nts(ist1_2)
            endif
            ii=icatts(ist1_1,ist1_2)
            nbadrt=0
            kk=0
            do kaa=naad,naaf
               kk=kk+1
               do k=1,nbadrt1
                  nbadrt=nbadrt+1
                  kadrt1(nbadrt)=k+ii
                  ltf(kk)=nbadrt
               enddo
            enddo
         endif
      endif
      if(yww)print*,'sortie cd07s nbadrt,kadrt1',
     *nbadrt,(kadrt1(k),k=1,nbadrt)
      return
      end
 
 
       subroutine cd06s(minst1,maxst1,nt1,nt10,ist10,nsym,isolt1)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      common/cd02w/yww
c
c--------------------------------------------------------
c     calcul des bornes des symetries
c--------------------------------------------------------
c
      if(nt1.eq.0) then
         minst1=1
         maxst1=1
      else if(nt1.eq.1) then
         if(nt10.eq.1) then
            minst1=ist10
            maxst1=ist10
         else
            minst1=1
            maxst1=nsym
         endif
      else
         if(nt10.eq.2) then
            minst1=ist10
            maxst1=ist10
         else
            if(isolt1.eq.0) then
               minst1=1
               maxst1=1
            else
               minst1=1
               maxst1=nsym
            endif
         endif
      endif
      return
      end
 
       subroutine cd05s(nt10,nt20,nt1,nt2,nbsolt
     *,ksolt1,ksolt2,it10,it20,yspinalttp,ninac)
      include 'maxorb.prm'
      implicit real*8 (a-h,o-x,z),logical*1(y)
      common/cd02w/yww
      dimension it10(2),it20(2)
      dimension ksolt1(3),ksolt2(3)
      dimension yspinalttp(maxorb)
c
c-----------------------------------------------------
c     on compte les differentes possibilites d'avoir
c     des electrons celibataires sur les trous (part)
c-----------------------------------------------------
c
      if(yww)print*,'cd05s nt1,nt2',nt1,nt2
      if(yww)print*,'cd05s it10,it20',
     *(it10(k),k=1,nt10),'  ...',(it20(k),k=1,nt20)
      if(nt1.ne.2.and.nt2.ne.2) then
         nbsolt=1
         ksolt1(1)=nt1
         ksolt2(1)=nt2
c        a completer pour yscmrs......
      else
         if(nt2.eq.0) then
c           nt1=2  nt2=0
            nbsolt=1
            if(it10(1).eq.it10(2)) then
               ksolt1(1)=0
               ksolt2(1)=0
            else
               ksolt1(1)=2
               ksolt2(1)=0
            endif
         else if(nt2.eq.1) then
c           nt1=2  nt2=1
            ksolt2(1)=1
            if(nt10.eq.1) then
               nbsolt=2
               ksolt2(2)=1
               ksolt1(1)=0
               ksolt1(2)=2
            else
               nbsolt=1
               if(it10(1).eq.it10(2)) then
                  ksolt1(1)=0
               else
                  ksolt1(1)=2
               endif
            endif
         else if(nt1.eq.0) then
c           nt1=0  nt2=2
            nbsolt=1
            if(it20(1).eq.it20(2)) then
               ksolt1(1)=0
               ksolt2(1)=0
            else
               ksolt1(1)=0
               ksolt2(1)=2
            endif
         else if(nt1.eq.1) then
c           nt1=1  nt2=2
            ksolt1(1)=1
            if(nt20.eq.1) then
               nbsolt=2
               ksolt1(2)=1
               ksolt2(1)=0
               ksolt2(2)=2
            else
               nbsolt=1
               if(it20(1).eq.it20(2)) then
                  ksolt2(1)=0
               else
                  ksolt2(1)=2
               endif
            endif
         else
c           nt1=2  nt2=2
            if(yww)print*,'2 el rajoutes de chaque cote'
            if(nt10.eq.0) then
c              2 el rajoutes de chaque cote
               nbsolt=2
               ksolt1(1)=0
               ksolt1(2)=2
               ksolt2(1)=0
               ksolt2(2)=2
            else if(nt10.eq.1) then
c              1 el rajoute de chaque cote
               if(yww)print*,'1 el rajoutes de chaque cote'
               if(it10(1).eq.it20(1)) then
                  if(yspinalttp(it10(1))) then
                     nbsolt=1
                     ksolt1(1)=2
                     ksolt2(1)=2
                  else
                     nbsolt=2
                     ksolt1(1)=0
                     ksolt2(1)=0
                     ksolt1(2)=2
                     ksolt2(2)=2
                  endif
               else
                  nbsolt=3
                  ksolt1(1)=0
                  ksolt1(2)=2
                  ksolt1(3)=2
                  ksolt2(1)=2
                  ksolt2(2)=0
                  ksolt2(3)=2
               endif
            else if(nt10.eq.2) then
c              0 el rajoute de chaque cote
               nbsolt=1
               if(it10(1).eq.it10(2)) then
                  ksolt1(1)=0
               else
                  ksolt1(1)=2
               endif
               if(it20(1).eq.it20(2)) then
                  ksolt2(1)=0
               else
                  ksolt2(1)=2
               endif
            endif
         endif
      endif
c     on verifie que le nombre d'electrons celibataires
c     n'est pas superieur au nombre d'orbitales
      if(ninac.lt.2) then
         nbsoltn=0
         do k=1,nbsolt
            if(ksolt1(k).le.ninac.and.ksolt2(k).le.ninac) then
               nbsoltn=nbsoltn+1
               ksolt1(nbsoltn)=ksolt1(k)
               ksolt2(nbsoltn)=ksolt2(k)
            endif
         enddo
         nbsolt=nbsoltn
      endif
      return
      end
 
 
 
       subroutine cd03s(in,nt20,it20,nc10,ic10,np10,ip10,iocc,
     *iplt20,iplp10,ind)
      parameter(maxorbcas=16)
      include 'maxorb.prm'
      implicit real*8 (a-h,o-x,z),logical*1(y)
      common/cd02w/yww
      dimension it20(2),ic10(2),ip10(2),iocc(maxorbcas)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      dimension iplt20(4),iplp10(4)
      if(yww)print*,'dans cd03s in,ind,nt20,np10',in,ind,nt20,np10
      if(itype(in).eq.1) then
         nt20=nt20+1
         it20(nt20)=in
         iplt20(nt20)=ind
         if(yww)print*,'iplt20(nt20)',iplt20(nt20)
      else if (itype(in).eq.2) then
         nc10=nc10+1
         ic10(nc10)=in
         iocc(itorbc(in))=iocc(itorbc(in))+1
      else
         np10=np10+1
         ip10(np10)=in
         iplp10(np10)=ind
         if(yww)print*,'iplp10(np10)',iplp10(np10)
      endif
      return
      end
 
       subroutine cd14s
      use mod_ndimcs0
      include 'maxorb.prm'
      include 'cds.inc'
      common/cd02w/yww
c
c---------------------------------------------------
c     valeurs possibles des trous
c---------------------------------------------------
c
c
c     diagonalisation
c
      nbt1=0
      if(.not.yscmrs) then
         do nt1=mint1,maxt1
            nbt1=nbt1+1
            kt1(nbt1)=nt1
         enddo
      else
         iech=-1
c
c        Habillage sc2
c
         if(itest(11).eq.2) then
            ifint=2
         else
            ifint=4
         endif
         do nt1=nt10,ifint
            np1=nt1-nc1+nelac
            if(np1.lt.np10.or.np1.gt.ifint) goto 20
            nta=nt1-nt10
            nt2=nta+nt20
            if(nt2.lt.nt20.or.nt2.gt.ifint) goto 20
            npa=np1-np10
            np2=npa+np20
            if(np2.lt.np20.or.np2.gt.ifint) goto 20
            if(yww) then
               write(75,*)'cd14s nt1,np1,nt2,np2',nt1,np1,nt2,np2,'$'
               call scril
            endif
            ybon1=.true.
            ybon2=.true.
            if(nt1.lt.mint1) ybon1=.false.
            if(nt1.gt.maxt1) ybon1=.false.
            if(nt2.lt.mint2) ybon2=.false.
            if(nt2.gt.maxt2) ybon2=.false.
            if(np1.lt.minp1) ybon1=.false.
            if(np1.gt.maxp1) ybon1=.false.
            if(np2.lt.minp2) ybon2=.false.
            if(np2.gt.maxp2) ybon2=.false.
            if(yww) then
               write(6,'('' ybon1,ybon2'',2l2 )')ybon1,ybon2
               print*,mint2,maxt2,minp2,maxp2
               print*,mint1,maxt1,minp1,maxp1
            endif
            if(ybon1.and..not.ybon2) then
               nbt1=nbt1+1
               kt1(nbt1)=nt1
               if(iech.eq.1) stop ' cd14s'
               iech=0
            else if(ybon2.and..not.ybon1) then
               nbt1=nbt1+1
               kt1(nbt1)=nt1
               if(iech.eq.0) stop ' cd14s'
               iech=1
            endif
 20         continue
         enddo
      endif
      return
      end
 
       subroutine cd15s
      use mod_ndimcs0
      include 'maxorb.prm'
      include 'cds.inc'
      common/cd02w/yww
 
      call ech(mint1,mint2)
      call ech(minp1,minp2)
      call ech(maxt1,maxt2)
      call ech(maxp1,maxp2)
      call ech(mixtpmrs1,mixtpmrs2)
      call ech(nim1,nim2)
      call echm(iocc1(1),iocc2(1),noac)
      return
      end
       subroutine ech(i,j)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      ii=i
      i=j
      j=ii
      return
      end
       subroutine echm(i,j,n)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      common/cd02w/yww
      dimension i(n),j(n)
      do k=1,n
c         print*,'k',k,n
         if(yww)print*,'ech n,k,i,j',n,k,i(k),j(k)
         ii=i(k)
         i(k)=j(k)
         j(k)=ii
      enddo
      return
      end
       function icar(c)
      character*1 c
      icar=ichar(c)
      if(icar.lt.0) icar=icar+256
      return
      end
 
 
       subroutine cd12s(nbadrt,
     *ninac,nta,nt10,nt20,it10,it20
     *,ista,isolt1,isolt2,ist1_1,ist1_2,ist2_1,ist2_2
     *,yspinalttp,nts,iplt10,iplt20
     *,iapret1,iapret2,naa,coef,ltf,ind256,norb)
c
c--------------------------------------------------------
c     longueur des adresses des T et P
c--------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/cd02w/yww
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      dimension yspinalttp(maxorb)
      dimension it10(2),it20(2)
      dimension nts(maxsym)
      dimension iplt10(2),iplt20(2)
      dimension ltf(naa)
c      dimension ntstot(0:maxsym)
      common/naadi/naadim
      character*1 coef(naadim,ind256)
      common /combs/  C(0:maxorbcas+4,-1:maxorbcas+4)
      integer c
c
c     longueur des adresses des trous
c
c      if(yww)print*,'entree cd12s,nta,nt10,nt20,isolt2'
c     *,nta,nt10,nt20,isolt2
      if(nta.eq.0) then
         nbadrt=naa
         do k=1,naa
            ltf(k)=1
         enddo
      else if(nta.eq.1) then
         if(nt10.eq.0) then
            if(isolt2.eq.0) then
               nbadrt=naa
         do k=1,naa
            ltf(k)=1
         enddo
            else  if(isolt2.eq.1.or.ist2_1.ne.ist2_2) then
               nbadrt=naa*nts(ista)
         do k=1,naa
            ltf(k)=nts(ista)
         enddo
c               if(yww)print*,'ista,nts(ista)',ista,nts(ista)
            else  if(isolt2.eq.2) then
c              alors il y a 2 zones dans le det 2
               nbadrt=0
               do kaa=1,naa
c                  if(yww)print*,'kaa,iplt20(1)',kaa,iplt20(1)
                  if(kaa.eq.1) then
                     jt20=it20(1)
                  else
                     jt20=icar(coef(kaa,iplt20(1)))
                     if(norb.ge.256)call decod2
     *               (jt20,coef(kaa,ind256),iplt20(1))
                  endif
                  nn=nts(ist2_1)
                  if(iapret2.eq.1) then
                     nbadrt=nbadrt+itorb(jt20)-1
                     ltf(kaa)=itorb(jt20)-1
                  else
                     nbadrt=nbadrt+max(0,nts(ista)-itorb(jt20))
                     ltf(kaa)=max(0,nts(ista)-itorb(jt20))
                  endif
               enddo
            endif
         else
c           nt10=1
            if(isolt1.eq.0) then
               if(yspinalttp(it10(1))) then
                  nbadrt=0
                  return
               endif
               nbadrt=naa
         do k=1,naa
            ltf(k)=1
         enddo
            else if(isolt1.eq.2) then
               if(isolt2.eq.0) then
                  nbadrt=naa
         do k=1,naa
            ltf(k)=1
         enddo
                  return
               endif
               if(isolt2.eq.1.or.ist2_1.ne.ist2_2) then
c                  if(yww)print*,'ist2_1,ist2_2',ist2_1,ist2_2
                  nbadrt=0
                  do kaa=1,naa
                     if(kaa.eq.1) then
                        jt10=it10(1)
                        jt20=it20(1)
                     else
                        if(nt10.ne.0)jt10=icar(coef(kaa,iplt10(1)))
                        if(nt20.ne.0)jt20=icar(coef(kaa,iplt20(1)))
                        if(norb.ge.256)call decod2
     *                  (jt10,coef(kaa,ind256),iplt10(1))
                        if(norb.ge.256)call decod2
     *                  (jt20,coef(kaa,ind256),iplt20(1))
                     endif
                     if(ist1_1.eq.ist1_2) then
                        if(iapret1.eq.1) then
                           idebadr=1
                           ifinadr=itorb(jt10)-1
                        else
                           idebadr=itorb(jt10)+1
                           ifinadr=nts(ista)
                        endif
                     else
                        idebadr=1
                        ifinadr=nts(ista)
                     endif
c                     if(yww)print*,'jt10,idebadr,ifinadr
c     *               ',jt10,idebadr,ifinadr
                     nbadrt=nbadrt+max(0,ifinadr-idebadr+1)
c                     if(yww)print*,'jt10,idebadr,ifinadr,nbadrt
c     *               ',jt10,idebadr,ifinadr,nbadrt
                      ltf(kaa)=max(0,ifinadr-idebadr+1)
                  enddo
                  return
               endif
c              on a alors isolt2=2
c               if(yww)print*,'coucou22',ist1_1,ist1_2,ist2_1,ist2_2
               nbadrt=0
               do kaa=1,naa
                  if(kaa.eq.1) then
                     jt10=it10(1)
                     jt20=it20(1)
                  else
                     if(nt10.ne.0) then
                        jt10=icar(coef(kaa,iplt10(1)))
                        if(norb.ge.256)call decod2
     *                  (jt10,coef(kaa,ind256),iplt10(1))
                     endif
                     if(nt20.ne.0) then
                        jt20=icar(coef(kaa,iplt20(1)))
                        if(norb.ge.256)call decod2
     *                  (jt20,coef(kaa,ind256),iplt20(1))
                     endif
                  endif
c                  if(yww)print*
                  if(ist1_1.eq.ist1_2) then
                     if(ist2_1.eq.ist2_2) then
                        if(iapret1.eq.1) then
                           if(iapret2.eq.1) then
                              idebadr=1
                              ifinadr=min(itorb(jt10),itorb(jt20))-1
                           else
                              idebadr=itorb(jt20)+1
                              ifinadr=itorb(jt10)-1
                           endif
                        else
                           if(iapret2.eq.1) then
                              idebadr=itorb(jt10)+1
                              ifinadr=itorb(jt20)-1
                           else
                              idebadr=max(itorb(jt10),itorb(jt20))+1
                              ifinadr=nts(ista)
                           endif
                        endif
                     else
                        if(iapret1.eq.1) then
                           idebadr=1
                           ifinadr=itorb(jt10)-1
                        else
                           idebadr=itorb(jt10)+1
                           ifinadr=nts(ista)
                        endif
                     endif
                  else
                     if(ist2_1.eq.ist2_2) then
                        if(iapret2.eq.1) then
                           idebadr=1
                           ifinadr=itorb(jt20)-1
                        else
                           idebadr=itorb(jt20)+1
                           ifinadr=nts(ista)
                        endif
                     else
                        idebadr=1
                        ifinadr=nts(ista)
                     endif
                  endif
                  nbadrt=nbadrt+max(0,ifinadr-idebadr+1)
                  ltf(kaa)=max(0,ifinadr-idebadr+1)
               enddo
c               if(yww)print*,'idebadr,ifinadr,nbadrt,jt10,jt20',
c     *         idebadr,ifinadr,nbadrt,jt10,jt20
            endif
         endif
      else if(nta.eq.2) then
         if(isolt1.eq.0) then
            nbadrt=ninac*naa
            do kaa=1,naa
               ltf(kaa)=ninac
            enddo
         else
            if(ista.eq.1) then
               nn=nts(ist1_1)
               nbadrt1=nn*(nn-1)/2
            else
               nbadrt1=nts(ist1_1)*nts(ist1_2)
            endif
            nbadrt=nbadrt1*naa
            do kaa=1,naa
               ltf(kaa)=nbadrt1
            enddo
         endif
      endif
      return
      end
 
       subroutine cd02s0(in,jn,kn,ln,a,esp1)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(iadris=500000,iadristp=200000)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      common/dimis/ iadris1,iadristp1,maxsps
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension esp1(iadri*2)
      dimension aa(iadris/2),iespaa(iadris),coef(iadris*4)
      character*1 coef
      common/naadi/naadim
      equivalence (aa(1),iespaa(1))
      equivalence (iespaa(1),coef(1))
c      dimension iespaa(iadris/2),coef(iadris/2)
c      dimension aa(50)
      naadim=1
      naa1=min(1,(iadris-iadristp-maxsps*3)/5)
      if(naa1.le.0) then
         print*,'dans cd02s0 iadris pas assez grand',
     *   ' iadris,iadristp,maxsps',iadris,iadristp,maxsps
         stop
      endif
      aa(1)=a
      if(norb.lt.256) then
         ind256=4
      else
         ind256=5
      endif
      call cd02s(in,jn,kn,ln,esp1,1,'      '
     *,0,0,0,0,iadris-3,iespaa(4),coef(9),aa,ind256)
      return
      end
 
