      subroutine mul1c(b,m)
c
c-------------------------------------------------------------------
c     subroutine de multiplication directe de la matrice par 1 vecteur
c     la dimension est ndet
c     le vecteur en donnee est b
c     le vecteur resultat est ab
c-------------------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      parameter (maxsym=8,maxorbcas=16)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b                        |
c
      common/opt/ihab,calcul
      character*3 calcul
      common/dim/iadri ; integer(8) iadri
      common /ijd/itab,dtab
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      dimension ITAB(NGRU3),DTAB(NGRU3)
      DIMENSION B(iadri*2)
      common/opc/ninc
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      common/pr/nprint,mprint(10)
      yw=.false.
      if(yw)print*,'entree mul1c'
c      mm=m2-m0-1
      if(itest(12).eq.1) then
         if(icalc(m-m0).eq.0) then
            call lire(b,m,ndet,21)
            nn=ndet
         else
c           multiracine
            do l=1,icalc(m-m0)
c               write(6,*)'mul1c l',l,icalc1,icalc(m-m0)
               call lire(b((l-1)*maxl0+1),m+l-1,ndet,21)
               if(mprint(1).eq.1)call scrida1
     *         ('b dans mul1c lect$',b((l-1)*maxl0+1),ndet)
            enddo
            nn=icalc(m-m0)*maxl0
         endif
      else
         call lire(b,m,ndet,21)
         nn=ndet
      endif
c       do k=1,ndet
c       print*,'bbbb',k,b(k),b(k+ndet)
c       enddo
c       print*,'dans mul1c iadri1',iadri1
      call mul2c(b,b(iadri1),m,nn)
      if(itest(21).eq.1) then
c        on ajoute dans le fichier MAT quelques termes a la matrice
         call mulmdd(b,b(iadri1),iadri1)
      endif
      if(yw)print*,'ecr dans mulc1',m
      call ecr(b(iadri1),m,ndet,22)
      return
      end
       subroutine mulmdd(b,ab,iadri1)
c
c-------------------------------------------------------------------
c     subroutine de multiplication d'une matrice additionnelle
c     sur file par 1 vecteur
c     le vecteur en donnee est b
c     le vecteur resultat est ab
c-------------------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      parameter (maxsym=8,maxorbcas=16)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b     |    ab      |
c
      DIMENSION B(iadri1),AB(iadri1)
      common /det/ndet,mdet(50),nbdet_cas
      common /ijd/itab,jtab,dtab
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
c--   on met b et ab a l'abri
      open(35,form='unformatted',file='BAB',status='unknown')
      write(35) ab
      write(35) b
c--   on remet b en ordre cipsi
      call reocip(b,ab,itab,ndet,2)
      do k=1,iadri1
         b(k)=ab(k)
         ab(k)=0.d0
      enddo
      rewind 83
441   read(83) itab,jtab,dtab
      NM=NGRU3
      IF(ITAB(NGRU3).EQ.-1) NM=JTAB(NGRU3)
      DO 442 KK=1,NM
      I=ITAB(KK)
      J=JTAB(KK)
      ab(I)=ab(I)+DTAB(KK)*b(J)
      ab(J)=ab(J)+DTAB(KK)*b(I)
c     print*,'kk,dtab(kk)',kk,dtab(kk)*2
c     print*,'abi',abi,ab(i)
      print*,'abj',ab(j)
 442  continue
      if(itab(ngru3).ge.0) goto 441
c--   on met deltaab en ordre casdi
      call reocip(ab,b,itab,ndet,1)
c--   on ajoute deltaab a ab
      rewind 35
      read(35) b
      do k=1,iadri1
         ab(k)=b(k)+ab(k)
      enddo
c--   on relit b qu'on avait mis a l'abri
      read(35) b
      close (35,status='delete')
      return
      end
       subroutine mul2c(b,ab,m,nn)
