      subroutine col1(c,hoi)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (ngru3=2048)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      parameter (maxda3=300)
      common/dim/iadri ; integer(8) iadri
      common/opt/ihab,calcul
      character*3 calcul
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /det/ndet,mdet(50),nbdet_cas
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      common /cstes_hab/sttpp,sttp,stt,stpp,stp,st,spp,sp
      logical*1 bidia
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      dimension it(2),ip(2)
      dimension it3(2),ip3(2)
      dimension it4(maxorbcas+2),ip4(maxorbcas+2)
      dimension it2(maxorbcas+2),ip2(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      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/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/l40/ hmono(maxorb*(maxorb+1)/2),aj(maxorb*(maxorb+1)/2)
     *,ak(maxorb*(maxorb+1)/2),f(maxorb*(maxorb+1)/2),e0
     *,ajk(maxorb*(maxorb+1)/2),escf
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common /nin/i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
      dimension c(iadri),hoi(iadri)
      common/test/itest(100)
      dimension yh(maxorb+maxorb)
      dimension ysgnh(1024)
      dimension numaca(maxorbcas),numacb(maxorbcas)
      dimension isgna(maxorb,maxorb),isgnb(maxorb,maxorb)
      dimension ikl(1),jkl(1),it31l(1),ip31l(1)
      character*1280 namel
      equivalence (ik,ikl(1)),(jk,jkl(1)),(it31,it31l(1))
     *,(ip31,ip31l(1))
      yw=.false.
      yw1=.false.
c
C--------------------------------------------------------------
c     mise a zero et calculs preliminaires
C--------------------------------------------------------------
c
      it(1)=0
      it(2)=0
      ip(1)=0
      ip(2)=0
c--   mise a zero
      do i=1,ndet
         hoi(i)=0.d0
      end do
c
c--   numaca,numacb : occupation du CAS dans la reference
      if(ihab.eq.0) then
c        si on a un calcul sans habillage, la colonne 1 est
c        la colonne correspondant au determinant donne dans
c        deth. Deth doit donc etre donne
         call LECNAM('&DETH',namel,93,ierr,0)
         if(ierr.ne.0) goto 4
         call nameli(namel,ITH,'ITH',4)
         call nameli(namel,IPH,'IPH',4)
         neh=noac+2
         do k=1,noac+2
            if(ith(k).eq.0) then
               neh=k-1
               goto 4
            else
               if(ith(k).lt.0) ith(k)=-ith(k)+norb
               if(iph(k).lt.0) iph(k)=-iph(k)+norb
            endif
         enddo
 4       continue
         if(mod(-ms2,2).ne.0) iph(neh)=norb+norb+1
         call reor(neh,ith,idum)
         call reor(neh,iph,idum)
      endif
      call trad(neh,ith,iph,nca,numaca,ncb,numacb,nt2,it4,ispt,np2,ip4,
     *ispp,ierr)
      if(yw) then
         write(6,'(a15,15i3)')'numaca',(numaca(k),k=1,nca0)
         write(6,'(a15,15i3)')'numacb',(numacb(k),k=1,ncb0)
         write(6,'(a15,15i3)')'ith',(ith(k),k=1,neh)
         write(6,'(a15,15i3)')'iph',(iph(k),k=1,neh)
         write(6,'(a15,50l1)')'yha',(yh(k),k=1,norb)
         write(6,'(a15,50l1)')'yhb',(yh(k),k=1+norb,norb*2)
      endif
      call calyh(yh)
c
c--   preparation des signes
c     isgna(i,j) : nb d'el alpha entre les orb i+1 et j-1
      do i=1,norb
         do j=i,norb
            ii=min(isbrot(i),isbrot(j))
            jj=max0(isbrot(i),isbrot(j))
            iaij=0
            ibij=0
            do k=ii+1,jj-1
               if(yh(itorbs(k))) iaij=iaij+1
            enddo
            do k=ii+1,jj-1
               if(yh(itorbs(k)+norb)) ibij=ibij+1
            enddo
            isgna(i,j)=1-2*mod(iaij,2)
            isgna(j,i)=isgna(i,j)
            isgnb(i,j)=1-2*mod(ibij,2)
            isgnb(j,i)=isgnb(i,j)
         enddo
      enddo
      if(yw) then
         write(6,*)'itorbs',(itorbs(k),k=1,norb)
         write(6,*)'isbrot',(isbrot(k),k=1,norb)
         write(6,*)'isgna'
         do k=1,norb
            write(6,'(20i3)')(isgna(l,k),l=1,norb)
         enddo
         write(6,*)'isgnb'
         do k=1,norb
            write(6,'(20i3)')(isgnb(l,k),l=1,norb)
         enddo
      endif
c     write(6,*)'ica',ica
c     write(6,*)'icb',icb
 
c
c-----------------------------------------------------------------
c     extraction de la 1ere colonne et stockage de hoi*ci dans hoi
c-----------------------------------------------------------------
c
      if(gener.eq.'DDCI'.or.gener.eq.'DDC2') goto 1
      if(gener.eq.'MRDD'.or.gener.eq.'MRD2'.or.gener.eq.'MRM') goto 1
      if(gener.eq.'MRTD'.or.gener.eq.'MRT2'.or.gener.eq.'MRTM') goto 1
      open(42,file='CDI_3311',status='OLD',form='UNFORMATTED')
      if(yw)write(6,*)'l3311,le3311',l3311,le3311
      if(yw)write(6,*)'i3311,ie3311',i3311,ie3311
      do ln=1,l3311+1
         call lirin4(inti,intj,intk,intl,aaint,42)
         lfini=1024
         if(ln.eq.l3311+1) lfini=i3311
         do in=1,lfini
            it(1)=inti(in)
            it(2)=intj(in)
            ip(1)=intk(in)
            ip(2)=intl(in)
            if(yw)write(6,*)'it,ip',it,ip
            if(yw)write(6,*)'numaca',numaca
            if(yw)write(6,*)'numacb',numacb
            if(yw)write(6,*)'nca0,ncb0',nca0,ncb0
            a=aaint(in)
            if(mod(ncb0-nca0,2).ne.0) a=-a
            if(yw1)call wrdet(0,0,ica,icb,1,1,it(1),
     *      it(2),1,1,ip(1),ip(2))
            call adrdet(nca0,numaca,ncb0,numacb,2,it,0,2,ip,0,iadr,
     *      mhdum,mtdum)
 
            if(yw)write(6,*)'iadr,a',iadr,a
            hoi(iadr)=a
c     if(iadr.eq.21)print*,'1hoi(21)',hoi(21)
c     if(iadr.eq.24)print*,'1hoi(24)',hoi(24)
c            print*,'1i,hoi*c',iadr,hoi(iadr)
            if(yw)write(6,*)'int dir it,ip',it,ip,a
            if(it(1).ne.it(2).or.ip(1).ne.ip(2)) then
               iii=it(1)
               it(1)=it(2)
               it(2)=iii
               iii=ip(1)
               ip(1)=ip(2)
               ip(2)=iii
               if(yw1)call wrdet(0,0,ica,icb,1,1,it(1),
     *         it(2),1,1,ip(1),ip(2))
               call adrdet(nca0,numaca,ncb0,numacb,2,it,0,2,ip,0,iadr
     *         ,mhdum,mtdum)
               if(yw1)write(6,*)'iadr,a',iadr,a
               hoi(iadr)=a
c     if(iadr.eq.21)print*,'2hoi(21)',hoi(21)
c     if(iadr.eq.24)print*,'2hoi(24)',hoi(24)
c               print*,'2i,hoi*c',iadr,hoi(iadr)
               if(yw)write(6,*)'int dir it,ip',it,ip,a
            endif
         enddo
      enddo
      if(yw)write(6,*)'ech'
      close(42)
      open(42,file='CDE_3311',status='OLD',form='UNFORMATTED')
      do ln=1,le3311+1
         call lirin4(inti,intj,intk,intl,aaint,42)
         lfini=1024
         if(ln.eq.le3311+1) lfini=ie3311
         do in=1,lfini
            it(1)=inti(in)
            it(2)=intj(in)
            ip(1)=intk(in)
            ip(2)=intl(in)
            call reor(2,it,isgnt)
            call reor(2,ip,isgnp)
            if(yw)write(6,*)'int cde_3311 it,ip',it,ip
            a=aaint(in)*isgnt*isgnp
            if(yw1)call wrdet(0,0,ica,icb,2,0,it,
     *      idum,2,0,ip,idum)
            call adrdet(nca0,numaca,ncb0,numacb,2,it,2,2,ip,2,iadr,
     *      mhdum,mtdum)
            hoi(iadr)=a
            if(yw)write(6,*)'int ech it,ip',it,ip,a
            call adrdet(nca0,numaca,ncb0,numacb,2,it,-2,2,ip,-2,iadr,
     *      mhdum,mtdum)
            if(yw1)write(6,*)'iadr,a',iadr,a
            hoi(iadr)=a
            if(yw)write(6,*)'int ech it,ip',it,ip,a,hoi(iadr)
         enddo
      enddo
      close(42)
      if(yw)write(6,*)' '
c
c----------------------------------------------------
c**********************************************************************
c          Autres integrales  : <c-c-pp> <c-tpp> <ttc+p> <ttc+c+>
c          <c-tc+p> <c-tc+c+> <c-c-c+p> <c-c-c+c+>
c          dans la subroutine disint, ces integrales sont pour
c          l'instant toutes dans CDI_INT0 et CDE_INT0
c**********************************************************************
c                                                            |
c------------------------------------------------------------
c
c     1) Integrale directe
c
c------------------------------------------------------------
 1    if(yw)write(6,*)'debut de sc2casn int generales directes'
      open(27,file='CDI_INT0',status='OLD',form='UNFORMATTED')
      if(yw)write(6,*)'l0000,le0000',l0000,le0000
      if(yw)write(6,*)'i0000,ie0000',i0000,ie0000
      rewind 27
      iadrmax=0
