      subroutine sc2casj(iesp2,c,esp2,iesp,yesp)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       c       |      esp2     |
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
      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
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/csc2/ nicdi,nvdum,norbs,nocas,nvsdum,ii28,itptp1,itptp2
      common /det/ndet,mdet(50),nbdet_cas
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      dimension c(iadri),esp2(iadri)
c     *,esp3(iadri+iadri+iadri/8)
      dimension iesp(iadri*2),yesp(*)
c      equivalence (iesp(1),c(1))
c      equivalence (yesp(1),c(1))
      common/opt/ihab,calcul
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      character*3 calcul
      common/pr/nprint,mprint(10)
      common/test/itest(100)
      integer*2 iesp2(iadri*8)
      character*1280 namel
      namelist/deth/ith,iph
      yw=.false.
      write(6,*)' '
      write(6,*)'   #####   #####   #####      ####     #     #####  '
      write(6,*)'  #     # #     # #     #    #    #   # #   #     # '
      write(6,*)'  #       #             #    #       #   #  #       '
      write(6,*)'   #####  #        ##### --- #      #     #  #####  '
      write(6,*)'        # #       #          #      #######       # '
      write(6,*)'  #     # #     # #          #    # #     # #     # '
      write(6,*)'   #####   #####  #######    #####  #     #  #####  '
      write(6,*)' '
      if(yhmono) then
         write(6,*)' '
         write(6,*)'             HABILLAGE PAR LES MONOS '
         write(6,*)' '
      end if
      write(6,*)' '
      write(6,*)'ndet 1',ndet
      conv=10.d0**(-ipresc)
      write(6,*)' *******SC2 maxith',maxith,'       conv',conv,'  ****'
c--   ouverture fichier temporaire pour stocker la 1ere diagonale
      open(29,file='BID29',form='UNFORMATTED')
      open(99,status='unknown',file='f99')
c
c-----------------------------------------------------------
c                 ihab=2 habillage etat excite
c-----------------------------------------------------------
c
      if(ihab.eq.2) then
         write(6,*)'             ----------------------------'
         write(6,*)'      ~      ihab=2 habillage etat excite'
         write(6,*)'             ----------------------------'
c--      lecture test pour verifier la conformite du fichier sc2ex
         rewind 12
         read(12) ndeth,noac2,nelac2,ith
         if(noac.ne.noac2) goto 2
         do k=1,noac
            if(ith(k).ne.numac(k)) goto 2
         enddo
         goto 3
 2       write(6,*)'le fichier sc2ex ne correspond pas a ce calcul'
         write(75,*)'dans sc2ex noac=',noac2,' numac=',
     *   (ith(k),k=1,noac2),'$'
         call scril
         write(75,*)'ici  noac=',noac,' numac=',
     *   (numac(k),k=1,noac),'$'
         call scril
         stop
 3       continue
c--      on transfere la diagonale sur file 29
         rewind 25
         call lir8bl(esp2,ndet,25)
         call ecr8bl(esp2,ndet,29)
         if(yw) then
            do k=1,ndet
               write(6,*)'diag0',k,esp2(k)
            enddo
         endif
c--      puis on met la file 25 a zero
         do k=1,ndet
            esp2(k)=0.d0
         enddo
         rewind 25
         call ecr8bl(esp2,ndet,25)
c        appel habillage
         do ideth=1,ndeth
c--         lecture du determinant habilleur
            read(12)neh,(ith(k),k=1,neh),(iph(k),k=1,neh)
            call xc2cicas(esp2)
         enddo
c
c        la diagonale originale est sur 29
c        les corrections a la diagonale sont sur 25
c--      on fait la somme de 25 et 29 et on stocke sur 25
         call aldobl(c,yesp(iadri*8+1),ndet,25,29)
         if(yw) then
            rewind 25
            call lir8bl(esp2,ndet,25)
            do k=1,ndet
               write(6,*)'diag',k,esp2(k)
            enddo
         endif
         return
      endif
c
c-----------------------------------------------------------
c               fin  ihab=2 habillage etat excite
c
c               habillage ihab=1
c-----------------------------------------------------------
c
c--   lecture de l'energie de depart
      print*,'ihvec',ihvec
      rewind 11
      read(11)nicdi,metat
      read(11) (e0,k=1,ihvec)
      write(6,'('' energie de depart'',f10.6)') e0
c--   on met le vecteur solution precedent en vecteur d'essai
      ifiess=11
      nessai=2
      rewind 11
c
c--   boucle : iteration d'habillage
c
      iprec0=iprec
      do 1 iterh=1,maxith
c--   on remet la precision a la valeur demandee
      if(itest(36).eq.1) then
         iprec=iprec0+ihprec-ihprec/(iterh+iterh)
      else
         if(iterh.eq.1) then
            iprec=iprec0
         else
            print*,'del',del
            prec=-log10(dabs(del/100))
            print*,'prec',prec
            iprec=prec
            iprec=max(iprec,iprec0)
            iprec=min(iprec,iprec0+ihprec)
         endif
      endif
      write(6,1000) iterh
 1000 format(//,70('*'),/,20x,'ITERATION HABILLAGE',i3,/,70('*'))
      if(ytana)write(6,*)'appel sc2'
c
c--   on transfere la diagonale sur file 29
      rewind 25
      call lir8bl(esp2,nicdi,25)
      call ecr8bl(esp2,nicdi,29)
CYW      if(yw) then
CYW      do k=1,nicdi
CYW         write(6,*)'diag0',k,esp2(k)
CYW      enddo
CYW      endif
c--   puis on met la file 25 a zero
      do k=1,nicdi
         esp2(k)=0
      enddo
      rewind 25
      call ecr8bl(esp2,nicdi,25)
c
c--   recherche du vecteur propre habilleur
      rewind 93
      do i=1,noac+2
         ith(i)=0
      enddo
 
 
c     read(93,deth,end=4)
      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
      if(yw)write(6,*)'lec 93'
      if(yw)write(6,deth)
      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 conformh
      if(yw)write(6,*)'neh',neh
      if(yw)write(6,*)'ith',(ith(k),k=1,neh)
      if(yw)write(6,*)'iph',(iph(k),k=1,neh)
      call vh(c,esp2)
      call lire(c,ihvec1,nicdi,21)
c
c-----------------------------------------------------------------
c     habillage multiref : calcul de la norme**2 des coefficients
c                          de reference (c2)
c-----------------------------------------------------------------
c
      rewind 93
      c2=0.d0
      do ideth=1,ndeth
         call adrh
         c2=c2+c(iadrh)*c(iadrh)
      enddo
c--   ecriture test pour verifier la conformite du fichier sc2ex
      rewind 12
      write(12) ndeth,noac,nelac,numac
      if(ndeth.gt.1) call calc22(c,esp2)
c
c
c-------------------------------------------------
c     habillage de la matrice :
c--   boucle sur les determinants habilleurs
c-------------------------------------------------
c
      rewind 93
      do ideth=1,ndeth
         call lire(c,ihvec1,nicdi,21)
c--      lecture et adresse du determinant habilleur
         call adrh
c--      ecriture du determinant habilleur
         write(12)neh,(ith(k),k=1,neh),(iph(k),k=1,neh)
c--      coefficient du determinant habilleur
         c0=c(iadrh)
c         coef=c0*c0/c2
c         write(6,*) 'coef',coef,c0,c0*c0,c2,iadrh
c--   denormalisation
         do i=1,nicdi
            c(i)=c(i)/c0
         end do
c--      habillage
         call sc2cicasj(c,esp2)
      enddo
      call aldobl(c,yesp(iadri*8+1),nicdi,25,29)
      if(ytana)write(6,*)'appel david'
c      write(6,*)'ndet 3',ndet
      call david(c,esp2,iesp,iesp2,yesp)
      if(mprint(4).eq.1) call wvec(c,esp2,esp2)
c--   test d'arret
      rewind 11
      read(11)nicdi,metat
      read(11) e
      write(6,'('' energie a l iteration     '',f12.8)') e
      del=e-e0
      write(6,'('' DELTAE'',f10.6)') del
      e0=e
      if(dabs(del).lt.conv) then
         write(6,'(''CONVERGENCE HABILLAGE ATTEINTE ENERGIE'',F12.8)') e
         return
      endif
CYW      if(yw)write(6,*)'nicdi,metat',nicdi,metat
      rewind 12
 1    continue
      write(6,*)'NON CONVERGE'
      maxith=10
      close(11)
      call wvec(c,esp2,esp2)
      call fin
      end
c**********************************************************************
       subroutine sc2cicasj(c,hii)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       c       |      hii      |
c
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (nexci=2,ngru3=2048)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      parameter (maxda3=300)
      common/dim/iadri ; integer(8) iadri
      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/csc2/ nicdi,nvdum,norbs,nocas,nvsdum,ii28,itptp1,itptp2
      dimension it(2),ip(2)
      dimension it3(2),ip3(2)
      dimension nt(12),np(12)
      dimension it4(maxorbcas+2),ip4(maxorbcas+2)
      dimension it2(maxorbcas+2),ip2(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas)
      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
      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/jjd/jnti(1024),jntj(1024),jntk(1024),jntl(1024),baint(1024)
     *,isto
      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),hii(iadri)