c
c-------------------------------------------------------------------
c     subroutine de multiplication directe de la matrice par 1 vecteur
c     la dimension est ndet
c     le vecteur en donnee est b
c     le vecteur resultat est ab
c-------------------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      parameter (maxsym=8,maxorbcas=16)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b     |    ab      |
c
      common/opt/ihab,calcul
      character*3 calcul
      common/dim/iadri ; integer(8) iadri
      common /ijd/itab,dtab
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      dimension ITAB(NGRU3),DTAB(NGRU3)
      DIMENSION B(iadri),AB(iadri)
      common/opc/ninc
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      yw=.false.
c     on met a zero le vecteur de sortie
c               call scrida1
c     *         ('b avant raz$',b,ndet)
c               call scrida1
c     *         ('b avant raz$',b(maxl0+1),ndet)
      DO 443 I=1,nn
      ab(I)=0.D0
 443  continue
c               call scrida1
c     *         ('b apres raz$',b,ndet)
c               call scrida1
c     *         ('b apres raz$',b(maxl0+1),ndet)
c
c     on multiplie
c
c     lecture des integrales pour cas a 2 differences
      open(81,file='B81',form='unformatted',status='unknown')
      call ecr8bl(b,nmulr,81)
      open(82,file='AB82',form='unformatted',status='unknown')
c      write(6,*)'b avant lirint dans mul1c'
c      ifin=0
c      do k=1,ndet,5
c         ideb=ifin+1
c         ifin=min(ndet,ideb+4)
c         write(6,1000)k,(b(kk),kk=ideb,ifin)
c      enddo
c      do k=ndet+1,ndet+ndet,5
c         ideb=ifin+1
c         ifin=min(ndet+ndet,ideb+4)
c         write(6,1000)k-ndet,(b(kk),kk=ideb,ifin)
c      enddo
c               call scrida1
c     *         ('b avant lirint$',b,ndet)
c               call scrida1
c     *         ('b avant lirint$',b(maxl0+1),ndet)
      call lirint(b)
      close(81,status='delete')
      close(82,status='delete')
c      do kkk=1,icalc1
c         call scrida1
c     *   ('ab dans mul1c fin2 $',ab(1+(kkk-1)*maxl0),ndet
c     &   )
c      enddo
c      if(mprint(1).eq.1)call scrida1
c     *('ab apres lirint dans mul1c$',esp1(iadri1),ndet)
c      write(6,*)'b apres lirint dans mul1c'
c      ifin=0
c      do k=1,ndet,5
c         ideb=ifin+1
c         ifin=min(ndet,ideb+4)
c         write(6,1000)k,(b(kk),kk=ideb,ifin)
c      enddo
c      write(6,*)'ab apres lirint dans mul1c'
c      ifin=0
c      do k=1,ndet,5
c         ideb=ifin+1
c         ifin=min(ndet,ideb+4)
c         write(6,1000)k,(ab(kk),kk=ideb,ifin)
c      enddo
c      do k=ndet+1,ndet+ndet,5
c         ideb=ifin+1
c         ifin=min(ndet+ndet,ideb+4)
c         write(6,1000)k,(ab(kk),kk=ideb,ifin)
c      enddo
c      do k=ndet+ndet+1,ndet+ndet+ndet,5
c         ideb=ifin+1
c         ifin=min(ndet+ndet+ndet,ideb+4)
c         write(6,1000)k,(ab(kk),kk=ideb,ifin)
c      enddo
c      do k=ndet+ndet+ndet+1,ndet+ndet+ndet+ndet,5
c         ideb=ifin+1
c         ifin=min(ndet+ndet+ndet+ndet,ideb+4)
c         write(6,1000)k,(ab(kk),kk=ideb,ifin)
c      enddo
c     lecture des determinants pour cas a 1 difference
c      write(6,*)'b avant dif1cd dans mul1c'
c      ifin=0
c      do k=1,ndet,5
c         ideb=ifin+1
c         ifin=min(ndet,ideb+4)
c         write(6,1000)k,(b(kk),kk=ideb,ifin)
c      enddo
      call diff1(b,ab)
c      write(6,*)'ab apres dif1cd dans mul1c'
c      ifin=0
c      do k=1,ndet,5
c         ideb=ifin+1
c         ifin=min(ndet,ideb+4)
c         write(6,1000)k,(ab(kk),kk=ideb,ifin)
c      enddo
c      do k=ndet+1,ndet+ndet,5
c         ideb=ifin+1
c         ifin=min(ndet+ndet,ideb+4)
c         write(6,1000)k,(ab(kk),kk=ideb,ifin)
c      enddo
      if(yw)write(6,*)'mul1c ab ordre adresses',(ab(kk),kk=1,ndet)
