cccccccccccccccccccccccccccccccccccccccccccccccc
cc                                            cc
cc  scor2prt.for  Version 1.3 -  9/9/97       cc
cc                                            cc
cccccccccccccccccccccccccccccccccccccccccccccccc
c 
c Changes since version 1.1:
c
c Deal with saved macros.
c Revise setup readin, to admit comments.
c Do not copy 'X' into parts
c
cccccccccccccccccccccccccccccccccccccccccccccccc  
      common /all/ noinst
      integer nvi(7)
      character*1 sq,achar(9)
      character*12 jobname
      character*128 instrum(7)
      character*128 line,holdln
      logical termrpt,isachar,topcoms,frstln,oneof2
      common /comtop/ topcoms
      data achar /'P','m','V','R','A','h','w','K','M' /
      data nvi /7*1/
      topcoms = .false.
      frstln = .true.
      lenhold = 0
      print*,'jobname:'
      read(*,'(a)')jobname  
      ljob = lenstr(jobname,12)
      if (ljob .gt. 7) then
        print*,'Use a jobname with 7 or fewer letters'
        stop
      end if
      sq = char(92)
      open(10,file=jobname(1:ljob)//'.pmx')
      iccount = 128
      read(10,'(a)')line
      if (line(1:3) .eq. '---') then
        print*,'Sorry, scor2prt cannot deal with type-5 TeX strings'
        stop 1
      end if
      rewind(10)
      nv = readin(line,iccount)+.1
      noinst = readin(line,iccount)+.1
      mtrnuml = readin(line,iccount)+.1
      mtrdenl = readin(line,iccount)+.1
      mtrnmp = readin(line,iccount)+.1
      mtrdnp = readin(line,iccount)+.1
      xmtrnum0 = readin(line,iccount)
      isig = readin(line,iccount)
      npages = readin(line,iccount)+.1
      nsyst = readin(line,iccount)+.1
      musicsize = readin(line,iccount)+.1
      fracindent = readin(line,iccount)
      do 19 iv = 1 , noinst
        open(10+iv,status='SCRATCH')
19    continue
      if (topcoms) then
        rewind(30)
        do 14 i = 1 , 10000
          read(30,'(a)',end=15)line
          call allparts(line,128)
14      continue
        print*,'Should not be here.  Call Dr. Don!'
15      continue
        close(30)
      end if
      if (npages .eq. 0) then
        print*,
     *'You entered npages=0, which means nsyst is not the total number'
        print*,
     *'of systems.  Scor2prt has to know the total number of systems.'
        print*,
     *'Please set npages and nsyst to their real values.'   
        stop
      end if
      nppp = (nsyst-1)/12+1
      nvi(1) = nv-noinst+1
      do 1 iv = 1 , noinst
        write(10+iv,'(6i5,f7.3,i5/3i5,f8.5)')
     *          nvi(iv),1,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,isig,
     *          nppp,nsyst,20,0.05
16      read(10,'(a)') instrum(iv)
        if (instrum(iv)(1:1) .eq. '%') then
          call allparts(instrum(iv),128)
          go to 16
        end if
c
c  The following checks for macro that write original C-clef as part of
c  instrument name.  See pmx.tex
c
        if (index(instrum(iv),'namewpc') .eq. 0) then
          write(10+iv,'(a)')' '
        else
          inm1 = index(instrum(iv),'{')+1
          inm2 = index(instrum(iv),'}')-1
          read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2
          write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'//
     *      char(iy1+49)//char(iy2+49)
          instrum(iv) = instrum(iv)(inm1:inm2)
        end if
1     continue
c
c  Clef string
c
17    read(10,'(a)') line
      if (line(1:1) .eq. '%') then
        call allparts(line,128)
        go to 17
      end if
      do 2 iv = 1 , noinst
        if (iv .eq. 1) then
          write(10+iv,'(a'//char(49+nv-noinst)//')')line(1:nv-noinst+1)
        else
          write(10+iv,'(a1)')line(nv-noinst+iv:nv-noinst+iv)
        end if
2     continue
c
c  Path string
c
18    read(10,'(a)') line
      if (line(1:1) .eq. '%') then
        call allparts(line,128)
        go to 18
      end if
      call allparts(line,128)
c
c  Write instrument names.  Will be blank if later part of a score.
c
      if (instrum(1)(1:1) .ne. ' ') then
        do 3 iv = 1 , noinst
          len = lenstr(instrum(iv),79)
          write(10+iv,'(a2/a)')'Ti',instrum(iv)(1:len)
3       continue
      end if
c
c  The big loop.  Except for '%%', put all comment lines in all parts.
c  Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts
c  If a line starts with %!, put the rest of it in each part.
c  If a line starts with %[n], put the rest of it in part [n].
c  Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes.
c     Assume they only come at top of block, except terminal repeat needs
c     special handling.
c  Check for "P"; ignore in parts.
c  Check for consecutive full-bar rests; if found, replace with rm[nn]
c
      iv = 1
      iinst = 1
      termrpt = .false.
4     read(10,'(a)',end=999)line
      if (line(1:2).eq. '%%') then
c
c  Ignore next line
c
        read(10,'(a)')line
        if (index('h XXl ',line(1:2)).gt.0) read(10,'(a)')line
        go to 4
      else if (line(1:1).eq.'%' .and. 
     *            index('1234567',line(2:2)).gt.0) then
        lenline = lenstr(line,128)
        write(10+ichar(line(2:2))-48,'(a)')line(3:lenline)
        go to 4
      else if (line(1:2) .eq. '%!') then
        call allparts(line(3:128),126)
        go to 4
      else if (line(1:1) .eq. 'T') then
        call allparts(line,128)
        read(10,'(a)')line
        call allparts(line,128)
        go to 4
      else if (line(1:2).eq.sq//sq .or. line(1:1).eq.'%') then
        call allparts(line,128)
        go to 4
      else if (index('hl',line(1:1)).gt.0 .and.
c    *    line(2:2).eq.' ') then
     *    index(' +-',line(2:2)) .gt. 0) then
c       call allparts(line(1:1),1)
        call allparts(line,128)
        read(10,'(a)')line
        call allparts(line,128)
        go to 4
      else if (iv .eq. 1) then
        do 5 ia = 1 , 9
          idxa = ntindex(line,achar(ia))
          isachar = idxa .gt. 0
          if (idxa.gt.1) isachar = line(idxa-1:idxa-1).eq.' '
          if (ia .eq. 9) isachar = 
     *                    isachar .and. line(idxa+1:idxa+1).eq.'S'
          if (isachar) then
c
c  Find next blank
c
            do 6 ib = idxa+1 , 128
              if (line(ib:ib) .eq. ' ') go to 7
6           continue
            print*,'Problem with "V,R,m,P,A,h,MS, or w"'
            print*,'Send files to Dr. Don at dsimons@logicon.com'
            stop
7           continue
c
c  Next blank is at position ib
c
            if (ia .eq. 4) then
c
c  Check for terminal repeat.  Note if there's a term rpt, there can't be any
c  others.  Also, must process repeats LAST, after m's and 'V's
c
              do 8 ic = ib+1 , 128
                if (index(' /',line(ic:ic)) .eq. 0) go to 9
                if (line(ic:ic) .eq. '/') then
                  termrpt = .true.
c
c  Process the line as if there were no "R"
c
                  go to 10
                end if
8             continue
c
c  If here, all chars after "R" symbol are blanks, so process the line normally
c
            else if (ia .eq. 1) then
c
c  Do not transfer P into parts.
c
              go to 12
            else if (ia .eq. 9) then
c
c  Start Saving a macro. After leaving here, a symbol will be sent to all parts,
c  If all on this line, set ib to end and exit normally.  
c
              ndxm = index(line(ib+1:128),'M')
              if (ndxm.gt.0 .and. line(ib+ndxm-1:ib+ndxm-1).eq.' ') then 
c
c  Macro ends on this line
c
                ib = ib+ndxm+1
              else
c
c  Save leading part of current line 
c
                lenhold = idxa-1
                if (lenhold .gt. 0) holdln = line(1:lenhold)
c
c  Transfer rest of line
c
                call allparts(line(idxa:128),129-idxa)
c
c  Read next line
c
20              read(10,'(a)')line
c
c  Check for comment, transfer and loop if so
c
                if (line(1:1).eq.'%') then
                  call allparts(line,128)
                  go to 20
                end if
c
c  Look for terminal ' M'  
c
                if (line(1:1) .eq. 'M') then
                  ndxm = 1
                else
                  ndxm = index(line,' M')
                  if (ndxm .gt. 0) ndxm = ndxm+1
                end if
                if (ndxm .gt. 0) then
c
c  Set parameters, exit normally (but later check for leading part of 1st line
c
                  idxa = 1
                  ib = ndxm+1
                else
c
c  No "M", transfer entire line, loop
c
                  call allparts(line,128)           
                  go to 20
                end if
              end if
            end if
9           continue
            call allparts(line(idxa:ib-1),ib-idxa)
12          continue
c
c  Remove the string from line
c
            if (idxa .eq. 1) then
              line = line(ib:128)
            else
              line = line(1:idxa-1)//line(ib:128)
            end if 
            lenline = lenstr(line,128)
c
c  Loop if only blanks are left
c
            if (lenline .eq. 0) go to 4
c
c  Tack on front part from 1st line of saved macro
c
            if (lenhold .gt. 0) then
              line = holdln(1:lenhold)//' '//line(1:lenline)
              lenhold = 0
            end if
          end if
5       continue
      end if
c
c  Now a special loop to remove 'X'.  If it was %[n]X..., will have been 
c  copied into part [n] already.
c
10    continue
      nchk = 1
13    ntinx = nchk-1+ntindex(line(nchk:),'X')
      if (ntinx .gt. nchk-1) then 
c
c  There is a non-TeX 'X' in this line.  Loop if not 1st or preceded by blank.
c
        if (ntinx.gt.1) then
          if (line(ntinx-1:ntinx-1).ne.' ') then
c
c  The X is embedded in a PMX command.  Advance starting point, loop. 
c
            nchk = ntinx+1
            go to 13
          end if
        end if
c
cc  We now know the X starts a PMX command, so remove it. First, find next blank
c  We now know the X starts a PMX command.  Find next blank
c
        ib = ntinx+index(line(ntinx+1:),' ')
        if (index(':S',line(ib-1:ib-1)) .gt. 0) then
c
c  The X command is a shift, not a hardspace.  Do not remove it
c
          nchk = ib+1
          go to 13
        end if
        if (ntinx .eq. 1) then
          line = line(ib+1:128)
        else
          line = line(1:ntinx-1)//line(ib+1:128)
        end if 
c
c  Resume checking after location of removed command.
c       
        nchk = ntinx
        go to 13
      end if
c
c  Done with loop for X-checks
c
      oneof2 = ntindex(line,'//') .gt. 0
      lenline = lenstr(line,128)
      if (termrpt .and. iv.gt.nv-noinst+1 .and. frstln .and.
     *             line(lenline:lenline).eq.'/') then
c
c  Must add a terminal repeat before the slash
c
        if (oneof2) lenline = lenline-1
        write(10+iinst,'(a)')line(1:lenline-1)
        if (.not. oneof2) then
          line = 'Rr /'
          lenline = 4
        else
          line = 'Rr //'
          lenline = 5
        end if
        if (iv .eq. nv) termrpt = .false.
      end if
      write(10+iinst,'(a)')line(1:lenline)
      if (oneof2) then
        frstln = .false.
      else if (.not.frstln) then
        frstln = .true.
      end if
      if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then
        iv = 1+mod(iv,nv)
        if (iv.eq.1 .or. iv.gt.nvi(1)) iinst = 1+mod(iinst,noinst)
      end if
      go to 4
999   continue
      close(10)
      do 11 iinst = 1 , noinst
        if (nvi(iinst) .eq. 1) then
          call mbrests(iinst,jobname,ljob)
        else
c
c  Send a signal to bypass mbrest processing
c
          call mbrests(iinst,jobname,-ljob)
        end if
11    continue
      end
      function lenstr(string,n)        
      character*(*) string
      do 1 lenstr = n , 1 , -1
        if (string(lenstr:lenstr) .ne. ' ') return
1     continue
      lenstr = 0
      return
      end 
      subroutine allparts(string,n)
      character*(*) string
      common /all/ noinst
      len = lenstr(string,n)
      if (len .eq. 0) then
        len = 1
        string = ' '
      end if
      do 1 iv = 1 , noinst
        write(10+iv,'(a)')string(1:len)
1     continue
      return
      end
      subroutine mbrests(iv,jobname,ljob)
      character*128 line(10),line1
      character*80 sym
      character*12 jobname
      character*3 wbrsym(2)
      character*1 sq
      logical wbrest,alldone,rpfirst
      sq = char(92)
      alldone = .false.
      rewind(10+iv)
      open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx')
      do 1 i = 1 , 10000
13      read(10+iv,'(a)',end=999)line(1)
7       len = lenstr(line(1),128)
c
c  Pass-through if inst. #1 has >1 voice.
c
        if (ljob .lt. 0) go to 2
        if (index('TtTiTch+h-h l ',line(1)(1:2)) .gt. 0) then
c
c  Traps titles, instruments, composers, headers, lower strings.  Read 2 lines.
c
          write(20,'(a)')line(1)(1:len)
          read(10+iv,'(a)')line(1)
          len = lenstr(line(1),128)
          go to 2
        end if
        if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then
          if (line(1)(1:1) .eq. '%') then
            write(20,'(a)')line(1)(1:len)
            go to 13
          end if
          if (i .eq. 1) then
            read(line(1),'(10x,2i5)')mtrnum,mtrden
          else 
            icden = 3
            if (line(1)(2:2) .eq. 'o') then
              mtrnum = 1
            else
              mtrnum = ichar(line(1)(2:2))-48
              if (mtrnum .eq. 1) then
                icden = 4
                mtrnum = 10+ichar(line(1)(3:3))-48
              end if
            end if
            mtrden = ichar(line(1)(icden:icden))-48
          end if
          lenbeat = ifnodur(mtrden,'x')
          lenmult = 1
          if (mtrden .eq. 2) then
            lenbeat = 16
            lenmult = 2
          end if
          lenbar = lenmult*mtrnum*lenbeat
          call fwbrsym(lenbar,nwbrs,wbrsym,lwbrs)
        end if
        ip1 = 0
        line1 = line(1)
        do 3 iw = 0 , nwbrs
          if (iw .gt. 0) then
            idx = ntindex(line1,wbrsym(iw)(1:lwbrs))
          else
            idx = ntindex(line1,'rp')
          end if
          if (idx .gt. 0) then
            if (ip1. eq. 0) then
              ip1 = idx
            else
              ip1 = min(ip1,idx)
            end if
          end if
3       continue
        if (i.le.5 .or. line(1)(1:1).eq.'%' .or. line(1)(1:2).eq.sq//sq
     *       .or. ip1.eq.0) go to 2
c
c  Switch to multibar rest search mode!!!  Start forward in line(1)
c
        rpfirst = line1(ip1:ip1+1) .eq. 'rp'
        iline = 1
        nmbr = 1
        if (rpfirst) then
          lwbrsx = 2
        else
          lwbrsx = lwbrs
        end if
        ipe = ip1+lwbrsx-1
4       if (ipe .eq. len) then
c
c  Need a new line 
c
          iline = iline+1
6         read(10+iv,'(a)',end=998)line(iline)
          len = lenstr(line(iline),128)
          if (line(iline)(1:1).eq.'%' ) then
            write(20,'(a)')'% Following comment has been moved forward'
            write(20,'(a)')line(iline)(1:len)
            go to 6
          end if
          ipe = 0
          go to 4
998       continue
c
c  No more input left
c
      print*,'All done!'
          alldone = .true.
          ipe = 0
          iline = iline-1
          go to 4
        else
          if (alldone) then
            sym(1:1) = ' '
          else
c
c  ipe<len here, so it's ok to get a symbol
c
            call nextsym(line(iline),len,ipe,ipenew,sym,lsym)
          end if
c
c  Check for end of block or bar line symbol
c
          if (index('/|',sym(1:1)) .gt. 0) then
            ipe = ipenew
            go to 4
          else 
            wbrest = .false.
            if (alldone) go to 12
            do 5 iw = 1 , nwbrs
              wbrest = wbrest .or. sym(1:lsym).eq.wbrsym(iw)(1:lwbrs)
5           continue
            wbrest = wbrest .or. (sym(1:lsym).eq.'r'.and.lwbrs.eq.2) 
     *                .or. (sym(1:lsym).eq.'rd'.and.lwbrs.eq.3) 
     *                .or. (sym(1:lsym).eq.'rp') 
     *                .or. (sym(1:lsym).eq.'r' .and. rpfirst)
12          if (wbrest) then
              ipe = ipenew
              nmbr = nmbr+1
              go to 4
            else 
c
c  AHA! Failed prev. test, so last symbol was *not* mbr.
c  It must be saved, and its starting position is ipenew-lsym+1
c
              if (nmbr .gt. 1) then
c
c  Write stuff up to start of mbr
c
                if (ip1 .gt. 1) write(20,'(a)')line(1)(1:ip1-1)
c
c  Insert mbr symbol.  Always end with a slash just in case next sym must be 
c  at start of block.  May think this causes undefined octaves, but
c  probably not since it's a single voice.
c
                ndig = int(alog10(nmbr+.01))+1
      print*,'Inserting rm, iv,nmbr:',iv,nmbr
                write(20,'(a2,i'//char(48+ndig)//',a2)')'rm',nmbr,' /'
                if (alldone) go to 999
                ipc = ipenew-lsym+1
                line(1) = line(iline)(ipc:len)
              else
c
c  Write old stuff up to end of original lonesome wbr, save the rest.
c  4 cases:  (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) ,
c      alldone.
c  In 1st 2 will have gotten some other lines, so write all up to one b4 last 
c  non-comment line; then revert to normal mode on that.  In 3rd case must 
c  split line.
c
                if (alldone) then
                  write(20,'(a)')line(1)(1:len)
                  go to 999
                else if (iline .gt. 1) then
                  do 9 il = 1 , iline-1
                    len = lenstr(line(il),128)
                    write(20,'(a)')line(il)(1:len)
9                 continue
                  line(1) = line(iline)
                else
c
c  Since iline = 1 the wbr is not the last sym, so must split
c
                  write(20,'(a)')line(1)(1:ip1+lwbrsx-1)
                  line(1) = line(1)(ip1+lwbrsx+1:len)
                end if
              end if
c
c  Exit multibar mode
c
              go to 7
            end if
          end if
        end if
c2       write(20,'(a)')line(1)(1:len)
2       continue
        if (len .gt. 0) then
          write(20,'(a)')line(1)(1:len)
        else
          write(20,'(a)')' '
        end if
1     continue
999   continue
      close(10+iv)
      close(20)
      return
      end
      function ifnodur(idur,dotq)
        character*1 dotq
        if (idur .eq. 6) then
          ifnodur=1
        else if (idur .eq. 3) then
          ifnodur=2
        else if (idur .eq. 1) then
          ifnodur=4 
        else if (idur .eq. 8) then
          ifnodur=8  
        else if (idur .eq. 4) then
          ifnodur=16 
        else if (idur .eq. 2) then
          ifnodur=32
        else if (idur .eq. 0) then
          ifnodur=64
        else 
          print*,'You entered an invalid note-length value'
          stop
        end if
        if (dotq .eq. 'd') ifnodur = ifnodur*3/2
      return
      end
      subroutine fwbrsym(lenbar,nwbrs,wbrsym,lwbrs)
      character*3 wbrsym(2)
        nwbrs = 1
        lwbrs = 2
        if (lenbar .eq. 16) then
          wbrsym(1) = 'r4'
        else if (lenbar .eq. 32) then
          wbrsym(1) = 'r2'
        else if (lenbar .eq. 64) then
          wbrsym(1) = 'r0'
        else if (lenbar .eq. 8) then
          wbrsym(1) = 'r8'
        else
          nwbrs = 2
          lwbrs = 3
          if (lenbar .eq. 24) then
            wbrsym(1) = 'rd4'
            wbrsym(2) = 'r4d'
          else if (lenbar .eq. 48) then
            wbrsym(1) = 'rd2'
            wbrsym(2) = 'r2d'
          else if (lenbar .eq. 96) then
            wbrsym(1) = 'rd0'
            wbrsym(2) = 'r0d'
          else
            write(*,'(33H Any whole-bar rests of duration ,i3,
     *        26H/64 will not be recognized)') lenbar
          end if
        end if
      return
      end           
      subroutine nextsym(line,len,ipeold,ipenew,sym,lsym)
c
c  Know its the last symbol if on return ipenew = len!.  So should never 
c    be called when ipstart=len.
c
        character*128 line
        character*80 sym
        if (ipeold .ge. len) then
          print*,'Called nextsym with ipstart>=len '
          print*,'Send files to Dr. Don at dsimons@logicon.com'
          stop
        end if
        do 1 ip = ipeold+1 , len
          if (line(ip:ip) .ne. ' ') then
c
c  symbol starts here (ip).  We're committed to exit the loop.
c
            if (ip .lt. len) then
              do 2 iip = ip+1 , len
                if (line(iip:iip) .ne. ' ') go to 2
c
c  iip is the space after the symbol
c
                ipenew = iip-1
                lsym = ipenew-ip+1
                sym = line(ip:ipenew)
                return
2             continue
c
c  Have len>=2 and ends on len
c
              ipenew = len
              lsym = ipenew-ip+1
              sym = line(ip:ipenew)
              return
            else 
c
c  ip = len
c
              ipenew = len
              lsym = 1
              sym = line(ip:ip)
              return
            end if 
          end if
1       continue        
      print*,'Error #3.  Send files to Dr. Don at dsimons@logicon.com'
      end                
      function ntindex(line,s2q)
c
c  Returns index(line,s2q) if NOT in TeX string, 0 otherwise
c
      character*(*) s2q
      character*128 line
      logical intex
c
c     print*,'Starting ntindex.  s2q:',s2q,', line(1:79) is below'
c     print*,line(1:79)
c
      ndxs2 = index(line,s2q)
      ndxbs = index(line,char(92))
      if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then
        ntindex = ndxs2
c     print*,'No bs, or char is left of 1st bs, ntindex:',ntindex
      else
c
c  There are both bs and s2q, and bs is to the left of sq2. So check bs's to
c  right of first: End is '\ ', start is ' \' 
c
        len = lenstr(line,128)
        intex = .true.
c     print*,'intex+>',intex
        do 1 ic = ndxbs+1 , len
          if (ic .eq. ndxs2) then
            if (intex) then
              ntindex = 0
              ndxs2 = index(line(ic+1:len),s2q)+ic
c     print*,'ndxs2 =>',ndxs2
            else
              ntindex = ndxs2
              return
            end if
c     print*,'Internal exit, intex, ntindex:',intex,ntindex 
          else if (intex .and. line(ic+1:ic+2).eq.char(92)//' ') then
            intex = .false.
c     print*,'intex+>',intex
          else if (.not.intex .and. line(ic+1:ic+2).eq.' '//char(92)) 
     *           then
            intex = .true.
c     print*,'intex+>',intex
          end if
1       continue
c     print*,'Out end of loop 1'
      end if
c     print*,'Exiting ntindex at the end???'
      return
      end
      subroutine getchar(line,iccount,charq)
c
c  Gets the next character out of line*128.  If pointer iccount=128 on entry,
c  then reads in a new line.  Resets iccount to position of the new character.
c
      character*1 charq
      character*128 line
      if (iccount .eq. 128) then
        read(10,'(a)')line
        iccount = 0
      end if
      iccount = iccount+1
      charq = line(iccount:iccount)
      return
      end
      function readin(line,iccount)
c
c  Reads a piece of setup data from line, gets a new line from
c  file 10 (jobname.pmx) if needed, Transfers comment lines into all parts.
c 
      character*128 line
      character*1 durq
      common /comtop/ topcoms
      logical topcoms
4     if (iccount .eq. 128) then
1       read(10,'(a)')line
        if (line(1:1) .eq. '%') then
          if (.not.topcoms) then
c
c  Set flag, check it after getting all top data, then put all %'s in all parts.
c
            topcoms = .true.
c
c  Open file to store top comments
c
            open(30,status='SCRATCH')
          end if
          lenline = lenstr(line,128)
          write(30,'(a)')line(1:lenline)
          go to 1
        end if
        iccount = 0
      end if
      iccount = iccount+1
c
c  Find next non-blank or end of line
c
      do 2 iccount = iccount , 127
        if (line(iccount:iccount) .ne. ' ') go to 3
2     continue
c
c  If here, need to get a new line
c
      iccount = 128
      go to 4
3     continue
c
c  iccount now points to start of number to read
c
      i1 = iccount
5     call getchar(line,iccount,durq)
c
c  Remember that getchar first increments iccount, *then* reads a character.
c
      if (index('0123456789.-',durq) .gt. 0) go to 5
      i2 = iccount-1
      if (i2 .lt. i1) then
        print*,'Found "'//durq//'" instead of number'
        stop 1
      end if
      icf = i2-i1+49
      read(line(i1:i2),'(f'//char(icf)//'.0)')readin
      return
      end