The R Project SVN – R – Diff – /branches/R-classInheritance/src/main/array.c



    int i;
    Rcomplex one, zero;
 
    one.r = 1.0; one.i = zero.r = zero.i = 0.0;
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
	F77_CALL(zgemm)(transa, transb, &nrx, &ncy, &ncx, &one,
			x, &nrx, y, &nry, &zero, z, &nrx);
    } else { /* zero-extent operations should return zeroes */
	for(i = 0; i < nrx*ncy; i++) z[i].r = z[i].i = 0;
    }
#else

{
    char *trans = "T", *uplo = "U";
    double one = 1.0, zero = 0.0;
    int i, j;
    if (nr > 0 && nc > 0) {
	F77_CALL(dsyrk)(uplo, trans, &nc, &nr, &one, x, &nr, &zero, z, &nc);
	for (i = 1; i < nc; i++)
	    for (j = 0; j < i; j++) z[i + nc *j] = z[j + nc * i];
    } else { /* zero-extent operations should return zeroes */
	for(i = 0; i < nc*nc; i++) z[i] = 0;
    }

		      double *y, int nry, int ncy, double *z)
{
    char *transa = "T", *transb = "N";
    double one = 1.0, zero = 0.0;
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
	F77_CALL(dgemm)(transa, transb, &ncx, &ncy, &nrx, &one,
			x, &nrx, y, &nry, &zero, z, &ncx);
    } else { /* zero-extent operations should return zeroes */
	int i;
	for(i = 0; i < ncx*ncy; i++) z[i] = 0;
    }

    char *transa = "T", *transb = "N";
    Rcomplex one, zero;
 
    one.r = 1.0; one.i = zero.r = zero.i = 0.0;
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
	F77_CALL(zgemm)(transa, transb, &ncx, &ncy, &nrx, &one,
			x, &nrx, y, &nry, &zero, z, &ncx);
    } else { /* zero-extent operations should return zeroes */
	int i;
	for(i = 0; i < ncx*ncy; i++) z[i].r = z[i].i = 0;
    }

{
    char *trans = "N", *uplo = "U";
    double one = 1.0, zero = 0.0;
    int i, j;
    if (nr > 0 && nc > 0) {
	F77_CALL(dsyrk)(uplo, trans, &nr, &nc, &one, x, &nr, &zero, z, &nr);
	for (i = 1; i < nr; i++)
	    for (j = 0; j < i; j++) z[i + nr *j] = z[j + nr * i];
    } else { /* zero-extent operations should return zeroes */
	for(i = 0; i < nr*nr; i++) z[i] = 0;
    }

		      double *y, int nry, int ncy, double *z)
{
    char *transa = "N", *transb = "T";
    double one = 1.0, zero = 0.0;
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
	F77_CALL(dgemm)(transa, transb, &nrx, &nry, &ncx, &one,
			x, &nrx, y, &nry, &zero, z, &nrx);
    } else { /* zero-extent operations should return zeroes */
	int i;
	for(i = 0; i < nrx*nry; i++) z[i] = 0;
    }

    char *transa = "N", *transb = "T";
    Rcomplex one, zero;
 
    one.r = 1.0; one.i = zero.r = zero.i = 0.0;
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
	F77_CALL(zgemm)(transa, transb, &nrx, &nry, &ncx, &one,
			x, &nrx, y, &nry, &zero, z, &nrx);
    } else { /* zero-extent operations should return zeroes */
	int i;
	for(i = 0; i < nrx*nry; i++) z[i].r = z[i].i = 0;
    }

