      subroutine lirintm(yok)
      use molcost
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c     PARAMETER (NTIBUF=9600,maxorb=1024,maxsym=8)
      PARAMETER (NTIBUF=9600,maxorb=2048,maxsym=8)
      parameter (min_Block_Length=1024)
      include '../../param/maxlong.prm'
      common/version/molcas,i_rec,i_at,i_orb,i_coo,y64
      integer fermi,frozen,inact,act,delete(8),inact_chol(8),act_chol(8)
      integer frozen_chol(8),delete_chol(8),fermi_chol(8)
      common/mcsd/fermi(8),frozen(8),inact(8),act(8)
      common /filc/jrc_oneint,jrc_comfile,jrc_traone,jrc_traint
      integer c_open,c_read
      common/proj/ prefix,ybas,ymo,ycl,ysym,yao
      dimension itoc(66)
      integer(8) itoc8(66)
      dimension norbs(8),buf(32),norbs0(32)
      equivalence(itoc(1),buf(1))
      dimension TIBUF(NTIBUF*2),itibuf(ntibuf*4)
      equivalence(itibuf(1),tibuf(1))
      dimension inferm(8),iord(maxorb),norb0(9)!,nn0(9)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym),norb
      common/sym1/ its(maxsym,maxsym),itsym(maxorb)
      common/pr/nprint,mprint(10),filorb,blan40
      character*80 blan40,filorb,prefix,aa
      integer*2 ind(4096),jnd(4096),knd(4096),lnd(4096)
      dimension aint(4096)
      character(1) charfil
      allocatable fiijj(:)
      !allocatable ifiijj(:)
      !equivalence(ifiijj(1),fiijj(1))
      real(8),dimension(:,:),allocatable :: one
      character(16) bb(120)
      dimension ii(120)
      integer(8) ii64(120)
 
      character*1280 namel
c      print*,'entree lirintm'
      if(ychol) then
         call titre(' Cholesky Calculation: File Info remains'//
     *   ' unchanged#',40)
      else
         call titre
     *   ('Molecular Orbital Part:# 1) Build COST_MO Namelist#'//
     *   ' 2) Add 1-e MO integrals to Mono file# 3) build ijcl '//
     *   'file#',40)
         print*,' '
         print*,'======================================================'
         print*,' READING TRAONE AND TRAINT FILES'
         write(2,'(a)') ' &cost_MO'
      endif
      allocate(fiijj(norb*(norb+1)/2))
      !allocate(ifiijj(norb*(norb+1)))
      if(molcas.eq.0) then
         print*,'molcas=0, must be 4 or 5 or 54'
         stop
      endif
c
c     read data
c
      rewind 93
      l_ijcl=maxlong/1000      ! max lenth of integral file (in Mbytes)
      act=0
      inact=0
      fermi=0
      delete=0
      call LECNAM('&COST ',namel,93,ierr,0)
      call nameli(namel,fermi,'FERMI',4)
      call nameli(namel,frozen,'FROZEN',4)
      call nameli(namel,delete,'DELETE',4)
      call nameli(namel,inact,'INACT',4)
      call nameli(namel,act,'ACT',4)
      print*,' '
      print*,'======================================'
      print'(a,8i4)','FERMI ',fermi(1:nsym)
      print'(a,8i4)','FROZEN',frozen(1:nsym)
      print'(a,8i4)','DELETE',DELETE(1:nsym)
      print*,'======================================'
      if(all(act.eq.0)) inact=fermi
      if(ychol) then
         fermi_chol=fermi
         frozen_chol=frozen
         delete_chol=delete
         act_chol=act
         inact_chol=inact
         fermi=0
         frozen=0
         delete=0
         act=0
         inact=0
      endif
      call nameli(namel,l_ijcl,'L_IJCL',4)
      ll_ijcl=1
      b_ijcl=1.d0*4096*16/1000000 ! length of a record (in Mbytes)
      nb_ijcl=l_ijcl/b_ijcl       ! max number of records
      nrec_ijcl=1
!      print'(a,f10.6,a)',
!     *'length of a record                     ',b_ijcl,' Mbytes'
!      print*,'max number of records in a file',nb_ijcl
!      if(nb_ijcl.eq.0) stop 'nb_ijcl=0'
!      stop
c
c
c
      yw=.false.
