      subroutine modifflo
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character(80) rep
      logical OK
      yw=.false.
!
!==========================================================
! Interactive modification of current final LO matrix
!==========================================================
!
      if(in_progress=='BOND') return
      if(iunit5==91) return
      if(yes) print*,'entree modifflo'
      call repl(form_dolo,'>','/MODIF_LO>',yrepl)
      call repl(form_dolo1,'>','/MODIF_LO>',yrepl)
      nwkp=0
      nwkk=0
      do
         write(6,form_dolo)'D: Display LO''s'
         write(6,form_dolo1)'L: List old data'
         write(6,form_dolo1)'LD n: data n: display details'
         write(6,form_dolo1)'DD n: Diplay orbitals of data n'
         write(6,form_dolo1)'O: Display occupations'
         !write(6,form_dolo1)'G: Enter GREP Mode'
         write(6,form_dolo1)'C n1 n2 ...: Cancel LO''s'
         write(6,form_dolo1)'CD n cancel data'
         write(6,form_dolo1)'P project LO''s'
         write(6,form_dolo1)'R rename LO''s'
         write(6,form_dolo1)'> string: transfer orbitals from occ>virt,'
     *   //' virt>occ'
         write(6,form_dolo1)'          (un)activate, (un)freeze'
         write(6,form_dolo1)'          "string" is included in the name'
     *   //' of the LO''s'
         write(6,form_dolo1)'          which must be modified'
         write(6,form_dolo1)'E search errors'
         write(6,form_dolo1)'EC search errors + interactive corrections'
         write(6,form_dolo1)'W display warnings in preceding data'
         write(6,form_dolo1)'X: Exit MODIF_LO'
         if(nwkk/=0.and.nwkp/=0) write(6,form_dolo1)'R: Run modif LO''s'
         read(5,'(a)') rep
         l=len_trim(rep)
         call fnormaligo(rep,l)
         print*, rep
!=================================================================
!=================================================================
         if(rep=='X') then
            exit
!=================================================================
!=================================================================
         else if(rep=='L') then
            do k=1,idatlist
               print'(i4,2x,a)',k,trim(datlist(k))
            enddo
!=================================================================
!=================================================================
         else if(rep(1:2)=='LD') then
            call displaydetails(rep)
!=================================================================
!=================================================================
         else if(rep(1:2)=='DD') then
            call displaydata(rep)
!=================================================================
!=================================================================
         else if(rep=='R') then
            call renamelo(5,5)
!=================================================================
!=================================================================
         else if(rep(1:1)=='>') then
            call changecat2(rep,' ')
!=================================================================
!=================================================================
         else if(rep=='D') then
            call displayflo
!=================================================================
!=================================================================
         else if(rep=='O') then
            ifilpr_sv=ifilpr
            ifilpr=6
            call occupations
            ifilpr=ifilpr_sv
!=================================================================
!=================================================================
         else if(rep(1:1)=='G') then
            call grepflo
!=================================================================
!=================================================================
         else if(rep=='P') then
            call proj0
!=================================================================
!=================================================================
         else if(rep(1:2)=='CD') then
            call canceldata(rep)
            cycle
!=================================================================
!=================================================================
         else if(rep(1:1)=='C') then
             call cancello(rep)
            cycle
!=================================================================
!=================================================================
         else if(rep(1:2)=='EC') then
            call verif(1)
!=================================================================
!=================================================================
         else if(rep(1:1)=='E') then
            call verif(0)
!=================================================================
!=================================================================
         else if(rep(1:1)=='W') then
            call displaywarnings(OK)
