&args cover   /* name of clean river coverage
&type ' WARNING, this needed debugging.  It can flip the mouth in the wrong direction'
&type 'or is it an ARC/INFO bug?'
/* Make all arcs point downstream
&if [show program] ne 'ARC' &then; &do
   &type This must be started from ARC
   &return &pause 'Exiting.  Try again.'
&end

/* set up for processing
&set status = [delete fro -file]
&set status = [delete too -file]
&set status = [delete mouth.sel -file]
build %cover% line
build %cover% node
indexitem %cover%.aat TNODE#  /* This will speed things up
indexitem %cover%.aat FNODE# 
&if ^ [iteminfo %cover% -arc JORDER -exists] &then
  additem %cover%.aat %cover%.aat JORDER 4 4 i
&if ^ [iteminfo %cover% -arc SHREVE -exists] &then
  additem %cover%.aat %cover%.aat SHREVE 4 4 i
&if ^ [iteminfo %cover% -arc STRAHLER -exists] &then
  additem %cover%.aat %cover%.aat STRAHLER 2 2 i
&if ^ [iteminfo %cover% -arc TLENGTH  -exists] &then
  additem %cover%.aat %cover%.aat TLENGTH 4    12     F      3

/* calculate total length and order from mouth
ARCEDIT 
ec %cover%
ef node
&if ^ [iteminfo %cover% -NODE flag -exists] &then
  ADDITEM flag 2 2 c
ef arc
sel all  /* if you are not sure of unique IDs
calc %cover%-id = %cover%#
calc JORDER = 0
save
sel dangle 
&type 'select the mouth arc[s]'
/* resel  %cover%# eq 1  /* or any other method of selection
display 9999;drawe arc;draw;sds 2;sel many;display 0 /* or any other method of selection
calc JORDER = 1  /* we have river outlets
calc tlength = LENGTH
&s order 1  /* here we number the arcs from the outlet
&label beowulf 
  sel JORDER = %order%
  &s num  [show number select]
  &if %num% eq 0 &then; &goto done
  &s i = 1
  &label startloop1
    &s id%i% = [show  arc [show select %i%] item %cover%-id]
    &s length%i% = [show arc [show select %i%] item tlength]
    &s i = [calc %i% + 1]
  &if %i% le %num% &then; &goto startloop1
  &set order = [calc %order% + 1]
  &ty working on stream order %order% %length1%
  &s i = 1
  &label startloop2
    sel %cover%-id eq [value id%i%]
    sel connect
    resel JORDER = 0
    &if [show number select] > 0 &then ; &do
       calc JORDER = %order%
       calc tlength = [value length%i%] + LENGTH
    &end
    &s i = [calc %i% + 1]
  &if %i% le %num% &then; &goto startloop2
&goto beowulf
&label done
&set order = [calc %order% - 1]
&type The highest order is %order%   /* 32
QUIT
y
y
build %cover% arc
build %cover% node
relate add
arcnod
%cover%.nat
info
FNODE#
%cover%#
linear
rw
nodarc
%cover%.aat
info
ARC#
%cover%#
linear
ro
[unquote '']

/* make sure that the first segment is pointing right
ARCEDIT
ec %cover%
ef arc
sel JORDER eq 1
selectput node
ef node
resel nodarc//TNODE# = %cover%#
moveitem 'M' flag
ef arc
sel JORDER eq 1
&s num [show number select]
&s i = 1
&label startloop3
    &s id%i% = [show arc [show select %i%] item %cover%-id]
    &s fnode%i% = [show arc [show select %i%] item FNODE#]
  &s i = [calc %i% + 1]
&if %i% le %num% &then; &goto startloop3
&s i = 1
&label startloop4
    sel connect
  &if [show arc [show select 1] item FNODE#] ne [value fnode%i%] and ~
      [show arc [show select 1] item TNODE#] eq [value fnode%i%] &then
    &set id%i% = [value id%i%] * -1
  &s i = [calc %i% + 1]
&if %i% le %num% &then; &goto startloop4
&ty I is %i%  /* diag
&s i = 1
&label startloop5
  &if [value id%i%] lt 0  &then; &do
    &set id = [value id%i%] * -1
    sel %cover%-id eq %id%
     flip
  &end
  &s i = [calc %i% + 1]
&if %i% le %num% &then; &goto startloop5
save
Q

ARCPLOT  /* here we make all the arcs face the right way
mapex %cover% /* else it will not trace
clearselect
resel %cover% node flag = 'M'
writeselect mouth.sel
clearselect
TRACE DIRECTION %cover% fro too mouth.sel
/* if cycles are found, copy the coverage to uff, build uff poly,
/* polygonlines uff 2; &r extex, and edit
readselect fro
calc %cover% line SHREVE = -1
quit /* to arc

ARCEDIT
ec %cover%
ef arc
sel SHREVE = -1
&if [show number select] > 0 &then ;flip
save  /* arcs are pointing the right way, so now we can find sources
sel dangle
resel JORDER ne 1
moveitem 'S' arcnod//flag  /* this is flaky, try again
calc SHREVE = 11
save
ef node
sel nodarc//SHREVE = 11
resel nodarc//FNODE# = %cover%#
moveitem 'S' flag
save
QUIT