c      print*,' '
c      print*,'======================================== '
c      print*,'  RENUMEROTATION DES ORBITALES  '
c      print*,'======================================== '
      print*,' '
c
c     32 or 64 bits ?
c     can be 32 bits in runfile, 64 bits in traone! (molcas7.7)
c     use y64_traone instead of y64
c     find y64 by looking at the beginning of traone file whether 
c     written in integer(8) or not
c
      krc=c_lseek(jrc_traone,0)
      krc=c_read(jrc_traone,itoc,64*4)
c     if 64 bits, itoc(1)==0
      y64_traone=itoc(2)==0
      !print*,'y64_traone',y64_traone

      if(y64_traone) then
         ifac=2
      else
         ifac=1
      endif
c
c     read the pointers of traone
c
      !???krc=c_read(jrc_traone,itoc,64*4*ifac)
      !if(.not.ychol) then
      krc=c_lseek(jrc_traone,0)
      if(y64_traone) then
         krc=c_read(jrc_traone,itoc8,64*8)
         itoc=itoc8
      else
         krc=c_read(jrc_traone,itoc,64*4)
      endif
      !print*,'itoc',itoc;stop
      yok=yok.and.krc>0
      if(.not.yok) print*,'ERREUR lect lirintm 1'
      !???iadrone=itoc(2*ifac)
      iadrone=itoc(2)
      if(iadrone==0) iadrone=itoc(3)
      !print*,'iadrone',iadrone,min_Block_Length
      if(molcas.eq.54) then
         iadrone=iadrone*8
      else if(molcas.eq.5) then
         iadrone=iadrone*8
      else if(molcas.eq.60) then
         iadrone=iadrone*512
      else
         iadrone=iadrone*min_Block_Length
      endif
      !print*,'iadrone',iadrone,min_Block_Length;stop

      if(.not.ychol) then
c      
c        lecture de traone : enuc, nombre de symetries,
c                            nombre d'orbitales par symetrie avant gel
c                            nombre d'orbitales par symetrie apres gel
c      
         if(molcas==60) then
            krc=c_lseek(jrc_traone,512)
            krc=c_read(jrc_traone,potnuc,8)
            print*,'Potnuc',potnuc
            krc=c_lseek(jrc_traone,1536)
            if(y64_traone) then
               krc=c_read(jrc_traone,ii64,64)
               do k=1,8
                  norbs0(k)=ii64(k)
               enddo
            else
               krc=c_read(jrc_traone,norbs0,64)
            endif
            krc=c_lseek(jrc_traone,2048)
            if(y64_traone) then
               krc=c_read(jrc_traone,ii64,64)
               norbs(1:8)=ii64(1:8)
            else
               krc=c_read(jrc_traone,norbs,64)
            endif
            goto 2000
         endif
         krc=c_read(jrc_traone,itoc,2*4)
         yok=yok.and.krc>0
         if(.not.yok) print*,'ERREUR lect lirintm 2'
         potnuc=buf(1)
         print*,'Potnuc',potnuc
c      
         yok=yok.and.krc>0
         if(.not.yok) print*,'ERREUR lect lirintm 3'
         krc=c_read(jrc_traone,nsym,4)
         if(y64_traone) krc=c_read(jrc_traone,nsym,4)
         print*,'nsym',nsym
         if(molcas.eq.54.and..not.y64_traone) 
     *   krc=c_read(jrc_traone,ibid,4)
         !print*,'ibid',ibid
         yok=yok.and.krc>0
         if(.not.yok) print*,'ERREUR lect lirintm 4'
         print*,'number of symmetries',nsym
