/*rexx: */ Address "ISREDIT";"MACRO (SORTF,SORTX,FLOW,COLL,SORT)"
/*  TITLE:       Reformat and SORT names
   Users:       SCRIPT users  or ISPF EDIT users
   Entry:       Used as an EDIT CLIST within ISPF EDIT  ===> SORTCR
   Contributed: 1985/11/25 David McRitchie -- "The REXX Macros Toolbox"
   Converted line by line from clist 1993/05/26 to REXX, some
      function with label may have been lost.
   Options:  FLOW option default is 70  e.g.  ===> SORTCR 70
   Options:  length options  default 10 e.g.  ===> SORTCR 70 10
   Requirements:
    defined area must begin with at least one blank, each line
        within area must begin the same number of blanks as the
        first line of the area.
    .SORTF    label required at beginning of a contiguous  word list
        section

    .SORTX    label immediately after end of the contiguous word
        list section.  If label not supplied it will be created
        based on a later line with data at an earlier starting column

   The reason that .SORTX must be below the last line is to be able
   to identify when there is only one line to be processed -- a
   possible alternative might have been to pass names of the line
   labels when invoking this edit macro, but I think the method used
   is better than the alternative.  The CC-range would have worked
   but cannot be redone.

   Internally:
    .SORTV    Temporary label used, will be created/removed
   Potential Problems:
     Assuming ASCII data does not contain "|", nor x'f0' through
     x'F9' because am using these characters for some transformations.
  *******************************************************************/
   /*trace intermediate*/
   "LINE_BEFORE .ZF  = NOTELINE """TIME('N') ,
      " ===> SORTCR" sortf sortx flow coll sort""""
   D = substr(SORTF,1,1)||substr(SORTX,1,1)
   IF D \= '..' then do
      sort = flow;coll=sortx;flow=sortf;
      SORTF = '.SORTF'
      SORTX = '.SORTX'
   END
   else do
      "label" sortf "= .sortf 0"
      "label" sortx "= .sortx 0"
      sortf = '.sortf'
      sortx = '.sortx'
   end
   "(SORTFNO) = LINENUM" SORTF
   IF rc > 0 THEN DO
      zedsmsg =  SORTF "MISSING"
      zedlmsg = "A" SORTF "label to designate first involved line",
                "is(/was) not in the file"
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      "LABEL .ZFIRST = .SORTF"    /* modified on pc-side*/
      "find P'^' 1"
      exit 12     /* could comment this out if testing */
   END
   "(SORTXNO) = LINENUM" SORTX
   IF rc > 0 THEN DO
      zedsmsg = SORTX "missing"
      zedlmsg = "A  .SORTX  label (at the line after the last" ,
                "'.du add ' line) is not in the file"
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
        EXIT 12
     "find first .sortf .sortf p' ^'"  /* modified on pc-side */
     "(rowz,colz) = cursor"
     "find next 1" colz "p'^'"
     if rc = 0 then "label .zcsr = .sortx 0"
     else exit 12
   END
   IF FLOW  = '' THEN FLOW = 70
   ELSE IF datatype(FLOW) \= "NUM" then do
      zedsmsg = "Bad Parameter"
      zedlmsg = FLOW "is an unknown parameter.  Use a column number."
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   IF COLL \= '' then
   IF datatype(COLL) \= NUM THEN DO
      zedsmsg = "Bad Parameter"
      zedlmsg = COLL "2ND PARAMETER IS INVALID LENGTH"
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   "(LBOUND,RBOUND) = BOUNDS"
   "(DWIDTH) = DATA_WIDTH"
   IF FLOW = '' then nop
   ELSE IF FLOW < 8  THEN DO
      zedsmsg = "Parameter too small"
      zedlmsg = "The parameter must be at least 10."
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   IF FLOW = '' then nop
   ELSE IF flow  >  RBOUND  THEN DO
      zedsmsg = "Parameter too large"
      zedlmsg = "The parameter must be smaller than or equal to" ,
                 RBOUND", the right-bound."
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   IF  RBOUND <  DWIDTH THEN DO
      "SEEK  .SORTF .SORTL  P'^'" value(RBOUND+1) DWIDTH
      IF rc = 0 THEN DO
         zedsmsg = "Data Outside Bounds"
         zedlmsg = "Non-blank characters exist outside" ,
                    "of the edit bounds"
         /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
         exit 12
         /* Will not attempt to process, if there is data beyond the
            right bound */
      END
   END
   "(SORTXNO) = LINENUM" SORTX
   SORTLNO = SORTXNO - 2
   SORTXNO = SORTXNO + 0
   "(SORTXNO) = LINENUM" SORTX; if rc > 0 then exit
   IF value(SORTFNO) = value(SORTLNO) THEN DO
      "LINE_AFTER" SORTF "= DATALINE LINE" SORTF   /* TO EFFECT A..*/
      "(SORTXNO) = LINENUM" SORTX
   END
   "LABEL" value(SORTXNO - 1 ) "= .SORTL 0"
   /* ************ ADDED D.MCR 1985/08/03 TO END ******/
   IF value(SORTXNO) < value(SORTFNO) THEN DO
      zedsmsg = "LABEL ERR "SORTF"/X"
      zedlmsg = SORTF "must appear earlier than" SORTX
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   "SEEK" .SORTF .SORTL " 1 ';.' ALL"
   "(SEEK1,SEEK2) = SEEK_COUNTS"
   IF value(SEEK2) \= value(0) THEN DO
      zedsmsg = "One Command per line"
      zedlmsg = "CAN ONLY HANDLE '.du add       ' COMMANDS AND ",
                "THEY MUST BEGIN IN COL 1"
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END

   "SEEK  .SORTF  .SORTL P'^' FIRST"
   "(SEEK1,SEEK2) = SEEK_COUNTS"
   IF value(SEEK2) = 0 then do
      zedsmsg = "No Data Found"
      zedlmsg =  ".SORTF .SORTL area appears to be blank"
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   "(CUR1,COLB) = CURSOR"
   COLBM1      = value(COLB - 1)
   "SEEK .SORTF  .SORTL P'^' 1" COLBM1
   "(SEEK1,SEEK2) = SEEK_COUNTS"
   IF value(SEEK2) \= value(0) THEN DO
      if colbm1 = 0 then colbm1 = 1 /* make message look okay*/
      zedsmsg = "NON-BLANK" COLBM1
      zedlmsg = sortf "thru .SORTL NOT CLEAR IN COLUMNS 1-"colbm1
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   "SEEK .SORTF  .SORTL  ' '" COLB
   if rc = 0 then do
      zedsmsg = "uneven" colb
      zedlmsg = SORTF .SORTL "All Data in range must",
         "begin at column" colb
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   /********** ALL VERIFICATION HAS BEEN COMPLETED ABOVE
               -- NOW SETTING UP TO CHANGE DATA*/
   "(sortvn) = linenum .sortx"
   "line_before .sortx = dataline "".*v"""
   "label" sortvn " = .sortv 0"
   "find first p'^' .sortf .sortf"
   "(row,col) = cursor"
   col = col + 1
   "TFLOW .sortf" col
   "label" sortfno "= .sortf 0"
   /********** START SPLITTING UP LINES FROM THE FIRST WORD*/
   /* letters precede numbers in EBCDIC on MVS -- ASCII is opposite*/
   "(SORTXNO) = LINENUM" SORTX; if rc > 0 then exit
   if x2c('41') = "A" then do;  /* Make ascii look like EBCDIC */
    /* attempt to make sort look more ebcdic like */
     "change all x'30' x'f0' .sortf .sortv"
     "change all x'31' x'f1' .sortf .sortv"
     "change all x'32' x'f2' .sortf .sortv"
     "change all x'33' x'f3' .sortf .sortv"
     "change all x'34' x'f4' .sortf .sortv"
     "change all x'35' x'f5' .sortf .sortv"
     "change all x'36' x'f6' .sortf .sortv"
     "change all x'37' x'f7' .sortf .sortv"
     "change all x'38' x'f8' .sortf .sortv"
     "change all x'39' x'f9' .sortf .sortv"
   end
   "(SORTXNO) = LINENUM" SORTX; if rc > 0 then exit
   "SORT" SORTF ".sortv" sort
   "SORT .sortf .sortv" /*sort */
   "(SORTXNO) = LINENUM" SORTX; if rc > 0 then exit
   if x2c('41') = "A" then do;  /* Put Numbers back to ASCII */
    /* restore normal ascii chars */
    "change all x'f0' x'30' .sortf .sortv"
    "change all x'f1' x'31' .sortf .sortv"
    "change all x'f2' x'32' .sortf .sortv"
    "change all x'f3' x'33' .sortf .sortv"
    "change all x'f4' x'34' .sortf .sortv"
    "change all x'f5' x'35' .sortf .sortv"
    "change all x'f6' x'36' .sortf .sortv"
    "change all x'f7' x'37' .sortf .sortv"
    "change all x'f8' x'38' .sortf .sortv"
    "change all x'f9' x'39' .sortf .sortv"
   end

   /* *********** remove any duplicates *****************/
   /* *********** MAY RESULT IN LOSS OF .SORTL AND OTHER LINES*/
   "(SORTXNO) = LINENUM" SORTX; if rc > 0 then exit
   "LOC" SORTF
   /* *********** remove any duplicates *****************/
   /* sortf to .sortv  (sortv itself never a duplicate) */
   "(sortfno) = linenum .sortf"
   "(sortxno) = linenum .sortx"
   prevline = " "
   sortvv = sortxno - 2
   l=0; if coll \="" then l=coll
   do i = sortvv to sortfno by -1
      /* could make line = substr(line,1,50)translate(line,1,20)) */
      /* and sort 51 70 1 50 */
      "(savlab,savlev) = label" i
      "(line) = line" i
      if savlab \= "" then
         "label" i "=" savlab savlev
      line=strip(line,'T')
      if line = prevline then "delete" i+1
      else prevline = line
      ll=length(line)
      if ll > l then l = ll
   end
   "label" sortfno "= .sortf 0"
   /* use requested length (coll) if > required length (collx) */
   if coll \= "" then do
      collx = l - colbm1
      if coll < collx then do
         zedsmsg = coll "too small"
         zedlmsg = zedsmsg", using entity width of" collx
         /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      end
      if coll > collx  then l = coll + colbm1
   end
   else coll = l - col + 1

   "change all .sortf .sortv  ' ' '|'" colb l
   /*"delete .sortv .sortv all" */
   /* ***************************************************/
   /* BELOW COULD BE ADDED TO SORTCR                   **/
   /*    MAKE ALL ROWnoS THE SAME                      **/
   "(SORTFNO) = LINENUM" SORTF
   "(SORTXNO) = LINENUM" SORTX
   SORTLNO = SORTXNO - 2
   "LABEL" SORTLNO "= .SORTL 0"  /* FIXUP */
   IDIFF = SORTLNO + 1 - SORTFNO
   "LOC" SORTF
   "FIND P'^' .SORTF .SORTF FIRST"
   "(RRR,CCC) = CURSOR"
   if coll \= '' then do
      protect = ccc + coll - 1;
      "CHANGE ALL .SORTF .SORTL" ccc protect "' ' '|'"
      /* guarantee minimum size, could still be larger*/
   end
   hightst = colb + 1
   cole = colb
   do forever;
      if hightst > rbound then leave
      "SEEK" ".SORTF .SORTL first p'^'"  hightst rbound
      if rc \=0 then leave
      "(rowx,colx) = cursor"
      cole = colx
      hightst = colx + 1
   END
   /*"change all .sortf .sortv" colb cole "' ' '|'"*/
     "change all .sortf .sortv" colb cole "'|' ' '"
   "DELETE .sortv .sortv"
   cole = cole + 1    /* include blank after last character found*/
   if coll = '' then do
       coll = cole - colb  /*coll does not include sep. space*/
   end
   else do
       if   value(cole - colb) \=  value(coll)
         then say value(cole - colb )   value(coll)
       if value(cole - colb) >  value(coll) then do
          collx = coll                /* as specified*/
          coll = cole - colb          /* as s/b specified*/
          "line_before .ZF = Noteline ""SORTCR forced column",
             "length of" collx", has been changed to the default"""
          "line_before .ZF = Noteline",
             """       i.e. -- SORTCR" flow coll""""
       end
   end
   /* ************ calculate number of columns **********************/
   collp1 = collp1
   "(T2) = LINENUM" SORTF
   "(T3) = LINENUM" SORTX

   T4 = COLL + 1             /* longest column length + 1 space*/
   T5 = flow - colb + 2      /* does need extra space at end*/
   COLno = trunc(T5 / T4)    /* NUMBER OF COLUMNS PER LINE */

   T10 = T3  - T2            /* NUMBER OF LINES INVOLVED */
   T11 = T10 + COLno - 1
   ROWno = trunc(T11 / COLno)    /* NUMBER OF ROWnoS REQUIRED */
   T6  = trunc((t10 + ROWno - 1) / ROWno)  /* columns seen*/
   /* -- Place single column into parallel columns.  The number of
         Rows and Columns has bee previously calculated as has the
         length of the columns.  All of the previous could be changed
         to -->  SORTCR 70 1           *****************************/
   "(LNB) = LINENUM" SORTF
   "(LNX) = LINENUM "SORTX
   "LABEL" value(LNX - 1) "= .SORTL"
   "CHANGE .SORTF .SORTL ALL" COLB COLE "' ' '³'"
   BLANK = substr(' ',1,70)
   ROWno = ROWno + 0
   COLno = COLno + 0
   C = 0
   LNA = LNB
   LNS = LNX - LNB
   LNST = 0           /* TEST NUMBER OF LINES SHOULD = LNS AT END */
   R = 0
   DO WHILE (R < ROWno)
      R = R + 1
      LNA = LNB + R - 1
      "(RLINE)   =  LINE" LNA
      RLINE = substr(rline,1,cole)
      C = 1
      LNST =  LNST + 1
      DO WHILE ( C <  COLno)
         C =  C + 1
         LNA =  LNA + ROWno
         IF  LNA <  LNX THEN DO
            "(NLINE) = LINE" LNA
            RLINE = RLINE||substr(nline,colb,value(cole+1-colb))
            LNST = LNST + 1
         END
         ELSE RLINE = rline||substr(blank,colb,value(cole+1-colb))
      END
   RPL      = LNB + R - 1
   IF value(FLOW) <= DWIDTH THEN "LINE" RPL "=(rline)"
   ELSE "LINE" RPL "=" substr(rline,1,dwidth)
   END
   "LABEL"  value(LNX - 1) "= .SORTL 0"
   /*   signal GYP*/
   "CHANGE .SORTF .SORTL 1" value(DWIDTH) "ALL '³' ' '"
   IF  LNST \=  LNS THEN DO
   GYP:
      "LINE_AFTER" SORTX "= NOTELINE ""UNMATCHED LINES IN="LNS",",
              " ENTRIES OUT="LNST
      "LINE_AFTER" SORTX "= ",
      "NOTELINE ""COLL="COLL "FLOW="FLOW,
          " COLno="COLno "("T5"+"T4"-1)/"T4 """"
      "LINE_AFTER" SORTX "= ",
      "NOTELINE "ROWno="ROWno ("T3" - "T2" + "colno" - 1) / "colno""""
      zedsmsg = "MISSING data "
      zedlmsg = "SHOULD HAVE" LNS "ENTRIES, NOW HAVE" LNST "ENTRIES"
      /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   colb=colb+0;
   IF T6 \= COLno then do
     t21 = trunc((flow - colb -t6) / t6)
     t22 = ROWno * COLno
     if t22 \= T10  then
       "LINE_AFTER "SORTX "= ",
        "NOTELINE ""  Entries could be increased to" t22,
         "and still fit within flow limit"""
     if t21 \= COLL then
       "LINE_AFTER "SORTX "= ",
        "NOTELINE ""  Length could be extended to" t21,
         "and still fit within flow limit."""
     "LINE_AFTER "SORTX "= ",
         "NOTELINE ""  with" T10 "entries into" ROWno "rows,",
         T6 "cols out of the" COLno "will be used"""
   end
   "LINE_AFTER "SORTX "= ",
   "NOTELINE ""SORTCR processed" LNS "entries into",
          COLno "Columns X" ROWno,
         "rows, F="flow "L="coll "b="colb "e="cole""""
   "LINE_BEFORE .zf    = ",
   "NOTELINE ""SORTCR processed" LNS "entries into",
          COLno "Columns X" ROWno,
         "rows, F="flow "L="coll "b="colb "e="cole""""
   DLN1 = LNB + ROWno
   DLN2 = LNX - 1
   IF DLN1 <= DLN2 THEN ,
   "DELETE" DLN1  DLN2 "ALL"
   "LABEL" value(LNB) "= .SORTF 0"
   "LABEL" value(LNB + ROWno) "=" SORTX "0"
   "LOC" SORTF
   "UP 1"
   if value(COLno * (COLL + 1) + COLB - 2) > FLOW ,
    | value(COLno * (COLL + 1) + COLB - 2 + COLL) < FLOW then
      "LINE_AFTER .SORTX = MSGLINE ""*** Check SORTCR usage",
      value(COLno * (COLL + 1) + COLB - 2)   FLOW ,
      value(COLno * (COLL + 1) + COLB - 2 + COLL) "where l="coll "t5="t5""""
   /**********************END OF PROGRAM ***********************/
   /*"RESET CHG" -- alternates in working on spf/pc 3.07*/s
   zedsmsg = "SORTCR finished OK"
   zedlmsg = "SORTCR MACRO FINISHED OKAY --",
              "CHANGED LINES INCLUDE" SORTF "-"SORTX
   /*Address*/ "ISPEXEC" "SETMSG MSG(ISRZ000)"
   exit 0