c--   integrales generales
      llll=l0000
      iiii=i0000
      yf30=.false.
      ifil=27
      y2233=itest(38).eq.1.and.(l2233.ne.0.or.i2233.ne.0)
      y2323=itest(38).eq.1.and.(l2323.ne.0.or.i2323.ne.0)
      y1122=itest(39).eq.1.and.(l1122.ne.0.or.i1122.ne.0)
      y1212=itest(39).eq.1.and.(l1212.ne.0.or.i1212.ne.0)
      y2133=itest(40).eq.1.and.(l2133.ne.0.or.i2133.ne.0)
      y2313=itest(40).eq.1.and.(l2313.ne.0.or.i2313.ne.0)
      y2311=itest(41).eq.1.and.(l2311.ne.0.or.i2311.ne.0)
      y2131=itest(41).eq.1.and.(l2131.ne.0.or.i2131.ne.0)
      y211a=itest(42).eq.1.and.(l211a.ne.0.or.i211a.ne.0)
      y211b=itest(42).eq.1.and.(l211b.ne.0.or.i211b.ne.0)
      y211c=itest(42).eq.1.and.(l211c.ne.0.or.i211c.ne.0)
      y2213=itest(43).eq.1.and.(l2213.ne.0.or.i2213.ne.0)
      y2123=itest(43).eq.1.and.(l2123.ne.0.or.i2123.ne.0)
c      print*,'yy',y2233,y2323,y1122,y1212,y2133,y2313
c     *,y2311,y2131,y2213,y2123
      do k=1,1024
         ysgnh(k)=.false.
      enddo
 322  continue
      do ln=1,llll+1
         call lirin4(inti,intj,intk,intl,aaint,ifil)
         lfini=1024
         if(ln.eq.llll+1) lfini=iiii
         if(yw)write(6,*)'lfini',lfini
         if(lfini.eq.0) goto 324
         if(ihab.ne.0.and.ifil.ne.27) then
            call liry(ysgnh,1024,54)
         else
            do in=1,lfini
               ysgnh(in)=.false.
            enddo
         endif
         do 21 in=1,lfini
         it3(1)=inti(in)
         it3(2)=intj(in)
         ip3(1)=intk(in)
         ip3(2)=intl(in)