c      
         krc=c_read(jrc_traone,norbs0,32*ifac)
         yok=yok.and.krc>0
         if(.not.yok) print*,'ERREUR lect lirintm 5'
 2000    continue
         nn=0
         do k=1,nsym
            nn=nn+norbs0(k)
         enddo
         write(6,'(/,
     *   ''  nombre d''''orbitales par symetrie avant motra'',/
     *   8i4)') (norbs0(k),k=1,nsym)
         write(6,*)'total :',nn
c        
         if(molcas<60) then
            krc=c_read(jrc_traone,norbs,32*ifac)
            yok=yok.and.krc>0
            if(.not.yok) print*,'ERREUR lect lirintm 6'
         endif
         nn=0
         do k=1,nsym
            nn=nn+norbs(k)
         enddo
         write(6,'(/,
     *   ''  nombre d''''orbitales par symetrie apres motra'',/
     *   8i4)') (norbs(k),k=1,nsym)
         write(6,*)'total :',nn
         write(6,'(/,''  nombre d''''orbitales gelees par symetrie'',/
     *   8i4)') (frozen(k),k=1,nsym)
         write(6,'(/,''  nombre de vituelles eliminees'',/
     *   8i4)') (norbs0(k)-norbs(k)-frozen(k),k=1,nsym)
         delete(1:nsym)=norbs0(1:nsym)-norbs(1:nsym)-frozen(1:nsym)
         print *,'-----------------------------------------------------'
         write(6,'(/,''  niveau de Fermi'',/
     *   8i4)') (fermi(k),k=1,nsym)
         write(6,'(/,''  nombre d''''actives (donnee act)'',/
     *   8i4)') (act(k),k=1,nsym)
         write(6,'(/,
     *   ''  nombre d''''inactives (donnee inact, =fermi si act=0)'',/
     *   8i4)') (inact(k),k=1,nsym)
      endif

      if(ychol) then
         !call titre('Cholesky Transformation#',50)
!
! Cholesky run
!

! read NumCho from RunFile
!   1. re-read the labels of the RunFile
         krc=c_lseek(jrc_comfile,512*ifac)
         if(yw)print*,'krc',krc,jrc_comfile
         krc=c_read(jrc_comfile,bb,120*16)
!   2. read the addresses ii corresponding to the labels
         krc=c_lseek(jrc_comfile,16384+512*ifac)
         if(y64) then
            krc=c_read(jrc_comfile,ii64,120*16)
            ii=ii64
         else
            krc=c_read(jrc_comfile,ii,120*16)
         endif
         if(yw)print*,'krc',krc
!   3. read numcho
         do k=1,120
            if (bb(k)(1:12)=='NumCho') then
               if(yw)print*,'Trouve k',k
               krc=c_lseek(jrc_comfile,ii(k)*512)
               if(y64) then
                  krc=c_read(jrc_comfile,ii64,8*8)
                  numcho(1:nsym)=ii64(1:nsym)
               else
                  krc=c_read(jrc_comfile,numcho,8*4)
               endif
            endif
         enddo
         call Fill_Chol(nSym,isym)

         potnuc=enuc
         print*,'Potnuc',potnuc
         norbs0(1:8)=isym(1:8)
         norbs=isym
         write(6,'(/,
     *   ''  nombre d''''orbitales par symetrie'',/
     *   8i4)') (norbs(k),k=1,nsym)
C         fermi=0
         frozen=0
         delete=0
         
      endif
 
c
c     nombre d'occupees
c
      noc=0
      do k=1,nsym
         noc=noc+fermi(k)
      enddo
c
c----ordre des orbitales-----
c
      NORB0(1)=0
      !nn0(1)=0
      DO 2 I=1,NSYM
      NORB0(I+1)=NORB0(I)+norbs(I)
      !nn0(i+1)=nn0(i)+norbs(I)*(norbs(I)+1)/2
2     CONTINUE
      nnorb=norb0(nsym+1)
      do k=1,nsym
         inferm(k)=norbs(k)-inact(k)-act(k)
      enddo
      if(yw)print*,'inferm',(inferm(k),k=1,nsym)
      print *,' '
      print*,'-----------------------------------------------------'
      n=0
      mm=0
      do k=1,nsym
         mm=max(mm,fermi(k))
      enddo
      !write(6,1001)(l,l=1,min0(mm,15))
 999  format(a3,i2,5x,15i4,' ...')
 1000 format(a3,i2,5x,20i4)
 1001 format('Num. motra',20i4)
 1002 format('Num. motra',15i4,' ...')

      !print*,'act',act(1:nsym)
      !print*,'act_chol',act(1:nsym)
      !print*,'inact',inact(1:nsym)
      !print*,'inact_chol',inact(1:nsym)
      !print*,'fermi',fermi(1:nsym)
      !print*,'fermi_chol',fermi_chol(1:nsym)
      !print*,'isym',isym(1:nsym)
      !print*,'inferm',(inferm(k),k=1,nsym)
      !print*,'itsym',itsym(1:norb)
      if(ychol) then
         if(all(act_chol==0)) then
