sortd.src

来自「没有说明」· SRC 代码 · 共 748 行 · 第 1/2 页

/*
** sortd.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.
**
**  Format                                                        Line
** =========================================================================
** INTRLEAV(infile1,infile2,outfile,keyvar,keytyp);                25
** MERGEBY(infile1,infile2,outfile,keytyp);                       337
** SORTD(infile,outfile,keyvar,keytyp);                           567
*/

/*
**> intrleav
**
**  Purpose:    To interleave the rows of two files that have been
**              sorted on a common variable, to give a single
**              file sorted on that variable.
**
**  Format:     intrleav(infile1,infile2,outfile,keyvar,keytyp);
**
**  Inputs:     infile1    string, name of input file 1.
**
**              infile2    string, name of input file 2.
**
**              outfile    string, name of output file.
**
**              keyvar     string, name of key variable, this is the column
**                         the files are sorted on.
**
**              keytyp     scalar, data type of key variable.
**
**                          1   numeric key, ascending order
**                          2   character key, ascending order
**                         -1   numeric key, descending order
**                         -2   character key, descending order
**
**  Remarks:    The two files MUST have exactly the same
**              variables, that is, the same number of columns
**              AND the same variable names. They must both
**              already be sorted on the key column. This
**              procedure will combine them into one large file,
**              sorted by the key variable.
**
**              If the inputs are null ("" or 0) the procedure
**              will ask for them.
**
**  Globals:    None
*/

proc 0 = intrleav(infile1,infile2,outfile,keyvar,keytyp);
    local ord,fstate,f1,f2,fout,inx,ws,b1,b2,varnames,nr;

    clear f1,f2,fout;

get1:

    if infile1 $== "";
        Print "Name of input file 1: ";;
        infile1 = cons;
        print;
    endif;
get2:

    if infile2 $== "";
        Print "Name of input file 2: ";;
        infile2 = cons;
        print;
    endif;

    if outfile $== "";
        Print "Name of output file: ";;
        outfile = cons;
        print;
    endif;

    open f1 = ^infile1;
    if f1==-1;
        print "Input file 1: " infile1 " not found";
        infile1 = "";
        goto get1;
    endif;
    if iscplxf(f1);
        errorlog "ERROR: Not implemented for complex data sets.";
        end;
    endif;

    open f2 = ^infile2;
    if f2==-1;
        print "Input file 2: " infile2 " not found";
        infile2 = "";
        goto get2;
    endif;
    if iscplxf(f2);
        errorlog "ERROR: Not implemented for complex data sets.";
        end;
    endif;

    varnames = getname(infile1);

    if indcv(varnames,getname(infile2)) /= seqa(1,1,rows(varnames));
        errorlog "Variables in each input file must be identical";
        goto errout;
    endif;

    if keyvar $/= "";
        goto havit;
    endif;

    format 8,8;
retry1:

    print "Variables are:";
    print $varnames';
    print "Name of key variable: ";;
    keyvar = cons;
    print;
havit:

    inx = indcv(keyvar,varnames);
    if scalmiss(inx);
        print "Variable " keyvar " not found";
        goto retry1;
    endif;

    if not keytyp;
        print "Sort order:";
        print "     1   numeric key, ascending order";
        print "     2   character key, ascending order";
        print "    -1   numeric key, descending order";
        print "    -2   character key, descending order";
        print;
        print "   ? ";;
        keytyp = stof(cons);
    print;
    endif;
    if keytyp < 0;
        ord = 0;
        keytyp = -keytyp;
    else;
        ord = 1;
    endif;

    create fout = ^outfile with ^varnames,0,typef(f1);
    if keytyp==2 and (typef(f1) /= 8 or typef(f2) /= 8);
        errorlog "WARNING - Sort is character type, data set not double preci"\
            "sion.";
    endif;
    if fout==-1;
        errorlog "Can't open output file: " $+ outfile;
        goto errout;
    endif;

    nr = 3000/colsf(f1);    /* !!! Number of rows to read in finish loop  */

    b1 = readr(f1,1);
    b2 = readr(f2,1);

    ws = 1;         /* is set to 1 by program if write is successful  */

    if keytyp==2;
        gosub chartyp;
    else;
        gosub numtyp;
    endif;
    if fstate==1;
        goto finish1;
    elseif fstate==2;
        goto finish2;
    else;
        goto diskfull;
    endif;

