      subroutine lirone(yok,ydip)
      IMPLICIT DOUBLE PRECISION (A-H,O-x,Z),logical*1(y)
      parameter (maxorb=1024,mm=1000000,maxsym=8,maxat=1024)
      parameter (min_Block_Length=1024)
      character*1280 namel
      character*80 tete(100),aa
      character*1 c
      character*4 atom(maxat)
      real*8 yij
      dimension coord(3)
      character*8 label(maxorb*4)
c      dimension c(261120),r8(261120/8),i4(261120/4)
      dimension c(mm*8),r8(mm),i4(mm*2)
      dimension itoc(14)
      common/symxyz/ isx,isy,isz
      common/symxxyyzz/ isxy, isxz, isyz
      dimension pxq(mm),pyq(mm),pzq(mm),pxxq(mm),pyyq(mm),pzzq(mm),
     * pxyq(mm),pxzq(mm),pyzq(mm)
      dimension ipoint(124)
      common /filc/jrc_oneint,jrc_comfile,jrc_traone,jrc_traint
      character*80 blan40,filorb
      common/pr/nprint,mprint(10),filorb,blan40
      common/version/molcas,i_rec,i_at,i_orb,i_coo,y64
      character*1 cote
      double precision,allocatable,dimension(:) :: ov
      equivalence (c(1),r8(1))
      equivalence (c(1),i4(1))
c
c
      character*7 file
      integer c_open,c_read,c_lseek
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym),norb
      common/sym1/ its(maxsym,maxsym),itsym(maxorb)
      character(80) sxyz(8)
      dimension jtsr(maxsym,maxsym)
      yw=.false.
      yw1=.false.
      y64=.true.
 1000 format(2a)
      istop=0
      write(2,'(a)') ' &cost_AO'