!            do k=1,nsym
!               n1=n+1
!               do l=1,fermi_chol(k)
!                  n=n+1
!                  itsym(n)=k
!               enddo
!               n2=min(n,n1+14)
!               if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
!            enddo
         else
!            do k=1,nsym
!               n1=n+1
!               do l=1,inact(k)
!                  n=n+1
!                  itsym(n)=k
!               enddo
!               n2=min(n,n1+14)
!               if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
!            enddo
!            print*,'-----------    Begin Active Orbitals   ------------'
!            do k=1,nsym
!               n1=n+1
!               do l=1,act(k)
!                  n=n+1
!                  itsym(n)=k
!               enddo
!               n2=min(n,n1+14)
!               if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
!            enddo
         endif
!         if(.not.all(act==0))
!     *   print*,'-----------      End of Active Orbitals  ------------'
      else
         if(all(act==0)) then
            do k=1,nsym
               n1=n+1
               do l=1,fermi(k)
                  n=n+1
                  itsym(n)=k
               enddo
               n2=min(n,n1+14)
               if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
            enddo
            print*,'-----------      Fermi sea             ------------'
         else
            do k=1,nsym
               n1=n+1
               do l=1,inact(k)
                  n=n+1
                  itsym(n)=k
               enddo
               n2=min(n,n1+14)
               if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
            enddo
            print*,'-----------    Begin Active Orbitals   ------------'
            do k=1,nsym
               n1=n+1
               do l=1,act(k)
                  n=n+1
                  itsym(n)=k
               enddo
               n2=min(n,n1+14)
               if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
            enddo
         endif
         if(.not.all(act==0))
     *   print*,'-----------      End of Active Orbitals  ------------'
      endif
      mm=0
      do k=1,nsym
         mm=max(mm,inferm(k))
      enddo
      if(mm.gt.15) then
         write(6,1002)(l,l=1,min0(mm,15))
      else
         write(6,1001)(l,l=1,min0(mm,15))
      endif
      do k=1,nsym
         n1=n+1
         do l=1,inferm(k)
            n=n+1
            itsym(n)=k
         enddo
         n2=min(n,n1+14)
         if(inferm(k).gt.15) then
            if(n2>=n1)write(6,999)'Sym',k,(l,l=n1,n2)
         else
            if(n2>=n1)write(6,1000)'Sym',k,(l,l=n1,n2)
         endif
      enddo
      !print*,'itsym',itsym(1:norb)
      print*,'-----------------------------------------------------'
      print*,' '
      !print*,'fermi',fermi
      !print*,'act',act;stop
c
      n=0
      do k=1,nsym
         do l=1,nnorb
            if(itsym(l).eq.k) then
               n=n+1
               iord(n)=l
            endif
         enddo
      enddo
      !print*,'fermi',fermi
      !print*,'frozen',frozen
      !print*,'delete',delete;stop
c
c-----ecriture des occupations------
c
      if(filorb.ne.blan40) call ecrocc(nsym,norbs,norbs0,
     *fermi,frozen,itsym,iord,act,inact,delete)
      
      if(ychol) goto 2002
c
c     reading file TraInt
c
      krc=c_read(jrc_traint,iiii,4)
      yok=yok.and.krc>0
      if(.not.yok) print*,'ERREUR lect lirintm 7',krc
      krc=c_lseek(jrc_traint,0)
