sortmc.src

来自「没有说明」· SRC 代码 · 共 129 行

/*
** sortmc.src
** (C) Copyright 1988-1998 by Aptech Systems, Inc.
** All Rights Reserved.
**
** This Software Product is PROPRIETARY SOURCE CODE OF APTECH
** SYSTEMS, INC.    This File Header must accompany all files using
** any portion, in whole or in part, of this Source Code.   In
** addition, the right to create such files is strictly limited by
** Section 2.A. of the GAUSS Applications License Agreement
** accompanying this Software Product.
**
** If you wish to distribute any portion of the proprietary Source
** Code, in whole or in part, you must first obtain written
** permission from Aptech Systems.
**
**> sortmc
**
**  Purpose:    Sorts a matrix on multiple columns.
**
**  Format:     y = sortmc(x,v);
**
**  Input:      x    NxK matrix to be sorted.
**
**              v    Lx1 vector containing integers specifying the columns, in
**                   order, that are to be sorted.  If an element is negative
**                   that column will be interpreted as character data.
**
**  Output:     y    NxK sorted matrix.
**
**  Remarks:    The function works recursively and the number of
**              sort columns is limited by the available
**              workspace.
**
*/

proc sortmc(x,v);
    local control,k,v1,x1,mask1,vleft,i,begin,fin,bi,fi,ms,seq,rb,fb,n;

    /* check for complex input */
    if iscplx(x);
        if hasimag(x);
            errorlog "ERROR: Not implemented for complex matrices.";
            end;
        else;
            x = real(x);
        endif;
    endif;

    if iscplx(v);
        if hasimag(v);
            errorlog "ERROR: Not implemented for complex matrices.";
            end;
        else;
            v = real(v);
        endif;
    endif;

    n = rows(x);    /* number of rows in the target matrix */
    k = rows(v);    /* total number of columns to sort on */
    v1 = v[1,1];    /* first column to sort on */

    /* Step 1: Sort the matrix on the first column */

    if v1 < 0;
        v1 = abs(v1);
        x = sortcc(x,v1);
    else;
        x = sortc(x,v1);
    endif;

    /* Step 2: If necessary, sort on a 2nd column */

    if k == 1;      /* only one column to be sorted on */
        retp(x);    /* done */
    else;           /* more than one col to be sorted on */
        x1 = x[.,v1];       /* pull out the column just sorted */
        mask1 = trimr(x1,0,1).==trimr(x1,1,0);      /* find successive
                                                    :: matches
                                                    */
        if mask1 == 0;      /* no 1's */
            retp(x);        /* done -- there are no replications, so the
                            :: matrix is already sorted on the first two
                            :: columns
                            */
        elseif mask1 == 1;          /* all 1's ==> all elements in this col
                                    :: are the same
                                    */
            retp( sortmc( x, trimr(v,1,0) ) );      /* pass entire matrix to
                                                    :: second copy of SORTMC,
                                                    :: and remaining elements
                                                    :: of v
                                                    */
        else;       /* neither all unique nor all the same */
        /* compute indices of beginning and ends of "runs" of equal elements
        :: in the current column
        */
            ms = (mask1|0) - (0|mask1);     /* 1's denote begin, -1's end  */
            seq = seqa(1,1,n);
            control = ndpcntrl(0,0);
            call ndpcntrl(1,1);
            begin = packr( seq + (miss(ms ./= 1,1) ) );     /* starting
                                                            :: indices
                                                            */
            fin = packr( seq + (miss(ms ./= -1,1) ) );      /* ending indices */
            ndpclex;        /* missings were used above */
            call ndpcntrl(control,0xffff);
            rb = rows(begin);
            fb = rows(fin);
            if ismiss(begin) or ismiss(fin) or (fb /= rb);
                errorlog "ERROR: Internal error in SORTMC";
                end;
            endif;

            vleft = trimr(v,1,0);           /* remaining columns to sort on */
            i = 1;
            do until i > fb;
                bi = begin[i,1];    /* beginning index of submatrix to be
                                    :: sorted
                                    */
                fi = fin[i,1];      /* ending index of submatrix to be sorted */
                x[bi:fi,.] = sortmc( x[bi:fi,.], vleft );
                i = i + 1;
            endo;
            retp(x);
        endif;
    endif;
endp;