      subroutine lirone
      IMPLICIT DOUBLE PRECISION (A-H,O-x,z),logical*1(y)
      parameter (maxorb=500,mm=maxorb*(maxorb+1)/2,maxsym=8)
      parameter (min_Block_Length=1024)
      character*1 c
      character*5280 namel 
      real*8 yij,yyij,yzij
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension c(40960),r8(40960/8),r4(40960/4),i4(40960/4)
      dimension itoc(14)
      dimension pxq(mm),pyq(mm),pzq(mm),pxxq(mm),pyyq(mm),pzzq(mm), 
     * pxyq(mm),pxzq(mm),pyzq(mm)
      dimension pxqc(maxorb,maxorb)
     *,pyqc(maxorb,maxorb),pzqc(maxorb,maxorb),pxxqc(maxorb,maxorb)
      common/xyz/
     * xij(maxorb,maxorb),yij(maxorb,maxorb)
     *,zij(maxorb,maxorb),rij(maxorb,maxorb)
      common/xxyyzz/  xxij(maxorb,maxorb),
     * zzij(maxorb,maxorb)
     *, yyij(maxorb,maxorb),xyij(maxorb,maxorb)
     *, xzij(maxorb,maxorb),yzij(maxorb,maxorb)


      common/symxyz/ isx,isy,isz
cpent 20-11-01
      common/symxxyyzz/ isxy, isxz, isyz
      common/hacer/ iprop,molcas
cpent 20-11-01
cpent 4-12-01
c onuc es el momento nuclear leido de oneint en lipq
c mira alli para mas info
      common/non/none(maxsym)
      common/fmomnucl/ onucx,onucy,onucz,
     * onucxx,onucxy,onucxz,onucyy,onucyz,onuczz
cpent 4-12-01

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)
      dimension ipoint(124)
      dimension orb(maxorb,maxorb),ibl(maxsym),iblmm(maxsym)
      common/pr/nprint,mprint(10)
cJV  An~ado la dimension del norbs3 
      dimension itoc1(66),norbs2(8),norbs3(8)
      character*1 c1 (66*4)
      equivalence (c1(1),itoc1(1))
      equivalence (c(1),r8(1))
      equivalence (c(1),r4(1))
      equivalence (c(1),i4(1))
c
c
      character*7 file
      dimension isym(maxsym)
      yw=.false.
      istop=0
      call LECNAM('&COST ',namel,93,ierr,0)
      call nameli(namel,MOLCAS,'MOLCAS',4)
            
c
c     lecture du nombre d'orbitales avant et apres gel/delete
c     a partir de traone
c
         rewind 45
         call LECNAM('&COST_MO ',namel,45,ierr,1)
         call nameli(namel,NSYM1,'NSYM',4)
      print*,'nombre de symetries',nsym1
c
cpent 23-04-2003 pequeñas modificaciones empiricas
cpent para tener en cuenta la version 54 de molcas
         call nameli(namel,NORBS2,'ISYM',4)
         call nameli(namel,NORBS,'FROZEN',4)
cJV An~ado la siguiente linea porque los orbitales DELETE
c   no se habia tenido en cuenta para contar los orbitales
c   antes y despues del frozen y/o delete
         call nameli(namel,NORBS3,'DELETE',4)
cJV  Y ademas sumo el norbs3 que tiene en cuenta los orbitales delete
         do k=1,nsym
            norbs(k)=norbs(k)+norbs2(k)+norbs3(k)
         enddo
c     if(nprint.ge.1) then
      write(6,'(/,''  nombre d''''orbitales par symetrie avant gel'',/
     *8i4)') (norbs(k),k=1,nsym)
c
      write(6,'(/,''  nombre d''''orbitales par symetrie apres gel'',/
     *8i4)') (norbs2(k),k=1,nsym)
c     endif
      do k=1,nsym
         if(norbs(k)-norbs2(k).ne.ngel(k)+ndel(k)) then
            print*,' '
            print*,'*************************************'
            print*,'symetrie',k
            print*,'mauvais nombre d''orbitales gelees et/ou detruites'
            print*,'ngel+ndel=',ngel(k)+ndel(k),', devrait valoir',
     *      norbs(k)-norbs2(k)
            print*,'*************************************'
            istop=1
         endif
      enddo
      if(istop.eq.1) stop
      write(6,'(/,''  nombre d''''orbitales gelees   '',
     *8i4)') (ngel(k),k=1,nsym)
      write(6,'(/,''  nombre d''''orbitales detruites   '',
     *8i4)') (ndel(k),k=1,nsym)
      print*,'nombre de symetries',nsym
         norb2=0
         long2=0
         norb=0
         long=0
         do is=1,nsym
            isym(is)=norbs(is)
            norb2=norb2+isym(is)
            long2=long2+isym(is)*(isym(is)+1)/2
            norb=norb+isym(is)
            long=long+isym(is)*(isym(is)+1)/2
         enddo