c-----on ajoute la contribution des elements diagonaux
c      do kkk=1,icalc1
c         call scrida1
c     *   ('ab dans mul1c fin1 $',ab(1+(kkk-1)*maxl0),ndet
c     &   )
c      enddo
c     on lit b
      call lire(b,m,ndet,21)
c     on lit les elements diagonaux et on corrige le vecteur de sortie
      rewind 25
      ifin=0
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb+ngru3-1,ndet)
         long=ifin-ideb+1
         call lir8(dtab,long,25)
         ii=0
         do l=ideb,ifin
            ii=ii+1
            ab(l)=ab(l)+dtab(ii)*b(l)
         enddo
      enddo
c      do kkk=1,icalc1
c         call scrida1
c     *   ('ab dans mul1c fin $',ab(1+(kkk-1)*maxl0),ndet
c     &   )
c      enddo
 
c     call scrida1('ab apres mul dans mul1c$',ab,ndet)
c     write(6,*)'ab apres mul dans mul1c'
c     ifin=0
c     do k=1,ndet+ndet,5
c        ideb=ifin+1
c        ifin=min(ndet+ndet,ideb+4)
c        write(6,1000)k,(ab(kk),kk=ideb,ifin)
c     enddo
 1000 format(i7,5(f10.6))
c
c--   multiracine : on ajoute a ab la quantite calculee en multiracine
      if(itest(12).eq.1) then
c      write(6,*)'m0,m,mm,m-m0,icalc(m-m0)',m0,m,mm,m-m0,icalc(m-m0)
c      write(6,*)'ndet',ndet
         if(icalc(m-m0).eq.0) then
            do k=1,ndet
               ab(k)=ab(k)+ab(m3*maxl0+k)
            enddo
         endif
      endif
c-----
c--   symetrie de spin
c      do k=0,m3
c         call syspi1(ab(k*maxl0+1),ndet)
c      enddo
c--   on ecrit le vecteur de sortie
      if(yw)write(6,*)'mul1c ab ordre cipsi',(ab(kk),kk=1,ndet)
      return
      end
       subroutine syspi11(ab,ndet)
c
c-------------------------------------------------------------------
c     sysmetrie de spin
c     on genere les coef des equivalents de spin
c-------------------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      parameter (maxsym=8)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c
      common/opt/ihab,calcul
      character*3 calcul
      common/dim/iadri ; integer(8) iadri
      DIMENSION ab(iadri)
      common /ijd/itab,dtab
      dimension ITAB(NGRU3),DTAB(NGRU3)
      character*1 syspin
      common /sysp1/syspin
c      dimension bid(1000),bid2(1000)
      yw=.false.
      if(yw)print*,'entree syspi11 syspin',syspin
      if(yw) then
         do k=1,ndet
            write(6,'('' ab'',i6,f12.8)')k,ab(k)
         enddo
      endif
      if(syspin.eq.'0') return
      if(syspin.eq.'+') then
         isyspi=1
      else
         isyspi=-1
      endif
      rewind 3
      ifin=0
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb+ngru3-1,ndet)
c        on lit le codage de la symetrie de spin
         call liri(itab,ngru3,3)
c        on corrige les coef
         if(yw) then
            write(6,*)'codage syspin'
            do kk=ideb,ifin
               write(6,*)'codage kk,itab(kk)',kk,itab(kk)
            enddo
         endif
         i=0
         do l=ideb,ifin
            i=i+1
            if(itab(i).gt.l) goto 1
            aa=ab(l)
            bb=ab(itab(i))
            ab(l)=aa+isyspi*bb
            ab(itab(i))=bb+isyspi*aa
 1          continue
c           if(yw)write(6,'('' syspin ab av/apr'',i6,2f12.8)')l,aa,
c     *      ab(l)
         enddo
      enddo
      if(yw) then
         do k=1,ndet
            write(6,'('' ab spin '',i6,f12.8)')k,ab(k)
         enddo
      endif
      return
      end