finish1:

    ws = writer(fout,b1);
    do while ws;
        if eof(f1);
            goto out;
        endif;
        b1 = readr(f1,nr);
        ws = writer(fout,b1)==rows(b1);
    endo;
    goto diskfull;

finish2:

    ws = writer(fout,b2);
    do while ws;
        if eof(f2);
            goto out;
        endif;
        b2 = readr(f2,nr);
        ws = writer(fout,b2)==rows(b2);
    endo;

diskfull:

    errorlog "\nDisk Full - Output file incomplete";
    goto errout;

out:

    call close(f1);
    call close(f2);
    call close(fout);
    retp;
errout:

    call close(f1);
    call close(f2);
    call close(fout);
    end;
/* ======================================================================== */
/* -------------------------- Subroutines Follow -------------------------- */
/* ======================================================================== */

/* =============================== */
/* ====== Numeric Key Sort ======= */
/* =============================== */

numtyp:

    /* ============== code for ascending order ================== */
    if ord==1;
        do while ws;        /* do while write successful */
            if b1[1,inx] < b2[1,inx];
                ws = writer(fout,b1);
                if eof(f1);
                    fstate = 2;
                    return;
                endif;
                b1 = readr(f1,1);
            else;
                ws = writer(fout,b2);
                if eof(f2);
                    fstate = 1;
                    return;
                endif;
                b2 = readr(f2,1);
            endif;
        endo;
        fstate = -1;

    /* ============ code for descending order ============= */
    else;

        do while ws;        /* do while write successful */
            if b1[1,inx] > b2[1,inx];
                ws = writer(fout,b1);
                if eof(f1);
                    fstate = 2;
                    return;
                endif;
                b1 = readr(f1,1);
            else;
                ws = writer(fout,b2);
                if eof(f2);
                    fstate = 1;
                    return;
                endif;
                b2 = readr(f2,1);
            endif;
        endo;
        fstate = -1;
    endif;

    return;

/* =============================== */
/* ===== Character Key Sort ====== */
/* =============================== */

chartyp:

    /* =========== code for ascending order =============== */
    if ord==1;
        do while ws;        /* do while write successful */
            if b1[1,inx] $< b2[1,inx];
                ws = writer(fout,b1);
                if eof(f1);
                    fstate = 2;
                    return;
                endif;
                b1 = readr(f1,1);
            else;
                ws = writer(fout,b2);
                if eof(f2);
                    fstate = 1;
                    return;
                endif;
                b2 = readr(f2,1);
            endif;
        endo;
        fstate = -1;

    /* ============ code for descending order ============= */
    else;

        do while ws;        /* do while write successful */
            if b1[1,inx] $> b2[1,inx];
                ws = writer(fout,b1);
                if eof(f1);
                    fstate = 2;
                    return;
                endif;
                b1 = readr(f1,1);
            else;
                ws = writer(fout,b2);
                if eof(f2);
                    fstate = 1;
                    return;
                endif;
                b2 = readr(f2,1);
            endif;
        endo;
        fstate = -1;
    endif;

    return;
/* ====================== End of Subroutines ==================== */

endp;

/*
**> mergeby
**
**  Purpose:    To merge two sorted files by a common variable.
**
**  Format:     mergeby(infile1,infile2,outfile,keytyp);
**
**  Inputs:     infile1    string, name of input file 1.
**
**              infile2    string, name of input file 2.
**
**              outfile    string, name of output file.
**
**              keytyp     scalar, data type of key variable.
**
**                          1 - numeric
**                          2 - character
**
**  Remarks:    This will combine the variables in the two files
**              to create a single large file.  The following
**              assumptions hold:
**
**                   1. Both files have a single (key) variable in
**                      common and it is the first variable.
**
**                   2. All of the values of the key variable are unique.
**
**                   3. Each file is already sorted on the key variable.
**
**              The output file will contain the key variable in
**              its first column.
**
**              It is not necessary for the two files to have the
**              same number of rows. For each row for which the
**              key variables match, a row will be created in the
**              output file. OUTFILE will contain the columns
**              from INFILE1 followed by the columns of INFILE2
**              minus the key column from the second file.
**