!=================================================================
!=================================================================
         else
            print*,'wrong data'
            cycle
         endif
      enddo
      call wdata
      call repl(form_dolo,'/MODIF_LO>','>',yrepl)
      call repl(form_dolo1,'/MODIF_LO>','>',yrepl)
      return
      end
       subroutine proj0
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character(80) rep
      dimension iwkk(100),iwkp(100)
      call titre('PROJECTIONS#',20)
      form_dolo='(/,'' DOLO/MODIF_LO/PROJ>>>>>>>  '',a)'
      form_dolo1='('' DOLO/MODIF_LO/PROJ>>>>>>>  '',a)'
      nwkk=0
      nwkp=0
      do
         write(6,form_dolo)'G: redisplay preceeding grep'
         write(6,form_dolo1)'K n1 n2...: unchanged LO''s'
         write(6,form_dolo1)'P n1 n2...: Projected LO''s'
         write(6,form_dolo1)'R: run projection and exit'
         write(6,form_dolo1)'X: Exit PROJ'
         read(5,'(a)') rep
         call fnormaligo(rep,l)
         print*, rep
!===========================================================
         if(rep(1:1)=='X') then
            exit
!===========================================================
         else if(rep(1:1)=='G') then
            rewind 75
            do
               read(75,'(a80)',end=5) rep
               print'(a)', trim(rep)
            enddo
 5          continue
!===========================================================
         else if(rep(1:1)=='K') then
            nwkk=0
            call rfi(rep,nwkk)
            iwkk(1:nwkk)=iwk(1:nwkk)
!===========================================================
         else if (rep(1:1)=='P') then
            nwkp=0
            call rfi(rep,nwkp)
            iwkp(1:nwkp)=iwk(1:nwkp)
!===========================================================
         else if (rep(1:1)=='R') then
            if(nwkk==0.or.nwkp==0) then
               print*,'you must enter K and P!'
               cycle
            endif
            call proj(nwkk,nwkp,iwkk,iwkp)
            exit
!===========================================================
         else
            print*,'wrong data'
            cycle
         endif
!===========================================================
         nwk=nwkk+nwkp
         iwk(1:nwkk)=iwkk(1:nwkk)
         iwk(1+nwkk:nwk)=iwkp(1:nwkp)
         print'(a,20i4)','Reference LO''s for projection',
     *   iwkk(1:nwkk)
         print'(a,20i4)','Projected LO''s               ',
     *   iwkp(1:nwkp)
         if(nwkp==0.or.nwkk==0) cycle
         ! verify if all K and P LO's are OCC/VIRT
         do i=1,nwk
            do j=1,i-1
               if(focvir(iwk(i))/=focvir(iwk(j))) then
                  print*,'Error  the selected LO''s belong to'//
     *            ' the OCC and VIRT spaces'
                  print'(20i5)',iwk(1:nwk)
                  print'(20a5)',focvir(iwk(1:nwk))
                  cycle
               endif
               if(fsym(iwk(i))/=fsym(iwk(j))) then
                  print*,'Error  the selected LO''s belong to'//
     *            ' different symmetries'
                  print'(5x,20i5)',iwk(1:nwk)
                  print'(a3,2x,20(1x,i4))','SYM',fsym(iwk(1:nwk))
                  cycle
               endif
            enddo
         enddo
         cycle
      enddo
      form_dolo='(/,'' DOLO/MODIF_LO/>>>>>>>  '',a)'
      form_dolo1='('' DOLO/MODIF_LO/>>>>>>>  '',a)'
      print*,'Exit PROJ mode'
      return
      end
       subroutine proj(nwkk,nwkp,iwkk,iwkp)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      allocatable ss(:,:),v(:,:)
      dimension iwkk(nwkk),iwkp(nwkp)
      character(10000) a
      allocatable flo1(:,:)
      yw=.false.
      if(yw)print*,'entree proj',iwkk(1:nwkk),iwkp(1:nwkp)
      if(yw)call displayflo