{
    int ldx, ldy, nrx, ncx, nry, ncy, mode;
    SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;
    Rboolean sym;
 
    if(PRIMVAL(op) == 0 &&
       (IS_S4_OBJECT(x) || IS_S4_OBJECT(y))
       && R_has_methods(op)) {
	SEXP s, value;
	/* Remove argument names to ensure positional matching */
	for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
	value = R_possible_dispatch(call, op, args, rho, FALSE);

    for (i=0; i<n; iip[i++] = 0);
 
    switch (TYPEOF(a)) {
 
    case INTSXP:
	for (j=0, i=0; i<len; i++) {
	    INTEGER(r)[i] = INTEGER(a)[j];
	    CLICKJ;
	}
	break;
 
    case LGLSXP:
	for (j=0, i=0; i<len; i++) {
	    LOGICAL(r)[i] = LOGICAL(a)[j];
	    CLICKJ;

		}
	    }
	    for (i = 0; i < n; i++) REAL(ans)[i] = rans[i];
	    if(n > 10000) Free(rans);
	    UNPROTECT(1);
	    return ans;
	}
 
	for (i = 0; i < n; i++) {
	    switch (type) {
	    case INTSXP:

Rev 44512	Rev 45446
Line 446...	Line 446...
446	`int i;`	446	`int i;`
447	`Rcomplex one, zero;`	447	`Rcomplex one, zero;`
448		448
449	`one.r = 1.0; one.i = zero.r = zero.i = 0.0;`	449	`one.r = 1.0; one.i = zero.r = zero.i = 0.0;`
450	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`	450	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`
451	`F77_CALL(zgemm)(transa, transb, &nrx, &ncy, &ncx, &one,`	451	`F77_CALL(zgemm)(transa, transb, &nrx, &ncy, &ncx, &one,`
452	`x, &nrx, y, &nry, &zero, z, &nrx);`	452	`x, &nrx, y, &nry, &zero, z, &nrx);`
453	`} else { /* zero-extent operations should return zeroes */`	453	`} else { /* zero-extent operations should return zeroes */`
454	`for(i = 0; i < nrx*ncy; i++) z[i].r = z[i].i = 0;`	454	`for(i = 0; i < nrx*ncy; i++) z[i].r = z[i].i = 0;`
455	`}`	455	`}`
456	`#else`	456	`#else`
Line 487...	Line 487...
487	`{`	487	`{`
488	`char trans = "T", uplo = "U";`	488	`char trans = "T", uplo = "U";`
489	`double one = 1.0, zero = 0.0;`	489	`double one = 1.0, zero = 0.0;`
490	`int i, j;`	490	`int i, j;`
491	`if (nr > 0 && nc > 0) {`	491	`if (nr > 0 && nc > 0) {`
492	`F77_CALL(dsyrk)(uplo, trans, &nc, &nr, &one, x, &nr, &zero, z, &nc);`	492	`F77_CALL(dsyrk)(uplo, trans, &nc, &nr, &one, x, &nr, &zero, z, &nc);`
493	`for (i = 1; i < nc; i++)`	493	`for (i = 1; i < nc; i++)`
494	`for (j = 0; j < i; j++) z[i + nc j] = z[j + nc i];`	494	`for (j = 0; j < i; j++) z[i + nc j] = z[j + nc i];`
495	`} else { /* zero-extent operations should return zeroes */`	495	`} else { /* zero-extent operations should return zeroes */`
496	`for(i = 0; i < nc*nc; i++) z[i] = 0;`	496	`for(i = 0; i < nc*nc; i++) z[i] = 0;`
497	`}`	497	`}`
Line 502...	Line 502...
502	`double y, int nry, int ncy, double z)`	502	`double y, int nry, int ncy, double z)`
503	`{`	503	`{`
504	`char transa = "T", transb = "N";`	504	`char transa = "T", transb = "N";`
505	`double one = 1.0, zero = 0.0;`	505	`double one = 1.0, zero = 0.0;`
506	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`	506	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`
507	`F77_CALL(dgemm)(transa, transb, &ncx, &ncy, &nrx, &one,`	507	`F77_CALL(dgemm)(transa, transb, &ncx, &ncy, &nrx, &one,`
508	`x, &nrx, y, &nry, &zero, z, &ncx);`	508	`x, &nrx, y, &nry, &zero, z, &ncx);`
509	`} else { /* zero-extent operations should return zeroes */`	509	`} else { /* zero-extent operations should return zeroes */`
510	`int i;`	510	`int i;`
511	`for(i = 0; i < ncx*ncy; i++) z[i] = 0;`	511	`for(i = 0; i < ncx*ncy; i++) z[i] = 0;`
512	`}`	512	`}`
Line 518...	Line 518...
518	`char transa = "T", transb = "N";`	518	`char transa = "T", transb = "N";`
519	`Rcomplex one, zero;`	519	`Rcomplex one, zero;`
520		520
521	`one.r = 1.0; one.i = zero.r = zero.i = 0.0;`	521	`one.r = 1.0; one.i = zero.r = zero.i = 0.0;`
522	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`	522	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`
523	`F77_CALL(zgemm)(transa, transb, &ncx, &ncy, &nrx, &one,`	523	`F77_CALL(zgemm)(transa, transb, &ncx, &ncy, &nrx, &one,`
524	`x, &nrx, y, &nry, &zero, z, &ncx);`	524	`x, &nrx, y, &nry, &zero, z, &ncx);`
525	`} else { /* zero-extent operations should return zeroes */`	525	`} else { /* zero-extent operations should return zeroes */`
526	`int i;`	526	`int i;`
527	`for(i = 0; i < ncx*ncy; i++) z[i].r = z[i].i = 0;`	527	`for(i = 0; i < ncx*ncy; i++) z[i].r = z[i].i = 0;`
528	`}`	528	`}`
Line 532...	Line 532...
532	`{`	532	`{`
533	`char trans = "N", uplo = "U";`	533	`char trans = "N", uplo = "U";`
534	`double one = 1.0, zero = 0.0;`	534	`double one = 1.0, zero = 0.0;`
535	`int i, j;`	535	`int i, j;`
536	`if (nr > 0 && nc > 0) {`	536	`if (nr > 0 && nc > 0) {`
537	`F77_CALL(dsyrk)(uplo, trans, &nr, &nc, &one, x, &nr, &zero, z, &nr);`	537	`F77_CALL(dsyrk)(uplo, trans, &nr, &nc, &one, x, &nr, &zero, z, &nr);`
538	`for (i = 1; i < nr; i++)`	538	`for (i = 1; i < nr; i++)`
539	`for (j = 0; j < i; j++) z[i + nr j] = z[j + nr i];`	539	`for (j = 0; j < i; j++) z[i + nr j] = z[j + nr i];`
540	`} else { /* zero-extent operations should return zeroes */`	540	`} else { /* zero-extent operations should return zeroes */`
541	`for(i = 0; i < nr*nr; i++) z[i] = 0;`	541	`for(i = 0; i < nr*nr; i++) z[i] = 0;`
542	`}`	542	`}`
Line 547...	Line 547...
547	`double y, int nry, int ncy, double z)`	547	`double y, int nry, int ncy, double z)`
548	`{`	548	`{`
549	`char transa = "N", transb = "T";`	549	`char transa = "N", transb = "T";`
550	`double one = 1.0, zero = 0.0;`	550	`double one = 1.0, zero = 0.0;`
551	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`	551	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`
552	`F77_CALL(dgemm)(transa, transb, &nrx, &nry, &ncx, &one,`	552	`F77_CALL(dgemm)(transa, transb, &nrx, &nry, &ncx, &one,`
553	`x, &nrx, y, &nry, &zero, z, &nrx);`	553	`x, &nrx, y, &nry, &zero, z, &nrx);`
554	`} else { /* zero-extent operations should return zeroes */`	554	`} else { /* zero-extent operations should return zeroes */`
555	`int i;`	555	`int i;`
556	`for(i = 0; i < nrx*nry; i++) z[i] = 0;`	556	`for(i = 0; i < nrx*nry; i++) z[i] = 0;`
557	`}`	557	`}`
Line 563...	Line 563...
563	`char transa = "N", transb = "T";`	563	`char transa = "N", transb = "T";`
564	`Rcomplex one, zero;`	564	`Rcomplex one, zero;`
565		565
566	`one.r = 1.0; one.i = zero.r = zero.i = 0.0;`	566	`one.r = 1.0; one.i = zero.r = zero.i = 0.0;`
567	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`	567	`if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {`
568	`F77_CALL(zgemm)(transa, transb, &nrx, &nry, &ncx, &one,`	568	`F77_CALL(zgemm)(transa, transb, &nrx, &nry, &ncx, &one,`
569	`x, &nrx, y, &nry, &zero, z, &nrx);`	569	`x, &nrx, y, &nry, &zero, z, &nrx);`
570	`} else { /* zero-extent operations should return zeroes */`	570	`} else { /* zero-extent operations should return zeroes */`
571	`int i;`	571	`int i;`
572	`for(i = 0; i < nrx*nry; i++) z[i].r = z[i].i = 0;`	572	`for(i = 0; i < nrx*nry; i++) z[i].r = z[i].i = 0;`
573	`}`	573	`}`
Line 579...	Line 579...
579	`{`	579	`{`
580	`int ldx, ldy, nrx, ncx, nry, ncy, mode;`	580	`int ldx, ldy, nrx, ncx, nry, ncy, mode;`
581	`SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;`	581	`SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;`
582	`Rboolean sym;`	582	`Rboolean sym;`
583		583
584	`if(PRIMVAL(op) == 0 &&`	584	`if(PRIMVAL(op) == 0 &&`
585	`(IS_S4_OBJECT(x) \|\| IS_S4_OBJECT(y))`	585	`(IS_S4_OBJECT(x) \|\| IS_S4_OBJECT(y))`
586	`&& R_has_methods(op)) {`	586	`&& R_has_methods(op)) {`
587	`SEXP s, value;`	587	`SEXP s, value;`
588	`/* Remove argument names to ensure positional matching */`	588	`/* Remove argument names to ensure positional matching */`
589	`for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);`	589	`for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);`
590	`value = R_possible_dispatch(call, op, args, rho, FALSE);`	590	`value = R_possible_dispatch(call, op, args, rho, FALSE);`
Line 1051...	Line 1051...
1051	`for (i=0; i<n; iip[i++] = 0);`	1051	`for (i=0; i<n; iip[i++] = 0);`
1052		1052
1053	`switch (TYPEOF(a)) {`	1053	`switch (TYPEOF(a)) {`
1054		1054
1055	`case INTSXP:`	1055	`case INTSXP:`
1056	`for (j=0, i=0; i<len; i++) {`	1056	`for (j=0, i=0; i<len; i++) {`
1057	`INTEGER(r)[i] = INTEGER(a)[j];`	1057	`INTEGER(r)[i] = INTEGER(a)[j];`
1058	`CLICKJ;`	1058	`CLICKJ;`
1059	`}`	1059	`}`
1060	`break;`	1060	`break;`
1061		1061
1062	`case LGLSXP:`	1062	`case LGLSXP:`
1063	`for (j=0, i=0; i<len; i++) {`	1063	`for (j=0, i=0; i<len; i++) {`
1064	`LOGICAL(r)[i] = LOGICAL(a)[j];`	1064	`LOGICAL(r)[i] = LOGICAL(a)[j];`
1065	`CLICKJ;`	1065	`CLICKJ;`
Line 1246...	Line 1246...
1246	`}`	1246	`}`
1247	`}`	1247	`}`
1248	`for (i = 0; i < n; i++) REAL(ans)[i] = rans[i];`	1248	`for (i = 0; i < n; i++) REAL(ans)[i] = rans[i];`
1249	`if(n > 10000) Free(rans);`	1249	`if(n > 10000) Free(rans);`
1250	`UNPROTECT(1);`	1250	`UNPROTECT(1);`
1251	`return ans;`	1251	`return ans;`
1252	`}`	1252	`}`
1253		1253
1254	`for (i = 0; i < n; i++) {`	1254	`for (i = 0; i < n; i++) {`
1255	`switch (type) {`	1255	`switch (type) {`
1256	`case INTSXP:`	1256	`case INTSXP:`

The R Project SVN R

(root)/branches/R-classInheritance/src/main/array.c @ 63243 – Rev 44512 → 45446