c
      include 'NoComment.inc'
      dimension rn(mrnv)
      logical        bCOUNT
      character*8    sCNTtag
      character*10   sNOR
      character*10   sNOL
      character*10   sCNT
      character*20   form
      character*32   sPARnow
      character*32   sPAR(mxCNT)
      dimension  nPARcnt(mxCNT)  
      character*2048 txt, FileNAME, FileTEMP
      sNOL = '#'
      iNOL = 1
      sNOR = '!'
      iNOR = 1
      sCNT = ''
      iCNT = 0
      io = 7
      ioo = io+1
      sCNTtag ='COUNTER_'
c     
   5  write(*,'(a)') 'Enter Commented file to clean....'    
      read(*,'(a)') txt
      if( txt(1:1).eq.' ' ) txt ='01_Sample_hccalp.XQX.txt'
      open(io,file=txt,err=5)
c
      FileNAME = 'NoComment_'//txt
c
c   Check if delimiters are to be redefined       
      do i = 1, 4
        read(io,'(a)',end=10) txt
        call caps(txt,1000)
        k1 = index(txt,'NO-LINE_DELIMITER:')
        if( k1.gt.0 ) then
          k1 = k1 + Len('NO-LINE_DELIMITER:') 
	    sNOL = txt(k1:k1+9) 
          iNOL = index(sNOL,' ')-1
	  endif
        k1 = index(txt,'NO-RIGHT_DELIMITER:')
        if( k1.gt.0 ) then
          k1 = k1 + Len('NO-RIGHT_DELIMITER:') 
	    sNOR = txt(k1:k1+9) 
          iNOR = index(sNOR,' ')-1
	  endif
        k1 = index(txt,'COUNTER_DELIMITER:')
        if( k1.gt.0 ) then
          k1 = k1 + Len('COUNTER_DELIMITER:') 
	    sCNT = txt(k1:k1+9) 
          iCNT = index(sCNT,' ')-1
	  endif
        k1 = index(txt,'ASK-FOR-OUTPUT-FILENAME')
        if( k1.gt.0 ) then
          write(*,'(a)') 'Enter file name of uncommented output ....'
          read(*,'(a)') FileNAME
	  endif
      enddo  
      rewind(io)
c  
c  Open scratch file to receive uncommented input     ---  Bad approach because file REWIND was not working & I didn't want to continue fiddling. 
      FileTEMP = 'temp.txt'
      open(ioo,file=FileTEMP)
c  
c  Scan for counter variables and things to count in the UNCOMMENTED text
      if( iCNT.gt.0 ) then
        ierr = 0
        nPARs = 0 
        nLINES = 0
        do while (ierr.eq.0) 
          call ncread(io,txt,sNOL,iNOL,sNOR,iNOR,ierr)
          if( ierr.eq.0 .and. index(txt,sCNT(1:iCNT)).gt.0 ) then
            call GetPARtags(TxT, sCNT,iCNT, sPAR,nPARs) 
          endif
          ki = index(txt,sCNTtag) 
          if( ki.gt.0 ) then
            ki = ki+len(sCNTtag)
            if( txt(ki:ki+4).eq.'START' ) then 
              sPARnow = txt(ki+6:ki+15)
              bCOUNT = .TRUE.
            else
              iPARnow = MATCH( sPARnow, sPAR )
              nPARcnt(iPARnow) = nLINES
              nLINES = 0
              bCOUNT = .FALSE.
            endif
          else
            if( bCOUNT ) nLINES = nLINES + 1
          endif
c Echo output to scratch file           
          if( iCNT.eq.0 .or. index(txt,sCNTtag).lt.1 ) then
            i = itxend(txt)
            form = '(AXXXX)'
            write(form(3:6),'(i4.4)') i
            write(ioo,form) txt
          endif
        enddo
        rewind(ioo)
      endif  
c
      close(io) 
c  Open file to receive uncommented input      
      open(io, file=FileNAME)
c  Process input to uncommented output  
      txt = ''
      do while (txt(1:3).ne.'EOF') 
        read(ioo,'(a)') txt
        if( txt(1:3).ne.'EOF' ) then
          if(iCNT.gt.0) then
            if(index(txt,sCNT(1:iCNT)).gt.0 ) then
              Call PutPARvalues(TxT, sCNT,iCNT, nPARcnt,sPAR,nPARs)
            endif
          endif
          i = itxend(txt)
          form = '(AXXXX)'
          write(form(3:6),'(i4.4)') i
          write(io,form) txt
        endif  
      enddo
c 
   10 close(io)       
      close(ioo)
c  Bad, bad -- compiler specific call       
      io = DELFILESQQ(FileTEMP)       
c
      stop
      end
c___________________________________________________
c
      integer function itxend( txt )
	character*2048 txt
	k = 2048
	do while( txt(k:k).eq.' ' .and. k.gt.1 ) 
	  k = k - 1
      enddo
      itxend = k
c 
      return
      end