c      yok=yok.and.krc>0
c      print'(a,l2,i16)','yok,krc',yok,krc
      krc=c_read(jrc_traint,iadrtwo,4)
      if(y64_traone)krc=c_read(jrc_traint,iadrtwo,4)
      yok=yok.and.krc>0
      if(.not.yok) print*,'ERREUR lect lirintm 71',krc
      krc=c_lseek(jrc_traint,0)
      !yok=yok.and.krc>0
      !if(.not.yok) print*,'ERREUR lect lirintm 72',krc
      if(molcas.eq.54) then
         !
         !iadrtwo mis a 53  !!!!!!!!!!!!!!!
         !
         print*,'iadrtwo',iadrtwo
         if(iadrtwo==0) iadrtwo=53
         print*,'iadrtwo',iadrtwo
         krc=c_read(jrc_traint,tibuf,iadrtwo*8)
         yok=yok.and.krc>0
         if(.not.yok) print*,'ERREUR lect lirintm 8',krc
      else if(molcas.eq.5) then
         krc=c_read(jrc_traint,tibuf,53*8)
         yok=yok.and.krc>0
      if(.not.yok) print*,'ERREUR lect lirintm 9'
      else if(molcas.eq.60) then
         krc=c_read(jrc_traint,tibuf,512*ifac)
         yok=yok.and.krc>0
      else
         krc=c_read(jrc_traint,tibuf,128*8)
         yok=yok.and.krc>0
      if(.not.yok) print*,'ERREUR lect lirintm a'
      endif
c
C TWO-ELECTRON INTEGRALS
c

      ijkl=0
      nlec=0
      inumfi=0
      DO 313 NSP=1,NSYM
      NOP=norbs(NSP)
      DO 312 NSQ=1,NSP
      NSPQ=its(NSP,NSQ)
      NOQ=norbs(NSQ)
      DO 311 NSR=1,NSP
      NSPQR=its(NSPQ,NSR)
      NOR=norbs(NSR)
      NSSM=NSR
      IF(NSR.EQ.NSP)NSSM=NSQ
      DO 310 NSS=1,NSSM
      IF(NSS.NE.NSPQR)GO TO 310
      NOS=norbs(NSS)
      NORBP=NOP*NOQ*NOR*NOS
      IF(NORBP.EQ.0)GO TO 310

      print*,'nsp',nsp,nsq,nsr,nss,inumfi
      call flush(6)
      krc=c_read(jrc_traint,tibuf,9600*8)
c--   renzo modif
      yfin=krc.ne.9600*8
       if(yfin)then
          print*,'read',krc,' instead of 76800'
          krcd=9600*8-krc
          krcs=krc
          print*,'krc=',krc,' Now opening new traint file'
