c     ******************************************************************
c
c     General utilities for Draw_PS  by Keith J. Halford    2/07/00
c
c     ******************************************************************
c
c ---------------------------------------------------------------------------------
c
      function irevdex(txt,ipos,char)
      character*1   char
      character*2048 txt
c
      i = ipos
      do while( i.gt.1 )
        i = i - 1
        if( txt(i:i) .eq. char) then
          irevdex = i
          i = 0
        endif
      enddo
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      integer function itxend( txt, n )
	character*2048 txt
	k = n
	do while( txt(k:k).eq.' ' .and. k.ge.1 )
	  k = k - 1
      enddo
      itxend = k
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      integer function ifrl( r )
      real*8 r
	ip = abs(r) + 0.5
	if( r .lt. 0.000 )  ip = -ip
	ifrl = ip
      return
      end
c ---------------------------------------------------------------------------------
c
      subroutine TrimALL(sTxT)
      CHARACTER sTxT*(*)
C
      L = len(trim(sTxT))
      DO while (sTxT(1:1).eq.' ' .and. L.gt.0 ) 
        sTxT = sTxT(2:L)
      end do
      sTxT = trim(sTxT) 
c
      RETURN
      END
c
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,sNOR,ierr)
      include 'WLmodel.inc'
      real*8 rn(lrna)
      character*5   sNOR
      character*5   sNOL
      character*2048  afile
      character*2048  txt,tx2
      integer ki
	data ioflip,ioalt /69,69/
	maxalp = 2048
c
      ierr = 0
    5 read(io,'(a)',end=10)  txt
      call TrimALL(sNOL)
      ki = len(trim(sNOL))
      if( txt(1:ki) .eq. sNOL(1:ki) )  goto 5
      call tab2space(txt)     !!   Replace all tabs with spaces
c
      call TrimALL(sNOR)
      ki = len(trim(sNOR))
	ki = index(txt,sNOR(1:ki))
	if( ki.gt.0 ) then
	  txt(ki:maxalp) = '                                             '
	endif
c
      tx2 = txt
      call UPCASE(tx2)
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         
c        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(5:5) = ' '
      if( io .eq. ioalt ) then 
        close(io)
        iohold = io
        io = ioflip
        ioflip = iohold 
        goto 5   
	else
        ierr = -1
	endif
c
      return
      end
c
c___________________________________________________
c
      subroutine tab2space(txt)
      character*1   tab                                                      
      CHARACTER txt*(*)
      integer iMax
      tab = char(9)                         !!     sets  tab delimiter
c                                                                             
      iMax = LEN(txt)
      do i = 1, iMax
        if( txt(i:i).eq.tab ) txt(i:i) = ' '
      enddo
c                                                                             
      return                                                                  
      end                                                                     
c ---------------------------------------------------------------------------------
c
      subroutine replace(txt,cf,cr,n)
      character*1 qs,qd
      character*1 cf,cr
      character*2048  txt
