      subroutine lirrunfile(r8,mm,i_sewx,i_sewi)
      use molcost
      use mod_script
      IMPLICIT DOUBLE PRECISION (A-H,O-x,Z),logical*1(y)
c     parameter (maxorb=1024,maxsym=8,maxat=1024)
      parameter (maxorb=2048,maxsym=8,maxat=1024)
      parameter (min_Block_Length=1024)
      common /filc/jrc_oneint,jrc_comfile,jrc_traone,jrc_traint
      common /name_filc/ comfile
      character(80) comfile
      common/sym1/ its(maxsym,maxsym),itsym(maxorb)
      common/pr/nprint,mprint(10),filorb,blan40
      character(16) aa(54)
      character(20) aa20(20)
      character(40) aa64(54)
      character(80) bb,blan40,filorb
      character c(144)
      character(4) atom(maxat)
      common/ato/atom
      character(8) label(maxorb)
      dimension ii(108),r8(mm)
      integer(8) ii64(108)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym),norb
      dimension ibid(maxsym*2)
      dimension coord(3)
      character*1 cote
      common/version/molcas,i_rec,i_at,i_orb,i_coo,y64
      common/cprop/isx,isy,isz,yprop
      double precision,allocatable,dimension(:) :: pxq
      common/proj/ prefix,ybas,ymo,ycl,ysym,yao
      character(80) prefix
      allocatable y(:)
      logical exist
      integer(8),dimension(8,8) :: jtsr64
      integer(4),dimension(8,8) :: jtsr= reshape(
     *(/1,  1,  1,  1,  1,  1,  1,  1,
     *  1, -1,  1, -1,  1, -1,  1, -1,
     *  1,  1, -1, -1,  1,  1, -1, -1,
     *  1, -1, -1,  1,  1, -1, -1,  1,
     *  1,  1,  1,  1, -1, -1, -1, -1,
     *  1, -1,  1, -1, -1,  1, -1,  1,
     *  1,  1, -1, -1, -1, -1,  1,  1,
     *  1, -1, -1,  1, -1,  1,  1, -1/),
     *  (/8,8/))
      jtsr64=jtsr

      call titre('Read '//trim(comfile)//' file#',40)



!
! y64=T or F ?
!
      if(.not.y64endonne) then
         krc=c_lseek(jrc_comfile,512)
         krc=c_read(jrc_comfile,aa(1)(1:8),8)
         if(aa(1)(1:8)=='iScalar ') then
            y64=.false.
            goto 200
         endif
         krc=c_lseek(jrc_comfile,1024)
         krc=c_read(jrc_comfile,aa(1)(1:8),8)
         if(aa(1)(1:8)=='iScalar ') then
            y64=.true.
            goto 200
         endif
         print*,'y64 n''a pas pu etre deduit de l''examen du fichier'
     *   //' Runfile.' 
         print*,'Il faut le donner dans &COST'
         stop
      endif
 200  continue
      print*,'y64=',y64
!
        
      ifac=1
      if(y64) ifac=2
      cote=''''
      print*,'ifac=',ifac
!
!     read the labels of the file
!
      krc=c_lseek(jrc_comfile,512*ifac)
      !print*,'krc',krc,jrc_comfile
      krc=c_read(jrc_comfile,aa,54*16)
      !print*,'krc',krcy64
!
!     read the addresses corresponding to the labels
!
      krc=c_lseek(jrc_comfile,16384+512*ifac)
      if(y64) then
         krc=c_read(jrc_comfile,ii64,54*8)
         ii=ii64
      else
         krc=c_read(jrc_comfile,ii,54*4)
      endif
      !???if(y64) ii(1:54)=(/(ii(k),k=2,108,2)/)
!
!     Seward Title
!

      do k=1,54
      if(nprint>1)print*,aa(k),ii(k)
         if (aa(k)(1:12)=='Seward Title') then
            print*,'read SEWARD title'
            print*,' '
            print*,(/('=',i=1,70)/)
            print*,'SEWARD title:'
            krc=c_lseek(jrc_comfile,ii(k)*512)
            krc=c_read(jrc_comfile,c(1:144),144)
            print '(80a1)',(c(kk),kk=1,73)
            print '(70a1)',(c(kk),kk=74,143)
            print*,(/('=',i=1,70)/)
            print*,' '
         endif
      enddo
      call titre('Build COST_AO Namelist#',40)
!
! Read isym, compute nsym, norb
      do k=1,54
         if(aa(k)=='nBas') then
            !print*,aa(k),ii(k)
            krc=c_lseek(jrc_comfile,ii(k)*512)
            if(y64) then
               !???krc=c_read(jrc_comfile,ibid,8*4*ifac)
               !???isym(1:8)=(/(ibid(k),k=2,16,2)/)
               krc=c_read(jrc_comfile,ii64,8*8)
               isym=ii64(1:8)
            else
               krc=c_read(jrc_comfile,isym,8*4)
            endif
            !print*,'isym',isym
            nsym=8
            do l=8,1,-1
               if(isym(l)==0) cycle
               nsym=l
               exit
            enddo
            if(nsym==3) nsym=4
            if(nsym>4) nsym=8
            norb=sum(isym(1:nsym))
            !print*,'norb',norb
            !print*,'nsym',nsym
            write(2,'(a,i1)')' nsym=',nsym
            write(2,1001) ' isym=',isym(1:nsym)
            write(2,'(a6,i5)')' norb=',norb
            write(6,'(a,i1)')' nsym=',nsym
            write(6,1001) ' isym=',isym(1:nsym)
            write(6,'(a6,i5)')' norb=',norb
         endif
      enddo
!
! Read natom
      do k=1,54
         if (aa(k)(1:16)=='iScalar values  ') then
            krc=c_lseek(jrc_comfile,ii(k)*512+28*ifac)
            krc=c_read(jrc_comfile,natom,4)
            if(nprint>0)print*,'natom',natom
            write(2,'(a,i4)')' natom=',natom
         endif
      enddo
       
!
! Read AO labels
!   first find if the atoms are written by molcas with 4 or 6 characters
      if(natom==1) then
         long_atom=6
      else
         do k=1,54
            if (aa(k)(1:16)=='Unique Atom Name') then
               krc=c_lseek(jrc_comfile,ii(k)*512)
               krc=c_read(jrc_comfile,atom(1),8)
               if(atom(2)(1:1)==' ') then
                  long_atom=6
               else
                  long_atom=4
               endif
               exit
            endif
         enddo
      endif

!   ...then read
      do k=1,54
         if(aa(k)=='Unique Basis Nam') then
            krc=c_lseek(jrc_comfile,ii(k)*512)
            do l=1,norb
               krc=c_read(jrc_comfile,label(l)(1:4),long_atom)
               krc=c_read(jrc_comfile,label(l)(5:8),4)
               !print*,'label',l,label(l)
            enddo
            call oldlabel(label,norb)
            write(2,'(a)')' label='
            write(6,'(a)')' label='
            ifin=0
            do
               ideb=ifin+1
               ifin=ifin+5
               ifin=min(ifin,norb)
               write(2,1002) (cote,label(l),cote,l=ideb,ifin)
               if(ifin<=20)
     *         write(6,1002) (cote,label(l),cote,l=ideb,ifin)
               if(ifin==norb) exit
            enddo
            if(norb>20) then
               print*,' ...'
               print*,' '
            endif
 1002       format(100(1x,5(a1,a8,a1,',')))
         endif
      enddo
!
! Compute natom from AO labels
C      n=0
C      allocate(y(norb))
C      y=.true.
C      do i=1,norb
C         if(.not.y(i)) cycle
C         do j=i+1,norb
C            if(.not.y(i)) cycle
C            if(label(i)(1:4)==label(j)(1:4)) y(i)=.false.
C         enddo
C      enddo
C      natom=count(y)
!
! Read Unique Atoms
      do k=1,54
         if (aa(k)(1:16)=='Unique Atom Name') then
            krc=c_lseek(jrc_comfile,ii(k)*512)
            do l=1,natom
               krc=c_read(jrc_comfile,atom(l),long_atom)
               ic=ichar(atom(l)(1:1))
            enddo
            if(nprint>0)print*,'natom,atom',natom,atom(1:natom)
C            write(2,'(a,i4)')' natom=',natom
            write(2,'(a)') ' atom='
            write(2,1003) (cote,atom(l),cote,l=1,natom)
            write(6,'(a,i4)')' natom=',natom
            write(6,'(a)') ' atom='
            write(6,1003) (cote,atom(l),cote,l=1,natom)
         endif
      enddo
!
! Read Coordinates
      do k=1,54
         if (aa(k)=='Unique Coordinat') then
            krc=c_lseek(jrc_comfile,ii(k)*512)
            write(2,'(a)')' coor='
            write(6,'(a)')' coor='
            do l=1,natom
               krc=c_read(jrc_comfile,coord,8*3)
               write(2,'(3(f20.10,'',''))') coord
               if(l<=10)write(6,'(3(f20.10,'',''))') coord
            enddo
            if(natom>10) print*,'       ...'
            if(natom>10) print*,' '
         else if (aa(k)=='dScalar values') then
!
! Read Enuc
            krc=c_lseek(jrc_comfile,ii(k)*512+56)
            krc=c_read(jrc_comfile,enuc,8)
            write(2,'(a,f20.12)') ' enuc=',enuc
           write(6,'(a,f20.12)') ' enuc=',enuc
         endif
      enddo
!
!
      write(2,'(a5)')' its='
      write(6,'(a5)')' its='
      do j=1,nsym
         write(2,'(6x,8(i1,'',''))') (its(i,j),i=1,nsym),(0,i=nsym+1,8)
         write(6,'(6x,8(i1,'',''))') (its(i,j),i=1,nsym),(0,i=nsym+1,8)
      enddo
!      if(y64) then
!         krc=c_lseek(jrc_comfile,71928)
!         krc=c_read(jrc_comfile,jtsr64,64*8)
!         jtsr=jtsr64
!      else
!         krc=c_lseek(jrc_comfile,52092)
!         krc=c_read(jrc_comfile,jtsr,64*4)
!      endif
      !call mscript(jtsr(1:nsym,1:nsym))
      write(2,'(a6)')' jtsr='
      write(6,'(a6)')' jtsr='
      do j=1,nsym
         write(2,'(6x,8(i2,'',''))') (jtsr(i,j),i=1,nsym),(0,i=nsym+1,8)
         write(6,'(6x,8(i2,'',''))') (jtsr(i,j),i=1,nsym),(0,i=nsym+1,8)
      enddo
!
!     Symmetry operations
!
      inquire(file=trim(prefix)//'Seward.Input',exist=exist)
      if(exist) then
         open(99,file=trim(prefix)//'Seward.Input',status='old')
         do 
            read(99,'(a)',end=1) bb
            bb=adjustl(bb)
            call maj(bb,4)
            l=len_trim(bb)
            i=index(bb(1:l),' ')
            if(bb(1:3)=='END') then
               call maj(bb,80)
               do while (i/=0) 
                  bb(i:l-1)=bb(i+1:l)
                  l=l-1
                  i=index(bb(1:l),' ')
               enddo
               if(bb(1:10)=='ENDOFINPUT') exit
            endif
            if(bb(1:4)=='SYMM') then
               read(99,'(a)') bb
               write(2,'(a)')" symm='"//trim(bb)//"',"
               write(6,'(a)')" symm='"//trim(bb)//"',"
               exit
            endif
         enddo
 1       continue
      endif
      close(99)


      write(2,'(a2)')' /'
      write(6,'(a2)')' /'
c
c     Find address of the basis set
c
      do k=1,54
         !print*,'k,aa(k)',k,aa(k)
         if(aa(k)=='SewXInfo') then
            i_sewx=ii(k)*512
            print*,'lirrun i_sewx',i_sewx
         endif
         if(aa(k)=='nExp') then
            i_sewi=ii(k)*512-4
            !print*,'lirrun i_sewi',i_sewi
         endif
      enddo
 1001 format(a,8(i4,','))
 1003 format(100(1x,5(a1,a4,a1,','),/))
      !
      !File OneInt
      !
      call titre('Read OneInt file#',40)
      long2=0
      long=0
      do is=1,nsym
         long=long+isym(is)*(isym(is)+1)/2
         long2=long2+isym(is)*(isym(is)+1)/2
      enddo
      long=long*8
      long2=long2*8
      !print*,jrc_oneint
      if(y64) then
         krc=c_lseek(jrc_oneint,168)
         print*,'position 168'
         !krc=c_read(jrc_oneint,aa64(1:20),40*20)
         krc=c_read(jrc_oneint,aa64,20*40)
         krc=c_lseek(jrc_oneint,168)
         krc=c_read(jrc_oneint,ii64,20*40)
         aa=' '
         aa(1:20)(1:8)=aa64(1:20)(1:8)
         ii=ii64
      else
         krc=c_lseek(jrc_oneint,156)
         print*,'position 156'
         krc=c_read(jrc_oneint,aa20,20*20)
         krc=c_lseek(jrc_oneint,156)
         krc=c_read(jrc_oneint,ii,20*20)
         aa(1:20)(1:8)=aa20(1:20)(1:8)
      endif
      print*,'read table of addresses'
      do k=1,20
         if(aa(k)(1:8)=='MLTPL  0') then
            !print*,'k,aa(k)',k,aa(k),ii(k*5),ii(k*5)*512
            krc=c_lseek(jrc_oneint,ii(k*5)*512)
            print*,'read the overlap matrix. Position:',ii(k*5)*512
            !print*,'II',ii(k*5)*512
            krc=c_read(jrc_oneint,r8,long2)
         endif
      enddo
c      
c     read the overlap matrix
c 
      nn= norb*(norb+1)/2
      print*,(/('=',i=1,70)/)
      print*,' '
      print*,' '
      print*,'WRITE THE OVERLAP MATRIX ON FILE Mono'
      !print*,'WRITE THE OVERLAP MATRIX (SYM)  dimension:',long2
      print*,(/('=',i=1,70)/)
      print*,' '
      print*,' '
      !print*,'WRITE THE OVERLAP MATRIX (TOTAL)  dimension:',nn*8
      call ecrmono60(aa,'MLTPL  0',jrc_oneint,ii,r8,long2,mm,
     *isym,nsym,norb,1,'OVERLAP')

      !
      ! ecriture dans Mono des operateurs de calcul des proprietes, (si
      ! (yprop=T)
      !
      if(yprop) then
         open(33,file=trim(prefix)//'Prop',status='unknown',
     *   form='unformatted')
         allocate(pxq(norb*norb))
         print*,'WRITE THE PXQ MATRIX'
         call ecrmono60p(aa,'MLTPL  1',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,1,'PXQ    ',isx,its)
         print*,'WRITE THE PYQ MATRIX'
         call ecrmono60p(aa,'MLTPL  1',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,2,'PYQ    ',isy,its)
         print*,'WRITE THE PZQ MATRIX'
         call ecrmono60p(aa,'MLTPL  1',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,3,'PZQ    ',isz,its)
         isxx=1
         isyy=1
         iszz=1
         isxy=its(isx,isy)
         isxz=its(isx,isz)
         isyz=its(isy,isz)
         print*,'WRITE THE PXXQ MATRIX'
         call ecrmono60p(aa,'MLTPL  2',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,1,'PXXQ   ',isxx,its)
         print*,'WRITE THE PXYQ MATRIX'
         call ecrmono60p(aa,'MLTPL  2',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,2,'PXYQ   ',isxy,its)
         print*,'WRITE THE PXZQ MATRIX'
         call ecrmono60p(aa,'MLTPL  2',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,3,'PXZQ   ',isxz,its)
         print*,'WRITE THE PYYQ MATRIX'
         call ecrmono60p(aa,'MLTPL  2',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,4,'PYYQ   ',isyy,its)
         print*,'WRITE THE PYZQ MATRIX'
         call ecrmono60p(aa,'MLTPL  2',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,5,'PYZQ   ',isyz,its)
         print*,'WRITE THE PZZQ MATRIX'
         call ecrmono60p(aa,'MLTPL  2',jrc_oneint,ii,r8,long2,mm,
     *   pxq,isym,nsym,norb,6,'PZZQ   ',iszz,its)
         close (33)
      endif
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
!      bb=' '
!      write(bb,'(a)')'==OVERLAP MATRIX (SYM)'
!      write(3) bb
!      write(3) long2/8,nsym,isym(1:nsym)
!      print*,mm,long2/8
!      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(bb,'(a)') '==OVERLAP MATRIX (TOTAL)'
!      write(3) bb
!      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)
!      print*,' '
      return
      end
       subroutine ecrmono60(aa,etiqu,jrc_oneint,ii,r8,long2,mm,
     *isym,nsym,norb,nskip,mess)
      use mod_script
      IMPLICIT DOUBLE PRECISION (A-H,O-x,Z),logical*1(y)
c     parameter (maxorb=1024,maxsym=8,maxat=1024)
      parameter (maxorb=2048,maxsym=8,maxat=1024)
      character(8) etiqu
      character(16) aa(54)
      dimension ii(108),r8(mm),isym(nsym)
      character(80) bb
      character(7) mess
      double precision,allocatable,dimension(:) :: ov
      common/pr/nprint,mprint(10),filorb,blan40
      character(80) blan40,filorb
c      
c     read the matrix
c
      ns=0
c      do k=1,55
c         print*,'etiqu',k,aa(k),ii(k)
c      enddo
      do k=1,20
         if(aa(k)(1:8)==etiqu) then
            ns=ns+1
!            print*,'skip',ns,nskip
            if(ns==nskip) then
!               print*,'k,aa(k)',k,aa(k),ii(k*5)
               krc=c_lseek(jrc_oneint,ii(k*5)*512)
!               print*,'II',ii(k*5)*512
               krc=c_read(jrc_oneint,r8,long2)
               goto 1234
            endif
         endif
      enddo 
 1234 continue
c
c
c     write the matrix (sym by sym)
c
      yw1=.false.
      bb=' '
!      print*,trim(mess)
      write(bb,'(a)')'=='//trim(mess)//' MATRIX (SYM)'
      write(3) bb
      write(3) long2/8,nsym,isym(1:nsym)
!      print*,mm,long2/8
      write(3) r8(1:long2/8)
      if(nprint.ge.2)call scri1(nsym,r8,isym)
c
c     write the matrix (total)
c
      nn= norb*(norb+1)/2
      write(bb,'(a)') '=='//trim(mess)//' MATRIX (TOTAL)'
      write(3) bb
      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)
      print*,' '
      return
      end
       subroutine ecrmono60p(aa,etiqu,jrc_oneint,ii,r8,long2,mm,
     *pxq,isym,nsym,norb,nskip,mess,isx,its)
      use mod_script
      IMPLICIT DOUBLE PRECISION (A-H,O-x,Z),logical*1(y)
c     parameter (maxorb=1024,maxsym=8,maxat=1024)
      parameter (maxorb=2048,maxsym=8,maxat=1024)
      character(8) etiqu
      character(16) aa(54)
      dimension ii(108),r8(mm),isym(nsym)
      character(80) bb
      character(7) mess
      dimension  its(maxsym,maxsym)
      double precision,allocatable,dimension(:) :: ov
      dimension pxq(norb*norb)
      common/pr/nprint,mprint(10),filorb,blan40
      character(80) blan40,filorb
c      
c     read the matrix
c
      print*,'entree ecrmono60p'
      if(isx==1) then
         ns=0
         do k=1,55
            print*,'etiqu isx=1',k,aa(k),ii(k)
         enddo
         do k=1,20
            if(aa(k)(1:8)==etiqu) then
               ns=ns+1
               print*,'skip',ns,nskip
               if(ns==nskip) then
                  print*,'k,aa(k)',k,aa(k),ii(k*5)
                  krc=c_lseek(jrc_oneint,ii(k*5)*512)
                  print*,'II',ii(k*5)*512
                  krc=c_read(jrc_oneint,r8,long2)
                  krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc',onuc
                  krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc',onuc
                  krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc',onuc
                  krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc',onuc
                  goto 1234
               endif
            endif
         enddo 
 1234    continue
c
c        write the matrix (isx=1)
c   
         yw1=.false.
         bb=' '
         print*,trim(mess)
         write(bb,'(a)')'=='//trim(mess)//' MATRIX'
         write(33) bb
         write(33) isx
         write(33) long2/8,nsym,isym(1:nsym)
         print*,mm,long2/8
         write(33) r8(1:long2/8)
         write(33) onuc
         if(nprint.ge.2)call scri1(nsym,r8,isym)
      else
         ns=0
!         do k=1,55
!            print*,'etiqu',k,aa(k),ii(k)
!         enddo
         do k=1,20
            print*,'eti isx/=1',aa(k)(1:8),etiqu
            if(aa(k)(1:8)==etiqu) then
               ns=ns+1
               !print*,'skip',ns,nskip
               if(ns==nskip) then
                  kk=0
                  ll=1
                  print*,trim(mess)
                  write(bb,'(a)')'=='//trim(mess)//' MATRIX'
                  write(33) bb
                  write(33) isx
                  krc=c_lseek(jrc_oneint,ii(k*5)*512)
                  do is=1,nsym
                     js=its(is,isx)
                     if(js.gt.is) goto 20
                     nsi=isym(is)
                     nsj=isym(js)
                     if(nprint.ge.2)print*,'is,js,nsi,nsj',
     *               is,js,nsi,nsj
                     long=nsi*nsj
                     long8=long*8
                     print*,'k,aa(k)',k,aa(k),ii(k*5)
                     print*,'II',ii(k*5)*512
                     krc=c_read(jrc_oneint,r8,long8)
                     kkk=0
                     do k1=1,nsi
                        do l=1,nsj
                           kk=kk+1
                           kkk=kkk+1
                           pxq(kk)=r8(kkk)
                        enddo
                     enddo
                     print*,'mat carree dans ecrmono60p is,isx',is,isx
                     if(nprint.ge.0)call script(pxq(ll),nsj,nsi,nsj,nsi)
                     write(33) nsj,nsi
                     ll=ll+long
20                   continue
                  enddo
               endif
            endif
         enddo
         write(33) pxq(1:ll)
         krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc2',onuc
         krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc2',onuc
         krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc2',onuc
         krc=c_read(jrc_oneint,onuc,8)
         print*,'molcost onuc2',onuc
         write(33) onuc
      endif
      return
      end
       subroutine oldlabel(label,norb)
!
! reecriture du label selon l'ancienne forme (les S sont toutes 1s,
! les p toutes 2p, etc...
! utile a partir de molcas 6.7
!
      character(8) label(norb)
      do k=1,norb
         if(label(k)(6:6)=='s') label(k)(5:5)='1'
         if(label(k)(6:6)=='p') label(k)(5:5)='2'
         if(label(k)(6:6)=='d') label(k)(5:5)='3'
         if(label(k)(6:6)=='f') label(k)(5:5)='4'
         if(label(k)(6:6)=='g') label(k)(5:5)='5'
         if(label(k)(6:6)=='h') label(k)(5:5)='6'
         if(label(k)(6:6)=='i') label(k)(5:5)='7'
      enddo
      return
      end