!
!-----------------------------
! Projection
!-----------------------------
!
      iwk(1:nwkk)=iwkk(1:nwkk)
      iwk(1+nwkk:nwkk+nwkp)=iwkp(1:nwkp)
      nwk=nwkk+nwkp
      allocate(ss(nwkp,nwkp))
      allocate(v(nwkp,nwkp))
      !print*,'flo orb K et P'
      if(in_progress.ne.'BOND') then
         print'(14X,10(4X,a4))',('KEPT',k=1,nwkk),('PROJ',k=nwkk+1,nwk)
         call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *   focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *   ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
      endif
      do i=1,nwkp
         do j=1,nwkk
            flo(:,iwkp(i))=flo(:,iwkp(i))
     *      -dot_product(flo(:,iwkp(i)),flo(:,iwkk(j)))
     *      *flo(:,iwkk(j))
         enddo
!      flo(:,iwkp(i))=flo(:,iwkp(i))/sqrt(dot_product(
!     *flo(:,iwkp(i)),flo(:,iwkp(i))))
      enddo
 
      if(yw)print*,'flo orb K et P apres projection'
      if(yw)call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
      do i=1,nwkp
         do j=1,i
            ss(i,j)=dot_product(flo(:,iwkp(i)),flo(:,iwkp(j)))
            ss(j,i)=ss(i,j)
         enddo
      enddo
      if(yw) print*,'mat de recouvrement entre orb P'
      if(yw)call script(ss,nwkp,nwkp,nwkp,nwkp)
      call hdiag(ss,v,nwkp,nwkp)
      if(yw)print'(a,20f8.4)','val pr rec',(ss(i,i),i=1,nwkp)
      if(yw)print'(a)','vect propres mat rec'
      if(yw)call script(v,nwkp,nwkp,nwkp,nwkp)
 
! Correction pour IDRIS  verfier!!!!
      do jj=1,nwkp
         j=iwkp(jj)
         do i=1,norb
            work2(i,j)=0.d0
            do kk=1,nwkp
               k=iwkp(kk)
               work2(i,j)=work2(i,j)+flo(i,k)*v(kk,jj)
            enddo
         enddo
      enddo
      flo(:,iwkp(1:nwkp))=work2(:,iwkp(1:nwkp))
 
C      flo(1:norb,iwkp(1:nwkp))=
C     *matmul(flo(1:norb,iwkp(1:nwkp)),v(1:nwkp,1:nwkp))
      if(yw)print*,'flo orb K et P apres projection et regroupement'
      if(yw)call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
      if(yw)print'(i3,a,20i4)'
     *,nwkk,'  eliminated LO(''s):',iwkp(nwkp-nwkk+1:nwkp)
      do k=nwkp,nwkp-nwkk+1,-1
         if(yw)print*,'elim',iwkp(k)
         ielim=iwkp(k)
         if(yw)call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *   focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *   ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
         call flodel(ielim)
          nwk=nwk-1
          do i=1,nwk
             if(iwk(i)>ielim) iwk(i)=iwk(i)-1
          enddo
         if(yw)call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *   focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *   ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
      enddo
 
      if(in_progress.ne.'BOND') then
         call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *   focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *   ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
      endif