c
      write(qs,100)
  100 format(1h')
      write(qd,'(1h")')
c
      iqs = 0
      iqd = 0
      do i = 1, n
        if( txt(i:i).eq.qs .and. mod(iqd,2).eq.0 ) iqs = iqs + 1
        if( txt(i:i).eq.qd .and. mod(iqs,2).eq.0 ) iqd = iqd + 1
        if( txt(i:i).eq.cf .and. mod(iqs,2).eq.0 .and. mod(iqd,2).eq.0 )
     +      txt(i:i) = cr
      enddo
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine stripquote(txt,n)
      character*1 qs,qd
      character*2048  txt
c
      write(qs,100)
  100 format(1h')
      write(qd,'(1h")')
c
      iqs = 0
      iqd = 0
      do i = 1, n
        if( txt(i:i).eq.qs .and. mod(iqd,2).eq.0 ) then
          iqs = iqs + 1
          txt(i:i) = ' '
        endif
        if( txt(i:i).eq.qd .and. mod(iqs,2).eq.0 ) then
          iqd = iqd + 1
          txt(i:i) = ' '
        endif
      enddo
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      integer function indexq(txt,n, tx2,ksf)
      character*1 qs,qd
      character*2048  txt, tx2
c
      write(qs,100)
  100 format(1h')
      write(qd,'(1h")')
c
      indexq = 0
      iqs = 0
      iqd = 0
	i = 0
      do while ( i.lt.n-ksf )
        i = i + 1
        ie = i + ksf-1
        if( txt(i:i).eq.qs .and. mod(iqd,2).eq.0 ) iqs = iqs + 1
        if( txt(i:i).eq.qd .and. mod(iqs,2).eq.0 ) iqd = iqd + 1
        if( txt(i:ie).eq.tx2(1:ksf) .and.
     +      mod(iqs,2).eq.0 .and. mod(iqd,2).eq.0 ) then
          indexq = i
          i = n
        endif
      enddo
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine shorten(txt,test,n,tx2)
      character*2048 txt,tx2,test
c
      tx2 = '???????'
      ki = index(txt,test(1:n))
      if(ki.gt.0) then
        tx2 = txt(ki:128)
        kc = index(tx2,':')+1
        tx2 = tx2(kc:128)
        kc = index(tx2,':')+1
        if( kc .gt. 1 ) tx2 = tx2(1:kc-1)
      endif
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine conden(txt,n)
      character*2048 txt
	mchr = 2048
c
      if(n.gt.mchr/2) n = mchr/2
      do  i = 1,mchr-n
        txt(n+i:n+i)=' '
      enddo
c
      l=0
      do 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
      enddo
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine noleadblank(txt,n)
      character*2048 txt
	mchr = 2048
c
	nm = n
      if(nm.gt.mchr) nm=mchr
c
	i = 0
      do while( txt(1:1).eq.' ' .and. i.lt.nm )
        txt = txt(2:mchr)
        i = i + 1
      enddo
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine reform(f,n)
      character*64 f
      if(n.gt.64) n=64
      write(*,*)'  N IN REFORM=',n
      f=','//f(2:n)
      do 10 i=1,n
         if(f(i:i).eq.'X' .or. f(i:i).eq.'x') then
         do l=1,5
         j=i-l
             if(f(j:j).eq.',') then
             jb=j+1
             je=j+l-1
             f= f(1:j)//'A'//f(jb:je)//f(i+1:n)
             goto 10
             endif
         enddo
         endif
   10 continue
      f='('//f(2:n)
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine bakped(n,io)
c
      do i=1,n
        backspace(io)
	enddo
c
      return
      end
c
c ---------------------------------------------------------------------------------
c
      subroutine qread(r,ni,ain,ierr)
      include 'WLmodel.inc'
      real*8 r(lrna)
      character*1   tab
      character*16  form
      character*2048 aTEMP,ain
	tab = char(9)
	mchr = 2048
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
      aTEMP = ain
      do i = 1, mchr
        if( aTEMP(i:i).eq.tab ) aTEMP(i:i) = ' '
        if( aTEMP(i:i).eq.',' ) aTEMP(i:i) = ' '
        if( aTEMP(i:i).eq.':' ) aTEMP(i:i) = ' '
        if( aTEMP(i:i).eq.'=' ) aTEMP(i:i) = ' '
      enddo
      n = 1
      i = 0
   11 r(ni+1) = r(ni+1) + 1
   10 i = i+1
      if( i.ge.mchr) goto 15
      if( aTEMP(i:i).eq.' ' ) then
        aTEMP(i:i) = '?'
        goto 10
      endif
c
      ki = index(aTEMP,' ')-1
      nd = ki - i + 1
      form ='(F??.0)              '
      write(form(3:4),'(i2.2)') nd
      READ (ATEMP(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.mchr) goto 10
c
  15  n  = n-1
      ierr = ni - n
	r(ni+2) = i
      return
      end
c
c ---------------------------------------------------------------------------------
c
      SUBROUTINE UPCASE(WORD)
C     ******************************************************************
C     CONVERT A CHARACTER STRING TO ALL UPPER CASE
C     ******************************************************************
C       SPECIFICATIONS:
C     ------------------------------------------------------------------
      CHARACTER WORD*(*)
C
C1------Compute the difference between lowercase and uppercase.
      L = LEN(WORD)
      IDIFF=ICHAR('a')-ICHAR('A')
C
C2------Loop through the string and convert any lowercase characters.
      DO 10 K=1,L
      IF(WORD(K:K).GE.'a' .AND. WORD(K:K).LE.'z')
     1   WORD(K:K)=CHAR(ICHAR(WORD(K:K))-IDIFF)
10    CONTINUE
C
C3------return.
      RETURN
      END
c ---------------------------------------------------------------------------------
c
      subroutine AddTEXTnNUMB(sTxT,sDELIM,rVAL,sFORM)
      CHARACTER sTxT*(*)
      CHARACTER sDELIM*(*) 
      CHARACTER sFORM*(*) 
      CHARACTER*64 sTxN 
      real*8 rVAL
c      integer k1, k2, k3 
C
      k1 = len(trim(sTxT)) 
      k2 = len(trim(sDELIM)) 
      write(sTxN,sFORM) rVAL
      call trimALL(sTxN) 
      k3 = len(trim(sTxN)) 
      
      sTxT = sTxT(1:k1)//sDELIM(1:k2)//sTxN(1:k3)
c
      RETURN
      END
