/*rexx: */ Address "ISREDIT";"MACRO (SORTF,SORTX,FLOW,COLL,SORT)"
/*  TITLE:      SORTCR --  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.
  *******************************************************************/
   /*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;
      SORTX = '.SORTX'
      SORTF = '.SORTF'
   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 (at the first '.du add ' line)" ,
                "is 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
   "(SORTXNO) = LINENUM" SORTX
   SORTLNO = SORTXNO - 1
   SORTXNO = SORTXNO + 0
   IF value(SORTFNO) = value(SORTLNO) THEN DO
      "LINE_AFTER" SORTF "= DATALINE LINE" SORTF   /* TO EFFECT A..*/
      "LINE_AFTER" SORTF "= DATALINE LINE" SORTF   /* TO EFFECT A..*/
      "LINE_AFTER" SORTF "= DATALINE LINE" SORTF   /* TO EFFECT A..*/
      "(SORTXNO) = LINENUM" SORTX
   END
   "LABEL" value(SORTXNO - 1 ) "= .SORTL 0"
   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
   /* ************ 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
      zedsmsg = "NON-BLANK" COLBM1
      zedlmsg = SORTF .SORTL "NOT CLEAR IN COLUMNS 1" colbm1
      Address "ISPEXEC" "SETMSG MSG(ISRZ000)"
      exit 12
   END
   /********** ALL VERIFICATION HAS BEEN COMPLETED ABOVE
               -- NOW SETTING UP TO CHANGE DATA*/
   "(SORTFNO) = LINENUM" SORTF
   "LINE_AFTER .SORTL = DATALINE LINE" .SORTL
   "(SORTXNO) = LINENUM" SORTX
   "LABEL" value(SORTXNO  - 1)" = .sortv 0"
   "LABEL" SORTFNO " = .SORTF  0"
      /*PROVIDED IN CASE SORTX was entered one line after SORTF */
   "(sortvNO) = LINENUM .sortv"
      /*RECALCULATED BECAUSE IT HAS MOVED ONE LINE DOWN*/
   /********** START SPLITTING UP LINES FROM THE FIRST WORD*/
   " CURSOR =" SORTFNO "0"
   " (sortvNO) = LINENUM .sortv"


   "TFLOW .SORTF" value(colb + 1)  /* first nonblank on .sortf + 1*/
   /* now have a single column to be sorted, reworked */

   "(SORTXNO) = LINENUM "SORTX
   "LABEL" value(SORTXNO - 1) "= .sortv 0"
   "LABEL" value(SORTXNO - 2) "= .SORTL 0"
   "DELETE .sortv .sortv"
   "LINE_BEFORE" SORTX " = dataline '.* sortv -- STOPS FLOW'"
   "LABEL" value(SORTXNO - 2) "= .SORTL 0"
   "LABEL" value(SORTXNO - 1) "= .sortv 0"
      /* could make a do group to sort upper/lowercase same*/
      /* could make line = substr(line,1,50)translate(line,1,20)) */
      /* and then   SORT .sortf .sortv 51 70 1 50 */

   /* letters precede numbers in EBCDIC on MVS -- ASCII is opposite*/
   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
   "SORT" SORTF ".sortv" sort
   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*/
   "LOC" SORTF
   /* *********** remove any duplicates *****************/
   /* sortf to .sortv  (sortv itself never a duplicate) */
   "(sortfn) = linenum .sortf"
   "(sortvn) = linenum .sortx"
   prevline = " "
   l=0
   sortvv = sortvn - 2
   do i = sortvv to sortfn by -1
      /* could make line = substr(line,1,50)translate(line,1,20)) */
      /* and sort 51 70 1 50 */
      "(line) = line" i
      line=strip(line,'T')
      if line = prevline then "delete" i+1
      else prevline = line
      ll=length(line)
      if ll > l then l = ll
   end
   /* 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 - colbm1

   "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"
   "(,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"
   "RESET CHG    .SORTF .SORTF"
   "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 ***********************/
   zedsmsg = "SORTCR finished OK"
   zedlmsg = "SORTCR MACRO FINISHED OKAY --",
              "CHANGED LINES INCLUDE" SORTF "-"SORTX
   Address "ISPEXEC" "SETMSG MSG(ISRZ000)"
   exit 0