c
c     dimension des blocs
c
      ibl(1)=0
      iblmm(1)=0
      do is=2,nsym
         ibl(is)=ibl(is-1)+isym(is-1)
         iblmm(is)=iblmm(is-1)+isym(is-1)*(isym(is-1)+1)/2
      enddo
      
      if(yw)print*,'long,long2',long,long2
      long=long*8
      long2=long2*8
      print*,'nombre d orbitales par symetrie',(isym(k),k=1,nsym)
      print*,'nombre d orbitales',norb
      print*,' '
      nn=norb*(norb+1)/2
         call limono60('OVERLAP',7,nn,nsym,r8)
      if(nprint.ge.2)call scri1(nsym,r8,isym)
c
cpent 3-12-01
c vamos a reasignar las isxy usando its
c esto hace inutiles las asignaciones via namelist
      isxy=its(isx,isy)
      isxz=its(isx,isz)
      isyz=its(isy,isz)
cpent 20-11-01 por el if
cpent 16-01-02
      molvar=1024
cpent 23-04-03 para incluir soporte para la 54

c molvar es el valor por el que se multiplica itoc
c molcas es el numero de la version de molcas
cpent 16-01-02

         if(iprop.eq.0.OR.iprop.eq.1) then
            call limono60s('PXQ',3,nn,nsym,pxq,onucx)
            call limono60s('PYQ',3,nn,nsym,pyq,onucy)
            call limono60s('PZQ',3,nn,nsym,pzq,onucz)
         endif
         if(iprop.eq.0.OR.iprop.eq.2) then
            call limono60s('PXXQ',4,nn,nsym,pxxq,onucxx)
            call limono60s('PXYQ',4,nn,nsym,pxyq,onucxy)
            call limono60s('PXZQ',4,nn,nsym,pxzq,onucxz)
            call limono60s('PYYQ',4,nn,nsym,pyyq,onucyy)
            call limono60s('PYZQ',4,nn,nsym,pyzq,onucyz)
            call limono60s('PZZQ',4,nn,nsym,pzzq,onuczz)
         endif

cpent 20-11-01

      print*,'------------------------------------------------------'
c
c     lecture des orbitales
c
      if(nprint.ge.2)print*,'ORBITALES'
      if(nprint.ge.2)print*,'norb',norb
      y60=.false.
 222  continue
      read(1,'(40a1)') (c(k),k=1,40)
      if(c(1).eq.'#') then
         y60=.true.     
         goto 222
      endif
      write(6,'('' orbitales lues :'', 40a1)') (c(k),k=1,40)
      if(y60) then
         do k=1,4
            read(1,*)
         enddo
      endif
      iorb=0
      do is=1,nsym
         nsi=isym(is)
         nsi2=norbs(is)
         do i=1,nsi
            read(1,*)
            iorb=iorb+1
            read(1,1000)(orb(k,iorb),k=1,nsi)
         enddo
         if(nprint.ge.2)
     *   call script(orb(1,1+ibl(is)),nsi,nsi,maxorb,maxorb)
      enddo
      if(nprint.ge.2)
     *call script(orb,norb,norb,maxorb,maxorb)
 1000 format(4d18.12)
c
c     matrices x, y ,z dans la base des om
c
      
cpent 20-11-01 - el if y las tres ultimas llamadas
      if(iprop.eq.0.OR.iprop.eq.1) then
          call calij(xij,pxq,isym,isx,ibl,iblmm,orb,norb)
          call calij(yij,pyq,isym,isy,ibl,iblmm,orb,norb)
          call calij(zij,pzq,isym,isz,ibl,iblmm,orb,norb)
      endif
      if(iprop.eq.0.OR.iprop.eq.2) then
          call calij(xxij,pxxq,isym,1,ibl,iblmm,orb,norb)
          call calij(yyij,pyyq,isym,1,ibl,iblmm,orb,norb)
          call calij(zzij,pzzq,isym,1,ibl,iblmm,orb,norb)

          call calij(xyij,pxyq,isym,isxy,ibl,iblmm,orb,norb)
          call calij(xzij,pxzq,isym,isxz,ibl,iblmm,orb,norb)
          call calij(yzij,pyzq,isym,isyz,ibl,iblmm,orb,norb)

      endif
