C-----------------------------------------------------------------------
C     1-2-2002 Main OK ad occhio ...
C
C     Programma per il calcolo della correzione perturbativa
C     al primo ordine alla matrice densita` utilizzando come 
C     perturbatori le funzioni monoeccitate contratte (quelle che
C     si introducono nel teorema di Brilluoin esteso), H_d come
C     Hamiltoniano di ordine zero e una funzione d'onda CAS-CI come 
C     funzione di ordine zero.
C 
C     Il calcolo deve essere preceduto da un calcolo variazionale
C     chg produca la funzione d'onda CAS-CI che viene letta dal
C     FILE04.
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C 
C     ENTREE DES DONNEES
C 
C     CARTE 1
C     TITRE   (80 CHARACTERES)
C 
C 
C     NAMELIST ICINP
C     ZTOUL =  T, GLI INTEGRALI SONO LETTI SECONDO IL FORMALISMO
C              TOLOSA (MOLCAS-MOTRA)
C              F, GLI INTEGRALI SONO LETTI DA IJKL (DEFAULT)
C     ZCV    = T, si calcolano le correzioni per gli elementi che 
C              accoppiano gli spazi core-virtuale, Default.
C     ZCA    = T, si calcolano le correzioni per gli elementi che 
C              accoppiano gli spazi core-attivo, Default.
C     ZAV    = T, si calcolano le correzioni per gli elementi che 
C              accoppiano gli spazi attivo-virtuale, Default.
C     ZLOC   = T, il programma viene usato per fare calcoli CASSCF
C              localizzati, quindi si ferma dopo aver scritto la 
C              matrice densita', Default.
C     ZPRT   = T, additional data are written on output
C              F, basic printing (Default).
C
C     ZSHEPS = T, si applica uno shift alle energie orbitaliche 
C              inattive, Default.
C     SHEPSC = energy shift applicato alle energie orbitaliche
C              di core (se zsheps=T), Default=0.d0
C     SHEPSV = energy shift applicato alle energie orbitaliche
C              virtuali (se zsheps=T), Default=0.d0
C     ERROR  = Errore ammesso sulla funzione d'onda nel calcolo delle
C              matrici di Koopmans (saranno considerati tutti i determinanti
C              che servono per ottenere 1-error della funzione d'onda).
C              Default error=0.d0.
C 
C     DIMENSIONS 
C     BASE D'ORBITALES MOLECULAIRES ............        = ID1
C     ESPACE DETERMINANTAL D'ORDRE ZERO ........        = ID4
C     TROUS ET PARTICULES ......................        = ID8
C     BASE ATOMIQUE (SSP. ATOM ET DIAOVL) ......        = ID13
C 
C-----------------------------------------------------------------------
      implicit real*8(a-h,o-y),logical*1(z)
      include 'cippi.prm'
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /vec/ c(id7),fmpb(id3)
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT
      COMMON /CPU/ TCPU,PCPU
      COMMON /MEM/ MEMSIZ,LOFFS,LOCMEM,LOCM(10)
      common /koo/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      common /density/ rotota(id1,id1),rototb(id1,id1)
      common /toul/ ztoul
      common /perturber/onel(id1*(id1+1)/2)
      common/detinf/zact(id1+1)
      dimension ifail(id1)

      pointer ijkl2(:),ijkl4(:),ijkl3(:),rijkl(:)
      common /big/ ijkl2,ijkl4,ijkl3,rijkl
      integer*2 ijkl2
      character*3,ijkl3
      real*4 rijkl
      dimension nos(20)

      allocatable d2alal(:,:,:,:),d2bebe(:,:,:,:)
      allocatable d2albe(:,:,:,:)
      dimension iwork(5*id1),cmo(id1,id1),cdum(id1)
      dimension eps(id1)
      indice(i,j)=max(i,j)*(max(i,j)-1)/2+min(i,j)
      character*1 range,uplo,jobz

      allocatable ain(:,:,:,:)
c
      ntotdet=0
      ntotconf=0
      ntotcap=0
      write (6,*) '   '
      CALL CPUT(-1)
      WRITE (6,'(/1X,70(''*''))')
      WRITE (6,'(/1X,7A9)') (' RODYALL ',I=1,7)
      WRITE (6,'(/1X,70(''*''))')
      CALL OFILES
      WRITE (6,'(/1X,70(''*''))')
      WRITE (6,*)
      ZTR=.TRUE.
      ZFA=.FALSE.
C 
C     lecture des donnees
C 
      call deter(error,zloc,zprt,zint)
      if (zprt) write (6,*) 'Letti i determinanti'

      zion=.false.
      if (ne(1).ne.0) then
         if (part(ne(1)).gt.2*norb) zion=.true.
      write (6,*)
      write (6,*) 'ODD NUMBER OF ELECTRONS'
      write (6,*)
      endif

       zautozact=.true.
         do i=1,norb
            if (zact(i)) zautozact=.false.
         enddo
       if (zautozact) then
         ii=nd(ncf)+ne(ncf)
         do i=1,II
         call flush(6)
            if (trou(i).gt.norb)then
               zact(trou(i)-norb)=.true.
       if (trou(i)-norb.eq.1) then
       write (6,*) 'trou',trou(I)
       endif
            else
               zact(trou(i))=.true.
       if (trou(i).eq.1) then
       write (6,*) 'trou',trou(I)
       endif
            endif
            if (part(i).le.2*norb) then
            if (part(i).gt.norb)then
               zact(part(i)-norb)=.true.
       if (part(i)-norb.eq.1) then
       write (6,*) 'part 2',part(i)
       endif
            else
               zact(part(i))=.true.
       if (part(i).eq.1) then
       write (6,*) 'part 1',part(i)
       endif
            endif
            endif
         enddo
       endif
         do i=1,norb
            if(zact(i))print*,'Orbital ',i,     '   active'
            if(.not.zact(i))print*,'Orbital ',i,' inactive'
         enddo

      call deforb(zact,norb,nocb,ncore,nact)

C 
C     lecture des integrales
C 
      jd1=id1

      call reijkl(factor,norb,nsym,itsym,its,nos,jd1)
      finv=1.d0/factor
      call memcip('IJKLP',.true.)
c      write (6,*) 'Zint=',zint,ncore,nact
c      call flush(6)
      if (zint) then
      allocate (ain(norb,ncore+nact,ncore+nact,ncore+nact))
      write (6,*) 'ain allocata'
      call flush(6)
      call itijkl_int(factor,norb,nact,ncore,ain)
      write (6,*) 'ain letta'
      call flush(6)
      endif

      if (ztoul) then
      call itijklt(factor,norb,nsym,nos,nijkl,
     * ijkl4,ijkl2,rijkl,ijkl3)
      else 
      call itijkl(factor,norb,nsym,nos,nijkl,
     * ijkl4,ijkl2,rijkl,ijkl3)
      endif
      call ijkf(2)

C 
C     CALCOLO PERTURBATIVO DELLA MATRICE DENSITA`
C 


