medit.src

没有说明

        core = floor((coreleft - leavfree) / _MED_ESZ);    /* .a16 and .a32 */
        if ( _med_1(_miss,TC~BC,r,c,0)
             + _med_1(_miss,TC~BC,3,c,0) ) GT core;
            /* allow for fmt etc */
            msg = "Not enough memory. Previous scrap buffer cleared.";
            goto re_call;
        endif;
        rc_buf = x[.,TC:BC];
        fmt_buf = fmt[TC:BC,.];
        v_buf = v[.,TC:BC];
        maxv_buf = max_vals[.,TC:BC];
        rc_cut = 2;         /* have cols in buffer */
        core = floor((coreleft - leavfree) / _MED_ESZ);     /* .a16 and .a32 */
        gosub CUT_COLS;
        if strlen(msg) /= 0;
            msg = "Not enough memory. Previous scrap buffer cleared.";
            clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;
            goto re_call;
        endif;

    elseif (request $== 6); /* copy cols memory used increased */
        /* copy all rows */
        clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;  /* free memory */
        core = floor((coreleft - leavfree) / _MED_ESZ);    /* .a16 and .a32 */
        /* test if enough memory to store result */
        if ( (BC-TC+1)*(r+1+3+1) + GXE_SIZE + _MED_PAD ) GT core;
            /* matrix + v_buf + fmt_buf + maxv_buf */
            msg = "Not enough memory. Previous scrap buffer cleared.";
            goto re_call;
        endif;
        if ( _med_1(_miss,TC~BC,r,c,0)
             + _med_1(_miss,TC~BC,3,c,0) ) GT core;
            /* allow for fmt etc */
            msg = "Not enough memory. Previous scrap buffer cleared.";
            goto re_call;
        endif;
        rc_buf = x[.,TC:BC];
        fmt_buf = fmt[TC:BC,.];
        v_buf = v[.,TC:BC];
        maxv_buf = max_vals[.,TC:BC];
        rc_cut = 2;         /* have cols in buffer */

    elseif (request $== 7);
        /* insert new row */
        if ((r+1) * c) GT MAX_SIZE;
            msg = "Resulting matrix too large";
            goto re_call;
        endif;
        /* add one row */
        if  ((c + GXE_SIZE + _MED_PAD) GT core) or
            (((r+1)*c + 4*c - bufc*bufr + _MED_PAD) GT core) ;
            /* allow for returns */
            msg = "Not enough memory";
            goto re_call;
        endif;
        if(CR LE 1);       /* put new row at top */
            if ( (2*1*c) + _med_1(_miss,_miss,r,c,0) ) GT core;
                msg = "Not enough memory";
                goto re_call;
            endif;
            x = reshape(fill_val[1],1,c) | x;
        else;
            if (_med_1(1~(CR-1),_miss,r,c,0) + 2*1*c + _med_1(CR~r,_miss,r,c,0))
                    GT core;
                msg = "Not enough memory";
                goto re_call;
            endif;
            x = x[1:CR-1,.] | reshape(fill_val[1],1,c) |
                x[CR:r,.];
        endif;
        #ifcplx /* COMPLEX version */
           if not(imag(fill_val[1]) $== 0);  /* added complex part */
              izero = 0;  /* x now complex */
           endif;
        #endif
        /* do not change max_vals these are updated by medit.gxe */

    elseif (request $== 8);
        /* insert new col */
        if ( (r * (c + 1)) GT MAX_SIZE );           /* matrix */
            msg = "Resulting matrix too large";
            goto re_call;
        endif;
        if ( ((c+1)*3) GT MAX_SIZE );       /* format */
            msg = "Resulting format matrix too large";
            goto re_call;
        endif;
        /* add one col */
        if (( (r+1+3+1) + GXE_SIZE + _MED_PAD) GT core) or
            ((r*(c+1) + 4*(c+1) - bufc*bufr + _MED_PAD) GT core);
            /* allow for returns */
            /* matrix + v_buf + fmt_buf + maxv_buf */
            msg = "Not enough memory";
            goto re_call;
        endif;
        if(CC LE 1);       /* put new col on left */
            if ( _med_1(_miss,_miss,r,c,0) + 2*r*1
                + (_med_1(_miss,_miss,3,c,0) + 2*3*1) )
                  GT core;     /* allow for fmt */
                msg = "Not enough memory";
                goto re_call;
            endif;
            x = reshape(fill_val[1],r,1) ~ x;
            if (fill_val[2] $== 0);         /* character column */
                fmt = m_c_fmt | fmt;
            else;
                fmt = m_n_fmt | fmt;
            endif;
            v = fill_val[2] ~ v;
            max_vals = m_col_v ~ max_vals;
        else;
            /* check memory for x and fmt */
            if (_med_1(_miss,1~(CC-1),r,c,0) + 2*r*1 +
                _med_1(_miss,CC~c,r,c,0) +
                ( _med_1(_miss,1~(CC-1),3,c,0) + 2*3*1 +
                    _med_1(_miss,CC~c,3,c,0)) )
                    GT core;
                msg = "Not enough memory";
                goto re_call;
            endif;
            x = x[.,1:CC-1] ~ reshape(fill_val[1],r,1) ~ x[.,CC:c];
            if (fill_val[2] $== 0);         /* character column */
                fmt = fmt[1:(CC-1),.] | m_c_fmt | fmt[CC:c,.];
            else;
                fmt = fmt[1:(CC-1),.] | m_n_fmt | fmt[CC:c,.];
            endif;
            v = v[.,1:(CC-1)] ~ fill_val[2] ~ v[.,CC:c];
            max_vals = max_vals[.,1:(CC-1)] ~ m_col_v ~ max_vals[.,CC:c];
        endif;
        #ifcplx /* COMPLEX version */
           if not(imag(fill_val[1]) $== 0);  /* added complex part */
              izero = 0;  /* x now complex */
           endif;
        #endif

    elseif (request $== 9);
        /* insert from scrap */
        if(rc_cut EQ 0);
            msg = "Scrap buffer empty";
            goto re_call;
        endif;
        if(rc_cut EQ 1);    /* insert rows in front of cursor */
            if bufc NE cols(x);
                msg = "Cannot insert row block.  Column dimensions differ.";
                goto re_call;
            endif;
            if  ((r+bufr) * c) GT MAX_SIZE;
                msg = "Resulting matrix too large";
                goto re_call;
            endif;
            if ((bufr * c + GXE_SIZE + _MED_PAD) GT core) or
               ( ((r+bufr)*c + 4*c - bufc*bufr + _MED_PAD) GT core);
                 /* allow for returns */
                msg = "Not enough memory";
                goto re_call;
            endif;
            if(CR LE 1);           /* put scrap at top */
                if (2*bufr*c + _med_1(_miss,_miss,r,c,0)) GT core;
                    msg = "Not enough memory";
                    goto re_call;
                endif;
                x = rc_buf | x;
            else;
                if (_med_1(1~(CR-1),_miss,r,c,0) + 2*bufr*c
                    + _med_1(CR~r,_miss,r,c,0) ) GT core;
                    msg = "Not enough memory";
                    goto re_call;
                endif;
                x = x[1:(CR-1),.] | rc_buf | x[CR:r,.];
            endif;
        /* this section of code reduces the work in medit.gxe */
        /* required to update the maximun number in column for "lf" formats */
            rc_blk[1,1] = CR;             /* new block starts at cursor  */
            rc_blk[2,1] = CR + bufr-1;    /* end of block */
            request = 10;           /* inserted row block */

        else;       /* (rc_cut EQ 2); insert cols in front of cursor  */
            if(bufr NE r);
                msg = "Cannot insert column block.  Row dimensions differ.";
                goto re_call;
            endif;
            if ( (r * (c+bufc)) GT MAX_SIZE);
                msg = "Resulting matrix too large";
                goto re_call;
            endif;
            if ( ((c+bufc) * 3) GT MAX_SIZE);
                msg = "Resulting format matrix too large";
                goto re_call;
            endif;
            if (( bufc*(r+1+3+1) + GXE_SIZE + _MED_PAD) GT core) or
                ((r*(c+bufc) + 4*(c+bufc) - bufc*bufr + _MED_PAD) GT core);
                /* matrix + v_buf + fmt_buf + maxv_buf */
                msg = "Not enough memory";
                goto re_call;
            endif;
            if(CC LE 1);           /* put scrap at left */
                if ( 2*r*bufc + _med_1(_miss,_miss,r,c,0)
                   + (2*3*bufc + _med_1(_miss,_miss,3,c,0)) )
                       GT core;
                    msg = "Not enough memory";
                    goto re_call;
                endif;
                x = rc_buf ~ x;
                fmt = fmt_buf | fmt;
                v = v_buf ~ v;
                max_vals = maxv_buf ~ max_vals;
            else;
                if ( _med_1(_miss,1~(CC-1),r,c,0) + 2*r*bufc
                      + _med_1(_miss,CC~c,r,c,0)
                   + (_med_1(_miss,1~(CC-1),3,c,0) + 2*3*bufc
                       + _med_1(_miss,CC~c,3,c,0))   )
                         GT core;
                    msg = "Not enough memory";
                    goto re_call;
                endif;
                x = x[.,1:(CC-1)] ~ rc_buf ~ x[.,CC:c];
                fmt = fmt[1:(CC-1).,] | fmt_buf |
                    fmt[CC:c,.];
                v = v[.,1:(CC-1)] ~ v_buf ~ v[.,CC:c];
                max_vals = max_vals[.,1:(CC-1)] ~ maxv_buf ~
                    max_vals[.,CC:c];
            endif;
            request = 11;           /* inserted column block */
        endif;
    else;
        msg = "Invalid request";
        goto re_call;
    endif;
    r = rows(x);
    c = cols(x);
    goto re_call;           /* loop back to medit */