cpent 20-11-01
      do i=1,norb
         do j=1,norb
            rij(j,i)=xij(j,i)+yij(j,i)+zij(j,i)
         enddo
      enddo
c      print*,'matrice zij'
c      call script(zij,norb,norb,maxorb,maxorb)
      if(nprint.ge.1) then
      print*,'matrice xij'
      call script(xij,norb,norb,maxorb,maxorb)
      print*,'matrice yij'
      call script(yij,norb,norb,maxorb,maxorb)
      print*,'matrice zij'
      call script(zij,norb,norb,maxorb,maxorb)
      print*,'matrice rij'
      call script(rij,norb,norb,maxorb,maxorb)
      endif
      END
      subroutine scri1(nsym,r8,isym)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      dimension isym(8),r8(*)
      idep=1
      do k=1,nsym
         call scri8(r8(idep),isym(k))
         idep=idep+isym(k)*(isym(k)+1)/2
      enddo
      return
      end
      subroutine scri8(r8,n)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      dimension r8(*)
      ifin=0
      do k=1,n
      ideb=ifin+1
      ifin=ideb+k-1
      write(6,'(10f8.4)')(r8(kk),kk=ideb,ifin)
      enddo
      return
      end


       subroutine calij(xij,pxq,isym,isx,ibl,iblmm,orb,norb)
      IMPLICIT DOUBLE PRECISION (A-H,O-x,Z),logical*1(y)
      parameter (maxorb=500,mm=maxorb*(maxorb+1)/2,maxsym=8)
      character*1 c
      real*8 yij
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension isym(maxsym)
      dimension pxq(mm)
      dimension xij(maxorb,maxorb)
      dimension orb(maxorb,maxorb),ibl(maxsym),iblmm(maxsym)
      dimension iblij(maxsym)
c      print*,'entree calij',isx
      do k=1,norb
         do l=1,norb
            xij(l,k)=0.d0
         enddo
      enddo
c      call script(orb,norb,norb,maxorb,maxorb)
      if(isx.eq.1) then
         do is=1,nsym
            nsi=isym(is)
c            call scri8(pxq(1+iblmm(is)),nsi)
            do i=1,nsi
               ii=i+ibl(is)
               do j=1,nsi
                  jj=j+ibl(is)
                  do k=1,nsi
                     do l=1,nsi
                        kk=max(k,l)
                        ll=min(k,l)
                        kl=kk*(kk-1)/2+ll+iblmm(is)
                        oo=orb(k,ii)*orb(l,jj)
                        xij(jj,ii)=xij(jj,ii)+oo*pxq(kl)
                     enddo
                  enddo
               enddo
            enddo
         enddo
      else
         iblij(1)=0
         do is=2,nsym
            nsi=isym(is-1)
            js=its(is-1,isx)
            if(js.lt.is) then
c por que aqui la condicion es que se trabaja
c si js<is pero en lipq solo se toman
c los datos si js>=is????
c ademas si cambias la condicion en lipq no hay
c alteraciones, pero si tocas esta se estropea
c el resultado para sim>1
               nsj=isym(js)
               iblij(is)=iblij(is-1)+nsi*nsj
            else
               iblij(is)=iblij(is-1)
            endif
c            print*,'is,ibl(is),iblij(is)',is,ibl(is),iblij(is)
c            print*,'is,isx,js,iblij(is)',is,isx,js,iblij(is)
         enddo
c         call script(pxq,norb,norb,maxorb,maxorb)
         do is=1,nsym
            nsi=isym(is)
            js=its(is,isx)
            if(js.lt.is) then
               nsj=isym(js)
               do i=1,nsi
                  ii=i+ibl(is)
                  do j=1,nsj
                     jj=j+ibl(js)
                     do k=1,nsi
                        kk=k+ibl(is)
c ???para que valen kk y ll???
                        do l=1,nsj
                           ll=l+ibl(js)
                           kl=iblij(is)+k+(l-1)*nsi
                           oo=orb(k,ii)*orb(l,jj)
