      subroutine cdr1(b,ab,v3,v2,
     *idebd,nn,ilond,ifil,mdet1
c     *,inddet
     *,lnt1,int1,is1)
      parameter(maxsym=8,ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      dimension idebd(norb,norb),ilond(maxsym)
      dimension iadrr3(ngru3),iadrr2(ngru3)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension b(maxl),ab(maxl),v3(maxl),v2(maxl)
c     common/bid2/ibidin
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common/test/itest(100)
      character*1 syspin
      common/sysp1/syspin
c     ibidin=inddet
      yw=.false.
      yw1=.false.
      if(itest(12).eq.1.and.icalc1.eq.0) then
         read(77)
         read(77)
         call saut(76,mdet1)
         return
      endif
 
c     if(yw1)write(6,*)'entree cdr1 icas',inddet
corr  write(6,*)'correc entree cdr1 icas',inddet
c
c     s'il y a la place (lbor=0)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      |       v3      |      v2       |
c
c     s'il n'y a pas la place (lbor=1)
c
c          |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c          |       b       |       v2      |
c     puis |       v3      |       v2      |
c     puis |       v3      |       ab      |
c
c      print*,'entree cdr1 ab',ab(1)
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd et ilond
c     lecture de iadrr
c      call lirbl(iadrr3,mdet1,76)
c     lecture de idebd
      call liri(idebd,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
c      print*,'lbor',lbor
c      print*,'entree cdr1 ab',ab(1),ab(326)
      call v1v2bis(b,iadrr3,v2,mdet1)
c      do k=1,mdet1
c         write(6,*)'cdr1 k,iadrr3(k)',k,iadrr3(k)
c      enddo
 
      do k=2,icalc1
         call back(76,mdet1)
         call v1v2bis(b((k-1)*maxl0+1),iadrr3,v2((k-1)*mdet1+1),mdet1)
      enddo
c      print*,'1entree cdr1 ab',ab(1) ,ab(326)
c     do k=1,mdet1
c        write(6,*)'cdr1 k,iadrr3(k)',k,iadrr3(k)
c     enddo
c     lecture des integrales <vvvv>
      do kk=1,mdet1
         v3(kk)=0.d0
      enddo
      do kk=mdet1+1,mdet1*icalc1
         v3(kk)=0.d0
      enddo
c      if(itest(12).eq.1.and.icalc1.eq.0) then
c        goto 100
c     endif
c      print*,'11entree cdr1 ab',ab(1) ,ab(326),mdet1
      do lm=1,lnt1+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(lm.eq.lnt1+1) lfini=int1
         do im=1,lfini
            in=inti(im)
            jn=intj(im)
            kn=intk(im)
            ln=intl(im)
            a=aaint(im)
 
c          yyyy=(ifil.eq.'CDI_3333'.and.in.lt.8)
c          yyyy=yyyy.or.(ifil.eq.'CDI_3333'.and.jn.lt.8)
c          yyyy=yyyy.or.(ifil.eq.'CDI_3333'.and.kn.lt.8)
c          yyyy=yyyy.or.(ifil.eq.'CDI_3333'.and.ln.lt.8)
c          if(yyyy) print*,'in,jn,kn,ln',in,jn,kn,ln
 
            if(a.eq.0.d0) goto 110
            if(syspin.ne.'0'.and.in.eq.jn.and.kn.eq.ln) a=a/2
            ij=its(itsym(in),itsym(jn))
            kj=its(itsym(kn),itsym(jn))
c--   int in jn kn ln
            ideb1=idebd(jn,in)
            l=idebd(ln,kn)-1
            !print*,'ij',ij
            ifin1=ideb1+ilond(ij)
            do k=ideb1,ifin1
               l=l+1
CIT17           if(itest(17).eq.l)write(6,'('' cdr1 it17'',i5,2f12.8)')
CIT17        *   k,a,v2(k)
CIT17           if(itest(17).eq.k)write(6,'('' cdr1 it17'',i5,2f12.8)')
CIT17        *   l,a,v2(l)
       if(l.eq.0.or.k.eq.0) then
          print*,'k,l',k,l
          print*,'in,jn,kn,ln',in,jn,kn,ln
          print*,'ilond',ilond(ij)
          call scripi(idebd,norb,norb,norb,norb,8)
       endif
               v3(l)=v3(l)+a*v2(k)
               v3(k)=v3(k)+a*v2(l)
            enddo
c--   multiracine
            do kk=2,icalc1
               incr=(kk-1)*mdet1
               ideb2=ideb1+incr
               ifin2=ifin1+incr
               l=idebd(ln,kn)-1+incr
               do k=ideb2,ifin2
                  l=l+1
                  v3(l)=v3(l)+a*v2(k)
                  v3(k)=v3(k)+a*v2(l)
               enddo
            enddo
c--   int kn jn in ln
            if(in.eq.kn.or.jn.eq.ln) goto 10
            ideb1=idebd(jn,kn)
            l=idebd(ln,in)-1
            ifin1=ideb1+ilond(kj)
            do k=ideb1,ifin1
               l=l+1
               v3(l)=v3(l)+a*v2(k)
               v3(k)=v3(k)+a*v2(l)
            enddo
c--   multiracine
            do kk=2,icalc1
               incr=(kk-1)*mdet1
               ideb2=ideb1+incr
               ifin2=ifin1+incr
               l=idebd(ln,in)-1+incr
               do k=ideb2,ifin2
                  l=l+1
                  v3(l)=v3(l)+a*v2(k)
                  v3(k)=v3(k)+a*v2(l)
               enddo
            enddo
 10         if(is1.eq.1.and.syspin.eq.'0') then
               if(ln.ne.kn.or.in.ne.jn) then
                  if(in.ne.ln.or.jn.ne.kn) then
c--               int ln kn jn in
                     ideb1=idebd(kn,ln)
                     l=idebd(in,jn)-1
                     ifin1=ideb1+ilond(ij)
                     do k=ideb1,ifin1
                        l=l+1
                        v3(l)=v3(l)+a*v2(k)
                        v3(k)=v3(k)+a*v2(l)
                     enddo
c--   multiracine
                     do kk=2,icalc1
                        incr=(kk-1)*mdet1
                        ideb2=ideb1+incr
                        ifin2=ifin1+incr
                        l=idebd(in,jn)-1+incr
                        do k=ideb2,ifin2
                           l=l+1
                           v3(l)=v3(l)+a*v2(k)
                           v3(k)=v3(k)+a*v2(l)
                        enddo
                     enddo
c--               int jn kn ln in
                     if(in.eq.kn.or.jn.eq.ln) goto 11
                     ideb1=idebd(kn,jn)
                     l=idebd(in,ln)-1
                     ifin1=ideb1+ilond(kj)
                     do k=ideb1,ifin1
                        l=l+1
                        v3(l)=v3(l)+a*v2(k)
                        v3(k)=v3(k)+a*v2(l)
                     enddo
c--   multiracine
                     do kk=2,icalc1
                        incr=(kk-1)*mdet1
                        ideb2=ideb1+incr
                        ifin2=ifin1+incr
                        l=idebd(in,ln)-1+incr
                        do k=ideb2,ifin2
                           l=l+1
                           v3(l)=v3(l)+a*v2(k)
                           v3(k)=v3(k)+a*v2(l)
                        enddo
                     enddo
 11                  continue
                  endif
               endif
            endif
 110        continue
         enddo
      enddo
c     transfert de v3 ordonne pour le produit dans ab
c     on relit iadrr
c      call back(76,mdet1)
c     backspace 76
c      call lirbl(iadrr2,mdet1,76)
c      if(yw)write(6,*)'ab avant v3v4'
c      if(yw)write(6,*)(ab(kk),kk=1,107)
c      print*,'2entree cdr1 ab',ab(1),ab(326)
c 100  continue
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
c      print*,'3entree cdr1 ab',ab(1),ndet,lbor,ab(326)
      call v3v4bis(ab,v3,iadrr2,mdet1,.true.)
      do k=2,icalc1
c         call back(76,mdet1)
         call v3v4bis(ab((k-1)*maxl0+1),v3((k-1)*mdet1+1),iadrr2,
     *   mdet1,.true.)
      enddo
c      if(lbor.eq.1) then
c          rewind 82
c          call ecr8bl(ab,nmulr,82)
c          rewind 81
c          call lir8bl(b,nmulr,81)
c       endif
c      if(yw)write(6,*)'ab apres v3v4'
c      if(yw)write(6,*)(ab(kk),kk=1,107)
      close(28)
      return
      end
       subroutine cdr1e(b,ab,v3,v2,
     *idebd,nn,ilond,ifil,mdet1,icas,lnt1,int1)
      parameter(maxsym=8,ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      dimension idebd(norb,norb),ilond(maxsym)
      dimension iadrr3(ngru3),iadrr2(ngru3)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension b(iadri),ab(iadri),v3(iadri),v2(iadri)
      common/tl/indi9(3,3),indi27(3,3)
      common/bid2/ibidin
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/opt/ihab,calcul
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      character*3 calcul
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common/test/itest(100)
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
      ibidin=icas
      yw=.false.
      yw1=.false.
      if(yw1)write(6,*)'entree cdr1e icas',icas
c     s'il y a la place (lbor=0)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      |       v3      |      v2       |
c
c     s'il n'y a pas la place (lbor=1)
c
c          |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c          |       b       |       v2      |
c     puis |       v3      |       v2      |
c     puis |       v3      |       ab      |
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit idebd et ilond
c     lecture de idebd
      call liri(idebd,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
      call v1v2bis(b,iadrr3,v2,mdet1)
      do k=2,icalc1
         call back(76,mdet1)
         call v1v2bis(b((k-1)*maxl0+1),iadrr3,v2((k-1)*mdet1+1),mdet1)
      enddo
      do kk=1,mdet1
         v3(kk)=0.d0
      enddo
      do kk=mdet1+1,mdet1*icalc1
         v3(kk)=0.d0
      enddo
      if(itest(12).eq.1.and.icalc1.eq.0) then
         goto 100
      endif
c---  boucles internes
c     lecture des integrales
      do lm=1,lnt1+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(lm.eq.lnt1+1) lfini=int1
         do im=1,lfini
            in=inti(im)
            kn=intk(im)
            if(icas.le.8) then
               jn=intj(im)
               ln=intl(im)
            else
               jn=intl(im)
               ln=intj(im)
            endif
            a=aaint(im)
            if(a.eq.0.d0) goto 110
            if(in.lt.jn) then
               iii=in
               in=jn
               jn=iii
               a=-a
            endif
            if(kn.lt.ln) then
               iii=kn
               kn=ln
               ln=iii
               a=-a
            endif
            ij=its(itsym(in),itsym(jn))
c--      int in jn kn ln
            if(yw) print*,'in,jn,kn,ln',in,jn,kn,ln
            ideb1=idebd(jn,in)
            l=idebd(ln,kn)-1
            ifin1=ideb1+ilond(ij)
            do k=ideb1,ifin1
               l=l+1
               v3(l)=v3(l)+a*v2(k)
               v3(k)=v3(k)+a*v2(l)
            enddo
c--   multiracine
            do kk=2,icalc1
               incr=(kk-1)*mdet1
               ideb2=ideb1+incr
               ifin2=ifin1+incr
               l=idebd(ln,kn)-1+incr
               do k=ideb2,ifin2
                  l=l+1
                  v3(l)=v3(l)+a*v2(k)
                  v3(k)=v3(k)+a*v2(l)
               enddo
            enddo
 110        continue
         enddo
      enddo
c     transfert de v3 ordonne pour le produit dans ab
 100  continue
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
      call v3v4bis(ab,v3,iadrr2,mdet1,.true.)
      do k=2,icalc1
         call v3v4bis(ab((k-1)*maxl0+1),v3((k-1)*mdet1+1),iadrr2,
     *   mdet1,.true.)
      enddo
      close(28)
      return
      end
       subroutine cdr1em(idebd,nn,ilond,ifil,iadrr,ab,mdet1,
     *icas,leiiii,ieiiii)
      parameter(maxsym=8)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      dimension idebd(norb,norb),ilond(maxsym),iadrr(iadri),ab(iadri)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/tl/indi9(3,3),indi27(3,3)
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |       ab      |
c
      if(yw1)write(6,*)'entree cdr1em   icas,mdet1,',icas,mdet1
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd et ilond
c     lecture de iadrr
      call lirbl(iadrr,mdet1,76)
      if(yw) then
         do k=1,mdet1
            print*,'cdr1em iadrr',k,iadrr(k)
         enddo
      endif
c     lecture de idebd
      call liri(idebd,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture des integrales <vvvv>
      do ln=1,leiiii+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.leiiii+1) lfini=ieiiii
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(yga2) then
               if(icas.eq.3.or.icas.eq.5.or.icas.eq.10.or.icas.eq.12
     *         .or.icas.eq.14) then
                  ifilg2=58
                  lg=lg2m
                  ig=ig2m
                  icg2=3
               else if(icas.eq.2.or.icas.eq.6.or.icas.eq.9
     *            .or.icas.eq.11.or.icas.eq.13) then
                  ifilg2=57
                  lg=lg2p
                  ig=ig2p
                  icg2=2
               endif
            endif
c         read(28,*) i,j,k,l,a
            if(yw1) then
               write(75,*)'cdr1em int spec lue',i,j,k,l,a,'$'
               call scril
            endif
            if(i.lt.j) then
               iii=i
               i=j
               j=iii
               a=-a
            endif
            if(k.lt.l) then
               iii=k
               k=l
               l=iii
               a=-a
            endif
            if(yga2)a=1.d0
            if(icas.le.8) then
               call cdr2m(i,j,k,l,a,idebd,ilond,iadrr,ab)
               if(yga2) call disin1(lg,ig,ifilg2,i,j,k,l,a,icg2)
            else
               call cdr2m(i,l,k,j,a,idebd,ilond,iadrr,ab)
               if(yga2) call disin1(lg,ig,ifilg2,i,l,k,j,a,icg2)
            endif
            if(yga2) then
               if(icas.eq.3.or.icas.eq.5.or.icas.eq.10.or.icas.eq.12
     *         .or.icas.eq.14) then
                  lg2m=lg
                  ig2m=ig
               else if(icas.eq.2.or.icas.eq.6.or.icas.eq.9
     *            .or.icas.eq.11.or.icas.eq.13) then
                  lg2p=lg
                  ig2p=ig
               endif
            endif
         enddo
      enddo
      close(28)
      return
      end
       subroutine cdr1m(idebd,nn,ilond,ifil,iadrr,ab,lllll,
     *iiiii,mdet1,is1)
      parameter(maxsym=8)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      dimension ab(iadri)
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd(norb,norb),ilond(maxsym),iadrr(iadri)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |      ab       |
c
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd et ilond
c     lecture de iadrr
      call lirbl(iadrr,mdet1,76)
      if(yw) then
         write(6,*)'cdr1m mdet1',mdet1
         do k=1,ndet
            write(6,*)'cdr1m k,iadrr(k)',k,iadrr(k)
         enddo
      endif
c     lecture de idebd
      call liri(idebd,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
 
      if(yw) then
         do k=1,norb
            write(6,1)'entree cdr1m idebd',(idebd(k,l),l=1,norb)
         enddo
         write(6,1)'entree cdr1m ilond',(ilond(l),l=1,nsym)
 1       format(a20,10i4)
      endif
 
 
 
c     lecture des integrales speciales
      do ln=1,lllll+1
         call lirin4(inti,intj,intk,intl,aaint,28)
         lfini=1024
         if(ln.eq.lllll+1) lfini=iiiii
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(yw1) then
               write(75,*)'int spec lue',i,j,k,l,a,'$'
               call scril
            endif
            if(yga2)a=1.d0
            call cdr2m(i,j,k,l,a,idebd,ilond,iadrr,ab)
            if(yga2) call disin1(lg2,ig2,56,i,j,k,l,a,1)
            if(k.ne.i.and.j.ne.l) then
               if(yga2)a=1.d0
               call cdr2m(k,j,i,l,a,idebd,ilond,iadrr,ab)
               if(yga2) call disin1(lg2,ig2,56,k,j,i,l,a,1)
            endif
            if(is1.eq.1) then
               if(l.ne.k.or.i.ne.j) then
                  if(i.ne.l.or.j.ne.k) then
                     if(yga2)a=1.d0
                     call cdr2m(l,k,j,i,a,idebd,ilond,iadrr,ab)
                     if(yga2) call disin1(lg2,ig2,56,l,k,j,i,a,1)
                     if(k.ne.i.and.j.ne.l) then
                        if(yga2)a=1.d0
                        call cdr2m(j,k,l,i,a,idebd,ilond,iadrr,ab)
                        if(yga2) call disin1(lg2,ig2,56,j,k,l,i,a,1)
                     endif
                  endif
               endif
            endif
         enddo
      enddo
      close(28)
      return
      end
       subroutine cdr2(in,jn,kn,ln,a,v3,v2,idebd,ilond)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension v3(iadri),v2(iadri),idebd(norb,norb),ilond(maxsym)
      common/test/itest(100)
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
c      common/bid2/inddet
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |      ab       |      v3       |      v2       | |
c                                                                 ()
c
      yw=.false.
      yw1=.false.
      if(yw)write(6,*)'entree cdr2'
      ideb1=idebd(jn,in)
      l=idebd(ln,kn)-1
      ifin1=ideb1+ilond(its(itsym(in),itsym(jn)))
c      do kk=1,norb
c         print*,'idebd',(idebd(kk,ll),ll=1,norb)
c      enddo
c      print*,'ilond',ilond
      if(yw)write(6,*)'ideb1,ifin1,l',ideb1,ifin1,l
      do k=ideb1,ifin1
         l=l+1
CIT17           if(itest(17).eq.l)write(6,'('' cdr2 it17'',i5,2f12.8)')
CIT17        *   k,a,v2(k)
CIT17           if(itest(17).eq.k)write(6,'('' cdr2 it17'',i5,2f12.8)')
CIT17        *   l,a,v2(l)
         v3(l)=v3(l)+a*v2(k)
         v3(k)=v3(k)+a*v2(l)
         if(yw)write(6,*)'v2,v3,a',v2(k),v3(l),a
         if(yw)write(6,*)'v2,v3,a',v2(l),v3(k),a
c         print*,'stocmd',k,l,a
cdcor
ccor          if(ibidr(k,1).eq.0) goto 20
ccor          if(ibidr(l,1).eq.0) goto 20
ccorc          if(yw)write(6,*)ibidr(k,1),ibidr(l,1)
ccor             minbid=min(ibidv(iabs(ibidr(k,1))),
ccor     *       ibidv(iabs(ibidr(l,1))))
ccor             maxbid=max0(ibidv(iabs(ibidr(k,1))),
ccor     *       ibidv(iabs(ibidr(l,1))))
ccorc         print*,'stocmd mma',minbid,maxbid,a
ccor         if(ibidv(iabs(ibidr(k,1))).eq.icor)
ccor     *   write(6,*)'correc cdr2',
ccor     *   a*v2(l),v2(l),ibidr(l,1)
ccor         if(ibidv(iabs(ibidr(k,1))).eq.icor)
ccor     *   write(6,*)'correc cdr2 v3',
ccor     *   v3(k)
ccor         if(ibidv(iabs(ibidr(l,1))).eq.icor)
ccor     *   write(6,*)'correc cdr2',
ccor     *   a*v2(k),v2(k),ibidr(k,1)
ccor         if(ibidv(iabs(ibidr(l,1))).eq.icor)
ccor     *   write(6,*)'correc cdr2 v3',
ccor     *   v2(l)
cfcor
 20      continue
      enddo
      return
      end
       subroutine cdr2i(a,v2,v3,long)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      dimension v2(*),v3(*)
      do k=1,long
         v3(k)=v3(k)+a*v2(k)
      enddo
      return
      end
 
       subroutine cdr2m(in,jn,kn,ln,a,idebd,ilond,iadrr,ab)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(ngru3=2048)
      real*4 d
      common/ver3/ itab(ngru3),jtab(ngru3),d(ngru3)
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension idebd(norb,norb),ilond(maxsym),iadrr(iadri),ab(iadri)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      COMMON/VER2/nelem
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |       ab      |
c
c
      yw1=.false.
      yw=.false.
c      yw=in.eq.6.and.jn.eq.7.and.kn.eq.6.and.ln.eq.8
      do k=1,norb
         if(yw)write(6,1)'entree cdr2m idebd',(idebd(k,l),l=1,norb)
      enddo
      if(yw)write(6,1)'entree cdr2m ilond',(ilond(l),l=1,nsym)
 1    format(a20,10i4)
      ideb1=idebd(jn,in)
c      write(6,*)jn,in,ideb1
      l=idebd(ln,kn)-1
      if(yw)write(6,*)'entree cdr2m in,jn,kn,ln',in,jn,kn,ln
c      if(yw) then
c         do k=1,140
c            write(6,*)'k,iadrr(k)',k,iadrr(k)
c         enddo
c      endif
      ifin1=ideb1+ilond(its(itsym(in),itsym(jn)))
      if(yw)print*,'jn,in,ideb1,ifin1',jn,in,ideb1,ifin1
      if(yw)print*,'ln,kn,l',jn,in,ideb1
      do k=ideb1,ifin1
         l=l+1
         if(yw)write(6,*)'cdr2m k,l',k,l,iadrr(k),iadrr(l)
         if(iadrr(k).eq.0) goto 2
         if(iadrr(l).eq.0) goto 2
         iadrrk=iabs(iadrr(k))
         iadrrl=iabs(iadrr(l))
         if(yga2) then
            aa=0.d0
            call stoga2(iadrrk,iadrrl,aa,ab)
            if(iadrr(k).gt.0) then
               if(iadrr(l).gt.0) then
                  a=a+aa
               else
                  a=a-aa
               endif
            else
               if(iadrr(l).gt.0) then
                  a=a-aa
               else
                  a=a+aa
               endif
            endif
c            print*,'appel stoga2',a,ab(1),ab(2)
         else
            if(iadrr(k).gt.0) then
               if(iadrr(l).gt.0) then
                  aa=a
               else
                  aa=-a
               endif
            else
               if(iadrr(l).gt.0) then
                  aa=-a
               else
                  aa=a
               endif
            endif
            call stover(iadrrk,iadrrl,aa)
         endif
 2       continue
      enddo
      return
      end
       subroutine cdr7m(idebd,nn,ilond,ifil,iadrr3,iadrr2,
     *lllll,iiiii,mdet1,ab)
      parameter(maxsym=8)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      dimension ab(iadri)
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      dimension iadrr2(iadri),iadrr3(iadri)
      dimension idebd(norb,norb),ilond(maxsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr2| iadrr3|      ab       |
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr3,iadrr2 et idebd et ilond
c     lecture de iadrr3 (determinants |i  a  +  +>
      call lirbl(iadrr3,mdet1,76)
      if(yw) then
         write(6,*)'cdr7m mdet1',mdet1
         do k=1,ndet
            write(6,*)'cdr7m k,iadrr3(k)',k,iadrr3(k)
         enddo
      endif
c     lecture de iadrr2 (determinants |i  a  -  ->
      call lirbl(iadrr2,mdet1,76)
      if(yw) then
         write(6,*)'cdr7m mdet1',mdet1
         do k=1,ndet
            write(6,*)'cdr7m k,iadrr2(k)',k,iadrr2(k)
         enddo
      endif
c     lecture de idebd
      call liri(idebd,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
      read(77)
      read(77)
c     lecture des integrales speciales 3311
      do ln=1,lllll+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.lllll+1) lfini=iiiii
         do in=1,lfini
            ii=inti(in)
            ij=intj(in)
            ia=intk(in)
            ib=intl(in)
            a=aaint(in)
c          read(28,*) ii,ij,ia,ib,a
            if(yw1) then
               write(75,*)'int spec lue',ii,ij,ia,ib,a,'$'
               call scril
            endif
            if(yga2)a=1.d0
            call cdr8m(ii,ia,ij,ib,a,idebd,ilond,iadrr3,iadrr2,ab)
            if(yga2) call disin1(lg2,ig2,56,ii,ia,ij,ib,a,1)
            if(ij.ne.ii.or.ia.ne.ib) then
               if(yga2)a=1.d0
               call cdr8m(ij,ib,ii,ia,a,idebd,ilond,iadrr3,iadrr2,ab)
               if(yga2) call disin1(lg2,ig2,56,ij,ib,ii,ia,a,1)
            endif
         enddo
      enddo
      close(28)
      return
      end
       subroutine cdr8m(in,jn,kn,ln,a,idebd,ilond,iadrr3,iadrr2,ab)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(ngru3=2048)
      real*4 d
      common/ver3/ itab(ngru3),jtab(ngru3),d(ngru3)
      common/dim/iadri ; integer(8) iadri
      dimension ab(iadri)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension idebd(norb,norb),ilond(maxsym)
      dimension iadrr2(iadri),iadrr3(iadri)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      COMMON/VER2/nelem
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr2|       | iadrr3|
c
c
      yw1=.false.
      yw=.false.
      do k=1,norb
         if(yw)write(6,1)'entree cdr8m idebd',(idebd(k,l),l=1,norb)
      enddo
      if(yw)write(6,1)'entree cdr8m ilond',(ilond(l),l=1,nsym)
 1    format(a20,10i4)
      ideb1=idebd(jn,in)
c      write(6,*)jn,in,ideb1
      l=idebd(ln,kn)-1
      if(yw)write(6,*)'entree cdr8m in,jn,kn,ln',in,jn,kn,ln
      if(yw) then
      endif
      ifin1=ideb1+ilond(its(itsym(in),itsym(jn)))
      if(yw)print*,'jn,in,ideb1,ifin1',jn,in,ideb1,ifin1
      if(yw)print*,'ln,kn,l',jn,in,ideb1
      do k=ideb1,ifin1
         l=l+1
         if(yw)write(6,*)'entree cdr8m k,l',k,l,iadrr3(k),iadrr2(l)
         if(iadrr3(k).eq.0) goto 2
         if(iadrr2(l).eq.0) goto 2
         iadrrk=iabs(iadrr3(k))
         iadrrl=iabs(iadrr2(l))
         isgn=1
         if(iadrr3(k).gt.0) then
            if(iadrr2(l).gt.0) then
               aa=a
            else
               aa=-a
            endif
         else
            if(iadrr2(l).gt.0) then
               aa=-a
            else
               aa=a
            endif
         endif
c         if(iadrr3(k)*iadrr2(l).gt.0) then
c            aa=a
c         else
c            aa=-a
c         endif
         call stover(iadrrk,iadrrl,aa)
 
 
c     erreur ! ab n'est pas un vecteur !
 
 
         if(yga2) call stoga2(iadrrk,iadrrl,aa,ab)
 2       continue
      enddo
      return
      end
       subroutine cdr7(b,ab,v3,v2,idebd,nn,ilond,ifil,
     *lllll,iiiii,mdet1)
      parameter(maxsym=8,ngru3=2048)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      dimension b(iadri),ab(iadri),v3(iadri),v2(iadri)
      common/opt/ihab,calcul
      character*3 calcul
      dimension iadrr2(ngru3),iadrr3(ngru3)
      dimension idebd(norb,norb),ilond(maxsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      character*1 syspin
      common/sysp1/syspin
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
ccor      common/bidvr2/ire
ccor      call lirbl(ibidr(1,1),mdet1,76)
ccor      call lirbl(ibidr(1,2),mdet1,76)
ccor      call back(76,mdet1)
ccor      call back(76,mdet1)
cccor      backspace 76
cccor      backspace 76
cfcor
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      | iadrr3|       |      v2       | |
c                           puis     |       v3      | iadrr2|
c                                                                 ()
c
      if(yw1)print*,'entree cdr7'
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
      ire=1
 1    continue
c ----on lit iadrr correspondant aux det +- et ++, idebd et ilond
c     (+- et -- au 2eme passage)
C      call lirbl(iadrr3,mdet1,76)
      if(ire.eq.0) goto 2
c     lecture de idebd
      call liri(idebd,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
      if(yw) then
         do kk=1,norb
            print*,'idebd',(idebd(kk,ll),ll=1,norb)
         enddo
         print*,'ilond',ilond
      endif
      read(77)
      read(77)
 2    continue
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
      call v1v2bis(b,iadrr3,v2,mdet1)
c      if(yw) then
c         write(6,*)'cdr7 mdet1',mdet1
c         do k=1,mdet1
c            write(6,*)'cdr7 k,iadrr3(k)',k,iadrr3(k)
c         enddo
c      endif
      if(ire.eq.0) then
         call back(76,mdet1)
         call back(76,mdet1)
      endif
c     lecture des integrales speciales 3311
      do kk=1,mdet1
         v3(kk)=0.d0
      enddo
      do ln=1,lllll+1
         call lirin4(inti,intj,intk,intl,aaint,28)
         lfini=1024
         if(ln.eq.lllll+1) lfini=iiiii
         do in=1,lfini
            ii=inti(in)
            ij=intj(in)
            ia=intk(in)
            ib=intl(in)
            a=aaint(in)
            if(a.eq.0.d0) goto 3
            if(syspin.ne.'0') a=a/2
            call cdr8(ii,ia,ij,ib,a,v3,v2,idebd,ilond)
            if(yw1) then
               write(75,*)'int spec lue',ifil,ii,ij,ia,ib,a,'cdr71$'
               call scril
            endif
            if(ij.ne.ii.or.ia.ne.ib) then
               if(yw1) then
                  write(75,*)'int spec lue',ifil,ii,ij,ia,ib,a,'cdr72$'
                  call scril
               endif
               call cdr8(ij,ib,ii,ia,a,v3,v2,idebd,ilond)
            endif
 3          continue
         enddo
      enddo
c     transfert de v3 ordonne pour le produit dans ab
c     on lit iadrr correspondant aux det +- et --
C      call lirbl(iadrr2,mdet1,76)
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
      call v3v4bis(ab,v3,iadrr2,mdet1,.false.)
      if(ire.eq.1) then
         call borlir(b)
         ire=0
         call back(76,mdet1)
         rewind 28
         goto 1
      endif
      call saut(76,mdet1)
      close(28)
      return
      end
       subroutine cdr8(in,jn,kn,ln,a,v3,v2,idebd,ilond)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension v3(iadri),v2(iadri),idebd(norb,norb),ilond(maxsym)
      common/test/itest(100)
cdcor
ccor  common/bidvr/ibidv(10000),ibidr(10000,20),icor
ccor      common/bidvr2/ire
cfcor
c      common/bid2/inddet
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |      ab       |      v3       |      v2       | |
c                                                                 ()
c
      yw=.false.
c      yw1=.false.
c      if(yw)write(6,*)'entree cdr8'
      ideb1=idebd(jn,in)
      l=idebd(ln,kn)-1
      ifin1=ideb1+ilond(its(itsym(in),itsym(jn)))
      if(yw)write(6,*)'ideb1,ifin1,l',ideb1,ifin1,l
 
c======pour gagner du temps. mais faux ! ========
c     call cdr8i(a,v3(l+1),v2(ideb1),ifin1-ideb1+1)
c     return
 
      do k=ideb1,ifin1
         l=l+1
         v3(l)=v3(l)+a*v2(k)
         if(yw)write(6,*)'v2,v3,a',v2(k),v3(l),a
      enddo
      return
      end
       subroutine cdr8i(a,v3,v2,long)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      dimension v2(*),v3(*)
      do k=1,long
         v3(k)=v3(k)+a*v2(k)
      enddo
      return
      end
       subroutine cdr7test(ii,jj,klim,ipass,ybon)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      yw=.false.
      if(ipass.eq.1) then
         ybon=ii.le.klim.and.jj.le.klim
      else if(ipass.eq.2) then
         ybon=ii.le.klim.and.jj.gt.klim
      else if(ipass.eq.3) then
         ybon=ii.gt.klim.and.jj.le.klim
      else if(ipass.eq.4) then
         ybon=ii.gt.klim.and.jj.gt.klim
      endif
      if(yw)print*,'cdr7test ii,jj,klim,ipass,ybon',
     * ii,jj,klim,ipass,ybon
      return
      end
 
       subroutine cdrlim(lim,klim,mdet1,npass,ninac1,numina,
     *nvirt1,numvir,idebd,ilond)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/test/itest(100)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      dimension numina(maxorb),numvir(maxorb),idebd(norb,norb)
      dimension ilond(maxsym)
c     recherche de la coupure si mdet1 > iadri
      yw=.false.
      klim=norb
      limite=iadri
      if(itest(57).ne.0) limite=min(itest(57),iadri)
      if(yw)print*,'mdet1,limite',mdet1,limite
      lim=mdet1
      npass=1
      if(icalc1.ne.1) return
      if(mdet1.gt.limite) then
         npass=4
         do kk=1,ninac1
            k=numina(kk)
            lim=idebd(k,numvir(1))-1
            do ll=1,nvirt1
               l=numvir(ll)
               kdeb=idebd(k,l)
               kfin=kdeb+ilond(its(itsym(k),itsym(l)))
               if(yw)print*,'k,l,lim,kdeb,kfin',k,l,lim,kdeb,kfin
               if(kdeb.le.limite.and.kfin.gt.limite) then
                  klim=k-1
                  kklim=kk
                  if(yw)print*,'klim,kklim',klim,kklim
                  goto 700
               endif
            enddo
         enddo
 700     continue
         if(yw)print*,'kklim,klim,lim',kklim,klim,lim
         if(yw)
     *   print*,'numina(kklim),numvir(1)',numina(kklim),numvir(1)
         do kk=kklim,ninac1
            k=numina(kk)
            do ll=1,nvirt1
               l=numvir(ll)
               idebd(k,l)=idebd(k,l)-lim
               idebd(l,k)=idebd(l,k)-lim
            enddo
         enddo
         if(yw)call scripi(idebd,norb,norb,norb,norb,10)
      endif
      end
