/*
* evaluate a test expression.
* flag is 0 on outer level
* flag is 1 when in parenthesis
* flag is 2 when evaluating -a
*/
static int expr(struct test *tp,register int flag)
{
register int r;
register char *p;
r = e3(tp);
while(tp->ap < tp->ac)
{
p = nxtarg(tp,0);
/* check for -o and -a */
if(flag && c_eq(p,')'))
{
tp->ap--;
break;
}
if(*p=='-' && *(p+2)==0)
{
if(*++p == 'o')
{
if(flag==2)
{
tp->ap--;
break;
}
r |= expr(tp,3);
continue;
}
else if(*p == 'a')
{
r &= expr(tp,2);
continue;
}
}
if(flag==0)
break;
errormsg(SH_DICT,ERROR_exit(2),e_badsyntax);
}
return(r);
}
void apply(board *b, move m) {
// Disable the old en passant eligibility for a file
if (b->en_passant_pawn_push_col_history[b->last_move_ply] != -1) {
b->hash ^= zobrist_en_passant_files[b->en_passant_pawn_push_col_history[b->last_move_ply]];
}
// Information
piece moved_piece = at(b, m.from);
piece new_piece = p_eq(m.promote_to, no_piece) ? moved_piece : m.promote_to;
// If the move we will apply is en passant, remove the captured pawn
if (m.en_passant_capture) {
uint8_t en_passant_capture_row = moved_piece.white ? 4 : 3;
coord en_pasant_capture_square = (coord){b->en_passant_pawn_push_col_history[b->last_move_ply], en_passant_capture_row};
set(b, en_pasant_capture_square, no_piece);
}
// Transform board and hash
b->hash ^= tt_pieceval(b, m.from);
b->hash ^= tt_pieceval(b, m.to);
set(b, m.to, new_piece);
set(b, m.from, no_piece);
b->hash ^= tt_pieceval(b, m.to);
b->hash ^= zobrist_black_to_move;
b->black_to_move = !b->black_to_move;
b->last_move_ply++;
// For en passant
b->en_passant_pawn_push_col_history[b->last_move_ply] = -1;
if (at(b, m.to).type == 'P' && abs(m.to.row - m.from.row) == 2) {
b->en_passant_pawn_push_col_history[b->last_move_ply] = m.to.col;
// En passant capture now enabled on this file
b->hash ^= zobrist_en_passant_files[b->en_passant_pawn_push_col_history[b->last_move_ply]];
}
// Manually move rook for castling
if (m.c != N) { // Manually move rook
uint8_t rook_from_col = ((m.c == K) ? 7 : 0);
uint8_t rook_to_col = ((m.c == K) ? 5 : 3);
b->hash ^= tt_pieceval(b, (coord){rook_from_col, m.from.row});
b->b[rook_to_col][m.to.row] = (piece){'R', at(b, m.to).white}; // !!
b->b[rook_from_col][m.from.row] = no_piece;
b->hash ^= tt_pieceval(b, (coord){rook_to_col, m.to.row});
}
// King moves always strip castling rights
if (moved_piece.white && moved_piece.type == 'K') {
if (b->castle_rights_wk) {
b->hash ^= zobrist_castle_wk;
b->castle_wk_lost_on_ply = b->last_move_ply;
b->castle_rights_wk = false;
}
if (b->castle_rights_wq) {
b->hash ^= zobrist_castle_wq;
b->castle_wq_lost_on_ply = b->last_move_ply;
b->castle_rights_wq = false;
}
} else if (!moved_piece.white && moved_piece.type == 'K') {
if (b->castle_rights_bk) {
b->hash ^= zobrist_castle_bk;
b->castle_bk_lost_on_ply = b->last_move_ply;
b->castle_rights_bk = false;
}
if (b->castle_rights_bq) {
b->hash ^= zobrist_castle_bq;
b->castle_bq_lost_on_ply = b->last_move_ply;
b->castle_rights_bq = false;
}
}
if (moved_piece.type == 'K') {
if (moved_piece.white) b->white_king = m.to;
else b->black_king = m.to;
}
// Moves involving rook squares always strip castling rights
if ((c_eq(m.from, wqr) || c_eq(m.to, wqr)) && b->castle_rights_wq) {
b->castle_rights_wq = false;
b->hash ^= zobrist_castle_wq;
b->castle_wq_lost_on_ply = b->last_move_ply;
}
if ((c_eq(m.from, wkr) || c_eq(m.to, wkr)) && b->castle_rights_wk) {
b->castle_rights_wk = false;
b->hash ^= zobrist_castle_wk;
b->castle_wk_lost_on_ply = b->last_move_ply;
}
if ((c_eq(m.from, bqr) || c_eq(m.to, bqr)) && b->castle_rights_bq) {
b->castle_rights_bq = false;
b->hash ^= zobrist_castle_bq;
b->castle_bq_lost_on_ply = b->last_move_ply;
}
if ((c_eq(m.from, bkr) || c_eq(m.to, bkr)) && b->castle_rights_bk) {
b->castle_rights_bk = false;
b->hash ^= zobrist_castle_bk;
b->castle_bk_lost_on_ply = b->last_move_ply;
}
}
/*! \brief
* <pre>
* Purpose
* =======
* ilu_cdrop_row() - Drop some small rows from the previous
* supernode (L-part only).
* </pre>
*/
int ilu_cdrop_row(
superlu_options_t *options, /* options */
int first, /* index of the first column in the supernode */
int last, /* index of the last column in the supernode */
double drop_tol, /* dropping parameter */
int quota, /* maximum nonzero entries allowed */
int *nnzLj, /* in/out number of nonzeros in L(:, 1:last) */
double *fill_tol, /* in/out - on exit, fill_tol=-num_zero_pivots,
* does not change if options->ILU_MILU != SMILU1 */
GlobalLU_t *Glu, /* modified */
float swork[], /* working space
* the length of swork[] should be no less than
* the number of rows in the supernode */
float swork2[], /* working space with the same size as swork[],
* used only by the second dropping rule */
int lastc /* if lastc == 0, there is nothing after the
* working supernode [first:last];
* if lastc == 1, there is one more column after
* the working supernode. */ )
{
register int i, j, k, m1;
register int nzlc; /* number of nonzeros in column last+1 */
register int xlusup_first, xlsub_first;
int m, n; /* m x n is the size of the supernode */
int r = 0; /* number of dropped rows */
register float *temp;
register complex *lusup = (complex *) Glu->lusup;
register int *lsub = Glu->lsub;
register int *xlsub = Glu->xlsub;
register int *xlusup = Glu->xlusup;
register float d_max = 0.0, d_min = 1.0;
int drop_rule = options->ILU_DropRule;
milu_t milu = options->ILU_MILU;
norm_t nrm = options->ILU_Norm;
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex none = {-1.0, 0.0};
int i_1 = 1;
int inc_diag; /* inc_diag = m + 1 */
int nzp = 0; /* number of zero pivots */
float alpha = pow((double)(Glu->n), -1.0 / options->ILU_MILU_Dim);
xlusup_first = xlusup[first];
xlsub_first = xlsub[first];
m = xlusup[first + 1] - xlusup_first;
n = last - first + 1;
m1 = m - 1;
inc_diag = m + 1;
nzlc = lastc ? (xlusup[last + 2] - xlusup[last + 1]) : 0;
temp = swork - n;
/* Quick return if nothing to do. */
if (m == 0 || m == n || drop_rule == NODROP)
{
*nnzLj += m * n;
return 0;
}
/* basic dropping: ILU(tau) */
for (i = n; i <= m1; )
{
/* the average abs value of ith row */
switch (nrm)
{
case ONE_NORM:
temp[i] = scasum_(&n, &lusup[xlusup_first + i], &m) / (double)n;
break;
case TWO_NORM:
temp[i] = scnrm2_(&n, &lusup[xlusup_first + i], &m)
/ sqrt((double)n);
break;
case INF_NORM:
default:
k = icamax_(&n, &lusup[xlusup_first + i], &m) - 1;
temp[i] = c_abs1(&lusup[xlusup_first + i + m * k]);
break;
}
/* drop small entries due to drop_tol */
if (drop_rule & DROP_BASIC && temp[i] < drop_tol)
{
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
caxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
c_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
ccopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
cswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
c_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
continue;
} /* if dropping */
else
{
if (temp[i] > d_max) d_max = temp[i];
if (temp[i] < d_min) d_min = temp[i];
}
i++;
} /* for */
/* Secondary dropping: drop more rows according to the quota. */
quota = ceil((double)quota / (double)n);
if (drop_rule & DROP_SECONDARY && m - r > quota)
{
register double tol = d_max;
/* Calculate the second dropping tolerance */
if (quota > n)
{
if (drop_rule & DROP_INTERP) /* by interpolation */
{
d_max = 1.0 / d_max; d_min = 1.0 / d_min;
tol = 1.0 / (d_max + (d_min - d_max) * quota / (m - n - r));
}
else /* by quick select */
{
int len = m1 - n + 1;
scopy_(&len, swork, &i_1, swork2, &i_1);
tol = sqselect(len, swork2, quota - n);
#if 0
register int *itemp = iwork - n;
A = temp;
for (i = n; i <= m1; i++) itemp[i] = i;
qsort(iwork, m1 - n + 1, sizeof(int), _compare_);
tol = temp[itemp[quota]];
#endif
}
}
for (i = n; i <= m1; )
{
if (temp[i] <= tol)
{
register int j;
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
caxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
c_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
ccopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
cswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
c_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
temp[i] = temp[m1];
continue;
}
i++;
} /* for */
} /* if secondary dropping */
for (i = n; i < m; i++) temp[i] = 0.0;
if (r == 0)
{
*nnzLj += m * n;
return 0;
}
/* add dropped entries to the diagnal */
if (milu != SILU)
{
register int j;
complex t;
float omega;
for (j = 0; j < n; j++)
{
t = lusup[xlusup_first + (m - 1) + j * m];
if (t.r == 0.0 && t.i == 0.0) continue;
omega = SUPERLU_MIN(2.0 * (1.0 - alpha) / c_abs1(&t), 1.0);
cs_mult(&t, &t, omega);
switch (milu)
{
case SMILU_1:
if ( !(c_eq(&t, &none)) ) {
c_add(&t, &t, &one);
cc_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
}
else
{
cs_mult(
&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
*fill_tol);
#ifdef DEBUG
printf("[1] ZERO PIVOT: FILL col %d.\n", first + j);
fflush(stdout);
#endif
nzp++;
}
break;
case SMILU_2:
cs_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
1.0 + c_abs1(&t));
break;
case SMILU_3:
c_add(&t, &t, &one);
cc_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
break;
case SILU:
default:
break;
}
}
if (nzp > 0) *fill_tol = -nzp;
}
/* Remove dropped entries from the memory and fix the pointers. */
m1 = m - r;
for (j = 1; j < n; j++)
{
register int tmp1, tmp2;
tmp1 = xlusup_first + j * m1;
tmp2 = xlusup_first + j * m;
for (i = 0; i < m1; i++)
lusup[i + tmp1] = lusup[i + tmp2];
}
for (i = 0; i < nzlc; i++)
lusup[xlusup_first + i + n * m1] = lusup[xlusup_first + i + n * m];
for (i = 0; i < nzlc; i++)
lsub[xlsub[last + 1] - r + i] = lsub[xlsub[last + 1] + i];
for (i = first + 1; i <= last + 1; i++)
{
xlusup[i] -= r * (i - first);
xlsub[i] -= r;
}
if (lastc)
{
xlusup[last + 2] -= r * n;
xlsub[last + 2] -= r;
}
*nnzLj += (m - r) * n;
return r;
}
/*! \brief Performs one of the matrix-vector operations y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y
*
* <pre>
* Purpose
* =======
*
* sp_cgemv() performs one of the matrix-vector operations
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
* where alpha and beta are scalars, x and y are vectors and A is a
* sparse A->nrow by A->ncol matrix.
*
* Parameters
* ==========
*
* TRANS - (input) char*
* On entry, TRANS specifies the operation to be performed as
* follows:
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
* TRANS = 'C' or 'c' y := alpha*A^H*x + beta*y.
*
* ALPHA - (input) complex
* On entry, ALPHA specifies the scalar alpha.
*
* A - (input) SuperMatrix*
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
*
* X - (input) complex*, array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
* Before entry, the incremented array X must contain the
* vector x.
*
* INCX - (input) int
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
*
* BETA - (input) complex
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
*
* Y - (output) complex*, array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry with BETA non-zero, the incremented array Y
* must contain the vector y. On exit, Y is overwritten by the
* updated vector y.
*
* INCY - (input) int
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
*
* ==== Sparse Level 2 Blas routine.
* </pre>
*/
int
sp_cgemv(char *trans, complex alpha, SuperMatrix *A, complex *x,
int incx, complex beta, complex *y, int incy)
{
/* Local variables */
NCformat *Astore;
complex *Aval;
int info;
complex temp, temp1;
int lenx, leny, i, j, irow;
int iy, jx, jy, kx, ky;
int notran;
complex comp_zero = {0.0, 0.0};
complex comp_one = {1.0, 0.0};
notran = ( strncmp(trans, "N", 1)==0 || strncmp(trans, "n", 1)==0 );
Astore = A->Store;
Aval = Astore->nzval;
/* Test the input parameters */
info = 0;
if ( !notran && strncmp(trans, "T", 1)!=0 && strncmp(trans, "C", 1)!=0)
info = 1;
else if ( A->nrow < 0 || A->ncol < 0 ) info = 3;
else if (incx == 0) info = 5;
else if (incy == 0) info = 8;
if (info != 0) {
input_error("sp_cgemv ", &info);
return 0;
}
/* Quick return if possible. */
if (A->nrow == 0 || A->ncol == 0 ||
c_eq(&alpha, &comp_zero) &&
c_eq(&beta, &comp_one))
return 0;
/* Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y. */
if ( notran ) {
lenx = A->ncol;
leny = A->nrow;
} else {
lenx = A->nrow;
leny = A->ncol;
}
if (incx > 0) kx = 0;
else kx = - (lenx - 1) * incx;
if (incy > 0) ky = 0;
else ky = - (leny - 1) * incy;
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if ( !c_eq(&beta, &comp_one) ) {
if (incy == 1) {
if ( c_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) y[i] = comp_zero;
else
for (i = 0; i < leny; ++i)
cc_mult(&y[i], &beta, &y[i]);
} else {
iy = ky;
if ( c_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) {
y[iy] = comp_zero;
iy += incy;
}
else
for (i = 0; i < leny; ++i) {
cc_mult(&y[iy], &beta, &y[iy]);
iy += incy;
}
}
}
if ( c_eq(&alpha, &comp_zero) ) return 0;
if ( notran ) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (incy == 1) {
for (j = 0; j < A->ncol; ++j) {
if ( !c_eq(&x[jx], &comp_zero) ) {
cc_mult(&temp, &alpha, &x[jx]);
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
cc_mult(&temp1, &temp, &Aval[i]);
c_add(&y[irow], &y[irow], &temp1);
}
}
jx += incx;
}
} else {
ABORT("Not implemented.");
}
} else if (strncmp(trans, "T", 1) == 0 || strncmp(trans, "t", 1) == 0) {
/* Form y := alpha*A'*x + y. */
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
cc_mult(&temp1, &Aval[i], &x[irow]);
c_add(&temp, &temp, &temp1);
}
cc_mult(&temp1, &alpha, &temp);
c_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
} else { /* trans == 'C' or 'c' */
/* Form y := alpha * conj(A) * x + y. */
complex temp2;
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
temp2.r = Aval[i].r;
temp2.i = -Aval[i].i; /* conjugation */
cc_mult(&temp1, &temp2, &x[irow]);
c_add(&temp, &temp, &temp1);
}
cc_mult(&temp1, &alpha, &temp);
c_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
}
return 0;
} /* sp_cgemv */
static int e3(struct test *tp)
{
register char *arg, *cp;
register int op;
char *binop;
arg=nxtarg(tp,0);
if(arg && c_eq(arg, '!'))
return(!e3(tp));
if(c_eq(arg, '('))
{
op = expr(tp,1);
cp = nxtarg(tp,0);
if(!cp || !c_eq(cp, ')'))
errormsg(SH_DICT,ERROR_exit(2),e_missing,"')'");
return(op);
}
cp = nxtarg(tp,1);
if(cp!=0 && (c_eq(cp,'=') || c2_eq(cp,'!','=')))
goto skip;
if(c2_eq(arg,'-','t'))
{
if(cp)
{
op = strtol(cp,&binop, 10);
return(*binop?0:tty_check(op));
}
else
{
/* test -t with no arguments */
tp->ap--;
return(tty_check(1));
}
}
if(*arg=='-' && arg[2]==0)
{
op = arg[1];
if(!cp)
{
/* for backward compatibility with new flags */
if(op==0 || !strchr(test_opchars+10,op))
return(1);
errormsg(SH_DICT,ERROR_exit(2),e_argument);
}
if(strchr(test_opchars,op))
return(test_unop(tp->sh,op,cp));
}
if(!cp)
{
tp->ap--;
return(*arg!=0);
}
skip:
op = sh_lookup(binop=cp,shtab_testops);
if(!(op&TEST_BINOP))
cp = nxtarg(tp,0);
if(!op)
errormsg(SH_DICT,ERROR_exit(2),e_badop,binop);
if(op==TEST_AND || op==TEST_OR)
tp->ap--;
return(test_binop(tp->sh,op,arg,cp));
}
int b_test(int argc, char *argv[],Shbltin_t *context)
{
struct test tdata;
register char *cp = argv[0];
register int not;
tdata.sh = context->shp;
tdata.av = argv;
tdata.ap = 1;
if(c_eq(cp,'['))
{
cp = argv[--argc];
if(!c_eq(cp, ']'))
errormsg(SH_DICT,ERROR_exit(2),e_missing,"']'");
}
if(argc <= 1)
return(1);
cp = argv[1];
if(c_eq(cp,'(') && argc<=6 && c_eq(argv[argc-1],')'))
{
/* special case ( binop ) to conform with standard */
if(!(argc==4 && (not=sh_lookup(cp=argv[2],shtab_testops))))
{
cp = (++argv)[1];
argc -= 2;
}
}
not = c_eq(cp,'!');
/* posix portion for test */
switch(argc)
{
case 5:
if(!not)
break;
argv++;
/* fall through */
case 4:
{
register int op = sh_lookup(cp=argv[2],shtab_testops);
if(op&TEST_BINOP)
break;
if(!op)
{
if(argc==5)
break;
if(not && cp[0]=='-' && cp[2]==0)
return(test_unop(tdata.sh,cp[1],argv[3])!=0);
else if(argv[1][0]=='-' && argv[1][2]==0)
return(!test_unop(tdata.sh,argv[1][1],cp));
else if(not && c_eq(argv[2],'!'))
return(*argv[3]==0);
errormsg(SH_DICT,ERROR_exit(2),e_badop,cp);
}
return(test_binop(tdata.sh,op,argv[1],argv[3])^(argc!=5));
}
case 3:
if(not)
return(*argv[2]!=0);
if(cp[0] != '-' || cp[2] || cp[1]=='?')
{
if(cp[0]=='-' && (cp[1]=='-' || cp[1]=='?') &&
strcmp(argv[2],"--")==0)
{
char *av[3];
av[0] = argv[0];
av[1] = argv[1];
av[2] = 0;
optget(av,sh_opttest);
errormsg(SH_DICT,ERROR_usage(2), "%s",opt_info.arg);
return(2);
}
break;
}
return(!test_unop(tdata.sh,cp[1],argv[2]));
case 2:
return(*cp==0);
}
tdata.ac = argc;
return(!expr(&tdata,0));
}
ConstitutiveModelParameters<EvalT, Traits>::
ConstitutiveModelParameters(Teuchos::ParameterList& p,
const Teuchos::RCP<Albany::Layouts>& dl) :
have_temperature_(false),
dl_(dl)
{
// get number of integration points and spatial dimensions
std::vector<PHX::DataLayout::size_type> dims;
dl_->qp_vector->dimensions(dims);
num_pts_ = dims[1];
num_dims_ = dims[2];
// get the Parameter Library
Teuchos::RCP<ParamLib> paramLib =
p.get<Teuchos::RCP<ParamLib> >("Parameter Library", Teuchos::null);
// get the material parameter list
Teuchos::ParameterList* mat_params =
p.get<Teuchos::ParameterList*>("Material Parameters");
// Check for optional field: temperature
if (p.isType<std::string>("Temperature Name")) {
have_temperature_ = true;
PHX::MDField<ScalarT, Cell, QuadPoint>
tmp(p.get<std::string>("Temperature Name"), dl_->qp_scalar);
temperature_ = tmp;
this->addDependentField(temperature_);
}
// step through the possible parameters, registering as necessary
//
// elastic modulus
std::string e_mod("Elastic Modulus");
if (mat_params->isSublist(e_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(e_mod, dl_->qp_scalar);
elastic_mod_ = tmp;
field_map_.insert(std::make_pair(e_mod, elastic_mod_));
parseParameters(e_mod, p, paramLib);
}
// Poisson's ratio
std::string pr("Poissons Ratio");
if (mat_params->isSublist(pr)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(pr, dl_->qp_scalar);
poissons_ratio_ = tmp;
field_map_.insert(std::make_pair(pr, poissons_ratio_));
parseParameters(pr, p, paramLib);
}
// bulk modulus
std::string b_mod("Bulk Modulus");
if (mat_params->isSublist(b_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(b_mod, dl_->qp_scalar);
bulk_mod_ = tmp;
field_map_.insert(std::make_pair(b_mod, bulk_mod_));
parseParameters(b_mod, p, paramLib);
}
// shear modulus
std::string s_mod("Shear Modulus");
if (mat_params->isSublist(s_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(s_mod, dl_->qp_scalar);
shear_mod_ = tmp;
field_map_.insert(std::make_pair(s_mod, shear_mod_));
parseParameters(s_mod, p, paramLib);
}
// yield strength
std::string yield("Yield Strength");
if (mat_params->isSublist(yield)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(yield, dl_->qp_scalar);
yield_strength_ = tmp;
field_map_.insert(std::make_pair(yield, yield_strength_));
parseParameters(yield, p, paramLib);
}
// hardening modulus
std::string h_mod("Hardening Modulus");
if (mat_params->isSublist(h_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(h_mod, dl_->qp_scalar);
hardening_mod_ = tmp;
field_map_.insert(std::make_pair(h_mod, hardening_mod_));
parseParameters(h_mod, p, paramLib);
}
// recovery modulus
std::string r_mod("Recovery Modulus");
if (mat_params->isSublist(r_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(r_mod, dl_->qp_scalar);
recovery_mod_ = tmp;
field_map_.insert(std::make_pair(r_mod, recovery_mod_));
parseParameters(r_mod, p, paramLib);
}
// concentration equilibrium parameter
std::string c_eq("Concentration Equilibrium Parameter");
if (mat_params->isSublist(c_eq)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(c_eq, dl_->qp_scalar);
conc_eq_param_ = tmp;
field_map_.insert(std::make_pair(c_eq, conc_eq_param_));
parseParameters(c_eq, p, paramLib);
}
// diffusion coefficient
std::string d_coeff("Diffusion Coefficient");
if (mat_params->isSublist(d_coeff)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(d_coeff, dl_->qp_scalar);
diff_coeff_ = tmp;
field_map_.insert(std::make_pair(d_coeff, diff_coeff_));
parseParameters(d_coeff, p, paramLib);
}
// thermal conductivity
std::string th_cond("Thermal Conductivity");
if (mat_params->isSublist(th_cond)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(th_cond, dl_->qp_scalar);
thermal_cond_ = tmp;
field_map_.insert(std::make_pair(th_cond, thermal_cond_));
parseParameters(th_cond, p, paramLib);
}
// flow rule coefficient
std::string f_coeff("Flow Rule Coefficient");
if (mat_params->isSublist(f_coeff)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(f_coeff, dl_->qp_scalar);
flow_coeff_ = tmp;
field_map_.insert(std::make_pair(f_coeff, flow_coeff_));
parseParameters(f_coeff, p, paramLib);
}
// flow rule exponent
std::string f_exp("Flow Rule Exponent");
if (mat_params->isSublist(f_exp)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(f_exp, dl_->qp_scalar);
flow_exp_ = tmp;
field_map_.insert(std::make_pair(f_exp, flow_exp_));
parseParameters(f_exp, p, paramLib);
}
// register evaluated fields
typename
std::map<std::string, PHX::MDField<ScalarT, Cell, QuadPoint> >::iterator it;
for (it = field_map_.begin();
it != field_map_.end();
++it) {
this->addEvaluatedField(it->second);
}
this->setName(
"Constitutive Model Parameters" + PHX::TypeString<EvalT>::value);
}
int
sp_cgemv(char *trans, complex alpha, SuperMatrix *A, complex *x,
int incx, complex beta, complex *y, int incy)
{
/* Purpose
=======
sp_cgemv() performs one of the matrix-vector operations
y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
where alpha and beta are scalars, x and y are vectors and A is a
sparse A->nrow by A->ncol matrix.
Parameters
==========
TRANS - (input) char*
On entry, TRANS specifies the operation to be performed as
follows:
TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
ALPHA - (input) complex
On entry, ALPHA specifies the scalar alpha.
A - (input) SuperMatrix*
Before entry, the leading m by n part of the array A must
contain the matrix of coefficients.
X - (input) complex*, array of DIMENSION at least
( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
and at least
( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
Before entry, the incremented array X must contain the
vector x.
INCX - (input) int
On entry, INCX specifies the increment for the elements of
X. INCX must not be zero.
BETA - (input) complex
On entry, BETA specifies the scalar beta. When BETA is
supplied as zero then Y need not be set on input.
Y - (output) complex*, array of DIMENSION at least
( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
and at least
( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
Before entry with BETA non-zero, the incremented array Y
must contain the vector y. On exit, Y is overwritten by the
updated vector y.
INCY - (input) int
On entry, INCY specifies the increment for the elements of
Y. INCY must not be zero.
==== Sparse Level 2 Blas routine.
*/
/* Local variables */
NCformat *Astore;
complex *Aval;
int info;
complex temp, temp1;
int lenx, leny, i, j, irow;
int iy, jx, jy, kx, ky;
int notran;
complex comp_zero = {0.0, 0.0};
complex comp_one = {1.0, 0.0};
notran = lsame_(trans, "N");
Astore = A->Store;
Aval = Astore->nzval;
/* Test the input parameters */
info = 0;
if ( !notran && !lsame_(trans, "T") && !lsame_(trans, "C")) info = 1;
else if ( A->nrow < 0 || A->ncol < 0 ) info = 3;
else if (incx == 0) info = 5;
else if (incy == 0) info = 8;
if (info != 0) {
xerbla_("sp_cgemv ", &info);
return 0;
}
/* Quick return if possible. */
if (A->nrow == 0 || A->ncol == 0 ||
c_eq(&alpha, &comp_zero) &&
c_eq(&beta, &comp_one))
return 0;
/* Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y. */
if (lsame_(trans, "N")) {
lenx = A->ncol;
leny = A->nrow;
} else {
lenx = A->nrow;
leny = A->ncol;
}
if (incx > 0) kx = 0;
else kx = - (lenx - 1) * incx;
if (incy > 0) ky = 0;
else ky = - (leny - 1) * incy;
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if ( !c_eq(&beta, &comp_one) ) {
if (incy == 1) {
if ( c_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) y[i] = comp_zero;
else
for (i = 0; i < leny; ++i)
cc_mult(&y[i], &beta, &y[i]);
} else {
iy = ky;
if ( c_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) {
y[iy] = comp_zero;
iy += incy;
}
else
for (i = 0; i < leny; ++i) {
cc_mult(&y[iy], &beta, &y[iy]);
iy += incy;
}
}
}
if ( c_eq(&alpha, &comp_zero) ) return 0;
if ( notran ) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (incy == 1) {
for (j = 0; j < A->ncol; ++j) {
if ( !c_eq(&x[jx], &comp_zero) ) {
cc_mult(&temp, &alpha, &x[jx]);
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
cc_mult(&temp1, &temp, &Aval[i]);
c_add(&y[irow], &y[irow], &temp1);
}
}
jx += incx;
}
} else {
ABORT("Not implemented.");
}
} else {
/* Form y := alpha*A'*x + y. */
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
cc_mult(&temp1, &Aval[i], &x[irow]);
c_add(&temp, &temp, &temp1);
}
cc_mult(&temp1, &alpha, &temp);
c_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
}
return 0;
} /* sp_cgemv */
