void
batfunc(char *in)
{
uint8_t hb[2];
uint16_t bv;
uint8_t l = fromhex(in+1,hb,2);
#ifdef CURV3
// hb[0] = 00 Charge with 500mA (hb[1]=01) or 100mA (hb[1]=00)
// hb[0] = 01 Disable USB charging (hb[1]=01) or enable it (hb[1]=00)
if(l == 2) {
uint8_t pin = BAT_PEN2;
if(hb[0] == 1) pin = BAT_USUS;
if(hb[1]) {
BAT_PORT |= _BV(pin);
} else {
BAT_PORT &= ~_BV(pin);
}
} else
#endif
{
// This will displayed on the 13char title row on the CUR
bv = get_adcw(BAT_MUX);
if(l >= 1 && hb[0]) {
DU(bv, 4);
} else {
raw2percent(bv);
DU(battery_state,3);
DC('%');
}
#ifdef CURV3
if( !bit_is_set( BAT_PIN, BAT_CHG ) ) DS_P( PSTR(" charging"));
if( !bit_is_set( BAT_PIN, BAT_DONE) ) DS_P( PSTR(" charged"));
if( !bit_is_set( BAT_PIN, BAT_FLT) ) DS_P( PSTR(" error"));
#else
uint8_t s1;
s1 = (bit_is_set( BAT_PIN, BAT_PIN1) ? 2 : 0);
s1 |= (bit_is_set( BAT_PIN, BAT_PIN2) ? 1 : 0);
if(s1==0) DS_P( PSTR(" discharge"));
if(s1==1) DS_P( PSTR(" charged"));
if(s1==2) DS_P( PSTR(" charging"));
if(s1==3) DS_P( PSTR(" error"));
#endif
#ifdef CURV3
if( !bit_is_set( BAT_PIN, BAT_DOK) ) DS_P( PSTR(" DC")); // not wired ;)
if( !bit_is_set( BAT_PIN, BAT_UOK) ) DS_P( PSTR(" USB"));
#endif
DNL();
}
}
void
kopp_fc_func(char *in)
{
int SingleBlkOnly=0; // Default: we will send key off if Keycode >= 0x80
uint32_t LastWatchdog;
uint8_t blkTXcode=0x00;
uint8_t inhex_dec[kopp_fc_Command_char]; // in_decbin: decimal value of hex commandline
uint8_t hblen = fromhex(in+2, inhex_dec, strlen(in));
strcpy(ErrorMSG,"ok");
// If parameter 2 = "t" then "Transmitt Free Control Telegram"
SingleBlkOnly=0; // Default: we will send key off if Keycode >= 0x80
if((in[1] == 't') || (in[1] == 's'))
// Transmitt Command
// =================
{
kopp_fc_tx_on = 1; // Transmitt activated
if (in[15]=='J') printon[0]='Y'; else printon[0]='N'; // Sollen wir Daten ausgeben (Zeitstempel etc)
if(in[1] == 's') SingleBlkOnly=1; // Command = "s", -> If KeyCode > 0x80 we will send no !! Key Off Code
LastWatchdog=ticks; // I guess, Watchdog reset was done shortly before
BlockStartTime=ticks;
// print some status Information
if (printon[0]=='Y')
{
DS_P(PSTR("Transmitt\r\n"));
DS_P(PSTR("commandlineparameter: "));
DS(in);
DS_P(PSTR("\r\nStringlength: "));
DU(strlen(in),0);
DS_P(PSTR("\r\nNext Character (int) after parameter (should be line end character): "));
DU((int)in[strlen(in)],0);
DS_P(PSTR("\r\nAmount of Bytes (Hex) found inside command line parameter: "));
DU(hblen,0);
DS_P(PSTR("\r\n"));
// following code to check whether ticks uses full 32 bits or will be reset afer 125 ticks
DS_P(PSTR("Tick Timer: "));
DH((uint16_t)(( BlockStartTime>>16) & 0xffff),4);
DH((uint16_t)(BlockStartTime & 0xffff),4);
DS_P(PSTR("\r\n"));
}
void
lcd_contrast(uint8_t hb)
{
uint8_t contrast = erb((uint8_t*)EE_CONTRAST);
if(hb == 0xFE) {
contrast--;
} else if (hb == 0xFD) {
contrast++;
} else if (hb == 0xFC) {
//keep the eeprom value
} else {
contrast = hb;
}
if(contrast < 40) contrast = 40;
if(contrast > 80) contrast = 80;
ewb((uint8_t*)EE_CONTRAST, contrast);
lcd_sendcmd (LCD_CMD_SETCON);
lcd_senddata (contrast);
DS_P( PSTR("Contrast:") );
DU(100-(contrast-40)*100/40, 3);
DC('%');
DNL();
}
int main(int argc, char **argv)
{
Poly *l, *p, *q = poly_alloc(3);
Hpoly *t = hpoly_alloc(3);
Item *i;
init_sdl();
s = scene_read();
init_render();
for (o = s->objs; o != NULL; o = o->next) {
for (l = prim_uv_decomp(o->u.prim, 1.); l != NULL; l = l->next) {
p = poly_transform(prim_polys(o->u.prim, l), mclip);
if (!is_backfacing(p, v3_unit(v3_scale(-1, poly_centr(p)))))
hither_clip(0, p, z_store, plist_free);
}
}
z = z_sort(z);
for (i = z->head; i != NULL; i = i->next) {
t = hpoly_polyxform(t, S(i), mdpy);
q = poly_wz_hpoly(q, W(i), t);
texture_wscale(W(i), T(i));
scan_spoly3(q, 2, texture_shadepaint,
texture_set(td,W(i),T(i),P(i),N(i),DU(i),DV(i),rc,M(i)));
}
img_write(s->img, "stdout", 0);
exit(0);
}
//--------------------------------------------------------------------
void
ccreg(char *in)
{
uint8_t hb, out;
if(fromhex(in+1, &hb, 1)) {
if(hb == 0x99) {
for(uint8_t i = 0; i < 0x30; i++) {
DH2(cc1100_readReg(i));
if((i&7) == 7)
DNL();
}
} else {
out = cc1100_readReg(hb);
DC('C'); // prefix
DH2(hb); // register number
DS_P( PSTR(" = ") );
DH2(out); // result, hex
DS_P( PSTR(" / ") );
DU(out,2); // result, decimal
DNL();
}
}
}
void dmx_func(char *in) {
uint8_t hb[4], d = 0;
if(in[1] == 'r') { // print latest record
memset( hb, 0, sizeof(hb) );
d = fromhex(in+2, hb, 1);
if(d) {
DH2( dmx_get_level( hb[0] ));
DNL();
}
} else if(in[1] == 'w') {
memset( hb, 0, sizeof(hb) );
d = fromhex(in+2, hb, 2);
if(d == 2) {
dmx_set_level( hb[0], hb[1] );
}
if(d > 0) {
DH2( dmx_get_level( hb[0] ));
DNL();
}
} else if(in[1] == 'c') {
DU( channel_count, 3 );
DNL();
}
}
void
fht_display_buf(uint8_t ptr[])
{
#ifdef FHTDEBUG
#warning FHT USB DEBUGGING IS ACTIVE
uint8_t odc = display_channel;
display_channel = DISPLAY_USB;
uint16_t *p = (uint16_t *)&ticks;
DU(*p, 5);
DC(' ');
DH2(fht80b_state);
DC(' ');
#else
if(!(tx_report & REP_FHTPROTO))
return;
#endif
DC('T');
for(uint8_t i = 0; i < 5; i++)
DH2(ptr[i]);
if(tx_report & REP_RSSI)
DH2(250);
DNL();
#ifdef FHTDEBUG
display_channel = odc;
#endif
}
//--------------------------------------------------------------------
void
ccreg(char *in)
{
uint8_t hb, out, addr;
if(in[1] == 'w' && fromhex(in+2, &addr, 1) && fromhex(in+4, &hb, 1)) {
cc1100_writeReg(addr, hb);
ccStrobe( CC1100_SCAL );
ccRX();
DH2(addr); DH2(hb); DNL();
} else if(fromhex(in+1, &hb, 1)) {
if(hb == 0x99) {
for(uint8_t i = 0; i < 0x30; i++) {
DH2(cc1100_readReg(i));
if((i&7) == 7)
DNL();
}
} else {
out = cc1100_readReg(hb);
DC('C'); // prefix
DH2(hb); // register number
DS_P( PSTR(" = ") );
DH2(out); // result, hex
DS_P( PSTR(" / ") );
DU(out,2); // result, decimal
DNL();
}
}
}
void
lcd_brightness(uint8_t hb)
{
int16_t brightness = erb((uint8_t*)EE_BRIGHTNESS);
if(hb == 0xFE) {
brightness += 0x20;
} else if (hb == 0xFD) {
brightness -= 0x20;
} else if (hb == 0xFC) {
//keep the eeprom value
} else {
brightness = hb;
}
if(brightness < 0) brightness = 0;
if(brightness > 255) brightness = 255;
ewb((uint8_t*)EE_BRIGHTNESS, brightness);
LCD_BL_PWM = brightness;
DS_P( PSTR("Brightns:") );
DU(brightness*100/255, 3);
DC('%');
DNL();
}
static void
display_ip4(uint8_t *a)
{
uint8_t cnt = 4;
while(cnt--) {
DU(*a++,1);
if(cnt)
DC('.');
}
}
static void
display_ee_ip4(uint8_t *a)
{
uint8_t cnt = 4;
while(cnt--) {
DU(erb(a++),1);
if(cnt)
DC('.');
}
}
void
read_eeprom(char *in)
{
uint8_t hb[2], d;
uint16_t addr;
#ifdef HAS_ETHERNET
if(in[1] == 'i') {
if(in[2] == 'm') { display_ee_mac(EE_MAC_ADDR);
} else if(in[2] == 'd') { DH2(erb(EE_USE_DHCP));
} else if(in[2] == 'a') { display_ee_ip4(EE_IP4_ADDR);
} else if(in[2] == 'n') { display_ee_ip4(EE_IP4_NETMASK);
} else if(in[2] == 'g') { display_ee_ip4(EE_IP4_GATEWAY);
} else if(in[2] == 'N') { display_ee_ip4(EE_IP4_NTPSERVER);
} else if(in[2] == 'o') { DH2(erb(EE_IP4_NTPOFFSET));
} else if(in[2] == 'p') {
DU(eeprom_read_word((uint16_t *)EE_IP4_TCPLINK_PORT), 0);
}
} else
#endif
if(in[1] == 'M') { display_ee_mac(EE_DUDETTE_MAC); }
else if(in[1] == 'P') { display_ee_bytes(EE_DUDETTE_PUBL, 16); }
else {
hb[0] = hb[1] = 0;
d = fromhex(in+1, hb, 2);
if(d == 2)
addr = (hb[0] << 8) | hb[1];
else
addr = hb[0];
d = erb((uint8_t *)addr);
DC('R'); // prefix
DH(addr,4); // register number
DS_P( PSTR(" = ") );
DH2(d); // result, hex
DS_P( PSTR(" / ") );
DU(d,2); // result, decimal
}
DNL();
}
void
set_txreport(char *in)
{
if(in[1] == 0) { // Report Value
DH2(tx_report);
DU(credit_10ms, 5);
DNL();
return;
}
fromhex(in+1, &tx_report, 1);
set_txrestore();
}
static void
rf_router_send(uint8_t addAddr)
{
#ifdef RFR_DEBUG
if(RFR_Buffer.buf[5] == 'T') nr_t++;
else if(RFR_Buffer.buf[5] == 'F') nr_f++;
else if(RFR_Buffer.buf[5] == 'E') nr_e++;
else if(RFR_Buffer.buf[5] == 'K') nr_k++;
else if(RFR_Buffer.buf[5] == 'H') nr_h++;
else nr_r++;
#endif
uint8_t buf[7], l = 1;
buf[0] = RF_ROUTER_PROTO_ID;
if(addAddr) {
tohex(rf_router_target, buf+1);
tohex(rf_router_myid, buf+3),
buf[5] = 'U';
l = 6;
}
rf_router_ping(); // 15ms
ccInitChip(EE_FASTRF_CFG); // 1.6ms
my_delay_ms(3); // 3ms: Found by trial and error
CC1100_ASSERT;
cc1100_sendbyte(CC1100_WRITE_BURST | CC1100_TXFIFO);
#ifdef RFR_USBECHO
uint8_t nbuf = RFR_Buffer.nbytes;
#endif
cc1100_sendbyte(RFR_Buffer.nbytes+l);
for(uint8_t i = 0; i < l; i++)
cc1100_sendbyte(buf[i]);
while(RFR_Buffer.nbytes)
cc1100_sendbyte(rb_get(&RFR_Buffer));
CC1100_DEASSERT;
ccTX();
rb_reset(&RFR_Buffer); // needed by FHT_compress
// Wait for the data to be sent
uint8_t maxwait = 20; // max 20ms
while((cc1100_readReg(CC1100_TXBYTES) & 0x7f) && maxwait--)
my_delay_ms(1);
set_txrestore();
#ifdef RFR_USBECHO
#warning RFR USB DEBUGGING IS ACTIVE
uint8_t odc = display_channel;
display_channel = DISPLAY_USB;
DC('.'); DU(nbuf, 2); DNL();
display_channel = odc;
#endif
}
void
dumppkt(void)
{
uint8_t *a = uip_buf;
DC('e');DC(' ');
DU(uip_len,5);
display_channel &= ~DISPLAY_TCP;
uint8_t ole = log_enabled;
log_enabled = 0;
DC(' '); DC('d'); DC(' '); display_mac(a); a+= sizeof(struct uip_eth_addr);
DC(' '); DC('s'); DC(' '); display_mac(a); a+= sizeof(struct uip_eth_addr);
DC(' '); DC('t'); DH2(*a++); DH2(*a++);
DNL();
if(eth_debug > 2)
dumpmem(a, uip_len - sizeof(struct uip_eth_hdr));
display_channel |= DISPLAY_TCP;
log_enabled = ole;
}
void getfreemem(char *unused) {
DC('B'); DU((uint16_t)__brkval, 5); DNL();
DC('S'); DU((uint16_t)__malloc_heap_start,5); DNL();
DC('E'); DU((uint16_t)__malloc_heap_end, 5); DNL();
DC('F'); DU((uint16_t)freeMem(), 5); DNL();
}
/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *
nrhs, real *dl, real *d, real *du, real *dlf, real *df, real *duf,
real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *
ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGTSVX uses the LU factorization to compute the solution to a real
system of linear equations A * X = B or A**T * X = B,
where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'N', the LU decomposition is used to factor the matrix A
as A = L * U, where L is a product of permutation and unit lower
bidiagonal matrices and U is upper triangular with nonzeros in
only the main diagonal and first two superdiagonals.
2. The factored form of A is used to estimate the condition number
of the matrix A. If the reciprocal of the condition number is
less than machine precision, steps 3 and 4 are skipped.
3. The system of equations is solved for X using the factored form
of A.
4. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of A has been
supplied on entry.
= 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
will not be modified.
= 'N': The matrix will be copied to DLF, DF, and DUF
and factored.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) REAL array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) REAL array, dimension (N)
The n diagonal elements of A.
DU (input) REAL array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then DLF is an input argument and on entry
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A as computed by SGTTRF.
If FACT = 'N', then DLF is an output argument and on exit
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A.
DF (input or output) REAL array, dimension (N)
If FACT = 'F', then DF is an input argument and on entry
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
If FACT = 'N', then DF is an output argument and on exit
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
DUF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then DUF is an input argument and on entry
contains the (n-1) elements of the first superdiagonal of U.
If FACT = 'N', then DUF is an output argument and on exit
contains the (n-1) elements of the first superdiagonal of U.
DU2 (input or output) REAL array, dimension (N-2)
If FACT = 'F', then DU2 is an input argument and on entry
contains the (n-2) elements of the second superdiagonal of
U.
If FACT = 'N', then DU2 is an output argument and on exit
contains the (n-2) elements of the second superdiagonal of
U.
IPIV (input or output) INTEGER array, dimension (N)
If FACT = 'F', then IPIV is an input argument and on entry
contains the pivot indices from the LU factorization of A as
computed by SGTTRF.
If FACT = 'N', then IPIV is an output argument and on exit
contains the pivot indices from the LU factorization of A;
row i of the matrix was interchanged with row IPIV(i).
IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
a row interchange was not required.
B (input) REAL array, dimension (LDB,NRHS)
The N-by-NRHS right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) REAL array, dimension (LDX,NRHS)
If INFO = 0, the N-by-NRHS solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A. If RCOND is less than the machine precision (in
particular, if RCOND = 0), the matrix is singular to working
precision. This condition is indicated by a return code of
INFO > 0, and the solution and error bounds are not computed.
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) REAL array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: U(i,i) is exactly zero. The factorization
has not been completed unless i = N, but the
factor U is exactly singular, so the solution
and error bounds could not be computed.
= N+1: RCOND is less than machine precision. The
factorization has been completed, but the
matrix is singular to working precision, and
the solution and error bounds have not been
computed.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
static char norm[1];
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal slangt_(char *, integer *, real *, real *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), sgtcon_(char *, integer *,
real *, real *, real *, real *, integer *, real *, real *, real *,
integer *, integer *);
static logical notran;
extern /* Subroutine */ int sgtrfs_(char *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sgttrf_(integer *, real *, real *, real *,
real *, integer *, integer *), sgttrs_(char *, integer *, integer
*, real *, real *, real *, real *, integer *, real *, integer *,
integer *);
#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define DLF(I) dlf[(I)-1]
#define DF(I) df[(I)-1]
#define DUF(I) duf[(I)-1]
#define DU2(I) du2[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
nofact = lsame_(fact, "N");
notran = lsame_(trans, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the LU factorization of A. */
scopy_(n, &D(1), &c__1, &DF(1), &c__1);
if (*n > 1) {
i__1 = *n - 1;
scopy_(&i__1, &DL(1), &c__1, &DLF(1), &c__1);
i__1 = *n - 1;
scopy_(&i__1, &DU(1), &c__1, &DUF(1), &c__1);
}
sgttrf_(n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, n, &DL(1), &D(1), &DU(1));
/* Compute the reciprocal of the condition number of A. */
sgtcon_(norm, n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &anorm,
rcond, &WORK(1), &IWORK(1), info);
/* Return if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
return 0;
}
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
sgttrs_(trans, n, nrhs, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &X(1,1), ldx, info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
sgtrfs_(trans, n, nrhs, &DL(1), &D(1), &DU(1), &DLF(1), &DF(1), &DUF(1), &
DU2(1), &IPIV(1), &B(1,1), ldb, &X(1,1), ldx, &FERR(1),
&BERR(1), &WORK(1), &IWORK(1), info);
return 0;
/* End of SGTSVX */
} /* sgtsvx_ */
/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, doublereal *dl,
doublereal *d, doublereal *du, doublereal *b, integer *ldb, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGTSV solves the equation
A*X = B,
where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
partial pivoting.
Note that the equation A'*X = B may be solved by interchanging the
order of the arguments DU and DL.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, DL must contain the (n-1) subdiagonal elements of
A.
On exit, DL is overwritten by the (n-2) elements of the
second superdiagonal of the upper triangular matrix U from
the LU factorization of A, in DL(1), ..., DL(n-2).
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, D must contain the diagonal elements of A.
On exit, D is overwritten by the n diagonal elements of U.
DU (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, DU must contain the (n-1) superdiagonal elements
of A.
On exit, DU is overwritten by the (n-1) elements of the first
superdiagonal of U.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, U(i,i) is exactly zero, and the solution
has not been computed. The factorization has not been
completed unless i = N.
=====================================================================
Parameter adjustments
Function Body */
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static doublereal temp, mult;
static integer j, k;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGTSV ", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
i__1 = *n - 1;
for (k = 1; k <= *n-1; ++k) {
if (DL(k) == 0.) {
/* Subdiagonal is zero, no elimination is required. */
if (D(k) == 0.) {
/* Diagonal is zero: set INFO = K and return; a u
nique
solution can not be found. */
*info = k;
return 0;
}
} else if ((d__1 = D(k), abs(d__1)) >= (d__2 = DL(k), abs(d__2))) {
/* No row interchange required */
mult = DL(k) / D(k);
D(k + 1) -= mult * DU(k);
i__2 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
B(k+1,j) -= mult * B(k,j);
/* L10: */
}
if (k < *n - 1) {
DL(k) = 0.;
}
} else {
/* Interchange rows K and K+1 */
mult = D(k) / DL(k);
D(k) = DL(k);
temp = D(k + 1);
D(k + 1) = DU(k) - mult * temp;
if (k < *n - 1) {
DL(k) = DU(k + 1);
DU(k + 1) = -mult * DL(k);
}
DU(k) = temp;
i__2 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
temp = B(k,j);
B(k,j) = B(k+1,j);
B(k+1,j) = temp - mult * B(k+1,j);
/* L20: */
}
}
/* L30: */
}
if (D(*n) == 0.) {
*info = *n;
return 0;
}
/* Back solve with the matrix U from the factorization. */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
B(*n,j) /= D(*n);
if (*n > 1) {
B(*n-1,j) = (B(*n-1,j) - DU(*n - 1) * B(*n,j)) / D(*n - 1);
}
for (k = *n - 2; k >= 1; --k) {
B(k,j) = (B(k,j) - DU(k) * B(k+1,j) - DL(k) * B(k+2,j)) / D(k);
/* L40: */
}
/* L50: */
}
return 0;
/* End of DGTSV */
} /* dgtsv_ */
doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex *
d, doublecomplex *du)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZLANGT returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
complex tridiagonal matrix A.
Description
===========
ZLANGT returns the value
ZLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in ZLANGT as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, ZLANGT is
set to zero.
DL (input) COMPLEX*16 array, dimension (N-1)
The (n-1) sub-diagonal elements of A.
D (input) COMPLEX*16 array, dimension (N)
The diagonal elements of A.
DU (input) COMPLEX*16 array, dimension (N-1)
The (n-1) super-diagonal elements of A.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define DU(I) du[(I)-1]
#define D(I) d[(I)-1]
#define DL(I) dl[(I)-1]
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = z_abs(&D(*n));
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&DL(i));
anorm = max(d__1,d__2);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&D(i));
anorm = max(d__1,d__2);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&DU(i));
anorm = max(d__1,d__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
if (*n == 1) {
anorm = z_abs(&D(1));
} else {
/* Computing MAX */
d__1 = z_abs(&D(1)) + z_abs(&DL(1)), d__2 = z_abs(&D(*n)) + z_abs(
&DU(*n - 1));
anorm = max(d__1,d__2);
i__1 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&D(i)) + z_abs(&DL(i)) + z_abs(&DU(
i - 1));
anorm = max(d__1,d__2);
/* L20: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
if (*n == 1) {
anorm = z_abs(&D(1));
} else {
/* Computing MAX */
d__1 = z_abs(&D(1)) + z_abs(&DU(1)), d__2 = z_abs(&D(*n)) + z_abs(
&DL(*n - 1));
anorm = max(d__1,d__2);
i__1 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&D(i)) + z_abs(&DU(i)) + z_abs(&DL(
i - 1));
anorm = max(d__1,d__2);
/* L30: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
zlassq_(n, &D(1), &c__1, &scale, &sum);
if (*n > 1) {
i__1 = *n - 1;
zlassq_(&i__1, &DL(1), &c__1, &scale, &sum);
i__1 = *n - 1;
zlassq_(&i__1, &DU(1), &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANGT */
} /* zlangt_ */
void
it_func(char *in)
{
if (in[1] == 't') {
fromdec (in+2, (uint8_t *)&it_interval);
DU(it_interval,0); DNL();
} else if (in[1] == 's') {
if (in[2] == 'r') { // Modify Repetition-counter
fromdec (in+3, (uint8_t *)&it_repetition);
DU(it_repetition,0); DNL();
#ifdef HAS_HOMEEASY
} else if (in[2] == 'h') { // HomeEasy
it_send (in, DATATYPE_HE);
} else if (in[2] == 'e') { // HomeEasy EU
it_send (in, DATATYPE_HEEU);
#endif
} else {
it_send (in, DATATYPE_IT); // Sending real data
} //sending real data
} else if (in[1] == 'r') { // Start of "Set Frequency" (f)
#ifdef HAS_ASKSIN
if (asksin_on) {
restore_asksin = 1;
asksin_on = 0;
}
#endif
#ifdef HAS_MORITZ
if (moritz_on) {
restore_moritz = 1;
moritz_on = 0;
}
#endif
it_tunein ();
intertechno_on = 1;
} else if (in[1] == 'f') { // Set Frequency
if (in[2] == '0' ) {
it_frequency[0] = 0x10;
it_frequency[1] = 0xb0;
it_frequency[2] = 0x71;
} else {
fromhex (in+2, it_frequency, 3);
}
DC('i');DC('f');DC(':');
DH2(it_frequency[0]);
DH2(it_frequency[1]);
DH2(it_frequency[2]);
DNL();
} else if (in[1] == 'x') { // Reset Frequency back to Eeprom value
if(0) { ;
#ifdef HAS_ASKSIN
} else if (restore_asksin) {
restore_asksin = 0;
rf_asksin_init();
asksin_on = 1;
ccRX();
#endif
#ifdef HAS_MORITZ
} else if (restore_moritz) {
restore_moritz = 0;
rf_moritz_init();
#endif
} else {
ccInitChip(EE_CC1100_CFG); // Set back to Eeprom Values
if(tx_report) { // Enable RX
ccRX();
} else {
ccStrobe(CC1100_SIDLE);
}
}
intertechno_on = 0;
}
}
int
main(void)
{
led_init();
#ifdef LED_RGB
led_off(LED_CHANNEL_GREEN);
led_off(LED_CHANNEL_RED);
led_off(LED_CHANNEL_BLUE);
#else
LED_ON();
#endif
spi_init();
OCR0A = 249; // Timer0: 0.008s = 8MHz/256/250 == 125Hz
TCCR0B = _BV(CS02);
TCCR0A = _BV(WGM01);
TIMSK0 = _BV(OCIE0A);
TCCR1A = 0;
TCCR1B = _BV(CS11) | _BV(WGM12); // Timer1: 1us = 8MHz/8
clock_prescale_set(clock_div_1);
MCUSR &= ~(1 << WDRF); // Enable the watchdog
uart_init( UART_BAUD_SELECT_DOUBLE_SPEED(UART_BAUD_RATE,F_CPU) );
input_handle_func = analyze_ttydata;
display_channel = DISPLAY_USB;
#ifdef LED_RGB
my_delay_ms(200);
led_on(LED_CHANNEL_RED);
my_delay_ms(200);
led_off(LED_CHANNEL_RED);
led_on(LED_CHANNEL_GREEN);
my_delay_ms(200);
led_off(LED_CHANNEL_GREEN);
led_on(LED_CHANNEL_BLUE);
my_delay_ms(200);
led_off(LED_CHANNEL_BLUE);
#else
LED_OFF();
#endif
sei();
/* start moritz function */
moritz_func("Zr\n");
for(;;) {
led_process(ticks);
uart_task();
Minute_Task();
rf_asksin_task();
rf_moritz_task();
if (rf_moritz_data_available()) {
DC('Z');
uint8_t *rf_data = (uint8_t*) &max_data;
for (uint8_t i=0; i<=*rf_data; i++) {
DH2( *rf_data++ );
}
DNL();
DS("length: ");
DU(max_data.length, 2);
DNL();
DS("msg count: ");
DU(max_data.message_count, 2);
DNL();
DS("msg type: ");
DU(max_data.message_type, 2);
DNL();
}
}
}
void
kopp_fc_init(void)
{
#ifdef ARM
AT91C_BASE_AIC->AIC_IDCR = 1 << CC1100_IN_PIO_ID; // disable INT - we'll poll...
CC1100_CS_BASE->PIO_PPUER = _BV(CC1100_CS_PIN); //Enable pullup
CC1100_CS_BASE->PIO_OER = _BV(CC1100_CS_PIN); //Enable output
CC1100_CS_BASE->PIO_PER = _BV(CC1100_CS_PIN); //Enable PIO control
#else
EIMSK &= ~_BV(CC1100_INT); // disable INT - we'll poll...
SET_BIT( CC1100_CS_DDR, CC1100_CS_PIN ); // CS as output
#endif
// Toggle chip select signal (why?)
CC1100_DEASSERT; // Chip Select InActiv
my_delay_us(30);
CC1100_ASSERT; // Chip Select Activ
my_delay_us(30);
CC1100_DEASSERT; // Chip Select InActiv
my_delay_us(45);
ccStrobe( CC1100_SRES ); // Send SRES command (Reset CC110x)
my_delay_us(100);
// load configuration (CC1100_Kopp_CFG[EE_CC1100_CFG_SIZE])
CC1100_ASSERT; // Chip Select Activ
cc1100_sendbyte( 0 | CC1100_WRITE_BURST );
for(uint8_t i = 0; i < EE_CC1100_CFG_SIZE; i++)
{
cc1100_sendbyte(__LPM(CC1100_Kopp_CFG+i));
}
CC1100_DEASSERT; // Chip Select InActiv
// If I don't missunderstand the code, in module cc1100.c the pa table is defined as
// 00 and C2 what means power off and max. power.
// so following code (setup PA table) is not needed ?
// did a trial, but does not work
// setup PA table (-> Remove as soon as transmitting ok?), table see cc1100.c
// this initializes the PA table with the table defined at EE_Prom
// which table will be taken depends on command "x00 .... x09"
// x00 means -10dbm pa ramping
// x09 means +10dBm no pa ramping (see cc1100.c) and commandref.html
#ifdef PrintOn //
DS_P(PSTR("PA Table values: "));
#endif
uint8_t *pa = EE_CC1100_PA; // EE_CC1100_PA+32 means max power???
CC1100_ASSERT;
cc1100_sendbyte( CC1100_PATABLE | CC1100_WRITE_BURST);
for (uint8_t i = 0; i < 8; i++)
{
#ifdef PrintOn //
DU(erb(pa),0); // ### Claus, mal sehen was im PA Table steht
DS_P(PSTR(" "));
#endif
cc1100_sendbyte(erb(pa++)); // fncollection.c "erb()"gibt einen EEPROM Wert zurück
}
#ifdef PrintOn
DS_P(PSTR("\r\n"));
#endif
CC1100_DEASSERT;
// Set CC_ON
ccStrobe( CC1100_SCAL); // Calibrate Synthesizer and turn it of. ##Claus brauchen wir das
my_delay_ms(1);
cc_on = 1;
kopp_fc_on = 1; //##Claus may be not needed in future (Tx Only)
checkFrequency();
}
/* Subroutine */ int cgtcon_(char *norm, integer *n, complex *dl, complex *d,
complex *du, complex *du2, integer *ipiv, real *anorm, real *rcond,
complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGTCON estimates the reciprocal of the condition number of a complex
tridiagonal matrix A using the LU factorization as computed by
CGTTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by CGTTRF.
D (input) COMPLEX array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) COMPLEX array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
ANORM (input) REAL
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer kase, kase1, i;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *), xerbla_(char *, integer *);
static real ainvnm;
static logical onenrm;
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
#define WORK(I) work[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define DU2(I) du2[(I)-1]
#define DU(I) du[(I)-1]
#define D(I) d[(I)-1]
#define DL(I) dl[(I)-1]
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.f) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
/* Check that D(1:N) is non-zero. */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
i__2 = i;
if (D(i).r == 0.f && D(i).i == 0.f) {
return 0;
}
/* L10: */
}
ainvnm = 0.f;
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L20:
clacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(U)*inv(L). */
cgttrs_("No transpose", n, &c__1, &DL(1), &D(1), &DU(1), &DU2(1),
&IPIV(1), &WORK(1), n, info);
} else {
/* Multiply by inv(L')*inv(U'). */
cgttrs_("Conjugate transpose", n, &c__1, &DL(1), &D(1), &DU(1), &
DU2(1), &IPIV(1), &WORK(1), n, info);
}
goto L20;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
return 0;
/* End of CGTCON */
} /* cgtcon_ */
/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs,
doublereal *dl, doublereal *d, doublereal *du, doublereal *dlf,
doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGTRFS improves the computed solution to a system of linear
equations when the coefficient matrix is tridiagonal, and provides
error bounds and backward error estimates for the solution.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of A.
DU (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by DGTTRF.
DF (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DUF (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) DOUBLE PRECISION array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DGTTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b18 = -1.;
static doublereal c_b19 = 1.;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer nz;
extern /* Subroutine */ int dlagtm_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1];
extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
static char transt[1];
static doublereal lstres, eps;
#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define DLF(I) dlf[(I)-1]
#define DF(I) df[(I)-1]
#define DUF(I) duf[(I)-1]
#define DU2(I) du2[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -13;
} else if (*ldx < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transn = 'T';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
dcopy_(n, &B(1,j), &c__1, &WORK(*n + 1), &c__1);
dlagtm_(trans, n, &c__1, &c_b18, &DL(1), &D(1), &DU(1), &X(1,j), ldx, &c_b19, &WORK(*n + 1), n);
/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
error bound. */
if (notran) {
if (*n == 1) {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2));
} else {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2)) + (d__3 = DU(1) * X(2,j), abs(d__3));
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1)) + (d__2 =
DL(i - 1) * X(i-1,j), abs(d__2)) + (
d__3 = D(i) * X(i,j), abs(d__3)) + (
d__4 = DU(i) * X(i+1,j), abs(d__4));
/* L30: */
}
WORK(*n) = (d__1 = B(*n,j), abs(d__1)) + (d__2 =
DL(*n - 1) * X(*n-1,j), abs(d__2)) + (
d__3 = D(*n) * X(*n,j), abs(d__3));
}
} else {
if (*n == 1) {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2));
} else {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2)) + (d__3 = DL(1) * X(2,j), abs(d__3));
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1)) + (d__2 =
DU(i - 1) * X(i-1,j), abs(d__2)) + (
d__3 = D(i) * X(i,j), abs(d__3)) + (
d__4 = DL(i) * X(i+1,j), abs(d__4));
/* L40: */
}
WORK(*n) = (d__1 = B(*n,j), abs(d__1)) + (d__2 =
DU(*n - 1) * X(*n-1,j), abs(d__2)) + (
d__3 = D(*n) * X(*n,j), abs(d__3));
}
}
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = WORK(*n + i), abs(d__1)) / WORK(i);
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = WORK(*n + i), abs(d__1)) + safe1) /
(WORK(i) + safe1);
s = max(d__2,d__3);
}
/* L50: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dgttrs_(trans, n, &c__1, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(
1), &WORK(*n + 1), n, info);
daxpy_(n, &c_b19, &WORK(*n + 1), &c__1, &X(1,j), &c__1)
;
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X
)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B
))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i);
} else {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i) + safe1;
}
/* L60: */
}
kase = 0;
L70:
dlacon_(n, &WORK((*n << 1) + 1), &WORK(*n + 1), &IWORK(1), &FERR(j), &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T). */
dgttrs_(transt, n, &c__1, &DLF(1), &DF(1), &DUF(1), &DU2(1), &
IPIV(1), &WORK(*n + 1), n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L80: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L90: */
}
dgttrs_(transn, n, &c__1, &DLF(1), &DF(1), &DUF(1), &DU2(1), &
IPIV(1), &WORK(*n + 1), n, info);
}
goto L70;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = X(i,j), abs(d__1));
lstres = max(d__2,d__3);
/* L100: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L110: */
}
return 0;
/* End of DGTRFS */
} /* dgtrfs_ */