c
c     Costruzione della matrice densita` su orb attivi
c     e delle matrici di Koopmans per IP e EA

      thrvar=0.d0
      if (error.ne.0.d0) then
      call givethr(thrvar,error)
      else
      write(6,*)
      write(6,*)'Variable ERROR is set to zero: all the determinants of'
      write (6,*) 'the CAS space are considered.'
      call flush(6)
      endif
      allocate(d2alal(1:nact,1:nact,1:nact,1:nact))
      allocate(d2bebe(1:nact,1:nact,1:nact,1:nact))
      allocate(d2albe(1:nact,1:nact,1:nact,1:nact))
      CALL CPUT(1)
      thr=1.d-12

      if (nact.ne.0) then
      call kooprho(thrvar,ncore,nact,d2alal,d2bebe,d2albe,thr,zion,zprt,
     *             zint,ain)
      if (zprt) write (6,*) 'IP Koopmans'' matrices done'
      CALL CPUT(1)
      call koopmansea(ncore,nact,thr,zprt,zint,ain)
      if (zprt) write (6,*) 'EA Koopmans'' matrices done'            
      CALL CPUT(1)
      call koopaver(ncore,nact,thr,zprt)
      if (zprt) write (6,*) 'Averaged Koopmans'' matrices done'
      CALL CPUT(1)
      endif

      call flush(6)
      CALL CPUT(1)
      if (zca) then
      write (6,234) 'Allowed.'
      else
      write (6,234) 'Not allowed.'
      endif
      if (zcv) then
      write (6,235) 'Allowed.'
      else
      write (6,235) 'Not allowed.'
      endif
      if (zav) then
      write (6,236) 'Allowed.'
      else
      write (6,236) 'Not allowed.'
      endif
      call flush(6)
 234  format (' Rotations between core and active orbitals    : ',A)
 235  format (' Rotations between core and virtual orbitals   : ',A)
 236  format (' Rotations between active and virtual orbitals : ',A)
      call flush(6)

      do i=1,norb
       do j=1,norb
        rotota(i,j)=0.d0
        rototb(i,j)=0.d0
       enddo
      enddo

      do i=1,nact
       do j=1,nact
        rotota(i+ncore,j+ncore)=rhoa(i,j)
        rototb(i+ncore,j+ncore)=rhob(i,j)
       enddo
      enddo

      do i=1,ncore
        rotota(i,i)=1.d0
        rototb(i,i)=1.d0
      enddo

c---calcolo degli eps secondo la formula:
c--eps(i)=h(i,i)+Sum(j=1,ncore)(2*J(i,j)-K(i,j))+
c--+Sum(a,b=1,nact)(<ia|ib>-0.5*<ia|bi>)*da(b,a)
c--analogo per eps(r)
      do i=1,ncore
         indi=indice(i,i)
         eps(i)=onel(indi)
         do j=1,ncore
            eps(i)=eps(i)+2.d0*ai(i,i,j,j)-ai(i,j,j,i)
         enddo
         do ia=1,nact
            do ib=1,nact
               eps(i)=eps(i)+(ai(i,i,ia+ncore,ib+ncore)-0.5d0*ai(i,ib
     $              +ncore,ia+ncore,i))*(rhoa(ib,ia)+rhob(ib,ia))
            enddo
         enddo
      enddo
      do ir=ncore+nact+1,norb
         indi=indice(ir,ir)
         eps(ir)=onel(indi)
         do j=1,ncore
            eps(ir)=eps(ir)+2.d0*ai(ir,ir,j,j)-ai(ir,j,j,ir)
         enddo
         do ia=1,nact
            do ib=1,nact
               eps(ir)=eps(ir)+(ai(ir,ir,ia+ncore,ib+ncore)-0.5d0*ai(ir
     $              ,ib+ncore,ia+ncore,ir))*(rhoa(ib,ia)+rhob(ib,ia))
            enddo
         enddo
      enddo
c
c     Aggiungo eventualmente gli shift
c
      if (zsheps) then
      write (6,*) 
      write (6,*) 'WARNING!!!!'
      write (6,*) 'The inactive orbital energies are shifted'
      write (6,'('' SHEPSC= '',F5.2)') shepsc
      write (6,'('' SHEPSV= '',F5.2)') shepsv
      do i=1,ncore
      eps(i)=eps(i)+shepsc*factor
      enddo
      do i=ncore+nact+1,norb
      eps(i)=eps(i)+shepsv*factor
      enddo
      endif


      print*
c      print*,' i          eps            fmpb '
      write (6,*)
      write (6,*) 'Inactive orbital energies'
      write (6,*)
      print*,' i          eps '
      do i=1,ncore
c         print '(i3,2f15.8)',i,eps(i)/factor,fmpb(i)/factor
         print '(i3,2f15.8)',i,eps(i)/factor
         fmpb(i)=eps(i)
         fmpb(i+norb)=eps(i)
      enddo
      do i=ncore+nact+1,norb
c         print '(i3,2f15.8)',i,eps(i)/factor,fmpb(i)/factor
         print '(i3,2f15.8)',i,eps(i)/factor
         fmpb(i)=eps(i)
         fmpb(i+norb)=eps(i)
      enddo
c      print*,'substituting fmpb with eps'


c
c
c     Termine V^(0p) 
c

      if (zcv) then
      write (6,*)
      if (zprt) write (6,*) 'Calling v0p'
      call v0p(thrvar,ncore,nact,zprt,zint,ain)
      if (zprt) print*,'Done with V(0p)'
      if (zprt) write (6,*)
      CALL CPUT(1)
      call flush(6)
      endif
c
c     Termine V^(+1p) 
c

      if (zca.and.(nact.ne.0)) then
      if (zprt) write (6,*) 'Calling v+1p'
      call vpup(thrvar,ncore,nact,d2alal,d2bebe,d2albe,zprt,zint,ain)
      if (zprt) print*,'Done with V(+1p)'
      write (6,*)
      CALL CPUT(1)
      call flush(6)
      endif
c
c     Termine V^(-1p) 
c

      if (zav.and.(nact.ne.0)) then
      if (zprt) write (6,*) 'Calling v-1p'
      call vmup(thrvar,ncore,nact,d2alal,d2bebe,d2albe,zprt,zint,ain)
      if (zprt) print*,'Done with V(-1p)'
      write (6,*)
      CALL CPUT(1)
      call flush(6)
      endif

      if (zprt) then
      dumca=0.d0
      dumcv=0.d0
      dumav=0.d0
      iav=1
      jav=1
      icv=1
      jcv=1
      ica=1
      jca=1
      do i=1,ncore
       do j=ncore+1,ncore+nact
       if (abs(rotota(i,j)).gt.dumca) then
       dumca=abs(rotota(i,j))
       dummca=rotota(i,j)
       ica=i
       jca=j
       endif
       enddo
       do j=ncore+nact+1,norb
       if (abs(rotota(i,j)).gt.dumcv) then
       dumcv=abs(rotota(i,j))
       dummcv=rotota(i,j)
       icv=i
       jcv=j
       endif
       enddo
      enddo
      do i=ncore+nact+1,norb
       do j=ncore+1,ncore+nact
       if (abs(rotota(i,j)).gt.dumav) then
       dumav=abs(rotota(i,j))
       dummav=rotota(i,j)
       iav=i
       jav=j
       endif
       enddo
      enddo

      write (6,*) 
     *   'MAXIMUM ABSOLUTE VALUES OF THE 0+1 ALPHA DENSITY MATRIX'
      write (6,*) 
      write (6,'(''Maximum element of the C-A block ='',2F15.10,
     *  '' ('',I3,'','',I3,'')'')') dumca,dummca,ica,jca
      write (6,'(''Maximum element of the C-V block ='',2F15.10
     *  '' ('',I3,'','',I3,'')'')') dumcv,dummcv,icv,jcv
      write (6,'(''Maximum element of the A-V block ='',2F15.10
     *  '' ('',I3,'','',I3,'')'')') dumav,dummav,iav,jav
      dumca=0.d0
      dumcv=0.d0
      dumav=0.d0
      do i=1,ncore
       do j=ncore+1,ncore+nact
       if (abs(rototb(i,j)).gt.dumca) then
       dumca=abs(rototb(i,j))
       dummca=rototb(i,j)
       ica=i
       jca=j
       endif
       enddo
       do j=ncore+nact+1,norb
       if (abs(rototb(i,j)).gt.dumcv) then
       dumcv=abs(rototb(i,j))
       dummcv=rototb(i,j)
       icv=i
       jcv=j
       endif
       enddo
      enddo
      do i=ncore+nact+1,norb
       do j=ncore+1,ncore+nact
       if (abs(rototb(i,j)).gt.dumav) then
       dumav=abs(rototb(i,j))
       dummav=rototb(i,j)
       iav=i
       jav=j
       endif
       enddo
      enddo

      write (6,*) 
     *  'MAXIMUM ABSOLUTE VALUES OF THE 0+1 BETA DENSITY MATRIX'
      write (6,*) 
      write (6,'(''Maximum element of the C-A block ='',2F15.10,
     *  '' ('',I3,'','',I3,'')'')') dumca,dummca,ica,jca
      write (6,'(''Maximum element of the C-V block ='',2F15.10
     *  '' ('',I3,'','',I3,'')'')') dumcv,dummcv,icv,jcv
      write (6,'(''Maximum element of the A-V block ='',2F15.10
     *  '' ('',I3,'','',I3,'')'')') dumav,dummav,iav,jav
      endif

c
c     Scrittura della matrice ro
c
c      write (6,*) 'Matrice densita` beta'
c      call matout(norb,norb,rototb,id1)
c      write (6,*) 
c      write (6,*) 
c      write (6,*) 'Matrice densita` alfa'
c      call matout(norb,norb,rotota,id1)

      do i=1,norb
       do j=1,norb
       rototb(i,j)=rotota(i,j)+rototb(i,j)
       enddo
      enddo
      dumca=0.d0
      dummca=0.d0
      dumcv=0.d0
      dummcv=0.d0
      dumav=0.d0
      dummav=0.d0
      ica=0
      jca=0
      icv=0
      jcv=0
      iav=0
      jav=0
      do i=1,ncore
       do j=ncore+1,ncore+nact
       if (abs(rototb(i,j)).gt.dumca) then
       dumca=abs(rototb(i,j))
       dummca=rototb(i,j)
       ica=i
       jca=j
       endif
       enddo
       do j=ncore+nact+1,norb
       if (abs(rototb(i,j)).gt.dumcv) then
       dumcv=abs(rototb(i,j))
       dummcv=rototb(i,j)
       icv=i
       jcv=j
       endif
       enddo
      enddo
      do i=ncore+nact+1,norb
       do j=ncore+1,ncore+nact
       if (abs(rototb(i,j)).gt.dumav) then
       dumav=abs(rototb(i,j))
       dummav=rototb(i,j)
       iav=i
       jav=j
       endif
       enddo
      enddo

      write (6,*) 
     *  'MAXIMUM ABSOLUTE VALUES OF THE 0+1 TOTAL DENSITY MATRIX'
      write (6,*) 
      write (6,'(''Maximum element of the C-A block ='',2F15.10,
     *  '' ('',I3,'','',I3,'')'')') dumca,dummca,ica,jca
      write (6,'(''Maximum element of the C-V block ='',2F15.10
     *  '' ('',I3,'','',I3,'')'')') dumcv,dummcv,icv,jcv
      write (6,'(''Maximum element of the A-V block ='',2F15.10
     *  '' ('',I3,'','',I3,'')'')') dumav,dummav,iav,jav
      write (6,*)
      write (6,*)
c      write (27) nao,norb
c      write (27) 
c      write (27) 
c      write (27) ((rotota(i,j),j=1,i),i=1,norb)

      write (27) ((rototb(i,j),j=1,norb),i=1,norb)
      write (27) ((rotota(i,j),j=1,norb),i=1,norb)

      if (zprt) then
      write (6,*) 
      write (6,*) 
      write (6,*) 'Total density matrix'
      call matout(norb,norb,rototb,id1)
      endif

      if (zloc) then
      write (6,*) 'NORMAL ENDING'
      call flush(6)
      stop
      endif


      rewind 11
      READ (11) ((cmo(I,J),I=1,NAO),J=1,NAO)

      do i=1,nao
       do j=1,nao
        rototb(i,j)=0.d0
        do k=1,nao
        rototb(i,j)=rototb(i,j)+cmo(i,k)*rotota(k,j)
        enddo
       enddo
      enddo

c      tras=0.d0
c      do i=1,norb
c       do j=1,norb
c       if (i.ne.j) tras=tras+rototb(i,j)**2
c       enddo
c      enddo
c      write (6,*) 'Tras=',tras

      write (28) ((rotota(I,J),I=1,NAO),J=1,NAO),
     * (2.d0,i=1,ncore),(-cdum(i+ncore),i=1,nact),
     * (0.d0,i=ncore+nact+1,nao)
      write (28) (1,i=1,nao)

c      READ (11) (cdum(i),i=1,nao*(nao+1)/2)
c
c      do i=1,nao
c       do j=1,i
c        ij=i*(i-1)/2+j
c      cmo(i,j)=cdum(ij)
c      cmo(j,i)=cdum(ij)
c       enddo
c      enddo
c
c      do i=1,norb
c       do j=i,norb
c       overl=0.d0
c        do k=1,nao
c       do l=1,nao
c       overl=overl+rototb(k,i)*cmo(k,l)*rototb(l,j)
c       enddo
c      enddo
c      write (6,1234) i,j,overl
c       enddo
c      enddo
c 1234 format ('overlap i,j',2I3,F17.14)

      CALL CPUT(1)
      STOP
      END
c-----------------------------------------------------------------------      
      SUBROUTINE OFILES
      implicit character*64(f)
      character*1280 namel
      character*80 card
      file03='CIPPI.FILE04'
      file04='CIPPI.FILE04'
      file11=' '
      file25='IJKL.FILE25'
      file26='CIPPI.FILE26'
      file27='CIPPI.FILE27'
      file28='CIPPI.FILE28'
      file50='IJKL.FILE50'
      call lecnam('&FILES',namel,5)
      call namela(namel,file03,'FILE03')
      call namela(namel,file04,'FILE04')
      call namela(namel,file11,'FILE11')
      call namela(namel,file25,'FILE25')
      call namela(namel,file26,'FILE26')
      call namela(namel,file27,'FILE27')
      call namela(namel,file28,'FILE28')
      call namela(namel,file50,'FILE50')

      open(3,file=file03,form='FORMATTED',status='UNKNOWN')
      rewind 3
      open(4,file=file04,form='UNFORMATTED',status='UNKNOWN')
      rewind 4

      if (file11.ne.' ') then
      open(11,file=file11,form='UNFORMATTED',status='OLD')
      rewind 11
      endif
      open(25,file=file25,form='UNFORMATTED',status='OLD')
      rewind 25
      open(26,file=file26,form='UNFORMATTED',status='UNKNOWN')
      rewind 26
      open(27,file=file27,form='UNFORMATTED',status='UNKNOWN')
      rewind 27
      open(28,file=file28,form='UNFORMATTED',status='UNKNOWN')
      rewind 28
      open(50,file=file50,form='UNFORMATTED',status='OLD')
      rewind 50
      WRITE (6,'(/''    INPUT DATA:''/)')
      write (6,*) ' FILE04 = ',file04
      write (6,*) ' FILE11 = ',file11
      write (6,*) ' FILE25 = ',file25
      write (6,*) ' FILE26 = ',file26
      write (6,*) ' FILE27 = ',file27
      write (6,*) ' FILE28 = ',file28
      write (6,*) ' FILE50 = ',file50
      icount=0
   50 read (5,'(a80)',end=99) card
      write (3,'(a80)') card
      icount=icount+1
      if (icount.le.15) write (6,'(1x,a80)') card
      i=index(card,'ICINP')
      if (i.ne.0) icount=0
      goto 50
   99 if (icount.gt.15) WRITE (6,'(8('' ..... etc''))')
      RETURN
      END