!          if(inumfi.eq.0)then
          krc=c_close(jrc_traint)
          print*,'file closed krc=',krc
          if(inumfi.eq.9)then
             print*,'too many TraInt files',inumfi+1
             stop 'too many files'
          endif
          write(charfil,'(i1)')inumfi+1
          jrc_traint=
     *    c_open(trim(prefix)//'TraInt'//charfil//char(0))
          print*,'New file succesfully opened',jrc_traint
          krc=c_read(jrc_traint,itibuf(krcs/4+1),krcd)
          print*,'read',krc,'bytes'
!          endif
          inumfi=inumfi+1
          yfin=.false.
       endif
       call flush(6)
c--   renzo modif end

      nlec=nlec+1
      IOUT=0
      DO 309 NV=1,NOR
      NXM=NOS
      IF(NSR.EQ.NSS)NXM=NV
      DO 308 NX=1,NXM
      NTM=1
      IF(NSP.EQ.NSR)NTM=NV
      DO 307 NT=NTM,NOP
      NUMIN=1
      IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX
      NUMAX=NOQ
      IF(NSP.EQ.NSQ)NUMAX=NT
      DO 306 NU=NUMIN,NUMAX
      IOUT=IOUT+1
!              print*,'inumfi',inumfi,nv,nx,nt,nu
!      if(inumfi>9) then
!              print*,'INUMFI',inumfi,nv,nx,nt,nu
!              stop
!      endif
      IF(IOUT.GT.NTIBUF) THEN
         krc=c_read(jrc_traint,itibuf,9600*8)
         yfin=krc.ne.9600*8
c--   renzo modif
         if(yfin)then
         print*,'read',krc,' instead of 76800'
         krcd=9600*8-krc
         krcs=krc
         print*,'krc=',krc,' now opening new traint file'
!         if(inumfi.eq.0)then
         krc=c_close(jrc_traint)
         print*,'file closed krc=',krc
         if(inumfi.eq.9)then
            print*,'too many TraInt files',inumfi+1
            stop 'too many files'
         endif
         write(charfil,'(i1)')inumfi+1
         jrc_traint=
     *   c_open(trim(prefix)//'TraInt'//charfil//char(0))
         print*,'new file succesfully opened',jrc_traint
         krc=c_read(jrc_traint,itibuf(krcs/4+1),krcd)
         print*,'read',krc,'bytes'
!         endif
         inumfi=inumfi+1
         yfin=.false.
         endif
         call flush(6)
c--   renzo modif end

         IOUT=1
         nlec=nlec+1
      END IF
          call flush(6)
305   continue
      M1=iord(NORB0(NSP)+NT)
      M2=iord(NORB0(NSQ)+NU)
      M3=iord(NORB0(NSR)+NV)
      M4=iord(NORB0(NSS)+NX)
      IF(M1.EQ.0.OR.M2.EQ.0)GO TO 306
      IF(M3.EQ.0.OR.M4.EQ.0)GO TO 306
C ORDER THESE INDICES CANONICALLY
      N1=M1
      N2=M2
      IF(M1.GT.M2)GO TO 11
      N1=M2
      N2=M1
11    N3=M3
      N4=M4
      IF(M3.GT.M4)GO TO 12
      N3=M4
      N4=M3
12    NI=N1
      NJ=N2
      NK=N3
      NL=N4
      IF(NI.GT.NK)GO TO 502
      IF(NI.EQ.NK)GO TO 14
      NI=N3
      NJ=N4
      NK=N1
      NL=N2
      GO TO 502
14    IF(NJ.GT.NL)GO TO 502
      NL=N2
      NJ=N4
502   FINI=TIBUF(IOUT)
c
c     ecriture sur ijcl
c
      if(ycl) then
         write(72,'(4i4,d20.12)') ni,nj,nk,nl,FINI
      else
         ijkl=ijkl+1
         ind(ijkl)=ni
         jnd(ijkl)=nj
         knd(ijkl)=nk
         lnd(ijkl)=nl
         aint(ijkl)=fini
         if(ijkl.eq.4096) then
            write(72)ind,jnd,knd,lnd,aint
            call incrijcl(ll_ijcl,nb_ijcl,nrec_ijcl)
            ijkl=0
         endif
      endif
 
      goto 306
 
306   CONTINUE
307   CONTINUE
308   CONTINUE
309   CONTINUE
310   CONTINUE
311   CONTINUE
312   CONTINUE
313   CONTINUE
c
c     write last block of TWO EL integrals
c
      if(.not.ycl) then
         ijkl=ijkl+1
         ind(ijkl)=0
         jnd(ijkl)=0
         knd(ijkl)=0
         lnd(ijkl)=0
         aint(ijkl)=potnuc
         write(72)ind,jnd,knd,lnd,aint
      endif
c
c
 2002 continue
c
C READ ONE-ELECTRON ORBITALS.
c
      NORBTT=0
      DO 7654 IS=1,nsym
      NORBTT=NORBTT+(norbs(IS)*(norbs(IS)+1))/2
 7654 CONTINUE
c
c     on positionne le pointeur
c
      krc=c_lseek(jrc_traone,iadrone)
c      yok=yok.and.krc>0
c
c     lecture
c
      krc=c_read(jrc_traone,fiijj,norbtt*8)
      yok=yok.and.krc>0
      if(.not.yok) print*,'ERREUR lect lirintm d'
      allocate (one(nnorb,nnorb))
c     on ecrit la matrice en carre
      jBUF=0
      KORBI=0
      one=0
      DO 200 IS=1,NSYM
      DO 199 JORBI=KORBI+1,KORBI+norbs(IS)
      DO 198 IORBI=KORBI+1,JORBI
      jBUF=jBUF+1
      ONEHAM=FIIJJ(jBUF)
      NI=iord(IORBI)
      NJ=iord(JORBI)
c      print *,'ONEHAM', nsym,jorbi,iorbi,jbuf,ni,nj,ONEHAM
      one(ni,nj)=oneham
      one(nj,ni)=oneham
      IF(NI.EQ.0.OR.NJ.EQ.0)GO TO 198
      IF(NI.LT.NJ) THEN
         NTMP=NI
         NI=NJ
         NJ=NTMP
      END IF
198   CONTINUE
199   CONTINUE
      KORBI=KORBI+norbs(IS)
200   CONTINUE
      if(.not.ychol) then
         if(.not.ysym.or.ycl) then
c        
c           write the one electron integrals to the formatted file
c        
            if(ycl) then
               print*,'WRITE THE ONEINT MATRIX (CL)  dimension:',norbtt
               do k=1,nnorb
                  do l=1,k
                  if(nprint.ge.2.and.itsym(k).eq.itsym(l))
     *            write(6,'(4i4,d20.12)') k,l,0,0,one(k,l)
                  if(itsym(k).eq.itsym(l))
     *            write(72,'(4i4,d20.12)') k,l,0,0,one(k,l)
                  enddo
               enddo
               write(72,'(4i4,d20.12)') 0,0,0,0,potnuc
            else
c        
c              write the one el. integrals to the unformatted file (unsym)
c        
               print*,' '
               print*,' '
               print*,'WRITE THE ONEINT MATRIX (UNSYM)  dimension:'
     *         ,nnorb
               aa=blan40
               write(aa,'(a)') '==ONEINT MATRIX (TOTAL)'
               write(3) aa
               write(3) nnorb
               write(3) ((one(i,j),i=1,nnorb),j=1,i)
            endif
         else
c        
c           write the one electron integrals to the unformatted file (sym)
c        
            print*,' '
            print*,' '
            print*,'WRITE THE ONEINT MATRIX (SYM)  dimension:',norbtt
            write(aa,'(a)') '==ONEINT MATRIX (SYM)'
            write(3) aa(1:80)
c            print*,'ecr',aa(1:80)
            write(3) norbtt,nsym,norbs(1:nsym)
c            print*,'ecr',norbtt,nsym,norbs(1:nsym)
            write(3) fiijj(1:norbtt)
c            print*,'ecr',fiijj(1:norbtt)
            if(nprint.ge.2)call scri1(nsym,fiijj,norbs)
c        
c           write the one el. integrals to the unformatted file (unsym)
c        
            print*,' '
            print*,' '
            nn=nnorb*(nnorb+1)/2
            print*,'WRITE THE ONEINT MATRIX (TOTAL) dimension:',nn
            aa=blan40
            write(aa,'(a)') '==ONEINT MATRIX (TOTAL)'
            write(3) aa
            write(3) nn,nsym,isym(1:nsym)
            write(3) ((one(i,j),j=1,i),i=1,nnorb)
         endif
      endif
 
      if(ychol) then
*---write info on file MO_ONEINT
         open(73,file='MO_ONEINT',status='unknown',form='unformatted')
         write(73) nnorb,nsym
         write(73) one
         write(73) norbs(1:nsym),numcho(1:nsym),potnuc,nb_ijcl
car
car      write(6,*) "info en MO_ONEINT"
car      write(6,*) norbs(1:nsym),numcho(1:nsym),potnuc,nb_ijcl
car
         write(73) fermi_chol(1:nsym),
     *   frozen_chol(1:nsym),delete_chol(1:nsym)
     *   ,act_chol(1:nsym),inact_chol(1:nsym)
!         write(6,*) 'FERMIFROZENDELETE',fermi_chol(1:nsym),
!     *   frozen_chol(1:nsym),delete_chol(1:nsym)
      else
*---enregistrements sur cost_MO------------------------------
         write(6,'(a6,i1,a6,i4,a5,i4)')' nsym=',nsym,',norb='
     *   ,nnorb,',noc=',noc
         write(6,'(a7)') ' itsym='
         write(6,'(1x,20(20(i1,'',''),/,1x))')(itsym(i),i=1,nnorb)
         write(2,'(a6,i1,a6,i4,a5,i4)')' nsym=',nsym,',norb='
     *   ,nnorb,',noc=',noc
         write(2,'(a7)') ' itsym='
         write(2,'(1x,20(20(i1,'',''),/,1x))')(itsym(i),i=1,nnorb)
         write(2,'(a6,8(i3,'',''))') ' isym=',norbs(1:nsym)
         write(2,'(a8,8(i3,'',''))') ' frozen=',frozen(1:nsym)
         write(2,'(a8,8(i3,'',''))') ' delete=',delete(1:nsym)
            
         write(2,'(a6,f20.12)')' enuc=',potnuc
         write(6,'(a6,f20.12)')' enuc=',potnuc
         write(2,'(a5,l1)')' ycl=',ycl
         write(6,'(a5,l1)')' ycl=',ycl
         write(2,'(a8,i9)')' n_ijcl=',nb_ijcl
         write(6,'(a8,i9)')' n_ijcl=',nb_ijcl
c         write(6,*) ' n_ijcl=',nrec_ijcl
         write(2,'(a5)') ' &end'
         write(6,'(a2)') ' /'
      endif
      deallocate (one)
*-----------------------------------------------------------
      return
      end
       subroutine incrijcl(ll_ijcl,nb_ijcl,nrec_ijcl)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/n_fil/ n_ijcl
      character*80 n_ijcl
      character*2 c
      yw=.false.
      ll_ijcl=ll_ijcl+1
      if(yw)print*,ll_ijcl,nb_ijcl,trim(n_ijcl)
      if(ll_ijcl.gt.nb_ijcl) then
         ll_ijcl=1
         close(72)
         long=len_trim(n_ijcl)
         if(yw)print*,'LONG',long
         if(yw)print*,'file   ',n_ijcl(1:long)
         itom=0
         do k=long,1,-1
            if(n_ijcl(k:k).eq.'_') then
                    if(yw)print*,'long,k',long,k,long-2
               if(k.eq.long-1) then
                       if(yw)print*,'coucou1'
                  read(n_ijcl(k+1:long),'(i1)',err=1) itom
                  if(yw)print*,'Itom',itom
               else if(k.eq.long-2) then
                       if(yw)print*,'coucou2'
                  read(n_ijcl(k+1:long),'(i2)',err=1) itom
               else
                       if(yw)print*,'coucou3'
                  goto 1
               endif
 1             continue
               exit
            endif
         enddo
         itom=itom+1
         if(yw)print*,'itom',itom
         if(itom.eq.100) stop 'too much ijcl files'
         c='  '
         if(itom.lt.10) then
            write(c(1:1),'(i1)') itom
         else
            write(c(1:2),'(i2)') itom
         endif
         if(itom.eq.1) then
                 if(yw)print*,'longc',len_trim(c)
                 if(yw)print*,'open72  ',n_ijcl(1:long)//'_'//trim(c)
            open(72,file=trim(n_ijcl)//'_'//trim(c),form='unformatted',
     *      status='unknown')
            n_ijcl=n_ijcl(1:long)//'_'//trim(c)
         else
                 if(yw)print*,'open72  ',n_ijcl(1:k-1)//'_'//trim(c)
            open(72,file=n_ijcl(1:k-1)//'_'//trim(c),form='unformatted',
     *      status='unknown')
            n_ijcl=n_ijcl(1:k-1)//'_'//trim(c)
         endif
         nrec_ijcl=nrec_ijcl+1
      endif
      return
      end
       subroutine traint2(jrc_traint,yok,tibuf)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/nfil/ traint1
      character*80 traint1
      dimension tibuf(9600)
      integer c_open,c_read,c_lseek
c      print*,'entree traint2'
c      print*,'traint1',traint1
      call incr_name(traint1)
      print*,'ouverture ',trim(traint1)
      jrc_traint=c_open(trim(traint1)//char(0))
      krcl=c_lseek(jrc_traint,0)
      krc=c_read(jrc_traint,tibuf,9600*8)
      yok=krc>0
      print*,'ouverture TRAINT',jrc_traint,krcl,krc,yok,tibuf(1)
      if(.not.yok) then
              print*,'ERREUR ouverture TRAINT1'
              stop
      endif
      return
      end
