      program CASDI
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      include 'iadri.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |             esp1              |
c
      common/dim/iadri0 ; integer(8) iadri0
      allocatable esp1(:)
      common/tps/icpu(10)
      common/debug/ ywgen
      common /det/ndet,mdet(50),nbdet_cas
      common/pliadri/ipliadri(2)
      write(6,*)' '
      write(6,*)'             #####     #     #####  ######    ###'
      write(6,*)'            #     #   # #   #     # #     #    #'
      write(6,*)'            #        #   #  #       #     #    #'
      write(6,*)'            #       #     #  #####  #     #    #'
      write(6,*)'            #       #######       # #     #    #'
      write(6,*)'            #     # #     # #     # #     #    #'
      write(6,*)'             #####  #     #  #####  ######    ###'
      write(6,*)' '
      ywgen=.false.
      ipliadri=0
      open(99,file='CASDI_BIEN_FINI',status='unknown')
      close(99,status='delete')
      open(93,status='unknown',file='CASDI_DATA',form='FORMATTED')
      call sto5
      call openf
      iadri0=max(iadri,ngru3*maxda3)
      iadri0=max(iadri0,(ndet/8)*8+8)
 1    continue
      allocate(esp1(iadri0*2))
! iadri0*8 doit pouvoir etre ecrit en integer*4  (2**31-1)
      max_int4=2**30+(2**30-1)
C      if(iadri0.gt.max_int4/8) then
C         print*,'iadri0 est trop grand pour que iadri0*8 puisse'//
C     *   ' etre ecrit en integer(4)'
C         print*,'iadri0=max(iadri,ndet)=',iadri0
C         print*,'valeur max',max_int4/8
C         stop
C      endif
C      print*,'iadri0',iadri0
      icpu(1)=itemps(idum)
      icpu(2)=itemps(idum)