c         print*,'INT LUE',it3,ip3,aaint(in),ysgnh(in)
c         in1=0
c           if(it3(1).le.noca) in1=in1+1
c           if(it3(2).le.noca) in1=in1+1
c           if(ip3(1).le.noca) in1=in1+1
c           if(ip3(2).le.noca) in1=in1+1
c         if(in1.ne.2) goto 21
c----------------  test integrale correcte ( D+ possible)
c      si 2 trous ou C- et 2 part ou C+ : OK =>
c      il faut tester  les 8 combinaisons : 1) ijkl, 2) jilk, 3) kjil
c      4) ilkj, 5) lkji, 6) klij, 7) jkli, 8) lijk
c      si i=j et k=l on ne fait pas 2),6),7),8)
c----------------
         iii=1
         it(1)=it3(1)
         it(2)=it3(2)
         ip(1)=ip3(1)
         ip(2)=ip3(2)
         it3(2)=it3(2)+norb
         ip3(2)=ip3(2)+norb
         i1=it(1)
         i2=it(2)
         i3=ip(1)
         i4=ip(2)
         a=aaint(in)
         if(ysgnh(in)) a=-a
         if(yw)write(6,*)'int dir lue',i1,i2,i3,i4,a
c20       if(it(1).le.noca.and.it(2).le.noca.and.ip(1).gt.noca.
c    *    and.ip(2).gt.noca) then
 20      continue
         it3(1)=it(1)
         it3(2)=it(2)+norb
         ip3(1)=ip(1)
         ip3(2)=ip(2)+norb
CJose    Primera correccio per a introduir les MONOS
CJose    La estructura sera similar a la feta per al sc2cas.f
         if(yh(it3(1)).and.yh(it3(2)).and..not.yh(ip3(1)).
     *   and..not.yh(ip3(2))) then
c           write(6,*)'it3',it3,'   ip3',ip3
            call tradh(norb,2,it3,ip3,ne2,it2,ip2,neh,ith,iph,isgn)
            if(yw)write(6,*)'it2',(it2(k),k=1,2),'  ip2',(ip2(k),k=1,2)
            call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
            if(yw)write(6,*)'it4',(it4(k),k=1,nt2),'  ip4',
     *      (ip4(k),k=1,np2)
            a1=a
            if(gener.eq.'MRTM'.or.gener.eq.'MRM') then
               if(nt2.gt.1.or.np2.gt.1) goto 21
            endif
            if(gener.eq.'MRTD'.or.gener.eq.'DDCI') then
               if(nt2+np2.gt.3) goto 21
            endif
            if(gener.eq.'MRTD'.or.gener.eq.'DDCI') then
               if(nt2+np2.gt.2) goto 21
            endif
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr,
     *      mhdum,mtdum)
            isgn=isgna(it(1),ip(1))*isgnb(it(2),ip(2))
            if(yw)write(6,*)'isgndirn',isgn,it(1),ip(1),it(2),ip(2)
     *      ,isgna(it(1),ip(1)),isgnb(it(2),ip(2))
            if(yw)write(6,*) 'hoi abans e iadr', hoi(iadr),iadr
            if(yw)
     *      write(6,*) 'Valor de la integral a1 i c(iadr):',a1,c(iadr)
            hoi(iadr)=hoi(iadr)+a1*isgn
            if(yw)write(6,*) 'hoi despres e iadr', hoi(iadr),iadr
            if(yw)write(6,*)'int dir it,ip,iadr',it,ip,a1,iadr
            if(yw)write(6,*)'iadr,hoi(iadr)'
     *      ,iadr,hoi(iadr),c(iadr),a1,isgn
            if(iadrmax.lt.iadr)iadrmax=iadr
         else
            if(yhmono) then
CJose    Else per a comprovar si la integral deixada es bona per
CJose    a fer les MONOS
               yret=.TRUE.
 103           continue
               iaob=0
c         if(yw)write(6,*) 'La integral ijkl numero',in,' l he llegida
c     *   passant pel pas',iii
               if(it3(1).eq.ip3(1).or.it3(2).eq.ip3(2)) then
c          write(6,*) ' Li hem dit que yhmono es TRUE, integral nu',in
                  iii=11
c          write(6,*) 'Escriu els it3,ip3 antics'
c          write(6,*) 'it3',it3,' ip3',ip3
                  it31=it3(1)
                  ip31=ip3(1)
                  if(it3(1).eq.ip3(1)) then
                     if(itype(it(1)).eq.2.and.yh(it3(1))) then
c             write(6,*) 'Els indexs son del CAS i TRUE'
                        goto 115
                     else
c             write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                        goto 112
                     end if
 115                 continue
                     if(it3(2).eq.ip3(2)) then
c            write(6,*) 'Integral de la forma ijij'
                        goto 21
                     else
                        it31=it3(2)
                        ip31=ip3(2)
                        iaob=iaob+1
                     end if
                  else
                     if(itype(it(2)).eq.2.and.yh(it3(2))) then
c             write(6,*) 'Els indexs son del CAS i TRUE'
                        goto 116
                     else
c             write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                        goto 112
                     end if
 116                 continue
                  end if
c           write(6,*) ' He considerat sols els indexs diferents'
c           write(6,*) ' els indexs diferents son',it31,ip31
                  if(.not.yh(it31).and.yh(ip31)) then
                     ichng=it31
                     it31=ip31
                     ip31=ichng
                     if(.not.yh(it(1)).and.yh(ip(1))) then
                        kkk=it(1)
                        it(1)=ip(1)
                        ip(1)=kkk
                     end if
                     if(.not.yh(it(1)+norb).and.yh(ip(1)+norb)) then
                        kkk=it(2)
                        it(2)=ip(2)
                        ip(2)=kkk
                     end if
                  else
                     if(yh(it31).and..not.yh(ip31)) then
                        goto 102
                     else
                        if(yret) then
c             write(6,*) ' Aixina es un EPV, vaig a canviar alfa-beta'
                           goto 112
                        else
c             write(6,*) 'Es un EPV i el vote'
                           goto 21
                        end if
                     end if
 102                 continue
                  end if