c     *,esp3(iadri+iadri)
      dimension tab(2048)
      common/test/itest(100)
      dimension yh(maxorb+maxorb),ysgnh(1024)
      dimension numaca(maxorbcas),numacb(maxorbcas)
      dimension isgna(maxorb,maxorb),isgnb(maxorb,maxorb)
      yw=.false.
      yw1=.false.
      if(itest(11).eq.2.and.(gener.eq.'TOUS'.or.gener.eq.'DDCI'
     *.or.gener.eq.'DDC2')) return
      do i=1,maxorbcas
         ica(i)=0
      enddo
c
c--   mise a zero
      it(1)=0
      it(2)=0
      ip(1)=0
      ip(2)=0
c--   numaca,numacb : occupation du CAS dans la reference
      call trad(neh,ith,iph,nca,numaca,ncb,numacb,nt2,it4,ispt,np2,ip4,
     *ispp,ierr)
      do i=1,norb+norb
         yh(i)=itype(iorb(i)).eq.1
      enddo
      if(mod(-ms2,2).ne.0)yh(norb+norb+1)=.false.
      if(yw)print*,'nca0,ncb0',nca0,ncb0
      do i=1,noca0-ninac
         yh(numac(i))=.true.
      enddo
      do i=1,noca0-ninac
         yh(numac(i)+norb)=.true.
      enddo
      if(yw)print*,'yh',(yh(k),k=1,norb)
      if(yw)print*,'yh',(yh(k),k=norb+1,norb+norb+1)
      do i=1,neh
         if(yh(ith(i))) then
            yh(ith(i))=.false.
         else
            stop' ith incorrect'
         endif
         if(.not.yh(iph(i))) then
            yh(iph(i))=.true.
         else
            stop' iph incorrect'
         endif
      enddo
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
c              if(yh(isbrot(k))) iaij=iaij+1
            enddo
            do k=ii+1,jj-1
               if(yh(itorbs(k)+norb)) ibij=ibij+1
c              if(yh(isbrot(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
CYW      if(yw) then
CYW         write(6,*)'itorbs',(itorbs(k),k=1,norb)
CYW         write(6,*)'isbrot',(isbrot(k),k=1,norb)
CYW         write(6,*)'isgna'
CYW         do k=1,norb
CYW            write(6,'(20i3)')(isgna(l,k),l=1,norb)
CYW         enddo
CYW         write(6,*)'isgnb'
CYW         do k=1,norb
CYW            write(6,'(20i3)')(isgnb(l,k),l=1,norb)
CYW         enddo
CYW      endif
CYW      if(yw)write(6,*)'nca0,ncb0',nca0,ncb0
      coef=c0*c0/c2
      if(yw)write(6,*) 'COEF',coef,iadrh
      do i=1,nicdi
         hii(i)=0.d0
      end do
      if(itest(11).eq.2.and.gener(1:2).ne.'MR') goto 1
      if(gener.eq.'DDCI'.or.gener.eq.'DDC2') goto 1
      if(gener.eq.'MRTD'.or.gener.eq.'MRT2') goto 1
      if(gener.eq.'MRTM'.or.gener.eq.'MRM') goto 1
c
c------------------------------------------------------
c     Lecture des integrales directes vvoo et habillage
c------------------------------------------------------
c
      print*,'integrales directes dans sc2casj ',gener
      isto=0
      open(42,file='CDI_3311',status='OLD',form='UNFORMATTED')
c      write(6,*)'l3311,le3311',l3311,le3311
c      write(6,*)'i3311,ie3311',i3311,ie3311
      do ln=1,l3311+1
         call lirin4(inti,intj,intk,intl,aaint,42)
c         read(42)inti,intj,intk,intl,aaint
         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)
CYW            if(yw)write(6,*)'it,ip',it,ip
            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)
c            write(6,*)'iadr,a',iadr,a
c           hii((iadr))=a
c
c--         appel a l'habillage
            dum=a*c(iadr)*coef
            call stosc2(it(1),it(2),ip(1),ip(2),dum)
 
            call sc01(it(1),it(2),ip(1),ip(2),dum,hii)
c            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
c              hii((iadr))=a
c
c--         appel a l'habillage
               dum=a*c(iadr)*coef
               call stosc2(it(1),it(2),ip(1),ip(2),dum)
               call sc01(it(1),it(2),ip(1),ip(2),dum,hii)
c            write(6,*)'int dir it,ip',it,ip,a
            endif
         enddo
      enddo
      call stosc2f
      close(42)
c     do k=1,nicdi
c     write(6,*)'hii',k,hii(k)
c     enddo
c
c------------------------------------------------------
c     Lecture des integrales dir+ech vvoo et habillage
c------------------------------------------------------
c
c      write(6,*)'le3311',le3311
c      write(6,*)'ie3311',ie3311
c      print*,'hii(93)',hii(93)
 
      open(42,file='CDE_3311',status='OLD',form='UNFORMATTED')
      do ln=1,le3311+1
         call lirin4(inti,intj,intk,intl,aaint,42)
c         read(42)inti,intj,intk,intl,aaint
         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)
CYW            if(yw)write(6,*)'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)
c           hii((iadr))=a
c--         appel a l'habillage
            dum=a*c(iadr)*coef
            call stosc2(it(1),it(2),ip(1),ip(2),dum)
            call sc01e(it(1),it(2),ip(1),ip(2),2,dum,hii)
CYW            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
c           hii((iadr))=a
c--         appel a l'habillage
            dum=a*c(iadr)*coef
            call stosc2(it(1),it(2),ip(1),ip(2),dum)
            call sc01e(it(1),it(2),ip(1),ip(2),-2,dum,hii)
CYW            if(yw)write(6,*)'int ech it,ip',it,ip,a
         enddo
      enddo
      call stosc2f
      close(42)