!
!-------------------------------------------------
! write projection command on OLD_DATA_??? file
!-------------------------------------------------
!
      !write(a,*) 'SUBS',iwkp(1:nwkp),' - ',iwkk(1:nwkk)
      !l=len_trim(a)
      !call fnormaligo(a,l)
      !write(90,'(a)') trim(a)
 
 
 
      deallocate(ss)
      call scriflo
      return
      end
       subroutine flodeld(m11)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      do l=fnorb,1,-1
         kd=fdat1(l)
         if(kd==m11) call flodel(l)
      enddo
 
      print*,'flodeld',m11
      datlist(m11)='*'//datlist(m11)(1:len_trim(datlist(m11))+1)
      if(iunit5==5) print*,'flodel datlist',trim(datlist(m11))
      return
      end
       subroutine flodel(k)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      fnorb=fnorb-1
      flo(:,k:fnorb)=flo(:,k+1:fnorb+1)
      flo(:,fnorb+1)=0.d0
      orig(k:fnorb)=orig(k+1:fnorb+1)
      orig(fnorb+1)=' '
      ftype(k:fnorb)=ftype(k+1:fnorb+1)
      ftype(fnorb+1)=' '
      flab(k:fnorb)=flab(k+1:fnorb+1)
      flab(fnorb+1)=' '
      focc(k:fnorb)=focc(k+1:fnorb+1)
      focc(fnorb+1)=0.d0
      fdat1(k:fnorb)=fdat1(k+1:fnorb+1)
      fdat1(fnorb+1)=0
      focvir(k:fnorb)=focvir(k+1:fnorb+1)
      focvir(fnorb+1)=' '
      fsym(k:fnorb)=fsym(k+1:fnorb+1)
      fsym(fnorb+1)=0
      fnat(k:fnorb)=fnat(k+1:fnorb+1)
      fnat(fnorb+1)=0
      atoms_in_lo(k:fnorb,:)=atoms_in_lo(k+1:fnorb+1,:)
      atoms_in_LO(fnorb+1,:)=' '
      return
      end
 
 
       subroutine rfi(rep,nwk)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character(80) rep
      character(18) lab
      logical chiffre
      nwk=0
      rep(1:1)=' '
      rep=adjustl(rep)
      l=len_trim(rep)
      ! en donnee : numeros ou label ?
      if(.not.chiffre(rep(1:1))) then
         read(rep,'(a)') lab
         do k=1,norb
            if(flab(k)/=lab) cycle
            nwk=nwk+1
            iwk(nwk)=k
         enddo
      else
         nwk=nwk+1
         do k=1,l
            if(rep(k:k)==' ') nwk=nwk+1
         enddo
         read(rep,*) iwk(1:nwk)
      endif
      print*,iwk(1:nwk)
      call reor(nwk,iwk(1:nwk))
      return
      end
       subroutine renamelo(ifilr,ifilr1)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character(300) rep,rep2
      allocatable n(:)
      character(18),allocatable :: locflab(:)
      logical chiffre,y,yy,yw
      yw=.false.
      if(yes) print*,'entree renamelo'
! Local allocation
      allocate(n(norb))
      allocate(locflab(norb))
! Set prompt to  '/RENAME_LO>
      call repl(form_dolo,'>','/RENAME_LO>',yrepl)
      call repl(form_dolo1,'>','/RENAME_LO>',yrepl)
! Infinite loop on rename data
      do
         if(ifilr==5) then
            write(6,form_dolo)'n1 n2...: rename LO''s n1,n2...'
            write(6,form_dolo)
     *      'string  : rename LO''s containing "string"'
            write(6,form_dolo1)'G re-display last Grep'
            write(6,form_dolo1)'X exit rename mode'
         endif
         read(ifilr,'(a)') rep
         l=len_trim(rep)
         call fnormaligo(rep,l)
         print*, rep
         if(rep=='X') exit
! re-display last grep
         if(rep=='G') then
            rewind 75
            do
               read(75,'(a80)',end=5) rep
               print'(a)', trim(rep)
            enddo
 5          continue
            cycle
         endif
         l=len_trim(rep)
         y=rep(l:l)=='*'
         if(y) rep(l:l)=' '
         if(chiffre(rep(1:1))) then
! Rename data is of type: 'n1 n2...: rename LO''s n1,n2...'
!           number of renamed LO's   nn
            nn=1
            l=len_trim(rep)
            do k=1,l
               if(rep(k:k)==' ')nn=nn+1
            enddo
            read(rep,*,err=1) n(1:nn)
         else
!  Rename data is of type: 'string  : rename LO''s containing "string"'
            nn=0
            do k=1,norb
               if(y) then
                  yy=index(flab(k),trim(rep))/=0
               else
                  yy=index5(flab(k),trim(rep))/=0
               endif
               if(yy) then
                  nn=nn+1
                  n(nn)=k
               endif
            enddo
         endif
         rep2=rep
         if(yw)print*,'rep2 ',rep2
         nwk=nn