c         write(6,*) 'Indexs en els que entra a tradh'
c         write(6,*) 'it3',it31,' ip3',ip31
                  call tradh(norb,1,it31l(1),ip31l(1),ne2,
     *            it2,ip2,neh,ith,iph
     *            ,isgn)
                  if(yw)write(6,*)'it2',(it2(k),k=1,2),'  ip2',(ip2(k),k
     &            =1,2)
c            write(6,*) 'Indexs en els que ix de tradh'
c            write(6,*) 'it2',(it2(k),k=1,ne2),' ip2',(ip2(k),k=1,ne2),
c     *      ' ne2=',ne2
                  call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2
     &            ,ip4,
     *            ispp,ierr)
                  a1=a
c            write(6,*) ' El determinant buscat es una ',ne2,' excitacio
                  call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *            iadr
     *      ,mhdum,mtdum)
c            write(6,*) 'i l adresse es',iadr
                  if(iaob.eq.0) then
                     isgn=isgna(it31,ip31)
c             write(6,*) ' He llegit alfa'
                  else
                     it3b1=it31-norb
                     ip3b1=ip31-norb
                     isgn=isgnb(it3b1,ip3b1)
c             write(6,*) ' He llegit beta'
                  end if
c            write(6,*) 'hoi abans e iadr', hoi(iadr),iadr
                  hoi(iadr)=hoi(iadr)+a1*isgn
c     if(iadr.eq.21)print*,'6hoi(21)',hoi(21)
c     if(iadr.eq.24)print*,'6hoi(24)',hoi(24)
c            write(6,*) 'hoi despres e iadr', hoi(iadr),iadr
                  if(yw)write(6,*)'int dir it,ip,iadr',it,ip,a1,iadr
                  if(yw)write(6,*)'iadr,hoi(iadr)'
     *            ,iadr,hoi(iadr),c(iadr),a1,isgn
                  if(iadrmax.lt.iadr)iadrmax=iadr
c            write(6,*) 'hoi,a1,c(iadr),isg,coef',hoi(iadr),a1
c     *      ,c(iadr),isgn,coef
 112              continue
                  ichgnt=it3(1)
                  ichgnp=ip3(1)
                  it3(1)=it3(2)-norb
                  ip3(1)=ip3(2)-norb
                  it3(2)=ichgnt+norb
                  ip3(2)=ichgnp+norb
                  kkk=it(1)
                  it(1)=it(2)
                  it(2)=kkk
                  kkk=ip(1)
                  ip(1)=ip(2)
                  ip(2)=kkk
c             print*, 'it, ip apres',it,ip
c             write(6,*) ' Indexs canviats'
c             write(6,*) 'it3(1)=',it3(1),' it3(2)=',it3(2)
c             write(6,*) 'ip3(1)=',ip3(1),' ip3(2)=',ip3(2)
                  if(yret) then
                     yret=.FALSE.
                     goto 103
                  end if
                  goto 21
               end if
            end if
         endif
         iii=iii+1
         if(iii.eq.2) then
            if(it(1).ne.it(2).or.ip(1).ne.ip(2)) then
               it(1)=i2
               it(2)=i1
               ip(1)=i4
               ip(2)=i3
               goto 20
            else
               iii=iii+1
            endif
         endif
         if(iii.eq.3) then
            it(1)=i3
            it(2)=i2
            ip(1)=i1
            ip(2)=i4
            goto 20
         endif
         if(iii.eq.4) then
            it(1)=i1
            it(2)=i4
            ip(1)=i3
            ip(2)=i2
            goto 20
         endif
         if(iii.eq.5) then
            it(1)=i4
            it(2)=i3
            ip(1)=i2
            ip(2)=i1
            goto 20
         endif
         if(iii.eq.6) then
            if(it(1).ne.it(2).or.ip(1).ne.ip(2)) then
               it(1)=i3
               it(2)=i4
               ip(1)=i1
               ip(2)=i2
               goto 20
            else
               iii=iii+1
            endif
         endif
         if(iii.eq.7) then
            if(it(1).ne.it(2).or.ip(1).ne.ip(2)) then
               it(1)=i2
               it(2)=i3
               ip(1)=i4
               ip(2)=i1
               goto 20
            else
               iii=iii+1
            endif
         endif
         if(iii.eq.8) then
            if(it(1).ne.it(2).or.ip(1).ne.ip(2)) then
               it(1)=i4
               it(2)=i1
               ip(1)=i2
               ip(2)=i3
               goto 20
            else
               iii=iii+1
            endif
         endif
 21      continue
 324     continue
      enddo
      if(yw)print*,'yf30',yf30
      if(yf30) close(30)
      if(yf30) close(54)
      if(y2233) then
         y2233=.false.
         llll=l2233
         iiii=i2233
         open(30,status='old',form='unformatted',file='CDI_2233')
         open(54,status='old',form='unformatted',file='HDI_2233')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2323) then
         y2323=.false.
         llll=l2323
         iiii=i2323
         open(30,status='old',form='unformatted',file='CDI_2323')
         open(54,status='old',form='unformatted',file='HDI_2323')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y1122) then
         y1122=.false.
         llll=l1122
         iiii=i1122
         open(30,status='old',form='unformatted',file='CDI_1122')
         open(54,status='old',form='unformatted',file='HDI_1122')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y1212) then
         y1212=.false.
         llll=l1212
         iiii=i1212
         open(30,status='old',form='unformatted',file='CDI_1212')
         open(54,status='old',form='unformatted',file='HDI_1212')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2133) then
         y2133=.false.
         llll=l2133
         iiii=i2133
         open(30,status='old',form='unformatted',file='CDI_2133')
         open(54,status='old',form='unformatted',file='HDI_2133')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2313) then
         y2313=.false.
         llll=l2313
         iiii=i2313
         open(30,status='old',form='unformatted',file='CDI_2313')
         open(54,status='old',form='unformatted',file='HDI_2313')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2311) then
         y2311=.false.
         llll=l2311
         iiii=i2311
         open(30,status='old',form='unformatted',file='CDI_2311')
         open(54,status='old',form='unformatted',file='HDI_2311')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2131) then
         y2131=.false.
         llll=l2131
         iiii=i2131
         open(30,status='old',form='unformatted',file='CDI_2131')
         open(54,status='old',form='unformatted',file='HDI_2131')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y211a) then
         y211a=.false.
         llll=l211a
         iiii=i211a
         open(30,status='old',form='unformatted',file='CDI_211a')
         open(54,status='old',form='unformatted',file='HDI_211a')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y211b) then
         y211b=.false.
         llll=l211b
         iiii=i211b
         open(30,status='old',form='unformatted',file='CDI_211b')
         open(54,status='old',form='unformatted',file='HDI_211b')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y211c) then
         y211c=.false.
         llll=l211c
         iiii=i211c
         open(30,status='old',form='unformatted',file='CDI_211c')
         open(54,status='old',form='unformatted',file='HDI_211c')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2213) then
         y2213=.false.
         llll=l2213
         iiii=i2213
         open(30,status='old',form='unformatted',file='CDI_2213')
         open(54,status='old',form='unformatted',file='HDI_2213')
         yf30=.true.
         ifil=30
         goto 322
      endif
      if(y2123) then
         y2123=.false.
         llll=l2123
         iiii=i2123
         open(30,status='old',form='unformatted',file='CDI_2123')
         open(54,status='old',form='unformatted',file='HDI_2123')
         yf30=.true.
         ifil=30
         goto 322
      endif
