      subroutine lirdav
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=50)
      parameter (maxsym=8,maxal=56,maxorb=500,maxorbcas=16)
      LOGICAL BIDIA
      character*5280 namel,namel2
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      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
      common/pr/nprint,mprint(10)
      common/opt/ihab,calcul
      character*3 calcul
      common /ijd/itab,jtab,dtab
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sui/isuiv
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      common/test/itest(50)
      common/memoire/mem
      common/stp/stop
      common /det/ndet,mdet(50)
      common /fpspi/yfpspi
      character*8 stop,restart
      character*1 syspin
      common /sysp1/syspin
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      common/scmr/yscmrs
      common/symxyz/ isx,isy,isz
cpent 20-11-01
      common/symxxyyzz/ isxy, isxz, isyz
      common/hacer/ iprop,molcas
cpent 20-11-01
cpent 17-4-02
      common/rocal/ calcro
      integer molcas,calcro
      common /ronum/ deltae,numero(2)
c      COMMON/GAO/GUESS,ORTH,GSYM,NGAO,NORTH
      character*4 hab
      character*1 espace
c la siguiente linea viene de la version SGI
      common/orbi/ngel(8),ndel(8),norbs(8),norb2
c      common/orbi/ngel(8),ndel(8),norbs(8)
      namelist/rho/
     *nprint,twvec,stop,ngel,ndel,
     *mem,isx,isy,isz                                                           
cpent 20-11-01
      namelist/rhc/
     *isxy,isxz,isyz,iprop,molcas,calcro
cpent 20-11-01
     


      do k=1,maxsym
         ngel(k)=0
         ndel(k)=0
      enddo
      numero(1)=1
      numero(2)=1
      iternat=0
      yw=.false.
      irest=0
      syspin='0'
      stop='FIN'
      restart='        '
      do k=1,10
         mprint(k)=0
      enddo
      do k=1,50
         itest(k)=0
      enddo
      twvec=0.05
      nprint=0
      isx=1
      isy=1
      isz=1
      itest(25)=1

cpent 20-11-01
      isxy=1
      isxz=1
      isyz=1
      iprop=1
c iprop regula el calculo a realizar:
c iprop=0 todos los calculos disponibles se realizan
c iprop=1 solo calculamos las propiedades de x, y y z
c iprop=2 solo calculamos las props de x2, xy,...
cpent 20-11-01

cpent 16-01-02
      molcas=5
c molcas es la version de molcas utilizada
cpent 17-04-02
      calcro=0
c si calcro>0 entonces fuerzas el calculo de ro
c incluso cuando es un momento dipolar
c y podrias leer prefix.dens
      
      call LECNAM('&RHO',namel,93,ierr,1)
      call nameli(namel,ndel,'NDEL',4)
      call nameli(namel,NGEL,'NGEL',4)
      call nameli(namel,NUMERO,'NUMERO',4)
      call nameli(namel,ISX,'ISX',4)
      call nameli(namel,ISY,'ISY',4)
      call nameli(namel,ISZ,'ISZ',4)
      call nameli(namel,nprint,'NPRINT',4)
      call nameli(namel,mprint,'MPRINT',4)
      call nameld(namel,twvec,'TWVEC',8)
      call namela(namel,calcul,'CALCUL')
      call namela(namel,stop,'STOP')
      call nameli(namel,MEM,'MEM',4)                                            

cpent 20-11-01
      call LECNAM('&RHC',namel2,93,ierr,1)
      call nameli(namel2,isxy,'ISXY',4)
      call nameli(namel2,isxz,'ISXZ',4)
      call nameli(namel2,isyz,'ISYZ',4)
      call nameli(namel2,iprop,'IPROP',4)
cpent 20-11-01
cpent 16-01-02
      call nameli(namel2,molcas,'MOLCAS',4)
cpent 16-01-02
cpent 17-04-02
      call nameli(namel2,calcro,'CALCRO',4)  
cpent 17-04-02
      rewind 75
c
c--   coherence des donnees
c
      call maj(stop,8)
      call maj(restart,8)
      call maj(calcul,3)
      call maj(hab,4)
      write(75,RHO)
      write(75,'('' mprint='')')
      write(75,'(10i4)') mprint
      write(75,'('' itest='')')
      write(75,'(5(10i4,/))') itest

cpent 20-11-01
      write(75,RHC)
cpent 20-11-01


      call scrinam('NAMELIST RHO,RHC   ')
      print*,
     *'=========================='//
     *'=================================='
      print*,' '
      return
      end
       subroutine reocip(b,b2,iadrv,ndet,icas)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/ iadri
      dimension b(ndet),iadrv(2048),b2(ndet)
      common/opt/ihab,calcul
      character*3 calcul
      rewind 87
c      call lirbl(iadrv,ndet,87)
      kk=2048
      if(icas.eq.1) then
         do k=1,ndet
            kk=kk+1
            if(kk.eq.2049) then
               kk=1
               call liri(iadrv,2048,87)
            endif
            b2(k)=b(iadrv(kk))
         enddo
      else
         do k=1,ndet
            kk=kk+1
            if(kk.eq.2049) then
               kk=1
               call liri(iadrv,2048,87)
            endif
            b2(iadrv(kk))=b(k)
         enddo
      endif
      return
      end

       subroutine scrinam(c)
      character b*80,a*2000,c*15
      rewind 75
      i=0
 1    i=i+1
      a(i:i)=' '
      read(75,'(a80)',end=1000) b
c     print*, b
      do k=1,80
         if(b(k:k).ne.' ') then
            i=i+1
            a(i:i)=b(k:k)
         endif
      enddo
      goto 1
 1000 continue
c      do k=1,i,60
c         print'(50(1x,a60))', a(k:k+59)
c      enddo
      print*,' '
      print*,'===================== ',c,
     *' ======================'
      k=0
      kk=0
 3    k=k+1
      kk=kk+1
c     print*,'k,kk,a(k:k)',k,kk,a(k:k)
      b(kk:kk)=a(k:k)
      if(k.ge.i) then
         print'(1x,a)', b(1:kk)
         goto 2
      endif
      kks=kk
      if(kks.gt.50) then
         do kkk=kks+1,i
c        print*,'kkk',kkk
            k=k+1
c           print*,'kkk,a',a(k:k)
            if(a(k:k).eq.' '.or.a(k:k).eq.','.or.kkk.gt.72) then
               b(kkk:kkk)=a(k:k)
               print'(1x,a)', b(1:kkk)
               kk=0
               goto 3
            else
               b(kkk:kkk)=a(k:k)
            endif
         enddo
      endif
      goto 3
c      do k=1,i,60
c         print'(50(1x,a60))', a(k:k+59)
c      enddo
 2    print*,
     *'=========================='//
     *'=================================='
      print*,' '
      rewind 75
      return
      end
 
       subroutine sto5
      character ligne*75,debut*5
c     write(6,*)'entree sto5'
 2    read(5,'(a5,a75)',end=1) debut,ligne
      write(93,'(a5,a75)') debut,ligne
c      write(6,'('' sto5'',a5,a75)') debut,ligne
      goto 2
 1    continue
      call flush(93)
      rewind 93
      return
      end

