      subroutine calro(va,vb)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      parameter(maxsym=8,maxorb=500,maxorbcas=16)
      parameter(maxne=maxorbcas+2,lungo=100)
      common/dim/ iadri
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ntn(maxorbcas+2),npn(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *ctps((maxne)*lungo*2),cex(lungo)
      dimension y(maxorb*2+1)
      common/mat/ roij(maxorb,maxorb)
      dimension roij1(maxorb,maxorb)
      dimension va(iadri),vb(iadri)
      dimension itab(2048)
      dimension iord(maxorb)
c la siguiente linea viene de la version SGI
      common/orbi/ngel(8),ndel(8),norbs(8),norb2
c      common/orbi/ngel(8),ndel(8),norbs(8)
      common/pr/nprint,mprint(10)
      LOGICAL BIDIA
      common/infdav/ alam(56),tau,twvec,twess,sint,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(56),ipresc,irest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,BIDIA,maxda2,ywvec,ytana
     *,yhmono,ydens,ywcas
      common/ronum/deltae,numero(2)
      character*2 iwspin(maxorb*2)
      common/cas_spin/isz0
      common /wvc/ iwspin
      dimension e(50)
      yw=.false.
      nel=ninac*2+nelac
      nelb=(nel-ms2)/2
      if(mod(-ms2,2)==0) then
         nela=nel-nelb
      else
         nela=(nel+ms2)/2+mod(-ms2,2)
      endif
      norbb=norb+mod(-ms2,2)
      do k=1,norb
         iwspin(k)='+ '
         iwspin(k+norb)='- '
      enddo
 
      do k=1,norb
         do l=1,norb
            roij(l,k)=0.d0
         enddo
      enddo
      print*,' '
      print*,'***********************************************'//
     *'******************************'
      print*,'         lecture des vecteurs'
c
c     symetries des 2 vecteurs, dimensions, energies
c
      rewind 60
      mdestod=0
      ndestod=0
      mdestod1=0
      ndestod1=0
      call venond1(60,ne,ntv,npv,ierr)
      if(yw)print*,'ntv,npv',(ntv(k),k=1,ne),(npv(k),k=1,ne)
      isa=1
      do k=1,ne-1
         isa=its(isa,itsym(ntv(k)))
         isa=its(isa,itsym(npv(k)))
      enddo
      if(ne.ne.0)isa=its(isa,itsym(ntv(ne)))
      if(ne.ne.0.and.npv(ne).ne.norb+norb+1) isa=its(isa,itsym(npv(ne)))
      read(10) ndeta,nvec
      read(10) (e(k),k=1,nvec)
      e1=e(numero(1))
      print*,'e1',e1
      do k=1,numero(1)-1
         read(10)
      enddo
      print*,'vecteur 1 : dimension =',ndeta,';     symetrie',isa
c
      rewind 61
      mdestod=0
      ndestod=0
      mdestod1=0
      ndestod1=0
      call venond1(61,ne,ntv,npv,ierr)
      if(yw)print*,'ntv,npv',(ntv(k),k=1,ne),(npv(k),k=1,ne)
      isb=1
      do k=1,ne-1
         isb=its(isb,itsym(ntv(k)))
         isb=its(isb,itsym(npv(k)))
      enddo
      if(ne.ne.0) then
         isb=its(isb,itsym(ntv(ne)))
         if(npv(ne).ne.norb+norb+1) isb=its(isb,itsym(npv(ne)))
      endif
      read(11) ndetb,nvec
      read(11) (e(k),k=1,nvec)
      e2=e(numero(2))
      print*,'e2',e2
      do k=1,numero(2)-1
         read(11)
      enddo
      print*,'vecteur 2 : dimension =',ndetb,';     symetrie',isb
      isro=its(isa,isb)
      print*,'numero',numero
      print*,'***********************************************'//
     *'******************************'
c
c     le vecteur 2 sera reconnu par ses adresses
c     il faut donc le reordonner
c
      call lir8(va,ndetb,11)
      print*,' VECTEUR 2'
      rewind 61
      mdestod=0
      ndestod=0
      mdestod1=0
      ndestod1=0
      call reocip(va,vb,itab,ndetb,1)
      do k=1,ndetb
         call venond1(61,ne,ntv,npv,ierr)
         if(dabs(vb(k)).gt.twvec) call wv(ne,ntv,npv,vb(k))
      enddo
c
c     vb contient le vecteur 2
c     on lit le vecteur 1
c
      call lir8(va,ndeta,10)
      print*,' VECTEUR 1'
      rewind 60
      mdestod=0
      ndestod=0
      mdestod1=0
      ndestod1=0
      do k=1,ndeta
         call venond1(60,ne,ntv,npv,ierr)
         if(dabs(va(k)).gt.twvec) call wv(ne,ntv,npv,va(k))
      enddo
      deltae=e2-e1
      print*,'deltae',deltae
c
c     signes
c
      call sgn(va,60,ndeta)
      call sgn(vb,61,ndetb)

c
c-------------------------------------------------------
c Matrice densite
c-------------------------------------------------------
c
       call dens(va,vb,its(isa,isb),roij)
c
c     on reordonne ro dans l'ordre des orbitales
c     sans tenir compte de l'ordre Occ/virt
c
!      print*,'ROIJ calro'
!      call script(roij,norb,norb,maxorb,maxorb)
      ii=0
      do is=1,nsym
         do k=1,norb
            if(itsym(k).eq.is) then
               ii=ii+1
               iord(ii)=k
            endif
         enddo
      enddo
      do i=1,norb
         do j=1,norb
            roij1((j),(i))=roij(iord(j),iord(i))
         enddo
      enddo
      if(nprint.ge.1) then
      print*,' '
      print*,' '
      print*,' '
      print*,' '
      print*,'MATRICE RO avant reintroduction du gel/del'
      call script(roij1,norb,norb,maxorb,maxorb)
      endif
c
c     on reintroduit les orbitales gelees et les orbitales detruites
c
      ysame=deltae.eq.0

      norb2=norb
      do is=1,nsym
         norb2=norb2+ngel(is)+ndel(is)
      enddo
      kk=0
      kp=0
      do is=1,nsym
         do k=1,ngel(is)
            kk=kk+1
            y(kk)=.false.
         enddo
         norbsp=norbs(is)-ngel(is)-ndel(is)
         do k=1,norbsp
            kk=kk+1
            kp=kp+1
            y(kk)=.true.
            iord(kp)=kk
         enddo
         do k=1,ndel(is)
            kk=kk+1
            y(kk)=.false.
         enddo
      enddo
      do k=1,norb2
         do l=1,norb2
            roij(l,k)=0.d0
         enddo
      enddo
      do k=1,norb
         do l=1,norb
            roij(iord(l),iord(k))=roij1(l,k)
         enddo
      enddo
      if(ysame) then
      kk=0
         do is=1,nsym
            do k=1,ngel(is)
               kk=kk+1
               roij(kk,kk)=2.d0
            enddo
            kk=kk+norbs(is)-ngel(is)
         enddo
      endif
 
 
 
      if(nprint.ge.1) then
      print*,' '
      print*,' '
      print*,' '
      print*,' '
      print*,'MATRICE RO apres reintroduction du gel/del'
      call script(roij,norb2,norb2,maxorb,maxorb)
      endif
      return
      kk=0
      kp=0
      do is=1,nsym
         norbsp=norbs(is)-ngel(is)-ndel(is)
         ll0=kk
         do k=1,ngel(is)
            kk=kk+1
            ll=ll0
            do l=1,norb2
               ll=ll+1
               roij(kk,ll)=0.d0
               roij(ll,kk)=0.d0
            enddo
            if(ysame)roij(kk,kk)=2.d0
         enddo
         ll0=kk
         lp0=kp
         do k=1,norbsp
            kk=kk+1
            kp=kp+1
            ll=ll0
            lp=lp0
            do l=1,norbsp
               ll=ll+1
               lp=lp+1
               roij(kk,ll)=roij1(kp,lp)
               roij(ll,kk)=roij1(lp,kp)
            enddo
         enddo
         ll0=kk
         do k=1,ndel(is)
            kk=kk+1
            ll=ll0
            do l=1,norb2
               ll=ll+1
               roij(kk,ll)=0.d0
               roij(ll,kk)=0.d0
            enddo
         enddo
      enddo
 
 
 
 
 
      return
      end
       subroutine sgnv(v,ifil,ndet)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorb=500,maxorbcas=16)
      parameter(maxne=maxorbcas+2,lungo=100)
      dimension v(ndet)
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ibid(maxorb*2)
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *ctps((maxne)*lungo*2),cex(lungo)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      yw=.false.
      mdestod=0
      ndestod=0
      mdestod1=0
      ndestod1=0
      rewind ifil
      do idet=1,ndet