save_mat:
    /* jump to here if request is 0 */
    clear rc_cut,rc_buf,fmt_buf,v_buf,maxv_buf;  /* free memory */
    #ifcplx  /* COMPLEX version */
        if izero;  /* x purely real */
            x = real(x);
        elseif iscplx(x);
            oldimtol = sysstate(21,0);
            if not hasimag(x);
                x = real(x);
            endif;
            call sysstate(21,oldimtol);
        endif;
    #endif
    ndpclex;
    call ndpcntrl(old_ctrl, 0xffff);
    /* save edited matrix in _MEDIT_X.FMT on GAUSS save path */
    str = "_medit_x";
    print "Saving edited matrix in _MEDIT_X.FMT...";;
    save ^str = x;
    print "\rEdited matrix saved in _MEDIT_X.FMT       ";
    retp(x,v,fmt);

/* Subroutines follow */
CUT_ROWS:
        if(TR LE 1);       /* cut first rows */
            if _med_1(BR+1~r,_miss,r,c,1) GT core;
                msg = "Not enough memory";
                return;
            endif;
            x = x[BR+1:r,.];
        elseif (BR GE r);          /* cut last rows */
            if _med_1(1~(TR-1),_miss,r,c,1) GT core;
                msg = "Not enough memory";
                return;
            endif;
            x = x[1:(TR-1),.];
        else;
            if _med_2r(1~(TR-1),(BR+1)~r,r,c) GT core;
                msg = "Not enough memory";
                return;
            endif;
            x = x[1:(TR-1),.] | x[(BR+1):r,.];
        endif;