c        write(6,*) ln,lfini
c        write(6,*) ' PARAT directe'
CJose   Ara faig el mateix ab les integrals directe+intercanvi
c
c     2) Integrale directe + echange
c      open(33,file='CDE_INT0',status='OLD',form='UNFORMATTED')
      rewind 33
      if(yw)write(6,*)'debut de sc2cas int directe+ech'
      llll=le0000
      iiii=ie0000
      yf30=.false.
      ifil=33
      ye2233=itest(38).eq.1.and.(le2233.ne.0.or.ie2233.ne.0)
      ye2323=itest(38).eq.1.and.(le2323.ne.0.or.ie2323.ne.0)
      ye1122=itest(39).eq.1.and.(le1122.ne.0.or.ie1122.ne.0)
      ye1212=itest(39).eq.1.and.(le1212.ne.0.or.ie1212.ne.0)
      ye2133=itest(40).eq.1.and.(le2133.ne.0.or.ie2133.ne.0)
      ye2313=itest(40).eq.1.and.(le2313.ne.0.or.ie2313.ne.0)
      ye2311=itest(41).eq.1.and.(le2311.ne.0.or.ie2311.ne.0)
      ye2131=itest(41).eq.1.and.(le2131.ne.0.or.ie2131.ne.0)
      ye2213=itest(43).eq.1.and.(le2213.ne.0.or.ie2213.ne.0)
      ye2123=itest(43).eq.1.and.(le2123.ne.0.or.ie2123.ne.0)
c      print*,'ye',ye2233,ye2323,ye1122,ye1212,ye2133,ye2313
c     *,ye2311,ye2131,ye2213,ye2123
 323  continue
      do ln=1,llll+1
         call lirin4(inti,intj,intk,intl,aaint,ifil)
         lfini=1024
         if(ln.eq.llll+1) lfini=iiii
         if(yw)write(6,*)'lfini',lfini
         if(lfini.eq.0) goto 325
         if(ihab.ne.0.and.ifil.ne.33) then
            call liry(ysgnh,1024,54)
         else
            do in=1,lfini
               ysgnh(in)=.false.
            enddo
         endif
         do 22 in=1,lfini
         it3(1)=inti(in)
         it3(2)=intj(in)
         ip3(1)=intk(in)
         ip3(2)=intl(in)
c         print*,'INT ECH LUE',it3,ip3,aaint(in),ysgnh(in)
c----------------  test integrale correcte ( D+ possible)
c      si 2 trous ou C- et 2 part ou C+ : OK =>
c      il faut tester  les 8 combinaisons : 1) ijkl, 2) -jikl, 3) -ijlk
c      4) jilk, 5) klij, 6) -lkij, 7) -klji, 8) lkji
c      si i=j OU k=l on saute
c      si i>j OU k>l on saute
c----------------
         iii=1
         it(1)=it3(1)
         it(2)=it3(2)
         ip(1)=ip3(1)
         ip(2)=ip3(2)
         i1=it(1)
         i2=it(2)
         i3=ip(1)
         i4=ip(2)
         a=aaint(in)
         if(ysgnh(in)) a=-a
         if(yw)write(6,*)'int d.e lue',i1,i2,i3,i4,a
c         write(6,*)'int d.e lue',i1,i2,i3,i4,a
         a1=a
 23      continue
         if(it(1).eq.it(2).or.ip(1).eq.ip(2)) goto 22
         if(it(1).gt.it(2).or.ip(1).gt.ip(2)) goto 24
CJose    Primera correccio per a introduir les MONOS
c         write(6,*) 'La integral ijkl numero',in,' l he llegida
c     *   passant pel pas ',iii
c         write(6,*) ' Indexs abans de considerar res'
c         write(6,*) 'it',it,' ip',ip
         if(yhmono) then
c            write(6,*) 'Li hem dit que yhmono es TRUE.Cas ALFA'
            if(it(1).eq.ip(1)) then
               if(itype(it(1)).eq.2.and.yh(it(1))) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                  goto 215
               else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                  goto 316
               end if
 215           continue
               it3(1)=it(2)
               ip3(1)=ip(2)
               neth=1
               yOK=yh(it(2)).and..not.yh(ip(2))
c                mm=1
            else
               if(it(2).eq.ip(2)) then
                  if(itype(it(2)).eq.2.and.yh(it(2))) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                     goto 216
                  else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                     goto 316
                  end if
 216              continue
                  it3(1)=it(1)
                  ip3(1)=ip(1)
                  neth=1
                  yOK=yh(it(1)).and..not.yh(ip(1))
c                mm=1
               else
                  if(it(1).eq.ip(2)) then
                     if(itype(it(1)).eq.2.and.yh(it(1))) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                        goto 217
                     else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                        goto 316
                     end if
 217                 continue
                     it3(1)=it(2)
                     ip3(1)=ip(1)
                     neth=1
                     yOK=yh(it(2)).and..not.yh(ip(1))