C***********************************************************************
      SUBROUTINE DETER(error,zloc,zprt,zint)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      character*2000 namel
      character*4 xt
      include 'cippi.prm'
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /vec/ c(id7),fmpb(id3)
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      common /hst/ host
      character*8 host
      common /toul/ ztoul
      COMMON /KOO/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      common/detinf/zact(id1)
   

      rewind 25
      READ (25) NSYM,NORB,NOC,NDEGEN,(ITSYM(I),I=1,NORB),
     *          nao,ngelo,ngelv
      rewind 3
      call cerca(3,'ICINP',itrovo)
      if (itrovo.eq.0) then
      write (6,*) '   *** NAMELIST &ICINP NOT FOUND ***'
      stop 12
      endif

      if (norb.gt.id1) then
      write (6,*) 'Attenzione, norb maggiore di id1',norb,id1
      stop 12
      endif

      call lecnam('&ICINP',namel,3)
c
      DO 11 I=1,NORB
   11 ITSYM(I+NORB)=ITSYM(I)

      zfac=.true.
      ztoul=.false.
      zca=.true.
      zcv=.true.
      zav=.true.
      zloc=.true.
      zint=.true.
      error=0.d0 
      zsheps=.false.
      shepsc=0.d0
      shepsv=0.d0
      factor=0.d0
      zprt=.false.
      host='        '
      do i=1,id1
      zact(i)=.false.
      enddo
      call namell(namel,ztoul,'ZTOUL',1)
      call namell(namel,zprt,'ZPRT',1)
      call namell(namel,ztoul,'ZLOC',1)
      call namell(namel,zca,'ZCA',1)
      call namell(namel,zcv,'ZCV',1)
      call namell(namel,zav,'ZAV',1)
      call namell(namel,zact,'ZACT',1)
      call namell(namel,zint,'ZINT',1)
      call namell(namel,zsheps,'ZSHEPS',1)
      if (zsheps) then
      call nameld(namel,shepsc,'SHEPSC',8)
      call nameld(namel,shepsv,'SHEPSV',8)
      endif
      call nameld(namel,error,'ERROR',8)
      call namela(namel,HOST,'HOST')


      NOCB=NOC
      NOCA=NOC+NORB
      MNOR1=2*NORB+1
      ITSYM(MNOR1)=1
      IORB(MNOR1)=NORB+1
      ISPIN(MNOR1)=1
      DO 150 I=1,NORB
      IORB(I)=I
      IORB(I+NORB)=I
      ISPIN(I)=0
  150 ISPIN(I+NORB)=1
      WRITE (6,3500) NORB
 3500 FORMAT (' NOMBRE D''ORBITALES(NORB):',I3)
      WRITE (6,3520) NOCB
 3520 FORMAT (' NOMBRE D''ORBITALES OCCUPEES :',I3)
      WRITE (6,3580) NSYM
 3580 FORMAT (' NOMBRE DE SYMETRIES POUR LES ORBITALES(NSYM):',I2)
      write (6,*)
      write (6,*)
      XT=' NON'
c
c   Lettura da file 4
c
      read (4) idum,idum,idum,metat,ncf,ii,icncf,(ne(j),nd(j),j=1,ncf),
     * (trou(j),part(j),j=1,ii),(c(j),j=1,icncf),(dum,J=1,metat),
     * (dum,J=1,metat),(dum,J=1,2*norb),
     * idum,(dum,J=1,idum),idum,(zdum,J=1,idum),
     * zdum,zdum,FACTOR

      if (II.gt.id8) then
      write (6,*) 'Attenzione, II maggiore di id8',ii,id8
      stop 12
      endif

      if (NCF.gt.id9) then
      write (6,*) 'Attenzione, NCF maggiore di id9',ncf,id9
      stop 12
      endif

      if (ICNCF.gt.id7) then
      write (6,*) 'Attenzione, ICNCF maggiore di id7',icncf,id7
      stop 12
      endif

      if (II.gt.id8) then
      write (6,*) 'Attenzione, II maggiore di id8',ii,id8
      stop 12
      endif


c
      END
c----------------------------------------------------------------
      subroutine deforb(zact,norb,nocb,ncore,nact)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      dimension zact(*)

      ncore=0
      nact=0
      zfin=.false.
      do i=1,nocb
      if (.not.zact(i)) then
       if (zfin) then
       write (6,*) 'Errore: orbitali non ordinati correttamente 1'
       stop
      endif
      ncore=ncore+1
      else
      zfin=.true. 
      nact=nact+1
      endif
      enddo

      zfin=.false.
      do i=nocb+1,norb
      if (zact(i)) then
       if (zfin) then
       write (6,*) 'Errore: orbitali non ordinati correttamente 2'
       stop
      endif
      nact=nact+1
      else
      zfin=.true. 
      endif
      enddo

      return
      end
c----------------------------------------------------------------
      subroutine givethrold(thrvar,error)
      implicit real*8 (a-h,o-y),logical*1 (z)
      include 'cippi.prm'
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /vec/ c(id7),fmpb(id3)
      dimension ztake(id7)

      do i=1,ncf
      ztake(i)=.false.
      enddo
      cdum=0.d0
      icount=0
  10  continue
      dum=0.d0
      write (6,*) icount,cdum
      call flush(6)
      do idet=1,ncf

       if (.not.ztake(idet)) then
       if (abs(c(idet)).gt.dum) then
       dum=abs(c(idet))
       jdet=idet
       endif
       endif

      enddo

      cdum=cdum+c(jdet)**2
      ztake(jdet)=.true.
      icount=icount+1

      if (icount.le.ncf) then
      if (1.d0-cdum.gt.error) goto 10
      thrvar=abs(c(jdet))
      else
      thrvar=0.d0
      icount=ncf
      endif

      write (6,*) 'THRVAR=',thrvar
      write (6,*) 'gives ',cdum*100.d0,' % of WF, using ',icount,
     * ' determinants'

      call flush(6)


      return
      end
c----------------------------------------------------------------
      subroutine givethr(thrvar,error)
      implicit real*8 (a-h,o-y),logical*1 (z)
      include 'cippi.prm'
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /vec/ c(id7),fmpb(id3)
      allocatable cl(:)
      allocate(cl(1:ncf))

      do idet=1,ncf
      cl(idet)=c(idet)
      enddo

      do idet=1,ncf-1
c       write (6,*) idet
       call flush(6)

       cdum=abs(cl(idet))

       do jdet=idet+1,ncf
        if (abs(cl(jdet)).gt.cdum) then
      dum=cl(jdet)
      cl(jdet)=cl(idet)
      cl(idet)=dum
      cdum=abs(cl(idet))
        endif
       enddo

      enddo
      write (6,*) 'Ordinati'
      CALL CPUT(-1)
      call flush(6)

      cdum=0.d0
      icount=0
      do idet=1,ncf
       cdum=cdum+cl(idet)**2
       icount=icount+1
       if (1.d0-cdum.lt.error) goto 10
      enddo

  10  thrvar=abs(cl(idet))

      write (6,*) 'THRVAR=',thrvar
      write (6,*) 'gives ',cdum*100.d0,' % of WF, using ',icount,
     * ' determinants'
      write (6,*) 'Error was set to',error

      call flush(6)

      deallocate (cl)

      return
      end
c----------------------------------------------------------------
      subroutine kooprho(thrvar,ncore,nact,d2alal,d2bebe,d2albe,thr,
     *                   zion,zprt,zint,ain)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /perturber/onel(id1*(id1+1)/2)
      common /koo/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      dimension rhotot(idac,idac)
      dimension d2alal(nact,nact,nact,nact),d2bebe(nact,nact,nact,nact)
      dimension d2albe(nact,nact,nact,nact)
      allocatable dram(:,:)
      allocatable drum(:,:)
      dimension ain(norb,ncore+nact,ncore+nact,ncore+nact)

      indice(i,j)=max(i,j)*(max(i,j)-1)/2+min(i,j)

      do i=1,idac
       do j=1,idac
       rhoa(i,j)=0.d0
       rhob(i,j)=0.d0
       koopipa(i,j)=0.d0
       koopipb(i,j)=0.d0
       koopeaa(i,j)=0.d0
       koopeab(i,j)=0.d0
       enddo
      enddo

      do i=1,nact
         do j=1,nact
            do k=1,nact
               do l=1,nact
                  d2alal(i,j,k,l)=0.d0
                  d2bebe(i,j,k,l)=0.d0
                  d2albe(i,j,k,l)=0.d0
               enddo
            enddo
         enddo
      enddo

      nele=(nocb-ncore)*2
      if (zion) nele=nele-1
c      write (6,*) 'NELE',nele,zion
      call flush(6)
      n=nact

      if (nele.eq.0) then
       write (6,*) 'Number of active electrons = 0'
       write (6,*) 'Number of active orbitals different from 0'
       write (6,*) 'Something wrong'
       stop
      endif

      if (nele.eq.1) then
      call ro1(rhoa,rhob,ncore,nact,thr,zprt,zion)
      goto 13
      endif


      call ro2(d2alal,d2bebe,d2albe,ncore,nact,thrvar,zprt)
      write (6,*) 'Two particle density matrix is done'
      CALL CPUT(1)
      call flush(6)
c      do i=1,nact
c      do j=1,nact
c      do k=1,nact
c      do l=1,nact
c      enddo
c      enddo
c      enddo
c      enddo
      nstop=(n+n*n)/2
      alnum=0.d0
      benum=0.d0
      alnum=0.d0
      benum=0.d0
      albe=0.d0
      beal=0.d0
      do i=1,n
         do j=1,n
           alnum=alnum+d2alal(i,j,i,j)
           benum=benum+d2bebe(i,j,i,j)
           albe=albe+d2albe(i,j,i,j)
           beal=beal+d2albe(j,i,j,i)
         enddo
      enddo
      write (6,1111) alnum,albe
 1111 format(//' Number of alpha-alpha couples =',f12.6,/,
     *         ' Number of alpha-beta couples  =',f12.6)