c___________________________________________________
c
      integer function ifrl( r )
	ip = abs(r) + 0.5
	if( r .lt. 0.000 )  ip = -ip
	ifrl = ip
      return
      end
c___________________________________________________
c
c   NCREAD: reads lines of input and ignores lines that begin with a "#" sign.
c          All information after a ! is wiped from the input card. 
      subroutine ncread(io,txt,sNOL,iNOL,sNOR,iNOR,ierr)
      include 'NoComment.inc'
      dimension rn(mrnv)
      character*10   sNOR
      character*10   sNOL
      character*1024  afile
      character*2048  txt,tx2
	data ioflip,ioalt /69,69/
	maxalp = 2048
c
      ierr = 0
    5 read(io,'(a)',end=10)  txt
      if( txt(1:iNOL) .eq. sNOL(1:iNOL) )  goto 5
      call tab2space(txt)     !!   Replace all tabs with spaces
c
	ki = index(txt,sNOR(1:iNOR))
	if( ki.gt.0 ) then
	  txt(ki:maxalp) = '                                             '
	endif
c
      tx2 = txt
      call caps(tx2,200)
c
c    Test for switching control to an auxilary input file
c
      ki = index(txt,':')
      if( index(tx2,'REDIRECT').gt.0 .and. ki.gt.0 ) then
	  afile = txt(ki+1:maxalp) 
	  ki = index(afile,'  ') - 1
        iohold = io
        io = ioflip
        ioflip = iohold 
        open(io,file=afile(1:ki),status='OLD',err=20)
c  Check for skipping lines   
        ki = index(tx2,'SKIPLINES=')
        if( ki.gt.0 )then
          ki = ki+len('SKIPLINES=')
          afile = txt(ki:maxalp) 
          call qread(rn,1,afile,ierrQ)
          ki = ifrl(rn(1))
          write(*,*)'  Skipping ',ki,' lines.'
          do i = 1,ki
            read(abs(io),'(a)',end=10) afile
          enddo
        endif
c  Check for parsing data         
        if( index(tx2,'PARSEONE').gt.0 ) sNOR(10:10) = 'P'
        goto 5   
	endif
c
c    Test for returning io control from auxillary input to master input file
c
      if( index(tx2,'RETURN')  .gt.0 .and.
     +    index(tx2,'CONTROL') .gt.0      ) goto 10 
c
      ki = index(tx2,'<END>')
      if( ki .gt. 0 ) then
	  ierr = 1
	  txt(ki+5:maxalp) = '                                           '
	endif
c
      if( index(tx2,'<STOP>') .gt. 0 ) ierr = 2
      return
c
c    Report error in opening auxillary input file and stop MODOPTIM
c
   20 write(*,*)
      write(*,*) '  ERROR opening auxillary input file  '
      write(*,*)
      write(*,'(2x,10h The file:,2x,a40,16h does not exist.)')  afile
      write(*,*) 
      stop ' ' 
c
   10 txt(1:3) = 'EOF'
      sNOR(10:10) = ' '
      if( io .eq. ioalt ) then 
        close(io)
        iohold = io
        io = ioflip
        ioflip = iohold 
        goto 5   
	else
        ierr = -1
	endif
c
      return
      end
c___________________________________________________
c
      subroutine shorten(txt,test,n,tx2)
      character*2048 txt,tx2,test
	maxalp = 2048
c
      tx2 = '???????'
      ki = index(txt,test(1:n))
      if(ki.gt.0) then
        tx2 = txt(ki:maxalp)
        kc = index(tx2,':')+1
        tx2 = tx2(kc:maxalp)
        kc = index(tx2,':')+1
        if( kc .gt. 1 ) tx2 = tx2(1:kc-1)
      endif
      return
      end
c___________________________________________________
c
      subroutine conden(txt,nin)
      character*2048 txt
	maxalp = 2048
c
      n = nin
      if( n.ge.256 ) n = 256
      do  i=1,maxalp-n
        txt(n+i:n+i)=' '
      enddo
c
      l=0
      do 10 k=1,n*2
      l=l+1
      if(txt(l:l).eq.' ')then
      do m=l,n
        txt(m:m)=txt(m+1:m+1)
      enddo
      l=l-1
      endif
   10 continue
      return
      end
c___________________________________________________
c
      subroutine qread(r,ni,ain,ierr)
      include 'NoComment.inc'
      dimension r(mrnv)                                                        
      character*1   tab                                                      
      character*16  form                                                      
      character*2048 atxt, ain  
      maxalp = 2048                                                
      tab = char(9)                         !!     sets  tab delimiter
