      program costnevpt
!
!     interface fichiers norme COST --> nevpt
!
      implicit real*8 (a-h,o-y),logical*1 (z)
      character(10000) namel
      character(80) prefix
      character(80) davec,ijcl,info,mono,det,f25,f04,aa,mono_new
      character(80) davec1,ijcl1,info1,mono1,det1,f251,f041,mono_new1
      real(8),allocatable,dimension(:,:) :: v
      real(8),allocatable,dimension(:) :: v1
      real(8),allocatable,dimension(:) :: e,hmono
      integer(4),allocatable,dimension(:) :: itsym,ND
      integer(2),allocatable,dimension(:) :: trou,part,ne,trou1,part1
      parameter(maxorbcas=16)
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension its(8,8)
      integer frozen(8),delete(8),numero(50)
      logical yw
      dimension aaint(4096)
      integer(2) iint(4096),jnt(4096),knt(4096),lnt(4096)
      common/spin/ms2
      yw=.false.
      print*,' '
      print*,'============================================='
      print*,'     Wrapper     COST --> nevpt'
      print*,'============================================='
      print*,' '
      open(4,status='unknown',form='unformatted',file='file04')
      open(25,status='unknown',form='unformatted',file='file25')
!
!     read data
!
      prefix=' '
      davec1=' '
      ijcl1=' '
      info1=' '
      mono1=' '
      mono_new1=' '
      det1=' '
      f251=' '
      f041=' '
      davec='davec'
      ijcl='ijcl'
      info='Info'
      mono='Mono'
      mono_new='mono'
      det='det'
      f25='f25'
      f04='f04'
      do i=1,50
      numero(i)=0
      enddo
      numero(1)=1
      nstates=1
      ijclf=0  ! ==1: lecture ijcl  ,  ==2: lecture ijcl2,ijcl3,ijcl4
      call lecnam('&CNEVPT',namel,5,ierr,1)
      call namela(namel,prefix,'PREFIX')
      call namela(namel,DAVEC1,'DAVEC1')
      call namela(namel,DAVEC,'DAVEC')
      call namela(namel,IJCL1,'IJCL1')
      call namela(namel,IJCL,'IJCL')
      call namela(namel,ijcl21,'IJCL21')
      call namela(namel,ijcl31,'IJCL31')
      call namela(namel,ijcl41,'IJCL41')
      call namela(namel,ijcl2,'IJCL2')
      call namela(namel,ijcl3,'IJCL3')
      call namela(namel,ijcl4,'IJCL4')
      call nameli(namel,ijclf,'IJCLF',4)
      call namela(namel,MONO_NEW1,'MONO_NEW1')
      call namela(namel,MONO_NEW,'MONO_NEW')
      call namela(namel,MONO1,'MONO1')
      call namela(namel,MONO,'MONO')
      call namela(namel,INFO1,'INFO1')
      call namela(namel,INFO,'INFO')
      call namela(namel,DET1,'DET1')
      call namela(namel,DET,'DET')
      call namela(namel,F251,'F251')
      call namela(namel,F25,'F25')
      call namela(namel,F041,'F041')
      call namela(namel,F04,'F04')
      call nameli(namel,nstates,'NSTATES',4)
      call nameli(namel,NUMERO,'NUMERO',4)
      print*,'NSTATES',NSTATES
      if(davec1==' ') davec1=trim(prefix)//trim(davec)
      if(ijcl1==' ') ijcl1=trim(prefix)//trim(ijcl)
      if(info1==' ') info1=trim(prefix)//trim(info)
      if(mono1==' ') mono1=trim(prefix)//trim(mono)
      if(mono_new1==' ') mono_new1=trim(prefix)//trim(mono_new)
      if(det1==' ') det1=trim(prefix)//trim(det)
      if(f251==' ') f251=trim(prefix)//trim(f25)
      if(f041==' ') f041=trim(prefix)//trim(f04)


      if (numero(nstates).eq.0) then
      write (6,*) 'Automatic definition of the considered states'
      do i=1,nstates
      numero(i)=i
      enddo
      endif