CYW      if(yw)write(6,*)' '
 1    continue
c      print*,'1hii(93)',hii(93)
c      hii1=hii(93)
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                                                            |
c     habillage multiref
c     a partir d'ici, on remplace le vecteur propre c
c     par c*(c0**2/c22)
c     c'est-a-dire que chaque c(i) est corrige par le coef de
c     la reference en cours au carre / la somme des coef
c     des references pour lesquelles l'excitation correspondant
c     a l'integrale est possible
c
      if(ndeth.gt.1) then
         do ideb=1,nicdi,2048
            ifin=min(ideb+2047,nicdi)
            call lir8(tab,2048,36)
            ii=0
            do k=ideb,ifin
               ii=ii+1
               c(k)=c(k)*c0*c0/tab(ii)
            enddo
         enddo
      endif
c                                                            |
c------------------------------------------------------------
c
c     1) Integrale directe
c
c------------------------------------------------------------
CYW      if(yw)write(6,*)'debut de sc2cas int directe'
      rewind 27
CYW      if(yw)write(6,*)'l0000,le0000',l0000,le0000
CYW      if(yw)write(6,*)'i0000,ie0000',i0000,ie0000
c--   integrales generales
      llll=l0000
      iiii=i0000
      yf30=.false.
      ifil=27
      y2233=itest(38).eq.1.and.(l2233.ne.0.or.i2233.ne.0)
      print'('' itest(38)'',l2,i3,2i6)',y2233,itest(38),l2233,i2233
      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)
      y2111=itest(42).eq.1.and.(l2111.ne.0.or.i2111.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
 
 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(lfini.eq.0) goto 324
         if(ifil.eq.27) then
            do in=1,lfini
               ysgnh(in)=.false.
            enddo
         else
            call liry(ysgnh,1024,54)
         endif
CYW         if(yw)write(6,*)'lfini',lfini
         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),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) 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----------------
         if(gener.eq.'DDC2'.or.gener.eq.'MRT2') then
c              alors l'integrale doit avoir au plus 2 non-actives
            iac=0
            if(itype(it3(1)).eq.2) iac=iac+1
            if(itype(it3(2)).eq.2) iac=iac+1
            if(itype(ip3(1)).eq.2) iac=iac+1
            if(itype(ip3(2)).eq.2) iac=iac+1
c               write(6,*)'it3,ip3,',it3,ip3,itype(it3(1)),itype(it3(2))
c     *         ,itype(ip3(1)) ,itype(ip3(2))
            if(iac.le.1) goto 21
         endif
         if(gener.eq.'DDCI'.or.gener.eq.'MRTD') then
c              alors l'integrale doit avoir au plus 3 non-actives
            iac=0
            if(itype(it3(1)).eq.2) iac=iac+1
            if(itype(it3(2)).eq.2) iac=iac+1
            if(itype(ip3(1)).eq.2) iac=iac+1
            if(itype(ip3(2)).eq.2) iac=iac+1
c               write(6,*)'it3,ip3,',it3,ip3,itype(it3(1)),itype(it3(2))
c     *         ,itype(ip3(1)) ,itype(ip3(2))
            if(iac.eq.0) goto 21
         endif
         if(gener.eq.'MRM'.or.gener.eq.'MRTM') then
c              alors l'integrale doit avoir au plus 1t 1p
            iact=0
            iacp=0
            if(itype(it3(1)).eq.2) iact=iact+1
            if(itype(it3(2)).eq.2) iact=iact+1
            if(iact.eq.0) goto 21
            if(itype(ip3(1)).eq.2) iacp=iacp+1
            if(itype(ip3(2)).eq.2) iacp=iacp+1
            if(iacp.eq.0) goto 21
         endif
         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
c
c--      quand on revient en 20, on a une nouvelle distribution des
c        spins sur l'integrale
c
 20      continue
         it3(1)=it(1)
         it3(2)=it(2)+norb
         ip3(1)=ip(1)
         ip3(2)=ip(2)+norb
c--      test integrale correcte :
         if(yh(it3(1)).and.yh(it3(2)).and..not.yh(ip3(1)).
     *   and..not.yh(ip3(2))) then
            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)
            a1=a
            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))
c--            appel a l'habillage
            dum=a1*c(iadr)*isgn
c            print'('' dum'',f12.8,i4,f12.8,i4,f12.8)'
c     *      ,a1,iadr,c(iadr),isgn,dum
c            write(6,*)'int dir it,ip',it(1),it(2),ip(1),ip(2)
            call stosc2(it(1),it(2),ip(1),ip(2),dum)
c            hiiav=hii(93)
            call sc01(it(1),it(2),ip(1),ip(2),dum,hii)
c            hiiap=hii(93)
c            print*,'2hii(93)',hii(93)
c            if(hii(93).ne.hii1) then
c            print'(a4,f12.8,4i4,f12.8)','HII',hii(93)-hii1,it,ip,hii(93
c            print'('' HII dum'',f12.8,i4,f12.8,i4,f12.8)'
c     *      ,a1,iadr,c(iadr),isgn,dum
c            print'('' HIIavap'',3f12.8)',hiiav,hiiap,hiiap-hiiav
c            endif
c            hii1=hii(93)
         else
            yret=.TRUE.
 103        continue
            iaob=0
c
CJose    INTRODUCCIO DE L HABILLAGE AB LES MONOS
c
            if(yhmono) then
               if(it3(1).eq.ip3(1).or.it3(2).eq.ip3(2)) then
c                 (habillage par les int a 2 indices identiques)
                  iii=11
                  if(yw)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
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 115
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                        goto 112
                     end if
 115                 continue
                     if(it3(2).eq.ip3(2)) then
cj                   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
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 116
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                        goto 112
                     end if
 116                 continue
                  end if
cj           write(6,*) 'He considerat sols el indexs diferents'
cj           write(6,*) 'els indexs diferents it3 ip3 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
                     endif
                     if(.not.yh(it(2)+norb).and.yh(ip(2)+norb)) then
                        kkk=it(2)
                        it(2)=ip(2)
                        ip(2)=kkk
                     endif
                  else
                     if(yh(it31).and..not.yh(ip31)) then
                        goto 102
                     else
                        if(yret) then
cj              write(6,*) "Aixina es un EPV, vaig a canviar alfa-beta"
                           goto 112
                        else
cj            write(6,*) 'Es un EPV i el vote'
                           goto 21
                        end if
                     end if
 102                 continue
                  end if
cj            write(6,*) 'indexs en els que entra a tradh'
cj            write(6,*)'it3',it31,'   ip3',ip31
                  call tradh(norb,1,it31,ip31,ne2,it2,ip2,neh,ith,iph
     *            ,isgn)
                  if(yw)write(6,*)'it2',(it2(k),k=1,2),'  ip2',
     *            (ip2(k),k=1,2)
cj            write(6,*) 'indexs en els que ix de tradh'
cj            write(6,*) 'it2',(it2(k),k=1,ne2),'  ip2',(ip2(k),k=1,ne2)
cj     *      ' ne2=',ne2
                  call trad
     *            (ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *            ispp,ierr)
                  a1=a
cj                 write(6,*) ' El determinant buscat es una',ne2,
cj     *           ' excitacio'
                  call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *            iadr
     *      ,mhdum,mtdum)
cj                 write(6,*) 'i el adresse es',iadr
                  if(iaob.eq.0) then
                     isgn=isgna(it31,ip31)
cj                 write(6,*) 'he llegit alfa'
                  else
                     it3b1=it31-norb
                     ip3b1=ip31-norb
                     isgn=isgnb(it3b1,ip3b1)