c                                                                             
c   r(ni+1) records the number of non-numeric entries that were attempted to be read as a number                                                                              
c   r(ni+2) records the last column that was read from the card
c                                                                             
      r(ni+1) = -1.0000
      atxt = ain                                                              
      do i = 1, maxalp
        if( atxt(i:i).eq.tab ) atxt(i:i) = ' '
        if( atxt(i:i).eq.',' ) atxt(i:i) = ' '
        if( atxt(i:i).eq.':' ) atxt(i:i) = ' '
        if( atxt(i:i).eq.'=' ) atxt(i:i) = ' '
      enddo
      n = 1                                                                   
      i = 0                                                                   
   11 r(ni+1) = r(ni+1) + 1
   10 i = i+1                                                                 
      if( i.ge.maxalp ) goto 15                                                   
      if( atxt(i:i).eq.' ' ) then                        
        atxt(i:i) = '?'                                                       
        goto 10                                                               
      endif                                                                   
c                                                                             
      ki = index(atxt,' ')-1                                                  
      nd = ki - i + 1                                                         
      form ='(F??.0)              '                                         
      write(form(3:4),'(i2.2)') nd
      READ (atxt(I:KI),FORM,ERR=13,IOSTAT=ISTAT) R(N)
   13 CONTINUE
      i = ki
      IF (ISTAT.GT.0) GOTO 11  ! PART OF BUG FIX -- ERB
      n = n+1
      if( n.le.ni .and. i.lt.maxalp) goto 10
c                                                                             
  15  n  = n-1                                                                
      ierr = ni - n   
	r(ni+2) = i                                                        
      return                                                                  
      end                                                                     
c___________________________________________________
c
      subroutine tab2space(txt)
      character*1   tab                                                      
      character*2048 txt 
      maxalp = 2048                                                
      tab = char(9)                         !!     sets  tab delimiter
c                                                                             
      do i = 1, maxalp
        if( txt(i:i).eq.tab ) txt(i:i) = ' '
      enddo
c                                                                             
      return                                                                  
      end                                                                     
c___________________________________________________
c
      subroutine caps(a1,n)
      character*1 lc(26), uc(26)
      character*2048  a1
      data lc /'a','b','c','d','e','f','g','h','i','j','k','l','m','n',
     .         'o','p','q','r','s','t','u','v','w','x','y','z'/
      data uc /'A','B','C','D','E','F','G','H','I','J','K','L','M','N',
     .         'O','P','Q','R','S','T','U','V','W','X','Y','Z'/
	do i=1,n
        j = 0
        do while( j.lt.26 )
          j = j + 1
          if( a1(i:i).eq.lc(j) ) then 
            a1(i:i) = uc(j)
	      j = 26
          endif
        enddo
      enddo
c
      return
      end
c___________________________________________________
c
      subroutine GetPARtags(TxT, sCNT,iCNT, sPAR,nPARs)
      include 'NoComment.inc'
      character*10   sCNT
      character*32   sPAR(mxCNT)
      character*2048 txt, sTxT 
c      
      sTxT = TxT
      call conden(sTxT,2048)
c      
      ki = 1
      do while (ki.gt.0) 
        ki = index(sTxT,sCNT(1:iCNT))
        if( ki.gt.0 ) then
          sTxT = sTxT(ki+iCNT:2048)
          ki = index(sTxT,sCNT(1:iCNT))
          nPARs = nPARs + 1
          sPAR(nPARs) = sTxT(1:ki-1)
          sTxT = sTxT(ki+iCNT:2048)
        endif
      enddo
c      
      return
      end
c___________________________________________________
c
      integer function MATCH( sFIND, sARR )
      include 'NoComment.inc'
      character*32   sFIND
      character*32   sARR(mxCNT)
c	
      ke = index(sFIND,' ') - 1
      match = 0
      ki = 2
      k = 0
	do while( ki.gt.1 ) 
	  k = k + 1
	  ki = index(sARR(k),' ') - 1
	  if( ki.gt.1 ) then
	    if( sFIND(1:ke) .EQ. sARR(k)(1:ki) ) then
	      match = k
	      ki = 0
	    endif  
	  endif
      enddo
c 
      return
      end
c___________________________________________________
c
      subroutine PutPARvalues(TxT, sCNT,iCNT, nPARcnt,sPAR,nPARs)
      include 'NoComment.inc'
      character*10   sCNT
      character*20   sForm
      character*32   sFIND
      character*32   sPAR(mxCNT)
      character*2048 TxT, Tx2
      integer nWRT
      dimension  nPARcnt(mxCNT)  
c      
      ki = 1
      do while (ki.gt.0) 
        ki = index(TxT,sCNT(1:iCNT))
        if( ki.gt.0 ) then
          TxT(ki:ki+iCNT-1) = repeat(' ',iCNT)
          ke = index(TxT,sCNT(1:iCNT)) + iCNT-1
          sFIND =  TxT(ki:ke-iCNT)
          call conden( sFIND, 32)
          iV = MATCH( sFIND, sPAR )
          nWRT = ke - ki + 1
          sForm = '(Ixx.xx)'
          write(sForm(3:7),'(i2.2,A1,i2.2)') nWRT,'.',nWRT
          write(TxT(ki:ke),sForm) nPARcnt(iV)
        endif
      enddo
c      
      return
      end