c
c     find molcas version
c
      cote=''''
      molcas=0
      rewind 93
      call LECNAM('&COST ',namel,93,ierr,0)
      call nameli(namel,MOLCAS,'MOLCAS',4)
      call namell(namel,Y64,'Y64',1)
      print*,' '
      print*,'================================================='
      if(molcas.eq.0) then
         print*,'the variable "molcas" has the default value 0'
         print*,'molcost will analyse the OneInt and ComFile'
         print*,'file to find the molcas version'
         krc=c_lseek(jrc_oneint,5264)
         krc=c_read(jrc_oneint,c,1)
         if(.not.y64) i688=688
         if(y64) i688=1376
         krc=c_read(jrc_comfile,namel,i688)
         ii_title=index(namel(1:i688),'TITLE')-1
         if(yw)print*,'ii_title',ii_title
         ii=ichar(c(1))
         if(ii_title.ne.-1) then
            molcas=54
         else if(ii.ge.65.and.ii.le.122) then
            molcas=4
            molvar=1024
         else
            molcas=5
            molvar=8
         endif
         print*,'molcas version:',molcas,'  please verify this result !'
      else if(molcas.eq.54) then
         if(.not.y64) i688=688
         if(y64) i688=1376
         krc=c_read(jrc_comfile,namel,i688)
         ii_title=index(namel(1:i688),'TITLE')-1
         if(yw)print*,'ii_title',ii_title
         print*,'molcas version:',molcas
      else
         print*,'molcas version (read from namelist cost):',molcas
      endif
      if(y64) then
         print*,'VERSION 64 BITS'
      else
         print*,'VERSION 32 BITS'
      endif
      print*,'================================================='
      print*,' '
c
c     read and print the seward title
c     read the OneInt pointer
c
      print*,' '
      print*,(/('=',i=1,70)/)
      print*,'SEWARD title:'
      if(molcas.eq.54) then
         if(.not.y64)krc=c_lseek(jrc_comfile,ii_title+12)
         if(y64)krc=c_lseek(jrc_comfile,ii_title+28)
         krc=c_read(jrc_comfile,i_title,4)
         if(yw)print*,i_title,ii_title
         krc=c_lseek(jrc_comfile,i_title*8)
         krc=c_read(jrc_comfile,c,144)
         print '(80a1)',(c(k),k=1,73)
         print '(70a1)',(c(k),k=74,143)
         print*,(/('=',i=1,70)/)
         print*,' '
         jrc=jrc_comfile
      else
         krc=c_lseek(jrc_oneint,0)
         krc=c_read(jrc_oneint,c,40960)
         jrc=jrc_oneint
         print '(80a1)',(c(k),k=13,85)
         print '(70a1)',(c(k),k=86,155)
         print*,(/('=',i=1,70)/)
         print*,' '
         ipoint=i4(1:124)
      endif
      if(molcas.eq.54) then
         krc=c_lseek(jrc,0)
         krc=c_read(jrc,c,40960)
      endif
c
c     read itoc
c
      do k=1,14
         itoc(k)=i4(44+k*5)
      enddo
      if(yw)print*,'itoc',itoc
 
c      do k=1,124
c         print*,'ipoint',k,ipoint(k)
c      enddo
 
c
c     set the pointers
c
      i2=1
      if(molcas.eq.54) then
!         l_r54=0
         if(y64)i12=28
         if(.not.y64)i12=12
         if(y64)i2=2
         if(y64)i1=1
         if(.not.y64)i1=0
         if(y64)ii4=4
         if(.not.y64)ii4=0
         krc=c_lseek(jrc,0)
         krc=c_read(jrc,namel,688)
         krc=c_lseek(jrc,0)
         krc=c_read(jrc,c,688)
         if(yw)print*,'ii4',ii4

         ii=index(namel,'COORD')
         i_coo=i4((ii-1+i12)/4+1)*8
         ii=index(namel,'NATOM')
         i_nat=i4((ii-1+i12)/4+1)*8+ii4
         if(yw)print*,(ii-1+i12)/4+1
         ii=index(namel,'ATOMLBL')
         i_at=i4((ii-1+i12)/4+1)*8
         ii=index(namel,'NSYM')
         i_sym=(i4((ii-1+i12)/4+1)*8+4)/4+i1
         if(yw)print*,(ii-1+i12)/4+1,i4((ii-1+i12)/4+1)
         ii=index(namel,'NBAS')
         i_sym2=(i4((ii-1+i12)/4+1)*8+4)/4+i1
         ii=index(namel,'POTNUC')
         i_nuc=(i4((ii-1+i12)/4+1)*8)
         ii=index(namel,'ATOMTYPE')
         i_lab=i4((ii-1+i12)/4+1)*8
         ii=index(namel,'SEWIINFO')
         i_sewi=i4((ii-1+i12)/4+1)*8
         ii=index(namel,'SEWCINFO')
         i_sewc=i4((ii-1+i12)/4+1)*8
         krc=c_lseek(jrc_oneint,0)
         krc=c_read(jrc_oneint,namel,672)
         krc=c_lseek(jrc_oneint,0)
         krc=c_read(jrc_oneint,c,672)
         ii=index(namel,'MLTPL  0')
         if(yw)print*,'ii',ii
         if(.not.y64)i_rec=i4((ii-1+16)/4+1)*8
         if(y64)i_rec=i4((ii-1+40)/4)*8
         if(yw)print*,i_rec,(ii-1+40)
         if(yw)print*,'i_rec',i_rec
         if(yw)print*,'i_at',i_at
         if(yw)print*,'i_coo',i_coo
         if(yw)print*,'i_sym',i_sym
         if(yw)print*,'i_nuc',i_nuc
         if(yw)print*,'i_nat',i_nat
         if(yw)print*,'i_lab',i_lab
         if(yw)print*,'i_sewc',i_sewc
         if(yw)print*,'i_sewi',i_sewi
 
!         l_r54=max(l_r54,i_nat)+4
!         l_r54_0=l_r54
!         krc=c_lseek(jrc,i_nat)
!         krc=c_read(jrc,natom,4)
!         l_r54=max(l_r54,i_coo)+24*natom
!         l_r54=max(l_r54,i_nuc)+8
!         l_r54=max(l_r54,i_at)+4*natom
!         l_r54=max(l_r54,i_sym*4)+4
!         l_r54=max(l_r54,i_sym2*4)+maxsym*4
!         if(mm.lt.l_r54) then
!            print*, 'mm too small in subroutine lirone'
!            print*,'increase mm up to ',lr_54
!            stop
!         endif
!         if(l_r54.gt.l_r54_0) then
!            krc=c_lseek(jrc,0)
!            krc=c_read(jrc,c,l_r54)
!            l_r54_0=l_r54
!         endif
!         norb=sum(i4(i_sym2:i_sym2+maxsym-1))
!         l_r54_sym2=l_r54
!         l_r54=max(l_r54,i_lab)+32*norb
!         if(mm.lt.l_r54) then
!            print*, 'mm too small in subroutine lirone'
!            print*,'increase mm up to ',lr_54
!            stop
!         endif
!         if(l_r54.gt.l_r54_0) then
!            krc=c_lseek(jrc,0)
!            krc=c_read(jrc,c,l_r54)
!         endif
      else if(molcas.eq.4) then
         i_nat=2784
         i_at=5264
         i_lab=5668
         i_coo=2792
         i_rec=40960
         i_sym=680
         i_sym2=i_sym+9
         i_nuc=0
      else if(molcas.eq.5) then
         i_nat=2784
         i_at=7664
         i_coo=2792
         i_rec=ipoint(44)*8
         i_sym=680
         i_sym2=i_sym+9
         i_lab=8468
         i_nuc=(ipoint(109)-1)*8
      endif
c     eventually, correct the pointers
      call nameli(namel,I_AT,'I_AT',4)
      call nameli(namel,I_ORB,'I_ORB',4)
      call nameli(namel,I_COO,'I_COO',4)
      call nameli(namel,I_REC,'I_REC',4)
      call nameli(namel,I_SYM,'I_SYM',4)
      call nameli(namel,I_LAB,'I_LAB',4)
      call nameli(namel,I_NUC,'I_NUC',4)
c
c     read the symmetries
c
!      nsym=i4(i_sym)
      krc=c_lseek(jrc,(i_sym-1)*4)
      krc=c_read(jrc,nsym,4)
      print'(a35,i3)','number of symmetries',nsym
      write(2,'(a,i1)')' nsym=',nsym
      long2=0
      kk=0
!      do k=i_sym2,i_sym2+nsym-1
!         kk=kk+1
!         isym(kk)=i4(k)
!         long2=long2+i4(k)*(i4(k)+1)/2
!      enddo
      krc=c_lseek(jrc,(i_sym2-1)*4)
      if(y64) then
         krc=c_read(jrc,isym,nsym*8)
         do k=1,nsym
            isym(k)=isym(k+k-1)
         enddo
      else
         krc=c_read(jrc,isym,nsym*4)
      endif
 
      norb=0
      long=0
      do is=1,nsym
         norb=norb+isym(is)
         long=long+isym(is)*(isym(is)+1)/2
         long2=long2+isym(is)*(isym(is)+1)/2
      enddo
      if(yw)print*,'long,long2',long,long2
      long=long*8
      long2=long2*8
      print'(a35,8i3)','number of orbitals per symmetry',
     *(isym(k),k=1,nsym)
      write(2,1001) ' isym=',isym(1:nsym)
 1001 format(a,8(i4,','))
      print'(a35,i5)','number of orbitals',norb
      write(2,'(a6,i5)')' norb=',norb
! 
!      list of symmetry operations for each irreductible representation
! 
!      if(molcas.eq.54) then
!         krc=c_lseek(jrc,i_sewc+6636)
!         krc=c_read(jrc,sxyz,nsym*80)
!         do k=1,nsym
!         if(sxyz(k).ne.' ') write(6,'(" sxyz(",i1,")=''",a,"''")') 
!     *   k,trim(sxyz(k))
!         if(sxyz(k).ne.' ') write(2,'(" sxyz(",i1,")=''",a,"''")') 
!     *   k,trim(sxyz(k))
!         enddo
!      endif
c
c     write the representation table
c
      write(2,'(a5)')' its='
      do j=1,nsym
         write(2,'(6x,8(i1,'',''))') (its(i,j),i=1,nsym),(0,i=nsym+1
     &   ,8)
      enddo
c
c     write the readen representation table
c
      if(molcas.eq.54) then
         krc=c_lseek(jrc,i_sewi+56004)
         krc=c_read(jrc,jtsr,nsym*8*4)
         if(yw)print*,'i_sewi',i_sewi,i_sewi+56004
         print'(a35)','jtsr'
         do k=1,nsym
            write(6,'(35x,8i4)') jtsr(k,1:nsym)
         enddo
         write(2,'(a6)')' jtsr='
         do j=1,nsym
            write(2,'(6x,8(i2,'',''))') (jtsr(i,j),i=1,nsym),(0,i=nsym+1
     *      ,8)
         enddo
      endif

c
c     read the nuclear repulsion energy
c
      krc=c_lseek(jrc,i_nuc)
      krc=c_read(jrc,enuc,8)
      print'(a35,f20.12)','enuc',enuc
      write(2,'(a,f20.12)') ' enuc=',enuc
c
c     read the atoms and the coordinates
c
!      do k=6720,6752,4
!      krc=c_lseek(jrc,k)
!      krc=c_read(jrc,natom,4)
!      print*,'natom',natom,k
!      enddo
!      stop

      krc=c_lseek(jrc,i_nat)
      krc=c_read(jrc,natom,4)
      print'(a35,i5)','number of atoms',natom
      krc=c_lseek(jrc,i_at)
      krc=c_read(jrc,atom,4*natom*i2)
      if(y64) then
         do k=1,natom
            atom(k)=atom(k*2-1)
         enddo
      endif
      write(2,'(a,i4)')' natom=',natom
      krc=c_lseek(jrc,i_coo)
      print*,' '
      print*,'------------------------------'
      print*,'coordinates'
      write(2,'(a)')' coor='
      do k=1,natom
         krc=c_read(jrc,coord,24)
         print'(a4,1x,3f10.6)', atom(k),coord
         write(2,'(3(f20.10,'',''))') coord
      enddo
      write(2,'(a)') ' atom='
      write(6,1003) (cote,atom(k),cote,k=1,natom)
      write(2,1003) (cote,atom(k),cote,k=1,natom)
 1003 format(100(1x,5(a1,a4,a1,','),/))
      print*,'------------------------------'
      print*,' '
c
c     read the labels
c
      krc=c_lseek(jrc,i_lab)
      if(molcas.eq.54) then
         do k=1,norb
            if(.not.y64)krc=c_read(jrc,namel(1:32),32)
            if(y64)krc=c_read(jrc,namel(1:64),64)
            do l=1,8
               if(.not.y64)label(k)(l:l)=namel(l*4-3:l*4-3)
               if(y64)label(k)(l:l)=namel(l*8-7:l*8-7)
            enddo
         enddo
      else
         krc=c_read(jrc,label,8*norb)
      endif
      print*,'labels'
      write(2,'(a)')' label='
      print 1002,(cote,label(k),cote,k=1,norb)
      write(2,1002) (cote,label(k),cote,k=1,norb)
 1002 format(100(1x,5(a1,a8,a1,','),/))
c     write(2,'(100(1x,5('''',a8,'''',''),/))') (label(k),k=1,norb)
      write(2,'(a)')' /'
c
c     read the overlap matrix:1
 
c
c
c     write the overlap matrix (sym by sym)
c
      yw1=.false.
      print*,(/('=',i=1,70)/)
      print*,' '
      print*,' '
      print*,'WRITE THE OVERLAP MATRIX (SYM)  dimension:',long2
      aa=' '
      write(aa,'(a)')'==OVERLAP MATRIX (SYM)'
      write(3) aa
      krc=c_lseek(jrc_oneint,i_rec)
      krc=c_read(jrc_oneint,c,long2)
      write(3) long2/8,nsym,isym(1:nsym)
      write(3) r8(1:long2/8)
      if(nprint.ge.2)call scri1(nsym,r8,isym)
c
c     write the overlap matrix (total)
c
      nn= norb*(norb+1)/2
      print*,(/('=',i=1,70)/)
      print*,' '
      print*,' '
      print*,'WRITE THE OVERLAP MATRIX (TOTAL)  dimension:',nn*8
      write(aa,'(a)') '==OVERLAP MATRIX (TOTAL)'
      write(3) aa
      allocate (ov(nn))
      ifinv=0
      ifinn=0
      do is=1,nsym
         do k=1,isym(is)
            idebn=ifinn+1
            ifinn=idebn+sum(isym(1:is-1))-1
            ov(idebn:ifinn)=0.d0
            idebn=ifinn+1
            ifinn=idebn+k-1
            idebv=ifinv+1
            ifinv=idebv+k-1
            ov(idebn:ifinn)=r8(idebv:ifinv)
         enddo
      enddo
      write(3) nn,nsym,isym(1:nsym)
      write(3) ov
      if(nprint.ge.2)call scri1(1,ov,norb)
c
c     read the various one-eletron operators
c
      if(.not.ydip) return
      call litop('X INTEGRALS (SYM)',long2/8,itoc(2)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('Y INTEGRALS (SYM)',long2/8,itoc(3)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('Z INTEGRALS (SYM)',long2/8,itoc(4)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('XX INTEGRALS (SYM)',long2/8,itoc(5)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('XY INTEGRALS (SYM)',long2/8,itoc(6)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('XZ INTEGRALS (SYM)',long2/8,itoc(7)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('YY INTEGRALS (SYM)',long2/8,itoc(8)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('YZ INTEGRALS (SYM)',long2/8,itoc(9)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      call litop('ZZ INTEGRALS (SYM)',long2/8,itoc(10)*molvar,nsym,isym
     *,jrc,c,r8,nprint)
      return
      END
 
       subroutine litop(op,long,mmm,nsym,isym,jrc,c,r8,nprint)
      IMPLICIT DOUBLE PRECISION (A-H,O-x,Z),logical*1(y)
      parameter (maxorb=1024,maxsym=8,maxat=1024)
      dimension isym(maxsym)
      character*1 c
      character*(*) op
      character*80 aa
      dimension c(261120),r8(261120/8)
      integer c_open,c_read
      print*,'WRITE THE '//trim(op)//'      dimension:',long2
      aa=' '
      write(aa,'(a)')'=='//trim(op)
      write(3) aa
      krc=c_lseek(jrc,mmm)
      krc=c_read(jrc,c,long2)
      write(3) long2/8,nsym,isym(1:nsym)
      write(3) r8(1:long2/8)
      if(nprint.ge.2)call scri1(nsym,r8,isym)
      return
      end
      block data
      parameter (maxorb=1024,maxsym=8)
      common/sym1/ its(maxsym,maxsym),itsym(maxorb)
      data its
     */1,2,3,4,5,6,7,8,
     *2,1,4,3,6,5,8,7,
     *3,4,1,2,7,8,5,6,
     *4,3,2,1,8,7,6,5,
     *5,6,7,8,1,2,3,4,
     *6,5,8,7,2,1,4,3,
     *7,8,5,6,3,4,1,2,
     *8,7,6,5,4,3,2,1/
      end