c                mm=1
                  else
                     if(it(2).eq.ip(1)) then
                        if(itype(it(2)).eq.2.and.yh(it(2))) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                           goto 218
                        else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                           goto 316
                        end if
 218                    continue
                        it3(1)=it(1)
                        ip3(1)=ip(2)
                        neth=1
                        yOK=yh(it(1)).and..not.yh(ip(2))
c                mm=1
                     else
                        yOK=yh(it(1)).and.yh(it(2)).and..not.yh(ip(1)).
     *                  and..not.yh(ip(2))
                        neth=2
                        it3(1)=it(1)
                        it3(2)=it(2)
                        ip3(1)=ip(1)
                        ip3(2)=ip(2)
c                mm=2
                     endif
                  endif
               endif
            endif
         else
            yOK=yh(it(1)).and.yh(it(2)).and..not.yh(ip(1)).
     *      and..not.yh(ip(2))
            neth=2
            it3(1)=it(1)
            it3(2)=it(2)
            ip3(1)=ip(1)
            ip3(2)=ip(2)
c            mm=2
         end if
c          write(6,*) 'neth=',neth
c          write(6,*) 'Escriu els indexs antics'
c          write(6,*) 'it3',it3,' ip3',ip3
         if(yOK) then
c           write(6,*)' Indexs en els que entra a tradh'
c           write(6,*)'it3',(it3(k),k=1,neth),' ip3',(ip3(k),k=1,neth)
            call tradh(norb,neth,it3,ip3,ne2,it2,ip2,neh,ith,iph,isgn)
c           write(6,*)' Indexs en els que ix de tradh'
c           write(6,*)'it2',(it2(k),k=1,ne2),' ip2',(ip2(k),k=1,ne2)
            call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
            if(gener.eq.'MRTM'.or.gener.eq.'MRM') then
               if(nt2.gt.1.or.np2.gt.1) goto 22
            endif
            if(gener.eq.'MRTD'.or.gener.eq.'DDCI') then
               if(nt2+np2.gt.3) goto 22
            endif
            if(gener.eq.'MRTD'.or.gener.eq.'DDCI') then
               if(nt2+np2.gt.2) goto 22
            endif
c           write(6,*) 'El determinant buscat es una',ne2,' excitacio'
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
c           write(6,*) 'i l adresse es',iadr
cj          print*,'it(1),ip(1),it(2),ip(2),isgna(it(1),ip(1)),
cj     *isgna(it(2),ip(2))',it(1),ip(1),it(2),ip(2),isgna(it(1),ip(1))
cj     *,isgna(it(2),ip(2))
            if(neth.eq.2) then
               isgn2=isgna(it(1),ip(1))*isgna(it(2),ip(2))
               jt1=(it(1))
               jt2=(it(2))
               jp1=(ip(1))
               jp2=(ip(2))
               if(jt1.gt.jt2)isgn2=-isgn2
               if(jp1.gt.jp2)isgn2=-isgn2
            else
               isgn2=isgna(it3(1),ip3(1))
               if(yw)print*,'it3,ip3,isgn2',it3(1),ip3(1),isgn2
            endif
            jt1=isbrot(it(1))
            jt2=isbrot(it(2))
            jp1=isbrot(ip(1))
            jp2=isbrot(ip(2))
            if(jt1.ne.jp1.and.jt1.ne.jp2.and.jt2.ne.jp1.and.jt2.ne.jp2)
     *      then
               if((jt2-jt1)*(jt2-jp1)*(jp2-jt1)*(jp2-jp1).lt.0)
     *         isgn2=-isgn2
            endif
            if(jt1.eq.jp1.or.jt2.eq.jp2) isgn2=-isgn2
            isgn=isgn2
c            write(6,*) 'hoi abans e iadr', hoi(iadr),iadr
            if(yw)print*,'a1',a1
            hoi(iadr)=hoi(iadr)+a1*isgn
            if(yw)write(6,*)'iadr,hoi(iadr)'
     *      ,iadr,hoi(iadr),c(iadr),a1,isgn
            if(yw)write(6,*)'int ech it,ip',it,ip,a1
            if(iadrmax.lt.iadr)iadrmax=iadr
         endif
 316     continue
         if(yhmono) then
            if(it(1).eq.ip(1)) then
               if(itype(it(1)).eq.2.and.yh(it(1)+norb)) then
                  goto 220
               else
                  goto 22
               end if
 220           continue
               it3(1)=it(2)+norb
               ip3(1)=ip(2)+norb
               neth=1
               yOK=yh(it(2)+norb).and..not.yh(ip(2)+norb)
c                mm=1
            else
               if(it(2).eq.ip(2)) then
                  if(itype(it(2)).eq.2.and.yh(it(2)+norb)) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                     goto 221
                  else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                     goto 22
                  end if
 221              continue
                  it3(1)=it(1)+norb
                  ip3(1)=ip(1)+norb
                  neth=1
                  yOK=yh(it(1)+norb).and..not.yh(ip(1)+norb)
c                mm=1
               else
                  if(it(1).eq.ip(2)) then
                     if(itype(it(1)).eq.2.and.yh(it(1)+norb)) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                        goto 222
                     else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                        goto 22
                     end if
 222                 continue
                     it3(1)=it(2)+norb
                     ip3(1)=ip(1)+norb
                     neth=1
                     yOK=yh(it(2)+norb).and..not.yh(ip(1)+norb)
c                mm=1
                  else
                     if(it(2).eq.ip(1)) then
                        if(itype(it(2)).eq.2.and.yh(it(2)+norb)) then
c                   write(6,*) 'Els indexs son del CAS i TRUE'
                           goto 223
                        else
c                   write(6,*) 'Els indexs NO son del CAS i/o NO TRUE'
                           goto 22
                        end if
 223                    continue
                        it3(1)=it(1)+norb
                        ip3(1)=ip(2)+norb
                        neth=1
                        yOK=yh(it(1)+norb).and..not.yh(ip(2)+norb)
c                mm=1
                     else
                        yOK=yh(it(1)+norb).and.yh(it(2)+norb).and.
     *                  .not.yh(ip(1)+norb).and..not.yh(ip(2)+norb)
                        neth=2
                        it3(1)=it(1)+norb
                        it3(2)=it(2)+norb
                        ip3(1)=ip(1)+norb
                        ip3(2)=ip(2)+norb