c
c-------------------------------------------------------------------
c     ITEST
c     itest est initialise dans david.f
c     itest(1)    =irest (interne)
c     itest(2)=1  ecriture des element de mat ds cd04i
c                 sur file 99 ('mattest')               (def 0)
c     itest(3)=1  dans dif2c1 yw=T pour le det d'adresse
c                 itest(4)                              (def 0)
c     itest(5)=1  ecriture sur 98 ('lirint') dans lirint
c                 de certaines integrales               (def 0)
c                 puis stockage des elements de mat
c                 correspondants seulement (dans stover)
c     itest(6)    interne
c     itest(7)=1  ecriture det dans adrdet              (def 0)
CDIF2c     itest(8)=1  int <C...> directes + ech rapides     (def 0)
c     itest(11)=1 habillage sc2 lent
c     itest(11)=2 habillage sc2 rapide (Nadia)          (def 2)
c     itest(12)=0 calcul des racine 1 a 1
c     itest(12)=1 calcul des racine toutes ensemble     (def 1)
c     itest(13)   cas itest(12)=1 longueur de l'espace ou on
c                 stocke les vecteurs propres           (def iadri)
c     itest(14)=1 sc2 : creation de fichiers ei,eijl,ein,einjl
c                                                       (def 0)
c     itest(16)=1 les integrales monoelectroniques Rij sont
c                 contenues dans les bielectroniques <iaja>
c              =0 non                                   (def 1)
c     itest(21)=1
c                 on ajoute dans le fichier MAT quelques
c                 termes a la matrice (usage interne, pilote par
c                 calcul='MDD')
c     itest(25)=0 les determinants son lus sur le fichier detcl
c     itest(26)=1 les integrales sont stockees en caracteres
c                 (def 1)
c     itest(30)=1 stockage d'information a l'iteration 1
c                 utilisation dans les autres iterations (def 0)
c     itest(50) : interne (calcul='D' sans namelist cdi)
c     itest(63) : 1: fonctionne apres un calcul casdint, ne lit
c                 pas ijcl, mais ijcl2,ijcl3,ijcl4, n'effectue pas
c                 calech (def 0)
c     itest(73) : Concerne le critere de calcul du signe
c                 - Dans tous les calculs du programme, les determinants
c                 sont ecrits spin-orbitale par spin-orbitale, dans l'ord
c                 TCP. Ainsi, une excitation T-->P envoie un electron
c                 par-dessus les electrons de meme spin deja presents
c                 a droite de T et a gauche de P
c                 - Dans cipsi, un determinant de reference est ecrit 
c                 comme 
c                 determinant |0>. Tout determinant est ecrit comme une
c                 excitation par rapport a |0> (le degre d'excitation 
c                 peut
c                 aller jusqu'a noac+2). Dans cette excitation, on 
c                 remplace
c                 la spin-orbitale occupee en la laissant en place.
c                 ex : |0>=|1 2 3 4 5 6 7 8> exc=4-->10
c                 cipsi : |1 2 3 10 5 6 7 8>
c                 casdi : |1 2 3 5 6 7 8 10>
c                 itest(73)=0 : les det sont lus avec le critere cipsi
c                 (si nessai=2). Ils sont ecrits avec le critere cipsi 
c                 a la fin du programme (appel a sgncip pour passer du 
c                 signe casdi au signe cipsi.
c                 itest(73)=1 : les det sont lus avec le critere casdi
c                 (si nessai=2). Ils sont ecrits avec le critere casdi 
c                 a la fin du programme (pas d'appel a sgncip)
c                 defaut : 0
c     itest(76) : =0 : calcule la valeur propre de S2
c     itest(77) : =1 : ecriture detaillee de la lecture des donnees
c     itest(80)=0 /=0 annule le vecteur propre a partir de itest(80)+1
c                 (permet d'obtenir le resultat d'une IC selectionnee)
c     itest(81)=0 /=0 ecrit le vecteur sur SAUVCD et SAUVCD2 (2 phases d
c                 signes opposes) avant la multiplication H.Psi, a
c                 l'iteration itest(81), puis stoppe le programme
c     itest(82)=0 /=0 idem, apres la multiplication H.Psi
c     itest(83)=0 /=0 pour calcul='M' : n'ecrit pas la matrice dans mat
c     itest(84)=0 /=0 pour calcul='M' et mprint(3)=1 (ecriture des elts
c                 de mat sur le listing) : n'ecrit que les elts
c                 (itest(84),itest(85))
c-------------------------------------------------------------------
c
      call prepc(esp1,esp1(iadri0+1),esp1,esp1,esp1,esp1)
! Si ipliadri(2)/=0, on n'avait pas reserve assez de memoire
! pour gerer les integrales
! On redommence donc le programme depuis le debut
      !print*,'ipliadri',ipliadri
      if(ipliadri(2)/=0) then
         print*,'***********on augmente iadri, retour debut*********'
         deallocate(esp1)
         iadri0=ipliadri(1)
         iadri0=(iadri0/8)*8+8
         !print*,'Iadri0',iadri0
         ipliadri(1)=0
         goto 1
      endif
      call titre('FIN CASDI#',50)
      open(99,file='CASDI_BIEN_FINI',status='unknown')
      end
      block data
      common/gd/ melc(5),nmelc
      common/dispre/ivvvv1,ioooo2,ivovo3,ivvoo4,
     *iovvo5,ivooo6,ivoov7,ivvvc8
     *,iccvv9,icvcv10,ioocc11,iococ12
     *,icovv13,icvov14,icvoo15,icovo16
     *,icooo17,iccov18,icocv19,iccco20,icccv21,icccc22
      data melc /0,1,-1,2,-2/
      data ivvvv1,ioooo2,ivovo3,ivvoo4,iovvo5,ivooo6,ivoov7,ivvvc8
     *,iccvv9,icvcv10,ioocc11,iococ12,icovv13,icvov14,icvoo15,icovo16
     *,icooo17,iccov18,icocv19,iccco20,icccv21,icccc22
     */1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22/
c     */0,0,0,0,0,0,0,0,0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
      end
       subroutine prepc(esp1,esp2,iesp,iesp2,cesp,yesp)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxda3=300,ngru3=2048)
      parameter(maxorbcas=16,maxdetc=12870)
      !include 'iadri.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     esp1      |      esp2     |
c    |     iesp
c    |     cesp
c    |     yesp
c
      common/dim/iadri0 ; integer(8) iadri0
      integer*8 iadri16,ndc,ndy,ndr
      common /det/ndet,mdet(50),nbdet_cas
      common/adr/iadr0(maxsym),nbint
      dimension esp1(iadri0),esp2(iadri0)
!      dimension iesp(iadri*4)
!      integer*2 iesp2(iadri*8)
      dimension iesp(*)
      integer*2 iesp2(*)
      dimension yesp(*)
      dimension cesp(*)
      character*1 cesp
      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
      character*4 hab
      logical*1 bidia,bidiaf
      common/opt/ihab,calcul
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/pr/nprint,mprint(10)
      character*3 calcul
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common/rr/ idebd(maxorb*maxorb*2),idebd3(maxorb*maxsym)
     *,idebd1(maxorb)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension lvecf(maxda3)
      common/test/itest(100)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      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
      character*1 syspin
      common /sysp1/syspin
      common/stp/stop
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*5 nomfil70
      character*8 stop
      common/only/ ymatonly
      common/pliadri/ipliadri(2)
      integer(8) nemax8
      yw=.false.
      iadri16=iadri0
      open(75,status='unknown',file='BID75')
      iterh=0
! si on vient d'augmenter iadri (donc de recommencer le programme),
! sauter ce qu'on a deja fait :
      !print*,'IPLIADRI',ipliadri
      if(ipliadri(2)==1) goto 3
      if(ipliadri(2)==2) goto 4
      if(ipliadri(2)==3) goto 5
      if(ipliadri(2)==4) goto 6
      call lircd
c***************erreur a trouver : syspin remis a '0'
c             if(gener(1:2).eq.'MR'.and.ihab.ne.0
c     *       .and.itest(65).eq.0) then
c             syspin='0'
c             print*,'********syspin mis a ''0'''
c             endif
c
c            en fait le pb est qu'on perd la sym de spin avec
c            l'habillage, et il y a contradiction quand on la
c            remet de force
c            je supprime la correction
c            ... a surveiller
c********************
!      call verdim('dimension mat trop grande   : ndet iadri '
!     *,ndet,iadri0)
!      call verdim('dimension trop grande : maxda2*ngru3 iadri '
!     *,maxda2*ngru3,iadri0)
      if(itest(50).eq.1) goto 1
      !print*,'avant prepar'
       call flush(6)
      call prepar
      !print*,'avant pread'
       call flush(6)
      call pread
      !print*,'avant prepad'
       call flush(6)
      call prepad
      print*,' '
      print*,'********************************************'
      print*,'Nombre de determinants',ndet
      print*,'********************************************'
      print*,' '
      !print*,'avant cd01p'
       call flush(6)
      call cd01p
      if(gener(1:2).eq.'MR') then
         call mrs1(iesp)
      endif
      if(calcul.eq.'D') then
         read(2,end=1)
         read(2,end=1)
         read(2,end=1) enr,enuc,eref
         goto 1
      endif
      !print*,'avant vermat'
       call flush(6)
      call vermat(esp1,esp1,esp2(iadri0/2+1),nemax)
      !print*,'apres vermat'
       call flush(6)
      if(itest(25).eq.0) then
         nemax8=nemax
         call reorde(ndet,nemax,esp1,esp1(iadri0/2+1),esp1(iadri0/2+1))
      else
         !print*,'avant reorde2 norb',norb
c         call reorde2(ndet,nemax,iadrv,isspi(iadri+1),cesp(iadri*4+1))
         nemax8=nemax
         call reorde2
     *   (cesp(iadri0*4+1),cesp(iadri0*4+1),ndet,nemax8,esp1)
         !print*,'apres reorde2 norb',norb
      endif
c--   stockage des monos
      ystomono=itest(37).ne.0
      if(ystomono) then
         call stomono
      endif
c
      close(84,status='delete')
      !print*,'avant sgn1'
      call sgn1
      !print*,'avant sgn0'
      call sgn0(yesp)
      !print*,'apres sgn0'
      ii=nbint
      if(mod(ii,2).ne.0) ii=ii+1
      if(norb.lt.256) then
         nind=3
      else
         nind=4
      endif
 6    continue
      ipliadri(2)=0
      if(nbint*12/16>iadri0)  then
         ipliadri(1)=nbint*12/16
         ipliadri(2)=4
         return
      endif
!      call verdim('trop d int a 3 indices  (nbint*12/16), iadri=  '
!     *,ii*12/16+15,iadri0)
 3    continue
      ifac=1
      if(itest(53).eq.1.and.nbint*nind.lt.iadri0*2) ifac=2
      !print*,'avant adrin'
      call adrin(nbint,ifac,esp1,
     *cesp(nbint*8*ifac+1),yesp(nbint*(8+nind)*ifac+1))
      !print*,'apres adrin'
      if(ipliadri(2)/=0) return
      call flush(6)
      call fock0(esp1)
      !print*,'apres fock0'
      call flush(6)
      call fock(esp1)
      !print*,'apres fock'
      call flush(6)
      call ref
      !print*,'apres ref'
      call flush(6)
      ierr=0
 4    continue
      !print*,'avant calech itest(63)',itest(63)
      if(irest.eq.0.or.irest.eq.3)then
         if(itest(63).eq.0) then
            !print*,'avant calech'
            call calech(esp1,iesp,yesp,cesp,ierr)
            if(ipliadri(2)/=0) return
            if(ierr.ne.0) then
               stop
            endif
         else  if(itest(63).ge.1) then
 
            !call calech63(esp1,iesp,yesp,cesp,ierr)
         endif
      endif
 5    continue
      ipliadri(2)=0
      if(maxorbcas*maxdetc*2>iadri0)  then
         ipliadri(1)=maxorbcas*maxdetc*2
         ipliadri(2)=3
          !print*,'Ipliadri',ipliadri
         return
      endif
!      call verdim('depassement  dans prepc    iadri*4      ',
!     *maxorbcas*maxdetc*2,iadri0*4)
      !
      ! disint :
      ! division du fichier d'integrales en differents fichiers
      ! CDI_...., CDE_....
      !
      call disint
c      call disin8(cesp,esp1((iadri*2)/3+1),1)
c     a simplifier...
      if(ihab.eq.0) then
         if(norb.lt.256) then
            ndc=(iadri16*16)/3
            ndr=(iadri16*4)/3
            ndy=0
         else
c            ndc=(iadri*80)/13
            ndc=(iadri16/13)*80+(mod(iadri0,13)*80)/13
 
            ndr=(iadri16*16)/13
            ndy=0
c            ndc=iadri*17*5/13
c            ndr=(iadri*17)/13
         endif
c        si ihab.eq.0 yesp n'est pas utilise dans disin8
      else
         if(norb.lt.256) then
c            ndc=iadri*64/13
            ndc=(iadri16/13)*64+(mod(iadri0,13)*64)/13
            ndr=(iadri16*16)/13
            ndy=(iadri16*16)/13
         else
c            ndc=iadri*80/14
            ndc=(iadri16/14)*80+(mod(iadri0,14)*80)/14
            ndr=(iadri16*16)/14
            ndy=(iadri16*16)/14
         endif
      endif
      call disin8(cesp,esp1(ndc/8+1),yesp(ndc+(ndy+1)*8+1),1,ndc,ndr)
      call flush(6)
      call disin5(esp1,cesp(iadri16*9+1),yesp(iadri16*8+1),
     *yesp(iadri16*13+1))
      call flush(6)
      if(itest(20).eq.1) then
         call disin4(esp1,yesp,1)
         call disin4(esp1,yesp,2)
         call flush(6)
      endif
      close(32,status='delete')
      if(irest.ne.1.and.irest.ne.2.and.itest(63)==0)
     *call filesplit('DELETE',32,0,idum,irec)
      call gencas
      call flush(6)
      call predet(iesp)
      if(itest(67).eq.1.or.itest(68).eq.1) then
         call disin8(cesp,esp1(ndc/8+1),yesp(ndc+(ndy+1)*8+1),2,ndc,ndr)
      endif
      call flush(6)
 1    continue
      if(calcul.eq.'M') then
         iadri1=iadri0+1
         lbor=0
         nmulr=iadri0
         maxl=iadri0
         mmdet=iadri0
         call lirint(esp1)
         call diff1(esp1,esp2)
         call finver2(iesp,yesp(iadri0*4+1))
      else if(calcul.eq.'D') then
         call david(esp1,esp2,iesp,iesp2,yesp)
c         print*,'calculM apres david'
         return
      else if(calcul.eq.'MD') then
c        write(6,*)'Ndet 6',ndet
         call borli0
         if(ihab.eq.0) then
            call david(esp1,esp2,iesp,iesp2,yesp)
!            print*,' calculMD apres david',itest(46),itest(48)
!     *      ,itest(54)
         else if(ihab.eq.1) then
c--         calcul SC2
c           on met a l'abri quelques variables pour les retrouver
c           dans la derniere diagonalisation
            nvecf=nvec
            nessf=nessai
            bidiaf=bidia
            do k=1,nvec
               print*,'k',k
               lvecf(k)=lvec(k)
            enddo
c           write(6,*)'Ndet 7',ndet
c           on fait l'habillage sur le vecteur ihvec
            nvec=ihvec
            bidia=.false.
c           less lit les donnees concernant les vecteurs d'essai
c           write(6,*)'Ndet 1',ndet
            call less
            if(nessai.eq.2.or.lvec(1).eq.1) then
c              si on a un bon vecteur d'essai, on ne diagonalise pas
c              on doit alors calculer la diagonale
               call diagon(esp1,esp2,1)
c              write(6,*)'Ndet 2',ndet
c              on ne diagonalisera pas, donc on recopie les vecteurs
c              d'essai dans les vecteurs diagonalises
               rewind 11
               rewind 15
               read(15)i,j
               write(11) i,j
               read(15) (esp1(k),k=1,ihvec)
               write(11) (esp1(k),k=1,ihvec)
               do kk=1,ihvec
                  read(15) (esp1(k),k=1,ndet)
                  write(11) (esp1(k),k=1,ndet)
               enddo
c              on appelle david, mais on en resortira tout de suite
c              apres l'appel de essai, sans faire la diagonalisation
               call david(esp1,esp2,iesp,iesp2,yesp)
c              write(6,*)'Ndet 1',ndet
            else
               call david(esp1,esp2,iesp,iesp2,yesp)
               if(mprint(4).eq.1.or.ihprec.eq.0)
     *         call wvec(esp1,iesp(iadri0*2+1),yesp(iadri0*8+1))
            endif
c           on habille :
            if(itest(11).eq.0) then
               call sc2(esp1,iesp,iesp2,yesp,ndet,ierr)
            else if(itest(11).eq.2) then
               call sc2casnj(iesp2,esp1,esp2,iesp,yesp,esp1,esp2,ierr)
            else if(itest(11).eq.1) then
               call sc2casj(iesp2,esp1,esp2,iesp,yesp)
            endif
            if(nvecf.eq.ihvec.and.ihab.ne.2) goto 2
            write(6,1000) nvecf
 1000       format(/,70('*'),/,'DIAGONALISATION DE LA MATRICE HABILLEE',
     *      ' POUR ',I3,' VALEURS PROPRES',/,70('*'))
c           on reprend les parametres initiaux et on diagonalise
c           pour les racines excitees
            nvec=nvecf
            bidia=bidiaf
            nessai=nessf
            ngao=nvec
            rewind 93
            lvec(1)=1
            rewind 11
            ifiess=11
            if(nessai.eq.2) then
c              on complete la file 11 contenant le vecteur converge
c              avec les vecteurs donnes en vecteurs d'essai
               rewind 15
               read(11)
               read(11)
               read(11)
               read(15)
               read(15)
               read(15)
               do k=2,nvec
                  read(15)(esp1(l),l=1,ndet)
                  write(11)(esp1(l),l=1,ndet)
               enddo
            endif
            call david(esp1,esp2,iesp,iesp2,yesp)
 2          call wvec(esp1,iesp(iadri0*2+1),yesp(iadri0*8+1))
         else if (ihab.eq.2) then
            call diagon(esp1,esp2,1)
            if(itest(11).eq.2) then
               call sc2casnj(iesp2,esp1,esp2,iesp,yesp,esp1,esp2,ierr)
            else if(itest(11).eq.1) then
               call sc2casj(iesp2,esp1,esp2,iesp,yesp)
            endif
            write(6,1000) nvec
            call david(esp1,esp2,iesp,iesp2,yesp)
            call wvec(esp1,iesp(iadri0*2+1),yesp(iadri0*8+1))
         endif
      endif
      if(itest(33).eq.1) then
         do k=1,ndet
            esp2(k)=1.d0
         enddo
         call lire(esp1,1,ndet,21)
         call col1(esp1,esp2)
      endif
c
c     calcul de gamma2
c
      if(yg2) then
         yga2=.true.
         syspin='0'
         call gamma2(esp1,esp2,iesp1,cesp,yesp)
      endif
      if(stop.eq.'DEL') then
         print*,
     *   'stop=''DEL'', on n''efface pas les fichiers temporaires'
         stop
      endif
      call fin(esp1,esp2)
      return
      end
       function itemps(i)
      double precision t1
      call cpu_time(t1)
      itemps=t1
c      itemps=iclock()
c      itemps=0
      return
      end