cj                 write(6,*) 'he llegit beta'
                  end if
c--            appel a l'habillage
                  dum=a1*c(iadr)*isgn
cj                 write(6,*) 'dum,a1,c(iadr),isg,coef',dum,a1,c(iadr),
cj     *           isgn,coef
CYW               if(yw)write(6,*)'int dir it,ip',it(1),it(2),ip(1),ip(2
                  if(iaob.eq.0) then
cj            write(6,*) " Cas alfa"
cj            write(6,*) "Indexs per sctosc2,sc01",it(1),ip(1)
                     call stosc2(it(1),0,ip(1),0,dum)
                     call sc01(it(1),0,ip(1),0,dum,hii)
                  else
cj            write(6,*) " Cas beta"
cj            write(6,*) "Indexs per sctosc2,sc01",it(2),ip(2)
                     call stosc2(0,it(2),0,ip(2),dum)
                     call sc01(0,it(2),0,ip(2),dum,hii)
                  end if
 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
cj          print*,'it,ip apres' ,it,ip
cj                 write(6,*) "indexs canviats:"
cj                 write(6,*) "it3(1)=",it3(1)," it3(2)=",it3(2)
cj                 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(yf30) close(30)
      if(yf30) close(54)
      if(y2233) then
         y2233=.false.
         llll=l2233
         iiii=i2233
         print*,'ouverture 54'
         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(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
      call stosc2f
cj       write(6,*) ln,lfini
c      write(6,*) ' PARAT directe'
c       stop
c
CJose  HABILLAGE AB LES INTEGRALS DIRECTE+ECHANGE
c     2) Integrale directe + echange
c      open(33,file='CDE_INT0',status='OLD',form='UNFORMATTED')
cj         write(6,*) "Llisc les integrals INTO+intercanvi"
      rewind 33
      if(yw1)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)
      ye2111=itest(42).eq.1.and.(le2111.ne.0.or.ie2111.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*,'sye',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)
c         read(33)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.le0000+1) lfini=iiii
CYW         if(yw)write(6,*)'lfini',lfini
         if(lfini.eq.0) goto 325
         if(ifil.eq.33) then
            do in=1,lfini
               ysgnh(in)=.false.
            enddo
         else
            call liry(ysgnh,1024,54)
         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)
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----------------
         if(gener.eq.'DDC2'.or.gener.eq.'MRT2') then
c              alors l'integrale doit avoir au plus 2 non-actives
            iac=0
            if(itype(it3(1)).eq.2) iac=iac+1
            if(itype(it3(2)).eq.2) iac=iac+1
            if(itype(ip3(1)).eq.2) iac=iac+1
            if(itype(ip3(2)).eq.2) iac=iac+1
            if(iac.le.1) goto 22
         endif
         if(gener.eq.'DDCI'.or.gener.eq.'MRTD') then
c              alors l'integrale doit avoir au plus 3 non-actives
            iac=0
            if(itype(it3(1)).eq.2) iac=iac+1
            if(itype(it3(2)).eq.2) iac=iac+1
            if(itype(ip3(1)).eq.2) iac=iac+1
            if(itype(ip3(2)).eq.2) iac=iac+1
c               write(6,*)'it3,ip3,',it3,ip3,itype(it3(1)),itype(it3(2))
c     *         ,itype(ip3(1)) ,itype(ip3(2))
            if(iac.eq.0) goto 22
         endif
         if(gener.eq.'MRM'.or.gener.eq.'MRTM') then
c              alors l'integrale doit avoir au plus 1t 1p
            iact=0
            iacp=0
            if(itype(it3(1)).eq.2) iact=iact+1
            if(itype(it3(2)).eq.2) iact=iact+1
            if(iact.eq.0) goto 22
            if(itype(ip3(1)).eq.2) iacp=iacp+1
            if(itype(ip3(2)).eq.2) iacp=iacp+1
            if(iacp.eq.0) goto 22
         endif
         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
         a1=a
         if(yw)print*,'int lue',a,i1,i2,i3,i4
cj         write(6,*) ' int lue',a,i1,i2,i3,i4
 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
cj         write(6,*) 'La integral ijkl numero',in,' la he llegida
cj     *   pasant pel pas ',iii
cj         write(6,*) ' Indexs abans de considerar res'
cj         write(6,*) 'it',it,' ip',ip
         if(yhmono) then
cj            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
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                  goto 215
               else
cj                   write(6,*) "Els indexs NO son del CAS y/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))
               mm=1
            else
               if(it(2).eq.ip(2)) then
                  if(itype(it(2)).eq.2.and.yh(it(2))) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                     goto 216
                  else
cj                   write(6,*) "Els indexs NO son del CAS y/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))
                  mm=1
               else
                  if(it(1).eq.ip(2)) then
                     if(itype(it(1)).eq.2.and.yh(it(1))) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 217
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/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))
                     mm=1
                  else
                     if(it(2).eq.ip(1)) then
                        if(itype(it(2)).eq.2.and.yh(it(2))) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                           goto 218
                        else
cj                   write(6,*) "Els indexs NO son del CAS y/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))
                        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)
                        mm=2
                     endif
                  endif
               endif
            endif
         else
cj          write(6,*) 'Li hem dit que yhmono es FALSE'
            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)
            mm=2
         end if
cj          write(6,*) 'neth=',neth
cj          write(6,*) 'Escriu els indexs antics'
cj          write(6,*) 'it3',it3,' ip3',ip3
         if(yOK) then
            if(yw)write(6,*)'iii',iii
cj            write(6,*) ' Indexs en els que entra a tradh'
cj            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)
cj            write(6,*) ' Indexs en els que ix de tradh'
cj            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)
cj            write(6,*) 'El determinant buscat es una',ne2,'excitacio'
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
cj            write(6,*) 'i el 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))
            jt1=(it(1))
            jt2=(it(2))
            jp1=(ip(1))
            jp2=(ip(2))
c     print*,'jt1,jt2,jp1,jp2',jt1,jt2,jp1,jp2
            if(neth.eq.2) then
               isgn=isgna(it(1),ip(1))*isgna(it(2),ip(2))
               if(jt1.gt.jt2)isgn=-isgn
               if(jp1.gt.jp2)isgn=-isgn
            else
               isgn=isgna(it3(1),ip3(1))
            endif
            jt1=isbrot(it(1))
            jt2=isbrot(it(2))
            jp1=isbrot(ip(1))
            jp2=isbrot(ip(2))
            if((jt2-jt1)*(jt2-jp1)*(jp2-jt1)*(jp2-jp1).lt.0)isgn=-isgn
c--         appel a l'habillage
            dum=a1*c(iadr)*isgn
c     print*,'dumb',dum
c     write(6,'(a5,2f12.8)')'duma',dum,c(iadr)
cj             write(6,*) 'dum,a1,c(iadr),isg,coef',dum,a1
cj     *      ,c(iadr),isgn,coef
            if(mm.eq.1) then
               call stosc2(it3(1),0,ip3(1),0,dum)
               call sc01(it3(1),0,ip3(1),0,dum,hii)
            else
               if(mm.eq.2) then
                  call stosc2(it(1),it(2),ip(1),ip(2),dum)
                  call sc01e(it(1),it(2),ip(1),ip(2),2,dum,hii)
CYW              if(yw)write(6,*)'int ech it,ip',it,ip,a1
               else
                  write(6,*) "QUE COLLONS PASSA"
                  stop
               end if
            end if
         endif
 316     continue
