/* * 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 */