c 1111 format(//' Numero coppie alpha-alpha=',f12.6,//,' Numero coppie
c     $     alpha-beta=',f12.6,' Totale=',f12.6)
      do i=1,n
         do k=1,n
            rhoa(i,k)=0.d0
            rhob(i,k)=0.d0
            do j=1,n
               rhoa(i,k)=rhoa(i,k)+d2alal(i,j,k,j)+d2albe(i,j,k,j)
               rhob(i,k)=rhob(i,k)+d2bebe(i,j,k,j)+d2albe(j,i,j,k)
            enddo
            rhoa(i,k)=rhoa(i,k)/(nele-1)
            rhob(i,k)=rhob(i,k)/(nele-1)
         enddo
      enddo

   13 continue
c      print*,'matrice rhoa'
c      call matout(n,n,rhoa,idac)
c      print*,'matrice rhob'
c      call matout(n,n,rhob,idac)
c      write(6,888)
      do i=1,n
         do j=1,n
            rhotot(i,j)=rhoa(i,j)+rhob(i,j)
         enddo
      enddo
c      print*,'density matrix'
c      call matout(n,n,rhotot,idac)
      el=0.d0
      do i=1,n
         el=el+rhotot(i,i)
      enddo
      print*
      write (6,'('' Total number of electrons       = '',F12.10)') el
      el=0.d0
      do i=1,n
         el=el+rhoa(i,i)
      enddo
      write (6,'('' Total number of alpha electrons = '',F12.10)') el
      el=0.d0
      do i=1,n
         el=el+rhob(i,i)
      enddo
      write (6,'('' Total number of beta electrons  = '',F12.10)') el
 888  format(//,' Test sulla contrazione della matrice densita',//)

      call flush(6)
      CALL CPUT(1)

C
C     Test sull'energia                                   
C
      if (zprt) then
      energia=0.d0
      energia1=0.d0
      do ii=1,ncore
       irind=indice(ii,ii)
       dum=2.d0*onel(irind)
       dum1=2.d0*onel(irind)
       energia=energia+dum
       energia1=energia1+dum1
       do ij=1,ncore
       if (zint) then
       dum=2.d0*ain(ij,ij,ii,ii)-ain(ij,ii,ii,ij)
       dum1=2.d0*ai(ij,ij,ii,ii)-ai(ij,ii,ii,ij)
       else
       dum=2.d0*ai(ij,ij,ii,ii)-ai(ij,ii,ii,ij)
       endif
       energia=energia+dum
       energia1=energia1+dum1
       enddo
      enddo

      do iba=1,nact
       ib=iba+ncore
        do ica=1,nact
         ic=ica+ncore

       irind=indice(ib,ic)
         dum=onel(irind)
         dum1=onel(irind)

         do ii=1,ncore
       if (zint) then
       dum=dum+2.d0*ain(ib,ic,ii,ii)-ain(ib,ii,ii,ic)
       dum1=dum1+2.d0*ai(ib,ic,ii,ii)-ai(ib,ii,ii,ic)
       else
       dum=dum+2.d0*ai(ib,ic,ii,ii)-ai(ib,ii,ii,ic)
       endif
       enddo
         energia=energia+dum*(rhob(ica,iba)+rhoa(ica,iba))
         energia1=energia1+dum1*(rhob(ica,iba)+rhoa(ica,iba))

      enddo
      enddo


c
c     Parte relativa alla matrice densita` a due particelle
c
       do iba=1,nact
        ib=iba+ncore
        do ija=1,nact
         ij=ija+ncore
        do ika=1,nact
         ik=ika+ncore
        do ila=1,nact
         il=ila+ncore

       if (zint) then
       dint=ain(ib,il,ij,ik)
       dint1=ai(ib,il,ij,ik)
       else
       dint=ai(ib,il,ij,ik)
       endif
       dum1=dint*d2alal(iba,ija,ila,ika)
       dum2=dint*d2bebe(iba,ija,ila,ika)
       dum3=dint*d2albe(iba,ija,ila,ika)
       dum4=dint*d2albe(ija,iba,ika,ila)
       dum1_1=dint1*d2alal(iba,ija,ila,ika)
       dum2_1=dint1*d2bebe(iba,ija,ila,ika)
       dum3_1=dint1*d2albe(iba,ija,ila,ika)
       dum4_1=dint1*d2albe(ija,iba,ika,ila)
       duma=dum1+dum3
       dumb=dum2+dum4
       duma_1=dum1_1+dum3_1
       dumb_1=dum2_1+dum4_1
         energia=energia+0.5d0*(dumb+duma)
         energia1=energia1+0.5d0*(dumb_1+duma_1)
      enddo
      enddo
      enddo
      enddo

       write(6,*) 'Energia=',energia/factor
       write(6,*) 'Energia1=',energia1/factor
      endif

C     Calcolo le matrici di Koopmans
C     Caso -1: matrici di Koopmans per la ionizzazione attiva
C
C     La parte relativa alle singole differenze attive
C     e alle doppie differenze, una attiva e una inattiva
C     viene calcolata mediante rho_ab
C
      do iaa=1,nact
       ia=iaa+ncore
       do iba=1,nact
        ib=iba+ncore
       koopipa(iba,iaa)=0.d0
       koopipb(iba,iaa)=0.d0
        do ica=1,nact
         ic=ica+ncore

         if (ic.lt.ib) then
          irind=ib*(ib-1)/2+ic
         else
          irind=ic*(ic-1)/2+ib
         endif

         dum=onel(irind)

         do ii=1,ncore
       if (zint) then
       dum=dum+2.d0*ain(ib,ic,ii,ii)-ain(ib,ii,ii,ic)
       else
       dum=dum+2.d0*ai(ib,ic,ii,ii)-ai(ib,ii,ii,ic)
       endif
       enddo
         koopipa(iba,iaa)=koopipa(iba,iaa)-dum*rhoa(ica,iaa)
         koopipb(iba,iaa)=koopipb(iba,iaa)-dum*rhob(ica,iaa)

      enddo
       enddo
      enddo

c
c     Parte relativa alla matrice densita` a due particelle
c
      do iaa=1,nact
       ia=iaa+ncore
       do iba=1,nact
        ib=iba+ncore

        do ija=1,nact
         ij=ija+ncore
        do ika=1,nact
         ik=ika+ncore
        do ila=1,nact
         il=ila+ncore

       if (zint) then
       dint=ain(ib,il,ij,ik)
       else
       dint=ai(ib,il,ij,ik)
       endif
c       ind=index(iaa,ija,ila,ika)
       dum1=dint*d2alal(iaa,ija,ila,ika)
       dum2=dint*d2bebe(iaa,ija,ila,ika)
c       ial=indice(iaa,ila)
c       ijk=indice(ija,ika)
       dum3=dint*d2albe(iaa,ija,ila,ika)
       dum4=dint*d2albe(ija,iaa,ika,ila)
       duma=dum1+dum3
       dumb=dum2+dum4
         koopipa(iba,iaa)=koopipa(iba,iaa)-duma
         koopipb(iba,iaa)=koopipb(iba,iaa)-dumb

      enddo
      enddo
      enddo

       enddo
      enddo

    
      allocate(dram(1:nact,1:nact))
      allocate(drum(1:nact,1:nact))

      if (zprt) then
      do i=1,nact
       do j=1,nact
       drum(i,j)=koopipb(i,j)/factor
       dram(i,j)=rhob(i,j)
       enddo
      enddo
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di koopmans IP beta'
      call matout(nact,nact,drum,nact)
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di overlap per IP beta'
      call matout(nact,nact,dram,nact)
      endif


      do i=1,nact
       do j=1,nact
       drum(i,j)=koopipb(i,j)
       dram(i,j)=rhob(i,j)
       enddo
      enddo
      call purifica(dram,drum,thr,nipb,nact,zprt)
      do i=1,nipb
      dipb(i)=dram(i,1)
       do j=1,nact
       cipb(j,i)=drum(j,i)
       enddo
      enddo
      write(6,*) 'Active beta Ionization Potentials'
      write(6,*) 
      do i=1,nipb
      write (6,'(2x,I2,F10.4,'' eV'')') i,dipb(i)*27.2113957/factor
      enddo
c      call flush(6)

      if (zprt) then
      write (6,*) 
      do i=1,nact
       do j=1,nact
       drum(i,j)=koopipa(i,j)/factor
       dram(i,j)=rhoa(i,j)
       enddo
      enddo
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di koopmans IP alfa'
      call matout(nact,nact,drum,nact)
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di overlap per IP alfa'
      call matout(nact,nact,dram,nact)
      call flush(6)
      endif

      do i=1,nact
       do j=1,nact
       drum(i,j)=koopipa(i,j)
       dram(i,j)=rhoa(i,j)
       enddo
      enddo
      call purifica(dram,drum,thr,nipa,nact,zprt)
      do i=1,nipa
      dipa(i)=dram(i,1)
       do j=1,nact
        cipa(j,i)=drum(j,i)
       enddo
      enddo
      write(6,*) 
      write(6,*) 'Active alpha Ionization Potentials'          
      write(6,*) 
      do i=1,nipa
      write (6,'(2x,I2,F10.4,'' eV'')') i,dipa(i)*27.2113957/factor
      enddo
      call flush(6)
      CALL CPUT(1)

c      do i=1,idac
c       do j=1,idac
c       koopipb(i,j)=koopipb(i,j)*factor
c       koopipa(i,j)=koopipa(i,j)*factor
c       enddo
c      enddo

      deallocate (dram)
      deallocate (drum)
      return
      end
c----------------------------------------------------------------
      subroutine koopmansea(ncore,nact,thr,zprt,zint,ain)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /perturber/onel(id1*(id1+1)/2)
      common /koo/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      allocatable dram(:,:)
      allocatable drum(:,:)
      indice(i,j)=max(i,j)*(max(i,j)-1)/2+min(i,j)
      dimension ain(norb,ncore+nact,ncore+nact,ncore+nact)

      do ia=1,nact
       iaf=ia+ncore
       do ib=1,nact
        ibf=ib+ncore
        irind=indice(ibf,iaf)
        dum=onel(irind)
        do i=1,ncore
         if (zint) then
         dum=dum+2.d0*ain(ibf,iaf,i,i)-ain(ibf,i,i,iaf)
         else
         dum=dum+2.d0*ai(ibf,iaf,i,i)-ai(ibf,i,i,iaf)
         endif
        enddo
        duma=dum
        dumb=dum
        do ie=1,nact
         ief=ie+ncore
         do id=1,nact
         idf=id+ncore
         if (zint) then
         dum2=ain(iaf,ibf,idf,ief)
         dum1=dum2-ain(iaf,ief,idf,ibf)
         else
         dum2=ai(iaf,ibf,idf,ief)
         dum1=dum2-ai(iaf,ief,idf,ibf)
         endif
         duma=duma+dum1*rhoa(ie,id)+dum2*rhob(ie,id)
         dumb=dumb+dum1*rhob(ie,id)+dum2*rhoa(ie,id)
         enddo
        enddo
        koopeaa(ib,ia)=koopipa(ib,ia)+duma
        koopeab(ib,ia)=koopipb(ib,ia)+dumb
       enddo
      enddo
    
      write (6,*) 
      allocate(dram(1:nact,1:nact))
      allocate(drum(1:nact,1:nact))

      if (zprt) then
      do i=1,nact
       do j=1,nact
       drum(i,j)=koopeab(i,j)/factor
       dum=0.d0
       if (i.eq.j) dum=1.d0
       dram(i,j)=dum-rhob(i,j)
       enddo
      enddo
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di koopmans EA beta'
      call matout(nact,nact,drum,nact)
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di overlap per EA beta'
      call matout(nact,nact,dram,nact)
      endif

      write (6,*) 
      do i=1,nact
       do j=1,nact
       drum(i,j)=koopeab(i,j)
       dum=0.d0
       if (i.eq.j) dum=1.d0
       dram(i,j)=dum-rhob(i,j)
       enddo
      enddo
      call purifica(dram,drum,thr,neab,nact,zprt)
      do i=1,neab
      deab(i)=dram(i,1)
       do j=1,nact
        ceab(j,i)=drum(j,i)
       enddo
      enddo
      write(6,*) 'Active beta Electron Affinities'      
      write(6,*) 
      do i=1,neab
      write (6,'(2x,I2,F10.4,'' eV'')') i,deab(i)*27.2113957/factor
      enddo

      if (zprt) then
      do i=1,nact
       do j=1,nact
       drum(i,j)=koopeaa(i,j)/factor
       dum=0.d0
       if (i.eq.j) dum=1.d0
       dram(i,j)=dum-rhoa(i,j)
       enddo
      enddo
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di koopmans EA alfa'
      call matout(nact,nact,drum,nact)
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di overlap per EA alfa'
      call matout(nact,nact,dram,nact)
      endif

      write (6,*) 
c      write (6,*) 
c      write (6,*) 'Matrice di koopmans IP alfa EA NEW'
c      call matout(nact,nact,koopeaa,idac)
c      call flush(6)
      do i=1,nact
       do j=1,nact
       drum(i,j)=koopeaa(i,j)
       dum=0.d0
       if (i.eq.j) dum=1.d0
       dram(i,j)=dum-rhoa(i,j)
       enddo
      enddo
      call purifica(dram,drum,thr,neaa,nact,zprt)
      do i=1,neaa
      deaa(i)=dram(i,1)
       do j=1,nact
        ceaa(j,i)=drum(j,i)
       enddo
      enddo
      write(6,*) 'Active alpha Electron Affinities'
      write(6,*) 
      do i=1,neaa
      write (6,'(2x,I2,F10.4,'' eV'')') i,deaa(i)*27.2113957/factor
      enddo
c      write(6,*) 'Autovettori EA alfa'
c      call matout(nact,nact,ceaa,idac)
c      call flush(6)
      CALL CPUT(1)

      deallocate (dram)
      deallocate (drum)

      return
      end
c----------------------------------------------------------------
      subroutine koopaver(ncore,nact,thr,zprt)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /perturber/onel(id1*(id1+1)/2)
      common /koo/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      allocatable dram(:,:)
      allocatable drum(:,:)

      write (6,*) 
      allocate(dram(1:nact,1:nact))
      allocate(drum(1:nact,1:nact))

      if (zprt) then
      do i=1,nact
       do j=1,nact
       drum(i,j)=(koopipa(i,j)+koopipb(i,j))/factor
       dram(i,j)=(rhoa(i,j)+rhob(i,j))
       enddo
      enddo
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di koopmans media IP'
      call matout(nact,nact,drum,nact)
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di overlap media per IP'
      call matout(nact,nact,dram,nact)

      endif
      do i=1,nact
       do j=1,nact
       drum(i,j)=(koopipa(i,j)+koopipb(i,j))
       dram(i,j)=(rhoa(i,j)+rhob(i,j))
       enddo
      enddo

      call purifica(dram,drum,thr,nipa,nact,zprt)
      nipb=nipa
      do i=1,nipa
      dipa(i)=dram(i,1)
      dipb(i)=dram(i,1)
       do j=1,nact
        cipa(j,i)=drum(j,i)
        cipb(j,i)=drum(j,i)
       enddo
      enddo
      write(6,*) 'Active averaged Ionization Potentials'
      write(6,*) 
      do i=1,nipa
      write (6,'(2x,I2,F10.4,'' eV'')') i,dipa(i)*27.2113957/factor
      enddo

      if (zprt) then
      do i=1,nact
       do j=1,nact
       drum(i,j)=(koopeaa(i,j)+koopeab(i,j))/factor
       dum=0.d0
       if (i.eq.j) dum=2.d0
       dram(i,j)=dum-(rhoa(i,j)+rhob(i,j))
       enddo
      enddo
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di koopmans media EA'
      call matout(nact,nact,drum,nact)
      write (6,*) 
      write (6,*) 
      write (6,*) 'Matrice di overlap media per EA'
      call matout(nact,nact,dram,nact)
      endif

      do i=1,nact
       do j=1,nact
       drum(i,j)=(koopeaa(i,j)+koopeab(i,j))
       dum=0.d0
       if (i.eq.j) dum=2.d0
       dram(i,j)=dum-(rhoa(i,j)+rhob(i,j))
       enddo
      enddo

      call purifica(dram,drum,thr,neaa,nact,zprt)
      neab=neaa
      do i=1,neaa
      deaa(i)=dram(i,1)
      deab(i)=dram(i,1)
       do j=1,nact
        ceaa(j,i)=drum(j,i)
        ceab(j,i)=drum(j,i)
       enddo
      enddo
      write(6,*) 
      write(6,*) 'Active averaged Electron Affinities'
      write(6,*) 
      do i=1,neaa
      write (6,'(2x,I2,F10.4,'' eV'')') i,deaa(i)*27.2113957/factor
      enddo
      CALL CPUT(1)

      deallocate (dram)
      deallocate (drum)

      return
      end
c----------------------------------------------------------------
      subroutine ro2(d2alal,d2bebe,d2albe,ncore,nact,thrvar,zprt)
      implicit real*8 (a-h,o-y),logical*1 (z)
      include 'cippi.prm'
      dimension d2alal(nact,nact,nact,nact),d2albe(nact,nact,nact,nact),
     * d2bebe(nact,nact,nact,nact)
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /diff/ n1,n2,n3,n4,ns1,ns2,ns3,ns4,nbdif,zseg
      logical z1,z2,z3,z4,z5
      allocatable iocca(:),ioccb(:)
      dimension nv(4),nw(4)
      integer segno
c common e dimensionamenti mettere dopo
      n=nact
      nocc=nocb-ncore
      allocate(iocca(norb))
      allocate(ioccb(norb))
c      print*,'nocc,noca',nocc,noca

      if (zprt) then
      print*,'subr. ro2'
      print*,'n=',n,' nocc=',nocc,' ncf=',ncf
      print*,'thrvar',thrvar
      endif

      do 1 m=1,ncf
         if (mod(m,100).eq.0.and.zprt)print *,'m=',m
         call flush(6)
         if(abs(c(m)).lt.thrvar)goto 1
         ndi=nd(m)
         nec=ne(m)
         call giveocc2(m,iocca,ioccb,nact,ncore,nocca,noccb,nocc,nec
     $        ,ndi,trou,part,iorb,ispin,norb)
         do 2 n=1,m
            if(abs(c(n)).lt.thrvar)goto 2
            if(n.eq.m)goto 3
            ndj=nd(n)
            ij=jdifgen(ne,nd,trou,part,m,n,nv,nw,2,zseg)
            if(ij.eq.0)nbdif=4
            if(nbdif.gt.2)goto 2
               if(zseg)then
                  segno=-1
               else
                  segno=1
               endif
               if(nbdif.eq.1)then
                  n1=iorb(nv(1))
                  ns1=ispin(nv(1))
                  n2=iorb(nw(1))
                  ns2=ispin(nw(1))
                  goto 10
               else
                  call ord2(nv,nw,zseg,segno) !prima gli alfa, poi i beta
                  n1=iorb(nv(1))
                  ns1=ispin(nv(1))
                  n2=iorb(nv(2))
                  ns2=ispin(nv(2))
                  n3=iorb(nw(1))
                  ns3=ispin(nw(1))
                  n4=iorb(nw(2))
                  ns4=ispin(nw(2))
c                  print '(a,4i3,l2)','due diff: ',n1,n3,n2,n4,zseg
                  goto 20
               endif
c            goto(10,20),nbdif
         if (n1.gt.norb.or.n2.gt.norb.or.n3.gt.norb.or.n4.gt.norb) then
         write (6,*) 'Something wrong in jdifgen',n1,n2,n3,n4
         endif
 3          continue
c     nessuna differenza
            ci2=c(m)*c(m)
            do i=1,nocca
               ia=iocca(i)
c               if (ia.gt.norb-ncore) cycle
               do j=i+1,nocca
                  ja=iocca(j)
c                  if (ja.gt.norb-ncore) cycle
                  d2alal(ia,ja,ia,ja)=d2alal(ia,ja,ia,ja)+ci2
                  call permbis(d2alal,ia,ja,ia,ja,nact)
               enddo
            enddo
            do i=1,noccb
               ib=ioccb(i)
               do j=i+1,noccb
                  jb=ioccb(j)
                  d2bebe(ib,jb,ib,jb)=d2bebe(ib,jb,ib,jb)+ci2
                  call permbis(d2bebe,ib,jb,ib,jb,nact)
               enddo
            enddo
            do i=1,nocca
               ia=iocca(i)
c               if (ia.gt.norb-ncore) cycle
               do j=1,noccb
                  jb=ioccb(j)
                  d2albe(ia,jb,ia,jb)=d2albe(ia,jb,ia,jb)+ci2
               enddo
            enddo
               goto 2
 10            continue
c     una differenza
               n1=n1-ncore
               n2=n2-ncore
               cij=c(m)*c(n)*segno
               if(ns1.eq.1.and.ns2.eq.1)then
                  do i=1,nocca
                     ia=iocca(i)
c                     if (ia.gt.norb-ncore) cycle
                     if(ia.ne.n1.and.ia.ne.n2)then
                        d2alal(n1,ia,n2,ia)=d2alal(n1,ia,n2,ia)+cij
                        call permbis(d2alal,n1,ia,n2,ia,nact)
                     endif
                  enddo
                  do i=1,noccb
                     ib=ioccb(i)
                     d2albe(n1,ib,n2,ib)=d2albe(n1,ib,n2,ib)+cij
                     d2albe(n2,ib,n1,ib)=d2albe(n2,ib,n1,ib)+cij
                  enddo
               else
                  do i=1,noccb
                     ib=ioccb(i)
                     if(ib.ne.n1.and.ib.ne.n2)then
                        d2bebe(n1,ib,n2,ib)=d2bebe(n1,ib,n2,ib)+cij
                        call permbis(d2bebe,n1,ib,n2,ib,nact)
                     endif
                  enddo
                  do i=1,nocca
                     ia=iocca(i)
c                     if (ia.gt.norb-ncore) cycle
                     d2albe(ia,n1,ia,n2)=d2albe(ia,n1,ia,n2)+cij
                     d2albe(ia,n2,ia,n1)=d2albe(ia,n2,ia,n1)+cij
                  enddo
               endif
               goto 2
c     due differenze
 20            continue
               n1=n1-ncore
               n2=n2-ncore
               n3=n3-ncore
               n4=n4-ncore
               cij=c(m)*c(n)*segno
c               print '(a,i1,a,i1,a,i1,a,i1)','Due diff.: ns1=',ns1,
c     $              ' ns2=',ns2,' ns3=',ns3,' ns4=',ns4
               if(ns1.eq.1.and.ns2.eq.1)then
                  d2alal(n1,n2,n3,n4)=d2alal(n1,n2,n3,n4)+cij
                  call permbis(d2alal,n1,n2,n3,n4,nact)
               elseif(ns1.eq.0.and.ns2.eq.0)then
                  d2bebe(n1,n2,n3,n4)=d2bebe(n1,n2,n3,n4)+cij
                  call permbis(d2bebe,n1,n2,n3,n4,nact)
               elseif(ns1.eq.1.and.ns2.eq.0)then
                  d2albe(n1,n2,n3,n4)=d2albe(n1,n2,n3,n4)+cij
                  d2albe(n3,n4,n1,n2)=d2albe(n3,n4,n1,n2)+cij
               endif
 2          continue
 1       continue
         return
         end
c------------------------------------------------------------------
      SUBROUTINE MATOUT(N,N2,A,NN)
      DOUBLE PRECISION A
      DIMENSION A(NN,*)
 
   20 FORMAT(//,8X,11(5X,I3,3X))
   30 FORMAT(1X,I4,4X,11(F11.6))
   35 FORMAT(8X,11(5X,I3,3X))
   37 FORMAT(8X,11(4X,A4,3X))
   36 FORMAT(/)
      DO 40 M=1,N2,6
      K=M+5
      IF(K.LE.N2) GOTO 10
      K=N2
   10 WRITE(6,20) (J,J=M,K)
      WRITE(6,36)
      WRITE(6,36)
      DO 40 I=1,N
      WRITE(6,30) I,(A(I,J),J=M,K)
 40   CONTINUE
      call flush(6)
      RETURN
      END
c----------------------------------------------------------------
      subroutine v0p(thrvar,ncore,nact,zprt,zint,ain)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /perturber/onel(id1*(id1+1)/2)
      common/detinf/zact(id1)
      COMMON /KOO/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      common /density/ rotota(id1,id1),rototb(id1,id1)
      dimension ain(norb,ncore+nact,ncore+nact,ncore+nact)

      zfa=.false.
      
c      write (6,*) 'nact',nact
c      write (6,*) 'ncore',ncore
c      write (6,*) 'norb',norb

      do 800 ii=1,ncore
      isy=itsym(ii)

      do 700 ir=ncore+nact+1,norb
      irsy=itsym(ir)
      irisy=its(isy,irsy)

      if (irisy.ne.1) goto 700

      if (zprt) then
      write (6,*) 
      write (6,*) 'Eccitazione con gli indici',ii,' -> ',ir
      call flush(6)
      endif
      

      irind=ir*(ir-1)/2+ii
      dint=onel(irind)
      do i=1,ncore
       if (zint) then
       dint=dint+2.d0*ain(ir,ii,i,i)-ain(ir,i,i,ii)
       else
       dint=dint+2.d0*ai(ir,ii,i,i)-ai(ir,i,i,ii)
       endif
      enddo
      einta=dint
      eintb=dint
      do ia=1,nact
       do ib=1,nact
       iaa=ia+ncore
       iba=ib+ncore
       if (zint) then
       dumJ=ain(ir,ii,iaa,iba)
       dumJK=dumJ-ain(ir,iba,iaa,ii)
       else
       dumJ=ai(ir,ii,iaa,iba)
       dumJK=dumJ-ai(ir,iba,iaa,ii)
       endif
       einta=einta+dumJK*rhoa(ib,ia)+dumJ*rhob(ib,ia)
       eintb=eintb+dumJK*rhob(ib,ia)+dumJ*rhoa(ib,ia)
       enddo
      enddo

      den=fmpb(ii)-fmpb(ir)

c      rotota(ir,ii)=0.5d0*(einta+eintb)/den
c      rototb(ir,ii)=0.5d0*(eintb+einta)/den
      rotota(ir,ii)=0.5d0*einta/den
      rototb(ir,ii)=0.5d0*eintb/den
      rotota(ii,ir)=rotota(ir,ii)
      rototb(ii,ir)=rototb(ir,ii)

  700 enddo

  800 enddo
   
   10 format (A,3F15.8)


      return
      end
c----------------------------------------------------------------
      subroutine vmup(thrvar,ncore,nact,d2alal,d2bebe,d2albe,zprt,
     *          zint,ain)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /perturber/onel(id1*(id1+1)/2)
      common/detinf/zact(id1)
      common /koo/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      common /density/ rotota(id1,id1),rototb(id1,id1)
      dimension d2alal(nact,nact,nact,nact),d2bebe(nact,nact,nact,nact)
      dimension d2albe(nact,nact,nact,nact)
      dimension finta(id1,id1),fintb(id1,id1)
      dimension ain(norb,ncore+nact,ncore+nact,ncore+nact)

      do 800 ir=ncore+nact+1,norb 
      irsy=itsym(ir)

      do 700 id=ncore+1,ncore+nact
      idi=id-ncore
      idsy=itsym(id)
      idrsy=its(irsy,idsy)

      if (idrsy.ne.1) goto 700

      if (zprt) then
      write (6,*) 
      write (6,*) 'Elemento ',id,' -> ',ir
      call flush(6)
      endif

      einta=0.d0
      eintb=0.d0

      do ia=ncore+1,ncore+nact
      irind=ir*(ir-1)/2+ia
      dint=onel(irind)
      do i=1,ncore
       if (zint) then
       dint=dint+2.d0*ain(ir,ia,i,i)-ain(ir,i,i,ia)
       else
       dint=dint+2.d0*ai(ia,ir,i,i)-ai(ia,i,i,ir)
       endif
      enddo
      densa=rhoa(id-ncore,ia-ncore)
      densb=rhob(id-ncore,ia-ncore)
      einta=einta+dint*densa
      eintb=eintb+dint*densb
      enddo

      do ia=1,nact
      iaa=ia+ncore
       do ib=1,nact
       iba=ib+ncore
        do ic=1,nact
        ica=ic+ncore
       if (zint) then
       dumJ=ain(ir,ica,iaa,iba)
       dumK=ain(ir,iba,iaa,ica)
       else 
       dumJ=ai(ir,ica,iaa,iba)
       dumK=ai(ir,iba,iaa,ica)
       endif
       dumJK=dumJ-dumK
       dinta=dumJ*d2albe(ic,ib,idi,ia)
       dintb=dumK*d2albe(ic,ib,ia,idi)
       if(ib.lt.ic) dinta=dinta+dumJK*d2alal(ic,ib,idi,ia)
       if(ib.lt.ic) dintb=dintb+dumJK*d2bebe(ic,ib,idi,ia)
       einta=einta+dinta
       eintb=eintb+dintb
      enddo
       enddo
      enddo

      finta(ir,id)=einta
      fintb(ir,id)=eintb

  700 enddo

  800 enddo

      do 100 id=1,nact
      idi=id+ncore
       idsym=itsym(idi)

       do 90 ir=ncore+nact+1,norb
       irsym=itsym(ir)
c       if (its(irsym,idsym).ne.1) goto 90
       do 80 imu=1,nipa
       dinta=0.d0
       do ib=1,nact
       iba=ib+ncore
       do ic=1,nact
       dinta=dinta+cipa(ib,imu)*(finta(ir,iba)+fintb(ir,iba))
     *      *rhoa(id,ic)*cipa(ic,imu)
       enddo
       enddo
       rotota(idi,ir)=rotota(idi,ir)-0.5*dinta/(dipa(imu)+fmpb(ir))
      rotota(ir,idi)=rotota(idi,ir)
  80  enddo
       do 81 imu=1,nipb
       dintb=0.d0
       do ib=1,nact
       iba=ib+ncore
       do ic=1,nact
       dintb=dintb+cipb(ib,imu)*(fintb(ir,iba)+finta(ir,iba))
     *       *rhob(id,ic)*cipb(ic,imu)
       enddo
       enddo
       rototb(idi,ir)=rototb(idi,ir)-0.5*dintb/(dipb(imu)+fmpb(ir))
      rototb(ir,idi)=rototb(idi,ir)
  81  enddo
  90  enddo

 100  enddo

      return
      end
c----------------------------------------------------------------
      subroutine vpup(thrvar,ncore,nact,d2alal,d2bebe,d2albe,zprt,
     *         zint,ain)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /vec/ c(id7),fmpb(id3)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /perturber/onel(id1*(id1+1)/2)
      common/detinf/zact(id1)
      common /koo/ rhoa(idac,idac),koopipa(idac,idac),
     * koopeaa(idac,idac),rhob(idac,idac),koopipb(idac,idac),
     * koopeab(idac,idac),cipa(idac,idac),cipb(idac,idac),
     * dipa(idac),dipb(idac),ceaa(idac,idac),ceab(idac,idac),
     * deaa(idac),deab(idac),shepsc,shepsv,
     * nipa,nipb,neaa,neab,ZCA,ZCV,ZAV,zsheps
      real*8 koopipb,koopipa,koopeab,koopeaa
      common /density/ rotota(id1,id1),rototb(id1,id1)
      dimension d2alal(nact,nact,nact,nact),d2bebe(nact,nact,nact,nact)
      dimension d2albe(nact,nact,nact,nact)
      dimension finta(id1,id1),fintb(id1,id1)
      dimension ain(norb,ncore+nact,ncore+nact,ncore+nact)

      do i=1,id1
       do j=1,id1
        finta(i,j)=0.d0
        fintb(i,j)=0.d0
       enddo
      enddo

      do 800 ii=1,ncore
      isy=itsym(ii)

      do 700 id=ncore+1,ncore+nact
      idi=id-ncore
      idsy=itsym(id)
      idisy=its(isy,idsy)

      if (idisy.ne.1) goto 700

      if (zprt) then
      write (6,*) 
      write (6,*) 'Elemento ',ii,' -> ',id
      call flush(6)
      endif

      einta=0.d0
      eintb=0.d0

      do ia=ncore+1,ncore+nact
      irind=ia*(ia-1)/2+ii
      dint=onel(irind)
      do i=1,ncore
       if (zint) then
       dint=dint+2.d0*ain(ia,ii,i,i)-ain(ia,i,i,ii)
       else
       dint=dint+2.d0*ai(ia,ii,i,i)-ai(ia,i,i,ii)
       endif
      enddo
      densa=-rhoa(id-ncore,ia-ncore)
      densb=-rhob(id-ncore,ia-ncore)
      if (ia.eq.id) then
      densa=densa+1.d0
      densb=densb+1.d0
      endif
      einta=einta+dint*densa
      eintb=eintb+dint*densb
      enddo

      do ib=1,nact
      iba=ib+ncore
       do ic=1,nact
       ica=ic+ncore
       if (zint) then
       dumJ=ain(id,ii,iba,ica)
       dumJK=dumJ-ain(id,ica,iba,ii)
       else
       dumJ=ai(id,ii,iba,ica)
       dumJK=dumJ-ai(id,ica,iba,ii)
       endif
       einta=einta+dumJK*rhoa(ib,ic)+dumJ*rhob(ib,ic)
       eintb=eintb+dumJK*rhob(ib,ic)+dumJ*rhoa(ib,ic)
       enddo
      enddo

      einta2=0.d0
      eintb2=0.d0
      do ia=1,nact
      iaa=ia+ncore
       do ib=1,nact
       iba=ib+ncore
        do ic=1,nact
        ica=ic+ncore
       if (zint) then
       dumJ=ain(iaa,ii,iba,ica)
       dumK=ain(iaa,ica,iba,ii)
       else
       dumJ=ai(iaa,ii,iba,ica)
       dumK=ai(iaa,ica,iba,ii)
       endif
       dumJK=dumJ-dumK
       dinta=dumj*d2albe(idi,ic,ia,ib)
       dintb=dumj*d2albe(ic,idi,ib,ia)
       if(ia.lt.ib) dinta=dinta+dumJK*d2alal(ic,idi,ib,ia)
       if(ia.lt.ib) dintb=dintb+dumJK*d2bebe(ic,idi,ib,ia)
       einta=einta-dinta
       eintb=eintb-dintb
c       dinta=dumj*d2albe(ia,ib,idi,ic)
c       dintb=dumj*d2albe(ib,ia,ic,idi)
c       if(ia.lt.ib) dinta=dinta+dumJK*d2alal(ia,ib,idi,ic)
c       if(ia.lt.ib) dintb=dintb+dumJK*d2bebe(ia,ib,idi,ic)
c       einta=einta-dinta
c       eintb=eintb-dintb
c       einta2=einta2-dinta
c       eintb2=eintb2-dintb
      enddo
       enddo
      enddo

c      einta1=0.d0
c      eintb1=0.d0
c      do ia=1,nact
c      iaa=ia+ncore
c       do ib=1,nact
c       iba=ib+ncore
c        do ic=1,nact
c        ica=ic+ncore
c       dumj=ai(iba,ii,iaa,ica)
c       dinta=dumj*(d2alal(idi,ic,ib,ia)+d2albe(idi,ic,ib,ia))
c       dintb=dumj*(d2bebe(idi,ic,ib,ia)+d2albe(ic,idi,ia,ib))
c       einta1=einta1+dinta
c       eintb1=eintb1+dintb
c       enddo
c       enddo
c      enddo
c
c      write (6,*) einta1,einta2
c      write (6,*) eintb1,eintb2


      finta(id,ii)=einta
      fintb(id,ii)=eintb

  700 enddo

  800 enddo

      do 100 id=1,nact
      idi=id+ncore
       idsym=itsym(idi)

       do 90 ii=1,ncore
       isym=itsym(ii)
       if (its(isym,idsym).ne.1) goto 90
       do 80 imu=1,neaa
       dinta=0.d0
       do ib=1,nact
       iba=ib+ncore
       do ic=1,nact
       ica=ic+ncore
       droa=-rhoa(id,ic)
       if (id.eq.ic) droa=droa+1.d0
       drob=-rhob(id,ic)
       if (id.eq.ic) drob=drob+1.d0
       dinta=dinta+ceaa(ib,imu)*(finta(iba,ii)+fintb(iba,ii))
     *  *droa*ceaa(ic,imu)
       enddo
       enddo
       rotota(ii,idi)=rotota(ii,idi)+0.5*dinta/(fmpb(ii)-deaa(imu))
  80  enddo
       do 81 imu=1,neab
       dintb=0.d0
       do ib=1,nact
       iba=ib+ncore
       do ic=1,nact
       ica=ic+ncore
       drob=-rhob(id,ic)
       if (id.eq.ic) drob=drob+1.d0
       dintb=dintb+ceab(ib,imu)*(fintb(iba,ii)+finta(iba,ii))
     *  *drob*ceab(ic,imu)
       enddo
       enddo
       rototb(ii,idi)=rototb(ii,idi)+0.5*dintb/(fmpb(ii)-deab(imu))
  81  enddo
      rotota(idi,ii)=rotota(ii,idi)
      rototb(idi,ii)=rototb(ii,idi)

      if (zprt) then
      write (6,*) 'indici ii,idi',ii,idi
      write (6,*) 'roa',rotota(idi,ii)
      write (6,*) 'rob',rototb(idi,ii)
      call flush(6)
      endif

  90  enddo

 100  enddo

      return
      end
C***********************************************************************
      SUBROUTINE IJKF(IPAS)
C 
C     J    INTEGRALES COULOMBIENNES STOCKEES DANS LE TABLEAU AJ
C     K    INTEGRALES D'ECHANGE     STOCKEES DANS LE TABLEAU AK
C     F    ELEMENTS DE L'OPERATEUR DE FOCK
C 
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /vec/ c(id7),fmpb(id3)
      common /hnd/ zhandy,zthree,zmotra,zfac
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /int/ ni4,ni3,ni2,nr4,
     * f(id2),aj(id2),ak(id2),num(id2),ndeb(500),nbo(99),
     * nad(2000),kt(2000),indic(id2),jndic(id2),lndic(id2)
      integer*2 indic,jndic,lndic,nad,kt
      dimension fdiag(id3),tocom(id1)
      common /perturber/onel(id1*(id1+1)/2)
      common/detinf/zact(id1)
      save fdiag
      dimension fock(id1,id1)
      common /toul/ ztoul
      nter=norb*(norb+1)/2
      ZPRT=.FALSE.
      ZION=.FALSE.

      if (ztoul) then

      rewind 26
      READ (26) (onel(L),L=1,NTER) !monoelettronici puri
      kl=0
      DO LL=1,NORB
      DO KK=1,LL
      kl=kl+1
      fock(ll,kk)=onel(kl)*factor
      fock(kk,ll)=onel(kl)*factor
      enddo
      enddo
      val=0
449   DO 500 ij=1,nocb
      VAL=VAL+Fock(ij,ij)*2.D0
      TT=AI(ij,ij,ij,ij)
      Fock(ij,ij)=Fock(ij,ij)+TT
      VAL=VAL+TT
      IM=ij-1
      IF(IM.EQ.0) GO TO 500
      DO 460 K=1,IM
      TT=AI(ij,ij,K,K)
      TK=AI(ij,K,ij,K)
      TT=TT+TT-TK
      Fock(ij,ij)=Fock(ij,ij)+TT
      Fock(K,K)=Fock(K,K)+TT
      VAL=VAL+TT+TT
      DO 450 J=1,nocb
450   Fock(ij,K)=Fock(ij,K)+AI(ij,K,J,J)*2.D0-AI(ij,J,K,J)
460   continue
500   CONTINUE
      I1=NOCB+1
      DO 600 ij=I1,NORB
      DO 600 J=1,ij
      TT=0.d0
      DO 550 K=1,NOCB
550   TT=TT+2.D0*AI(ij,J,K,K)-AI(ij,K,J,K)
600   Fock(ij,J)=Fock(ij,J)+TT
      kl=0
      DO LL=1,NORB
      DO KK=1,LL
      kl=kl+1
      f(kl)=fock(ll,kk)/factor
      enddo
      enddo
      write (50) (F(L),L=1,NTER)

      else

      READ (50) (F(L),L=1,NTER)
      READ (50) (onel(L),L=1,NTER)

      endif

      do ij=1,nter
      onel(ij)=onel(ij)*factor
      enddo
      L=0
      KL=0
      DO 3200 LL=1,NORB
      DO 3100 KK=1,LL
      KL=KL+1
      F(KL)=F(KL)*factor
      AJ(KL)=AI(LL,LL,KK,KK)
 3100 AK(KL)=AI(LL,KK,LL,KK)
c      write (6,*) 'F,AJ,AK=',f(kl),aj(kl),ak(kl)
      L=L+LL
      FDIAG(LL)=F(L)
 3200 FDIAG(LL+NORB)=F(L)
      IF (.NOT.ZPRT.OR.IPAS.GT.1) GOTO 3400
      WRITE (6,3250)
 3250 FORMAT (/5X,'INTEGRALES J')
      MAX=0
      DO 3260 L=1,NORB
      MIN=MAX+1
      MAX=MAX+L
      WRITE (6,3270) L
 3260 WRITE (6,3280) (AJ(KL),KL=MIN,MAX)
 3270 FORMAT (I8)
 3280 FORMAT (1X,10F13.0)
      WRITE (6,3350)
 3350 FORMAT (/5X,'INTEGRALES K')
      MAX=0
      DO 3360 L=1,NORB
      MIN=MAX+1
      MAX=MAX+L
      WRITE (6,3270) L
 3360 WRITE (6,3280) (AK(KL),KL=MIN,MAX)
 3400 IF (.NOT.ZION) GOTO 3600
      NTER=NTER+1
      NN=NTER+NORB+NORB+2
      DO 3500 L=NTER,NN
      F(L)=0.D0
      AJ(L)=0.D0
 3500 AK(L)=0.D0
      FDIAG(NORB2+1)=0.D0
      FDIAG(NORB2+2)=0.D0
 3600 IF (IPAS.GT.1) RETURN
      rewind 25
      read (25) idum,idum,idum,ndegen
      read (25)
      do l=1,ndegen
      read (25)
      enddo
      READ (25) ESCF,(TOCOM(L),L=1,NORB)
      DO 4300 L=1,NOCB
 4300 TOCOM(L)=TOCOM(L)-2.D0
      DO 4500 L=1,NORB
      T=FDIAG(L)
      LJ=NUM(L)
      DO 4400 J=1,NORB
      LJ=LJ+1
      IF (J.GT.L) LJ=NUM(J)+L
 4400 T=T+TOCOM(J)*(AJ(LJ)-0.5D0*AK(LJ))
      FMPB(L)=T
 4500 FMPB(L+NORB)=T
      IF (ZION) FMPB(NORB2+1)=0.D0
      IF (ZION) FMPB(NORB2+2)=0.D0
      WRITE (6,4600)
 4600 FORMAT (/'    O.M.  ACT.  SYMETRIE   N. D''OCCUP.      ENERGIE',
     * '      INT. COULOMB')
      ntrpa=nd(ncf)+ne(ncf)
      do 4700 l=1,norb
      zactl=.false.
      do j=1,ntrpa
      if (trou(j).eq.l) zactl=.true.
      if (part(j).eq.l) zactl=.true.
      if (trou(j)-norb.eq.l) zactl=.true.
      if (part(j)-norb.eq.l) zactl=.true.
      enddo
      ll=(l*l+l)/2
      if (l.le.nocb) write (6,4800)
     * 'occ ',l,zactl,itsym(l),tocom(l)+2.d0,fmpb(l)*finv,aj(ll)*finv
      if (l.gt.nocb) write (6,4800)
     * 'virt',l,zactl,itsym(l),tocom(l),fmpb(l)*finv,aj(ll)*finv
 4700 continue
 4800 format (1x,a4,i4,l4,i8,f15.6,2f16.8)
      RETURN
      END
c----------------------------------------------------------------
      subroutine giveocc2(m,iocca,ioccb,nact,ncore,nocca,noccb,nocc,nec
     $     ,ndm,trou,part,iorb,ispin,norb)
      implicit real*8 (a-h,o-y),logical*1 (z)
      dimension iocca(*),ioccb(*),trou(*),part(*),iorb(*),ispin(*)
      integer*2 trou,part,iorb,ispin
      do i=1,nact
         if(i.le.nocc)then
            iocca(i)=i
            ioccb(i)=i
         else
            iocca(i)=0
            ioccb(i)=0
         endif
      enddo
      do i=1,nec
         it=trou(ndm+i)
         ip=part(ndm+i)
         its=ispin(it)
         ips=ispin(ip)
         it=iorb(it)-ncore
         ip=iorb(ip)-ncore
         if(its.eq.1)then
            iocca(it)=0
         else
            ioccb(it)=0
         endif
         if(ips.eq.1)then
            if (ip.le.(norb-ncore)) iocca(ip)=ip
         else
            ioccb(ip)=ip
         endif
      enddo
      nocca=0
      noccb=0
      do i=1,nact
         if(iocca(i).ne.0)then
            nocca=nocca+1
            iocca(nocca)=iocca(i)
         endif
         if(ioccb(i).ne.0)then
            noccb=noccb+1
            ioccb(noccb)=ioccb(i)
         endif
      enddo
      return
      end
c---------------------------------------------------------------------
      FUNCTION Jdifgen(ne,nd,trou,part,II,JJ,nv1,nv2,nma,zsig)
      implicit real*8(a-h,o-y),logical*1(z)
C
C     SSP DE RECHERCHE DES ELEMENTS D'INTERACTION
C     ENTRE DEUX DETERMINANTS, NUMEROTES II ET JJ
C
      parameter (nmax=4)
      dimension ne(*),nd(*),trou(*),part(*)
      INTEGER*2 NE,TROU,PART
      DIMENSION ITA(99),ITB(99),NV1(nmax),NV2(nmax),NATU1(nmax)
     $     ,NATU2(nmax)
      common/diff/n1,n2,n3,n4,ns1,ns2,ns3,ns4,nbdif
      KR=II
      KL=JJ
C
C     LE DETERMINANT - 1 - EST CHOISI COMME LE
C     DETERMINANT AYANT LE PLUS D'O.M. EXCITEES
C
      zshift=.false.
      IF (NE(KR)-NE(KL)) 5,7,7
    5 KKKK=KR
      KR=KL
      KL=KKKK
      zshift=.true.
    7 NE1=NE(KR)
C     TEST SUR LE FONDAMENTAL
      IF (NE1.EQ.0) GOTO 44
      NE2=NE(KL)
C     NBDIF : EST LE NOMBRE DE SPIN-ORBITALES
C     DIFFERENTES
      NBDIF=NE1-NE2
      IF (NBDIF.GT.nma) GOTO 24
C     CONSTRUCTION POUR LE DETERMINANT -1- ET -2-
C     DE IT ET NS, QUI CONTIENNENT LES NUMEROS
C     DES ORBITALES ET LEURS SPINS
C
      ND1=ND(KR)
      ND2=ND(KL)
      DO 15 J=1,NE1
         ITA(J)=TROU(J+ND1)
         ITA(J+NE1)=PART(J+ND1) 
 15   CONTINUE
C
C     ZSIG :  EST LA PARITE DU  NOMBRE DE CROISEMENTS
C     DANS LE DIAGRAMME D INTERACTION
      ZSIG=.FALSE.
C     SI NE2=0 LE DETERMINANT -2- EST LE FONDAMENTAL
      IF (NE2.EQ.0) GOTO 125
 121  CONTINUE
      DO 25 J= 1,NE2
         ITB(J)=TROU(J+ND2)
 25   ITB(J+NE2)=PART(J+ND2)
    4 DO 8 K=1,2
         K1=(K-1)*NE1
         K2=(K-1)*NE2
         DO 10I=1,NE2
            NIT1=ITB(K2+I)
            J1=1+K1
            J2=NE1+K1
            DO 12 J=J1,J2
               NJT2=ITA(J)
               IF (NIT1.NE.NJT2) GOTO 12
               IF (I.EQ.(J-K1)) GOTO 10
               ITA(J)=ITA(I+K1)
               ITA(I+K1)=NJT2
               ZSIG=.NOT.ZSIG
               GOTO 10
 12         CONTINUE
            NBDIF=NBDIF+1
            IF (NBDIF.GT.nma) GOTO 24
            NV1(NBDIF)=NIT1
            NATU1(NBDIF)=K
            NATU2(NBDIF)=I
 10         CONTINUE
 8       CONTINUE
 125     IF (NBDIF.LE.0) GOTO 44
C
C     NAR : EXCITATION SUPLEMENTAIRE DU DETERMINANT -1-
C     PAR RAPPORT AU DETERMINANT -2-
 26      NAR=NE1-NE2
         IF (NAR.LE.0) GOTO 28
 30      DO 32 I=1,NAR
            NET=NE1+1-I
            NV1(I)=ITA(NET)
            NV2(I)=ITA(NET+NE1)
 32      CONTINUE
 28      NBAR=NBDIF-NAR
         IF (NBAR.LE.0) GOTO 34
 36      NAR1=NAR+1
         DO 38 I=NAR1,NBDIF
            K=NATU1(I)
            NI=NATU2(I)
            NU=NV1(I)
            NV2(I)=ITA(NI+NE1*(K-1))
            IF (K.EQ.2) GOTO 38
 40         NV1(I)=NV2(I)
            NV2(I)=NU
            ZSIG=.NOT.ZSIG
 38      CONTINUE
 34      CONTINUE
C     CALCUL DE L ELEMENT DE MATRICE
 2       continue
         if(zshift)then
            do i=1,nbdif
               ndum=nv1(i)
               nv1(i)=nv2(i)
               nv2(i)=ndum
            enddo
         endif
         jdifgen=1
         RETURN
 24      Jdifgen=0
         RETURN
 44      WRITE (6,1006) II,JJ,NE1,NE2
 1006    FORMAT (//5X,'IDENTITE DANS HNTD'/' II,JJ,NE1,NE2 =',4I4)
         WRITE (6,1007) (ITA(K),K=1,NE1)
         WRITE (6,1008) (ITA(K+NE1),K=1,NE1)
         WRITE (6,1007) (ITB(K),K=1,NE2)
         WRITE (6,1008) (ITB(K+NE2),K=1,NE2)
 1007    FORMAT (' TROU',8I4)
 1008    FORMAT (' PART',8I4)
         STOP
         END

c--------------------------------------------------------------------
      subroutine permbis(d,i,j,k,l,nact)
      implicit real*8 (a-h,o-y),logical*1 (z)
      dimension d(nact,nact,nact,nact)
c--block 1
      a=d(i,j,k,l)
      d(j,i,k,l)=-a
      d(k,l,i,j)=a
      d(k,l,j,i)=-a
c--block 2
      d(i,j,l,k)=-a
      d(j,i,l,k)=a
      d(l,k,i,j)=-a
      d(l,k,j,i)=a
      return
      end
C------------------------------------------------
      subroutine ord2(nv,nw,zseg,segno)
c--prima gli alfa poi i beta
      logical*1 zseg
      integer segno
      dimension nv(*),nw(*)
      if(nv(2).gt.nv(1))then
         n=nv(1)
         nv(1)=nv(2)
         nv(2)=n
         zseg=.not.zseg
      endif
      if(nw(2).gt.nw(1))then
         n=nw(1)
         nw(1)=nw(2)
         nw(2)=n
         zseg=.not.zseg
      endif
      if(zseg)then
         segno=-1
      else
         segno=1
      endif
      return
      end
c-----------------------------------------------------
      subroutine ro1(rhoa,rhob,ncore,nact,thr,zprt,zion)
      implicit real*8 (a-h,o-y),logical*1 (z)
      include 'cippi.prm'
      dimension rhoa(idac,idac),rhob(idac,idac)
      integer segno
      common /vec/ c(id7)
      common /cip/ factor,finv,norb,norb2,nocb,noca,nao,ngelo,ngelv,
     * ncf,nsym
      common /det/ nd(id9),ne(id9),trou(id8),part(id8),iorb(id3),
     * ispin(id3),itsym(id3),its(20,20)
      integer*2 ne,trou,part,iorb,ispin
      common /diff/ n1,n2,n3,n4,ns1,ns2,ns3,ns4,nbdif,zseg
      dimension nv(4),nw(4)
      n=nact
      nocc=nocb-ncore
      nn=(n*n+n)/2
c      print*,'subr. ro1'
c      print*,'n=',n,' nocc=',nocc,' ncf=',ncf
      nac=nocc
      do j=1,nac
         rhoa(j,j)=1.d0
         rhob(j,j)=1.d0
      enddo
      do 1 i=1,ncf
         if(abs(c(i)).lt.thr)goto 1
         do 2 j=1,i
            if(abs(c(j)).lt.thr)goto 2
            if(i.eq.j)goto 3
            ij=jdifgen(ne,nd,trou,part,i,j,nv,nw,1,zseg)
c            write (6,*) 'i,j',i,j,ij
            if(ij.eq.0)goto 2
            if(zseg)then
               segno=-1
            else
               segno=1
            endif
            n1=iorb(nv(1))
            ns1=ispin(nv(1))
            n2=iorb(nw(1))
            ns2=ispin(nw(1))
            n2=n2-ncore
            n1=n1-ncore
            if (ns1.eq.1) then
            rhoa(n1,n2)=rhoa(n1,n2)+c(i)*c(j)*segno
            rhoa(n2,n1)=rhoa(n1,n2)
            else
            rhob(n1,n2)=rhob(n1,n2)+c(i)*c(j)*segno
            rhob(n2,n1)=rhob(n1,n2)
            endif
            goto 2
 3          nec=ne(i)
            if(nec.eq.0)goto 2
            cmi2=c(i)*c(i)
            ndi=nd(i)
c            write (6,*) 'i=',i,nec,cmi2
            do 30 l=1,nec
               lts=trou(l+ndi)
               lps=part(l+ndi)
               lt=iorb(lts)-ncore
               lp=iorb(lps)-ncore
c               write (6,*) 'l=',l,lts,lt,lps,lp

                if (ispin(lts).eq.1) then
                 rhoa(lt,lt)=rhoa(lt,lt)-cmi2
                else
                 rhob(lt,lt)=rhob(lt,lt)-cmi2
                endif

                if (ispin(lps).eq.1) then
                 if (lp.le.norb-ncore) rhoa(lp,lp)=rhoa(lp,lp)+cmi2
                else
                 if (lp.le.norb-ncore) rhob(lp,lp)=rhob(lp,lp)+cmi2
                endif

 30         continue
 2       continue
 1    continue
      return
      end