return;

CUT_COLS:
        if(TC LE 1);       /* cut first cols */
            if _med_1(_miss,(BC+1)~c,maxc(r|3),c,1) GT core;/* allow for fmt */
                msg = "Not enough memory";
                return;
            endif;
            x = x[.,BC+1:c];
            fmt = fmt[BC+1:c,.];
            v = v[.,BC+1:c];
            max_vals = max_vals[.,BC+1:c];
        elseif (BC GE c);          /* cut last cols */
            if _med_1(_miss,1~(TC-1),maxc(r|3),c,1) GT core; /* allow for fmt */
                msg = "Not enough memory";
                return;
            endif;
            x = x[.,1:(TC-1)];
            fmt = fmt[1:(TC-1),.];
            v = v[.,1:(TC-1)];
            max_vals = max_vals[.,1:(TC-1)];
        else;
            /* allow for fmt */
            if _med_2c(1~(TC-1),(BC+1)~c,maxc(r|3),c) GT core;
                /* allow for fmt */
                msg = "Not enough memory";
                return;
            endif;
            x = x[.,1:(TC-1)] ~ x[.,(BC+1):c];
            fmt = fmt[1:(TC-1),.] | fmt[(BC+1):c,.];
            v = v[.,1:(TC-1)] ~ v[.,(BC+1):c];
            max_vals = max_vals[.,1:(TC-1)] ~ max_vals[.,(BC+1):c];
        endif;
return;

endp;

#endif