1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
|
#include "rb_lapack.h"
extern doublereal dla_porcond_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);
static VALUE
rblapack_dla_porcond(int argc, VALUE *argv, VALUE self){
#ifdef USEXBLAS
VALUE rblapack_uplo;
char uplo;
VALUE rblapack_a;
doublereal *a;
VALUE rblapack_af;
doublereal *af;
VALUE rblapack_cmode;
integer cmode;
VALUE rblapack_c;
doublereal *c;
VALUE rblapack_work;
doublereal *work;
VALUE rblapack_iwork;
integer *iwork;
VALUE rblapack_info;
integer info;
VALUE rblapack___out__;
doublereal __out__;
integer lda;
integer n;
integer ldaf;
VALUE rblapack_options;
if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
argc--;
rblapack_options = argv[argc];
if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n LOGICAL UP\n* ..\n* .. Array Arguments ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n EXTERNAL LSAME, IDAMAX\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
return Qnil;
}
if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
return Qnil;
}
} else
rblapack_options = Qnil;
if (argc != 7 && argc != 7)
rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
rblapack_uplo = argv[0];
rblapack_a = argv[1];
rblapack_af = argv[2];
rblapack_cmode = argv[3];
rblapack_c = argv[4];
rblapack_work = argv[5];
rblapack_iwork = argv[6];
if (argc == 7) {
} else if (rblapack_options != Qnil) {
} else {
}
uplo = StringValueCStr(rblapack_uplo)[0];
if (!NA_IsNArray(rblapack_af))
rb_raise(rb_eArgError, "af (3th argument) must be NArray");
if (NA_RANK(rblapack_af) != 2)
rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
ldaf = NA_SHAPE0(rblapack_af);
n = NA_SHAPE1(rblapack_af);
if (NA_TYPE(rblapack_af) != NA_DFLOAT)
rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
af = NA_PTR_TYPE(rblapack_af, doublereal*);
if (!NA_IsNArray(rblapack_c))
rb_raise(rb_eArgError, "c (5th argument) must be NArray");
if (NA_RANK(rblapack_c) != 1)
rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_c) != n)
rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
if (NA_TYPE(rblapack_c) != NA_DFLOAT)
rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
c = NA_PTR_TYPE(rblapack_c, doublereal*);
if (!NA_IsNArray(rblapack_iwork))
rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
if (NA_RANK(rblapack_iwork) != 1)
rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_iwork) != n)
rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
if (NA_TYPE(rblapack_iwork) != NA_LINT)
rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
if (!NA_IsNArray(rblapack_a))
rb_raise(rb_eArgError, "a (2th argument) must be NArray");
if (NA_RANK(rblapack_a) != 2)
rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
lda = NA_SHAPE0(rblapack_a);
if (NA_SHAPE1(rblapack_a) != n)
rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
if (NA_TYPE(rblapack_a) != NA_DFLOAT)
rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
a = NA_PTR_TYPE(rblapack_a, doublereal*);
if (!NA_IsNArray(rblapack_work))
rb_raise(rb_eArgError, "work (6th argument) must be NArray");
if (NA_RANK(rblapack_work) != 1)
rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_work) != (3*n))
rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
if (NA_TYPE(rblapack_work) != NA_DFLOAT)
rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
work = NA_PTR_TYPE(rblapack_work, doublereal*);
cmode = NUM2INT(rblapack_cmode);
__out__ = dla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);
rblapack_info = INT2NUM(info);
rblapack___out__ = rb_float_new((double)__out__);
return rb_ary_new3(2, rblapack_info, rblapack___out__);
#else
return Qnil;
#endif
}
void
init_lapack_dla_porcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
sHelp = sH;
sUsage = sU;
rblapack_ZERO = zero;
rb_define_module_function(mLapack, "dla_porcond", rblapack_dla_porcond, -1);
}
|