cj          write(6,*) 'La integral ijkl numero',in,' la he llegida
cj     *   pasant pel pas ',iii
         if(yhmono) then
cj            write(6,*) 'Li hem dit que yhmono es TRUE.Cas BETA'
            if(it(1).eq.ip(1)) then
               if(itype(it(1)).eq.2.and.yh(it(1)+norb)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                  goto 220
               else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                  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)
               mm=1
            else
               if(it(2).eq.ip(2)) then
                  if(itype(it(2)).eq.2.and.yh(it(2)+norb)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                     goto 221
                  else
cj                   write(6,*) "Els indexs NO son del CAS y/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)
                  mm=1
               else
                  if(it(1).eq.ip(2)) then
                     if(itype(it(1)).eq.2.and.yh(it(1)+norb)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 222
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/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)
                     mm=1
                  else
                     if(it(2).eq.ip(1)) then
                        if(itype(it(2)).eq.2.and.yh(it(2)+norb)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                           goto 223
                        else
cj                   write(6,*) "Els indexs NO son del CAS y/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)
                        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)
cj         print*,'beta XXX yOK  ',yok
                        neth=2
                        it3(1)=it(1)+norb
                        it3(2)=it(2)+norb
                        ip3(1)=ip(1)+norb
                        ip3(2)=ip(2)+norb
                        mm=2
                     endif
                  endif
               endif
            endif
         else
cj          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
            mm=2
         end if
cj          write(6,*) 'Escriue els indexs antics'
cj          write(6,*) 'it3',it3,' ip3',ip3
         if(yOK) then
cj            write(6,*) ' Indexs en els que entra a tradh'
cj            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)
cj            write(6,*) ' Indexs en els que ix de tradh'
cj            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)
cj            write(6,*) 'El determinant buscat es una',ne2,'excitacio'
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
cj            write(6,*) 'i el adresse es',iadr
            jt1=(it(1))
            jt2=(it(2))
            jp1=(ip(1))
            jp2=(ip(2))
            if(neth.eq.2) then
               isgn=isgnb(it(1),ip(1))*isgnb(it(2),ip(2))
               if(jt1.gt.jt2)isgn=-isgn
               if(jp1.gt.jp2)isgn=-isgn
            else
               it3b1=it3(1)-norb
               ip3b1=ip3(1)-norb
               isgn=isgnb(it3b1,ip3b1)
            endif
            jt1=isbrot(it(1))
            jt2=isbrot(it(2))
            jp1=isbrot(ip(1))
            jp2=isbrot(ip(2))
            if((jt2-jt1)*(jt2-jp1)*(jp2-jt1)*(jp2-jp1).lt.0)isgn=-isgn
c--         appel a l'habillage
            dum=a1*c(iadr)*isgn
            if(mm.eq.1) then
               call stosc2(0,it3b1,0,ip3b1,dum)
               call sc01(0,it3b1,0,ip3b1,dum,hii)
            else
               if(mm.eq.2) then
                  call stosc2(it(1),it(2),ip(1),ip(2),dum)
                  call sc01e(it(1),it(2),ip(1),ip(2),-2,dum,hii)
CYW              if(yw)write(6,*)'int ech it,ip',it,ip,a1
               else
                  write(6,*) "QUE COLLONS PASSA"
                  stop
               end if
            end if
         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(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(ye2111) then
         ye2111=.false.
         llll=le2111
         iiii=ie2111
         open(30,status='old',form='unformatted',file='CDE_2111')
         open(54,status='old',form='unformatted',file='HDE_2111')
         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
c
CJose   ULTIMA CONSIDERACIO INTEGRALS F(i,j)
c
      if(yhmono.and.itest(16).eq.0) then
cj        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
cj          write(6,*) "Valor de la integral",ik,jk,f(ij)
               fmod=ABS(f(ij))
               if(fmod.lt.1.D-12) then
cj          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
cj             print*,'pas1'
               else
                  if(yh(ik).and.yh(jk).or..not
     *            .yh(ik).and..not.yh(jk)) then
                     if(yret) then
cj             write(6,*) "Vaig a probar canviant el spin"
                     end if
cj                print*,'pas2'
                     goto 301
                  end if
               end if
cj            print*,'pas3'
cj          write(6,*) " Indexs en els que entra a tradh",ik,jk
               call tradh(norb,1,ik,jk,ne2,it2,ip2,neh,ith,iph,isgn)
cj            write(6,*) ' Indexs en els que ix de tradh'
cj            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)
cj            write(6,*) 'El determinant buscat es una',ne2,'excitacio'
               call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *         iadr
     *      ,mhdum,mtdum)
cj            write(6,*) 'i el adresse es',iadr
               if(yret) then
                  isgn=isgna(ik,jk)
cj              write(6,*) " He llegit la primera volta: alfa"
               else
                  ikb=ik-norb
                  jkb=jk-norb
                  isgn=isgnb(ikb,jkb)
cj              write(6,*) "Llisc la segona volta: beta"
               end if
c--         appel a l'habillage
               dum=f(ij)*c(iadr)*isgn
c     print*,'dumc',dum
c     write(6,'(a5,f12.8)')'dumb',dum
cj            write(6,*) 'dum,f(ij),c(iadr),isg,coef',dum,f(ij)
cj     *     ,c(iadr),isgn,coef
               if(.not.yret) then
                  ik=ik-norb
                  jk=jk-norb
cj             write(6,*) "Son beta. A stosc2 ab indexs originals"
               end if
               if(yret) then
cj            write(6,*) " Cas alfa"
                  call stosc2(ik,0,jk,0,dum)
                  call sc01(ik,0,jk,0,dum,hii)
               else
cj            write(6,*) " Cas beta"
                  call stosc2(0,ik,0,jk,dum)
                  call sc01(0,ik,0,jk,dum,hii)
               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
      call stosc2f
c     do k=1,nicdi
c     write(6,*)'hii3',k,hii(k)
c     enddo
      if(yw)write(6,*) ' PARAT directe+intercanvi'
c       stop
C-----------------------------------------------------------------------
C     modification de la diagonale
c     hii contient la correction a la diagonale
c--      on lit les elements diagonaux
c         if(itest(11).eq.1) then
c            if(iterh.eq.1) then
c               rewind 25
c               call lir8bl(c,nicdi,25)
c               call ecr8bl(c,nicdi,29)
c            else
c               rewind 29
c              call lir8bl(c,nicdi,29)
c            endif
c         else
c              rewind 25
c            call lir8bl(c,nicdi,25)
c         endif
c--      on lit les elements diagonaux
CYWc     if(yw) then
CYW         rewind 61
CYW         do kkk=1,nicdi
CYW            read(61) ne
CYW            if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
CYW            write(6,'('' diagon '',3f12.8,12i3)') c(kkk),hii(kkk),
CYW     *      c(kkk)+hii(kkk),
CYW     *      (nt(k),k=1,ne),(np(k),k=1,ne)
CYW         enddo
CYWc     endif
      if(itest(14).eq.1) then
         if(itest(11).eq.1) then
            open(97,status='unknown',file='eidjl',form='formatted')
            call rew61
            write(6,*)'nicdi',nicdi
            do kkk=1,nicdi