c      yw=idet.eq.31
           if(ifil.eq.0)then
           print*,'ifil vale 0!!'
           stop
           end if
         call venond1(ifil,ne,ntv,npv,ierr)
c         print*,'ntv,npv',(ntv(k),k=1,ne),(npv(k),k=1,ne)
c        --on occupe jusqu'a noca0
         do k=1,noca0
            ibid(k)=k
            ibid(k+noca0)=k+norb
         enddo
         if(yw)print*,'ibid',(ibid(k),k=1,noca0+noca0)
c        --on place les part dans les trous (mode cipsi)
         nea=0
         do k=1,ne
            if(ntv(k).le.norb)ibid(ntv(k))=npv(k)
            if(ntv(k).le.norb) nea=nea+1
c            if(ntv(k).gt.norb)ibid(iorb(ntv(k))+noca0)=npv(k)
            if(ntv(k).gt.norb)ibid(ntv(k)-norb+noca0)=npv(k)
         enddo
         if(yw)print*,'2ibid',(ibid(k),k=1,noca0+noca0)
         neb=ne-nea
c        --eventuellement, on supprime l'electron qui va a l'infini
         do k=1,noca0+noca0
            if(ibid(k).eq.norb+norb+1) then
               do l=k+1,noca0+noca0
                  ibid(l-1)=ibid(l)
               enddo
            endif
         enddo
         if(yw)print*,'3ibid',(ibid(k),k=1,noca0+noca0)