!     read &cdi
      ms2=0
      open(99,file=trim(prefix)//'cdi',status='old')
      call lecnam('&CDI',namel,99,ierr,1)
      call nameli(namel,MS2,'MS2',4)
      close(99)
      print*,'ms2',ms2
!
!     open read files
!
      print*,' '
      print*,'--------------------------------------------------'
      print*,'FILE NAMES:'
      print*,'read:'
      print*,trim(davec1)
      print*,trim(ijcl1)
      print*,trim(info1)
      print*,trim(mono1)
      print*,trim(det1)
      print*,'write:'
      print*,trim(mono_new1)
      print*,trim(f251)
      print*,trim(f041)
      open(59,status='old',form='unformatted',file=davec1)
      open(50,status='old',form='unformatted',file=ijcl1)
      maxlong=200000000
      call filesplit('OPEN',50,maxlong,idum,idum2)
      open(12,status='old',form='formatted',file=info1)
      open(26,status='old',form='unformatted',file=mono1)
      open(27,status='old',form='unformatted',file=det1)
!
!     read davec
!
      read(59) n,nvec
      allocate(v(n,nvec),e(nvec))
      read(59) e,enuc,el_en
      do k=1,nvec
         read(59) v(:,k)
      enddo
!
!     print info
!
      print*,' '
      print*,'Number of determinants    ',n
      print*,'Number of vectors in casdi',nvec
      print*,'Number of Vector(s) : NSTATES=',nstates
      print*,'Perturbed Vector(s) : NUMERO =',(numero(i),i=1,nstates)
      if(numero(nstates)>nvec) then
         print*,'numero(nstates)>nvec'
         stop
      endif
      print*,'--------------------------------------------------'
      print*,' '
      call flush(6)
!
!     read info
!
      frozen=0
      call lecnam('COST_AO',namel,12,ierr,1)
      call nameli(namel,ITS,'ITS',4)
      call nameli(namel,nao,'NORB',4)
      rewind 12
      call lecnam('COST_MO',namel,12,ierr,1)
      call nameli(namel,NSYM,'NSYM',4)
      call nameli(namel,NORB,'NORB',4)
      call nameli(namel,NOC,'NOC',4)
      call nameli(namel,FROZEN,'FROZEN',4)
      delete=nao-norb-frozen
      allocate(itsym(norb))
      call nameli(namel,ITSYM,'ITSYM',4)
      if(yw)print*,'norb,nsym,noc',norb,nsym,noc
      if(yw)print*,'itsym',(itsym(k),k=1,norb)
!
!     read det
!     reorder determinants in increasing excitation
!     choose vector to be perturbed
!
      allocate(ne(n),nd(n))
      allocate(trou((maxorbcas+2)*n))
      allocate(part((maxorbcas+2)*n))
      allocate(v1(n*nstates))
      nn=0
      kk=0
      do nex=0,maxorbcas+2
         call venond0(27)
         do k=1,n
            call venond(27,nee,ntv,npv,ierr,norb)
            if(nex==nee) then
               kk=kk+1
               if(yw)print'(a,20i3)','det',ntv(1:nee),npv(1:nee)
               nd(kk)=nn
               ne(kk)=nee
               trou(nn+1:nn+ne(kk))=ntv(1:ne(kk))
               part(nn+1:nn+ne(kk))=npv(1:ne(kk))
               nn=nn+ne(kk)
               do istate=1,nstates
               v1(kk+(istate-1)*n)=v(k,numero(istate))
               enddo
            endif
         enddo
         if(kk==n) exit
      enddo

!
!     read Mono
!
      nter=NORB*(NORB+1)/2
      allocate(hmono(nter))
      read(26) aa
 18   continue
      read(26) aa
      read(26)
      read(26)
c        essai de lecture en triangle
      if(index(aa,'ONEINT MATRIX (TOTAL)').eq.0) goto 18
      if(yw)print*,'index',index(aa,'ONEINT MATRIX (TOTAL)')
      backspace (26)
      backspace (26)
      read(26) nter,nsym
      read(26) hmono
!
!     Find factor
!
      bigint=0.d0
      idummy=0
      do
         call filesplit('READ',50,16*4096,ichange,idum2)
c         idummy=idummy+16*4096
c         write (6,*) idummy,ichange
c         call flush(6)
         read(50) iint,jnt,knt,lnt,aaint
         do n1=1,4096
            lab=knt(n1)
c            write (6,*) iint(n1),jnt(n1),knt(n1),lnt(n1),aaint(n1)
c            call flush(6)
            if(lab==0) goto 2
            bigint=max(bigint,abs(aaint(n1)))
         enddo
      enddo
  2   continue
      factor=2147483647.d0/bigint
      print*,'factor',factor
!
!     open write files
!
      if(yw)print*,'ouverture ',f041
      if(yw)print*,'ouverture ',f251
      open(25,status='unknown',form='unformatted',file=f251)
      open(04,status='unknown',form='unformatted',file=f041)
      open(28,status='unknown',form='unformatted',file=mono_new1)
      if(yw) then
         do k=1,n
            print*,'ne dans costnevpt',k,ne(k),nd(k)
         enddo
         do k=1,100
            print*,'cost tp',k,trou(k),part(k)
         enddo
      endif
      if(yw)print*,'E',e,el_en,enuc,el_en+enuc
      eref=el_en+enuc
      print*,'Eref',eref
      print*,'write file f04'
      zhandy=.False.
      zthree=.False.
      write(4) norb,noc,noc+norb,nstates,n,nn,n*nstates
     *,(NE(J),ND(J),J=1,N),
     *(TROU(J),PART(J),J=1,nn),V1
     *,(E(numero(i))*factor,i=1,nstates),(0.d0,J=1,nstates),
     * (0.d0,J=1,NORB),
     *(0.d0,J=1,NORB),0,
     *0,zhandy,zthree,FACTOR,eref
      !
      print*,'write file f25'
      write(25) NSYM,NORB,NOC,0,(ITSYM(I),I=1,NORB)
     *,nao,sum(frozen),sum(delete)
      write(25) ((ITS(I,J),I=1,NSYM),J=1,NSYM)
      write(25) enuc,enuc
      print*,'write file mono'
      write(28) hmono
      print*,' '
      print*,'End of Costnevpt'
      end

       subroutine reor(n,it,isgn)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      dimension it(n)
      isgn=1
      do 1 i=1,n-1
      do 2 j=i+1,n
      if(it(j).ge.it(i)) goto 2
      isgn=-isgn
      ii=it(i)
      it(i)=it(j)
      it(j)=ii
 2    continue
 1    continue
      return
      end