c               read(61) ne
c               if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
               call venondloc(ne,nt,np,ierr)
               if(ne.eq.1)write(97,'(2i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
               if(ne.eq.2)write(97,'(4i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
               if(ne.eq.3)write(97,'(6i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
               if(ne.eq.4)write(97,'(8i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
c               write(75,*)' 97',ne,hii(kkk),(nt(k),k=1,ne),(np(k),k=1,n
c     &         ),'$'
c               call scril
            enddo
         else if(itest(11).eq.2) then
            open(97,status='unknown',file='einjl',form='formatted')
            call rew61
            do kkk=1,nicdi
c               read(61) ne
c               if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
               call venondloc(ne,nt,np,ierr)
               if(ne.eq.1)write(97,'(2i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
               if(ne.eq.2)write(97,'(4i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
               if(ne.eq.3)write(97,'(6i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
               if(ne.eq.4)write(97,'(8i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
            enddo
            close(97)
         endif
      endif
c--      on corrige les elements diagonaux
c      do i=1,nicdi
c         c(i)=c(i)+hii(i)
c      enddo
c     do i=1,nicdi
c        write(6,'('' sc2cas diag lue,corr'',2f12.8)')c(i),c(i)+hii(i)
c      enddo
      if(itest(14).eq.1) then
         if(itest(11).eq.1) then
            open(97,status='unknown',file='eid',form='formatted')
            call rew61
            do kkk=1,nicdi
c               read(61) ne
c               if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
               call venondloc(ne,nt,np,ierr)
               if(ne.eq.1)write(97,'(2i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
               if(ne.eq.2)write(97,'(4i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
               if(ne.eq.3)write(97,'(6i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
               if(ne.eq.4)write(97,'(8i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
            enddo
         else if(itest(11).eq.2) then
            open(97,status='unknown',file='ein',form='formatted')
            call rew61
            do kkk=1,nicdi
c               read(61) ne
c               if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
               call venondloc(ne,nt,np,ierr)
               if(ne.eq.1)write(97,'(2i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
               if(ne.eq.2)write(97,'(4i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
               if(ne.eq.3)write(97,'(6i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
               if(ne.eq.4)write(97,'(8i3,f12.6)')
     *         (nt(k),k=1,ne),(np(k),k=1,ne),c(kkk)
            enddo
            close(97)
         endif
      endif
C
C        fin de la correction de la diagonale
C        la diagonale corrigee est dans hii
C        on stocke la diagonale corrigee sur 25
C
      rewind 25
c         call ecr8bl(c,nicdi,25)
      call aldobl2(hii,nicdi,25)
c      write(6,*)'fin habillage 1'
c      call flush(6)
c      write(6,*)'fin habillage 1'
      return
      end
c**********************************************************************
       subroutine xc2cicas(hii)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (nexci=2,ngru3=2048)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      common/dim/iadri ; integer(8) iadri
      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/csc2/ nicdi,nvdum,norbs,nocas,nvsdum,ii28,itptp1,itptp2
CYW      dimension nt(12),np(12)
      common /det/ndet,mdet(50),nbdet_cas
      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
      common/test/itest(100)
      dimension hii(iadri)
c     *,esp3(iadri+iadri)
      yw=.false.
      yw1=.false.
c      print*,'entree sc2cicas',itest(11),gener
      if(itest(11).eq.2.and.(gener.eq.'TOUS'.or.gener.eq.'DDCI'
     *.or.gener.eq.'DDC2')) return
c      print*,'entree sc2cicas'
CYW      if(yw)write(6,*) 'norb,noca,ndet',norb,noca,ndet
c
c----------------------------------------------------
c     Lecture des integrales et habillage
c----------------------------------------------------
      do i=1,ndet
         hii(i)=0.d0
      end do
      ncas=2
      if(itest(11).eq.2.and.gener(1:2).ne.'MR') ncas=1
      do 4 idum=1,ncas
 1    continue
c     write(6,*)'avant lec12 1'
      read(12)inti,intj,intk,intl,aaint
      lfini=1024
      if(inti(1024).eq.-1) lfini=intj(1024)
c         write(6,*)'lfini',lfini
      do in=1,lfini
         dum=aaint(in)
c         print*,'duma',dum
c
c--      appel a l'habillage
c        print*,'x int',inti(in),intj(in),intk(in),intl(in)
         call sc01(inti(in),intj(in),intk(in),intl(in),dum,hii)
c            write(6,*)'int dir it,ip',it,ip,a
      enddo
      if(inti(1024).ne.-1) goto 1
      isp=2
 2    continue
c        write(6,*)'avant lec12 2'
      read(12)inti,intj,intk,intl,aaint
      lfini=1024
      if(inti(1024).eq.-1) lfini=intj(1024)
      do in=1,lfini
         dum=aaint(in)
c
c--         appel a l'habillage
         call sc01e(inti(in),intj(in),intk(in),intl(in),isp,dum,hii)
         isp=-isp
c            write(6,*)'int dir it,ip',it,ip,a
      enddo
      if(inti(1024).ne.-1) goto 2
 4    continue
c      close(12)
C-----------------------------------------------------------------------
C     modification de la diagonale
c     hii contient la correction a la diagonale
CYW      if(yw)write(6,*)'ndet',ndet
c--      on lit les elements diagonaux
c            rewind 25
c            call lir8bl(c,ndet,25)
CYWc     if(yw) then
CYW         rewind 61
CYW         do kkk=1,ndet
CYW            read(61) ne
CYW            if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
CYW            write(6,'('' diagon '',3f12.8,12i3)') c(kkk),hii(kkk),
CYW     *      c(kkk)+hii(kkk),
CYW     *      (nt(k),k=1,ne),(np(k),k=1,ne)
CYW         enddo
CYWc     endif
c--      on corrige les elements diagonaux
c      do i=1,ndet
c         c(i)=c(i)+hii(i)
c      enddo
CYW         if(yw) then
CYW            open(97,status='unknown',file='eid',form='formatted')
CYW            rewind 61
CYW            do kkk=1,ndet
CYW            read(61) ne
CYW            if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
CYW               if(ne.eq.1)write(97,'(2i3,f12.8)')
CYW     *      (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
CYW               if(ne.eq.2)write(97,'(4i3,f12.8)')
CYW     *      (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
CYW               if(ne.eq.3)write(97,'(6i3,f12.8)')
CYW     *      (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
CYW               if(ne.eq.4)write(97,'(8i3,f12.8)')
CYW     *      (nt(k),k=1,ne),(np(k),k=1,ne),hii(kkk)
CYW            enddo
CYW            close(97)
CYW          endif
C
C        fin de la correction de la diagonale
C        la diagonale corrigee est dans hii
C        on stocke la diagonale corrigee sur 25
C
      rewind 25
c         call ecr8bl(c,ndet,25)
c         print*,'appel aldobl2 depuis xc2cas',ndet
      call aldobl2(hii,ndet,25)
      write(6,*)'fin habillage x1'
      call flush(6)
      return
      end
       subroutine stosc2(i,j,k,l,dum)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/jjd/jnti(1024),jntj(1024),jntk(1024),jntl(1024),baint(1024)
     *,isto
      isto=isto+1
      jnti(isto)=i
      jntj(isto)=j
      jntk(isto)=k
      jntl(isto)=l
      baint(isto)=dum
      if(isto.eq.1024) then
         write(12)jnti,jntj,jntk,jntl,baint
         isto=0
      endif
      return
      end
       subroutine stosc2f
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/jjd/jnti(1024),jntj(1024),jntk(1024),jntl(1024),baint(1024)
     *,isto
      jnti(1024)=-1
      jntj(1024)=isto
      isto=0
      write(12)jnti,jntj,jntk,jntl,baint
      return
      end
       subroutine calc22(c,c22)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (nexci=2,ngru3=2048)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      parameter (maxda3=300)
      parameter (maxdeth=50)
      common/dim/iadri ; integer(8) iadri
      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/csc2/ nicdi,nvdum,norbs,nocas,nvsdum,ii28,itptp1,itptp2
      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)
      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
      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/jjd/jnti(1024),jntj(1024),jntk(1024),jntl(1024),baint(1024)
     *,isto
      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(nicdi),c22(nicdi)
c     *,esp3(iadri+iadri)
      common/test/itest(100)
      dimension yh(maxorb+maxorb,maxdeth)
      dimension numaca(maxorbcas),numacb(maxorbcas)
      dimension ch(maxdeth)
      yw=.false.
      yw1=.false.
c**********************************************************************
c          calcul des denominateurs dans l'habillage multireference
c          on repere, pour chaque integrale non vvoo, les references
c          sur lesquelles l'excitation correspondant a cette integrale
c          est possible
c
c          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**********************************************************************
      do k=1,nicdi
         c22(k)=0.
      enddo
      open(36,form='unformatted',status='unknown',file='SC2C22')
c
c--   preparation : coef des determinants habilleurs
c
      call verdim('Hab MR trop de ref  ndeth    maxdeth  ',
     *ndeth,maxdeth)
      call lire(c,ihvec1,nicdi,21)
      rewind 93
      do ideth=1,ndeth
c--      lecture et adresse du determinant habilleur
         call adrh
c--      coefficient du determinant habilleur
         ch(ideth)=c(iadrh)
c--      calcul de yh
         call trad(neh,ith,iph,nca,numaca,ncb,numacb,nt2,it4,ispt,np2,ip
     &   4,
     *   ispp,ierr)
         do i=1,norb+norb
            yh(i,ideth)=itype(iorb(i)).eq.1
         enddo
         if(mod(-ms2,2).ne.0)yh(norb+norb+1,ideth)=.false.
         do i=1,noca0-ninac
            yh(numac(i),ideth)=.true.
         enddo
         do i=1,noca0-ninac
            yh(numac(i)+norb,ideth)=.true.
         enddo
         do i=1,neh
            if(yh(ith(i),ideth)) then
               yh(ith(i),ideth)=.false.
            else
               stop' ith incorrect ideth'
            endif
            if(.not.yh(iph(i),ideth)) then
               yh(iph(i),ideth)=.true.
            else
               stop' iph incorrect ideth'
            endif
         enddo
 
      enddo
c
c--   lecture des integrales
c
c     1) Integrale directe
      rewind 27
      do ln=1,l0000+1
         call lirin4(inti,intj,intk,intl,aaint,27)
         lfini=1024
         if(ln.eq.l0000+1) lfini=i0000
         do 21 in=1,lfini
         it3(1)=inti(in)
         it3(2)=intj(in)
         ip3(1)=intk(in)
         ip3(2)=intl(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) 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----------------
         if(gener.eq.'DDC2') then
c              alors l'integrale doit avoir au plus 2 non-actives
            iac=0
            if(itype(it3(1)).eq.2) iac=iac+1
            if(itype(it3(2)).eq.2) iac=iac+1
            if(itype(ip3(1)).eq.2) iac=iac+1
            if(itype(ip3(2)).eq.2) iac=iac+1
c               write(6,*)'it3,ip3,',it3,ip3,itype(it3(1)),itype(it3(2))
c     *         ,itype(ip3(1)) ,itype(ip3(2))
            if(iac.le.1) goto 21
         endif
         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)
c
c--      boucle sur les determinants habilleurs
c
         do 25 ideth=1,ndeth
c
c--      quand on revient en 20, on a une nouvelle distribution des
c        spins sur l'integrale
c
 20      continue
         it3(1)=it(1)
         it3(2)=it(2)+norb
         ip3(1)=ip(1)
         ip3(2)=ip(2)+norb
c--      test integrale correcte :
         if(yh(it3(1),ideth).and.yh(it3(2),ideth)
     *   .and..not.yh(ip3(1),ideth).and..not.yh(ip3(2),ideth)) then
            if(yw)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)
            a1=a
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
            c22(iadr)=c22(iadr)+ch(ideth)*ch(ideth)
         else
            yret=.TRUE.
 103        continue
            iaob=0
cj           write(6,*) 'La integral ijkl numero ',in,' la he llegida
cj     *     pasant pel pas ',iii
c
CJose    INTRODUCCIO DE L HABILLAGE AB LES MONOS
c
            if(yhmono) then
               if(it3(1).eq.ip3(1).or.it3(2).eq.ip3(2)) then
c                 (habillage par les int a 2 indices identiques)
cj                write(6,*) 'Li hem dit que yhmono es
cj                TRUE, integral nu',in
                  iii=11
cj                write(6,*) 'Escriu els it3,ip3 antics'
cj                write(6,*)'it3',it3,'   ip3',ip3
                  if(yw)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),ideth)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 115
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                        goto 112
                     end if
 115                 continue
                     if(it3(2).eq.ip3(2)) then
cj                   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),ideth)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 116
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                        goto 112
                     end if
 116                 continue
                  end if
cj           write(6,*) 'He considerat sols el indexs diferents'
cj           write(6,*) 'els indexs diferents it3 ip3 son', it31,ip31
                  if(.not.yh(it31,ideth).and.yh(ip31,ideth)) then
                     ichng=it31
                     it31=ip31
                     ip31=ichng
                     if(.not.yh(it(1),ideth).and.yh(ip(1),ideth)) then
                        kkk=it(1)
                        it(1)=ip(1)
                        ip(1)=kkk
                     endif
                     if(.not.yh(it(2)+norb,ideth)
     *               .and.yh(ip(2)+norb,ideth)) then
                        kkk=it(2)
                        it(2)=ip(2)
                        ip(2)=kkk
                     endif
                  else
                     if(yh(it31,ideth).and..not.yh(ip31,ideth)) then
                        goto 102
                     else
                        if(yret) then
cj              write(6,*) "Aixina es un EPV, vaig a canviar alfa-beta"
                           goto 112
                        else
cj            write(6,*) 'Es un EPV i el vote'
                           goto 25
                        end if
                     end if
 102                 continue
                  end if
cj            write(6,*) 'indexs en els que entra a tradh'
cj            write(6,*)'it3',it31,'   ip3',ip31
                  call tradh(norb,1,it31,ip31,ne2,it2,ip2,neh,ith,iph
     *            ,isgn)
                  if(yw)write(6,*)'it2',(it2(k),k=1,2),'  ip2',
     *            (ip2(k),k=1,2)
cj            write(6,*) 'indexs en els que ix de tradh'
cj            write(6,*) 'it2',(it2(k),k=1,ne2),'  ip2',(ip2(k),k=1,ne2)
cj     *      ' ne2=',ne2
                  call trad
     *            (ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *            ispp,ierr)
                  a1=a
cj                 write(6,*) ' El determinant buscat es una',ne2,
cj     *           ' excitacio'
                  call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *            iadr
     *      ,mhdum,mtdum)
cj                 write(6,*) 'i el adresse es',iadr
                  if(iaob.eq.0) then
cj                 write(6,*) 'he llegit alfa'
                  else
                     it3b1=it31-norb
                     ip3b1=ip31-norb
cj                 write(6,*) 'he llegit beta'
                  end if
                  c22(iadr)=c22(iadr)+ch(iadrh)*ch(iadrh)
 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
cj          print*,'it,ip apres' ,it,ip
cj                 write(6,*) "indexs canviats:"
cj                 write(6,*) "it3(1)=",it3(1)," it3(2)=",it3(2)
cj                 write(6,*) "ip3(1)=",ip3(1)," ip3(2)=",ip3(2)
                  if(yret) then
                     yret=.FALSE.
                     goto 103
                  end if
                  goto 25
               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
 25      continue
 21      continue
      enddo
c     2) Integrale directe + echange
c      open(33,file='CDE_INT0',status='OLD',form='UNFORMATTED')
      rewind 33
      do ln=1,le0000+1
         call lirin4(inti,intj,intk,intl,aaint,33)
         lfini=1024
         if(ln.eq.le0000+1) lfini=ie0000
         do 22 in=1,lfini
         it3(1)=inti(in)
         it3(2)=intj(in)
         ip3(1)=intk(in)
         ip3(2)=intl(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----------------
         if(gener.eq.'DDC2') then
c              alors l'integrale doit avoir au plus 2 non-actives
            iac=0
            if(itype(it3(1)).eq.2) iac=iac+1
            if(itype(it3(2)).eq.2) iac=iac+1
            if(itype(ip3(1)).eq.2) iac=iac+1
            if(itype(ip3(2)).eq.2) iac=iac+1
            if(iac.le.1) goto 22
         endif
         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)
c
c--      boucle sur les determinants habilleurs
c
         do 26 ideth=1,ndeth
c
c--      quand on revient en 23, on a une nouvelle distribution des
c        spins sur l'integrale
c
         a1=a
         if(yw)print*,'int lue',a,i1,i2,i3,i4
 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
c
c--      integrales + + + +
c
         if(yhmono) then
            if(it(1).eq.ip(1)) then
               if(itype(it(1)).eq.2.and.yh(it(1),ideth)) then
                  goto 215
               else
                  goto 316
               end if
 215           continue
               it3(1)=it(2)
               ip3(1)=ip(2)
               neth=1
               yOK=yh(it(2),ideth).and..not.yh(ip(2),ideth)
               mm=1
            else
               if(it(2).eq.ip(2)) then
                  if(itype(it(2)).eq.2.and.yh(it(2),ideth)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                     goto 216
                  else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                     goto 316
                  end if
 216              continue
                  it3(1)=it(1)
                  ip3(1)=ip(1)
                  neth=1
                  yOK=yh(it(1),ideth).and..not.yh(ip(1),ideth)
                  mm=1
               else
                  if(it(1).eq.ip(2)) then
                     if(itype(it(1)).eq.2.and.yh(it(1),ideth)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                        goto 217
                     else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                        goto 316
                     end if
 217                 continue
                     it3(1)=it(2)
                     ip3(1)=ip(1)
                     neth=1
                     yOK=yh(it(2),ideth).and..not.yh(ip(1),ideth)
                     mm=1
                  else
                     if(it(2).eq.ip(1)) then
                        if(itype(it(2)).eq.2.and.yh(it(2),ideth)) then
cj                   write(6,*) "Els indexs son del CAS y TRUE"
                           goto 218
                        else
cj                   write(6,*) "Els indexs NO son del CAS y/o NO TRUE"
                           goto 316
                        end if
 218                    continue
                        it3(1)=it(1)
                        ip3(1)=ip(2)
                        neth=1
                        yOK=yh(it(1),ideth).and..not.yh(ip(2),ideth)
                        mm=1
                     else
                        yOK=yh(it(1),ideth).and.yh(it(2),ideth).and.
     *                  .not.yh(ip(1),ideth).
     *                  and..not.yh(ip(2),ideth)
                        neth=2
                        it3(1)=it(1)
                        it3(2)=it(2)
                        ip3(1)=ip(1)
                        ip3(2)=ip(2)
                        mm=2
                     endif
                  endif
               endif
            endif
         else
            yOK=yh(it(1),ideth).and.yh(it(2),ideth)
     *      .and..not.yh(ip(1),ideth).
     *      and..not.yh(ip(2),ideth)
            neth=2
            it3(1)=it(1)
            it3(2)=it(2)
            ip3(1)=ip(1)
            ip3(2)=ip(2)
            mm=2
         end if
         if(yOK) then
            if(yw)write(6,*)'iii',iii
            call tradh(norb,neth,it3,ip3,ne2,it2,ip2,neh,ith,iph,isgn)
            call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
            c22(iadr)=c22(iadr)+ch(ideth)*ch(ideth)
         endif
 316     continue
c
c--      integrales - - - -
c
         if(yhmono) then
            if(it(1).eq.ip(1)) then
               if(itype(it(1)).eq.2.and.yh(it(1)+norb,ideth)) then
                  goto 220
               else
                  goto 26
               end if
 220           continue
               it3(1)=it(2)+norb
               ip3(1)=ip(2)+norb
               neth=1
               yOK=yh(it(2)+norb,ideth).and..not.yh(ip(2)+norb,ideth)
               mm=1
            else
               if(it(2).eq.ip(2)) then
                  if(itype(it(2)).eq.2.and.yh(it(2)+norb,ideth)) then
                     goto 221
                  else
                     goto 26
                  end if
 221              continue
                  it3(1)=it(1)+norb
                  ip3(1)=ip(1)+norb
                  neth=1
                  yOK=yh(it(1)+norb,ideth).and..not.yh(ip(1)+norb,ideth)
                  mm=1
               else
                  if(it(1).eq.ip(2)) then
                     if(itype(it(1)).eq.2.and.yh(it(1)+norb,ideth)) then
                        goto 222
                     else
                        goto 26
                     end if
 222                 continue
                     it3(1)=it(2)+norb
                     ip3(1)=ip(1)+norb
                     neth=1
                     yOK=yh(it(2)+norb,ideth).and.
     *               .not.yh(ip(1)+norb,ideth)
                     mm=1
                  else
                     if(it(2).eq.ip(1)) then
                        if(itype(it(2)).eq.2
     *                  .and.yh(it(2)+norb,ideth)) then
                           goto 223
                        else
                           goto 26
                        end if
 223                    continue
                        it3(1)=it(1)+norb
                        ip3(1)=ip(2)+norb
                        neth=1
                        yOK=yh(it(1)+norb,ideth)
     *                  .and..not.yh(ip(2)+norb,ideth)
                        mm=1
                     else
                        yOK=yh(it(1)+norb,ideth)
     *                  .and.yh(it(2)+norb,ideth).and.
     *                  .not.yh(ip(1)+norb,ideth)
     *                  .and..not.yh(ip(2)+norb,ideth)
                        neth=2
                        it3(1)=it(1)+norb
                        it3(2)=it(2)+norb
                        ip3(1)=ip(1)+norb
                        ip3(2)=ip(2)+norb
                        mm=2
                     endif
                  endif
               endif
            endif
         else
            yOK=yh(it(1)+norb,ideth).and.yh(it(2)+norb,ideth).and.
     *      .not.yh(ip(1)+norb,ideth).and..not.yh(ip(2)+norb,ideth)
            neth=2
            it3(1)=it(1)+norb
            it3(2)=it(2)+norb
            ip3(1)=ip(1)+norb
            ip3(2)=ip(2)+norb
            mm=2
         end if
         if(yOK) then
            call tradh(norb,neth,it3,ip3,ne2,it2,ip2,neh,ith,iph,isgn)
            call trad(ne2,it2,ip2,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
            call adrdet(nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,
     *      iadr
     *      ,mhdum,mtdum)
            c22(iadr)=c22(iadr)+ch(ideth)*ch(ideth)
         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
 26      continue
 22      continue
      enddo
      call ecribl(c22,nicdi,36)
      rewind 36
      return
      end