c        --on reordonne
         call reor(noca+nocb,ibid,isgn)
         if(yw)print*,'4ibid',(ibid(k),k=1,noca0+noca0)
         if(yw)print*,'isgn',isgn
         v(idet)=v(idet)*isgn
         if(yw)print*,'idet,v(idet)',idet,v(idet)
       enddo
       return
       end
        subroutine wv(ne,itv,ipv,v)
      parameter(maxorb=500,maxorbcas=16)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      dimension itv(maxorbcas+2),ipv(maxorbcas+2)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      character*2 ibla2
      character*2 iwspin(maxorb*2)
      common /wvc/ iwspin
      character*50 detc
      ibla2='=>'
      ibla1=0
            ne1=ne
            if(ne.ne.0) then
               if(ipv(ne).eq.norb+norb+1)ne1=ne-1
            endif
               l=ne*10+5
               if(l.gt.50) then
                  write(6,6666)(IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *            ibla1,ibla2
                  detc(1:35)='                                   '
                  write(detc,6666)(IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                     write(6,'(a35,15x,3X,F11.7,i8)')detc(1:35)
     *               ,(v)
               else
                  detc(1:50)='                          '//
     *            '                        '
                  write(detc,6666) (IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *            ibla1,ibla2, (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                     write(6,'(a50,3X,F11.7,i8)')
     *               detc(1:50),v
               endif
6666        FORMAT(1X, 10(I3,A2))
      return
      end
 
 