c                mm=2
                     endif
                  endif
               endif
            endif
         else
c          write(6,*) 'Li hem dit que yhmono es FALSE'
            yOK=yh(it(1)+norb).and.yh(it(2)+norb).and.
     *      .not.yh(ip(1)+norb).and..not.yh(ip(2)+norb)
            neth=2
            it3(1)=it(1)+norb
            it3(2)=it(2)+norb
            ip3(1)=ip(1)+norb
            ip3(2)=ip(2)+norb
c            mm=2
         end if
         if(yw) then
            write(6,*) 'neth=',neth
            write(6,*) ' Escriu els indexs antics'
            write(6,*) 'it',it,' ip',ip
            write(6,*) 'it3',it3,' ip3',ip3
         endif
         if(yOK) then
c            write(6,*) 'Indexs en els que entra a tradh'
c            write(6,*) 'it3',(it3(k),k=1,neth),' ip3',(ip3(k),k=1,neth)
            call tradh(norb,neth,it3,ip3,ne2,it2,ip2,neh,ith,iph,isgn)
c            write(6,*) 'Indexs en els que ix de tradh'
c            write(6,*) 'it2',(it2(k),k=1,ne2),' ip2',(ip2(k),k=1,ne2)
            call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
c            write(6,*) 'El determinant buscat es una',ne2,' excitacio'
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
c            write(6,*) 'i l adresse es',iadr
            if(neth.eq.2) then
               isgn2=isgnb(it(1),ip(1))*isgnb(it(2),ip(2))
               jt1=(it(1))
               jt2=(it(2))
               jp1=(ip(1))
               jp2=(ip(2))
               if(jt1.gt.jt2)isgn2=-isgn2
               if(jp1.gt.jp2)isgn2=-isgn2
            else
               it3b1=it3(1)-norb
               ip3b1=ip3(1)-norb
               isgn2=isgnb(it3b1,ip3b1)
               if(yw)print*,'it3b1,ip3b1,isgn2',it3b1,ip3b1,isgn2
            endif
c     print*,'jt1,jt2,jp1,jp2',jt1,jt2,jp1,jp2
            jt1=isbrot(it(1))
            jt2=isbrot(it(2))
            jp1=isbrot(ip(1))
            jp2=isbrot(ip(2))
            if(yw)print*,'jt1,jt2,jp1,jp2',jt1,jt2,jp1,jp2
            if(jt1.ne.jp1.and.jt1.ne.jp2.and.jt2.ne.jp1.and.jt2.ne.jp2)
     *      then
               if((jt2-jt1)*(jt2-jp1)*(jp2-jt1)*(jp2-jp1).lt.0)
     *         isgn2=-isgn2
            endif
            if(yw)
     *      print*,'signe',(jt2-jt1)*(jt2-jp1)*(jp2-jt1)*(jp2-jp1)
            if(jt1.eq.jp1.or.jt2.eq.jp2) isgn2=-isgn2
            isgn=isgn2
            if(yw)print*,'a1',a1
            hoi(iadr)=hoi(iadr)+a1*isgn
            if(yw)write(6,*)'int ech it,ip',it,ip,a1
            if(yw)write(6,*)'iadr,hoi(iadr)'
     *      ,iadr,hoi(iadr)
            if(iadrmax.lt.iadr)iadrmax=iadr
         endif
 24      continue
         iii=iii+1
         if(iii.eq.2) then
            it(1)=i2
            it(2)=i1
            a1=-a
            goto 23
         endif
         if(iii.eq.3) then
            it(1)=i1
            it(2)=i2
            ip(1)=i4
            ip(2)=i3
            a1=-a
            goto 23
         endif
         if(iii.eq.4) then
            it(1)=i2
            it(2)=i1
            ip(1)=i4
            ip(2)=i3
            a1=a
            goto 23
         endif
         if(iii.eq.5) then
            it(1)=i3
            it(2)=i4
            ip(1)=i1
            ip(2)=i2
            a1=a
            goto 23
         endif
         if(iii.eq.6) then
            it(1)=i4
            it(2)=i3
            ip(1)=i1
            ip(2)=i2
            a1=-a
            goto 23
         endif
         if(iii.eq.7) then
            it(1)=i3
            it(2)=i4
            ip(1)=i2
            ip(2)=i1
            a1=-a
            goto 23
         endif
         if(iii.eq.8) then
            it(1)=i4
            it(2)=i3
            ip(1)=i2
            ip(2)=i1
            a1=a
            goto 23
         endif
 22      continue
 325     continue
      enddo
      if(yf30) close(30)
      if(yf30) close(54)
      if(ye2233) then
         ye2233=.false.
         llll=le2233
         iiii=ie2233
         yf30=.true.
         open(30,status='old',form='unformatted',file='CDE_2233')
         open(54,status='old',form='unformatted',file='HDE_2233')
         ifil=30
         goto 323
      endif
      if(ye2323) then
         ye2323=.false.
         llll=le2323
         iiii=ie2323
         yf30=.true.
         open(30,status='old',form='unformatted',file='CDE_2323')
         open(54,status='old',form='unformatted',file='HDE_2323')
         ifil=30
         goto 323
      endif
      if(ye1122) then
         ye1122=.false.
         llll=le1122
         iiii=ie1122
         open(30,status='old',form='unformatted',file='CDE_1122')
         open(54,status='old',form='unformatted',file='HDE_1122')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye1212) then
         ye1212=.false.
         llll=le1212
         iiii=ie1212
         open(30,status='old',form='unformatted',file='CDE_1212')
         open(54,status='old',form='unformatted',file='HDE_1212')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye2133) then
         ye2133=.false.
         llll=le2133
         iiii=ie2133
         open(30,status='old',form='unformatted',file='CDE_2133')
         open(54,status='old',form='unformatted',file='HDE_2133')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye2313) then
         ye2313=.false.
         llll=le2313
         iiii=ie2313
         open(30,status='old',form='unformatted',file='CDE_2313')
         open(54,status='old',form='unformatted',file='HDE_2313')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye2311) then
         ye2311=.false.
         llll=le2311
         iiii=ie2311
         open(30,status='old',form='unformatted',file='CDE_2311')
         open(54,status='old',form='unformatted',file='HDE_2311')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye2131) then
         ye2131=.false.
         llll=le2131
         iiii=ie2131
         open(30,status='old',form='unformatted',file='CDE_2131')
         open(54,status='old',form='unformatted',file='HDE_2131')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye2213) then
         ye2213=.false.
         llll=le2213
         iiii=ie2213
         open(30,status='old',form='unformatted',file='CDE_2213')
         open(54,status='old',form='unformatted',file='HDE_2213')
         yf30=.true.
         ifil=30
         goto 323
      endif
      if(ye2123) then
         ye2123=.false.
         llll=le2123
         iiii=ie2123
         open(30,status='old',form='unformatted',file='CDE_2123')
         open(54,status='old',form='unformatted',file='HDE_2123')
         yf30=.true.
         ifil=30
         goto 323
      endif