c                print*,'jj,ii,kl',jj,ii,kl
                           xij(jj,ii)=xij(jj,ii)+oo*pxq(kl)
c                print*,'jj,ii,xij',jj,ii,kl,xij(jj,ii),oo,pxq(kl)
                        enddo
                     enddo
                  enddo
               enddo
            endif
         enddo
         do i=1,norb
            do j=1,i
               xij(i,j)=xij(j,i)
            enddo
         enddo
      endif
c      print*,'fin calij'
      return
      end
       subroutine limono60(etiqu,l,nn,nsym,r8)
      IMPLICIT DOUBLE PRECISION (A-H,O-x,z),logical*1(y)
      character*80 namel
      character*7 etiqu
      dimension r8(40960/8)
      rewind 46
      read(46) namel
      ii=0
      do kkk=1,10000
         if(ii.ne.0) goto 1234
         read(46) namel
         read(46)
         read(46)
         ii=index(namel,etiqu(1:l)//' MATRIX (TOTAL)')
      enddo
 1234 continue
      backspace (46)
      backspace (46)
      read(46) nn,nsym
      read(46) (r8(k),k=1,nn)
      return
      end
       subroutine limono60s(etiqu,l,nn,nsym,r8,onuc)
      IMPLICIT DOUBLE PRECISION (A-H,O-x,z),logical*1(y)
cJV por JM, me indica una seria de cambios de posibles errores
      parameter (maxorb=500,mm=maxorb*(maxorb+1)/2,maxsym=8)
      character*80 namel
      character*7 etiqu
cJV por JM, me indica una seria de cambios de posibles errores
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym)
      dimension r8(*)
      dimension isym(8)
      yw=.false.
!
!     lecture de la matrice
!
      ifil=47
      rewind ifil
      ii=0
      if(yw)print*,etiqu(1:l)//' MATRIX'
      do k=1,10000
         read(ifil) namel
         read(ifil) isx
         ii=index(namel,etiqu(1:l)//' MATRIX')
         if(yw)print*,'namel ',namel(1:50),ii
         if(yw)print*,'on cherche',etiqu(1:l)//' MATRIX'
         if(yw)print*,'isx',isx
         if(ii.ne.0) goto 1234
cJV por JM, me indica una seria de cambios de posibles errores
         if(index(namel,'==P')==0) then
            read(ifil)
         else
            if(isx==1) then
               read(ifil) lll
               if(yw)print*,'l',lll
               read(ifil) A
               if(yw)print*,'a',a
               read(ifil) onuc
               if(yw)print*,'onuc',onuc
            else
               do is=1,nsym
                     js=its(is,isx)
                     if(js.gt.is) goto 30
                     read(ifil) i1,i2
                     if(yw)print*,'i1,i2',i1,i2
 30                  continue
               enddo
               read(ifil) A
               if(yw)print*,'a',a
               read(ifil) onuc
               if(yw)print*,'onuc',onuc
            endif
cJV por JM, me indica una seria de cambios de posibles errores
         endif
         if(yw)print*,'k,ii,isx',k,ii,isx
      enddo
 1234 continue
      if(yw)print*,'OK isx',isx
      if(isx==1) then
!         backspace(ifil)
!         backspace(ifil)
!         backspace(ifil)
         read(ifil) nn,nsym,(isym(k),k=1,nsym)
         if(yw)print*,'nn,nsym',nn,nsym
         read(ifil) (r8(k),k=1,nn)
         read(ifil) onuc
         if(yw)call scri1(nsym,r8,isym)
      else
!         backspace(ifil)
!         backspace(ifil)
!         backspace(ifil)
!         backspace(ifil)
cJV por JM, me indica una seria de cambios de posibles errores
         iii=1
         do is=1,nsym
                 js=its(is,isx)
                 if(js.gt.is) goto 20
              read(ifil) i1,i2
              if(yw)print*,'i1,i2',i1,i2
              iii=iii+i1*i2
 20            continue
         enddo
         if(yw)print*,'iii',iii
         read(ifil) (r8(k),k=1,iii)
         if(yw)print*,'r8',(r8(k),k=1,iii)
         if(yw)call script(r8,i1,i2,i1,i2)
         if(yw)call script(r8(i1*i2+1),i3,i4,i3,i4)
         read(ifil) onuc
      endif
cJV por JM, fin de los cambios indicados por JM
      return
      end