! Numbers of LO's to be renamed are iwk(1:nwk)
         iwk(1:nwk)=n(1:nwk)
         call scripto6(flo(:,n(1:nn)),norb,nn,norb,nn,orbi,6,
     *   focvir(n(1:nn)),flab(n(1:nn)),focc(n(1:nn))
     *   ,fsym(n(1:nn)),fdat1(n(1:nn)),n(1:nn))
         print'(20(a,1x))','Old label   ',(trim(flab(n(k))),k=1,nn)
         do
 3          continue
! Enter new labels
            print*,'Enter new label(s) (X to exit)'
            read(ifilr1,'(a)') rep
            l=len_trim(rep)
            call fnormaligo(rep,l)
            if(rep=='X') exit
            nnlu=1
            do k=1,l
               if(rep(k:k)==' ')nnlu=nnlu+1
            enddo
            if(nnlu/=nn) then
               print*,nn,' new labels requested'
               print*,nnlu,' new labels are given'
               cycle
            endif
            do k=1,nn
               l=index(rep,' ')-1
               if(l>18) then
                  print*,'too long label '//rep(1:l)
                  goto 3
               endif
               locflab(n(k))=rep(1:l)
               rep(1:l)=' '
               rep=adjustl(rep)
            enddo
 4          continue
            print*,'Old labels'
            print'(10(a,1x))',(trim(flab(n(k))),k=1,nn)
            print*,'New labels'
            print'(10(a,1x))',(trim(locflab(n(k))),k=1,nn)
            if(ifilr1==5) then
               print*,'Confirm? (Y/N)'
               read(5,'(a)') rep
               l=len_trim(rep)
               call fnormaligo(rep,l)
               if(rep=='Y') then
!                  flab(n(1:nn))=locflab(n(1:nn))
                  ! store rename data
                  rep='REN'
                  ll=len(rep)
!                  if(rep2==' ') then
!                     ! LO's to be renamed are given by label
!                     write(rep(5:ll),*) n(1:nn)
!               print*,'coucou1'
!                  else
                     ! LO's to be renamed are given by numbers
                     write(rep(5:ll),'(a)') trim(rep2)
!                  endif
                  if(yw)print*,'rep01 ',trim(rep)
                  call fnormaligo(rep(5:ll),ll-4)
!                  print*,trim(rep)
                  do k=1,nn
                     l=len_trim(rep)+2
                     lk=len_trim(locflab(n(k)))+l
                     rep(l:lk)=locflab(n(k))
                  enddo
                  if(yw)print*,'rep02 ',trim(rep)
                  idatlist=idatlist+1
                  datlist(idatlist)=trim(rep)
                  idatlist0=idatlist0+1
                  datlist0(idatlist0)=trim(rep)
                  call wdata
               else if(rep=='N') then
                  exit
               else
                  print*,'wrong data'
                  goto 4
               endif
            else
            endif
            ! Modify focvir
            do k=1,nn
               if(locflab(n(k))(1:1)/='A'.and.focvir(n(k))=='ACTO')
     *         focvir(n(k))='OCC'
               if(locflab(n(k))(1:1)/='A'.and.focvir(n(k))=='ACTV')
     *         focvir(n(k))='VIRT'
            enddo
            ! modify flab
            flab(n(1:nn))=locflab(n(1:nn))
            ! store rename data
!            rep='REN'
!            ll=len(rep)
!            write(rep(5:ll),*) n(1:nn)
!            print*,'rep03 ',trim(rep)
!            call fnormaligo(rep(5:ll),ll-4)
!            print*,'rep04 ',trim(rep)
!            do k=1,nn
!               l=len_trim(rep)+2
!               lk=len_trim(locflab(n(k)))+l
!               rep(l:lk)=locflab(n(k))
!            enddo
!            print*,'rep05 ',trim(rep)
!            !write(90,'(a)') rep(1:lk)
!            call wdata
            exit
         enddo
         exit
 1       continue
         print*, 'wrond data'
         cycle
      enddo
      call repl(form_dolo,'/RENAME_LO>','>',yrepl)
      call repl(form_dolo1,'/RENAME_LO>','>',yrepl)
      call changecat
      deallocate(locflab)
      deallocate(n)
      if(yes) print*,'sortie renamelo'
      return
      end
       subroutine renamelo_dir(AA)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character(len_datlist) AA,bb
      dimension ii(len_datlist)
      logical chiffre
      yw=.false.
      if(yes) print*,'entree renamelo_dir'