CJose    Llegim ara la matriu F(i,j)
      if(yhmono.and.itest(16).eq.0) then
c        write(6,*) 'Vaig a llegir les integrals monoelectroniques'
         ij=0
         do i=1,norb
            do j=1,i
               yret=.TRUE.
               ij=ij+1
               ik=i
               jk=j
 300           continue
c           write(6,*) ' Valor de la integral',ik,jk,f(ij)
               fmod=ABS(f(ij))
               if(fmod.lt.1.D-12) then
c           write(6,*) ' El valor per a corregir es 0.No faig res'
                  goto 302
               end if
               if(yh(jk).and..not.yh(ik)) then
                  iprov=ik
                  ik=jk
                  jk=iprov
c            print*, 'pas1'
               else
                  if(yh(ik).and.yh(jk).or..not.yh(ik).and..not.yh(jk))
     *            then
                     if(yret) then
c             write(6,*) ' Vaig a provar canviant el spin'
                     end if
c                 print*,'pas2'
                     goto 301
                  endif
               endif
c           print*,'pas3'
c           write(6,*) 'Indexs en els que entra a tradh',ik,jk
               call tradh(norb,1,ikl(1),jkl(1),ne2,it2,ip2,neh
     *         ,ith,iph,isgn)
c            write(6,*) 'Indexs en els que ix de tradh'
c            write(6,*) 'it2',(it2(k),k=1,ne2),' ip2',(ip2(k),k=1,ne2)
               call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip
     &         4,
     *         ispp,ierr)
c            write(6,*) 'El determinant buscat es una',ne2,' excitacio'
               call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *         iadr
     *      ,mhdum,mtdum)
c            write(6,*) 'i l adresse es',iadr
               if(yret) then
                  isgn=isgna(ik,jk)
c                write(6,*) 'He llegit la primera volta:alfa'
               else
                  ikb=ik-norb
                  jkb=jk-norb
                  isgn=isgnb(ikb,jkb)
c                write(6,*) 'Llisc la segona volta'
               end if
               hoi(iadr)=hoi(iadr)+f(ij)*isgn
               if(.not.yret) then
                  ik=ik-norb
                  jk=jk-norb
c           write(6,*) ' Son beta. Vaig a canviar a indexs originals'
               end if
 301           continue
               if(yret) then
                  ik=ik+norb
                  jk=jk+norb
                  yret=.FALSE.
                  goto 300
               end if
 302           continue
            end do
         end do
      end if
c          write(6,*) ' PARAT directe+intercanvi'
c----------------------------------------------------
c     hoi contient les hoi (1ere colonne de la matrice)
c----------------------------------------------------
      if(itest(33).eq.1) then
c--      on stocke hoi
         call stohc(hoi,c)
         itest(33)=0
      endif
      do k=1,ndet
c         print*,'HOI',k,hoi(k)
         hoi(k)=hoi(k)*c(k)
      enddo
c----------------------------------------------------
c     hoi contient les produits hoi*ci
c----------------------------------------------------
      return
      end
       subroutine calyh(yh)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      dimension yh(maxorb+maxorb)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      yw=.false.
 
      do i=1,norb+norb
         yh(i)=itype(iorb(i)).eq.1
      enddo
      if(yw) then
         write(6,*)'yh',(yh(k),k=1,norb)
         write(6,*)'yh',(yh(k+norb),k=1,norb)
      endif
      if(mod(-ms2,2).ne.0)yh(norb+norb+1)=.false.
      do i=1,noca0-ninac
         yh(numac(i))=.true.
      enddo
      do i=1,noca0-ninac
         yh(numac(i)+norb)=.true.
      enddo
      if(yw) then
         write(6,*)'neh',neh
         write(6,*)'yh',(yh(k),k=1,norb)
         write(6,*)'yh',(yh(k+norb),k=1,norb)
      endif
      do i=1,neh
         if(yh(ith(i))) then
            yh(ith(i))=.false.
         else
            stop' sc2casn ith incorrect'
         endif
         if(.not.yh(iph(i))) then
            yh(iph(i))=.true.
         else
            print*,'iph',(iph(k),k=1,neh)
            write(6,*)'yh',(yh(k),k=1,norb)
            write(6,*)'yh',(yh(k+norb),k=1,norb)
            stop' sc2casn iph incorrect'
         endif
      enddo
      if(yw) then
         write(6,*)'yh',(yh(k),k=1,norb)
         write(6,*)'yh',(yh(k+norb),k=1,norb)
      endif
      return
      end
       subroutine stohc(hoi,c)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      c        |      hoi      |
c
c
c-----------------------------------------------
c     stockage de hoi
c-----------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension hoi(iadri),c(iadri)
      common/ver3/ ei(2048),itab(2048)
      common /det/ndet,mdet(50),nbdet_cas
c--   ecriture de la 1ere colonne
      close(33)
      call sgncip(hoi,c,ndet)
      call reocip(hoi,c,itab,ndet,2)
      open(33,file='HOI',status='unknown',form='unformatted')
      call ecr8bl(c,ndet,33)
      close(33)
      open(33,file='CDE_INT0',status='unknown',form='unformatted')
      return
      end
