      program PROP
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorb=500)
      include 'iadri.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     esp1      |      esp2     |
c
      common/dim/ iadri0
      common/espa/ esp1(iadri),esp2(iadri)
c     *,esp3(iadri+iadri+iadri/8)
      dimension iesp(iadri*4)
      integer*2 iesp2(iadri*8)
      dimension yesp(iadri*16)
      dimension cesp(iadri*16)
      character*1 cesp
      character*5280 namel
      common/dyn/ydyn
      common/tps/icpu(10)
      equivalence (esp1(1),cesp(1))
      equivalence (esp1(1),iesp2(1))
      equivalence (esp1(1),yesp(1))
      equivalence (esp1(1),iesp(1))
      ydyn=.false.
      write(6,*)' '
      write(6,*)'       ########  ########      ###    ########'
      write(6,*)'        ##     #  ##     #   ##   ##   ##     #'
      write(6,*)'        ##     ## ##     ## ##     ##  ##     ##'
      write(6,*)'        ##     #  ##     #  ##     ##  ##     #'
      write(6,*)'        #######   #######  ###     ##  #######'
      write(6,*)'        ##        ## ##    ###     ##  ##'
      write(6,*)'        ##        ## ###   ###     ##  ##'
      write(6,*)'        ##        ##  ##    ##     ##  ##'
      write(6,*)'        ##        ##   ##   ##     ##  ##'
      write(6,*)'        ##        ##   ###   ##   ##   ##'
      write(6,*)'       ####      ####  ####     #     ####'
      write(6,*)' '
      if(mod(iadri,8).ne.0) then
         write(6,*)'iadri doit etre divisible par 8'
         stop
      endif
      iadri0=iadri
      icpu(1)=itemps(idum)
      icpu(2)=itemps(idum)
c
c-------------------------------------------------------------------
c     ITEST
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                 (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-------------------------------------------------------------------
c
      call prepc(esp1,esp2,iesp,iesp2,cesp,yesp)
      write(6,*)'FIN'
      end
      block data
      common/gd/ melc(5),nmelc
      common/dispre/ivvvv1,ioooo2,ivovo3,ivvoo4,
     *iovvo5,ivooo6,ivoov7,ivvvc8
     *,iccvv9,icvcv10,ioocc11,iococ12
      data melc /0,1,-1,2,-2/
      data ivvvv1,ioooo2,ivovo3,ivvoo4,iovvo5,ivooo6,ivoov7,ivvvc8
     *,iccvv9,icvcv10,ioocc11,iococ12
     */1,2,3,4,5,6,7,8,9,10,11,12/
c    */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,maxorb=500)
      parameter(maxal=56)
      parameter(maxorbcas=16,maxdetc=12870)
      include 'iadri.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     esp1      |      esp2     |
c    |     iesp
c    |     cesp
c    |     yesp
c
      common /det/ndet,mdet(50)
      common/adr/iadr0(maxsym),nbint
      dimension esp1(iadri),esp2(iadri)
      dimension iesp(iadri*4)
      integer*2 iesp2(iadri*8)
      dimension yesp(iadri*16)
      dimension cesp(iadri*16)
      character*1 cesp
      common/infdav/ alam(maxal),tau,twvec,twess,sint,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxal),ipresc,irest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,BIDIA,maxda2,ywvec,ytana
     *,yhmono,ydens,ywcas
      character*4 hab
      LOGICAL 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(maxal)
      common/test/itest(50)
      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
cpent 17-4-02
c introducimos el common para el numero de estado
      common/ronum/deltae,numero(2)
c y otra variable del namelist para controlar
c el calculo o lectura de ro
      common/rocal/calcro
      character*8 stop
cpent 18-4-02
      dimension e(50)

      open(75,status='unknown',file='BID75')
      open(93,status='unknown',file='BID93',form='FORMATTED')
      call sto5
      iterh=0
      write(6,*)'iadri',iadri
      call openf
c      print*,'apres openf'
      call lircd
      call verdim('dimension mat trop grande   : ndet iadri '
     *,ndet,iadri)
      call prepar
      call pread
c      print*,'avant prepad'
      call prepad
      call cd01p
      if(gener(1:2).eq.'MR') then
         call mrs1
      endif
c      print*,'avant vermat'
      call vermat(esp1,esp1,esp2(iadri/2+1),nemax)
c      print*,'apres vermat'
      if(itest(25).eq.0) then
         call reorde(ndet,nemax,esp1,esp1(iadri/2+1),esp1(iadri/2+1))
      else
c      print*,'avant reorde2 norb',norb
c         call reorde2(cesp(iadri*4+1),ndet,nemax,esp1)
         call reorde2(cesp(iadri*4+1),cesp(iadri*4+1),ndet,nemax,esp1)
      endif
      call sgn1
c      call sgn0(yesp)
c      write(6,*)'ndet2',ndet
      close(84,status='delete')
c      print*, 'avant lirone'
      call lirone
c      print*, 'apres lirone'
cpent 18-4-02
c queremos introducir una restriccion en el calculo de la matriz ro:
c solo debe calcularse si es el mismo estado: transiciones entre
c estados de la misma simetria con el mismo numero:
c las siguientes lineas determinan que es el mismo estado
c comprobando las energias (la simetria no es tan sencillo)
      read(10) ndetb,nvec
      read(10) (e(k),k=1,nvec)
      e1=e(numero(1))
cc      print*,'e1',e1

      read(11) ndetb,nvec
      read(11) (e(k),k=1,nvec)
      e2=e(numero(2))
cc      print*,'e2',e2
      
      rewind(10)
      rewind(11)

cpent 17-4-02
c lee ro o calcula ro segun convenga
      if(numero(1).eq.numero(2).and.calcro.eq.0.and.e1.eq.e2) then
c      if(calcro.eq.0) then
      print*,'La matriz de densidad se lee del fichero dens de CASDI'
      print*,'------------------------------------------------------'
      call leero(esp1,esp2)
      else
      print*,'La matriz de densidad se calcula'
      print*,'------------------------------------------------------'
      call calro(esp1,esp2)
      endif
      call calmu(esp1,esp2)
 
      return
      end
       function itemps(i)
c     itemps=iclock()
      itemps=0
      return
      end