!
!----------------------------------------------
! Save data if it was read on 5
!----------------------------------------------
!
!      if(iunit5==5) then
!         idatlist=idatlist+1
!         datlist(idatlist)=AA
!      endif
!
!----------------------------------------------
! Normalize data
!----------------------------------------------
!
      l=len_trim(AA)
      call fnormaligo(AA,l)
      AA(1:3)=' '
      AA=adjustl(aa)
      l=len_trim(AA)
!
!----------------------------------------------
! Type of the data?
! REN n1 n2 n3 ... lab1 lab2 lab3...
! or
! REN LAB lab1 lab2 lab3...
!----------------------------------------------
!
      if(.not.chiffre(AA(1:1))) then
         ! number of modified labels (nn)
         n=0
         do k=1,l
            if(AA(k:k)==' ') n=n+1
         enddo
         ! list of new labels
         l1=index(AA,' ')-1
         print'(a,l2)','dataok',dataok
         call lab_list(AA(1:l1),ii,n,norb*gap)
         if(.not.dataok) return
         write(bb,*) ii(1:n)
         lb=len_trim(bb)
         call fnormaligo(bb,lb)
         AA(lb+2:l+lb-l1)=AA(l1+2:l)
         AA(l+lb-l1+1:l)=' '
         if(yw)print*,'AA1',trim(aa)
         aa(1:lb+1)=bb(1:lb)//' '
         if(yw)print*,'AA2',trim(aa)
      endif
      l=len_trim(AA)
 
!
!----------------------------------------------
! number of modified labels (nn)
!----------------------------------------------
!
      nn=1
      do k=1,l
         if(AA(k:k)==' ') nn=nn+1
         ! print*,'dir',k,aa(k:k),nn
      enddo
      print*,'nn',nn
      nn=nn/2
!
!----------------------------------------------
! limit between old label numbers and new labels (ll)
! in the data line
!----------------------------------------------
!
      nnn=0
      print*,'AA',trim(aa)
 
      do k=1,l
         if(AA(k:k)==' ') nnn=nnn+1
         if(nnn==nn) then
            ll=k-1
            exit
         endif
      enddo
      print*,'nnn',nnn,ll
      open(99)
      write(6,'(a)') AA(1:ll)
      write(6,'(a)') AA(ll+1:l)
      write(99,'(a)') AA(1:ll)
      write(99,'(a)') AA(ll+1:l)
      write(99,'(a)') 'X'
      rewind 99
      call renamelo(99,99)
      close(99,status='delete')
      if(yes) print*,'sortie renamelo_dir'
      return
      end
       logical function chiffre(a)
      character a
      if(ichar(a)<58.and.ichar(a)>47) then
         chiffre=.true.
      else
         chiffre=.false.
      endif
      return
      end
       subroutine lab_list(bb,ii,n,nlab)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character(*) bb
      dimension ii(n)
      kk=0
      do k=1,nlab
         if(flab(k)==bb) then
            kk=kk+1
            if(kk>n) goto 1
            ii(kk)=k
         endif
      enddo
      if(n/=kk) goto 1
      return
 1    continue
      print*,'Data: REN LAB lab1 lab2 lab3...'
      print*,'The number of LO''s corresponding to LAB does'//
     *' not match with the number of lab1 lab2 lab3... data'
      dataok=.false.
      print*,'n,kk',n,kk
      return
      end
