home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / C and C++ / Science⁄Math / meschach / meschach3.shar < prev    next >
Encoding:
Text File  |  1994-06-07  |  176.0 KB  |  7,044 lines  |  [TEXT/ttxt]
  1. # to unbundle, sh this file (in an empty directory)
  2. echo sparse.c 1>&2
  3. sed >sparse.c <<'//GO.SYSIN DD sparse.c' 's/^-//'
  4. -
  5. -/**************************************************************************
  6. -**
  7. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  8. -**
  9. -**                 Meschach Library
  10. -** 
  11. -** This Meschach Library is provided "as is" without any express 
  12. -** or implied warranty of any kind with respect to this software. 
  13. -** In particular the authors shall not be liable for any direct, 
  14. -** indirect, special, incidental or consequential damages arising 
  15. -** in any way from use of the software.
  16. -** 
  17. -** Everyone is granted permission to copy, modify and redistribute this
  18. -** Meschach Library, provided:
  19. -**  1.  All copies contain this copyright notice.
  20. -**  2.  All modified copies shall carry a notice stating who
  21. -**      made the last modification and the date of such modification.
  22. -**  3.  No charge is made for this software or works derived from it.  
  23. -**      This clause shall not be construed as constraining other software
  24. -**      distributed on the same medium as this software, nor is a
  25. -**      distribution fee considered a charge.
  26. -**
  27. -***************************************************************************/
  28. -
  29. -/*
  30. -  Sparse matrix package
  31. -  See also: sparse.h, matrix.h
  32. -  */
  33. -
  34. -#include    <stdio.h>
  35. -#include    <math.h>
  36. -#include        <stdlib.h>
  37. -#include    "sparse.h"
  38. -
  39. -
  40. -static char    rcsid[] = "$Id: sparse.c,v 1.10 1994/03/08 05:46:07 des Exp $";
  41. -
  42. -#define    MINROWLEN    10
  43. -
  44. -
  45. -
  46. -/* sp_get_val -- returns the (i,j) entry of the sparse matrix A */
  47. -double    sp_get_val(A,i,j)
  48. -SPMAT    *A;
  49. -int    i, j;
  50. -{
  51. -   SPROW    *r;
  52. -   int    idx;
  53. -   
  54. -   if ( A == SMNULL )
  55. -     error(E_NULL,"sp_get_val");
  56. -   if ( i < 0 || i >= A->m || j < 0 || j >= A->n )
  57. -     error(E_SIZES,"sp_get_val");
  58. -   
  59. -   r = A->row+i;
  60. -   idx = sprow_idx(r,j);
  61. -   if ( idx < 0 )
  62. -     return 0.0;
  63. -   /* else */
  64. -   return r->elt[idx].val;
  65. -}
  66. -
  67. -/* sp_set_val -- sets the (i,j) entry of the sparse matrix A */
  68. -double    sp_set_val(A,i,j,val)
  69. -SPMAT    *A;
  70. -int    i, j;
  71. -double    val;
  72. -{
  73. -   SPROW    *r;
  74. -   int    idx, idx2, new_len;
  75. -   
  76. -   if ( A == SMNULL )
  77. -     error(E_NULL,"sp_set_val");
  78. -   if ( i < 0 || i >= A->m || j < 0 || j >= A->n )
  79. -     error(E_SIZES,"sp_set_val");
  80. -   
  81. -   r = A->row+i;
  82. -   idx = sprow_idx(r,j);
  83. -   /* printf("sp_set_val: idx = %d\n",idx); */
  84. -   if ( idx >= 0 )
  85. -   {    r->elt[idx].val = val;    return val;    }
  86. -   /* else */ if ( idx < -1 )
  87. -   {
  88. -      /* Note: this destroys the column & diag access paths */
  89. -      A->flag_col = A->flag_diag = FALSE;
  90. -      /* shift & insert new value */
  91. -      idx = -(idx+2);    /* this is the intended insertion index */
  92. -      if ( r->len >= r->maxlen )
  93. -      {
  94. -     r->len = r->maxlen;
  95. -     new_len = max(2*r->maxlen+1,5);
  96. -     if (mem_info_is_on()) {
  97. -        mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt),
  98. -                new_len*sizeof(row_elt));
  99. -     }
  100. -
  101. -     r->elt = RENEW(r->elt,new_len,row_elt);
  102. -     if ( ! r->elt )    /* can't allocate */
  103. -       error(E_MEM,"sp_set_val");
  104. -     r->maxlen = 2*r->maxlen+1;
  105. -      }
  106. -      for ( idx2 = r->len-1; idx2 >= idx; idx2-- )
  107. -    MEM_COPY((char *)(&(r->elt[idx2])),
  108. -         (char *)(&(r->elt[idx2+1])),sizeof(row_elt));
  109. -      /************************************************************
  110. -    if ( idx < r->len )
  111. -    MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])),
  112. -    (r->len-idx)*sizeof(row_elt));
  113. -    ************************************************************/
  114. -      r->len++;
  115. -      r->elt[idx].col = j;
  116. -      return r->elt[idx].val = val;
  117. -   }
  118. -   /* else -- idx == -1, error in index/matrix! */
  119. -   return 0.0;
  120. -}
  121. -
  122. -/* sp_mv_mlt -- sparse matrix/dense vector multiply
  123. -   -- result is in out, which is returned unless out==NULL on entry
  124. -   --  if out==NULL on entry then the result vector is created */
  125. -VEC    *sp_mv_mlt(A,x,out)
  126. -SPMAT    *A;
  127. -VEC    *x, *out;
  128. -{
  129. -   int    i, j_idx, m, n, max_idx;
  130. -   Real    sum, *x_ve;
  131. -   SPROW    *r;
  132. -   row_elt    *elts;
  133. -   
  134. -   if ( ! A || ! x )
  135. -     error(E_NULL,"sp_mv_mlt");
  136. -   if ( x->dim != A->n )
  137. -     error(E_SIZES,"sp_mv_mlt");
  138. -   if ( ! out || out->dim < A->m )
  139. -     out = v_resize(out,A->m);
  140. -   if ( out == x )
  141. -     error(E_INSITU,"sp_mv_mlt");
  142. -   m = A->m;    n = A->n;
  143. -   x_ve = x->ve;
  144. -   
  145. -   for ( i = 0; i < m; i++ )
  146. -   {
  147. -      sum = 0.0;
  148. -      r = &(A->row[i]);
  149. -      max_idx = r->len;
  150. -      elts    = r->elt;
  151. -      for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ )
  152. -    sum += elts->val*x_ve[elts->col];
  153. -      out->ve[i] = sum;
  154. -   }
  155. -   return out;
  156. -}
  157. -
  158. -/* sp_vm_mlt -- sparse matrix/dense vector multiply from left
  159. -   -- result is in out, which is returned unless out==NULL on entry
  160. -   -- if out==NULL on entry then result vector is created & returned */
  161. -VEC    *sp_vm_mlt(A,x,out)
  162. -SPMAT    *A;
  163. -VEC    *x, *out;
  164. -{
  165. -   int    i, j_idx, m, n, max_idx;
  166. -   Real    tmp, *x_ve, *out_ve;
  167. -   SPROW    *r;
  168. -   row_elt    *elts;
  169. -   
  170. -   if ( ! A || ! x )
  171. -     error(E_NULL,"sp_vm_mlt");
  172. -   if ( x->dim != A->m )
  173. -     error(E_SIZES,"sp_vm_mlt");
  174. -   if ( ! out || out->dim < A->n )
  175. -     out = v_resize(out,A->n);
  176. -   if ( out == x )
  177. -     error(E_INSITU,"sp_vm_mlt");
  178. -   
  179. -   m = A->m;    n = A->n;
  180. -   v_zero(out);
  181. -   x_ve = x->ve;    out_ve = out->ve;
  182. -   
  183. -   for ( i = 0; i < m; i++ )
  184. -   {
  185. -      r = A->row+i;
  186. -      max_idx = r->len;
  187. -      elts    = r->elt;
  188. -      tmp = x_ve[i];
  189. -      for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ )
  190. -    out_ve[elts->col] += elts->val*tmp;
  191. -   }
  192. -   
  193. -   return out;
  194. -}
  195. -
  196. -
  197. -/* sp_get -- get sparse matrix
  198. -   -- len is number of elements available for each row without
  199. -   allocating further memory */
  200. -SPMAT    *sp_get(m,n,maxlen)
  201. -int    m, n, maxlen;
  202. -{
  203. -   SPMAT    *A;
  204. -   SPROW    *rows;
  205. -   int    i;
  206. -   
  207. -   if ( m < 0 || n < 0 )
  208. -     error(E_NEG,"sp_get");
  209. -
  210. -   maxlen = max(maxlen,1);
  211. -   
  212. -   A = NEW(SPMAT);
  213. -   if ( ! A )        /* can't allocate */
  214. -     error(E_MEM,"sp_get");
  215. -   else if (mem_info_is_on()) {
  216. -      mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT));
  217. -      mem_numvar(TYPE_SPMAT,1);
  218. -   }
  219. -   /* fprintf(stderr,"Have SPMAT structure\n"); */
  220. -   
  221. -   A->row = rows = NEW_A(m,SPROW);
  222. -   if ( ! A->row )        /* can't allocate */
  223. -     error(E_MEM,"sp_get");
  224. -   else if (mem_info_is_on()) {
  225. -      mem_bytes(TYPE_SPMAT,0,m*sizeof(SPROW));
  226. -   }
  227. -   /* fprintf(stderr,"Have row structure array\n"); */
  228. -   
  229. -   A->start_row = NEW_A(n,int);
  230. -   A->start_idx = NEW_A(n,int);
  231. -   if ( ! A->start_row || ! A->start_idx )    /* can't allocate */
  232. -     error(E_MEM,"sp_get");
  233. -   else if (mem_info_is_on()) {
  234. -      mem_bytes(TYPE_SPMAT,0,2*n*sizeof(int));
  235. -   }
  236. -   for ( i = 0; i < n; i++ )
  237. -     A->start_row[i] = A->start_idx[i] = -1;
  238. -   /* fprintf(stderr,"Have start_row array\n"); */
  239. -   
  240. -   A->m = A->max_m = m;
  241. -   A->n = A->max_n = n;
  242. -   
  243. -   for ( i = 0; i < m; i++, rows++ )
  244. -   {
  245. -      rows->elt = NEW_A(maxlen,row_elt);
  246. -      if ( ! rows->elt )
  247. -    error(E_MEM,"sp_get");
  248. -      else if (mem_info_is_on()) {
  249. -     mem_bytes(TYPE_SPMAT,0,maxlen*sizeof(row_elt));
  250. -      }
  251. -      /* fprintf(stderr,"Have row %d element array\n",i); */
  252. -      rows->len = 0;
  253. -      rows->maxlen = maxlen;
  254. -      rows->diag = -1;
  255. -   }
  256. -   
  257. -   return A;
  258. -}
  259. -
  260. -
  261. -/* sp_free -- frees up the memory for a sparse matrix */
  262. -int    sp_free(A)
  263. -SPMAT    *A;
  264. -{
  265. -   SPROW    *r;
  266. -   int    i;
  267. -   
  268. -   if ( ! A )
  269. -     return -1;
  270. -   if ( A->start_row != (int *)NULL ) {
  271. -      if (mem_info_is_on()) {
  272. -     mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0);
  273. -      }
  274. -      free((char *)(A->start_row));
  275. -   }
  276. -   if ( A->start_idx != (int *)NULL ) {
  277. -      if (mem_info_is_on()) {
  278. -     mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0);
  279. -      }
  280. -      
  281. -      free((char *)(A->start_idx));
  282. -   }
  283. -   if ( ! A->row )
  284. -   {
  285. -      if (mem_info_is_on()) {
  286. -     mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0);
  287. -     mem_numvar(TYPE_SPMAT,-1);
  288. -      }
  289. -      
  290. -      free((char *)A);
  291. -      return 0;
  292. -   }
  293. -   for ( i = 0; i < A->m; i++ )
  294. -   {
  295. -      r = &(A->row[i]);
  296. -      if ( r->elt != (row_elt *)NULL ) {
  297. -     if (mem_info_is_on()) {
  298. -        mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt),0);
  299. -     }
  300. -     free((char *)(r->elt));
  301. -      }
  302. -   }
  303. -   
  304. -   if (mem_info_is_on()) {
  305. -      if (A->row) 
  306. -    mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW),0);
  307. -      mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0);
  308. -      mem_numvar(TYPE_SPMAT,-1);
  309. -   }
  310. -   
  311. -   free((char *)(A->row));
  312. -   free((char *)A);
  313. -
  314. -   return 0;
  315. -}
  316. -
  317. -
  318. -/* sp_copy -- constructs a copy of a given matrix
  319. -   -- note that the max_len fields (etc) are no larger in the copy
  320. -   than necessary
  321. -   -- result is returned */
  322. -SPMAT    *sp_copy(A)
  323. -SPMAT    *A;
  324. -{
  325. -   SPMAT    *out;
  326. -   SPROW    *row1, *row2;
  327. -   int    i;
  328. -   
  329. -   if ( A == SMNULL )
  330. -     error(E_NULL,"sp_copy");
  331. -   if ( ! (out=NEW(SPMAT)) )
  332. -     error(E_MEM,"sp_copy");
  333. -   else if (mem_info_is_on()) {
  334. -      mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT));
  335. -      mem_numvar(TYPE_SPMAT,1);
  336. -   }
  337. -   out->m = out->max_m = A->m;    out->n = out->max_n = A->n;
  338. -   
  339. -   /* set up rows */
  340. -   if ( ! (out->row=NEW_A(A->m,SPROW)) )
  341. -     error(E_MEM,"sp_copy");
  342. -   else if (mem_info_is_on()) {
  343. -      mem_bytes(TYPE_SPMAT,0,A->m*sizeof(SPROW));
  344. -   }
  345. -   for ( i = 0; i < A->m; i++ )
  346. -   {
  347. -      row1 = &(A->row[i]);
  348. -      row2 = &(out->row[i]);
  349. -      if ( ! (row2->elt=NEW_A(max(row1->len,3),row_elt)) )
  350. -    error(E_MEM,"sp_copy");
  351. -      else if (mem_info_is_on()) {
  352. -     mem_bytes(TYPE_SPMAT,0,max(row1->len,3)*sizeof(row_elt));
  353. -      }
  354. -      row2->len = row1->len;
  355. -      row2->maxlen = max(row1->len,3);
  356. -      row2->diag = row1->diag;
  357. -      MEM_COPY((char *)(row1->elt),(char *)(row2->elt),
  358. -           row1->len*sizeof(row_elt));
  359. -   }
  360. -   
  361. -   /* set up start arrays -- for column access */
  362. -   if ( ! (out->start_idx=NEW_A(A->n,int)) ||
  363. -       ! (out->start_row=NEW_A(A->n,int)) )
  364. -     error(E_MEM,"sp_copy");
  365. -   else if (mem_info_is_on()) {
  366. -      mem_bytes(TYPE_SPMAT,0,2*A->n*sizeof(int));
  367. -   }
  368. -   MEM_COPY((char *)(A->start_idx),(char *)(out->start_idx),
  369. -        A->n*sizeof(int));
  370. -   MEM_COPY((char *)(A->start_row),(char *)(out->start_row),
  371. -        A->n*sizeof(int));
  372. -   
  373. -   return out;
  374. -}
  375. -
  376. -/* sp_col_access -- set column access path; i.e. nxt_row, nxt_idx fields
  377. -   -- returns A */
  378. -SPMAT    *sp_col_access(A)
  379. -SPMAT    *A;
  380. -{
  381. -   int    i, j, j_idx, len, m, n;
  382. -   SPROW    *row;
  383. -   row_elt    *r_elt;
  384. -   int    *start_row, *start_idx;
  385. -   
  386. -   if ( A == SMNULL )
  387. -     error(E_NULL,"sp_col_access");
  388. -   
  389. -   m = A->m;    n = A->n;
  390. -   
  391. -   /* initialise start_row and start_idx */
  392. -   start_row = A->start_row;    start_idx = A->start_idx;
  393. -   for ( j = 0; j < n; j++ )
  394. -   {    *start_row++ = -1;    *start_idx++ = -1;    }
  395. -   
  396. -   start_row = A->start_row;    start_idx = A->start_idx;
  397. -   
  398. -   /* now work UP the rows, setting nxt_row, nxt_idx fields */
  399. -   for ( i = m-1; i >= 0; i-- )
  400. -   {
  401. -      row = &(A->row[i]);
  402. -      r_elt = row->elt;
  403. -      len   = row->len;
  404. -      for ( j_idx = 0; j_idx < len; j_idx++, r_elt++ )
  405. -      {
  406. -     j = r_elt->col;
  407. -     r_elt->nxt_row = start_row[j];
  408. -     r_elt->nxt_idx = start_idx[j];
  409. -     start_row[j] = i;
  410. -     start_idx[j] = j_idx;
  411. -      }
  412. -   }
  413. -   
  414. -   A->flag_col = TRUE;
  415. -   return A;
  416. -}
  417. -
  418. -/* sp_diag_access -- set diagonal access path(s) */
  419. -SPMAT    *sp_diag_access(A)
  420. -SPMAT    *A;
  421. -{
  422. -   int    i, m;
  423. -   SPROW    *row;
  424. -   
  425. -   if ( A == SMNULL )
  426. -     error(E_NULL,"sp_diag_access");
  427. -   
  428. -   m = A->m;
  429. -   
  430. -   row = A->row;
  431. -   for ( i = 0; i < m; i++, row++ )
  432. -     row->diag = sprow_idx(row,i);
  433. -   
  434. -   A->flag_diag = TRUE;
  435. -   
  436. -   return A;
  437. -}
  438. -
  439. -/* sp_m2dense -- convert a sparse matrix to a dense one */
  440. -MAT    *sp_m2dense(A,out)
  441. -SPMAT    *A;
  442. -MAT    *out;
  443. -{
  444. -   int    i, j_idx;
  445. -   SPROW    *row;
  446. -   row_elt    *elt;
  447. -   
  448. -   if ( ! A )
  449. -     error(E_NULL,"sp_m2dense");
  450. -   if ( ! out || out->m < A->m || out->n < A->n )
  451. -     out = m_get(A->m,A->n);
  452. -   
  453. -   m_zero(out);
  454. -   for ( i = 0; i < A->m; i++ )
  455. -   {
  456. -      row = &(A->row[i]);
  457. -      elt = row->elt;
  458. -      for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ )
  459. -    out->me[i][elt->col] = elt->val;
  460. -   }
  461. -   
  462. -   return out;
  463. -}
  464. -
  465. -
  466. -/*  C = A+B, can be in situ */
  467. -SPMAT *sp_add(A,B,C)
  468. -SPMAT *A, *B, *C;
  469. -{
  470. -   int i, in_situ;
  471. -   SPROW *rc;
  472. -   static SPROW *tmp;
  473. -
  474. -   if ( ! A || ! B )
  475. -     error(E_NULL,"sp_add");
  476. -   if ( A->m != B->m || A->n != B->n )
  477. -     error(E_SIZES,"sp_add");
  478. -   if (C == A || C == B)
  479. -     in_situ = TRUE;
  480. -   else in_situ = FALSE;
  481. -
  482. -   if ( ! C )
  483. -     C = sp_get(A->m,A->n,5);
  484. -   else {
  485. -      if ( C->m != A->m || C->n != A->n  )
  486. -    error(E_SIZES,"sp_add");
  487. -      if (!in_situ) sp_zero(C);
  488. -   }
  489. -
  490. -   if (tmp == (SPROW *)NULL && in_situ) {
  491. -      tmp = sprow_get(MINROWLEN);
  492. -      MEM_STAT_REG(tmp,TYPE_SPROW);
  493. -   }
  494. -
  495. -   if (in_situ)
  496. -     for (i=0; i < A->m; i++) {
  497. -    rc = &(C->row[i]);
  498. -    sprow_add(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW);
  499. -    sprow_resize(rc,tmp->len,TYPE_SPMAT);
  500. -    MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt));
  501. -    rc->len = tmp->len;
  502. -     }
  503. -   else
  504. -     for (i=0; i < A->m; i++) {
  505. -    sprow_add(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT);
  506. -     }
  507. -
  508. -   C->flag_col = C->flag_diag = FALSE;
  509. -
  510. -   return C;
  511. -}
  512. -
  513. -/*  C = A-B, cannot be in situ */
  514. -SPMAT *sp_sub(A,B,C)
  515. -SPMAT *A, *B, *C;
  516. -{
  517. -   int i, in_situ;
  518. -   SPROW *rc;
  519. -   static SPROW *tmp;
  520. -   
  521. -   if ( ! A || ! B )
  522. -     error(E_NULL,"sp_sub");
  523. -   if ( A->m != B->m || A->n != B->n )
  524. -     error(E_SIZES,"sp_sub");
  525. -   if (C == A || C == B)
  526. -     in_situ = TRUE;
  527. -   else in_situ = FALSE;
  528. -
  529. -   if ( ! C )
  530. -     C = sp_get(A->m,A->n,5);
  531. -   else {
  532. -      if ( C->m != A->m || C->n != A->n  )
  533. -    error(E_SIZES,"sp_sub");
  534. -      if (!in_situ) sp_zero(C);
  535. -   }
  536. -
  537. -   if (tmp == (SPROW *)NULL && in_situ) {
  538. -      tmp = sprow_get(MINROWLEN);
  539. -      MEM_STAT_REG(tmp,TYPE_SPROW);
  540. -   }
  541. -
  542. -   if (in_situ)
  543. -     for (i=0; i < A->m; i++) {
  544. -    rc = &(C->row[i]);
  545. -    sprow_sub(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW);
  546. -    sprow_resize(rc,tmp->len,TYPE_SPMAT);
  547. -    MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt));
  548. -    rc->len = tmp->len;
  549. -     }
  550. -   else
  551. -     for (i=0; i < A->m; i++) {
  552. -    sprow_sub(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT);
  553. -     }
  554. -
  555. -   C->flag_col = C->flag_diag = FALSE;
  556. -   
  557. -   return C;
  558. -}
  559. -
  560. -/*  C = A+alpha*B, cannot be in situ */
  561. -SPMAT *sp_mltadd(A,B,alpha,C)
  562. -SPMAT *A, *B, *C;
  563. -double alpha;
  564. -{
  565. -   int i, in_situ;
  566. -   SPROW *rc;
  567. -   static SPROW *tmp;
  568. -
  569. -   if ( ! A || ! B )
  570. -     error(E_NULL,"sp_mltadd");
  571. -   if ( A->m != B->m || A->n != B->n )
  572. -     error(E_SIZES,"sp_mltadd");
  573. -   if (C == A || C == B)
  574. -     in_situ = TRUE;
  575. -   else in_situ = FALSE;
  576. -
  577. -   if ( ! C )
  578. -     C = sp_get(A->m,A->n,5);
  579. -   else {
  580. -      if ( C->m != A->m || C->n != A->n  )
  581. -    error(E_SIZES,"sp_mltadd");
  582. -      if (!in_situ) sp_zero(C);
  583. -   }
  584. -
  585. -   if (tmp == (SPROW *)NULL && in_situ) {
  586. -      tmp = sprow_get(MINROWLEN);
  587. -      MEM_STAT_REG(tmp,TYPE_SPROW);
  588. -   }
  589. -
  590. -   if (in_situ)
  591. -     for (i=0; i < A->m; i++) {
  592. -    rc = &(C->row[i]);
  593. -    sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0,tmp,TYPE_SPROW);
  594. -    sprow_resize(rc,tmp->len,TYPE_SPMAT);
  595. -    MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt));
  596. -    rc->len = tmp->len;
  597. -     }
  598. -   else
  599. -     for (i=0; i < A->m; i++) {
  600. -    sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0,
  601. -             &(C->row[i]),TYPE_SPMAT);
  602. -     }
  603. -   
  604. -   C->flag_col = C->flag_diag = FALSE;
  605. -   
  606. -   return C;
  607. -}
  608. -
  609. -
  610. -
  611. -/*  B = alpha*A, can be in situ */
  612. -SPMAT *sp_smlt(A,alpha,B)
  613. -SPMAT *A, *B;
  614. -double alpha;
  615. -{
  616. -   int i;
  617. -
  618. -   if ( ! A )
  619. -     error(E_NULL,"sp_smlt");
  620. -   if ( ! B )
  621. -     B = sp_get(A->m,A->n,5);
  622. -   else
  623. -     if ( A->m != B->m || A->n != B->n )
  624. -       error(E_SIZES,"sp_smlt");
  625. -
  626. -   for (i=0; i < A->m; i++) {
  627. -      sprow_smlt(&(A->row[i]),alpha,0,&(B->row[i]),TYPE_SPMAT);
  628. -   }
  629. -   return B;
  630. -}
  631. -
  632. -
  633. -
  634. -/* sp_zero -- zero all the (represented) elements of a sparse matrix */
  635. -SPMAT    *sp_zero(A)
  636. -SPMAT    *A;
  637. -{
  638. -   int    i, idx, len;
  639. -   row_elt    *elt;
  640. -   
  641. -   if ( ! A )
  642. -     error(E_NULL,"sp_zero");
  643. -   
  644. -   for ( i = 0; i < A->m; i++ )
  645. -   {
  646. -      elt = A->row[i].elt;
  647. -      len = A->row[i].len;
  648. -      for ( idx = 0; idx < len; idx++ )
  649. -    (*elt++).val = 0.0;
  650. -   }
  651. -   
  652. -   return A;
  653. -}
  654. -
  655. -/* sp_copy2 -- copy sparse matrix (type 2) 
  656. -   -- keeps structure of the OUT matrix */
  657. -SPMAT    *sp_copy2(A,OUT)
  658. -SPMAT    *A, *OUT;
  659. -{
  660. -   int    i /* , idx, len1, len2 */;
  661. -   SPROW    *r1, *r2;
  662. -   static SPROW    *scratch = (SPROW *)NULL;
  663. -   /* row_elt    *e1, *e2; */
  664. -   
  665. -   if ( ! A )
  666. -     error(E_NULL,"sp_copy2");
  667. -   if ( ! OUT )
  668. -     OUT = sp_get(A->m,A->n,10);
  669. -   if ( ! scratch ) {
  670. -      scratch = sprow_xpd(scratch,MINROWLEN,TYPE_SPROW);
  671. -      MEM_STAT_REG(scratch,TYPE_SPROW);
  672. -   }
  673. -
  674. -   if ( OUT->m < A->m )
  675. -   {
  676. -      if (mem_info_is_on()) {
  677. -     mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW),
  678. -              A->m*sizeof(SPROW));
  679. -      }
  680. -
  681. -      OUT->row = RENEW(OUT->row,A->m,SPROW);
  682. -      if ( ! OUT->row )
  683. -    error(E_MEM,"sp_copy2");
  684. -      
  685. -      for ( i = OUT->m; i < A->m; i++ )
  686. -      {
  687. -     OUT->row[i].elt = NEW_A(MINROWLEN,row_elt);
  688. -     if ( ! OUT->row[i].elt )
  689. -       error(E_MEM,"sp_copy2");
  690. -     else if (mem_info_is_on()) {
  691. -        mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt));
  692. -     }
  693. -     
  694. -     OUT->row[i].maxlen = MINROWLEN;
  695. -     OUT->row[i].len = 0;
  696. -      }
  697. -      OUT->m = A->m;
  698. -   }
  699. -   
  700. -   OUT->flag_col = OUT->flag_diag = FALSE;
  701. -   /* sp_zero(OUT); */
  702. -
  703. -   for ( i = 0; i < A->m; i++ )
  704. -   {
  705. -      r1 = &(A->row[i]);    r2 = &(OUT->row[i]);
  706. -      sprow_copy(r1,r2,scratch,TYPE_SPROW);
  707. -      if ( r2->maxlen < scratch->len )
  708. -    sprow_xpd(r2,scratch->len,TYPE_SPMAT);
  709. -      MEM_COPY((char *)(scratch->elt),(char *)(r2->elt),
  710. -           scratch->len*sizeof(row_elt));
  711. -      r2->len = scratch->len;
  712. -      /*******************************************************
  713. -    e1 = r1->elt;        e2 = r2->elt;
  714. -    len1 = r1->len;        len2 = r2->len;
  715. -    for ( idx = 0; idx < len2; idx++, e2++ )
  716. -    e2->val = 0.0;
  717. -    for ( idx = 0; idx < len1; idx++, e1++ )
  718. -    sprow_set_val(r2,e1->col,e1->val);
  719. -    *******************************************************/
  720. -   }
  721. -
  722. -   sp_col_access(OUT);
  723. -   return OUT;
  724. -}
  725. -
  726. -/* sp_resize -- resize a sparse matrix
  727. -   -- don't destroying any contents if possible
  728. -   -- returns resized matrix */
  729. -SPMAT    *sp_resize(A,m,n)
  730. -SPMAT    *A;
  731. -int    m, n;
  732. -{
  733. -   int    i, len;
  734. -   SPROW    *r;
  735. -   
  736. -   if (m < 0 || n < 0)
  737. -     error(E_NEG,"sp_resize");
  738. -
  739. -   if ( ! A )
  740. -     return sp_get(m,n,10);
  741. -
  742. -   if (m == A->m && n == A->n)
  743. -     return A;
  744. -
  745. -   if ( m <= A->max_m )
  746. -   {
  747. -      for ( i = A->m; i < m; i++ )
  748. -    A->row[i].len = 0;
  749. -      A->m = m;
  750. -   }
  751. -   else
  752. -   {
  753. -      if (mem_info_is_on()) {
  754. -     mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW),
  755. -             m*sizeof(SPROW));
  756. -      }
  757. -
  758. -      A->row = RENEW(A->row,(unsigned)m,SPROW);
  759. -      if ( ! A->row )
  760. -    error(E_MEM,"sp_resize");
  761. -      for ( i = A->m; i < m; i++ )
  762. -      {
  763. -     if ( ! (A->row[i].elt = NEW_A(MINROWLEN,row_elt)) )
  764. -       error(E_MEM,"sp_resize");
  765. -     else if (mem_info_is_on()) {
  766. -        mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt));
  767. -     }
  768. -     A->row[i].len = 0;    A->row[i].maxlen = MINROWLEN;
  769. -      }
  770. -      A->m = A->max_m = m;
  771. -   }
  772. -
  773. -   /* update number of rows */
  774. -   A->n = n;
  775. -
  776. -   /* do we need to increase the size of start_idx[] and start_row[] ? */
  777. -   if ( n > A->max_n )
  778. -   {    /* only have to update the start_idx & start_row arrays */
  779. -      if (mem_info_is_on())
  780. -      {
  781. -      mem_bytes(TYPE_SPMAT,2*A->max_n*sizeof(int),
  782. -            2*n*sizeof(int));
  783. -      }
  784. -
  785. -      A->start_row = RENEW(A->start_row,(unsigned)n,int);
  786. -      A->start_idx = RENEW(A->start_idx,(unsigned)n,int);
  787. -      if ( ! A->start_row || ! A->start_idx )
  788. -    error(E_MEM,"sp_resize");
  789. -      A->max_n = n;    /* ...and update max_n */
  790. -
  791. -      return A;
  792. -   }
  793. -
  794. -   if ( n <= A->n )
  795. -       /* make sure that all rows are truncated just before column n */
  796. -       for ( i = 0; i < A->m; i++ )
  797. -       {
  798. -       r = &(A->row[i]);
  799. -       len = sprow_idx(r,n);
  800. -       if ( len < 0 )
  801. -           len = -(len+2);
  802. -       if ( len < 0 )
  803. -           error(E_MEM,"sp_resize");
  804. -       r->len = len;
  805. -       }
  806. -   
  807. -   return A;
  808. -}
  809. -
  810. -
  811. -/* sp_compact -- removes zeros and near-zeros from a sparse matrix */
  812. -SPMAT    *sp_compact(A,tol)
  813. -SPMAT    *A;
  814. -double    tol;
  815. -{
  816. -   int    i, idx1, idx2;
  817. -   SPROW    *r;
  818. -   row_elt    *elt1, *elt2;
  819. -   
  820. -   if (  ! A )
  821. -     error(E_NULL,"sp_compact");
  822. -   if ( tol < 0.0 )
  823. -     error(E_RANGE,"sp_compact");
  824. -   
  825. -   A->flag_col = A->flag_diag = FALSE;
  826. -   
  827. -   for ( i = 0; i < A->m; i++ )
  828. -   {
  829. -      r = &(A->row[i]);
  830. -      elt1 = elt2 = r->elt;
  831. -      idx1 = idx2 = 0;
  832. -      while ( idx1 < r->len )
  833. -      {
  834. -     /* printf("# sp_compact: idx1 = %d, idx2 = %d\n",idx1,idx2); */
  835. -     if ( fabs(elt1->val) <= tol )
  836. -     {    idx1++;    elt1++;    continue;    }
  837. -     if ( elt1 != elt2 )
  838. -       MEM_COPY(elt1,elt2,sizeof(row_elt));
  839. -     idx1++;    elt1++;
  840. -     idx2++;    elt2++;
  841. -      }
  842. -      r->len = idx2;
  843. -   }
  844. -   
  845. -   return A;
  846. -}
  847. -
  848. -/* varying number of arguments */
  849. -
  850. -#ifdef ANSI_C
  851. -
  852. -/* To allocate memory to many arguments. 
  853. -   The function should be called:
  854. -   sp_get_vars(m,n,deg,&x,&y,&z,...,NULL);
  855. -   where 
  856. -     int m,n,deg;
  857. -     SPMAT *x, *y, *z,...;
  858. -     The last argument should be NULL ! 
  859. -     m x n is the dimension of matrices x,y,z,...
  860. -     returned value is equal to the number of allocated variables
  861. -*/
  862. -
  863. -int sp_get_vars(int m,int n,int deg,...) 
  864. -{
  865. -   va_list ap;
  866. -   int i=0;
  867. -   SPMAT **par;
  868. -   
  869. -   va_start(ap, deg);
  870. -   while (par = va_arg(ap,SPMAT **)) {   /* NULL ends the list*/
  871. -      *par = sp_get(m,n,deg);
  872. -      i++;
  873. -   } 
  874. -
  875. -   va_end(ap);
  876. -   return i;
  877. -}
  878. -
  879. -
  880. -/* To resize memory for many arguments. 
  881. -   The function should be called:
  882. -   sp_resize_vars(m,n,&x,&y,&z,...,NULL);
  883. -   where 
  884. -     int m,n;
  885. -     SPMAT *x, *y, *z,...;
  886. -     The last argument should be NULL ! 
  887. -     m X n is the resized dimension of matrices x,y,z,...
  888. -     returned value is equal to the number of allocated variables.
  889. -     If one of x,y,z,.. arguments is NULL then memory is allocated to this 
  890. -     argument. 
  891. -*/
  892. -  
  893. -int sp_resize_vars(int m,int n,...) 
  894. -{
  895. -   va_list ap;
  896. -   int i=0;
  897. -   SPMAT **par;
  898. -   
  899. -   va_start(ap, n);
  900. -   while (par = va_arg(ap,SPMAT **)) {   /* NULL ends the list*/
  901. -      *par = sp_resize(*par,m,n);
  902. -      i++;
  903. -   } 
  904. -
  905. -   va_end(ap);
  906. -   return i;
  907. -}
  908. -
  909. -/* To deallocate memory for many arguments. 
  910. -   The function should be called:
  911. -   sp_free_vars(&x,&y,&z,...,NULL);
  912. -   where 
  913. -     SPMAT *x, *y, *z,...;
  914. -     The last argument should be NULL ! 
  915. -     There must be at least one not NULL argument.
  916. -     returned value is equal to the number of allocated variables.
  917. -     Returned value of x,y,z,.. is VNULL.
  918. -*/
  919. -
  920. -int sp_free_vars(SPMAT **va,...)
  921. -{
  922. -   va_list ap;
  923. -   int i=1;
  924. -   SPMAT **par;
  925. -   
  926. -   sp_free(*va);
  927. -   *va = (SPMAT *) NULL;
  928. -   va_start(ap, va);
  929. -   while (par = va_arg(ap,SPMAT **)) {   /* NULL ends the list*/
  930. -      sp_free(*par); 
  931. -      *par = (SPMAT *)NULL;
  932. -      i++;
  933. -   } 
  934. -
  935. -   va_end(ap);
  936. -   return i;
  937. -}
  938. -
  939. -
  940. -#elif VARARGS
  941. -
  942. -/* To allocate memory to many arguments. 
  943. -   The function should be called:
  944. -   sp_get_vars(m,n,deg,&x,&y,&z,...,NULL);
  945. -   where 
  946. -     int m,n,deg;
  947. -     SPMAT *x, *y, *z,...;
  948. -     The last argument should be NULL ! 
  949. -     m x n is the dimension of matrices x,y,z,...
  950. -     returned value is equal to the number of allocated variables
  951. -*/
  952. -
  953. -int sp_get_vars(va_alist) va_dcl
  954. -{
  955. -   va_list ap;
  956. -   int i=0, m, n, deg;
  957. -   SPMAT **par;
  958. -   
  959. -   va_start(ap);
  960. -   m = va_arg(ap,int);
  961. -   n = va_arg(ap,int);
  962. -   deg = va_arg(ap,int);
  963. -   while (par = va_arg(ap,SPMAT **)) {   /* NULL ends the list*/
  964. -      *par = sp_get(m,n,deg);
  965. -      i++;
  966. -   } 
  967. -
  968. -   va_end(ap);
  969. -   return i;
  970. -}
  971. -
  972. -
  973. -/* To resize memory for many arguments. 
  974. -   The function should be called:
  975. -   sp_resize_vars(m,n,&x,&y,&z,...,NULL);
  976. -   where 
  977. -     int m,n;
  978. -     SPMAT *x, *y, *z,...;
  979. -     The last argument should be NULL ! 
  980. -     m X n is the resized dimension of matrices x,y,z,...
  981. -     returned value is equal to the number of allocated variables.
  982. -     If one of x,y,z,.. arguments is NULL then memory is allocated to this 
  983. -     argument. 
  984. -*/
  985. -
  986. -int sp_resize_vars(va_alist) va_dcl
  987. -{
  988. -   va_list ap;
  989. -   int i=0, m, n;
  990. -   SPMAT **par;
  991. -   
  992. -   va_start(ap);
  993. -   m = va_arg(ap,int);
  994. -   n = va_arg(ap,int);
  995. -   while (par = va_arg(ap,SPMAT **)) {   /* NULL ends the list*/
  996. -      *par = sp_resize(*par,m,n);
  997. -      i++;
  998. -   } 
  999. -
  1000. -   va_end(ap);
  1001. -   return i;
  1002. -}
  1003. -
  1004. -
  1005. -
  1006. -/* To deallocate memory for many arguments. 
  1007. -   The function should be called:
  1008. -   sp_free_vars(&x,&y,&z,...,NULL);
  1009. -   where 
  1010. -     SPMAT *x, *y, *z,...;
  1011. -     The last argument should be NULL ! 
  1012. -     There must be at least one not NULL argument.
  1013. -     returned value is equal to the number of allocated variables.
  1014. -     Returned value of x,y,z,.. is VNULL.
  1015. -*/
  1016. -
  1017. -int sp_free_vars(va_alist) va_dcl
  1018. -{
  1019. -   va_list ap;
  1020. -   int i=0;
  1021. -   SPMAT **par;
  1022. -   
  1023. -   va_start(ap);
  1024. -   while (par = va_arg(ap,SPMAT **)) {   /* NULL ends the list*/
  1025. -      sp_free(*par); 
  1026. -      *par = (SPMAT *)NULL;
  1027. -      i++;
  1028. -   } 
  1029. -
  1030. -   va_end(ap);
  1031. -   return i;
  1032. -}
  1033. -
  1034. -
  1035. -
  1036. -#endif
  1037. -
  1038. //GO.SYSIN DD sparse.c
  1039. echo sprow.c 1>&2
  1040. sed >sprow.c <<'//GO.SYSIN DD sprow.c' 's/^-//'
  1041. -
  1042. -/**************************************************************************
  1043. -**
  1044. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  1045. -**
  1046. -**                 Meschach Library
  1047. -** 
  1048. -** This Meschach Library is provided "as is" without any express 
  1049. -** or implied warranty of any kind with respect to this software. 
  1050. -** In particular the authors shall not be liable for any direct, 
  1051. -** indirect, special, incidental or consequential damages arising 
  1052. -** in any way from use of the software.
  1053. -** 
  1054. -** Everyone is granted permission to copy, modify and redistribute this
  1055. -** Meschach Library, provided:
  1056. -**  1.  All copies contain this copyright notice.
  1057. -**  2.  All modified copies shall carry a notice stating who
  1058. -**      made the last modification and the date of such modification.
  1059. -**  3.  No charge is made for this software or works derived from it.  
  1060. -**      This clause shall not be construed as constraining other software
  1061. -**      distributed on the same medium as this software, nor is a
  1062. -**      distribution fee considered a charge.
  1063. -**
  1064. -***************************************************************************/
  1065. -
  1066. -/*
  1067. -  Sparse rows package
  1068. -  See also: sparse.h, matrix.h
  1069. -  */
  1070. -
  1071. -#include    <stdio.h>
  1072. -#include    <math.h>
  1073. -#include        <stdlib.h>
  1074. -#include    "sparse.h"
  1075. -
  1076. -
  1077. -static char    rcsid[] = "$Id: sprow.c,v 1.1 1994/01/13 05:35:36 des Exp $";
  1078. -
  1079. -#define    MINROWLEN    10
  1080. -
  1081. -
  1082. -/* sprow_dump - prints relevant information about the sparse row r */
  1083. -
  1084. -void sprow_dump(fp,r)
  1085. -FILE *fp;
  1086. -SPROW *r;
  1087. -{
  1088. -   int  j_idx;
  1089. -   row_elt *elts;
  1090. -   
  1091. -   fprintf(fp,"SparseRow dump:\n");
  1092. -   if ( ! r )
  1093. -   {       fprintf(fp,"*** NULL row ***\n");   return; }
  1094. -   
  1095. -   fprintf(fp,"row: len = %d, maxlen = %d, diag idx = %d\n",
  1096. -       r->len,r->maxlen,r->diag);
  1097. -   fprintf(fp,"element list @ 0x%lx\n",(long)(r->elt));
  1098. -   if ( ! r->elt )
  1099. -   {
  1100. -      fprintf(fp,"*** NULL element list ***\n");
  1101. -      return;
  1102. -   }
  1103. -   elts = r->elt;
  1104. -   for ( j_idx = 0; j_idx < r->len; j_idx++, elts++ )
  1105. -     fprintf(fp,"Col: %d, Val: %g, nxt_row = %d, nxt_idx = %d\n",
  1106. -         elts->col,elts->val,elts->nxt_row,elts->nxt_idx);
  1107. -   fprintf(fp,"\n");
  1108. -}
  1109. -
  1110. -
  1111. -/* sprow_idx -- get index into row for a given column in a given row
  1112. -   -- return -1 on error
  1113. -   -- return -(idx+2) where idx is index to insertion point */
  1114. -int    sprow_idx(r,col)
  1115. -SPROW    *r;
  1116. -int    col;
  1117. -{
  1118. -   register int        lo, hi, mid;
  1119. -   int            tmp;
  1120. -   register row_elt    *r_elt;
  1121. -   
  1122. -   /*******************************************
  1123. -     if ( r == (SPROW *)NULL )
  1124. -     return -1;
  1125. -     if ( col < 0 )
  1126. -     return -1;
  1127. -     *******************************************/
  1128. -   
  1129. -   r_elt = r->elt;
  1130. -   if ( r->len <= 0 )
  1131. -     return -2;
  1132. -   
  1133. -   /* try the hint */
  1134. -   /* if ( hint >= 0 && hint < r->len && r_elt[hint].col == col )
  1135. -      return hint; */
  1136. -   
  1137. -   /* otherwise use binary search... */
  1138. -   /* code from K&R Ch. 6, p. 125 */
  1139. -   lo = 0;        hi = r->len - 1;    mid = lo;
  1140. -   while ( lo <= hi )
  1141. -   {
  1142. -      mid = (hi + lo)/2;
  1143. -      if ( (tmp=r_elt[mid].col-col) > 0 )
  1144. -    hi = mid-1;
  1145. -      else if ( tmp < 0 )
  1146. -    lo = mid+1;
  1147. -      else /* tmp == 0 */
  1148. -    return mid;
  1149. -   }
  1150. -   tmp = r_elt[mid].col - col;
  1151. -   
  1152. -   if ( tmp > 0 )
  1153. -     return -(mid+2);    /* insert at mid   */
  1154. -   else /* tmp < 0 */
  1155. -     return -(mid+3);    /* insert at mid+1 */
  1156. -}
  1157. -
  1158. -
  1159. -/* sprow_get -- gets, initialises and returns a SPROW structure
  1160. -   -- max. length is maxlen */
  1161. -SPROW    *sprow_get(maxlen)
  1162. -int    maxlen;
  1163. -{
  1164. -   SPROW    *r;
  1165. -   
  1166. -   if ( maxlen < 0 )
  1167. -     error(E_NEG,"sprow_get");
  1168. -
  1169. -   r = NEW(SPROW);
  1170. -   if ( ! r )
  1171. -     error(E_MEM,"sprow_get");
  1172. -   else if (mem_info_is_on()) {
  1173. -      mem_bytes(TYPE_SPROW,0,sizeof(SPROW));
  1174. -      mem_numvar(TYPE_SPROW,1);
  1175. -   }
  1176. -   r->elt = NEW_A(maxlen,row_elt);
  1177. -   if ( ! r->elt )
  1178. -     error(E_MEM,"sprow_get");
  1179. -   else if (mem_info_is_on()) {
  1180. -      mem_bytes(TYPE_SPROW,0,maxlen*sizeof(row_elt));
  1181. -   }
  1182. -   r->len = 0;
  1183. -   r->maxlen = maxlen;
  1184. -   r->diag = -1;
  1185. -   
  1186. -   return r;
  1187. -}
  1188. -
  1189. -
  1190. -/* sprow_xpd -- expand row by means of realloc()
  1191. -   -- type must be TYPE_SPMAT if r is a row of a SPMAT structure,
  1192. -      otherwise it must be TYPE_SPROW
  1193. -   -- returns r */
  1194. -SPROW    *sprow_xpd(r,n,type)
  1195. -SPROW    *r;
  1196. -int    n,type;
  1197. -{
  1198. -   int    newlen;
  1199. -   
  1200. -   if ( ! r ) {
  1201. -     r = NEW(SPROW);
  1202. -     if (! r ) 
  1203. -       error(E_MEM,"sprow_xpd");
  1204. -     else if ( mem_info_is_on()) {
  1205. -    if (type != TYPE_SPMAT && type != TYPE_SPROW)
  1206. -      warning(WARN_WRONG_TYPE,"sprow_xpd");
  1207. -    mem_bytes(type,0,sizeof(SPROW));
  1208. -    if (type == TYPE_SPROW)
  1209. -      mem_numvar(type,1);
  1210. -     }
  1211. -   }
  1212. -
  1213. -   if ( ! r->elt )
  1214. -   {
  1215. -      r->elt = NEW_A((unsigned)n,row_elt);
  1216. -      if ( ! r->elt )
  1217. -    error(E_MEM,"sprow_xpd");
  1218. -      else if (mem_info_is_on()) {
  1219. -     mem_bytes(type,0,n*sizeof(row_elt));
  1220. -      }
  1221. -      r->len = 0;
  1222. -      r->maxlen = n;
  1223. -      return r;
  1224. -   }
  1225. -   if ( n <= r->len )
  1226. -     newlen = max(2*r->len + 1,MINROWLEN);
  1227. -   else
  1228. -     newlen = n;
  1229. -   if ( newlen <= r->maxlen )
  1230. -   {
  1231. -      MEM_ZERO((char *)(&(r->elt[r->len])),
  1232. -           (newlen-r->len)*sizeof(row_elt));
  1233. -      r->len = newlen;
  1234. -   }
  1235. -   else
  1236. -   {
  1237. -      if (mem_info_is_on()) {
  1238. -     mem_bytes(type,r->maxlen*sizeof(row_elt),
  1239. -             newlen*sizeof(row_elt)); 
  1240. -      }
  1241. -      r->elt = RENEW(r->elt,newlen,row_elt);
  1242. -      if ( ! r->elt )
  1243. -    error(E_MEM,"sprow_xpd");
  1244. -      r->maxlen = newlen;
  1245. -      r->len = newlen;
  1246. -   }
  1247. -   
  1248. -   return r;
  1249. -}
  1250. -
  1251. -/* sprow_resize -- resize a SPROW variable by means of realloc()
  1252. -   -- n is a new size
  1253. -   -- returns r */
  1254. -SPROW    *sprow_resize(r,n,type)
  1255. -SPROW    *r;
  1256. -int    n,type;
  1257. -{
  1258. -   if (n < 0)
  1259. -     error(E_NEG,"sprow_resize");
  1260. -
  1261. -   if ( ! r ) 
  1262. -     return sprow_get(n);
  1263. -   
  1264. -   if (n == r->len)
  1265. -     return r;
  1266. -
  1267. -   if ( ! r->elt )
  1268. -   {
  1269. -      r->elt = NEW_A((unsigned)n,row_elt);
  1270. -      if ( ! r->elt )
  1271. -    error(E_MEM,"sprow_resize");
  1272. -      else if (mem_info_is_on()) {
  1273. -     mem_bytes(type,0,n*sizeof(row_elt));
  1274. -      }
  1275. -      r->maxlen = r->len = n;
  1276. -      return r;
  1277. -   }
  1278. -
  1279. -   if ( n <= r->maxlen )
  1280. -     r->len = n;
  1281. -   else
  1282. -   {
  1283. -      if (mem_info_is_on()) {
  1284. -     mem_bytes(type,r->maxlen*sizeof(row_elt),
  1285. -           n*sizeof(row_elt)); 
  1286. -      }
  1287. -      r->elt = RENEW(r->elt,n,row_elt);
  1288. -      if ( ! r->elt )
  1289. -    error(E_MEM,"sprow_resize");
  1290. -      r->maxlen = r->len = n;
  1291. -   }
  1292. -   
  1293. -   return r;
  1294. -}
  1295. -
  1296. -
  1297. -/* release a row of a matrix */
  1298. -int sprow_free(r)
  1299. -SPROW    *r;
  1300. -{
  1301. -   if ( ! r )
  1302. -     return -1;
  1303. -
  1304. -   if (mem_info_is_on()) {
  1305. -      mem_bytes(TYPE_SPROW,sizeof(SPROW),0);
  1306. -      mem_numvar(TYPE_SPROW,-1);
  1307. -   }
  1308. -   
  1309. -   if ( r->elt )
  1310. -   {
  1311. -      if (mem_info_is_on()) {
  1312. -     mem_bytes(TYPE_SPROW,r->maxlen*sizeof(row_elt),0);
  1313. -      }
  1314. -      free((char *)r->elt);
  1315. -   }
  1316. -   free((char *)r);
  1317. -   return 0;
  1318. -}
  1319. -
  1320. -
  1321. -/* sprow_merge -- merges r1 and r2 into r_out
  1322. -   -- cannot be done in-situ
  1323. -   -- type must be SPMAT or SPROW depending on
  1324. -      whether r_out is a row of a SPMAT structure
  1325. -      or a SPROW variable
  1326. -   -- returns r_out */
  1327. -SPROW    *sprow_merge(r1,r2,r_out,type)
  1328. -SPROW    *r1, *r2, *r_out;
  1329. -int type;
  1330. -{
  1331. -   int    idx1, idx2, idx_out, len1, len2, len_out;
  1332. -   row_elt    *elt1, *elt2, *elt_out;
  1333. -   
  1334. -   if ( ! r1 || ! r2 )
  1335. -     error(E_NULL,"sprow_merge");
  1336. -   if ( ! r_out )
  1337. -     r_out = sprow_get(MINROWLEN);
  1338. -   if ( r1 == r_out || r2 == r_out )
  1339. -     error(E_INSITU,"sprow_merge");
  1340. -   
  1341. -   /* Initialise */
  1342. -   len1 = r1->len;    len2 = r2->len;    len_out = r_out->maxlen;
  1343. -   idx1 = idx2 = idx_out = 0;
  1344. -   elt1 = r1->elt;    elt2 = r2->elt;    elt_out = r_out->elt;
  1345. -   
  1346. -   while ( idx1 < len1 || idx2 < len2 )
  1347. -   {
  1348. -      if ( idx_out >= len_out )
  1349. -      {   /* r_out is too small */
  1350. -     r_out->len = idx_out;
  1351. -     r_out = sprow_xpd(r_out,0,type);
  1352. -     len_out = r_out->len;
  1353. -     elt_out = &(r_out->elt[idx_out]);
  1354. -      }
  1355. -      if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) )
  1356. -      {
  1357. -     elt_out->col = elt1->col;
  1358. -     elt_out->val = elt1->val;
  1359. -     if ( elt1->col == elt2->col && idx2 < len2 )
  1360. -     {    elt2++;        idx2++;    }
  1361. -     elt1++;    idx1++;
  1362. -      }
  1363. -      else
  1364. -      {
  1365. -     elt_out->col = elt2->col;
  1366. -     elt_out->val = elt2->val;
  1367. -     elt2++;    idx2++;
  1368. -      }
  1369. -      elt_out++;    idx_out++;
  1370. -   }
  1371. -   r_out->len = idx_out;
  1372. -   
  1373. -   return r_out;
  1374. -}
  1375. -
  1376. -/* sprow_copy -- copies r1 and r2 into r_out
  1377. -   -- cannot be done in-situ
  1378. -   -- type must be SPMAT or SPROW depending on
  1379. -      whether r_out is a row of a SPMAT structure
  1380. -      or a SPROW variable
  1381. -   -- returns r_out */
  1382. -SPROW    *sprow_copy(r1,r2,r_out,type)
  1383. -SPROW    *r1, *r2, *r_out;
  1384. -int type;
  1385. -{
  1386. -   int    idx1, idx2, idx_out, len1, len2, len_out;
  1387. -   row_elt    *elt1, *elt2, *elt_out;
  1388. -   
  1389. -   if ( ! r1 || ! r2 )
  1390. -     error(E_NULL,"sprow_copy");
  1391. -   if ( ! r_out )
  1392. -     r_out = sprow_get(MINROWLEN);
  1393. -   if ( r1 == r_out || r2 == r_out )
  1394. -     error(E_INSITU,"sprow_copy");
  1395. -   
  1396. -   /* Initialise */
  1397. -   len1 = r1->len;    len2 = r2->len;    len_out = r_out->maxlen;
  1398. -   idx1 = idx2 = idx_out = 0;
  1399. -   elt1 = r1->elt;    elt2 = r2->elt;    elt_out = r_out->elt;
  1400. -   
  1401. -   while ( idx1 < len1 || idx2 < len2 )
  1402. -   {
  1403. -      while ( idx_out >= len_out )
  1404. -      {   /* r_out is too small */
  1405. -     r_out->len = idx_out;
  1406. -     r_out = sprow_xpd(r_out,0,type);
  1407. -     len_out = r_out->maxlen;
  1408. -     elt_out = &(r_out->elt[idx_out]);
  1409. -      }
  1410. -      if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) )
  1411. -      {
  1412. -     elt_out->col = elt1->col;
  1413. -     elt_out->val = elt1->val;
  1414. -     if ( elt1->col == elt2->col && idx2 < len2 )
  1415. -     {    elt2++;        idx2++;    }
  1416. -     elt1++;    idx1++;
  1417. -      }
  1418. -      else
  1419. -      {
  1420. -     elt_out->col = elt2->col;
  1421. -     elt_out->val = 0.0;
  1422. -     elt2++;    idx2++;
  1423. -      }
  1424. -      elt_out++;    idx_out++;
  1425. -   }
  1426. -   r_out->len = idx_out;
  1427. -   
  1428. -   return r_out;
  1429. -}
  1430. -
  1431. -/* sprow_mltadd -- sets r_out <- r1 + alpha.r2
  1432. -   -- cannot be in situ
  1433. -   -- only for columns j0, j0+1, ...
  1434. -   -- type must be SPMAT or SPROW depending on
  1435. -      whether r_out is a row of a SPMAT structure
  1436. -      or a SPROW variable
  1437. -   -- returns r_out */
  1438. -SPROW    *sprow_mltadd(r1,r2,alpha,j0,r_out,type)
  1439. -SPROW    *r1, *r2, *r_out;
  1440. -double    alpha;
  1441. -int    j0, type;
  1442. -{
  1443. -   int    idx1, idx2, idx_out, len1, len2, len_out;
  1444. -   row_elt    *elt1, *elt2, *elt_out;
  1445. -   
  1446. -   if ( ! r1 || ! r2 )
  1447. -     error(E_NULL,"sprow_mltadd");
  1448. -   if ( r1 == r_out || r2 == r_out )
  1449. -     error(E_INSITU,"sprow_mltadd");
  1450. -   if ( j0 < 0 )
  1451. -     error(E_BOUNDS,"sprow_mltadd");
  1452. -   if ( ! r_out )
  1453. -     r_out = sprow_get(MINROWLEN);
  1454. -   
  1455. -   /* Initialise */
  1456. -   len1 = r1->len;    len2 = r2->len;    len_out = r_out->maxlen;
  1457. -   /* idx1 = idx2 = idx_out = 0; */
  1458. -   idx1    = sprow_idx(r1,j0);
  1459. -   idx2    = sprow_idx(r2,j0);
  1460. -   idx_out = sprow_idx(r_out,j0);
  1461. -   idx1    = (idx1 < 0) ? -(idx1+2) : idx1;
  1462. -   idx2    = (idx2 < 0) ? -(idx2+2) : idx2;
  1463. -   idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out;
  1464. -   elt1    = &(r1->elt[idx1]);
  1465. -   elt2    = &(r2->elt[idx2]);
  1466. -   elt_out = &(r_out->elt[idx_out]);
  1467. -   
  1468. -   while ( idx1 < len1 || idx2 < len2 )
  1469. -   {
  1470. -      if ( idx_out >= len_out )
  1471. -      {   /* r_out is too small */
  1472. -     r_out->len = idx_out;
  1473. -     r_out = sprow_xpd(r_out,0,type);
  1474. -     len_out = r_out->maxlen;
  1475. -     elt_out = &(r_out->elt[idx_out]);
  1476. -      }
  1477. -      if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) )
  1478. -      {
  1479. -     elt_out->col = elt1->col;
  1480. -     elt_out->val = elt1->val;
  1481. -     if ( idx2 < len2 && elt1->col == elt2->col )
  1482. -     {
  1483. -        elt_out->val += alpha*elt2->val;
  1484. -        elt2++;        idx2++;
  1485. -     }
  1486. -     elt1++;    idx1++;
  1487. -      }
  1488. -      else
  1489. -      {
  1490. -     elt_out->col = elt2->col;
  1491. -     elt_out->val = alpha*elt2->val;
  1492. -     elt2++;    idx2++;
  1493. -      }
  1494. -      elt_out++;    idx_out++;
  1495. -   }
  1496. -   r_out->len = idx_out;
  1497. -   
  1498. -   return r_out;
  1499. -}
  1500. -
  1501. -/* sprow_add -- sets r_out <- r1 + r2
  1502. -   -- cannot be in situ
  1503. -   -- only for columns j0, j0+1, ...
  1504. -   -- type must be SPMAT or SPROW depending on
  1505. -      whether r_out is a row of a SPMAT structure
  1506. -      or a SPROW variable
  1507. -   -- returns r_out */
  1508. -SPROW    *sprow_add(r1,r2,j0,r_out,type)
  1509. -SPROW    *r1, *r2, *r_out;
  1510. -int    j0, type;
  1511. -{
  1512. -   int    idx1, idx2, idx_out, len1, len2, len_out;
  1513. -   row_elt    *elt1, *elt2, *elt_out;
  1514. -   
  1515. -   if ( ! r1 || ! r2 )
  1516. -     error(E_NULL,"sprow_add");
  1517. -   if ( r1 == r_out || r2 == r_out )
  1518. -     error(E_INSITU,"sprow_add");
  1519. -   if ( j0 < 0 )
  1520. -     error(E_BOUNDS,"sprow_add");
  1521. -   if ( ! r_out )
  1522. -     r_out = sprow_get(MINROWLEN);
  1523. -   
  1524. -   /* Initialise */
  1525. -   len1 = r1->len;    len2 = r2->len;    len_out = r_out->maxlen;
  1526. -   /* idx1 = idx2 = idx_out = 0; */
  1527. -   idx1    = sprow_idx(r1,j0);
  1528. -   idx2    = sprow_idx(r2,j0);
  1529. -   idx_out = sprow_idx(r_out,j0);
  1530. -   idx1    = (idx1 < 0) ? -(idx1+2) : idx1;
  1531. -   idx2    = (idx2 < 0) ? -(idx2+2) : idx2;
  1532. -   idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out;
  1533. -   elt1    = &(r1->elt[idx1]);
  1534. -   elt2    = &(r2->elt[idx2]);
  1535. -   elt_out = &(r_out->elt[idx_out]);
  1536. -   
  1537. -   while ( idx1 < len1 || idx2 < len2 )
  1538. -   {
  1539. -      if ( idx_out >= len_out )
  1540. -      {   /* r_out is too small */
  1541. -     r_out->len = idx_out;
  1542. -     r_out = sprow_xpd(r_out,0,type);
  1543. -     len_out = r_out->maxlen;
  1544. -     elt_out = &(r_out->elt[idx_out]);
  1545. -      }
  1546. -      if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) )
  1547. -      {
  1548. -     elt_out->col = elt1->col;
  1549. -     elt_out->val = elt1->val;
  1550. -     if ( idx2 < len2 && elt1->col == elt2->col )
  1551. -     {
  1552. -        elt_out->val += elt2->val;
  1553. -        elt2++;        idx2++;
  1554. -     }
  1555. -     elt1++;    idx1++;
  1556. -      }
  1557. -      else
  1558. -      {
  1559. -     elt_out->col = elt2->col;
  1560. -     elt_out->val = elt2->val;
  1561. -     elt2++;    idx2++;
  1562. -      }
  1563. -      elt_out++;    idx_out++;
  1564. -   }
  1565. -   r_out->len = idx_out;
  1566. -   
  1567. -   return r_out;
  1568. -}
  1569. -
  1570. -/* sprow_sub -- sets r_out <- r1 - r2
  1571. -   -- cannot be in situ
  1572. -   -- only for columns j0, j0+1, ...
  1573. -   -- type must be SPMAT or SPROW depending on
  1574. -      whether r_out is a row of a SPMAT structure
  1575. -      or a SPROW variable
  1576. -   -- returns r_out */
  1577. -SPROW    *sprow_sub(r1,r2,j0,r_out,type)
  1578. -SPROW    *r1, *r2, *r_out;
  1579. -int    j0, type;
  1580. -{
  1581. -   int    idx1, idx2, idx_out, len1, len2, len_out;
  1582. -   row_elt    *elt1, *elt2, *elt_out;
  1583. -   
  1584. -   if ( ! r1 || ! r2 )
  1585. -     error(E_NULL,"sprow_sub");
  1586. -   if ( r1 == r_out || r2 == r_out )
  1587. -     error(E_INSITU,"sprow_sub");
  1588. -   if ( j0 < 0 )
  1589. -     error(E_BOUNDS,"sprow_sub");
  1590. -   if ( ! r_out )
  1591. -     r_out = sprow_get(MINROWLEN);
  1592. -   
  1593. -   /* Initialise */
  1594. -   len1 = r1->len;    len2 = r2->len;    len_out = r_out->maxlen;
  1595. -   /* idx1 = idx2 = idx_out = 0; */
  1596. -   idx1    = sprow_idx(r1,j0);
  1597. -   idx2    = sprow_idx(r2,j0);
  1598. -   idx_out = sprow_idx(r_out,j0);
  1599. -   idx1    = (idx1 < 0) ? -(idx1+2) : idx1;
  1600. -   idx2    = (idx2 < 0) ? -(idx2+2) : idx2;
  1601. -   idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out;
  1602. -   elt1    = &(r1->elt[idx1]);
  1603. -   elt2    = &(r2->elt[idx2]);
  1604. -   elt_out = &(r_out->elt[idx_out]);
  1605. -   
  1606. -   while ( idx1 < len1 || idx2 < len2 )
  1607. -   {
  1608. -      if ( idx_out >= len_out )
  1609. -      {   /* r_out is too small */
  1610. -     r_out->len = idx_out;
  1611. -     r_out = sprow_xpd(r_out,0,type);
  1612. -     len_out = r_out->maxlen;
  1613. -     elt_out = &(r_out->elt[idx_out]);
  1614. -      }
  1615. -      if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) )
  1616. -      {
  1617. -     elt_out->col = elt1->col;
  1618. -     elt_out->val = elt1->val;
  1619. -     if ( idx2 < len2 && elt1->col == elt2->col )
  1620. -     {
  1621. -        elt_out->val -= elt2->val;
  1622. -        elt2++;        idx2++;
  1623. -     }
  1624. -     elt1++;    idx1++;
  1625. -      }
  1626. -      else
  1627. -      {
  1628. -     elt_out->col = elt2->col;
  1629. -     elt_out->val = -elt2->val;
  1630. -     elt2++;    idx2++;
  1631. -      }
  1632. -      elt_out++;    idx_out++;
  1633. -   }
  1634. -   r_out->len = idx_out;
  1635. -   
  1636. -   return r_out;
  1637. -}
  1638. -
  1639. -
  1640. -/* sprow_smlt -- sets r_out <- alpha*r1 
  1641. -   -- can be in situ
  1642. -   -- only for columns j0, j0+1, ...
  1643. -   -- returns r_out */
  1644. -SPROW    *sprow_smlt(r1,alpha,j0,r_out,type)
  1645. -SPROW    *r1, *r_out;
  1646. -double    alpha;
  1647. -int    j0, type;
  1648. -{
  1649. -   int    idx1, idx_out, len1;
  1650. -   row_elt    *elt1, *elt_out;
  1651. -   
  1652. -   if ( ! r1 )
  1653. -     error(E_NULL,"sprow_smlt");
  1654. -   if ( j0 < 0 )
  1655. -     error(E_BOUNDS,"sprow_smlt");
  1656. -   if ( ! r_out )
  1657. -     r_out = sprow_get(MINROWLEN);
  1658. -   
  1659. -   /* Initialise */
  1660. -   len1 = r1->len;
  1661. -   idx1    = sprow_idx(r1,j0);
  1662. -   idx_out = sprow_idx(r_out,j0);
  1663. -   idx1    = (idx1 < 0) ? -(idx1+2) : idx1;
  1664. -   idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out;
  1665. -   elt1    = &(r1->elt[idx1]);
  1666. -
  1667. -   r_out = sprow_resize(r_out,idx_out+len1-idx1,type);  
  1668. -   elt_out = &(r_out->elt[idx_out]);
  1669. -
  1670. -   for ( ; idx1 < len1; elt1++,elt_out++,idx1++,idx_out++ )
  1671. -   {
  1672. -      elt_out->col = elt1->col;
  1673. -      elt_out->val = alpha*elt1->val;
  1674. -   }
  1675. -
  1676. -   r_out->len = idx_out;
  1677. -
  1678. -   return r_out;
  1679. -}
  1680. -
  1681. -  
  1682. -/* sprow_foutput -- print a representation of r on stream fp */
  1683. -void    sprow_foutput(fp,r)
  1684. -FILE    *fp;
  1685. -SPROW    *r;
  1686. -{
  1687. -   int    i, len;
  1688. -   row_elt    *e;
  1689. -   
  1690. -   if ( ! r )
  1691. -   {
  1692. -      fprintf(fp,"SparseRow: **** NULL ****\n");
  1693. -      return;
  1694. -   }
  1695. -   len = r->len;
  1696. -   fprintf(fp,"SparseRow: length: %d\n",len);
  1697. -   for ( i = 0, e = r->elt; i < len; i++, e++ )
  1698. -     fprintf(fp,"Column %d: %g, next row: %d, next index %d\n",
  1699. -         e->col, e->val, e->nxt_row, e->nxt_idx);
  1700. -}
  1701. -
  1702. -
  1703. -/* sprow_set_val -- sets the j-th column entry of the sparse row r
  1704. -   -- Note: destroys the usual column & row access paths */
  1705. -double  sprow_set_val(r,j,val)
  1706. -SPROW   *r;
  1707. -int     j;
  1708. -double  val;
  1709. -{
  1710. -   int  idx, idx2, new_len;
  1711. -   
  1712. -   if ( ! r )
  1713. -     error(E_NULL,"sprow_set_val");
  1714. -   
  1715. -   idx = sprow_idx(r,j);
  1716. -   if ( idx >= 0 )
  1717. -   {    r->elt[idx].val = val;  return val;     }
  1718. -   /* else */ if ( idx < -1 )
  1719. -   {
  1720. -      /* shift & insert new value */
  1721. -      idx = -(idx+2);   /* this is the intended insertion index */
  1722. -      if ( r->len >= r->maxlen )
  1723. -      {
  1724. -         r->len = r->maxlen;
  1725. -         new_len = max(2*r->maxlen+1,5);
  1726. -         if (mem_info_is_on()) {
  1727. -            mem_bytes(TYPE_SPROW,r->maxlen*sizeof(row_elt),
  1728. -                        new_len*sizeof(row_elt)); 
  1729. -         }
  1730. -         
  1731. -         r->elt = RENEW(r->elt,new_len,row_elt);
  1732. -         if ( ! r->elt )        /* can't allocate */
  1733. -           error(E_MEM,"sprow_set_val");
  1734. -         r->maxlen = 2*r->maxlen+1;
  1735. -      }
  1736. -      for ( idx2 = r->len-1; idx2 >= idx; idx2-- )
  1737. -        MEM_COPY((char *)(&(r->elt[idx2])),
  1738. -                 (char *)(&(r->elt[idx2+1])),sizeof(row_elt));
  1739. -      /************************************************************
  1740. -        if ( idx < r->len )
  1741. -        MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])),
  1742. -        (r->len-idx)*sizeof(row_elt));
  1743. -        ************************************************************/
  1744. -      r->len++;
  1745. -      r->elt[idx].col = j;
  1746. -      r->elt[idx].nxt_row = -1;
  1747. -      r->elt[idx].nxt_idx = -1;
  1748. -      return r->elt[idx].val = val;
  1749. -   }
  1750. -   /* else -- idx == -1, error in index/matrix! */
  1751. -   return 0.0;
  1752. -}
  1753. -
  1754. -
  1755. //GO.SYSIN DD sprow.c
  1756. echo sparseio.c 1>&2
  1757. sed >sparseio.c <<'//GO.SYSIN DD sparseio.c' 's/^-//'
  1758. -
  1759. -/**************************************************************************
  1760. -**
  1761. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  1762. -**
  1763. -**                 Meschach Library
  1764. -** 
  1765. -** This Meschach Library is provided "as is" without any express 
  1766. -** or implied warranty of any kind with respect to this software. 
  1767. -** In particular the authors shall not be liable for any direct, 
  1768. -** indirect, special, incidental or consequential damages arising 
  1769. -** in any way from use of the software.
  1770. -** 
  1771. -** Everyone is granted permission to copy, modify and redistribute this
  1772. -** Meschach Library, provided:
  1773. -**  1.  All copies contain this copyright notice.
  1774. -**  2.  All modified copies shall carry a notice stating who
  1775. -**      made the last modification and the date of such modification.
  1776. -**  3.  No charge is made for this software or works derived from it.  
  1777. -**      This clause shall not be construed as constraining other software
  1778. -**      distributed on the same medium as this software, nor is a
  1779. -**      distribution fee considered a charge.
  1780. -**
  1781. -***************************************************************************/
  1782. -
  1783. -
  1784. -/*
  1785. -    This file has the routines for sparse matrix input/output
  1786. -    It works in conjunction with sparse.c, sparse.h etc
  1787. -*/
  1788. -
  1789. -#include        <stdio.h>
  1790. -#include        "sparse.h"
  1791. -
  1792. -static char rcsid[] = "$Id: sparseio.c,v 1.4 1994/01/13 05:34:25 des Exp $";
  1793. -
  1794. -
  1795. -
  1796. -/* local variables */
  1797. -static char line[MAXLINE];
  1798. -
  1799. -/* sp_foutput -- output sparse matrix A to file/stream fp */
  1800. -void    sp_foutput(fp,A)
  1801. -FILE    *fp;
  1802. -SPMAT  *A;
  1803. -{
  1804. -    int     i, j_idx, m /* , n */;
  1805. -    SPROW  *rows;
  1806. -    row_elt *elts;
  1807. -
  1808. -    fprintf(fp,"SparseMatrix: ");
  1809. -    if ( A == SMNULL )
  1810. -    {
  1811. -        fprintf(fp,"*** NULL ***\n");
  1812. -        error(E_NULL,"sp_foutput");    return;
  1813. -    }
  1814. -    fprintf(fp,"%d by %d\n",A->m,A->n);
  1815. -    m = A->m;       /* n = A->n; */
  1816. -    if ( ! (rows=A->row) )
  1817. -    {
  1818. -        fprintf(fp,"*** NULL rows ***\n");
  1819. -        error(E_NULL,"sp_foutput");    return;
  1820. -    }
  1821. -
  1822. -    for ( i = 0; i < m; i++ )
  1823. -    {
  1824. -        fprintf(fp,"row %d: ",i);
  1825. -        if ( ! (elts=rows[i].elt) )
  1826. -        {
  1827. -            fprintf(fp,"*** NULL element list ***\n");
  1828. -            continue;
  1829. -        }
  1830. -        for ( j_idx = 0; j_idx < rows[i].len; j_idx++ )
  1831. -        {
  1832. -            fprintf(fp,"%d:%-20.15g ",elts[j_idx].col,
  1833. -                            elts[j_idx].val);
  1834. -            if ( j_idx % 3 == 2 && j_idx != rows[i].len-1 )
  1835. -                fprintf(fp,"\n     ");
  1836. -        }
  1837. -        fprintf(fp,"\n");
  1838. -    }
  1839. -    fprintf(fp,"#\n");    /* to stop looking beyond for next entry */
  1840. -}
  1841. -
  1842. -/* sp_foutput2 -- print out sparse matrix **as a dense matrix**
  1843. -    -- see output format used in matrix.h etc */
  1844. -/******************************************************************
  1845. -void    sp_foutput2(fp,A)
  1846. -FILE    *fp;
  1847. -SPMAT  *A;
  1848. -{
  1849. -    int     cnt, i, j, j_idx;
  1850. -    SPROW  *r;
  1851. -    row_elt *elt;
  1852. -
  1853. -    if ( A == SMNULL )
  1854. -    {
  1855. -        fprintf(fp,"Matrix: *** NULL ***\n");
  1856. -        return;
  1857. -    }
  1858. -    fprintf(fp,"Matrix: %d by %d\n",A->m,A->n);
  1859. -    for ( i = 0; i < A->m; i++ )
  1860. -    {
  1861. -        fprintf(fp,"row %d:",i);
  1862. -        r = &(A->row[i]);
  1863. -        elt = r->elt;
  1864. -        cnt = j = j_idx = 0;
  1865. -        while ( j_idx < r->len || j < A->n )
  1866. -        {
  1867. -            if ( j_idx >= r->len )
  1868. -                fprintf(fp,"%14.9g ",0.0);
  1869. -            else if ( j < elt[j_idx].col )
  1870. -                fprintf(fp,"%14.9g ",0.0);
  1871. -            else
  1872. -                fprintf(fp,"%14.9g ",elt[j_idx++].val);
  1873. -            if ( cnt++ % 4 == 3 )
  1874. -                fprintf(fp,"\n");
  1875. -            j++;
  1876. -        }
  1877. -        fprintf(fp,"\n");
  1878. -    }
  1879. -}
  1880. -******************************************************************/
  1881. -
  1882. -/* sp_dump -- prints ALL relevant information about the sparse matrix A */
  1883. -void    sp_dump(fp,A)
  1884. -FILE    *fp;
  1885. -SPMAT  *A;
  1886. -{
  1887. -    int     i, j, j_idx;
  1888. -    SPROW  *rows;
  1889. -    row_elt *elts;
  1890. -
  1891. -    fprintf(fp,"SparseMatrix dump:\n");
  1892. -    if ( ! A )
  1893. -    {       fprintf(fp,"*** NULL ***\n");   return; }
  1894. -    fprintf(fp,"Matrix at 0x%lx\n",(long)A);
  1895. -    fprintf(fp,"Dimensions: %d by %d\n",A->m,A->n);
  1896. -    fprintf(fp,"MaxDimensions: %d by %d\n",A->max_m,A->max_n);
  1897. -    fprintf(fp,"flag_col = %d, flag_diag = %d\n",A->flag_col,A->flag_diag);
  1898. -    fprintf(fp,"start_row @ 0x%lx:\n",(long)(A->start_row));
  1899. -    for ( j = 0; j < A->n; j++ )
  1900. -    {
  1901. -        fprintf(fp,"%d ",A->start_row[j]);
  1902. -        if ( j % 10 == 9 )
  1903. -            fprintf(fp,"\n");
  1904. -    }
  1905. -    fprintf(fp,"\n");
  1906. -    fprintf(fp,"start_idx @ 0x%lx:\n",(long)(A->start_idx));
  1907. -    for ( j = 0; j < A->n; j++ )
  1908. -    {
  1909. -        fprintf(fp,"%d ",A->start_idx[j]);
  1910. -        if ( j % 10 == 9 )
  1911. -            fprintf(fp,"\n");
  1912. -    }
  1913. -    fprintf(fp,"\n");
  1914. -    fprintf(fp,"Rows @ 0x%lx:\n",(long)(A->row));
  1915. -    if ( ! A->row )
  1916. -    {       fprintf(fp,"*** NULL row ***\n");       return; }
  1917. -    rows = A->row;
  1918. -    for ( i = 0; i < A->m; i++ )
  1919. -    {
  1920. -        fprintf(fp,"row %d: len = %d, maxlen = %d, diag idx = %d\n",
  1921. -            i,rows[i].len,rows[i].maxlen,rows[i].diag);
  1922. -        fprintf(fp,"element list @ 0x%lx\n",(long)(rows[i].elt));
  1923. -        if ( ! rows[i].elt )
  1924. -        {
  1925. -            fprintf(fp,"*** NULL element list ***\n");
  1926. -            continue;
  1927. -        }
  1928. -        elts = rows[i].elt;
  1929. -        for ( j_idx = 0; j_idx < rows[i].len; j_idx++, elts++ )
  1930. -            fprintf(fp,"Col: %d, Val: %g, nxt_row = %d, nxt_idx = %d\n",
  1931. -            elts->col,elts->val,elts->nxt_row,elts->nxt_idx);
  1932. -        fprintf(fp,"\n");
  1933. -    }
  1934. -}
  1935. -
  1936. -#define MAXSCRATCH      100
  1937. -
  1938. -/* sp_finput -- input sparse matrix from stream/file fp
  1939. -    -- uses friendly input routine if fp is a tty
  1940. -    -- uses format identical to output format otherwise */
  1941. -SPMAT  *sp_finput(fp)
  1942. -FILE    *fp;
  1943. -{
  1944. -    int     i, len, ret_val;
  1945. -    int     col, curr_col, m, n, tmp, tty;
  1946. -    Real  val;
  1947. -    SPMAT  *A;
  1948. -    SPROW  *rows;
  1949. -
  1950. -    row_elt scratch[MAXSCRATCH];
  1951. -    /* cannot handle >= MAXSCRATCH elements in a row */
  1952. -
  1953. -    for ( i = 0; i < MAXSCRATCH; i++ )
  1954. -        scratch[i].nxt_row = scratch[i].nxt_idx = -1;
  1955. -
  1956. -    tty = isatty(fileno(fp));
  1957. -
  1958. -    if ( tty )
  1959. -    {
  1960. -        fprintf(stderr,"SparseMatrix: ");
  1961. -        do {
  1962. -            fprintf(stderr,"input rows cols: ");
  1963. -            if ( ! fgets(line,MAXLINE,fp) )
  1964. -                error(E_INPUT,"sp_finput");
  1965. -        } while ( sscanf(line,"%u %u",&m,&n) != 2 );
  1966. -        A = sp_get(m,n,5);
  1967. -        rows = A->row;
  1968. -
  1969. -        for ( i = 0; i < m; i++ )
  1970. -        {
  1971. -            fprintf(stderr,"Row %d:\n",i);
  1972. -            fprintf(stderr,"Enter <col> <val> or 'e' to end row\n");
  1973. -            curr_col = -1;
  1974. -            for ( len = 0; len < MAXSCRATCH; len++ )
  1975. -            {
  1976. -            do {
  1977. -                fprintf(stderr,"Entry %d: ",len);
  1978. -                if ( ! fgets(line,MAXLINE,fp) )
  1979. -                error(E_INPUT,"sp_finput");
  1980. -                if ( *line == 'e' || *line == 'E' )
  1981. -                break;
  1982. -#if REAL == DOUBLE
  1983. -            } while ( sscanf(line,"%u %lf",&col,&val) != 2 ||
  1984. -#elif REAL == FLOAT
  1985. -            } while ( sscanf(line,"%u %f",&col,&val) != 2 ||
  1986. -#endif
  1987. -                    col >= n || col <= curr_col );
  1988. -
  1989. -            if ( *line == 'e' || *line == 'E' )
  1990. -                break;
  1991. -
  1992. -            scratch[len].col = col;
  1993. -            scratch[len].val = val;
  1994. -            curr_col = col;
  1995. -            }
  1996. -
  1997. -            /* Note: len = # elements in row */
  1998. -            if ( len > 5 )
  1999. -             {
  2000. -            if (mem_info_is_on()) {
  2001. -               mem_bytes(TYPE_SPMAT,
  2002. -                       A->row[i].maxlen*sizeof(row_elt),
  2003. -                       len*sizeof(row_elt));  
  2004. -            }
  2005. -
  2006. -            rows[i].elt = (row_elt *)realloc((char *)rows[i].elt,
  2007. -                             len*sizeof(row_elt));
  2008. -            rows[i].maxlen = len;
  2009. -            }
  2010. -            MEM_COPY(scratch,rows[i].elt,len*sizeof(row_elt));
  2011. -            rows[i].len  = len;
  2012. -            rows[i].diag = sprow_idx(&(rows[i]),i);
  2013. -        }
  2014. -    }
  2015. -    else /* not tty */
  2016. -    {
  2017. -            ret_val = 0;
  2018. -        skipjunk(fp);
  2019. -        fscanf(fp,"SparseMatrix:");
  2020. -        skipjunk(fp);
  2021. -        if ( (ret_val=fscanf(fp,"%u by %u",&m,&n)) != 2 )
  2022. -            error((ret_val == EOF) ? E_EOF : E_FORMAT,"sp_finput");
  2023. -        A = sp_get(m,n,5);
  2024. -
  2025. -        /* initialise start_row */
  2026. -        for ( i = 0; i < A->n; i++ )
  2027. -            A->start_row[i] = -1;
  2028. -
  2029. -        rows = A->row;
  2030. -        for ( i = 0; i < m; i++ )
  2031. -        {
  2032. -            /* printf("Reading row # %d\n",i); */
  2033. -            rows[i].diag = -1;
  2034. -            skipjunk(fp);
  2035. -            if ( (ret_val=fscanf(fp,"row %d :",&tmp)) != 1 ||
  2036. -             tmp != i )
  2037. -            error((ret_val == EOF) ? E_EOF : E_FORMAT,
  2038. -                  "sp_finput");
  2039. -            curr_col = -1;
  2040. -            for ( len = 0; len < MAXSCRATCH; len++ )
  2041. -            {
  2042. -#if REAL == DOUBLE
  2043. -            if ( (ret_val=fscanf(fp,"%u : %lf",&col,&val)) != 2 )
  2044. -#elif REAL == FLOAT
  2045. -            if ( (ret_val=fscanf(fp,"%u : %f",&col,&val)) != 2 )
  2046. -#endif
  2047. -                break;
  2048. -            if ( col <= curr_col || col >= n )
  2049. -                error(E_FORMAT,"sp_finput");
  2050. -            scratch[len].col = col;
  2051. -            scratch[len].val = val;
  2052. -            }
  2053. -            if ( ret_val == EOF )
  2054. -            error(E_EOF,"sp_finput");
  2055. -
  2056. -            if ( len > rows[i].maxlen )
  2057. -            {
  2058. -            rows[i].elt = (row_elt *)realloc((char *)rows[i].elt,
  2059. -                            len*sizeof(row_elt));
  2060. -            rows[i].maxlen = len;
  2061. -            }
  2062. -            MEM_COPY(scratch,rows[i].elt,len*sizeof(row_elt));
  2063. -            rows[i].len  = len;
  2064. -            /* printf("Have read row # %d\n",i); */
  2065. -            rows[i].diag = sprow_idx(&(rows[i]),i);
  2066. -            /* printf("Have set diag index for row # %d\n",i); */
  2067. -        }
  2068. -    }
  2069. -
  2070. -    return A;
  2071. -}
  2072. -
  2073. //GO.SYSIN DD sparseio.c
  2074. echo spchfctr.c 1>&2
  2075. sed >spchfctr.c <<'//GO.SYSIN DD spchfctr.c' 's/^-//'
  2076. -
  2077. -/**************************************************************************
  2078. -**
  2079. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  2080. -**
  2081. -**                 Meschach Library
  2082. -** 
  2083. -** This Meschach Library is provided "as is" without any express 
  2084. -** or implied warranty of any kind with respect to this software. 
  2085. -** In particular the authors shall not be liable for any direct, 
  2086. -** indirect, special, incidental or consequential damages arising 
  2087. -** in any way from use of the software.
  2088. -** 
  2089. -** Everyone is granted permission to copy, modify and redistribute this
  2090. -** Meschach Library, provided:
  2091. -**  1.  All copies contain this copyright notice.
  2092. -**  2.  All modified copies shall carry a notice stating who
  2093. -**      made the last modification and the date of such modification.
  2094. -**  3.  No charge is made for this software or works derived from it.  
  2095. -**      This clause shall not be construed as constraining other software
  2096. -**      distributed on the same medium as this software, nor is a
  2097. -**      distribution fee considered a charge.
  2098. -**
  2099. -***************************************************************************/
  2100. -
  2101. -
  2102. -/*
  2103. -    Sparse Cholesky factorisation code
  2104. -    To be used with sparse.h, sparse.c etc
  2105. -
  2106. -*/
  2107. -
  2108. -static char    rcsid[] = "$Id: spchfctr.c,v 1.4 1994/01/13 05:31:32 des Exp $";
  2109. -
  2110. -#include    <stdio.h>
  2111. -#include    <math.h>
  2112. -#include    "matrix.h"
  2113. -#include    "sparse.h"
  2114. -#include        "sparse2.h"
  2115. -
  2116. -
  2117. -#ifndef MALLOCDECL
  2118. -#ifndef ANSI_C
  2119. -extern    char    *calloc(), *realloc();
  2120. -#endif
  2121. -#endif
  2122. -
  2123. -
  2124. -
  2125. -/* sprow_ip -- finds the (partial) inner product of a pair of sparse rows
  2126. -    -- uses a "merging" approach & assumes column ordered rows
  2127. -    -- row indices for inner product are all < lim */
  2128. -double    sprow_ip(row1, row2, lim)
  2129. -SPROW    *row1, *row2;
  2130. -int    lim;
  2131. -{
  2132. -    int            idx1, idx2, len1, len2, tmp;
  2133. -    int            sprow_idx();
  2134. -    register row_elt    *elts1, *elts2;
  2135. -    register Real        sum;
  2136. -
  2137. -    elts1 = row1->elt;    elts2 = row2->elt;
  2138. -    len1 = row1->len;    len2 = row2->len;
  2139. -
  2140. -    sum = 0.0;
  2141. -
  2142. -    if ( len1 <= 0 || len2 <= 0 )
  2143. -        return 0.0;
  2144. -    if ( elts1->col >= lim || elts2->col >= lim )
  2145. -        return 0.0;
  2146. -
  2147. -    /* use sprow_idx() to speed up inner product where one row is
  2148. -        much longer than the other */
  2149. -    idx1 = idx2 = 0;
  2150. -    if ( len1 > 2*len2 )
  2151. -    {
  2152. -        idx1 = sprow_idx(row1,elts2->col);
  2153. -        idx1 = (idx1 < 0) ? -(idx1+2) : idx1;
  2154. -        if ( idx1 < 0 )
  2155. -            error(E_UNKNOWN,"sprow_ip");
  2156. -        len1 -= idx1;
  2157. -    }
  2158. -    else if ( len2 > 2*len1 )
  2159. -    {
  2160. -        idx2 = sprow_idx(row2,elts1->col);
  2161. -        idx2 = (idx2 < 0) ? -(idx2+2) : idx2;
  2162. -        if ( idx2 < 0 )
  2163. -            error(E_UNKNOWN,"sprow_ip");
  2164. -        len2 -= idx2;
  2165. -    }
  2166. -    if ( len1 <= 0 || len2 <= 0 )
  2167. -        return 0.0;
  2168. -
  2169. -    elts1 = &(elts1[idx1]);        elts2 = &(elts2[idx2]);
  2170. -
  2171. -
  2172. -    for ( ; ; )    /* forever do... */
  2173. -    {
  2174. -        if ( (tmp=elts1->col-elts2->col) < 0 )
  2175. -        {
  2176. -            len1--;        elts1++;
  2177. -            if ( ! len1 || elts1->col >= lim )
  2178. -            break;
  2179. -        }
  2180. -        else if ( tmp > 0 )
  2181. -        {
  2182. -            len2--;        elts2++;
  2183. -            if ( ! len2 || elts2->col >= lim )
  2184. -            break;
  2185. -        }
  2186. -        else
  2187. -        {
  2188. -            sum += elts1->val * elts2->val;
  2189. -            len1--;        elts1++;
  2190. -            len2--;        elts2++;
  2191. -            if ( ! len1 || ! len2 ||
  2192. -                elts1->col >= lim || elts2->col >= lim )
  2193. -            break;
  2194. -        }
  2195. -    }
  2196. -
  2197. -    return sum;
  2198. -}
  2199. -
  2200. -/* sprow_sqr -- returns same as sprow_ip(row, row, lim) */
  2201. -double    sprow_sqr(row, lim)
  2202. -SPROW    *row;
  2203. -int    lim;
  2204. -{
  2205. -    register    row_elt    *elts;
  2206. -    int        idx, len;
  2207. -    register    Real    sum, tmp;
  2208. -
  2209. -    sum = 0.0;
  2210. -    elts = row->elt;    len = row->len;
  2211. -    for ( idx = 0; idx < len; idx++, elts++ )
  2212. -    {
  2213. -        if ( elts->col >= lim )
  2214. -            break;
  2215. -        tmp = elts->val;
  2216. -        sum += tmp*tmp;
  2217. -    }
  2218. -
  2219. -    return sum;
  2220. -}
  2221. -
  2222. -static    int    *scan_row = (int *)NULL, *scan_idx = (int *)NULL,
  2223. -            *col_list = (int *)NULL;
  2224. -static    int    scan_len = 0;
  2225. -
  2226. -/* set_scan -- expand scan_row and scan_idx arrays
  2227. -    -- return new length */
  2228. -int    set_scan(new_len)
  2229. -int    new_len;
  2230. -{
  2231. -    if ( new_len <= scan_len )
  2232. -        return scan_len;
  2233. -    if ( new_len <= scan_len+5 )
  2234. -        new_len += 5;
  2235. -
  2236. -    if ( ! scan_row || ! scan_idx || ! col_list )
  2237. -    {
  2238. -        scan_row = (int *)calloc(new_len,sizeof(int));
  2239. -        scan_idx = (int *)calloc(new_len,sizeof(int));
  2240. -        col_list = (int *)calloc(new_len,sizeof(int));
  2241. -    }
  2242. -    else
  2243. -    {
  2244. -        scan_row = (int *)realloc((char *)scan_row,new_len*sizeof(int));
  2245. -        scan_idx = (int *)realloc((char *)scan_idx,new_len*sizeof(int));
  2246. -        col_list = (int *)realloc((char *)col_list,new_len*sizeof(int));
  2247. -    }
  2248. -
  2249. -    if ( ! scan_row || ! scan_idx || ! col_list )
  2250. -        error(E_MEM,"set_scan");
  2251. -    return new_len;
  2252. -}
  2253. -
  2254. -/* spCHfactor -- sparse Cholesky factorisation
  2255. -    -- only the lower triangular part of A (incl. diagonal) is used */
  2256. -SPMAT    *spCHfactor(A)
  2257. -SPMAT    *A;
  2258. -{
  2259. -    register     int    i;
  2260. -    int    idx, k, m, minim, n, num_scan, diag_idx, tmp1;
  2261. -    Real    pivot, tmp2;
  2262. -    SPROW    *r_piv, *r_op;
  2263. -    row_elt    *elt_piv, *elt_op, *old_elt;
  2264. -
  2265. -    if ( A == SMNULL )
  2266. -        error(E_NULL,"spCHfactor");
  2267. -    if ( A->m != A->n )
  2268. -        error(E_SQUARE,"spCHfactor");
  2269. -
  2270. -    /* set up access paths if not already done so */
  2271. -    sp_col_access(A);
  2272. -    sp_diag_access(A);
  2273. -
  2274. -    /* printf("spCHfactor() -- checkpoint 1\n"); */
  2275. -    m = A->m;    n = A->n;
  2276. -    for ( k = 0; k < m; k++ )
  2277. -    {
  2278. -        r_piv = &(A->row[k]);
  2279. -        if ( r_piv->len > scan_len )
  2280. -            set_scan(r_piv->len);
  2281. -        elt_piv = r_piv->elt;
  2282. -        diag_idx = sprow_idx2(r_piv,k,r_piv->diag);
  2283. -        if ( diag_idx < 0 )
  2284. -            error(E_POSDEF,"spCHfactor");
  2285. -        old_elt = &(elt_piv[diag_idx]);
  2286. -        for ( i = 0; i < r_piv->len; i++ )
  2287. -        {
  2288. -            if ( elt_piv[i].col > k )
  2289. -                break;
  2290. -            col_list[i] = elt_piv[i].col;
  2291. -            scan_row[i] = elt_piv[i].nxt_row;
  2292. -            scan_idx[i] = elt_piv[i].nxt_idx;
  2293. -        }
  2294. -        /* printf("spCHfactor() -- checkpoint 2\n"); */
  2295. -        num_scan = i;    /* number of actual entries in scan_row etc. */
  2296. -        /* printf("num_scan = %d\n",num_scan); */
  2297. -
  2298. -        /* set diagonal entry of Cholesky factor */
  2299. -        tmp2 = elt_piv[diag_idx].val - sprow_sqr(r_piv,k);
  2300. -        if ( tmp2 <= 0.0 )
  2301. -            error(E_POSDEF,"spCHfactor");
  2302. -        elt_piv[diag_idx].val = pivot = sqrt(tmp2);
  2303. -
  2304. -        /* now set the k-th column of the Cholesky factors */
  2305. -        /* printf("k = %d\n",k); */
  2306. -        for ( ; ; )    /* forever do... */
  2307. -        {
  2308. -            /* printf("spCHfactor() -- checkpoint 3\n"); */
  2309. -            /* find next row where something (non-trivial) happens
  2310. -            i.e. find min(scan_row) */
  2311. -            /* printf("scan_row: "); */
  2312. -            minim = n;
  2313. -            for ( i = 0; i < num_scan; i++ )
  2314. -            {
  2315. -            tmp1 = scan_row[i];
  2316. -            /* printf("%d ",tmp1); */
  2317. -            minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim;
  2318. -            }
  2319. -            /* printf("minim = %d\n",minim); */
  2320. -            /* printf("col_list: "); */
  2321. -/**********************************************************************
  2322. -            for ( i = 0; i < num_scan; i++ )
  2323. -            printf("%d ",col_list[i]);
  2324. -            printf("\n");
  2325. -**********************************************************************/
  2326. -
  2327. -            if ( minim >= n )
  2328. -            break;    /* nothing more to do for this column */
  2329. -            r_op = &(A->row[minim]);
  2330. -            elt_op = r_op->elt;
  2331. -
  2332. -            /* set next entry in column k of Cholesky factors */
  2333. -            idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]);
  2334. -            if ( idx < 0 )
  2335. -            {    /* fill-in */
  2336. -            sp_set_val(A,minim,k,
  2337. -                    -sprow_ip(r_piv,r_op,k)/pivot);
  2338. -            /* in case a realloc() has occurred... */
  2339. -            elt_op = r_op->elt;
  2340. -            /* now set up column access path again */
  2341. -            idx = sprow_idx2(r_op,k,-(idx+2));
  2342. -            tmp1 = old_elt->nxt_row;
  2343. -            old_elt->nxt_row = minim;
  2344. -            r_op->elt[idx].nxt_row = tmp1;
  2345. -            tmp1 = old_elt->nxt_idx;
  2346. -            old_elt->nxt_idx = idx;
  2347. -            r_op->elt[idx].nxt_idx = tmp1;
  2348. -            }
  2349. -            else
  2350. -                elt_op[idx].val = (elt_op[idx].val -
  2351. -                sprow_ip(r_piv,r_op,k))/pivot;
  2352. -
  2353. -            /* printf("spCHfactor() -- checkpoint 4\n"); */
  2354. -
  2355. -            /* remember current element in column k for column chain */
  2356. -            idx = sprow_idx2(r_op,k,idx);
  2357. -            old_elt = &(r_op->elt[idx]);
  2358. -
  2359. -            /* update scan_row */
  2360. -            /* printf("spCHfactor() -- checkpoint 5\n"); */
  2361. -            /* printf("minim = %d\n",minim); */
  2362. -            for ( i = 0; i < num_scan; i++ )
  2363. -            {
  2364. -            if ( scan_row[i] != minim )
  2365. -                continue;
  2366. -            idx = sprow_idx2(r_op,col_list[i],scan_idx[i]);
  2367. -            if ( idx < 0 )
  2368. -            {    scan_row[i] = -1;    continue;    }
  2369. -            scan_row[i] = elt_op[idx].nxt_row;
  2370. -            scan_idx[i] = elt_op[idx].nxt_idx;
  2371. -            /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */
  2372. -            /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */
  2373. -            }
  2374. -            
  2375. -        }
  2376. -        /* printf("spCHfactor() -- checkpoint 6\n"); */
  2377. -        /* sp_dump(stdout,A); */
  2378. -        /* printf("\n\n\n"); */
  2379. -    }
  2380. -
  2381. -    return A;
  2382. -}
  2383. -
  2384. -/* spCHsolve -- solve L.L^T.out=b where L is a sparse matrix,
  2385. -    -- out, b dense vectors
  2386. -    -- returns out; operation may be in-situ */
  2387. -VEC    *spCHsolve(L,b,out)
  2388. -SPMAT    *L;
  2389. -VEC    *b, *out;
  2390. -{
  2391. -    int    i, j_idx, n, scan_idx, scan_row;
  2392. -    SPROW    *row;
  2393. -    row_elt    *elt;
  2394. -    Real    diag_val, sum, *out_ve;
  2395. -
  2396. -    if ( L == SMNULL || b == VNULL )
  2397. -        error(E_NULL,"spCHsolve");
  2398. -    if ( L->m != L->n )
  2399. -        error(E_SQUARE,"spCHsolve");
  2400. -    if ( b->dim != L->m )
  2401. -        error(E_SIZES,"spCHsolve");
  2402. -
  2403. -    if ( ! L->flag_col )
  2404. -        sp_col_access(L);
  2405. -    if ( ! L->flag_diag )
  2406. -        sp_diag_access(L);
  2407. -
  2408. -    out = v_copy(b,out);
  2409. -    out_ve = out->ve;
  2410. -
  2411. -    /* forward substitution: solve L.x=b for x */
  2412. -    n = L->n;
  2413. -    for ( i = 0; i < n; i++ )
  2414. -    {
  2415. -        sum = out_ve[i];
  2416. -        row = &(L->row[i]);
  2417. -        elt = row->elt;
  2418. -        for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ )
  2419. -        {
  2420. -            if ( elt->col >= i )
  2421. -            break;
  2422. -            sum -= elt->val*out_ve[elt->col];
  2423. -        }
  2424. -        if ( row->diag >= 0 )
  2425. -            out_ve[i] = sum/(row->elt[row->diag].val);
  2426. -        else
  2427. -            error(E_SING,"spCHsolve");
  2428. -    }
  2429. -
  2430. -    /* backward substitution: solve L^T.out = x for out */
  2431. -    for ( i = n-1; i >= 0; i-- )
  2432. -    {
  2433. -        sum = out_ve[i];
  2434. -        row = &(L->row[i]);
  2435. -        /* Note that row->diag >= 0 by above loop */
  2436. -        elt = &(row->elt[row->diag]);
  2437. -        diag_val = elt->val;
  2438. -
  2439. -        /* scan down column */
  2440. -        scan_idx = elt->nxt_idx;
  2441. -        scan_row = elt->nxt_row;
  2442. -        while ( scan_row >= 0 /* && scan_idx >= 0 */ )
  2443. -        {
  2444. -            row = &(L->row[scan_row]);
  2445. -            elt = &(row->elt[scan_idx]);
  2446. -            sum -= elt->val*out_ve[scan_row];
  2447. -            scan_idx = elt->nxt_idx;
  2448. -            scan_row = elt->nxt_row;
  2449. -        }
  2450. -        out_ve[i] = sum/diag_val;
  2451. -    }
  2452. -
  2453. -    return out;
  2454. -}
  2455. -
  2456. -/* spICHfactor -- sparse Incomplete Cholesky factorisation
  2457. -    -- does a Cholesky factorisation assuming NO FILL-IN
  2458. -    -- as for spCHfactor(), only the lower triangular part of A is used */
  2459. -SPMAT    *spICHfactor(A)
  2460. -SPMAT    *A;
  2461. -{
  2462. -    int    k, m, n, nxt_row, nxt_idx, diag_idx;
  2463. -    Real    pivot, tmp2;
  2464. -    SPROW    *r_piv, *r_op;
  2465. -    row_elt    *elt_piv, *elt_op;
  2466. -
  2467. -    if ( A == SMNULL )
  2468. -        error(E_NULL,"spICHfactor");
  2469. -    if ( A->m != A->n )
  2470. -        error(E_SQUARE,"spICHfactor");
  2471. -
  2472. -    /* set up access paths if not already done so */
  2473. -    if ( ! A->flag_col )
  2474. -        sp_col_access(A);
  2475. -    if ( ! A->flag_diag )
  2476. -        sp_diag_access(A);
  2477. -
  2478. -    m = A->m;    n = A->n;
  2479. -    for ( k = 0; k < m; k++ )
  2480. -    {
  2481. -        r_piv = &(A->row[k]);
  2482. -
  2483. -        diag_idx = r_piv->diag;
  2484. -        if ( diag_idx < 0 )
  2485. -            error(E_POSDEF,"spICHfactor");
  2486. -
  2487. -        elt_piv = r_piv->elt;
  2488. -
  2489. -        /* set diagonal entry of Cholesky factor */
  2490. -        tmp2 = elt_piv[diag_idx].val - sprow_sqr(r_piv,k);
  2491. -        if ( tmp2 <= 0.0 )
  2492. -            error(E_POSDEF,"spICHfactor");
  2493. -        elt_piv[diag_idx].val = pivot = sqrt(tmp2);
  2494. -
  2495. -        /* find next row where something (non-trivial) happens */
  2496. -        nxt_row = elt_piv[diag_idx].nxt_row;
  2497. -        nxt_idx = elt_piv[diag_idx].nxt_idx;
  2498. -
  2499. -        /* now set the k-th column of the Cholesky factors */
  2500. -        while ( nxt_row >= 0 && nxt_idx >= 0 )
  2501. -        {
  2502. -            /* nxt_row and nxt_idx give next next row (& index)
  2503. -            of the entry to be modified */
  2504. -            r_op = &(A->row[nxt_row]);
  2505. -            elt_op = r_op->elt;
  2506. -            elt_op[nxt_idx].val = (elt_op[nxt_idx].val -
  2507. -                sprow_ip(r_piv,r_op,k))/pivot;
  2508. -
  2509. -            nxt_row = elt_op[nxt_idx].nxt_row;
  2510. -            nxt_idx = elt_op[nxt_idx].nxt_idx;
  2511. -        }
  2512. -    }
  2513. -
  2514. -    return A;
  2515. -}
  2516. -
  2517. -
  2518. -/* spCHsymb -- symbolic sparse Cholesky factorisation
  2519. -    -- does NOT do any floating point arithmetic; just sets up the structure
  2520. -    -- only the lower triangular part of A (incl. diagonal) is used */
  2521. -SPMAT    *spCHsymb(A)
  2522. -SPMAT    *A;
  2523. -{
  2524. -    register     int    i;
  2525. -    int    idx, k, m, minim, n, num_scan, diag_idx, tmp1;
  2526. -    SPROW    *r_piv, *r_op;
  2527. -    row_elt    *elt_piv, *elt_op, *old_elt;
  2528. -
  2529. -    if ( A == SMNULL )
  2530. -        error(E_NULL,"spCHsymb");
  2531. -    if ( A->m != A->n )
  2532. -        error(E_SQUARE,"spCHsymb");
  2533. -
  2534. -    /* set up access paths if not already done so */
  2535. -    if ( ! A->flag_col )
  2536. -        sp_col_access(A);
  2537. -    if ( ! A->flag_diag )
  2538. -        sp_diag_access(A);
  2539. -
  2540. -    /* printf("spCHsymb() -- checkpoint 1\n"); */
  2541. -    m = A->m;    n = A->n;
  2542. -    for ( k = 0; k < m; k++ )
  2543. -    {
  2544. -        r_piv = &(A->row[k]);
  2545. -        if ( r_piv->len > scan_len )
  2546. -            set_scan(r_piv->len);
  2547. -        elt_piv = r_piv->elt;
  2548. -        diag_idx = sprow_idx2(r_piv,k,r_piv->diag);
  2549. -        if ( diag_idx < 0 )
  2550. -            error(E_POSDEF,"spCHsymb");
  2551. -        old_elt = &(elt_piv[diag_idx]);
  2552. -        for ( i = 0; i < r_piv->len; i++ )
  2553. -        {
  2554. -            if ( elt_piv[i].col > k )
  2555. -                break;
  2556. -            col_list[i] = elt_piv[i].col;
  2557. -            scan_row[i] = elt_piv[i].nxt_row;
  2558. -            scan_idx[i] = elt_piv[i].nxt_idx;
  2559. -        }
  2560. -        /* printf("spCHsymb() -- checkpoint 2\n"); */
  2561. -        num_scan = i;    /* number of actual entries in scan_row etc. */
  2562. -        /* printf("num_scan = %d\n",num_scan); */
  2563. -
  2564. -        /* now set the k-th column of the Cholesky factors */
  2565. -        /* printf("k = %d\n",k); */
  2566. -        for ( ; ; )    /* forever do... */
  2567. -        {
  2568. -            /* printf("spCHsymb() -- checkpoint 3\n"); */
  2569. -            /* find next row where something (non-trivial) happens
  2570. -            i.e. find min(scan_row) */
  2571. -            minim = n;
  2572. -            for ( i = 0; i < num_scan; i++ )
  2573. -            {
  2574. -            tmp1 = scan_row[i];
  2575. -            /* printf("%d ",tmp1); */
  2576. -            minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim;
  2577. -            }
  2578. -
  2579. -            if ( minim >= n )
  2580. -            break;    /* nothing more to do for this column */
  2581. -            r_op = &(A->row[minim]);
  2582. -            elt_op = r_op->elt;
  2583. -
  2584. -            /* set next entry in column k of Cholesky factors */
  2585. -            idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]);
  2586. -            if ( idx < 0 )
  2587. -            {    /* fill-in */
  2588. -            sp_set_val(A,minim,k,0.0);
  2589. -            /* in case a realloc() has occurred... */
  2590. -            elt_op = r_op->elt;
  2591. -            /* now set up column access path again */
  2592. -            idx = sprow_idx2(r_op,k,-(idx+2));
  2593. -            tmp1 = old_elt->nxt_row;
  2594. -            old_elt->nxt_row = minim;
  2595. -            r_op->elt[idx].nxt_row = tmp1;
  2596. -            tmp1 = old_elt->nxt_idx;
  2597. -            old_elt->nxt_idx = idx;
  2598. -            r_op->elt[idx].nxt_idx = tmp1;
  2599. -            }
  2600. -
  2601. -            /* printf("spCHsymb() -- checkpoint 4\n"); */
  2602. -
  2603. -            /* remember current element in column k for column chain */
  2604. -            idx = sprow_idx2(r_op,k,idx);
  2605. -            old_elt = &(r_op->elt[idx]);
  2606. -
  2607. -            /* update scan_row */
  2608. -            /* printf("spCHsymb() -- checkpoint 5\n"); */
  2609. -            /* printf("minim = %d\n",minim); */
  2610. -            for ( i = 0; i < num_scan; i++ )
  2611. -            {
  2612. -            if ( scan_row[i] != minim )
  2613. -                continue;
  2614. -            idx = sprow_idx2(r_op,col_list[i],scan_idx[i]);
  2615. -            if ( idx < 0 )
  2616. -            {    scan_row[i] = -1;    continue;    }
  2617. -            scan_row[i] = elt_op[idx].nxt_row;
  2618. -            scan_idx[i] = elt_op[idx].nxt_idx;
  2619. -            /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */
  2620. -            /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */
  2621. -            }
  2622. -            
  2623. -        }
  2624. -        /* printf("spCHsymb() -- checkpoint 6\n"); */
  2625. -    }
  2626. -
  2627. -    return A;
  2628. -}
  2629. -
  2630. -/* comp_AAT -- compute A.A^T where A is a given sparse matrix */
  2631. -SPMAT    *comp_AAT(A)
  2632. -SPMAT    *A;
  2633. -{
  2634. -    SPMAT    *AAT;
  2635. -    SPROW    *r, *r2;
  2636. -    row_elt    *elts, *elts2;
  2637. -    int    i, idx, idx2, j, m, minim, n, num_scan, tmp1;
  2638. -    Real    ip;
  2639. -
  2640. -    if ( ! A )
  2641. -        error(E_NULL,"comp_AAT");
  2642. -    m = A->m;    n = A->n;
  2643. -
  2644. -    /* set up column access paths */
  2645. -    if ( ! A->flag_col )
  2646. -        sp_col_access(A);
  2647. -
  2648. -    AAT = sp_get(m,m,10);
  2649. -
  2650. -    for ( i = 0; i < m; i++ )
  2651. -    {
  2652. -        /* initialisation */
  2653. -        r = &(A->row[i]);
  2654. -        elts = r->elt;
  2655. -
  2656. -        /* set up scan lists for this row */
  2657. -        if ( r->len > scan_len )
  2658. -            set_scan(r->len);
  2659. -        for ( j = 0; j < r->len; j++ )
  2660. -        {
  2661. -            col_list[j] = elts[j].col;
  2662. -            scan_row[j] = elts[j].nxt_row;
  2663. -            scan_idx[j] = elts[j].nxt_idx;
  2664. -        }
  2665. -        num_scan = r->len;
  2666. -
  2667. -        /* scan down the rows for next non-zero not
  2668. -            associated with a diagonal entry */
  2669. -        for ( ; ; )
  2670. -        {
  2671. -            minim = m;
  2672. -            for ( idx = 0; idx < num_scan; idx++ )
  2673. -            {
  2674. -            tmp1 = scan_row[idx];
  2675. -            minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim;
  2676. -            }
  2677. -            if ( minim >= m )
  2678. -             break;
  2679. -            r2 = &(A->row[minim]);
  2680. -            if ( minim > i )
  2681. -            {
  2682. -            ip = sprow_ip(r,r2,n);
  2683. -                sp_set_val(AAT,minim,i,ip);
  2684. -                sp_set_val(AAT,i,minim,ip);
  2685. -            }
  2686. -            /* update scan entries */
  2687. -            elts2 = r2->elt;
  2688. -            for ( idx = 0; idx < num_scan; idx++ )
  2689. -            {
  2690. -            if ( scan_row[idx] != minim || scan_idx[idx] < 0 )
  2691. -                continue;
  2692. -            idx2 = scan_idx[idx];
  2693. -            scan_row[idx] = elts2[idx2].nxt_row;
  2694. -            scan_idx[idx] = elts2[idx2].nxt_idx;
  2695. -            }
  2696. -        }
  2697. -
  2698. -        /* set the diagonal entry */
  2699. -        sp_set_val(AAT,i,i,sprow_sqr(r,n));
  2700. -    }
  2701. -
  2702. -    return AAT;
  2703. -}
  2704. -
  2705. //GO.SYSIN DD spchfctr.c
  2706. echo splufctr.c 1>&2
  2707. sed >splufctr.c <<'//GO.SYSIN DD splufctr.c' 's/^-//'
  2708. -
  2709. -/**************************************************************************
  2710. -**
  2711. -** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved.
  2712. -**
  2713. -**                 Meschach Library
  2714. -** 
  2715. -** This Meschach Library is provided "as is" without any express 
  2716. -** or implied warranty of any kind with respect to this software. 
  2717. -** In particular the authors shall not be liable for any direct, 
  2718. -** indirect, special, incidental or consequential damages arising 
  2719. -** in any way from use of the software.
  2720. -** 
  2721. -** Everyone is granted permission to copy, modify and redistribute this
  2722. -** Meschach Library, provided:
  2723. -**  1.  All copies contain this copyright notice.
  2724. -**  2.  All modified copies shall carry a notice stating who
  2725. -**      made the last modification and the date of such modification.
  2726. -**  3.  No charge is made for this software or works derived from it.  
  2727. -**      This clause shall not be construed as constraining other software
  2728. -**      distributed on the same medium as this software, nor is a
  2729. -**      distribution fee considered a charge.
  2730. -**
  2731. -***************************************************************************/
  2732. -
  2733. -
  2734. -/*
  2735. -    Sparse LU factorisation
  2736. -    See also: sparse.[ch] etc for details about sparse matrices
  2737. -*/
  2738. -
  2739. -#include    <stdio.h>
  2740. -#include    <math.h>
  2741. -#include        "sparse2.h"
  2742. -
  2743. -
  2744. -
  2745. -/* Macro for speedup */
  2746. -/* #define    sprow_idx2(r,c,hint)    \
  2747. -   ( ( (hint) >= 0 && (r)->elt[hint].col == (c)) ? hint : sprow_idx((r),(c)) ) */
  2748. -
  2749. -
  2750. -/* spLUfactor -- sparse LU factorisation with pivoting
  2751. -    -- uses partial pivoting and Markowitz criterion
  2752. -            |a[p][k]| >= alpha * max_i |a[i][k]|
  2753. -    -- creates fill-in as needed
  2754. -    -- in situ factorisation */
  2755. -SPMAT    *spLUfactor(A,px,alpha)
  2756. -SPMAT    *A;
  2757. -PERM    *px;
  2758. -double    alpha;
  2759. -{
  2760. -    int    i, best_i, k, idx, len, best_len, m, n;
  2761. -    SPROW    *r, *r_piv, tmp_row;
  2762. -    static    SPROW    *merge = (SPROW *)NULL;
  2763. -    Real    max_val, tmp;
  2764. -    static VEC    *col_vals=VNULL;
  2765. -
  2766. -    if ( ! A || ! px )
  2767. -        error(E_NULL,"spLUfctr");
  2768. -    if ( alpha <= 0.0 || alpha > 1.0 )
  2769. -        error(E_RANGE,"alpha in spLUfctr");
  2770. -    if ( px->size <= A->m )
  2771. -        px = px_resize(px,A->m);
  2772. -    px_ident(px);
  2773. -    col_vals = v_resize(col_vals,A->m);
  2774. -    MEM_STAT_REG(col_vals,TYPE_VEC);
  2775. -
  2776. -    m = A->m;    n = A->n;
  2777. -    if ( ! A->flag_col )
  2778. -        sp_col_access(A);
  2779. -    if ( ! A->flag_diag )
  2780. -        sp_diag_access(A);
  2781. -    A->flag_col = A->flag_diag = FALSE;
  2782. -    if ( ! merge ) {
  2783. -       merge = sprow_get(20);
  2784. -       MEM_STAT_REG(merge,TYPE_SPROW);
  2785. -    }
  2786. -
  2787. -    for ( k = 0; k < n; k++ )
  2788. -    {
  2789. -        /* find pivot row/element for partial pivoting */
  2790. -
  2791. -        /* get first row with a non-zero entry in the k-th column */
  2792. -        max_val = 0.0;
  2793. -        for ( i = k; i < m; i++ )
  2794. -        {
  2795. -        r = &(A->row[i]);
  2796. -        idx = sprow_idx(r,k);
  2797. -        if ( idx < 0 )
  2798. -            tmp = 0.0;
  2799. -        else
  2800. -            tmp = r->elt[idx].val;
  2801. -        if ( fabs(tmp) > max_val )
  2802. -            max_val = fabs(tmp);
  2803. -        col_vals->ve[i] = tmp;
  2804. -        }
  2805. -
  2806. -        if ( max_val == 0.0 )
  2807. -        continue;
  2808. -
  2809. -        best_len = n+1;    /* only if no possibilities */
  2810. -        best_i = -1;
  2811. -        for ( i = k; i < m; i++ )
  2812. -        {
  2813. -        tmp = fabs(col_vals->ve[i]);
  2814. -        if ( tmp == 0.0 )
  2815. -            continue;
  2816. -        if ( tmp >= alpha*max_val )
  2817. -        {
  2818. -            r = &(A->row[i]);
  2819. -            idx = sprow_idx(r,k);
  2820. -            len = (r->len) - idx;
  2821. -            if ( len < best_len )
  2822. -            {
  2823. -            best_len = len;
  2824. -            best_i = i;
  2825. -            }
  2826. -        }
  2827. -        }
  2828. -
  2829. -        /* swap row #best_i with row #k */
  2830. -        MEM_COPY(&(A->row[best_i]),&tmp_row,sizeof(SPROW));
  2831. -        MEM_COPY(&(A->row[k]),&(A->row[best_i]),sizeof(SPROW));
  2832. -        MEM_COPY(&tmp_row,&(A->row[k]),sizeof(SPROW));
  2833. -        /* swap col_vals entries */
  2834. -        tmp = col_vals->ve[best_i];
  2835. -        col_vals->ve[best_i] = col_vals->ve[k];
  2836. -        col_vals->ve[k] = tmp;
  2837. -        px_transp(px,k,best_i);
  2838. -
  2839. -        r_piv = &(A->row[k]);
  2840. -        for ( i = k+1; i < n; i++ )
  2841. -        {
  2842. -        /* compute and set multiplier */
  2843. -        tmp = col_vals->ve[i]/col_vals->ve[k];
  2844. -        if ( tmp != 0.0 )
  2845. -            sp_set_val(A,i,k,tmp);
  2846. -        else
  2847. -            continue;
  2848. -
  2849. -        /* perform row operations */
  2850. -        merge->len = 0;
  2851. -        r = &(A->row[i]);
  2852. -        sprow_mltadd(r,r_piv,-tmp,k+1,merge,TYPE_SPROW);
  2853. -        idx = sprow_idx(r,k+1);
  2854. -        if ( idx < 0 )
  2855. -            idx = -(idx+2);
  2856. -        /* see if r needs expanding */
  2857. -        if ( r->maxlen < idx + merge->len )
  2858. -            sprow_xpd(r,idx+merge->len,TYPE_SPMAT);
  2859. -        r->len = idx+merge->len;
  2860. -        MEM_COPY((char *)(merge->elt),(char *)&(r->elt[idx]),
  2861. -            merge->len*sizeof(row_elt));
  2862. -        }
  2863. -    }
  2864. -
  2865. -    return A;
  2866. -}
  2867. -
  2868. -/* spLUsolve -- solve A.x = b using factored matrix A from spLUfactor()
  2869. -    -- returns x
  2870. -    -- may not be in-situ */
  2871. -VEC    *spLUsolve(A,pivot,b,x)
  2872. -SPMAT    *A;
  2873. -PERM    *pivot;
  2874. -VEC    *b, *x;
  2875. -{
  2876. -    int    i, idx, len, lim;
  2877. -    Real    sum, *x_ve;
  2878. -    SPROW    *r;
  2879. -    row_elt    *elt;
  2880. -
  2881. -    if ( ! A || ! b )
  2882. -        error(E_NULL,"spLUsolve");
  2883. -    if ( (pivot != PNULL && A->m != pivot->size) || A->m != b->dim )
  2884. -        error(E_SIZES,"spLUsolve");
  2885. -    if ( ! x || x->dim != A->n )
  2886. -        x = v_resize(x,A->n);
  2887. -
  2888. -    if ( pivot != PNULL )
  2889. -        x = px_vec(pivot,b,x);
  2890. -    else
  2891. -        x = v_copy(b,x);
  2892. -
  2893. -    x_ve = x->ve;
  2894. -    lim = min(A->m,A->n);
  2895. -    for ( i = 0; i < lim; i++ )
  2896. -    {
  2897. -        sum = x_ve[i];
  2898. -        r = &(A->row[i]);
  2899. -        len = r->len;
  2900. -        elt = r->elt;
  2901. -        for ( idx = 0; idx < len && elt->col < i; idx++, elt++ )
  2902. -        sum -= elt->val*x_ve[elt->col];
  2903. -        x_ve[i] = sum;
  2904. -    }
  2905. -
  2906. -    for ( i = lim-1; i >= 0; i-- )
  2907. -    {
  2908. -        sum = x_ve[i];
  2909. -        r = &(A->row[i]);
  2910. -        len = r->len;
  2911. -        elt = &(r->elt[len-1]);
  2912. -        for ( idx = len-1; idx >= 0 && elt->col > i; idx--, elt-- )
  2913. -        sum -= elt->val*x_ve[elt->col];
  2914. -        if ( idx < 0 || elt->col != i || elt->val == 0.0 )
  2915. -        error(E_SING,"spLUsolve");
  2916. -        x_ve[i] = sum/elt->val;
  2917. -    }
  2918. -
  2919. -    return x;
  2920. -}
  2921. -
  2922. -/* spLUTsolve -- solve A.x = b using factored matrix A from spLUfactor()
  2923. -    -- returns x
  2924. -    -- may not be in-situ */
  2925. -VEC    *spLUTsolve(A,pivot,b,x)
  2926. -SPMAT    *A;
  2927. -PERM    *pivot;
  2928. -VEC    *b, *x;
  2929. -{
  2930. -    int    i, idx, lim, rownum;
  2931. -    Real    sum, *tmp_ve;
  2932. -    /* SPROW    *r; */
  2933. -    row_elt    *elt;
  2934. -    static VEC    *tmp=VNULL;
  2935. -
  2936. -    if ( ! A || ! b )
  2937. -        error(E_NULL,"spLUTsolve");
  2938. -    if ( (pivot != PNULL && A->m != pivot->size) || A->m != b->dim )
  2939. -        error(E_SIZES,"spLUTsolve");
  2940. -    tmp = v_copy(b,tmp);
  2941. -    MEM_STAT_REG(tmp,TYPE_VEC);
  2942. -
  2943. -    if ( ! A->flag_col )
  2944. -        sp_col_access(A);
  2945. -    if ( ! A->flag_diag )
  2946. -        sp_diag_access(A);
  2947. -
  2948. -    lim = min(A->m,A->n);
  2949. -    tmp_ve = tmp->ve;
  2950. -    /* solve U^T.tmp = b */
  2951. -    for ( i = 0; i < lim; i++ )
  2952. -    {
  2953. -        sum = tmp_ve[i];
  2954. -        rownum = A->start_row[i];
  2955. -        idx    = A->start_idx[i];
  2956. -        if ( rownum < 0 || idx < 0 )
  2957. -        error(E_SING,"spLUTsolve");
  2958. -        while ( rownum < i && rownum >= 0 && idx >= 0 )
  2959. -        {
  2960. -        elt = &(A->row[rownum].elt[idx]);
  2961. -        sum -= elt->val*tmp_ve[rownum];
  2962. -        rownum = elt->nxt_row;
  2963. -        idx    = elt->nxt_idx;
  2964. -        }
  2965. -        if ( rownum != i )
  2966. -        error(E_SING,"spLUTsolve");
  2967. -        elt = &(A->row[rownum].elt[idx]);
  2968. -        if ( elt->val == 0.0 )
  2969. -        error(E_SING,"spLUTsolve");
  2970. -        tmp_ve[i] = sum/elt->val;
  2971. -    }
  2972. -
  2973. -    /* now solve L^T.tmp = (old) tmp */
  2974. -    for ( i = lim-1; i >= 0; i-- )
  2975. -    {
  2976. -        sum = tmp_ve[i];
  2977. -        rownum = i;
  2978. -        idx    = A->row[rownum].diag;
  2979. -        if ( idx < 0 )
  2980. -        error(E_NULL,"spLUTsolve");
  2981. -        elt = &(A->row[rownum].elt[idx]);
  2982. -        rownum = elt->nxt_row;
  2983. -        idx    = elt->nxt_idx;
  2984. -        while ( rownum < lim && rownum >= 0 && idx >= 0 )
  2985. -        {
  2986. -        elt = &(A->row[rownum].elt[idx]);
  2987. -        sum -= elt->val*tmp_ve[rownum];
  2988. -        rownum = elt->nxt_row;
  2989. -        idx    = elt->nxt_idx;
  2990. -        }
  2991. -        tmp_ve[i] = sum;
  2992. -    }
  2993. -
  2994. -    if ( pivot != PNULL )
  2995. -        x = pxinv_vec(pivot,tmp,x);
  2996. -    else
  2997. -        x = v_copy(tmp,x);
  2998. -
  2999. -    return x;
  3000. -}
  3001. -
  3002. -/* spILUfactor -- sparse modified incomplete LU factorisation with
  3003. -                        no pivoting
  3004. -    -- all pivot entries are ensured to be >= alpha in magnitude
  3005. -    -- setting alpha = 0 gives incomplete LU factorisation
  3006. -    -- no fill-in is generated
  3007. -    -- in situ factorisation */
  3008. -SPMAT    *spILUfactor(A,alpha)
  3009. -SPMAT    *A;
  3010. -double    alpha;
  3011. -{
  3012. -    int        i, k, idx, idx_piv, m, n, old_idx, old_idx_piv;
  3013. -    SPROW    *r, *r_piv;
  3014. -    Real    piv_val, tmp;
  3015. -    
  3016. -    /* printf("spILUfactor: entered\n"); */
  3017. -    if ( ! A )
  3018. -    error(E_NULL,"spILUfactor");
  3019. -    if ( alpha < 0.0 )
  3020. -    error(E_RANGE,"[alpha] in spILUfactor");
  3021. -    
  3022. -    m = A->m;    n = A->n;
  3023. -    sp_diag_access(A);
  3024. -    sp_col_access(A);
  3025. -    
  3026. -    for ( k = 0; k < n; k++ )
  3027. -    {
  3028. -    /* printf("spILUfactor(l.%d): checkpoint A: k = %d\n",__LINE__,k); */
  3029. -    /* printf("spILUfactor(l.%d): A =\n", __LINE__); */
  3030. -    /* sp_output(A); */
  3031. -    r_piv = &(A->row[k]);
  3032. -    idx_piv = r_piv->diag;
  3033. -    if ( idx_piv < 0 )
  3034. -    {
  3035. -        sprow_set_val(r_piv,k,alpha);
  3036. -        idx_piv = sprow_idx(r_piv,k);
  3037. -    }
  3038. -    /* printf("spILUfactor: checkpoint B\n"); */
  3039. -    if ( idx_piv < 0 )
  3040. -        error(E_BOUNDS,"spILUfactor");
  3041. -    old_idx_piv = idx_piv;
  3042. -    piv_val = r_piv->elt[idx_piv].val;
  3043. -    /* printf("spILUfactor: checkpoint C\n"); */
  3044. -    if ( fabs(piv_val) < alpha )
  3045. -        piv_val = ( piv_val < 0.0 ) ? -alpha : alpha;
  3046. -    if ( piv_val == 0.0 )    /* alpha == 0.0 too! */
  3047. -        error(E_SING,"spILUfactor");
  3048. -
  3049. -    /* go to next row with a non-zero in this column */
  3050. -    i = r_piv->elt[idx_piv].nxt_row;
  3051. -    old_idx = idx = r_piv->elt[idx_piv].nxt_idx;
  3052. -    while ( i >= k )
  3053. -    {
  3054. -        /* printf("spILUfactor: checkpoint D: i = %d\n",i); */
  3055. -        /* perform row operations */
  3056. -        r = &(A->row[i]);
  3057. -        /* idx = sprow_idx(r,k); */
  3058. -        /* printf("spLUfactor(l.%d) i = %d, idx = %d\n",
  3059. -           __LINE__, i, idx); */
  3060. -        if ( idx < 0 )
  3061. -        {
  3062. -        idx = r->elt[old_idx].nxt_idx;
  3063. -        i = r->elt[old_idx].nxt_row;
  3064. -        continue;
  3065. -        }
  3066. -        /* printf("spILUfactor: checkpoint E\n"); */
  3067. -        /* compute and set multiplier */
  3068. -        r->elt[idx].val = tmp = r->elt[idx].val/piv_val;
  3069. -        /* printf("spILUfactor: piv_val = %g, multiplier = %g\n",
  3070. -           piv_val, tmp); */
  3071. -        /* printf("spLUfactor(l.%d) multiplier = %g\n", __LINE__, tmp); */
  3072. -        if ( tmp == 0.0 )
  3073. -        {
  3074. -        idx = r->elt[old_idx].nxt_idx;
  3075. -        i = r->elt[old_idx].nxt_row;
  3076. -        continue;
  3077. -        }
  3078. -        /* idx = sprow_idx(r,k+1); */
  3079. -        /* if ( idx < 0 )
  3080. -        idx = -(idx+2); */
  3081. -        idx_piv++;    idx++;    /* now look beyond the multiplier entry */
  3082. -        /* printf("spILUfactor: checkpoint F: idx = %d, idx_piv = %d\n",
  3083. -           idx, idx_piv); */
  3084. -        while ( idx_piv < r_piv->len && idx < r->len )
  3085. -        {
  3086. -        /* printf("spILUfactor: checkpoint G: idx = %d, idx_piv = %d\n",
  3087. -               idx, idx_piv); */
  3088. -        if ( r_piv->elt[idx_piv].col < r->elt[idx].col )
  3089. -            idx_piv++;
  3090. -        else if ( r_piv->elt[idx_piv].col > r->elt[idx].col )
  3091. -            idx++;
  3092. -        else /* column numbers match */
  3093. -        {
  3094. -            /* printf("spILUfactor(l.%d) subtract %g times the ",
  3095. -               __LINE__, tmp); */
  3096. -            /* printf("(%d,%d) entry to the (%d,%d) entry\n",
  3097. -               k, r_piv->elt[idx_piv].col,
  3098. -               i, r->elt[idx].col); */
  3099. -            r->elt[idx].val -= tmp*r_piv->elt[idx_piv].val;
  3100. -            idx++;    idx_piv++;
  3101. -        }
  3102. -        }
  3103. -
  3104. -        /* bump to next row with a non-zero in column k */
  3105. -        /* printf("spILUfactor(l.%d) column = %d, row[%d] =\n",
  3106. -           __LINE__, r->elt[old_idx].col, i); */
  3107. -        /* sprow_foutput(stdout,r); */
  3108. -        i = r->elt[old_idx].nxt_row;
  3109. -        old_idx = idx = r->elt[old_idx].nxt_idx;
  3110. -        /* printf("spILUfactor(l.%d) i = %d, idx = %d\n", __LINE__, i, idx); */
  3111. -        /* and restore idx_piv to index of pivot entry */
  3112. -        idx_piv = old_idx_piv;
  3113. -    }
  3114. -    }
  3115. -    /* printf("spILUfactor: exiting\n"); */
  3116. -    return A;
  3117. -}
  3118. //GO.SYSIN DD splufctr.c
  3119. echo spbkp.c 1>&2
  3120. sed >spbkp.c <<'//GO.SYSIN DD spbkp.c' 's/^-//'
  3121. -
  3122. -/**************************************************************************
  3123. -**
  3124. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  3125. -**
  3126. -**                 Meschach Library
  3127. -** 
  3128. -** This Meschach Library is provided "as is" without any express 
  3129. -** or implied warranty of any kind with respect to this software. 
  3130. -** In particular the authors shall not be liable for any direct, 
  3131. -** indirect, special, incidental or consequential damages arising 
  3132. -** in any way from use of the software.
  3133. -** 
  3134. -** Everyone is granted permission to copy, modify and redistribute this
  3135. -** Meschach Library, provided:
  3136. -**  1.  All copies contain this copyright notice.
  3137. -**  2.  All modified copies shall carry a notice stating who
  3138. -**      made the last modification and the date of such modification.
  3139. -**  3.  No charge is made for this software or works derived from it.  
  3140. -**      This clause shall not be construed as constraining other software
  3141. -**      distributed on the same medium as this software, nor is a
  3142. -**      distribution fee considered a charge.
  3143. -**
  3144. -***************************************************************************/
  3145. -
  3146. -
  3147. -/*
  3148. -  Sparse matrix Bunch--Kaufman--Parlett factorisation and solve
  3149. -  Radical revision started Thu 05th Nov 1992, 09:36:12 AM
  3150. -  to use Karen George's suggestion of leaving the the row elements unordered
  3151. -  Radical revision completed Mon 07th Dec 1992, 10:59:57 AM
  3152. -*/
  3153. -
  3154. -static    char    rcsid[] = "$Id: spbkp.c,v 1.5 1994/01/13 05:44:35 des Exp $";
  3155. -
  3156. -#include    <stdio.h>
  3157. -#include    <math.h>
  3158. -#include    "matrix.h"
  3159. -#include    "sparse.h"
  3160. -#include        "sparse2.h"
  3161. -
  3162. -
  3163. -#ifdef MALLOCDECL
  3164. -#include <malloc.h>
  3165. -#endif
  3166. -
  3167. -#define alpha    0.6403882032022076 /* = (1+sqrt(17))/8 */
  3168. -
  3169. -
  3170. -#define    btos(x)    ((x) ? "TRUE" : "FALSE")
  3171. -
  3172. -/* assume no use of sqr() uses side-effects */
  3173. -#define    sqr(x)    ((x)*(x))
  3174. -
  3175. -/* unord_get_idx -- returns index (encoded if entry not allocated)
  3176. -    of the element of row r with column j
  3177. -    -- uses linear search */
  3178. -int    unord_get_idx(r,j)
  3179. -SPROW    *r;
  3180. -int    j;
  3181. -{
  3182. -    int        idx;
  3183. -    row_elt    *e;
  3184. -
  3185. -    if ( ! r || ! r->elt )
  3186. -    error(E_NULL,"unord_get_idx");
  3187. -    for ( idx = 0, e = r->elt; idx < r->len; idx++, e++ )
  3188. -    if ( e->col == j )
  3189. -        break;
  3190. -    if ( idx >= r->len )
  3191. -    return -(r->len+2);
  3192. -    else
  3193. -    return idx;
  3194. -}
  3195. -
  3196. -/* unord_get_val -- returns value of the (i,j) entry of A
  3197. -    -- same assumptions as unord_get_idx() */
  3198. -double    unord_get_val(A,i,j)
  3199. -SPMAT    *A;
  3200. -int    i, j;
  3201. -{
  3202. -    SPROW    *r;
  3203. -    int        idx;
  3204. -
  3205. -    if ( ! A )
  3206. -    error(E_NULL,"unord_get_val");
  3207. -    if ( i < 0 || i >= A->m || j < 0 || j >= A->n )
  3208. -    error(E_BOUNDS,"unord_get_val");
  3209. -
  3210. -    r = &(A->row[i]);
  3211. -    idx = unord_get_idx(r,j);
  3212. -    if ( idx < 0 )
  3213. -    return 0.0;
  3214. -    else
  3215. -    return r->elt[idx].val;
  3216. -}
  3217. -
  3218. -        
  3219. -/* bkp_swap_elt -- swaps the (i,j) with the (k,l) entry of sparse matrix
  3220. -    -- either or both of the entries may be unallocated */
  3221. -static SPMAT    *bkp_swap_elt(A,i1,j1,idx1,i2,j2,idx2)
  3222. -SPMAT    *A;
  3223. -int    i1, j1, idx1, i2, j2, idx2;
  3224. -{
  3225. -    int        tmp_row, tmp_idx;
  3226. -    SPROW    *r1, *r2;
  3227. -    row_elt    *e1, *e2;
  3228. -    Real    tmp;
  3229. -
  3230. -    if ( ! A )
  3231. -    error(E_NULL,"bkp_swap_elt");
  3232. -
  3233. -    if ( i1 < 0 || j1 < 0 || i2 < 0 || j2 < 0 ||
  3234. -     i1 >= A->m || j1 >= A->n || i2 >= A->m || j2 >= A->n )
  3235. -    {
  3236. -    error(E_BOUNDS,"bkp_swap_elt");
  3237. -    }
  3238. -
  3239. -    if ( i1 == i2 && j1 == j2 )
  3240. -    return A;
  3241. -    if ( idx1 < 0 && idx2 < 0 )    /* neither allocated */
  3242. -    return A;
  3243. -
  3244. -    r1 = &(A->row[i1]);        r2 = &(A->row[i2]);
  3245. -    /* if ( idx1 >= r1->len || idx2 >= r2->len )
  3246. -    error(E_BOUNDS,"bkp_swap_elt"); */
  3247. -    if ( idx1 < 0 )    /* assume not allocated */
  3248. -    {
  3249. -    idx1 = r1->len;
  3250. -    if ( idx1 >= r1->maxlen )
  3251. -    {    tracecatch(sprow_xpd(r1,2*r1->maxlen+1,TYPE_SPMAT),
  3252. -            "bkp_swap_elt");    }
  3253. -    r1->len = idx1+1;
  3254. -    r1->elt[idx1].col = j1;
  3255. -    r1->elt[idx1].val = 0.0;
  3256. -    /* now patch up column access path */
  3257. -    tmp_row = -1;    tmp_idx = j1;
  3258. -    chase_col(A,j1,&tmp_row,&tmp_idx,i1-1);
  3259. -
  3260. -    if ( tmp_row < 0 )
  3261. -    {
  3262. -        r1->elt[idx1].nxt_row = A->start_row[j1];
  3263. -        r1->elt[idx1].nxt_idx = A->start_idx[j1];
  3264. -        A->start_row[j1] = i1;
  3265. -        A->start_idx[j1] = idx1;
  3266. -    }
  3267. -    else
  3268. -    {
  3269. -        row_elt    *tmp_e;
  3270. -
  3271. -        tmp_e = &(A->row[tmp_row].elt[tmp_idx]);
  3272. -        r1->elt[idx1].nxt_row = tmp_e->nxt_row;
  3273. -        r1->elt[idx1].nxt_idx = tmp_e->nxt_idx;
  3274. -        tmp_e->nxt_row = i1;
  3275. -        tmp_e->nxt_idx = idx1;
  3276. -    }
  3277. -    }
  3278. -    else if ( r1->elt[idx1].col != j1 )
  3279. -    error(E_INTERN,"bkp_swap_elt");
  3280. -    if ( idx2 < 0 )
  3281. -    {
  3282. -    idx2 = r2->len;
  3283. -    if ( idx2 >= r2->maxlen )
  3284. -    {    tracecatch(sprow_xpd(r2,2*r2->maxlen+1,TYPE_SPMAT),
  3285. -            "bkp_swap_elt");    }
  3286. -
  3287. -    r2->len = idx2+1;
  3288. -    r2->elt[idx2].col = j2;
  3289. -    r2->elt[idx2].val = 0.0;
  3290. -    /* now patch up column access path */
  3291. -    tmp_row = -1;    tmp_idx = j2;
  3292. -    chase_col(A,j2,&tmp_row,&tmp_idx,i2-1);
  3293. -    if ( tmp_row < 0 )
  3294. -    {
  3295. -        r2->elt[idx2].nxt_row = A->start_row[j2];
  3296. -        r2->elt[idx2].nxt_idx = A->start_idx[j2];
  3297. -        A->start_row[j2] = i2;
  3298. -        A->start_idx[j2] = idx2;
  3299. -    }
  3300. -    else
  3301. -    {
  3302. -        row_elt    *tmp_e;
  3303. -
  3304. -        tmp_e = &(A->row[tmp_row].elt[tmp_idx]);
  3305. -        r2->elt[idx2].nxt_row = tmp_e->nxt_row;
  3306. -        r2->elt[idx2].nxt_idx = tmp_e->nxt_idx;
  3307. -        tmp_e->nxt_row = i2;
  3308. -        tmp_e->nxt_idx = idx2;
  3309. -    }
  3310. -    }
  3311. -    else if ( r2->elt[idx2].col != j2 )
  3312. -    error(E_INTERN,"bkp_swap_elt");
  3313. -
  3314. -    e1 = &(r1->elt[idx1]);    e2 = &(r2->elt[idx2]);
  3315. -
  3316. -    tmp = e1->val;
  3317. -    e1->val = e2->val;
  3318. -    e2->val = tmp;
  3319. -
  3320. -    return A;
  3321. -}
  3322. -
  3323. -/* bkp_bump_col -- bumps row and idx to next entry in column j */
  3324. -row_elt    *bkp_bump_col(A, j, row, idx)
  3325. -SPMAT    *A;
  3326. -int    j, *row, *idx;
  3327. -{
  3328. -    SPROW    *r;
  3329. -    row_elt    *e;
  3330. -
  3331. -    if ( *row < 0 )
  3332. -    {
  3333. -    *row = A->start_row[j];
  3334. -    *idx = A->start_idx[j];
  3335. -    }
  3336. -    else
  3337. -    {
  3338. -    r = &(A->row[*row]);
  3339. -    e = &(r->elt[*idx]);
  3340. -    if ( e->col != j )
  3341. -        error(E_INTERN,"bkp_bump_col");
  3342. -    *row = e->nxt_row;
  3343. -    *idx = e->nxt_idx;
  3344. -    }
  3345. -    if ( *row < 0 )
  3346. -    return (row_elt *)NULL;
  3347. -    else
  3348. -    return &(A->row[*row].elt[*idx]);
  3349. -}
  3350. -
  3351. -/* bkp_interchange -- swap rows/cols i and j (symmetric pivot)
  3352. -    -- uses just the upper triangular part */
  3353. -SPMAT    *bkp_interchange(A, i1, i2)
  3354. -SPMAT    *A;
  3355. -int    i1, i2;
  3356. -{
  3357. -    int        tmp_row, tmp_idx;
  3358. -    int        row1, row2, idx1, idx2, tmp_row1, tmp_idx1, tmp_row2, tmp_idx2;
  3359. -    SPROW    *r1, *r2;
  3360. -    row_elt    *e1, *e2;
  3361. -    IVEC    *done_list = IVNULL;
  3362. -
  3363. -    if ( ! A )
  3364. -    error(E_NULL,"bkp_interchange");
  3365. -    if ( i1 < 0 || i1 >= A->n || i2 < 0 || i2 >= A->n )
  3366. -    error(E_BOUNDS,"bkp_interchange");
  3367. -    if ( A->m != A->n )
  3368. -    error(E_SQUARE,"bkp_interchange");
  3369. -
  3370. -    if ( i1 == i2 )
  3371. -    return A;
  3372. -    if ( i1 > i2 )
  3373. -    {    tmp_idx = i1;    i1 = i2;    i2 = tmp_idx;    }
  3374. -
  3375. -    done_list = iv_resize(done_list,A->n);
  3376. -    for ( tmp_idx = 0; tmp_idx < A->n; tmp_idx++ )
  3377. -    done_list->ive[tmp_idx] = FALSE;
  3378. -    row1 = -1;        idx1 = i1;
  3379. -    row2 = -1;        idx2 = i2;
  3380. -    e1 = bkp_bump_col(A,i1,&row1,&idx1);
  3381. -    e2 = bkp_bump_col(A,i2,&row2,&idx2);
  3382. -
  3383. -    while ( (row1 >= 0 && row1 < i1) || (row2 >= 0 && row2 < i1) )
  3384. -    /* Note: "row2 < i1" not "row2 < i2" as we must stop before the
  3385. -       "knee bend" */
  3386. -    {
  3387. -    if ( row1 >= 0 && row1 < i1 && ( row1 < row2 || row2 < 0 ) )
  3388. -    {
  3389. -        tmp_row1 = row1;    tmp_idx1 = idx1;
  3390. -        e1 = bkp_bump_col(A,i1,&tmp_row1,&tmp_idx1);
  3391. -        if ( ! done_list->ive[row1] )
  3392. -        {
  3393. -        if ( row1 == row2 )
  3394. -            bkp_swap_elt(A,row1,i1,idx1,row1,i2,idx2);
  3395. -        else
  3396. -            bkp_swap_elt(A,row1,i1,idx1,row1,i2,-1);
  3397. -        done_list->ive[row1] = TRUE;
  3398. -        }
  3399. -        row1 = tmp_row1;    idx1 = tmp_idx1;
  3400. -    }
  3401. -    else if ( row2 >= 0 && row2 < i1 && ( row2 < row1 || row1 < 0 ) )
  3402. -    {
  3403. -        tmp_row2 = row2;    tmp_idx2 = idx2;
  3404. -        e2 = bkp_bump_col(A,i2,&tmp_row2,&tmp_idx2);
  3405. -        if ( ! done_list->ive[row2] )
  3406. -        {
  3407. -        if ( row1 == row2 )
  3408. -            bkp_swap_elt(A,row2,i1,idx1,row2,i2,idx2);
  3409. -        else
  3410. -            bkp_swap_elt(A,row2,i1,-1,row2,i2,idx2);
  3411. -        done_list->ive[row2] = TRUE;
  3412. -        }
  3413. -        row2 = tmp_row2;    idx2 = tmp_idx2;
  3414. -    }
  3415. -    else if ( row1 == row2 )
  3416. -    {
  3417. -        tmp_row1 = row1;    tmp_idx1 = idx1;
  3418. -        e1 = bkp_bump_col(A,i1,&tmp_row1,&tmp_idx1);
  3419. -        tmp_row2 = row2;    tmp_idx2 = idx2;
  3420. -        e2 = bkp_bump_col(A,i2,&tmp_row2,&tmp_idx2);
  3421. -        if ( ! done_list->ive[row1] )
  3422. -        {
  3423. -        bkp_swap_elt(A,row1,i1,idx1,row2,i2,idx2);
  3424. -        done_list->ive[row1] = TRUE;
  3425. -        }
  3426. -        row1 = tmp_row1;    idx1 = tmp_idx1;
  3427. -        row2 = tmp_row2;    idx2 = tmp_idx2;
  3428. -    }
  3429. -    }
  3430. -
  3431. -    /* ensure we are **past** the first knee */
  3432. -    while ( row2 >= 0 && row2 <= i1 )
  3433. -    e2 = bkp_bump_col(A,i2,&row2,&idx2);
  3434. -
  3435. -    /* at/after 1st "knee bend" */
  3436. -    r1 = &(A->row[i1]);
  3437. -    idx1 = 0;
  3438. -    e1 = &(r1->elt[idx1]);
  3439. -    while ( row2 >= 0 && row2 < i2 )
  3440. -    {
  3441. -    /* used for update of e2 at end of loop */
  3442. -    tmp_row = row2;    tmp_idx = idx2;
  3443. -    if ( ! done_list->ive[row2] )
  3444. -    {
  3445. -        r2 = &(A->row[row2]);
  3446. -        bkp_bump_col(A,i2,&tmp_row,&tmp_idx);
  3447. -        done_list->ive[row2] = TRUE;
  3448. -        tmp_idx1 = unord_get_idx(r1,row2);
  3449. -        tracecatch(bkp_swap_elt(A,row2,i2,idx2,i1,row2,tmp_idx1),
  3450. -               "bkp_interchange");
  3451. -    }
  3452. -
  3453. -    /* update e1 and e2 */
  3454. -    row2 = tmp_row;    idx2 = tmp_idx;
  3455. -    e2 = ( row2 >= 0 ) ? &(A->row[row2].elt[idx2]) : (row_elt *)NULL;
  3456. -    }
  3457. -
  3458. -    idx1 = 0;
  3459. -    e1 = r1->elt;
  3460. -    while ( idx1 < r1->len )
  3461. -    {
  3462. -    if ( e1->col >= i2 || e1->col <= i1 )
  3463. -    {
  3464. -        idx1++;
  3465. -        e1++;
  3466. -        continue;
  3467. -    }
  3468. -    if ( ! done_list->ive[e1->col] )
  3469. -    {
  3470. -        tmp_idx2 = unord_get_idx(&(A->row[e1->col]),i2);
  3471. -        tracecatch(bkp_swap_elt(A,i1,e1->col,idx1,e1->col,i2,tmp_idx2),
  3472. -               "bkp_interchange");
  3473. -        done_list->ive[e1->col] = TRUE;
  3474. -    }
  3475. -    idx1++;
  3476. -    e1++;
  3477. -    }
  3478. -
  3479. -    /* at/after 2nd "knee bend" */
  3480. -    idx1 = 0;
  3481. -    e1 = &(r1->elt[idx1]);
  3482. -    r2 = &(A->row[i2]);
  3483. -    idx2 = 0;
  3484. -    e2 = &(r2->elt[idx2]);
  3485. -    while ( idx1 < r1->len )
  3486. -    {
  3487. -    if ( e1->col <= i2 )
  3488. -    {
  3489. -        idx1++;    e1++;
  3490. -        continue;
  3491. -    }
  3492. -    if ( ! done_list->ive[e1->col] )
  3493. -    {
  3494. -        tmp_idx2 = unord_get_idx(r2,e1->col);
  3495. -        tracecatch(bkp_swap_elt(A,i1,e1->col,idx1,i2,e1->col,tmp_idx2),
  3496. -               "bkp_interchange");
  3497. -        done_list->ive[e1->col] = TRUE;
  3498. -    }
  3499. -    idx1++;    e1++;
  3500. -    }
  3501. -
  3502. -    idx2 = 0;    e2 = r2->elt;
  3503. -    while ( idx2 < r2->len )
  3504. -    {
  3505. -    if ( e2->col <= i2 )
  3506. -    {
  3507. -        idx2++;    e2++;
  3508. -        continue;
  3509. -    }
  3510. -    if ( ! done_list->ive[e2->col] )
  3511. -    {
  3512. -        tmp_idx1 = unord_get_idx(r1,e2->col);
  3513. -        tracecatch(bkp_swap_elt(A,i2,e2->col,idx2,i1,e2->col,tmp_idx1),
  3514. -               "bkp_interchange");
  3515. -        done_list->ive[e2->col] = TRUE;
  3516. -    }
  3517. -    idx2++;    e2++;
  3518. -    }
  3519. -
  3520. -    /* now interchange the digonal entries! */
  3521. -    idx1 = unord_get_idx(&(A->row[i1]),i1);
  3522. -    idx2 = unord_get_idx(&(A->row[i2]),i2);
  3523. -    if ( idx1 >= 0 || idx2 >= 0 )
  3524. -    {
  3525. -    tracecatch(bkp_swap_elt(A,i1,i1,idx1,i2,i2,idx2),
  3526. -           "bkp_interchange");
  3527. -    }
  3528. -
  3529. -    return A;
  3530. -}
  3531. -
  3532. -
  3533. -/* iv_min -- returns minimum of an integer vector
  3534. -   -- sets index to the position in iv if index != NULL */
  3535. -int    iv_min(iv,index)
  3536. -IVEC    *iv;
  3537. -int    *index;
  3538. -{
  3539. -    int        i, i_min, min_val, tmp;
  3540. -    
  3541. -    if ( ! iv ) 
  3542. -    error(E_NULL,"iv_min");
  3543. -    if ( iv->dim <= 0 )
  3544. -    error(E_SIZES,"iv_min");
  3545. -    i_min = 0;
  3546. -    min_val = iv->ive[0];
  3547. -    for ( i = 1; i < iv->dim; i++ )
  3548. -    {
  3549. -    tmp = iv->ive[i];
  3550. -    if ( tmp < min_val )
  3551. -    {
  3552. -        min_val = tmp;
  3553. -        i_min = i;
  3554. -    }
  3555. -    }
  3556. -    
  3557. -    if ( index != (int *)NULL )
  3558. -    *index = i_min;
  3559. -    
  3560. -    return min_val;
  3561. -}
  3562. -
  3563. -/* max_row_col -- returns max { |A[j][k]| : k >= i, k != j, k != l } given j
  3564. -    using symmetry and only the upper triangular part of A */
  3565. -static double max_row_col(A,i,j,l)
  3566. -SPMAT    *A;
  3567. -int    i, j, l;
  3568. -{
  3569. -    int        row_num, idx;
  3570. -    SPROW    *r;
  3571. -    row_elt    *e;
  3572. -    Real    max_val, tmp;
  3573. -
  3574. -    if ( ! A )
  3575. -    error(E_NULL,"max_row_col");
  3576. -    if ( i < 0 || i > A->n || j < 0 || j >= A->n )
  3577. -    error(E_BOUNDS,"max_row_col");
  3578. -
  3579. -    max_val = 0.0;
  3580. -
  3581. -    idx = unord_get_idx(&(A->row[i]),j);
  3582. -    if ( idx < 0 )
  3583. -    {
  3584. -    row_num = -1;    idx = j;
  3585. -    e = chase_past(A,j,&row_num,&idx,i);
  3586. -    }
  3587. -    else
  3588. -    {
  3589. -    row_num = i;
  3590. -    e = &(A->row[i].elt[idx]);
  3591. -    }
  3592. -    while ( row_num >= 0 && row_num < j )
  3593. -    {
  3594. -    if ( row_num != l )
  3595. -    {
  3596. -        tmp = fabs(e->val);
  3597. -        if ( tmp > max_val )
  3598. -        max_val = tmp;
  3599. -    }
  3600. -    e = bump_col(A,j,&row_num,&idx);
  3601. -    }
  3602. -    r = &(A->row[j]);
  3603. -    for ( idx = 0, e = r->elt; idx < r->len; idx++, e++ )
  3604. -    {
  3605. -    if ( e->col > j && e->col != l )
  3606. -    {
  3607. -        tmp = fabs(e->val);
  3608. -        if ( tmp > max_val )
  3609. -        max_val = tmp;
  3610. -    }
  3611. -    }
  3612. -
  3613. -    return max_val;
  3614. -}
  3615. -
  3616. -/* nonzeros -- counts non-zeros in A */
  3617. -static int    nonzeros(A)
  3618. -SPMAT    *A;
  3619. -{
  3620. -    int        cnt, i;
  3621. -
  3622. -    if ( ! A )
  3623. -    return 0;
  3624. -    cnt = 0;
  3625. -    for ( i = 0; i < A->m; i++ )
  3626. -    cnt += A->row[i].len;
  3627. -
  3628. -    return cnt;
  3629. -}
  3630. -
  3631. -/* chk_col_access -- for spBKPfactor()
  3632. -    -- checks that column access path is OK */
  3633. -int    chk_col_access(A)
  3634. -SPMAT    *A;
  3635. -{
  3636. -    int        cnt_nz, j, row, idx;
  3637. -    SPROW    *r;
  3638. -    row_elt    *e;
  3639. -
  3640. -    if ( ! A )
  3641. -    error(E_NULL,"chk_col_access");
  3642. -
  3643. -    /* count nonzeros as we go down columns */
  3644. -    cnt_nz = 0;
  3645. -    for ( j = 0; j < A->n; j++ )
  3646. -    {
  3647. -    row = A->start_row[j];
  3648. -    idx = A->start_idx[j];
  3649. -    while ( row >= 0 )
  3650. -    {
  3651. -        if ( row >= A->m || idx < 0 )
  3652. -        return FALSE;
  3653. -        r = &(A->row[row]);
  3654. -        if ( idx >= r->len )
  3655. -        return FALSE;
  3656. -        e = &(r->elt[idx]);
  3657. -        if ( e->nxt_row >= 0 && e->nxt_row <= row )
  3658. -        return FALSE;
  3659. -        row = e->nxt_row;
  3660. -        idx = e->nxt_idx;
  3661. -        cnt_nz++;
  3662. -    }
  3663. -    }
  3664. -
  3665. -    if ( cnt_nz != nonzeros(A) )
  3666. -    return FALSE;
  3667. -    else
  3668. -    return TRUE;
  3669. -}
  3670. -
  3671. -/* col_cmp -- compare two columns -- for sorting rows using qsort() */
  3672. -static int    col_cmp(e1,e2)
  3673. -row_elt    *e1, *e2;
  3674. -{
  3675. -    return e1->col - e2->col;
  3676. -}
  3677. -
  3678. -/* spBKPfactor -- sparse Bunch-Kaufman-Parlett factorisation of A in-situ
  3679. -   -- A is factored into the form P'AP = MDM' where 
  3680. -   P is a permutation matrix, M lower triangular and D is block
  3681. -   diagonal with blocks of size 1 or 2
  3682. -   -- P is stored in pivot; blocks[i]==i iff D[i][i] is a block */
  3683. -SPMAT    *spBKPfactor(A,pivot,blocks,tol)
  3684. -SPMAT    *A;
  3685. -PERM    *pivot, *blocks;
  3686. -double    tol;
  3687. -{
  3688. -    int        i, j, k, l, n, onebyone, r;
  3689. -    int        idx, idx1, idx_piv;
  3690. -    int        row_num;
  3691. -    int        best_deg, best_j, best_l, best_cost, mark_cost, deg, deg_j,
  3692. -            deg_l, ignore_deg;
  3693. -    int        list_idx, list_idx2, old_list_idx;
  3694. -    SPROW    *row, *r_piv, *r1_piv;
  3695. -    row_elt    *e, *e1;
  3696. -    Real    aii, aip1, aip1i;
  3697. -    Real    det, max_j, max_l, s, t;
  3698. -    static IVEC    *scan_row = IVNULL, *scan_idx = IVNULL, *col_list = IVNULL,
  3699. -        *tmp_iv = IVNULL;
  3700. -    static IVEC *deg_list = IVNULL;
  3701. -    static IVEC    *orig_idx = IVNULL, *orig1_idx = IVNULL;
  3702. -    static PERM    *order = PNULL;
  3703. -
  3704. -    if ( ! A || ! pivot || ! blocks )
  3705. -    error(E_NULL,"spBKPfactor");
  3706. -    if ( A->m != A->n )
  3707. -    error(E_SQUARE,"spBKPfactor");
  3708. -    if ( A->m != pivot->size || pivot->size != blocks->size )
  3709. -    error(E_SIZES,"spBKPfactor");
  3710. -    if ( tol <= 0.0 || tol > 1.0 )
  3711. -    error(E_RANGE,"spBKPfactor");
  3712. -    
  3713. -    n = A->n;
  3714. -    
  3715. -    px_ident(pivot);    px_ident(blocks);
  3716. -    sp_col_access(A);    sp_diag_access(A);
  3717. -    ignore_deg = FALSE;
  3718. -
  3719. -    deg_list = iv_resize(deg_list,n);
  3720. -    order = px_resize(order,n);
  3721. -    MEM_STAT_REG(deg_list,TYPE_IVEC);
  3722. -    MEM_STAT_REG(order,TYPE_PERM);
  3723. -
  3724. -    scan_row = iv_resize(scan_row,5);
  3725. -    scan_idx = iv_resize(scan_idx,5);
  3726. -    col_list = iv_resize(col_list,5);
  3727. -    orig_idx = iv_resize(orig_idx,5);
  3728. -    orig_idx = iv_resize(orig1_idx,5);
  3729. -    orig_idx = iv_resize(tmp_iv,5);
  3730. -    MEM_STAT_REG(scan_row,TYPE_IVEC);
  3731. -    MEM_STAT_REG(scan_idx,TYPE_IVEC);
  3732. -    MEM_STAT_REG(col_list,TYPE_IVEC);
  3733. -    MEM_STAT_REG(orig_idx,TYPE_IVEC);
  3734. -    MEM_STAT_REG(orig1_idx,TYPE_IVEC);
  3735. -    MEM_STAT_REG(tmp_iv,TYPE_IVEC);
  3736. -
  3737. -    for ( i = 0; i < n-1; i = onebyone ? i+1 : i+2 )
  3738. -    {
  3739. -    /* now we want to use a Markowitz-style selection rule for
  3740. -       determining which rows to swap and whether to use
  3741. -       1x1 or 2x2 pivoting */
  3742. -
  3743. -    /* get list of degrees of nodes */
  3744. -    deg_list = iv_resize(deg_list,n-i);
  3745. -    if ( ! ignore_deg )
  3746. -        for ( j = i; j < n; j++ )
  3747. -        deg_list->ive[j-i] = 0;
  3748. -    else
  3749. -    {
  3750. -        for ( j = i; j < n; j++ )
  3751. -        deg_list->ive[j-i] = 1;
  3752. -        if ( i < n )
  3753. -        deg_list->ive[0] = 0;
  3754. -    }
  3755. -    order = px_resize(order,n-i);
  3756. -    px_ident(order);
  3757. -
  3758. -    if ( ! ignore_deg )
  3759. -    {
  3760. -        for ( j = i; j < n; j++ )
  3761. -        {
  3762. -        /* idx = sprow_idx(&(A->row[j]),j+1); */
  3763. -        /* idx = fixindex(idx); */
  3764. -        idx = 0;
  3765. -        row = &(A->row[j]);
  3766. -        e = &(row->elt[idx]);
  3767. -        /* deg_list->ive[j-i] += row->len - idx; */
  3768. -        for ( ; idx < row->len; idx++, e++ )
  3769. -            if ( e->col >= i )
  3770. -            deg_list->ive[e->col - i]++;
  3771. -        }
  3772. -        /* now deg_list[k] == degree of node k+i */
  3773. -        
  3774. -        /* now sort them into increasing order */
  3775. -        iv_sort(deg_list,order);
  3776. -        /* now deg_list[idx] == degree of node i+order[idx] */
  3777. -    }
  3778. -
  3779. -    /* now we can chase through the nodes in order of increasing
  3780. -       degree, picking out the ones that satisfy our stability
  3781. -       criterion */
  3782. -    list_idx = 0;    r = -1;
  3783. -    best_j = best_l = -1;
  3784. -    for ( deg = 0; deg <= n; deg++ )
  3785. -    {
  3786. -        Real    ajj, all, ajl;
  3787. -
  3788. -        if ( list_idx >= deg_list->dim )
  3789. -        break;    /* That's all folks! */
  3790. -        old_list_idx = list_idx;
  3791. -        while ( list_idx < deg_list->dim &&
  3792. -            deg_list->ive[list_idx] <= deg )
  3793. -        {
  3794. -        j = i+order->pe[list_idx];
  3795. -        if ( j < i )
  3796. -            continue;
  3797. -        /* can we use row/col j for a 1 x 1 pivot? */
  3798. -        /* find max_j = max_{k>=i} {|A[k][j]|,|A[j][k]|} */
  3799. -        ajj = fabs(unord_get_val(A,j,j));
  3800. -        if ( ajj == 0.0 )
  3801. -        {
  3802. -            list_idx++;
  3803. -            continue;    /* can't use this for 1 x 1 pivot */
  3804. -        }
  3805. -
  3806. -        max_j = max_row_col(A,i,j,-1);
  3807. -        if ( ajj >= tol/* *alpha */ *max_j )
  3808. -        {
  3809. -            onebyone = TRUE;
  3810. -            best_j = j;
  3811. -            best_deg = deg_list->ive[list_idx];
  3812. -            break;
  3813. -        }
  3814. -        list_idx++;
  3815. -        }
  3816. -        if ( best_j >= 0 )
  3817. -        break;
  3818. -        best_cost = 2*n;    /* > any possible Markowitz cost (bound) */
  3819. -        best_j = best_l = -1;
  3820. -        list_idx = old_list_idx;
  3821. -        while ( list_idx < deg_list->dim &&
  3822. -            deg_list->ive[list_idx] <= deg )
  3823. -        {
  3824. -        j = i+order->pe[list_idx];
  3825. -        ajj = fabs(unord_get_val(A,j,j));
  3826. -        for ( list_idx2 = 0; list_idx2 < list_idx; list_idx2++ )
  3827. -        {
  3828. -            deg_j = deg;
  3829. -            deg_l = deg_list->ive[list_idx2];
  3830. -            l = i+order->pe[list_idx2];
  3831. -            if ( l < i )
  3832. -            continue;
  3833. -            /* try using rows/cols (j,l) for a 2 x 2 pivot block */
  3834. -            all = fabs(unord_get_val(A,l,l));
  3835. -            ajl = ( j > l ) ? fabs(unord_get_val(A,l,j)) :
  3836. -                       fabs(unord_get_val(A,j,l));
  3837. -            det = fabs(ajj*all - ajl*ajl);
  3838. -            if ( det == 0.0 )
  3839. -            continue;
  3840. -            max_j = max_row_col(A,i,j,l);
  3841. -            max_l = max_row_col(A,i,l,j);
  3842. -            if ( tol*(all*max_j+ajl*max_l) < det &&
  3843. -             tol*(ajl*max_j+ajj*max_l) < det )
  3844. -            {
  3845. -            /* acceptably stable 2 x 2 pivot */
  3846. -            /* this is actually an overestimate of the
  3847. -               Markowitz cost for choosing (j,l) */
  3848. -            mark_cost = (ajj == 0.0) ?
  3849. -                ((all == 0.0) ? deg_j+deg_l : deg_j+2*deg_l) :
  3850. -                ((all == 0.0) ? 2*deg_j+deg_l :
  3851. -                 2*(deg_j+deg_l));
  3852. -            if ( mark_cost < best_cost )
  3853. -            {
  3854. -                onebyone = FALSE;
  3855. -                best_cost = mark_cost;
  3856. -                best_j = j;
  3857. -                best_l = l;
  3858. -                best_deg = deg_j;
  3859. -            }
  3860. -            }
  3861. -        }
  3862. -        list_idx++;
  3863. -        }
  3864. -        if ( best_j >= 0 )
  3865. -        break;
  3866. -    }
  3867. -
  3868. -    if ( best_deg > (int)floor(0.8*(n-i)) )
  3869. -        ignore_deg = TRUE;
  3870. -
  3871. -    /* now do actual interchanges */
  3872. -    if ( best_j >= 0 && onebyone )
  3873. -    {
  3874. -        bkp_interchange(A,i,best_j);
  3875. -        px_transp(pivot,i,best_j);
  3876. -    }
  3877. -    else if ( best_j >= 0 && best_l >= 0 && ! onebyone )
  3878. -    {
  3879. -        if ( best_j == i || best_j == i+1 )
  3880. -        {
  3881. -        if ( best_l == i || best_l == i+1 )
  3882. -        {
  3883. -            /* no pivoting, but must update blocks permutation */
  3884. -            px_transp(blocks,i,i+1);
  3885. -            goto dopivot;
  3886. -        }
  3887. -        bkp_interchange(A,(best_j == i) ? i+1 : i,best_l);
  3888. -        px_transp(pivot,(best_j == i) ? i+1 : i,best_l);
  3889. -        }
  3890. -        else if ( best_l == i || best_l == i+1 )
  3891. -        {
  3892. -        bkp_interchange(A,(best_l == i) ? i+1 : i,best_j);
  3893. -        px_transp(pivot,(best_l == i) ? i+1 : i,best_j);
  3894. -        }
  3895. -        else /* best_j & best_l outside i, i+1 */
  3896. -        {
  3897. -        if ( i != best_j )
  3898. -        {
  3899. -            bkp_interchange(A,i,best_j);
  3900. -            px_transp(pivot,i,best_j);
  3901. -        }
  3902. -        if ( i+1 != best_l )
  3903. -        {
  3904. -            bkp_interchange(A,i+1,best_l);
  3905. -            px_transp(pivot,i+1,best_l);
  3906. -        }
  3907. -        }
  3908. -    }
  3909. -    else    /* can't pivot &/or nothing to pivot */
  3910. -        continue;
  3911. -
  3912. -    /* update blocks permutation */
  3913. -    if ( ! onebyone )
  3914. -        px_transp(blocks,i,i+1);
  3915. -
  3916. -    dopivot:
  3917. -    if ( onebyone )
  3918. -    {
  3919. -        int        idx_j, idx_k, s_idx, s_idx2;
  3920. -        row_elt    *e_ij, *e_ik;
  3921. -
  3922. -        r_piv = &(A->row[i]);
  3923. -        idx_piv = unord_get_idx(r_piv,i);
  3924. -        /* if idx_piv < 0 then aii == 0 and no pivoting can be done;
  3925. -           -- this means that we should continue to the next iteration */
  3926. -        if ( idx_piv < 0 )
  3927. -        continue;
  3928. -        aii = r_piv->elt[idx_piv].val;
  3929. -        if ( aii == 0.0 )
  3930. -        continue;
  3931. -
  3932. -        /* for ( j = i+1; j < n; j++ )  { ... pivot step ... } */
  3933. -        /* initialise scan_... etc for the 1 x 1 pivot */
  3934. -        scan_row = iv_resize(scan_row,r_piv->len);
  3935. -        scan_idx = iv_resize(scan_idx,r_piv->len);
  3936. -        col_list = iv_resize(col_list,r_piv->len);
  3937. -        orig_idx = iv_resize(orig_idx,r_piv->len);
  3938. -        row_num = i;    s_idx = idx = 0;
  3939. -        e = &(r_piv->elt[idx]);
  3940. -        for ( idx = 0; idx < r_piv->len; idx++, e++ )
  3941. -        {
  3942. -        if ( e->col < i )
  3943. -            continue;
  3944. -        scan_row->ive[s_idx] = i;
  3945. -        scan_idx->ive[s_idx] = idx;
  3946. -        orig_idx->ive[s_idx] = idx;
  3947. -        col_list->ive[s_idx] = e->col;
  3948. -        s_idx++;
  3949. -        }
  3950. -        scan_row = iv_resize(scan_row,s_idx);
  3951. -        scan_idx = iv_resize(scan_idx,s_idx);
  3952. -        col_list = iv_resize(col_list,s_idx);
  3953. -        orig_idx = iv_resize(orig_idx,s_idx);
  3954. -
  3955. -        order = px_resize(order,scan_row->dim);
  3956. -        px_ident(order);
  3957. -        iv_sort(col_list,order);
  3958. -
  3959. -        tmp_iv = iv_resize(tmp_iv,scan_row->dim);
  3960. -        for ( idx = 0; idx < order->size; idx++ )
  3961. -        tmp_iv->ive[idx] = scan_idx->ive[order->pe[idx]];
  3962. -        iv_copy(tmp_iv,scan_idx);
  3963. -        for ( idx = 0; idx < order->size; idx++ )
  3964. -        tmp_iv->ive[idx] = scan_row->ive[order->pe[idx]];
  3965. -        iv_copy(tmp_iv,scan_row);
  3966. -        for ( idx = 0; idx < scan_row->dim; idx++ )
  3967. -        tmp_iv->ive[idx] = orig_idx->ive[order->pe[idx]];
  3968. -        iv_copy(tmp_iv,orig_idx);
  3969. -
  3970. -        /* now do actual pivot */
  3971. -        /* for ( j = i+1; j < n-1; j++ ) .... */
  3972. -
  3973. -        for ( s_idx = 0; s_idx < scan_row->dim; s_idx++ )
  3974. -        {
  3975. -        idx_j = orig_idx->ive[s_idx];
  3976. -        if ( idx_j < 0 )
  3977. -            error(E_INTERN,"spBKPfactor");
  3978. -        e_ij = &(r_piv->elt[idx_j]);
  3979. -        j = e_ij->col;
  3980. -        if ( j < i+1 )
  3981. -            continue;
  3982. -        scan_to(A,scan_row,scan_idx,col_list,j);
  3983. -
  3984. -        /* compute multiplier */
  3985. -        t = e_ij->val / aii;
  3986. -
  3987. -        /* for ( k = j; k < n; k++ ) { .... update A[j][k] .... } */
  3988. -        /* this is the row in which pivoting is done */
  3989. -        row = &(A->row[j]);
  3990. -        for ( s_idx2 = s_idx; s_idx2 < scan_row->dim; s_idx2++ )
  3991. -        {
  3992. -            idx_k = orig_idx->ive[s_idx2];
  3993. -            e_ik = &(r_piv->elt[idx_k]);
  3994. -            k = e_ik->col;
  3995. -            /* k >= j since col_list has been sorted */
  3996. -
  3997. -            if ( scan_row->ive[s_idx2] == j )
  3998. -            {    /* no fill-in -- can be done directly */
  3999. -            idx = scan_idx->ive[s_idx2];
  4000. -            /* idx = sprow_idx2(row,k,idx); */
  4001. -            row->elt[idx].val -= t*e_ik->val;
  4002. -            }
  4003. -            else
  4004. -            {    /* fill-in -- insert entry & patch column */
  4005. -            int    old_row, old_idx;
  4006. -            row_elt    *old_e, *new_e;
  4007. -
  4008. -            old_row = scan_row->ive[s_idx2];
  4009. -            old_idx = scan_idx->ive[s_idx2];
  4010. -            /* old_idx = sprow_idx2(&(A->row[old_row]),k,old_idx); */
  4011. -
  4012. -            if ( old_idx < 0 )
  4013. -                error(E_INTERN,"spBKPfactor");
  4014. -            /* idx = sprow_idx(row,k); */
  4015. -            /* idx = fixindex(idx); */
  4016. -            idx = row->len;
  4017. -
  4018. -            /* sprow_set_val(row,k,-t*e_ik->val); */
  4019. -            if ( row->len >= row->maxlen )
  4020. -            { tracecatch(sprow_xpd(row,2*row->maxlen+1,TYPE_SPMAT),
  4021. -                     "spBKPfactor");        }
  4022. -
  4023. -            row->len = idx+1;
  4024. -
  4025. -            new_e = &(row->elt[idx]);
  4026. -            new_e->val = -t*e_ik->val;
  4027. -            new_e->col = k;
  4028. -
  4029. -            old_e = &(A->row[old_row].elt[old_idx]);
  4030. -            new_e->nxt_row = old_e->nxt_row;
  4031. -            new_e->nxt_idx = old_e->nxt_idx;
  4032. -            old_e->nxt_row = j;
  4033. -            old_e->nxt_idx = idx;
  4034. -            }
  4035. -        }
  4036. -        e_ij->val = t;
  4037. -        }
  4038. -    }
  4039. -    else /* onebyone == FALSE */
  4040. -    {    /* do 2 x 2 pivot */
  4041. -        int    idx_k, idx1_k, s_idx, s_idx2;
  4042. -        int    old_col;
  4043. -        row_elt    *e_tmp;
  4044. -
  4045. -        r_piv = &(A->row[i]);
  4046. -        idx_piv = unord_get_idx(r_piv,i);
  4047. -        aii = aip1i = 0.0;
  4048. -        e_tmp = r_piv->elt;
  4049. -        for ( idx_piv = 0; idx_piv < r_piv->len; idx_piv++, e_tmp++ )
  4050. -        if ( e_tmp->col == i )
  4051. -            aii = e_tmp->val;
  4052. -            else if ( e_tmp->col == i+1 )
  4053. -            aip1i = e_tmp->val;
  4054. -
  4055. -        r1_piv = &(A->row[i+1]);
  4056. -        e_tmp = r1_piv->elt;
  4057. -        aip1 = unord_get_val(A,i+1,i+1);
  4058. -        det = aii*aip1 - aip1i*aip1i;    /* Must have det < 0 */
  4059. -        if ( aii == 0.0 && aip1i == 0.0 )
  4060. -        {
  4061. -        /* error(E_RANGE,"spBKPfactor"); */
  4062. -        onebyone = TRUE;
  4063. -        continue;    /* cannot pivot */
  4064. -        }
  4065. -
  4066. -        if ( det == 0.0 )
  4067. -        {
  4068. -        if ( aii != 0.0 )
  4069. -            error(E_RANGE,"spBKPfactor");
  4070. -        onebyone = TRUE;
  4071. -        continue;    /* cannot pivot */
  4072. -        }
  4073. -        aip1i = aip1i/det;
  4074. -        aii = aii/det;
  4075. -        aip1 = aip1/det;
  4076. -        
  4077. -        /* initialise scan_... etc for the 2 x 2 pivot */
  4078. -        s_idx = r_piv->len + r1_piv->len;
  4079. -        scan_row = iv_resize(scan_row,s_idx);
  4080. -        scan_idx = iv_resize(scan_idx,s_idx);
  4081. -        col_list = iv_resize(col_list,s_idx);
  4082. -        orig_idx = iv_resize(orig_idx,s_idx);
  4083. -        orig1_idx = iv_resize(orig1_idx,s_idx);
  4084. -
  4085. -        e = r_piv->elt;
  4086. -        for ( idx = 0; idx < r_piv->len; idx++, e++ )
  4087. -        {
  4088. -        scan_row->ive[idx] = i;
  4089. -        scan_idx->ive[idx] = idx;
  4090. -        col_list->ive[idx] = e->col;
  4091. -        orig_idx->ive[idx] = idx;
  4092. -        orig1_idx->ive[idx] = -1;
  4093. -        }
  4094. -        e = r_piv->elt;
  4095. -        e1 = r1_piv->elt;
  4096. -        for ( idx = 0; idx < r1_piv->len; idx++, e1++ )
  4097. -        {
  4098. -        scan_row->ive[idx+r_piv->len] = i+1;
  4099. -        scan_idx->ive[idx+r_piv->len] = idx;
  4100. -        col_list->ive[idx+r_piv->len] = e1->col;
  4101. -        orig_idx->ive[idx+r_piv->len] = -1;
  4102. -        orig1_idx->ive[idx+r_piv->len] = idx;
  4103. -        }
  4104. -
  4105. -        e1 = r1_piv->elt;
  4106. -        order = px_resize(order,scan_row->dim);
  4107. -        px_ident(order);
  4108. -        iv_sort(col_list,order);
  4109. -        tmp_iv = iv_resize(tmp_iv,scan_row->dim);
  4110. -        for ( idx = 0; idx < order->size; idx++ )
  4111. -        tmp_iv->ive[idx] = scan_idx->ive[order->pe[idx]];
  4112. -        iv_copy(tmp_iv,scan_idx);
  4113. -        for ( idx = 0; idx < order->size; idx++ )
  4114. -        tmp_iv->ive[idx] = scan_row->ive[order->pe[idx]];
  4115. -        iv_copy(tmp_iv,scan_row);
  4116. -        for ( idx = 0; idx < scan_row->dim; idx++ )
  4117. -        tmp_iv->ive[idx] = orig_idx->ive[order->pe[idx]];
  4118. -        iv_copy(tmp_iv,orig_idx);
  4119. -        for ( idx = 0; idx < scan_row->dim; idx++ )
  4120. -        tmp_iv->ive[idx] = orig1_idx->ive[order->pe[idx]];
  4121. -        iv_copy(tmp_iv,orig1_idx);
  4122. -
  4123. -        s_idx = 0;
  4124. -        old_col = -1;
  4125. -        for ( idx = 0; idx < scan_row->dim; idx++ )
  4126. -        {
  4127. -        if ( col_list->ive[idx] == old_col )
  4128. -        {
  4129. -            if ( scan_row->ive[idx] == i )
  4130. -            {
  4131. -            scan_row->ive[s_idx-1] = scan_row->ive[idx];
  4132. -            scan_idx->ive[s_idx-1] = scan_idx->ive[idx];
  4133. -            col_list->ive[s_idx-1] = col_list->ive[idx];
  4134. -            orig_idx->ive[s_idx-1] = orig_idx->ive[idx];
  4135. -            orig1_idx->ive[s_idx-1] = orig1_idx->ive[idx-1];
  4136. -            }
  4137. -            else if ( idx > 0 )
  4138. -            {
  4139. -            scan_row->ive[s_idx-1] = scan_row->ive[idx-1];
  4140. -            scan_idx->ive[s_idx-1] = scan_idx->ive[idx-1];
  4141. -            col_list->ive[s_idx-1] = col_list->ive[idx-1];
  4142. -            orig_idx->ive[s_idx-1] = orig_idx->ive[idx-1];
  4143. -            orig1_idx->ive[s_idx-1] = orig1_idx->ive[idx];
  4144. -            }
  4145. -        }
  4146. -        else
  4147. -        {
  4148. -            scan_row->ive[s_idx] = scan_row->ive[idx];
  4149. -            scan_idx->ive[s_idx] = scan_idx->ive[idx];
  4150. -            col_list->ive[s_idx] = col_list->ive[idx];
  4151. -            orig_idx->ive[s_idx] = orig_idx->ive[idx];
  4152. -            orig1_idx->ive[s_idx] = orig1_idx->ive[idx];
  4153. -            s_idx++;
  4154. -        }
  4155. -        old_col = col_list->ive[idx];
  4156. -        }
  4157. -        scan_row = iv_resize(scan_row,s_idx);
  4158. -        scan_idx = iv_resize(scan_idx,s_idx);
  4159. -        col_list = iv_resize(col_list,s_idx);
  4160. -        orig_idx = iv_resize(orig_idx,s_idx);
  4161. -        orig1_idx = iv_resize(orig1_idx,s_idx);
  4162. -
  4163. -        /* for ( j = i+2; j < n; j++ )  { .... row operation .... } */
  4164. -        for ( s_idx = 0; s_idx < scan_row->dim; s_idx++ )
  4165. -        {
  4166. -        int    idx_piv, idx1_piv;
  4167. -        Real    aip1j, aij, aik, aip1k;
  4168. -        row_elt    *e_ik, *e_ip1k;
  4169. -
  4170. -        j = col_list->ive[s_idx];
  4171. -        if ( j < i+2 )
  4172. -            continue;
  4173. -        tracecatch(scan_to(A,scan_row,scan_idx,col_list,j),
  4174. -               "spBKPfactor");
  4175. -
  4176. -        idx_piv = orig_idx->ive[s_idx];
  4177. -        aij = ( idx_piv < 0 ) ? 0.0 : r_piv->elt[idx_piv].val;
  4178. -        /* aij = ( s_idx < r_piv->len ) ? r_piv->elt[s_idx].val :
  4179. -            0.0; */
  4180. -        /* aij   = sp_get_val(A,i,j); */
  4181. -        idx1_piv = orig1_idx->ive[s_idx];
  4182. -        aip1j = ( idx1_piv < 0 ) ? 0.0 : r1_piv->elt[idx1_piv].val;
  4183. -        /* aip1j = ( s_idx < r_piv->len ) ? 0.0 :
  4184. -            r1_piv->elt[s_idx-r_piv->len].val; */
  4185. -        /* aip1j = sp_get_val(A,i+1,j); */
  4186. -        s = - aip1i*aip1j + aip1*aij;
  4187. -        t = - aip1i*aij + aii*aip1j;
  4188. -
  4189. -        /* for ( k = j; k < n; k++ )  { .... update entry .... } */
  4190. -        row = &(A->row[j]);
  4191. -        /* set idx_k and idx1_k indices */
  4192. -        s_idx2 = s_idx;
  4193. -        k = col_list->ive[s_idx2];
  4194. -        idx_k = orig_idx->ive[s_idx2];
  4195. -        idx1_k = orig1_idx->ive[s_idx2];
  4196. -
  4197. -        while ( s_idx2 < scan_row->dim )
  4198. -        {
  4199. -            k = col_list->ive[s_idx2];
  4200. -            idx_k = orig_idx->ive[s_idx2];
  4201. -            idx1_k = orig1_idx->ive[s_idx2];
  4202. -            e_ik = ( idx_k < 0 ) ? (row_elt *)NULL :
  4203. -            &(r_piv->elt[idx_k]);
  4204. -            e_ip1k = ( idx1_k < 0 ) ? (row_elt *)NULL :
  4205. -            &(r1_piv->elt[idx1_k]);
  4206. -            aik = ( idx_k >= 0 ) ? e_ik->val : 0.0;
  4207. -            aip1k = ( idx1_k >= 0 ) ? e_ip1k->val : 0.0;
  4208. -            if ( scan_row->ive[s_idx2] == j )
  4209. -            {    /* no fill-in */
  4210. -            row = &(A->row[j]);
  4211. -            /* idx = sprow_idx(row,k); */
  4212. -            idx = scan_idx->ive[s_idx2];
  4213. -            if ( idx < 0 )
  4214. -                error(E_INTERN,"spBKPfactor");
  4215. -            row->elt[idx].val -= s*aik + t*aip1k;
  4216. -            }
  4217. -            else
  4218. -            {    /* fill-in -- insert entry & patch column */
  4219. -            Real    tmp;
  4220. -            int    old_row, old_idx;
  4221. -            row_elt    *old_e, *new_e;
  4222. -
  4223. -            tmp = - s*aik - t*aip1k;
  4224. -            if ( tmp != 0.0 )
  4225. -            {
  4226. -                row = &(A->row[j]);
  4227. -                old_row = scan_row->ive[s_idx2];
  4228. -                old_idx = scan_idx->ive[s_idx2];
  4229. -
  4230. -                idx = row->len;
  4231. -                if ( row->len >= row->maxlen )
  4232. -                {  tracecatch(sprow_xpd(row,2*row->maxlen+1,
  4233. -                            TYPE_SPMAT),
  4234. -                       "spBKPfactor");        }
  4235. -
  4236. -                row->len = idx + 1;
  4237. -                /* idx = sprow_idx(row,k); */
  4238. -                new_e = &(row->elt[idx]);
  4239. -                new_e->val = tmp;
  4240. -                new_e->col = k;
  4241. -
  4242. -                if ( old_row < 0 )
  4243. -                error(E_INTERN,"spBKPfactor");
  4244. -                /* old_idx = sprow_idx2(&(A->row[old_row]),
  4245. -                          k,old_idx); */
  4246. -                old_e = &(A->row[old_row].elt[old_idx]);
  4247. -                new_e->nxt_row = old_e->nxt_row;
  4248. -                new_e->nxt_idx = old_e->nxt_idx;
  4249. -                old_e->nxt_row = j;
  4250. -                old_e->nxt_idx = idx;
  4251. -            }
  4252. -            }
  4253. -
  4254. -            /* update idx_k, idx1_k, s_idx2 etc */
  4255. -            s_idx2++;
  4256. -        }
  4257. -
  4258. -        /* store multipliers -- may involve fill-in (!) */
  4259. -        /* idx = sprow_idx(r_piv,j); */
  4260. -        idx = orig_idx->ive[s_idx];
  4261. -        if ( idx >= 0 )
  4262. -        {
  4263. -            r_piv->elt[idx].val = s;
  4264. -        }
  4265. -        else if ( s != 0.0 )
  4266. -        {
  4267. -            int        old_row, old_idx;
  4268. -            row_elt    *new_e, *old_e;
  4269. -
  4270. -            old_row = -1;    old_idx = j;
  4271. -
  4272. -            if ( i > 0 )
  4273. -            {
  4274. -            tracecatch(chase_col(A,j,&old_row,&old_idx,i-1),
  4275. -                   "spBKPfactor");
  4276. -            }
  4277. -            /* sprow_set_val(r_piv,j,s); */
  4278. -            idx = r_piv->len;
  4279. -            if ( r_piv->len >= r_piv->maxlen )
  4280. -            {    tracecatch(sprow_xpd(r_piv,2*r_piv->maxlen+1,
  4281. -                         TYPE_SPMAT),
  4282. -                   "spBKPfactor");            }
  4283. -
  4284. -            r_piv->len = idx + 1;
  4285. -            /* idx = sprow_idx(r_piv,j); */
  4286. -            /* if ( idx < 0 )
  4287. -            error(E_INTERN,"spBKPfactor"); */
  4288. -            new_e = &(r_piv->elt[idx]);
  4289. -            new_e->val = s;
  4290. -            new_e->col = j;
  4291. -            if ( old_row < 0 )
  4292. -            {
  4293. -            new_e->nxt_row = A->start_row[j];
  4294. -            new_e->nxt_idx = A->start_idx[j];
  4295. -            A->start_row[j] = i;
  4296. -            A->start_idx[j] = idx;
  4297. -            }
  4298. -            else
  4299. -            {
  4300. -            /* old_idx = sprow_idx2(&(A->row[old_row]),j,old_idx);*/
  4301. -            if ( old_idx < 0 )
  4302. -                error(E_INTERN,"spBKPfactor");
  4303. -            old_e = &(A->row[old_row].elt[old_idx]);
  4304. -            new_e->nxt_row = old_e->nxt_row;
  4305. -            new_e->nxt_idx = old_e->nxt_idx;
  4306. -            old_e->nxt_row = i;
  4307. -            old_e->nxt_idx = idx;
  4308. -            }
  4309. -        }
  4310. -        /* idx1 = sprow_idx(r1_piv,j); */
  4311. -        idx1 = orig1_idx->ive[s_idx];
  4312. -        if ( idx1 >= 0 )
  4313. -        {
  4314. -            r1_piv->elt[idx1].val = t;
  4315. -        }
  4316. -        else if ( t != 0.0 )
  4317. -        {
  4318. -            int        old_row, old_idx;
  4319. -            row_elt    *new_e, *old_e;
  4320. -
  4321. -            old_row = -1;    old_idx = j;
  4322. -            tracecatch(chase_col(A,j,&old_row,&old_idx,i),
  4323. -                   "spBKPfactor");
  4324. -            /* sprow_set_val(r1_piv,j,t); */
  4325. -            idx1 = r1_piv->len;
  4326. -            if ( r1_piv->len >= r1_piv->maxlen )
  4327. -            {    tracecatch(sprow_xpd(r1_piv,2*r1_piv->maxlen+1,
  4328. -                         TYPE_SPMAT),
  4329. -                   "spBKPfactor");            }
  4330. -
  4331. -            r1_piv->len = idx1 + 1;
  4332. -            /* idx1 = sprow_idx(r1_piv,j); */
  4333. -            /* if ( idx < 0 )
  4334. -            error(E_INTERN,"spBKPfactor"); */
  4335. -            new_e = &(r1_piv->elt[idx1]);
  4336. -            new_e->val = t;
  4337. -            new_e->col = j;
  4338. -            if ( idx1 < 0 )
  4339. -            error(E_INTERN,"spBKPfactor");
  4340. -            new_e = &(r1_piv->elt[idx1]);
  4341. -            if ( old_row < 0 )
  4342. -            {
  4343. -            new_e->nxt_row = A->start_row[j];
  4344. -            new_e->nxt_idx = A->start_idx[j];
  4345. -            A->start_row[j] = i+1;
  4346. -            A->start_idx[j] = idx1;
  4347. -            }
  4348. -            else
  4349. -            {
  4350. -            old_idx = sprow_idx2(&(A->row[old_row]),j,old_idx);
  4351. -            if ( old_idx < 0 )
  4352. -                error(E_INTERN,"spBKPfactor");
  4353. -            old_e = &(A->row[old_row].elt[old_idx]);
  4354. -            new_e->nxt_row = old_e->nxt_row;
  4355. -            new_e->nxt_idx = old_e->nxt_idx;
  4356. -            old_e->nxt_row = i+1;
  4357. -            old_e->nxt_idx = idx1;
  4358. -            }
  4359. -        }
  4360. -        }
  4361. -    }
  4362. -    }
  4363. -
  4364. -    /* now sort the rows arrays */
  4365. -    for ( i = 0; i < A->m; i++ )
  4366. -    qsort(A->row[i].elt,A->row[i].len,sizeof(row_elt),(int(*)())col_cmp);
  4367. -    A->flag_col = A->flag_diag = FALSE;
  4368. -
  4369. -    return A;
  4370. -}
  4371. -
  4372. -/* spBKPsolve -- solves A.x = b where A has been factored a la BKPfactor()
  4373. -   -- returns x, which is created if NULL */
  4374. -VEC    *spBKPsolve(A,pivot,block,b,x)
  4375. -SPMAT    *A;
  4376. -PERM    *pivot, *block;
  4377. -VEC    *b, *x;
  4378. -{
  4379. -    static VEC    *tmp=VNULL;    /* dummy storage needed */
  4380. -    int        i /* , j */, n, onebyone;
  4381. -    int        row_num, idx;
  4382. -    Real    a11, a12, a22, b1, b2, det, sum, *tmp_ve, tmp_diag;
  4383. -    SPROW    *r;
  4384. -    row_elt    *e;
  4385. -    
  4386. -    if ( ! A || ! pivot || ! block || ! b )
  4387. -    error(E_NULL,"spBKPsolve");
  4388. -    if ( A->m != A->n )
  4389. -    error(E_SQUARE,"spBKPsolve");
  4390. -    n = A->n;
  4391. -    if ( b->dim != n || pivot->size != n || block->size != n )
  4392. -    error(E_SIZES,"spBKPsolve");
  4393. -    x = v_resize(x,n);
  4394. -    tmp = v_resize(tmp,n);
  4395. -    MEM_STAT_REG(tmp,TYPE_VEC);
  4396. -    
  4397. -    tmp_ve = tmp->ve;
  4398. -
  4399. -    if ( ! A->flag_col )
  4400. -    sp_col_access(A);
  4401. -
  4402. -    px_vec(pivot,b,tmp);
  4403. -    /* printf("# BKPsolve: effect of pivot: tmp =\n");    v_output(tmp); */
  4404. -
  4405. -    /* solve for lower triangular part */
  4406. -    for ( i = 0; i < n; i++ )
  4407. -    {
  4408. -    sum = tmp_ve[i];
  4409. -    if ( block->pe[i] < i )
  4410. -    {
  4411. -        /* for ( j = 0; j < i-1; j++ )
  4412. -          sum -= A_me[j][i]*tmp_ve[j]; */
  4413. -        row_num = -1;    idx = i;
  4414. -        e = bump_col(A,i,&row_num,&idx);
  4415. -        while ( row_num >= 0 && row_num < i-1 )
  4416. -        {
  4417. -        sum -= e->val*tmp_ve[row_num];
  4418. -        e = bump_col(A,i,&row_num,&idx);
  4419. -        }
  4420. -    }
  4421. -    else
  4422. -    {
  4423. -        /* for ( j = 0; j < i; j++ )
  4424. -              sum -= A_me[j][i]*tmp_ve[j]; */
  4425. -        row_num = -1; idx = i;
  4426. -        e = bump_col(A,i,&row_num,&idx);
  4427. -        while ( row_num >= 0 && row_num < i )
  4428. -        {
  4429. -        sum -= e->val*tmp_ve[row_num];
  4430. -        e = bump_col(A,i,&row_num,&idx);
  4431. -        }
  4432. -    }
  4433. -    tmp_ve[i] = sum;
  4434. -    }
  4435. -
  4436. -    /* printf("# BKPsolve: solving L part: tmp =\n");    v_output(tmp); */
  4437. -    /* solve for diagonal part */
  4438. -    for ( i = 0; i < n; i = onebyone ? i+1 : i+2 )
  4439. -    {
  4440. -    onebyone = ( block->pe[i] == i );
  4441. -    if ( onebyone )
  4442. -    {
  4443. -        /* tmp_ve[i] /= A_me[i][i]; */
  4444. -        tmp_diag = sp_get_val(A,i,i);
  4445. -        if ( tmp_diag == 0.0 )
  4446. -        error(E_SING,"spBKPsolve");
  4447. -        tmp_ve[i] /= tmp_diag;
  4448. -    }
  4449. -    else
  4450. -    {
  4451. -        a11 = sp_get_val(A,i,i);
  4452. -        a22 = sp_get_val(A,i+1,i+1);
  4453. -        a12 = sp_get_val(A,i,i+1);
  4454. -        b1 = tmp_ve[i];
  4455. -        b2 = tmp_ve[i+1];
  4456. -        det = a11*a22-a12*a12;    /* < 0 : see BKPfactor() */
  4457. -        if ( det == 0.0 )
  4458. -        error(E_SING,"BKPsolve");
  4459. -        det = 1/det;
  4460. -        tmp_ve[i]   = det*(a22*b1-a12*b2);
  4461. -        tmp_ve[i+1] = det*(a11*b2-a12*b1);
  4462. -    }
  4463. -    }
  4464. -
  4465. -    /* printf("# BKPsolve: solving D part: tmp =\n");    v_output(tmp); */
  4466. -    /* solve for transpose of lower triangular part */
  4467. -    for ( i = n-2; i >= 0; i-- )
  4468. -    {
  4469. -    sum = tmp_ve[i];
  4470. -    if ( block->pe[i] > i )
  4471. -    {
  4472. -        /* onebyone is false */
  4473. -        /* for ( j = i+2; j < n; j++ )
  4474. -          sum -= A_me[i][j]*tmp_ve[j]; */
  4475. -        if ( i+2 >= n )
  4476. -        continue;
  4477. -        r = &(A->row[i]);
  4478. -        idx = sprow_idx(r,i+2);
  4479. -        idx = fixindex(idx);
  4480. -        e = &(r->elt[idx]);
  4481. -        for ( ; idx < r->len; idx++, e++ )
  4482. -        sum -= e->val*tmp_ve[e->col];
  4483. -    }
  4484. -    else /* onebyone */
  4485. -    {
  4486. -        /* for ( j = i+1; j < n; j++ )
  4487. -          sum -= A_me[i][j]*tmp_ve[j]; */
  4488. -        r = &(A->row[i]);
  4489. -        idx = sprow_idx(r,i+1);
  4490. -        idx = fixindex(idx);
  4491. -        e = &(r->elt[idx]);
  4492. -        for ( ; idx < r->len; idx++, e++ )
  4493. -        sum -= e->val*tmp_ve[e->col];
  4494. -    }
  4495. -    tmp_ve[i] = sum;
  4496. -    }
  4497. -
  4498. -    /* printf("# BKPsolve: solving L^T part: tmp =\n");v_output(tmp); */
  4499. -    /* and do final permutation */
  4500. -    x = pxinv_vec(pivot,tmp,x);
  4501. -
  4502. -    return x;
  4503. -}
  4504. -
  4505. -
  4506. -
  4507. //GO.SYSIN DD spbkp.c
  4508. echo spswap.c 1>&2
  4509. sed >spswap.c <<'//GO.SYSIN DD spswap.c' 's/^-//'
  4510. -
  4511. -/**************************************************************************
  4512. -**
  4513. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  4514. -**
  4515. -**                 Meschach Library
  4516. -** 
  4517. -** This Meschach Library is provided "as is" without any express 
  4518. -** or implied warranty of any kind with respect to this software. 
  4519. -** In particular the authors shall not be liable for any direct, 
  4520. -** indirect, special, incidental or consequential damages arising 
  4521. -** in any way from use of the software.
  4522. -** 
  4523. -** Everyone is granted permission to copy, modify and redistribute this
  4524. -** Meschach Library, provided:
  4525. -**  1.  All copies contain this copyright notice.
  4526. -**  2.  All modified copies shall carry a notice stating who
  4527. -**      made the last modification and the date of such modification.
  4528. -**  3.  No charge is made for this software or works derived from it.  
  4529. -**      This clause shall not be construed as constraining other software
  4530. -**      distributed on the same medium as this software, nor is a
  4531. -**      distribution fee considered a charge.
  4532. -**
  4533. -***************************************************************************/
  4534. -
  4535. -
  4536. -/*
  4537. -    Sparse matrix swap and permutation routines
  4538. -    Modified Mon 09th Nov 1992, 08:50:54 PM
  4539. -    to use Karen George's suggestion to use unordered rows
  4540. -*/
  4541. -
  4542. -static    char    rcsid[] = "$Id: spswap.c,v 1.3 1994/01/13 05:44:43 des Exp $";
  4543. -
  4544. -#include    <stdio.h>
  4545. -#include    <math.h>
  4546. -#include    "matrix.h"
  4547. -#include    "sparse.h"
  4548. -#include        "sparse2.h"
  4549. -
  4550. -
  4551. -#define    btos(x)    ((x) ? "TRUE" : "FALSE")
  4552. -
  4553. -/* scan_to -- updates scan (int) vectors to point to the last row in each
  4554. -    column with row # <= max_row, if any */
  4555. -void    scan_to(A, scan_row, scan_idx, col_list, max_row)
  4556. -SPMAT    *A;
  4557. -IVEC    *scan_row, *scan_idx, *col_list;
  4558. -int    max_row;
  4559. -{
  4560. -    int        col, idx, j_idx, row_num;
  4561. -    SPROW    *r;
  4562. -    row_elt    *e;
  4563. -
  4564. -    if ( ! A || ! scan_row || ! scan_idx || ! col_list )
  4565. -    error(E_NULL,"scan_to");
  4566. -    if ( scan_row->dim != scan_idx->dim || scan_idx->dim != col_list->dim )
  4567. -    error(E_SIZES,"scan_to");
  4568. -
  4569. -    if ( max_row < 0 )
  4570. -    return;
  4571. -
  4572. -    if ( ! A->flag_col )
  4573. -    sp_col_access(A);
  4574. -
  4575. -    for ( j_idx = 0; j_idx < scan_row->dim; j_idx++ )
  4576. -    {
  4577. -    row_num = scan_row->ive[j_idx];
  4578. -    idx = scan_idx->ive[j_idx];
  4579. -    col = col_list->ive[j_idx];
  4580. -
  4581. -    if ( col < 0 || col >= A->n )
  4582. -        error(E_BOUNDS,"scan_to");
  4583. -    if ( row_num < 0 )
  4584. -    {
  4585. -        idx = col;
  4586. -        continue;
  4587. -    }
  4588. -    r = &(A->row[row_num]);
  4589. -    if ( idx < 0 )
  4590. -        error(E_INTERN,"scan_to");
  4591. -    e = &(r->elt[idx]);
  4592. -    if ( e->col != col )
  4593. -        error(E_INTERN,"scan_to");
  4594. -    if ( idx < 0 )
  4595. -    {
  4596. -        printf("scan_to: row_num = %d, idx = %d, col = %d\n",
  4597. -           row_num, idx, col);
  4598. -        error(E_INTERN,"scan_to");
  4599. -    }
  4600. -    /* if ( e->nxt_row <= max_row )
  4601. -        chase_col(A, col, &row_num, &idx, max_row); */
  4602. -    while ( e->nxt_row >= 0 && e->nxt_row <= max_row )
  4603. -    {
  4604. -        row_num = e->nxt_row;
  4605. -        idx = e->nxt_idx;
  4606. -        e = &(A->row[row_num].elt[idx]);
  4607. -    }
  4608. -        
  4609. -    /* printf("scan_to: computed j_idx = %d, row_num = %d, idx = %d\n",
  4610. -           j_idx, row_num, idx); */
  4611. -    scan_row->ive[j_idx] = row_num;
  4612. -    scan_idx->ive[j_idx] = idx;
  4613. -    }
  4614. -}
  4615. -
  4616. -/* patch_col -- patches column access paths for fill-in */
  4617. -void patch_col(A, col, old_row, old_idx, row_num, idx)
  4618. -SPMAT    *A;
  4619. -int    col, old_row, old_idx, row_num, idx;
  4620. -{
  4621. -    SPROW    *r;
  4622. -    row_elt    *e;
  4623. -    
  4624. -    if ( old_row >= 0 )
  4625. -    {
  4626. -    r = &(A->row[old_row]);
  4627. -    old_idx = sprow_idx2(r,col,old_idx);
  4628. -    e = &(r->elt[old_idx]);
  4629. -    e->nxt_row = row_num;
  4630. -    e->nxt_idx = idx;
  4631. -    }
  4632. -    else
  4633. -    {
  4634. -    A->start_row[col] = row_num;
  4635. -    A->start_idx[col] = idx;
  4636. -    }
  4637. -}
  4638. -
  4639. -/* chase_col -- chases column access path in column col, starting with
  4640. -   row_num and idx, to find last row # in this column <= max_row
  4641. -   -- row_num is returned; idx is also set by this routine
  4642. -   -- assumes that the column access paths (possibly without the
  4643. -   nxt_idx fields) are set up */
  4644. -row_elt *chase_col(A, col, row_num, idx, max_row)
  4645. -SPMAT    *A;
  4646. -int    col, *row_num, *idx, max_row;
  4647. -{
  4648. -    int        old_idx, old_row, tmp_idx, tmp_row;
  4649. -    SPROW    *r;
  4650. -    row_elt    *e;
  4651. -    
  4652. -    if ( col < 0 || col >= A->n )
  4653. -    error(E_BOUNDS,"chase_col");
  4654. -    tmp_row = *row_num;
  4655. -    if ( tmp_row < 0 )
  4656. -    {
  4657. -    if ( A->start_row[col] > max_row )
  4658. -    {
  4659. -        tmp_row = -1;
  4660. -        tmp_idx = col;
  4661. -        return (row_elt *)NULL;
  4662. -    }
  4663. -    else
  4664. -    {
  4665. -        tmp_row = A->start_row[col];
  4666. -        tmp_idx = A->start_idx[col];
  4667. -    }
  4668. -    }
  4669. -    else
  4670. -    tmp_idx = *idx;
  4671. -    
  4672. -    old_row = tmp_row;
  4673. -    old_idx = tmp_idx;
  4674. -    while ( tmp_row >= 0 && tmp_row < max_row )
  4675. -    {
  4676. -    r = &(A->row[tmp_row]);
  4677. -    /* tmp_idx = sprow_idx2(r,col,tmp_idx); */
  4678. -    if ( tmp_idx < 0 || tmp_idx >= r->len ||
  4679. -         r->elt[tmp_idx].col != col )
  4680. -    {
  4681. -#ifdef DEBUG
  4682. -        printf("chase_col:error: col = %d, row # = %d, idx = %d\n",
  4683. -           col, tmp_row, tmp_idx);
  4684. -        printf("chase_col:error: old_row = %d, old_idx = %d\n",
  4685. -           old_row, old_idx);
  4686. -        printf("chase_col:error: A =\n");
  4687. -        sp_dump(stdout,A);
  4688. -#endif
  4689. -        error(E_INTERN,"chase_col");
  4690. -    }
  4691. -    e = &(r->elt[tmp_idx]);
  4692. -    old_row = tmp_row;
  4693. -    old_idx = tmp_idx;
  4694. -    tmp_row = e->nxt_row;
  4695. -    tmp_idx = e->nxt_idx;
  4696. -    }
  4697. -    if ( old_row > max_row )
  4698. -    {
  4699. -    old_row = -1;
  4700. -    old_idx = col;
  4701. -    e = (row_elt *)NULL;
  4702. -    }
  4703. -    else if ( tmp_row <= max_row && tmp_row >= 0 )
  4704. -    {
  4705. -    old_row = tmp_row;
  4706. -    old_idx = tmp_idx;
  4707. -    }
  4708. -
  4709. -    *row_num = old_row;
  4710. -    if ( old_row >= 0 )
  4711. -    *idx = old_idx;
  4712. -    else
  4713. -    *idx = col;
  4714. -
  4715. -    return e;
  4716. -}
  4717. -
  4718. -/* chase_past -- as for chase_col except that we want the first
  4719. -    row whose row # >= min_row; -1 indicates no such row */
  4720. -row_elt *chase_past(A, col, row_num, idx, min_row)
  4721. -SPMAT    *A;
  4722. -int    col, *row_num, *idx, min_row;
  4723. -{
  4724. -    SPROW    *r;
  4725. -    row_elt    *e;
  4726. -    int        tmp_idx, tmp_row;
  4727. -
  4728. -    tmp_row = *row_num;
  4729. -    tmp_idx = *idx;
  4730. -    chase_col(A,col,&tmp_row,&tmp_idx,min_row);
  4731. -    if ( tmp_row < 0 )    /* use A->start_row[..] etc. */
  4732. -    {
  4733. -    if ( A->start_row[col] < 0 )
  4734. -        tmp_row = -1;
  4735. -    else
  4736. -    {
  4737. -        tmp_row = A->start_row[col];
  4738. -        tmp_idx = A->start_idx[col];
  4739. -    }
  4740. -    }
  4741. -    else if ( tmp_row < min_row )
  4742. -    {
  4743. -    r = &(A->row[tmp_row]);
  4744. -    if ( tmp_idx < 0 || tmp_idx >= r->len ||
  4745. -         r->elt[tmp_idx].col != col )
  4746. -        error(E_INTERN,"chase_past");
  4747. -    tmp_row = r->elt[tmp_idx].nxt_row;
  4748. -    tmp_idx = r->elt[tmp_idx].nxt_idx;
  4749. -    }
  4750. -
  4751. -    *row_num = tmp_row;
  4752. -    *idx = tmp_idx;
  4753. -    if ( tmp_row < 0 )
  4754. -    e = (row_elt *)NULL;
  4755. -    else
  4756. -    {
  4757. -    if ( tmp_idx < 0 || tmp_idx >= A->row[tmp_row].len ||
  4758. -         A->row[tmp_row].elt[tmp_idx].col != col )
  4759. -        error(E_INTERN,"bump_col");
  4760. -    e = &(A->row[tmp_row].elt[tmp_idx]);
  4761. -    }
  4762. -
  4763. -    return e;
  4764. -}
  4765. -
  4766. -/* bump_col -- move along to next nonzero entry in column col after row_num
  4767. -    -- update row_num and idx */
  4768. -row_elt *bump_col(A, col, row_num, idx)
  4769. -SPMAT    *A;
  4770. -int    col, *row_num, *idx;
  4771. -{
  4772. -    SPROW    *r;
  4773. -    row_elt    *e;
  4774. -    int        tmp_row, tmp_idx;
  4775. -
  4776. -    tmp_row = *row_num;
  4777. -    tmp_idx = *idx;
  4778. -    /* printf("bump_col: col = %d, row# = %d, idx = %d\n",
  4779. -       col, *row_num, *idx); */
  4780. -    if ( tmp_row < 0 )
  4781. -    {
  4782. -    tmp_row = A->start_row[col];
  4783. -    tmp_idx = A->start_idx[col];
  4784. -    }
  4785. -    else
  4786. -    {
  4787. -    r = &(A->row[tmp_row]);
  4788. -    if ( tmp_idx < 0 || tmp_idx >= r->len ||
  4789. -         r->elt[tmp_idx].col != col )
  4790. -        error(E_INTERN,"bump_col");
  4791. -    e = &(r->elt[tmp_idx]);
  4792. -    tmp_row = e->nxt_row;
  4793. -    tmp_idx = e->nxt_idx;
  4794. -    }
  4795. -    if ( tmp_row < 0 )
  4796. -    {
  4797. -    e = (row_elt *)NULL;
  4798. -    tmp_idx = col;
  4799. -    }
  4800. -    else
  4801. -    {
  4802. -    if ( tmp_idx < 0 || tmp_idx >= A->row[tmp_row].len ||
  4803. -         A->row[tmp_row].elt[tmp_idx].col != col )
  4804. -        error(E_INTERN,"bump_col");
  4805. -    e = &(A->row[tmp_row].elt[tmp_idx]);
  4806. -    }
  4807. -    *row_num = tmp_row;
  4808. -    *idx = tmp_idx;
  4809. -
  4810. -    return e;
  4811. -}
  4812. -
  4813. -
  4814. //GO.SYSIN DD spswap.c
  4815. echo iter0.c 1>&2
  4816. sed >iter0.c <<'//GO.SYSIN DD iter0.c' 's/^-//'
  4817. -
  4818. -/**************************************************************************
  4819. -**
  4820. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  4821. -**
  4822. -**                 Meschach Library
  4823. -** 
  4824. -** This Meschach Library is provided "as is" without any express 
  4825. -** or implied warranty of any kind with respect to this software. 
  4826. -** In particular the authors shall not be liable for any direct, 
  4827. -** indirect, special, incidental or consequential damages arising 
  4828. -** in any way from use of the software.
  4829. -** 
  4830. -** Everyone is granted permission to copy, modify and redistribute this
  4831. -** Meschach Library, provided:
  4832. -**  1.  All copies contain this copyright notice.
  4833. -**  2.  All modified copies shall carry a notice stating who
  4834. -**      made the last modification and the date of such modification.
  4835. -**  3.  No charge is made for this software or works derived from it.  
  4836. -**      This clause shall not be construed as constraining other software
  4837. -**      distributed on the same medium as this software, nor is a
  4838. -**      distribution fee considered a charge.
  4839. -**
  4840. -***************************************************************************/
  4841. -
  4842. -
  4843. -/* iter0.c  14/09/93 */
  4844. -
  4845. -/* ITERATIVE METHODS - service functions */
  4846. -
  4847. -/* functions for creating and releasing ITER structures;
  4848. -   for memory information;
  4849. -   for getting some values from an ITER variable;
  4850. -   for changing values in an ITER variable;
  4851. -   see also iter.c
  4852. -*/
  4853. -
  4854. -#include        <stdio.h>
  4855. -#include    <math.h>
  4856. -#include        "iter.h"
  4857. -
  4858. -
  4859. -static char rcsid[] = "$Id: iter0.c,v 1.1 1994/01/13 05:38:23 des Exp $";
  4860. -
  4861. -
  4862. -/* standard functions */
  4863. -
  4864. -/* standard information */
  4865. -void iter_std_info(ip,nres,res,Bres)
  4866. -ITER *ip;
  4867. -double nres;
  4868. -VEC *res, *Bres;
  4869. -{
  4870. -   if (nres >= 0.0)
  4871. -     printf(" %d. residual = %g\n",ip->steps,nres);
  4872. -   else 
  4873. -     printf(" %d. residual = %g (WARNING !!! should be >= 0) \n",
  4874. -        ip->steps,nres);
  4875. -}
  4876. -
  4877. -/* standard stopping criterion */
  4878. -int iter_std_stop_crit(ip, nres, res, Bres)
  4879. -ITER *ip;
  4880. -double nres;
  4881. -VEC *res, *Bres;
  4882. -{
  4883. -   /* save initial value of the residual in init_res */
  4884. -   if (ip->steps == 0)
  4885. -     ip->init_res = fabs(nres);
  4886. -
  4887. -   /* standard stopping criterium */
  4888. -   if (nres <= ip->init_res*ip->eps) return TRUE; 
  4889. -   return FALSE;
  4890. -}
  4891. -
  4892. -
  4893. -/* iter_get - create a new structure pointing to ITER */
  4894. -
  4895. -ITER *iter_get(lenb, lenx)
  4896. -int lenb, lenx;
  4897. -{
  4898. -   ITER *ip;
  4899. -
  4900. -   if ((ip = NEW(ITER)) == (ITER *) NULL)
  4901. -     error(E_MEM,"iter_get");
  4902. -   else if (mem_info_is_on()) {
  4903. -      mem_bytes(TYPE_ITER,0,sizeof(ITER));
  4904. -      mem_numvar(TYPE_ITER,1);
  4905. -   }
  4906. -
  4907. -   /* default values */
  4908. -   
  4909. -   ip->shared_x = FALSE;
  4910. -   ip->shared_b = FALSE;
  4911. -   ip->k = 0;
  4912. -   ip->limit = ITER_LIMIT_DEF;
  4913. -   ip->eps = ITER_EPS_DEF;
  4914. -   ip->steps = 0;
  4915. -
  4916. -   if (lenb > 0) ip->b = v_get(lenb);
  4917. -   else ip->b = (VEC *)NULL;
  4918. -
  4919. -   if (lenx > 0) ip->x = v_get(lenx);
  4920. -   else ip->x = (VEC *)NULL;
  4921. -
  4922. -   ip->Ax = ip->A_par = NULL;
  4923. -   ip->ATx = ip->AT_par = NULL;
  4924. -   ip->Bx = ip->B_par = NULL;
  4925. -   ip->info = iter_std_info;
  4926. -   ip->stop_crit = iter_std_stop_crit;
  4927. -   ip->init_res = 0.0;
  4928. -   
  4929. -   return ip;
  4930. -}
  4931. -
  4932. -
  4933. -/* iter_free - release memory */
  4934. -int iter_free(ip)
  4935. -ITER *ip;
  4936. -{
  4937. -   if (ip == (ITER *)NULL) return -1;
  4938. -   
  4939. -   if (mem_info_is_on()) {
  4940. -      mem_bytes(TYPE_ITER,sizeof(ITER),0);
  4941. -      mem_numvar(TYPE_ITER,-1);
  4942. -   }
  4943. -
  4944. -   if ( !ip->shared_x && ip->x != NULL ) v_free(ip->x);
  4945. -   if ( !ip->shared_b && ip->b != NULL ) v_free(ip->b);
  4946. -
  4947. -   free((char *)ip);
  4948. -
  4949. -   return 0;
  4950. -}
  4951. -
  4952. -ITER *iter_resize(ip,new_lenb,new_lenx)
  4953. -ITER *ip;
  4954. -int new_lenb, new_lenx;
  4955. -{
  4956. -   VEC *old;
  4957. -
  4958. -   if ( ip == (ITER *) NULL)
  4959. -     error(E_NULL,"iter_resize");
  4960. -
  4961. -   old = ip->x;
  4962. -   ip->x = v_resize(ip->x,new_lenx);
  4963. -   if ( ip->shared_x && old != ip->x )
  4964. -     warning(WARN_SHARED_VEC,"iter_resize");
  4965. -   old = ip->b;
  4966. -   ip->b = v_resize(ip->b,new_lenb);
  4967. -   if ( ip->shared_b && old != ip->b )
  4968. -     warning(WARN_SHARED_VEC,"iter_resize");
  4969. -
  4970. -   return ip;
  4971. -}
  4972. -
  4973. -
  4974. -/* print out ip structure - for diagnostic purposes mainly */
  4975. -void iter_dump(fp,ip)
  4976. -ITER *ip;
  4977. -FILE *fp;
  4978. -{
  4979. -   if (ip == NULL) {
  4980. -      fprintf(fp," ITER structure: NULL\n");
  4981. -      return;
  4982. -   }
  4983. -
  4984. -   fprintf(fp,"\n ITER structure:\n");
  4985. -   fprintf(fp," ip->shared_x = %s, ip->shared_b = %s\n",
  4986. -       (ip->shared_x ? "TRUE" : "FALSE"),
  4987. -       (ip->shared_b ? "TRUE" : "FALSE") );
  4988. -   fprintf(fp," ip->k = %d, ip->limit = %d, ip->steps = %d, ip->eps = %g\n",
  4989. -       ip->k,ip->limit,ip->steps,ip->eps);
  4990. -   fprintf(fp," ip->x = 0x%p, ip->b = 0x%p\n",ip->x,ip->b);
  4991. -   fprintf(fp," ip->Ax = 0x%p, ip->A_par = 0x%p\n",ip->Ax,ip->A_par);
  4992. -   fprintf(fp," ip->ATx = 0x%p, ip->AT_par = 0x%p\n",ip->ATx,ip->AT_par);
  4993. -   fprintf(fp," ip->Bx = 0x%p, ip->B_par = 0x%p\n",ip->Bx,ip->B_par);
  4994. -   fprintf(fp," ip->info = 0x%p, ip->stop_crit = 0x%p, ip->init_res = %g\n",
  4995. -       ip->info,ip->stop_crit,ip->init_res);
  4996. -   fprintf(fp,"\n");
  4997. -   
  4998. -}
  4999. -
  5000. -
  5001. -/* copy the structure ip1 to ip2 preserving vectors x and b of ip2
  5002. -   (vectors x and b in ip2 are the same before and after iter_copy2)
  5003. -   if ip2 == NULL then a new structure is created with x and b being NULL
  5004. -   and other members are taken from ip1
  5005. -*/
  5006. -ITER *iter_copy2(ip1,ip2)
  5007. -ITER *ip1, *ip2;
  5008. -{
  5009. -   VEC *x, *b;
  5010. -   int shx, shb;
  5011. -
  5012. -   if (ip1 == (ITER *)NULL) 
  5013. -     error(E_NULL,"iter_copy2");
  5014. -
  5015. -   if (ip2 == (ITER *)NULL) {
  5016. -      if ((ip2 = NEW(ITER)) == (ITER *) NULL)
  5017. -    error(E_MEM,"iter_copy2");
  5018. -      else if (mem_info_is_on()) {
  5019. -     mem_bytes(TYPE_ITER,0,sizeof(ITER));
  5020. -     mem_numvar(TYPE_ITER,1);
  5021. -      }
  5022. -      ip2->x = ip2->b = NULL;
  5023. -      ip2->shared_x = ip2->shared_x = FALSE;
  5024. -   }
  5025. -
  5026. -   x = ip2->x;
  5027. -   b = ip2->b;
  5028. -   shb = ip2->shared_b;
  5029. -   shx = ip2->shared_x;
  5030. -   MEM_COPY(ip1,ip2,sizeof(ITER));
  5031. -   ip2->x = x;
  5032. -   ip2->b = b;
  5033. -   ip2->shared_x = shx;
  5034. -   ip2->shared_b = shb;
  5035. -
  5036. -   return ip2;
  5037. -}
  5038. -
  5039. -
  5040. -/* copy the structure ip1 to ip2 copying also the vectors x and b */
  5041. -ITER *iter_copy(ip1,ip2)
  5042. -ITER *ip1, *ip2;
  5043. -{
  5044. -   VEC *x, *b;
  5045. -
  5046. -   if (ip1 == (ITER *)NULL) 
  5047. -     error(E_NULL,"iter_copy");
  5048. -
  5049. -   if (ip2 == (ITER *)NULL) {
  5050. -      if ((ip2 = NEW(ITER)) == (ITER *) NULL)
  5051. -    error(E_MEM,"iter_copy2");
  5052. -      else if (mem_info_is_on()) {
  5053. -     mem_bytes(TYPE_ITER,0,sizeof(ITER));
  5054. -     mem_numvar(TYPE_ITER,1);
  5055. -      }
  5056. -   }
  5057. -
  5058. -   x = ip2->x;
  5059. -   b = ip2->b;
  5060. -
  5061. -   MEM_COPY(ip1,ip2,sizeof(ITER));
  5062. -   if (ip1->x)
  5063. -     ip2->x = v_copy(ip1->x,x);
  5064. -   if (ip1->b)
  5065. -     ip2->b = v_copy(ip1->b,b);
  5066. -
  5067. -   ip2->shared_x = ip2->shared_b = FALSE;
  5068. -
  5069. -   return ip2;
  5070. -}
  5071. -
  5072. -
  5073. -/*** functions to generate sparse matrices with random entries ***/
  5074. -
  5075. -
  5076. -/* iter_gen_sym -- generate symmetric positive definite
  5077. -   n x n matrix, 
  5078. -   nrow - number of nonzero entries in a row
  5079. -   */
  5080. -SPMAT    *iter_gen_sym(n,nrow)
  5081. -int    n, nrow;
  5082. -{
  5083. -   SPMAT    *A;
  5084. -   VEC            *u;
  5085. -   Real       s1;
  5086. -   int        i, j, k, k_max;
  5087. -   
  5088. -   if (nrow <= 1) nrow = 2;
  5089. -   /* nrow should be even */
  5090. -   if ((nrow & 1)) nrow -= 1;
  5091. -   A = sp_get(n,n,nrow);
  5092. -   u = v_get(A->m);
  5093. -   v_zero(u);
  5094. -   for ( i = 0; i < A->m; i++ )
  5095. -   {
  5096. -      k_max = ((rand() >> 8) % (nrow/2));
  5097. -      for ( k = 0; k <= k_max; k++ )
  5098. -      {
  5099. -     j = (rand() >> 8) % A->n;
  5100. -     s1 = mrand();
  5101. -     sp_set_val(A,i,j,s1);
  5102. -     sp_set_val(A,j,i,s1);
  5103. -     u->ve[i] += fabs(s1);
  5104. -     u->ve[j] += fabs(s1);
  5105. -      }
  5106. -   }
  5107. -   /* ensure that A is positive definite */
  5108. -   for ( i = 0; i < A->m; i++ )
  5109. -     sp_set_val(A,i,i,u->ve[i] + 1.0);
  5110. -   
  5111. -   V_FREE(u);
  5112. -   return A;
  5113. -}
  5114. -
  5115. -
  5116. -/* iter_gen_nonsym -- generate non-symmetric m x n sparse matrix, m >= n 
  5117. -   nrow - number of entries in a row;
  5118. -   diag - number which is put in diagonal entries and then permuted
  5119. -   (if diag is zero then 1.0 is there)
  5120. -*/
  5121. -SPMAT    *iter_gen_nonsym(m,n,nrow,diag)
  5122. -int    m, n, nrow;
  5123. -double diag;
  5124. -{
  5125. -   SPMAT    *A;
  5126. -   PERM        *px;
  5127. -   int        i, j, k, k_max;
  5128. -   Real        s1;
  5129. -   
  5130. -   if (nrow <= 1) nrow = 2;
  5131. -   if (diag == 0.0) diag = 1.0;
  5132. -   A = sp_get(m,n,nrow);
  5133. -   px = px_get(n);
  5134. -   for ( i = 0; i < A->m; i++ )
  5135. -   {
  5136. -      k_max = (rand() >> 8) % (nrow-1);
  5137. -      for ( k = 0; k <= k_max; k++ )
  5138. -      {
  5139. -     j = (rand() >> 8) % A->n;
  5140. -     s1 = mrand();
  5141. -     sp_set_val(A,i,j,-s1);
  5142. -      }
  5143. -   }
  5144. -   /* to make it likely that A is nonsingular, use pivot... */
  5145. -   for ( i = 0; i < 2*A->n; i++ )
  5146. -   {
  5147. -      j = (rand() >> 8) % A->n;
  5148. -      k = (rand() >> 8) % A->n;
  5149. -      px_transp(px,j,k);
  5150. -   }
  5151. -   for ( i = 0; i < A->n; i++ )
  5152. -     sp_set_val(A,i,px->pe[i],diag);  
  5153. -   
  5154. -   PX_FREE(px);
  5155. -   return A;
  5156. -}
  5157. -
  5158. -
  5159. -/* iter_gen_nonsym -- generate non-symmetric positive definite 
  5160. -   n x n sparse matrix;
  5161. -   nrow - number of entries in a row
  5162. -*/
  5163. -SPMAT    *iter_gen_nonsym_posdef(n,nrow)
  5164. -int    n, nrow;
  5165. -{
  5166. -   SPMAT    *A;
  5167. -   PERM        *px;
  5168. -   VEC          *u;
  5169. -   int        i, j, k, k_max;
  5170. -   Real        s1;
  5171. -   
  5172. -   if (nrow <= 1) nrow = 2;
  5173. -   A = sp_get(n,n,nrow);
  5174. -   px = px_get(n);
  5175. -   u = v_get(A->m);
  5176. -   v_zero(u);
  5177. -   for ( i = 0; i < A->m; i++ )
  5178. -   {
  5179. -      k_max = (rand() >> 8) % (nrow-1);
  5180. -      for ( k = 0; k <= k_max; k++ )
  5181. -      {
  5182. -     j = (rand() >> 8) % A->n;
  5183. -     s1 = mrand();
  5184. -     sp_set_val(A,i,j,-s1);
  5185. -     u->ve[i] += fabs(s1);
  5186. -      }
  5187. -   }
  5188. -   /* ensure that A is positive definite */
  5189. -   for ( i = 0; i < A->m; i++ )
  5190. -     sp_set_val(A,i,i,u->ve[i] + 1.0);
  5191. -   
  5192. -   PX_FREE(px);
  5193. -   V_FREE(u);
  5194. -   return A;
  5195. -}
  5196. -
  5197. -
  5198. //GO.SYSIN DD iter0.c
  5199. echo itersym.c 1>&2
  5200. sed >itersym.c <<'//GO.SYSIN DD itersym.c' 's/^-//'
  5201. -
  5202. -/**************************************************************************
  5203. -**
  5204. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  5205. -**
  5206. -**                 Meschach Library
  5207. -** 
  5208. -** This Meschach Library is provided "as is" without any express 
  5209. -** or implied warranty of any kind with respect to this software. 
  5210. -** In particular the authors shall not be liable for any direct, 
  5211. -** indirect, special, incidental or consequential damages arising 
  5212. -** in any way from use of the software.
  5213. -** 
  5214. -** Everyone is granted permission to copy, modify and redistribute this
  5215. -** Meschach Library, provided:
  5216. -**  1.  All copies contain this copyright notice.
  5217. -**  2.  All modified copies shall carry a notice stating who
  5218. -**      made the last modification and the date of such modification.
  5219. -**  3.  No charge is made for this software or works derived from it.  
  5220. -**      This clause shall not be construed as constraining other software
  5221. -**      distributed on the same medium as this software, nor is a
  5222. -**      distribution fee considered a charge.
  5223. -**
  5224. -***************************************************************************/
  5225. -
  5226. -
  5227. -/* itersym.c 17/09/93 */
  5228. -
  5229. -
  5230. -/* 
  5231. -  ITERATIVE METHODS - implementation of several iterative methods;
  5232. -  see also iter0.c
  5233. -  */
  5234. -
  5235. -#include        <stdio.h>
  5236. -#include    <math.h>
  5237. -#include        "matrix.h"
  5238. -#include        "matrix2.h"
  5239. -#include    "sparse.h"
  5240. -#include        "iter.h"
  5241. -
  5242. -static char rcsid[] = "$Id: itersym.c,v 1.1 1994/01/13 05:38:59 des Exp $";
  5243. -
  5244. -
  5245. -#ifdef ANSI_C
  5246. -VEC    *spCHsolve(SPMAT *,VEC *,VEC *);
  5247. -VEC    *trieig(VEC *,VEC *,MAT *);
  5248. -#else
  5249. -VEC    *spCHsolve();
  5250. -VEC    *trieig();
  5251. -#endif
  5252. -
  5253. -
  5254. -
  5255. -/* iter_spcg -- a simple interface to iter_cg() which uses sparse matrix
  5256. -   data structures
  5257. -   -- assumes that LLT contains the Cholesky factorisation of the
  5258. -   actual preconditioner;
  5259. -   use always as follows:
  5260. -   x = iter_spcg(A,LLT,b,eps,x,limit,steps);
  5261. -   or 
  5262. -   x = iter_spcg(A,LLT,b,eps,VNULL,limit,steps);
  5263. -   In the second case the solution vector is created.
  5264. -   */
  5265. -VEC  *iter_spcg(A,LLT,b,eps,x,limit,steps)
  5266. -SPMAT    *A, *LLT;
  5267. -VEC    *b, *x;
  5268. -double    eps;
  5269. -int *steps, limit;
  5270. -{    
  5271. -   ITER *ip;
  5272. -   
  5273. -   ip = iter_get(0,0);
  5274. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  5275. -   ip->A_par = (void *)A;
  5276. -   ip->Bx = (Fun_Ax) spCHsolve;
  5277. -   ip->B_par = (void *)LLT;
  5278. -   ip->info = (Fun_info) NULL;
  5279. -   ip->b = b;
  5280. -   ip->eps = eps;
  5281. -   ip->limit = limit;
  5282. -   ip->x = x;
  5283. -   iter_cg(ip);
  5284. -   x = ip->x;
  5285. -   if (steps) *steps = ip->steps;
  5286. -   ip->shared_x = ip->shared_b = TRUE;
  5287. -   iter_free(ip);   /* release only ITER structure */
  5288. -   return x;        
  5289. -}
  5290. -
  5291. -/* 
  5292. -  Conjugate gradients method;
  5293. -  */
  5294. -VEC  *iter_cg(ip)
  5295. -ITER *ip;
  5296. -{
  5297. -   static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL;
  5298. -   Real    alpha, beta, inner, old_inner, nres;
  5299. -   VEC *rr;   /* rr == r or rr == z */
  5300. -   
  5301. -   if (ip == INULL)
  5302. -     error(E_NULL,"iter_cg");
  5303. -   if (!ip->Ax || !ip->b)
  5304. -     error(E_NULL,"iter_cg");
  5305. -   if ( ip->x == ip->b )
  5306. -     error(E_INSITU,"iter_cg");
  5307. -   if (!ip->stop_crit)
  5308. -     error(E_NULL,"iter_cg");
  5309. -   
  5310. -   if ( ip->eps <= 0.0 )
  5311. -     ip->eps = MACHEPS;
  5312. -   
  5313. -   r = v_resize(r,ip->b->dim);
  5314. -   p = v_resize(p,ip->b->dim);
  5315. -   q = v_resize(q,ip->b->dim);
  5316. -   
  5317. -   MEM_STAT_REG(r,TYPE_VEC);
  5318. -   MEM_STAT_REG(p,TYPE_VEC);
  5319. -   MEM_STAT_REG(q,TYPE_VEC);
  5320. -   
  5321. -   if (ip->Bx != (Fun_Ax)NULL) {
  5322. -      z = v_resize(z,ip->b->dim);
  5323. -      MEM_STAT_REG(z,TYPE_VEC);
  5324. -      rr = z;
  5325. -   }
  5326. -   else rr = r;
  5327. -   
  5328. -   if (ip->x != VNULL) {
  5329. -      if (ip->x->dim != ip->b->dim)
  5330. -    error(E_SIZES,"iter_cg");
  5331. -      ip->Ax(ip->A_par,ip->x,p);            /* p = A*x */
  5332. -      v_sub(ip->b,p,r);                 /* r = b - A*x */
  5333. -   }
  5334. -   else {  /* ip->x == 0 */
  5335. -      ip->x = v_get(ip->b->dim);
  5336. -      ip->shared_x = FALSE;
  5337. -      v_copy(ip->b,r);
  5338. -   }
  5339. -   
  5340. -   old_inner = 0.0;
  5341. -   for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ )
  5342. -   {
  5343. -      if ( ip->Bx )
  5344. -    (ip->Bx)(ip->B_par,r,rr);        /* rr = B*r */
  5345. -      
  5346. -      inner = in_prod(rr,r);
  5347. -      nres = sqrt(fabs(inner));
  5348. -      if (ip->info) ip->info(ip,nres,r,rr);
  5349. -      if ( ip->stop_crit(ip,nres,r,rr) ) break;
  5350. -      
  5351. -      if ( ip->steps )    /* if ( ip->steps > 0 ) ... */
  5352. -      {
  5353. -     beta = inner/old_inner;
  5354. -     p = v_mltadd(rr,p,beta,p);
  5355. -      }
  5356. -      else        /* if ( ip->steps == 0 ) ... */
  5357. -      {
  5358. -     beta = 0.0;
  5359. -     p = v_copy(rr,p);
  5360. -     old_inner = 0.0;
  5361. -      }
  5362. -      (ip->Ax)(ip->A_par,p,q);     /* q = A*p */
  5363. -      alpha = inner/in_prod(p,q);
  5364. -      v_mltadd(ip->x,p,alpha,ip->x);
  5365. -      v_mltadd(r,q,-alpha,r);
  5366. -      old_inner = inner;
  5367. -   }
  5368. -   
  5369. -   return ip->x;
  5370. -}
  5371. -
  5372. -
  5373. -
  5374. -/* iter_lanczos -- raw lanczos algorithm -- no re-orthogonalisation
  5375. -   -- creates T matrix of size == m,
  5376. -   but no larger than before beta_k == 0
  5377. -   -- uses passed routine to do matrix-vector multiplies */
  5378. -void    iter_lanczos(ip,a,b,beta2,Q)
  5379. -ITER    *ip;
  5380. -VEC    *a, *b;
  5381. -Real    *beta2;
  5382. -MAT    *Q;
  5383. -{
  5384. -   int    j;
  5385. -   static VEC    *v = VNULL, *w = VNULL, *tmp = VNULL;
  5386. -   Real    alpha, beta, c;
  5387. -   
  5388. -   if ( ! ip )
  5389. -     error(E_NULL,"iter_lanczos");
  5390. -   if ( ! ip->Ax || ! ip->x || ! a || ! b )
  5391. -     error(E_NULL,"iter_lanczos");
  5392. -   if ( ip->k <= 0 )
  5393. -     error(E_BOUNDS,"iter_lanczos");
  5394. -   if ( Q && ( Q->n < ip->x->dim || Q->m < ip->k ) )
  5395. -     error(E_SIZES,"iter_lanczos");
  5396. -   
  5397. -   a = v_resize(a,(u_int)ip->k);    
  5398. -   b = v_resize(b,(u_int)(ip->k-1));
  5399. -   v = v_resize(v,ip->x->dim);
  5400. -   w = v_resize(w,ip->x->dim);
  5401. -   tmp = v_resize(tmp,ip->x->dim);
  5402. -   MEM_STAT_REG(v,TYPE_VEC);
  5403. -   MEM_STAT_REG(w,TYPE_VEC);
  5404. -   MEM_STAT_REG(tmp,TYPE_VEC);
  5405. -   
  5406. -   beta = 1.0;
  5407. -   v_zero(a);
  5408. -   v_zero(b);
  5409. -   if (Q) m_zero(Q);
  5410. -   
  5411. -   /* normalise x as w */
  5412. -   c = v_norm2(ip->x);
  5413. -   if (c <= MACHEPS) { /* ip->x == 0 */
  5414. -      *beta2 = 0.0;
  5415. -      return;
  5416. -   }
  5417. -   else 
  5418. -     sv_mlt(1.0/c,ip->x,w);
  5419. -   
  5420. -   (ip->Ax)(ip->A_par,w,v);
  5421. -   
  5422. -   for ( j = 0; j < ip->k; j++ )
  5423. -   {
  5424. -      /* store w in Q if Q not NULL */
  5425. -      if ( Q ) set_row(Q,j,w);
  5426. -      
  5427. -      alpha = in_prod(w,v);
  5428. -      a->ve[j] = alpha;
  5429. -      v_mltadd(v,w,-alpha,v);
  5430. -      beta = v_norm2(v);
  5431. -      if ( beta == 0.0 )
  5432. -      {
  5433. -     *beta2 = 0.0;
  5434. -     return;
  5435. -      }
  5436. -      
  5437. -      if ( j < ip->k-1 )
  5438. -    b->ve[j] = beta;
  5439. -      v_copy(w,tmp);
  5440. -      sv_mlt(1/beta,v,w);
  5441. -      sv_mlt(-beta,tmp,v);
  5442. -      (ip->Ax)(ip->A_par,w,tmp);
  5443. -      v_add(v,tmp,v);
  5444. -   }
  5445. -   *beta2 = beta;
  5446. -   
  5447. -}
  5448. -
  5449. -/* iter_splanczos -- version that uses sparse matrix data structure */
  5450. -void    iter_splanczos(A,m,x0,a,b,beta2,Q)
  5451. -SPMAT    *A;
  5452. -int     m;
  5453. -VEC     *x0, *a, *b;
  5454. -Real    *beta2;
  5455. -MAT     *Q;
  5456. -{    
  5457. -   ITER *ip;
  5458. -   
  5459. -   ip = iter_get(0,0);
  5460. -   ip->shared_x = ip->shared_b = TRUE;
  5461. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  5462. -   ip->A_par = (void *) A;
  5463. -   ip->x = x0;
  5464. -   ip->k = m;
  5465. -   iter_lanczos(ip,a,b,beta2,Q);    
  5466. -   iter_free(ip);   /* release only ITER structure */
  5467. -}
  5468. -
  5469. -
  5470. -
  5471. -extern    double    frexp(), ldexp();
  5472. -
  5473. -/* product -- returns the product of a long list of numbers
  5474. -   -- answer stored in mant (mantissa) and expt (exponent) */
  5475. -static    double    product(a,offset,expt)
  5476. -VEC    *a;
  5477. -double    offset;
  5478. -int    *expt;
  5479. -{
  5480. -   Real    mant, tmp_fctr;
  5481. -   int    i, tmp_expt;
  5482. -   
  5483. -   if ( ! a )
  5484. -     error(E_NULL,"product");
  5485. -   
  5486. -   mant = 1.0;
  5487. -   *expt = 0;
  5488. -   if ( offset == 0.0 )
  5489. -     for ( i = 0; i < a->dim; i++ )
  5490. -     {
  5491. -    mant *= frexp(a->ve[i],&tmp_expt);
  5492. -    *expt += tmp_expt;
  5493. -    if ( ! (i % 10) )
  5494. -    {
  5495. -       mant = frexp(mant,&tmp_expt);
  5496. -       *expt += tmp_expt;
  5497. -    }
  5498. -     }
  5499. -   else
  5500. -     for ( i = 0; i < a->dim; i++ )
  5501. -     {
  5502. -    tmp_fctr = a->ve[i] - offset;
  5503. -    tmp_fctr += (tmp_fctr > 0.0 ) ? -MACHEPS*offset :
  5504. -      MACHEPS*offset;
  5505. -    mant *= frexp(tmp_fctr,&tmp_expt);
  5506. -    *expt += tmp_expt;
  5507. -    if ( ! (i % 10) )
  5508. -    {
  5509. -       mant = frexp(mant,&tmp_expt);
  5510. -       *expt += tmp_expt;
  5511. -    }
  5512. -     }
  5513. -   
  5514. -   mant = frexp(mant,&tmp_expt);
  5515. -   *expt += tmp_expt;
  5516. -   
  5517. -   return mant;
  5518. -}
  5519. -
  5520. -/* product2 -- returns the product of a long list of numbers
  5521. -   -- answer stored in mant (mantissa) and expt (exponent) */
  5522. -static    double    product2(a,k,expt)
  5523. -VEC    *a;
  5524. -int    k;    /* entry of a to leave out */
  5525. -int    *expt;
  5526. -{
  5527. -   Real    mant, mu, tmp_fctr;
  5528. -   int    i, tmp_expt;
  5529. -   
  5530. -   if ( ! a )
  5531. -     error(E_NULL,"product2");
  5532. -   if ( k < 0 || k >= a->dim )
  5533. -     error(E_BOUNDS,"product2");
  5534. -   
  5535. -   mant = 1.0;
  5536. -   *expt = 0;
  5537. -   mu = a->ve[k];
  5538. -   for ( i = 0; i < a->dim; i++ )
  5539. -   {
  5540. -      if ( i == k )
  5541. -    continue;
  5542. -      tmp_fctr = a->ve[i] - mu;
  5543. -      tmp_fctr += ( tmp_fctr > 0.0 ) ? -MACHEPS*mu : MACHEPS*mu;
  5544. -      mant *= frexp(tmp_fctr,&tmp_expt);
  5545. -      *expt += tmp_expt;
  5546. -      if ( ! (i % 10) )
  5547. -      {
  5548. -     mant = frexp(mant,&tmp_expt);
  5549. -     *expt += tmp_expt;
  5550. -      }
  5551. -   }
  5552. -   mant = frexp(mant,&tmp_expt);
  5553. -   *expt += tmp_expt;
  5554. -   
  5555. -   return mant;
  5556. -}
  5557. -
  5558. -/* dbl_cmp -- comparison function to pass to qsort() */
  5559. -static    int    dbl_cmp(x,y)
  5560. -Real    *x, *y;
  5561. -{
  5562. -   Real    tmp;
  5563. -   
  5564. -   tmp = *x - *y;
  5565. -   return (tmp > 0 ? 1 : tmp < 0 ? -1: 0);
  5566. -}
  5567. -
  5568. -/* iter_lanczos2 -- lanczos + error estimate for every e-val
  5569. -   -- uses Cullum & Willoughby approach, Sparse Matrix Proc. 1978
  5570. -   -- returns multiple e-vals where multiple e-vals may not exist
  5571. -   -- returns evals vector */
  5572. -VEC    *iter_lanczos2(ip,evals,err_est)
  5573. -ITER     *ip;            /* ITER structure */
  5574. -VEC    *evals;        /* eigenvalue vector */
  5575. -VEC    *err_est;    /* error estimates of eigenvalues */
  5576. -{
  5577. -   VEC        *a;
  5578. -   static    VEC    *b=VNULL, *a2=VNULL, *b2=VNULL;
  5579. -   Real    beta, pb_mant, det_mant, det_mant1, det_mant2;
  5580. -   int    i, pb_expt, det_expt, det_expt1, det_expt2;
  5581. -   
  5582. -   if ( ! ip )
  5583. -     error(E_NULL,"iter_lanczos2");
  5584. -   if ( ! ip->Ax || ! ip->x )
  5585. -     error(E_NULL,"iter_lanczos2");
  5586. -   if ( ip->k <= 0 )
  5587. -     error(E_RANGE,"iter_lanczos2");
  5588. -   
  5589. -   a = evals;
  5590. -   a = v_resize(a,(u_int)ip->k);
  5591. -   b = v_resize(b,(u_int)(ip->k-1));
  5592. -   MEM_STAT_REG(b,TYPE_VEC);
  5593. -   
  5594. -   iter_lanczos(ip,a,b,&beta,MNULL);
  5595. -   
  5596. -   /* printf("# beta =%g\n",beta); */
  5597. -   pb_mant = 0.0;
  5598. -   if ( err_est )
  5599. -   {
  5600. -      pb_mant = product(b,(double)0.0,&pb_expt);
  5601. -      /* printf("# pb_mant = %g, pb_expt = %d\n",pb_mant, pb_expt); */
  5602. -   }
  5603. -   
  5604. -   /* printf("# diags =\n");    v_output(a); */
  5605. -   /* printf("# off diags =\n");    v_output(b); */
  5606. -   a2 = v_resize(a2,a->dim - 1);
  5607. -   b2 = v_resize(b2,b->dim - 1);
  5608. -   MEM_STAT_REG(a2,TYPE_VEC);
  5609. -   MEM_STAT_REG(b2,TYPE_VEC);
  5610. -   for ( i = 0; i < a2->dim - 1; i++ )
  5611. -   {
  5612. -      a2->ve[i] = a->ve[i+1];
  5613. -      b2->ve[i] = b->ve[i+1];
  5614. -   }
  5615. -   a2->ve[a2->dim-1] = a->ve[a2->dim];
  5616. -   
  5617. -   trieig(a,b,MNULL);
  5618. -   
  5619. -   /* sort evals as a courtesy */
  5620. -   qsort((void *)(a->ve),(int)(a->dim),sizeof(Real),(int (*)())dbl_cmp);
  5621. -   
  5622. -   /* error estimates */
  5623. -   if ( err_est )
  5624. -   {
  5625. -      err_est = v_resize(err_est,(u_int)ip->k);
  5626. -      
  5627. -      trieig(a2,b2,MNULL);
  5628. -      /* printf("# a =\n");    v_output(a); */
  5629. -      /* printf("# a2 =\n");    v_output(a2); */
  5630. -      
  5631. -      for ( i = 0; i < a->dim; i++ )
  5632. -      {
  5633. -     det_mant1 = product2(a,i,&det_expt1);
  5634. -     det_mant2 = product(a2,(double)a->ve[i],&det_expt2);
  5635. -     /* printf("# det_mant1=%g, det_expt1=%d\n",
  5636. -        det_mant1,det_expt1); */
  5637. -     /* printf("# det_mant2=%g, det_expt2=%d\n",
  5638. -        det_mant2,det_expt2); */
  5639. -     if ( det_mant1 == 0.0 )
  5640. -     {   /* multiple e-val of T */
  5641. -        err_est->ve[i] = 0.0;
  5642. -        continue;
  5643. -     }
  5644. -     else if ( det_mant2 == 0.0 )
  5645. -     {
  5646. -        err_est->ve[i] = HUGE;
  5647. -        continue;
  5648. -     }
  5649. -     if ( (det_expt1 + det_expt2) % 2 )
  5650. -       /* if odd... */
  5651. -       det_mant = sqrt(2.0*fabs(det_mant1*det_mant2));
  5652. -     else /* if even... */
  5653. -       det_mant = sqrt(fabs(det_mant1*det_mant2));
  5654. -     det_expt = (det_expt1+det_expt2)/2;
  5655. -     err_est->ve[i] = fabs(beta*
  5656. -                   ldexp(pb_mant/det_mant,pb_expt-det_expt));
  5657. -      }
  5658. -   }
  5659. -   
  5660. -   return a;
  5661. -}
  5662. -
  5663. -/* iter_splanczos2 -- version of iter_lanczos2() that uses sparse matrix data
  5664. -   structure */
  5665. -
  5666. -VEC    *iter_splanczos2(A,m,x0,evals,err_est)
  5667. -SPMAT    *A;
  5668. -int     m;
  5669. -VEC    *x0;        /* initial vector */
  5670. -VEC    *evals;        /* eigenvalue vector */
  5671. -VEC    *err_est;    /* error estimates of eigenvalues */
  5672. -{    
  5673. -   ITER *ip;
  5674. -   VEC *a;
  5675. -   
  5676. -   ip = iter_get(0,0);
  5677. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  5678. -   ip->A_par = (void *) A;
  5679. -   ip->x = x0;
  5680. -   ip->k = m;
  5681. -   a = iter_lanczos2(ip,evals,err_est);    
  5682. -   ip->shared_x = ip->shared_b = TRUE;
  5683. -   iter_free(ip);   /* release only ITER structure */
  5684. -   return a;
  5685. -}
  5686. -
  5687. -
  5688. -
  5689. -
  5690. -/*
  5691. -  Conjugate gradient method
  5692. -  Another variant - mainly for testing
  5693. -  */
  5694. -
  5695. -VEC  *iter_cg1(ip)
  5696. -ITER *ip;
  5697. -{
  5698. -   static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL;
  5699. -   Real    alpha;
  5700. -   double inner,nres;
  5701. -   VEC *rr;   /* rr == r or rr == z */
  5702. -   
  5703. -   if (ip == INULL)
  5704. -     error(E_NULL,"iter_cg");
  5705. -   if (!ip->Ax || !ip->b)
  5706. -     error(E_NULL,"iter_cg");
  5707. -   if ( ip->x == ip->b )
  5708. -     error(E_INSITU,"iter_cg");
  5709. -   if (!ip->stop_crit)
  5710. -     error(E_NULL,"iter_cg");
  5711. -   
  5712. -   if ( ip->eps <= 0.0 )
  5713. -     ip->eps = MACHEPS;
  5714. -   
  5715. -   r = v_resize(r,ip->b->dim);
  5716. -   p = v_resize(p,ip->b->dim);
  5717. -   q = v_resize(q,ip->b->dim);
  5718. -   
  5719. -   MEM_STAT_REG(r,TYPE_VEC);
  5720. -   MEM_STAT_REG(p,TYPE_VEC);
  5721. -   MEM_STAT_REG(q,TYPE_VEC);
  5722. -   
  5723. -   if (ip->Bx != (Fun_Ax)NULL) {
  5724. -      z = v_resize(z,ip->b->dim);
  5725. -      MEM_STAT_REG(z,TYPE_VEC);
  5726. -      rr = z;
  5727. -   }
  5728. -   else rr = r;
  5729. -   
  5730. -   if (ip->x != VNULL) {
  5731. -      if (ip->x->dim != ip->b->dim)
  5732. -    error(E_SIZES,"iter_cg");
  5733. -      ip->Ax(ip->A_par,ip->x,p);            /* p = A*x */
  5734. -      v_sub(ip->b,p,r);                 /* r = b - A*x */
  5735. -   }
  5736. -   else {  /* ip->x == 0 */
  5737. -      ip->x = v_get(ip->b->dim);
  5738. -      ip->shared_x = FALSE;
  5739. -      v_copy(ip->b,r);
  5740. -   }
  5741. -   
  5742. -   if (ip->Bx) (ip->Bx)(ip->B_par,r,p);
  5743. -   else v_copy(r,p);
  5744. -   
  5745. -   inner = in_prod(p,r);
  5746. -   nres = sqrt(fabs(inner));
  5747. -   if (ip->info) ip->info(ip,nres,r,p);
  5748. -   if ( ip->stop_crit(ip,nres,r,p) ) return ip->x;
  5749. -   
  5750. -   for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ )
  5751. -   {
  5752. -      ip->Ax(ip->A_par,p,q);
  5753. -      inner = in_prod(q,p);
  5754. -      if (inner <= 0.0) {
  5755. -     warning(WARN_RES_LESS_0,"iter_cg");
  5756. -     break;
  5757. -      }
  5758. -      alpha = in_prod(p,r)/inner;
  5759. -      v_mltadd(ip->x,p,alpha,ip->x);
  5760. -      v_mltadd(r,q,-alpha,r);
  5761. -      
  5762. -      rr = r;
  5763. -      if (ip->Bx) {
  5764. -     ip->Bx(ip->B_par,r,z);
  5765. -     rr = z;
  5766. -      }
  5767. -      
  5768. -      nres = in_prod(r,rr);
  5769. -      if (nres < 0.0) {
  5770. -     warning(WARN_RES_LESS_0,"iter_cg");
  5771. -     break;
  5772. -      }
  5773. -      nres = sqrt(fabs(nres));
  5774. -      if (ip->info) ip->info(ip,nres,r,z);
  5775. -      if ( ip->stop_crit(ip,nres,r,z) ) break;
  5776. -      
  5777. -      alpha = -in_prod(rr,q)/inner;
  5778. -      v_mltadd(rr,p,alpha,p);
  5779. -      
  5780. -   }
  5781. -   
  5782. -   return ip->x;
  5783. -}
  5784. -
  5785. //GO.SYSIN DD itersym.c
  5786. echo iternsym.c 1>&2
  5787. sed >iternsym.c <<'//GO.SYSIN DD iternsym.c' 's/^-//'
  5788. -
  5789. -/**************************************************************************
  5790. -**
  5791. -** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved.
  5792. -**
  5793. -**                 Meschach Library
  5794. -** 
  5795. -** This Meschach Library is provided "as is" without any express 
  5796. -** or implied warranty of any kind with respect to this software. 
  5797. -** In particular the authors shall not be liable for any direct, 
  5798. -** indirect, special, incidental or consequential damages arising 
  5799. -** in any way from use of the software.
  5800. -** 
  5801. -** Everyone is granted permission to copy, modify and redistribute this
  5802. -** Meschach Library, provided:
  5803. -**  1.  All copies contain this copyright notice.
  5804. -**  2.  All modified copies shall carry a notice stating who
  5805. -**      made the last modification and the date of such modification.
  5806. -**  3.  No charge is made for this software or works derived from it.  
  5807. -**      This clause shall not be construed as constraining other software
  5808. -**      distributed on the same medium as this software, nor is a
  5809. -**      distribution fee considered a charge.
  5810. -**
  5811. -***************************************************************************/
  5812. -
  5813. -
  5814. -/* iter.c 17/09/93 */
  5815. -
  5816. -/* 
  5817. -  ITERATIVE METHODS - implementation of several iterative methods;
  5818. -  see also iter0.c
  5819. -*/
  5820. -
  5821. -#include        <stdio.h>
  5822. -#include    <math.h>
  5823. -#include        "matrix.h"
  5824. -#include        "matrix2.h"
  5825. -#include    "sparse.h"
  5826. -#include        "iter.h"
  5827. -
  5828. -static char rcsid[] = "$Id: iternsym.c,v 1.2 1994/02/02 06:02:20 des Exp $";
  5829. -
  5830. -
  5831. -#ifdef ANSI_C
  5832. -VEC    *spCHsolve(SPMAT *,VEC *,VEC *);
  5833. -#else
  5834. -VEC    *spCHsolve();
  5835. -#endif
  5836. -
  5837. -
  5838. -/* 
  5839. -  iter_cgs -- uses CGS to compute a solution x to A.x=b
  5840. -*/
  5841. -
  5842. -VEC    *iter_cgs(ip,r0)
  5843. -ITER *ip;
  5844. -VEC *r0;
  5845. -{
  5846. -   static VEC  *p = VNULL, *q = VNULL, *r = VNULL, *u = VNULL;
  5847. -   static VEC  *v = VNULL, *z = VNULL;
  5848. -   VEC  *tmp;
  5849. -   Real    alpha, beta, nres, rho, old_rho, sigma, inner;
  5850. -
  5851. -   if (ip == INULL)
  5852. -     error(E_NULL,"iter_cgs");
  5853. -   if (!ip->Ax || !ip->b || !r0)
  5854. -     error(E_NULL,"iter_cgs");
  5855. -   if ( ip->x == ip->b )
  5856. -     error(E_INSITU,"iter_cgs");
  5857. -   if (!ip->stop_crit)
  5858. -     error(E_NULL,"iter_cgs");
  5859. -   if ( r0->dim != ip->b->dim )
  5860. -     error(E_SIZES,"iter_cgs");
  5861. -   
  5862. -   if ( ip->eps <= 0.0 )
  5863. -     ip->eps = MACHEPS;
  5864. -   
  5865. -   p = v_resize(p,ip->b->dim);
  5866. -   q = v_resize(q,ip->b->dim);
  5867. -   r = v_resize(r,ip->b->dim);
  5868. -   u = v_resize(u,ip->b->dim);
  5869. -   v = v_resize(v,ip->b->dim);
  5870. -
  5871. -   MEM_STAT_REG(p,TYPE_VEC);
  5872. -   MEM_STAT_REG(q,TYPE_VEC);
  5873. -   MEM_STAT_REG(r,TYPE_VEC);
  5874. -   MEM_STAT_REG(u,TYPE_VEC);
  5875. -   MEM_STAT_REG(v,TYPE_VEC);
  5876. -
  5877. -   if (ip->Bx) {
  5878. -      z = v_resize(z,ip->b->dim);
  5879. -      MEM_STAT_REG(z,TYPE_VEC); 
  5880. -   }
  5881. -
  5882. -   if (ip->x != VNULL) {
  5883. -      if (ip->x->dim != ip->b->dim)
  5884. -    error(E_SIZES,"iter_cgs");
  5885. -      ip->Ax(ip->A_par,ip->x,v);            /* v = A*x */
  5886. -      if (ip->Bx) {
  5887. -     v_sub(ip->b,v,v);            /* v = b - A*x */
  5888. -     (ip->Bx)(ip->B_par,v,r);        /* r = B*(b-A*x) */
  5889. -      }
  5890. -      else v_sub(ip->b,v,r);            /* r = b-A*x */
  5891. -   }
  5892. -   else {  /* ip->x == 0 */
  5893. -      ip->x = v_get(ip->b->dim);        /* x == 0 */
  5894. -      ip->shared_x = FALSE;
  5895. -      if (ip->Bx) (ip->Bx)(ip->B_par,ip->b,r);    /* r = B*b */
  5896. -      else v_copy(ip->b,r);                       /* r = b */
  5897. -   }
  5898. -
  5899. -   v_zero(p);    
  5900. -   v_zero(q);
  5901. -   old_rho = 1.0;
  5902. -   
  5903. -   for (ip->steps = 0; ip->steps <= ip->limit; ip->steps++) {
  5904. -
  5905. -      inner = in_prod(r,r);
  5906. -      nres = sqrt(fabs(inner));
  5907. -
  5908. -      if (ip->info) ip->info(ip,nres,r,VNULL);
  5909. -      if ( ip->stop_crit(ip,nres,r,VNULL) ) break;
  5910. -
  5911. -      rho = in_prod(r0,r);
  5912. -      if ( old_rho == 0.0 )
  5913. -    error(E_SING,"iter_cgs");
  5914. -      beta = rho/old_rho;
  5915. -      v_mltadd(r,q,beta,u);
  5916. -      v_mltadd(q,p,beta,v);
  5917. -      v_mltadd(u,v,beta,p);
  5918. -      
  5919. -      (ip->Ax)(ip->A_par,p,q);
  5920. -      if (ip->Bx) {
  5921. -     (ip->Bx)(ip->B_par,q,z);
  5922. -     tmp = z;
  5923. -      }
  5924. -      else tmp = q;
  5925. -      
  5926. -      sigma = in_prod(r0,tmp);
  5927. -      if ( sigma == 0.0 )
  5928. -    error(E_SING,"iter_cgs");
  5929. -      alpha = rho/sigma;
  5930. -      v_mltadd(u,tmp,-alpha,q);
  5931. -      v_add(u,q,v);
  5932. -      
  5933. -      (ip->Ax)(ip->A_par,v,u);
  5934. -      if (ip->Bx) {
  5935. -     (ip->Bx)(ip->B_par,u,z);
  5936. -     tmp = z;
  5937. -      }
  5938. -      else tmp = u;
  5939. -      
  5940. -      v_mltadd(r,tmp,-alpha,r);
  5941. -      v_mltadd(ip->x,v,alpha,ip->x);
  5942. -      
  5943. -      old_rho = rho;
  5944. -   }
  5945. -
  5946. -   return ip->x;
  5947. -}
  5948. -
  5949. -
  5950. -
  5951. -/* iter_spcgs -- simple interface for SPMAT data structures 
  5952. -   use always as follows:
  5953. -      x = iter_spcgs(A,B,b,r0,tol,x,limit,steps);
  5954. -   or 
  5955. -      x = iter_spcgs(A,B,b,r0,tol,VNULL,limit,steps);
  5956. -   In the second case the solution vector is created.  
  5957. -   If B is not NULL then it is a preconditioner. 
  5958. -*/
  5959. -VEC    *iter_spcgs(A,B,b,r0,tol,x,limit,steps)
  5960. -SPMAT    *A, *B;
  5961. -VEC    *b, *r0, *x;
  5962. -double    tol;
  5963. -int     *steps,limit;
  5964. -{    
  5965. -   ITER *ip;
  5966. -   
  5967. -   ip = iter_get(0,0);
  5968. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  5969. -   ip->A_par = (void *) A;
  5970. -   if (B) {
  5971. -      ip->Bx = (Fun_Ax) sp_mv_mlt;
  5972. -      ip->B_par = (void *) B;
  5973. -   }
  5974. -   else {
  5975. -      ip->Bx = (Fun_Ax) NULL;
  5976. -      ip->B_par = NULL;
  5977. -   }
  5978. -   ip->info = (Fun_info) NULL;
  5979. -   ip->limit = limit;
  5980. -   ip->b = b;
  5981. -   ip->eps = tol;
  5982. -   ip->x = x;
  5983. -   iter_cgs(ip,r0);
  5984. -   x = ip->x;
  5985. -   if (steps) *steps = ip->steps;
  5986. -   ip->shared_x = ip->shared_b = TRUE;   
  5987. -   iter_free(ip);   /* release only ITER structure */
  5988. -   return x;        
  5989. -
  5990. -}
  5991. -
  5992. -/*
  5993. -  Routine for performing LSQR -- the least squares QR algorithm
  5994. -  of Paige and Saunders:
  5995. -  "LSQR: an algorithm for sparse linear equations and
  5996. -  sparse least squares", ACM Trans. Math. Soft., v. 8
  5997. -  pp. 43--71 (1982)
  5998. -  */
  5999. -/* lsqr -- sparse CG-like least squares routine:
  6000. -   -- finds min_x ||A.x-b||_2 using A defined through A & AT
  6001. -   -- returns x (if x != NULL) */
  6002. -VEC    *iter_lsqr(ip)
  6003. -ITER *ip;
  6004. -{
  6005. -   static VEC    *u = VNULL, *v = VNULL, *w = VNULL, *tmp = VNULL;
  6006. -   Real    alpha, beta, phi, phi_bar;
  6007. -   Real rho, rho_bar, rho_max, theta, nres;
  6008. -   Real    s, c;    /* for Givens' rotations */
  6009. -   int  m, n;
  6010. -   
  6011. -   if ( ! ip || ! ip->b || !ip->Ax || !ip->ATx )
  6012. -     error(E_NULL,"iter_lsqr");
  6013. -   if ( ip->x == ip->b )
  6014. -     error(E_INSITU,"iter_lsqr");
  6015. -   if (!ip->stop_crit || !ip->x)
  6016. -     error(E_NULL,"iter_lsqr");
  6017. -
  6018. -   if ( ip->eps <= 0.0 )
  6019. -     ip->eps = MACHEPS;
  6020. -   
  6021. -   m = ip->b->dim;    
  6022. -   n = ip->x->dim;
  6023. -
  6024. -   u = v_resize(u,(u_int)m);
  6025. -   v = v_resize(v,(u_int)n);
  6026. -   w = v_resize(w,(u_int)n);
  6027. -   tmp = v_resize(tmp,(u_int)n);
  6028. -
  6029. -   MEM_STAT_REG(u,TYPE_VEC);
  6030. -   MEM_STAT_REG(v,TYPE_VEC);
  6031. -   MEM_STAT_REG(w,TYPE_VEC);
  6032. -   MEM_STAT_REG(tmp,TYPE_VEC);  
  6033. -
  6034. -   if (ip->x != VNULL) {
  6035. -      ip->Ax(ip->A_par,ip->x,u);            /* u = A*x */
  6036. -      v_sub(ip->b,u,u);                /* u = b-A*x */
  6037. -   }
  6038. -   else {  /* ip->x == 0 */
  6039. -      ip->x = v_get(ip->b->dim);
  6040. -      ip->shared_x = FALSE;
  6041. -      v_copy(ip->b,u);                       /* u = b */
  6042. -   }
  6043. - 
  6044. -   beta = v_norm2(u); 
  6045. -   if ( beta == 0.0 )
  6046. -     return ip->x;
  6047. -   sv_mlt(1.0/beta,u,u);
  6048. -   (ip->ATx)(ip->AT_par,u,v);
  6049. -   alpha = v_norm2(v);
  6050. -   if ( alpha == 0.0 )
  6051. -     return ip->x;
  6052. -   sv_mlt(1.0/alpha,v,v);
  6053. -   v_copy(v,w);
  6054. -   phi_bar = beta;
  6055. -   rho_bar = alpha;
  6056. -   
  6057. -   rho_max = 1.0;
  6058. -   for (ip->steps = 0; ip->steps <= ip->limit; ip->steps++) {
  6059. -
  6060. -      tmp = v_resize(tmp,m);
  6061. -      (ip->Ax)(ip->A_par,v,tmp);
  6062. -      
  6063. -      v_mltadd(tmp,u,-alpha,u);
  6064. -      beta = v_norm2(u);    
  6065. -      sv_mlt(1.0/beta,u,u);
  6066. -      
  6067. -      tmp = v_resize(tmp,n);
  6068. -      (ip->ATx)(ip->AT_par,u,tmp);
  6069. -      v_mltadd(tmp,v,-beta,v);
  6070. -      alpha = v_norm2(v);    
  6071. -      sv_mlt(1.0/alpha,v,v);
  6072. -      
  6073. -      rho = sqrt(rho_bar*rho_bar+beta*beta);
  6074. -      if ( rho > rho_max )
  6075. -    rho_max = rho;
  6076. -      c   = rho_bar/rho;
  6077. -      s   = beta/rho;
  6078. -      theta   =  s*alpha;
  6079. -      rho_bar = -c*alpha;
  6080. -      phi     =  c*phi_bar;
  6081. -      phi_bar =  s*phi_bar;
  6082. -      
  6083. -      /* update ip->x & w */
  6084. -      if ( rho == 0.0 )
  6085. -    error(E_SING,"iter_lsqr");
  6086. -      v_mltadd(ip->x,w,phi/rho,ip->x);
  6087. -      v_mltadd(v,w,-theta/rho,w);
  6088. -
  6089. -      nres = fabs(phi_bar*alpha*c)*rho_max;
  6090. -
  6091. -      if (ip->info) ip->info(ip,nres,w,VNULL);
  6092. -      if ( ip->stop_crit(ip,nres,w,VNULL) ) break;
  6093. -   } 
  6094. -   
  6095. -   return ip->x;
  6096. -}
  6097. -
  6098. -/* iter_splsqr -- simple interface for SPMAT data structures */
  6099. -VEC    *iter_splsqr(A,b,tol,x,limit,steps)
  6100. -SPMAT    *A;
  6101. -VEC    *b, *x;
  6102. -double    tol;
  6103. -int *steps,limit;
  6104. -{
  6105. -   ITER *ip;
  6106. -   
  6107. -   ip = iter_get(0,0);
  6108. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  6109. -   ip->A_par = (void *) A;
  6110. -   ip->ATx = (Fun_Ax) sp_vm_mlt;
  6111. -   ip->AT_par = (void *) A;
  6112. -   ip->Bx = (Fun_Ax) NULL;
  6113. -   ip->B_par = NULL;
  6114. -
  6115. -   ip->info = (Fun_info) NULL;
  6116. -   ip->limit = limit;
  6117. -   ip->b = b;
  6118. -   ip->eps = tol;
  6119. -   ip->x = x;
  6120. -   iter_lsqr(ip);
  6121. -   x = ip->x;
  6122. -   if (steps) *steps = ip->steps;
  6123. -   ip->shared_x = ip->shared_b = TRUE;
  6124. -   iter_free(ip);   /* release only ITER structure */
  6125. -   return x;        
  6126. -}
  6127. -
  6128. -
  6129. -
  6130. -/* iter_arnoldi -- an implementation of the Arnoldi method;
  6131. -   iterative refinement is applied.
  6132. -*/
  6133. -MAT    *iter_arnoldi_iref(ip,h_rem,Q,H)
  6134. -ITER  *ip;
  6135. -Real  *h_rem;
  6136. -MAT   *Q, *H;
  6137. -{
  6138. -   static VEC *u=VNULL, *r=VNULL, *s=VNULL, *tmp=VNULL;
  6139. -   VEC v;     /* auxiliary vector */
  6140. -   int    i,j;
  6141. -   Real    h_val, c;
  6142. -   
  6143. -   if (ip == INULL)
  6144. -     error(E_NULL,"iter_arnoldi_iref");
  6145. -   if ( ! ip->Ax || ! Q || ! ip->x )
  6146. -     error(E_NULL,"iter_arnoldi_iref");
  6147. -   if ( ip->k <= 0 )
  6148. -     error(E_BOUNDS,"iter_arnoldi_iref");
  6149. -   if ( Q->n != ip->x->dim ||    Q->m != ip->k )
  6150. -     error(E_SIZES,"iter_arnoldi_iref");
  6151. -   
  6152. -   m_zero(Q);
  6153. -   H = m_resize(H,ip->k,ip->k);
  6154. -   m_zero(H);
  6155. -
  6156. -   u = v_resize(u,ip->x->dim);
  6157. -   tmp = v_resize(tmp,ip->x->dim);
  6158. -   r = v_resize(r,ip->k);
  6159. -   s = v_resize(s,ip->k);
  6160. -   MEM_STAT_REG(u,TYPE_VEC);
  6161. -   MEM_STAT_REG(tmp,TYPE_VEC);
  6162. -   MEM_STAT_REG(r,TYPE_VEC);
  6163. -   MEM_STAT_REG(s,TYPE_VEC);
  6164. -
  6165. -   v.dim = v.max_dim = ip->x->dim;
  6166. -
  6167. -   c = v_norm2(ip->x);
  6168. -   if ( c <= 0.0)
  6169. -     return H;
  6170. -   else {
  6171. -      v.ve = Q->me[0];
  6172. -      sv_mlt(1.0/c,ip->x,&v);
  6173. -   }
  6174. -
  6175. -   v_zero(r);
  6176. -   v_zero(s);
  6177. -   for ( i = 0; i < ip->k; i++ )
  6178. -   {
  6179. -      v.ve = Q->me[i];
  6180. -      u = (ip->Ax)(ip->A_par,&v,u);
  6181. -      v_zero(tmp);
  6182. -      for (j = 0; j <= i; j++) {
  6183. -     v.ve = Q->me[j];
  6184. -     r->ve[j] = in_prod(&v,u);
  6185. -     v_mltadd(tmp,&v,r->ve[j],tmp);
  6186. -      }
  6187. -      v_sub(u,tmp,u);
  6188. -      h_val = v_norm2(u);
  6189. -      /* if u == 0 then we have an exact subspace */
  6190. -      if ( h_val <= 0.0 )
  6191. -      {
  6192. -     *h_rem = h_val;
  6193. -     return H;
  6194. -      }
  6195. -      /* iterative refinement -- ensures near orthogonality */
  6196. -      do {
  6197. -     v_zero(tmp);
  6198. -     for (j = 0; j <= i; j++) {
  6199. -        v.ve = Q->me[j];
  6200. -        s->ve[j] = in_prod(&v,u);
  6201. -        v_mltadd(tmp,&v,s->ve[j],tmp);
  6202. -     }
  6203. -     v_sub(u,tmp,u);
  6204. -     v_add(r,s,r);
  6205. -      } while ( v_norm2(s) > 0.1*(h_val = v_norm2(u)) );
  6206. -      /* now that u is nearly orthogonal to Q, update H */
  6207. -      set_col(H,i,r);
  6208. -      /* check once again if h_val is zero */
  6209. -      if ( h_val <= 0.0 )
  6210. -      {
  6211. -     *h_rem = h_val;
  6212. -     return H;
  6213. -      }
  6214. -      if ( i == ip->k-1 )
  6215. -      {
  6216. -     *h_rem = h_val;
  6217. -     continue;
  6218. -      }
  6219. -      /* H->me[i+1][i] = h_val; */
  6220. -      m_set_val(H,i+1,i,h_val);
  6221. -      v.ve = Q->me[i+1];
  6222. -      sv_mlt(1.0/h_val,u,&v);
  6223. -   }
  6224. -   
  6225. -   return H;
  6226. -}
  6227. -
  6228. -/* iter_arnoldi -- an implementation of the Arnoldi method;
  6229. -   without iterative refinement
  6230. -*/
  6231. -MAT    *iter_arnoldi(ip,h_rem,Q,H)
  6232. -ITER  *ip;
  6233. -Real  *h_rem;
  6234. -MAT   *Q, *H;
  6235. -{
  6236. -   static VEC *u=VNULL, *r=VNULL, *tmp=VNULL;
  6237. -   VEC v;     /* auxiliary vector */
  6238. -   int    i,j;
  6239. -   Real    h_val, c;
  6240. -   
  6241. -   if (ip == INULL)
  6242. -     error(E_NULL,"iter_arnoldi");
  6243. -   if ( ! ip->Ax || ! Q || ! ip->x )
  6244. -     error(E_NULL,"iter_arnoldi");
  6245. -   if ( ip->k <= 0 )
  6246. -     error(E_BOUNDS,"iter_arnoldi");
  6247. -   if ( Q->n != ip->x->dim ||    Q->m != ip->k )
  6248. -     error(E_SIZES,"iter_arnoldi");
  6249. -   
  6250. -   m_zero(Q);
  6251. -   H = m_resize(H,ip->k,ip->k);
  6252. -   m_zero(H);
  6253. -
  6254. -   u = v_resize(u,ip->x->dim);
  6255. -   tmp = v_resize(tmp,ip->x->dim);
  6256. -   r = v_resize(r,ip->k);
  6257. -   MEM_STAT_REG(u,TYPE_VEC);
  6258. -   MEM_STAT_REG(tmp,TYPE_VEC);
  6259. -   MEM_STAT_REG(r,TYPE_VEC);
  6260. -
  6261. -   v.dim = v.max_dim = ip->x->dim;
  6262. -
  6263. -   c = v_norm2(ip->x);
  6264. -   if ( c <= 0.0)
  6265. -     return H;
  6266. -   else {
  6267. -      v.ve = Q->me[0];
  6268. -      sv_mlt(1.0/c,ip->x,&v);
  6269. -   }
  6270. -
  6271. -   v_zero(r);
  6272. -   for ( i = 0; i < ip->k; i++ )
  6273. -   {
  6274. -      v.ve = Q->me[i];
  6275. -      u = (ip->Ax)(ip->A_par,&v,u);
  6276. -      v_zero(tmp);
  6277. -      for (j = 0; j <= i; j++) {
  6278. -     v.ve = Q->me[j];
  6279. -     r->ve[j] = in_prod(&v,u);
  6280. -     v_mltadd(tmp,&v,r->ve[j],tmp);
  6281. -      }
  6282. -      v_sub(u,tmp,u);
  6283. -      h_val = v_norm2(u);
  6284. -      /* if u == 0 then we have an exact subspace */
  6285. -      if ( h_val <= 0.0 )
  6286. -      {
  6287. -     *h_rem = h_val;
  6288. -     return H;
  6289. -      }
  6290. -      set_col(H,i,r);
  6291. -      if ( i == ip->k-1 )
  6292. -      {
  6293. -     *h_rem = h_val;
  6294. -     continue;
  6295. -      }
  6296. -      /* H->me[i+1][i] = h_val; */
  6297. -      m_set_val(H,i+1,i,h_val);
  6298. -      v.ve = Q->me[i+1];
  6299. -      sv_mlt(1.0/h_val,u,&v);
  6300. -   }
  6301. -   
  6302. -   return H;
  6303. -}
  6304. -
  6305. -
  6306. -
  6307. -/* iter_sparnoldi -- uses arnoldi() with an explicit representation of A */
  6308. -MAT    *iter_sparnoldi(A,x0,m,h_rem,Q,H)
  6309. -SPMAT    *A;
  6310. -VEC    *x0;
  6311. -int    m;
  6312. -Real    *h_rem;
  6313. -MAT    *Q, *H;
  6314. -{
  6315. -   ITER *ip;
  6316. -   
  6317. -   ip = iter_get(0,0);
  6318. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  6319. -   ip->A_par = (void *) A;
  6320. -   ip->x = x0;
  6321. -   ip->k = m;
  6322. -   iter_arnoldi_iref(ip,h_rem,Q,H);
  6323. -   ip->shared_x = ip->shared_b = TRUE;
  6324. -   iter_free(ip);   /* release only ITER structure */
  6325. -   return H;    
  6326. -}
  6327. -
  6328. -
  6329. -/* for testing gmres */
  6330. -static void test_gmres(ip,i,Q,R,givc,givs,h_val)
  6331. -ITER *ip;
  6332. -int i;
  6333. -MAT *Q, *R;
  6334. -VEC *givc, *givs;
  6335. -double h_val;
  6336. -{
  6337. -   VEC vt, vt1;
  6338. -   static MAT *Q1, *R1;
  6339. -   int j;
  6340. -   
  6341. -   /* test Q*A*Q^T = R  */
  6342. -
  6343. -   Q = m_resize(Q,i+1,ip->b->dim);
  6344. -   Q1 = m_resize(Q1,i+1,ip->b->dim);
  6345. -   R1 = m_resize(R1,i+1,i+1);
  6346. -   MEM_STAT_REG(Q1,TYPE_MAT);
  6347. -   MEM_STAT_REG(R1,TYPE_MAT);
  6348. -
  6349. -   vt.dim = vt.max_dim = ip->b->dim;
  6350. -   vt1.dim = vt1.max_dim = ip->b->dim;
  6351. -   for (j=0; j <= i; j++) {
  6352. -      vt.ve = Q->me[j];
  6353. -      vt1.ve = Q1->me[j];
  6354. -      ip->Ax(ip->A_par,&vt,&vt1);
  6355. -   }
  6356. -
  6357. -   mmtr_mlt(Q,Q1,R1);
  6358. -   R1 = m_resize(R1,i+2,i+1);
  6359. -   for (j=0; j < i; j++)
  6360. -     R1->me[i+1][j] = 0.0;
  6361. -   R1->me[i+1][i] = h_val;
  6362. -   
  6363. -   for (j = 0; j <= i; j++) {
  6364. -      rot_rows(R1,j,j+1,givc->ve[j],givs->ve[j],R1);
  6365. -   }
  6366. -
  6367. -   R1 = m_resize(R1,i+1,i+1);
  6368. -   m_sub(R,R1,R1);
  6369. -   /* if (m_norm_inf(R1) > MACHEPS*ip->b->dim)  */
  6370. -   printf(" %d. ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n",
  6371. -      ip->steps,m_norm_inf(R1),MACHEPS);
  6372. -   
  6373. -   /* check Q*Q^T = I */
  6374. -   
  6375. -   Q = m_resize(Q,i+1,ip->b->dim);
  6376. -   mmtr_mlt(Q,Q,R1);
  6377. -   for (j=0; j <= i; j++)
  6378. -     R1->me[j][j] -= 1.0;
  6379. -   if (m_norm_inf(R1) > MACHEPS*ip->b->dim)
  6380. -     printf(" ! m_norm_inf(Q*Q^T) = %g\n",m_norm_inf(R1));  
  6381. -   
  6382. -}
  6383. -
  6384. -
  6385. -/* gmres -- generalised minimum residual algorithm of Saad & Schultz
  6386. -   SIAM J. Sci. Stat. Comp. v.7, pp.856--869 (1986)
  6387. -*/
  6388. -VEC    *iter_gmres(ip)
  6389. -ITER *ip;
  6390. -{
  6391. -   static VEC *u=VNULL, *r=VNULL, *rhs = VNULL;
  6392. -   static VEC *givs=VNULL, *givc=VNULL, *z = VNULL;
  6393. -   static MAT *Q = MNULL, *R = MNULL;
  6394. -   VEC *rr, v, v1;   /* additional pointers (not real vectors) */
  6395. -   int    i,j, done;
  6396. -   Real    nres;
  6397. -/*   Real last_h;  */
  6398. -   
  6399. -   if (ip == INULL)
  6400. -     error(E_NULL,"iter_gmres");
  6401. -   if ( ! ip->Ax || ! ip->b )
  6402. -     error(E_NULL,"iter_gmres");
  6403. -   if ( ! ip->stop_crit )
  6404. -     error(E_NULL,"iter_gmres");
  6405. -   if ( ip->k <= 0 )
  6406. -     error(E_BOUNDS,"iter_gmres");
  6407. -   if (ip->x != VNULL && ip->x->dim != ip->b->dim)
  6408. -     error(E_SIZES,"iter_gmres");
  6409. -
  6410. -   r = v_resize(r,ip->k+1);
  6411. -   u = v_resize(u,ip->b->dim);
  6412. -   rhs = v_resize(rhs,ip->k+1);
  6413. -   givs = v_resize(givs,ip->k);  /* Givens rotations */
  6414. -   givc = v_resize(givc,ip->k); 
  6415. -   
  6416. -   MEM_STAT_REG(r,TYPE_VEC);
  6417. -   MEM_STAT_REG(u,TYPE_VEC);
  6418. -   MEM_STAT_REG(rhs,TYPE_VEC);
  6419. -   MEM_STAT_REG(givs,TYPE_VEC);
  6420. -   MEM_STAT_REG(givc,TYPE_VEC);
  6421. -   
  6422. -   R = m_resize(R,ip->k+1,ip->k);
  6423. -   Q = m_resize(Q,ip->k,ip->b->dim);
  6424. -   MEM_STAT_REG(R,TYPE_MAT);
  6425. -   MEM_STAT_REG(Q,TYPE_MAT);        
  6426. -
  6427. -   if (ip->x == VNULL) {  /* ip->x == 0 */
  6428. -      ip->x = v_get(ip->b->dim);
  6429. -      ip->shared_x = FALSE;
  6430. -   }   
  6431. -
  6432. -   v.dim = v.max_dim = ip->b->dim;      /* v and v1 are pointers to rows */
  6433. -   v1.dim = v1.max_dim = ip->b->dim;      /* of matrix Q */
  6434. -   
  6435. -   if (ip->Bx != (Fun_Ax)NULL) {    /* if precondition is defined */
  6436. -      z = v_resize(z,ip->b->dim);
  6437. -      MEM_STAT_REG(z,TYPE_VEC);
  6438. -   }
  6439. -   
  6440. -   done = FALSE;
  6441. -   for (ip->steps = 0; ip->steps <= ip->limit; ) {
  6442. -
  6443. -      /* restart */
  6444. -
  6445. -      ip->Ax(ip->A_par,ip->x,u);            /* u = A*x */
  6446. -      v_sub(ip->b,u,u);                 /* u = b - A*x */
  6447. -      rr = u;                /* rr is a pointer only */
  6448. -      
  6449. -      if (ip->Bx) {
  6450. -     (ip->Bx)(ip->B_par,u,z);            /* tmp = B*(b-A*x)  */
  6451. -     rr = z;
  6452. -      }
  6453. -      
  6454. -      nres = v_norm2(rr);
  6455. -      if (ip->steps == 0) {
  6456. -     if (ip->info) ip->info(ip,nres,VNULL,VNULL);
  6457. -     if ( ip->stop_crit(ip,nres,VNULL,VNULL) ) {
  6458. -        done = TRUE;
  6459. -        break;
  6460. -     }
  6461. -      }
  6462. -      else if (nres <= 0.0) break;
  6463. -
  6464. -      v.ve = Q->me[0];
  6465. -      sv_mlt(1.0/nres,rr,&v);
  6466. -      
  6467. -      v_zero(r);
  6468. -      v_zero(rhs);
  6469. -      rhs->ve[0] = nres;
  6470. -
  6471. -      for ( i = 0; i < ip->k; i++ ) {
  6472. -     ip->steps++;
  6473. -     v.ve = Q->me[i];    
  6474. -     (ip->Ax)(ip->A_par,&v,u);
  6475. -     rr = u;
  6476. -     if (ip->Bx) {
  6477. -        (ip->Bx)(ip->B_par,u,z);
  6478. -        rr = z;
  6479. -     }
  6480. -     
  6481. -     if (i < ip->k - 1) {
  6482. -        v1.ve = Q->me[i+1];
  6483. -        v_copy(rr,&v1);
  6484. -        for (j = 0; j <= i; j++) {
  6485. -           v.ve = Q->me[j];
  6486. -           r->ve[j] = in_prod(&v,rr);
  6487. -           v_mltadd(&v1,&v,-r->ve[j],&v1);
  6488. -        }
  6489. -        
  6490. -        r->ve[i+1] = nres = v_norm2(&v1);
  6491. -        if (nres <= 0.0) {
  6492. -           warning(WARN_RES_LESS_0,"iter_gmres");
  6493. -           break;
  6494. -        }
  6495. -        sv_mlt(1.0/nres,&v1,&v1);
  6496. -     }
  6497. -     else {  /* i == ip->k - 1 */
  6498. -        /* Q->me[ip->k] need not be computed */
  6499. -
  6500. -        for (j = 0; j <= i; j++) {
  6501. -           v.ve = Q->me[j];
  6502. -           r->ve[j] = in_prod(&v,rr);
  6503. -        }
  6504. -        
  6505. -        nres = in_prod(rr,rr) - in_prod(r,r);
  6506. -        if (nres <= 0.0) {
  6507. -           warning(WARN_RES_LESS_0,"iter_gmres");
  6508. -           break;
  6509. -        }
  6510. -        r->ve[i+1] = sqrt(nres);
  6511. -     }
  6512. -
  6513. -     /* QR update */
  6514. -
  6515. -     /* last_h = r->ve[i+1]; */ /* for test only */
  6516. -     for (j = 0; j < i; j++) 
  6517. -       rot_vec(r,j,j+1,givc->ve[j],givs->ve[j],r);
  6518. -     givens(r->ve[i],r->ve[i+1],&givc->ve[i],&givs->ve[i]);
  6519. -     rot_vec(r,i,i+1,givc->ve[i],givs->ve[i],r);
  6520. -     rot_vec(rhs,i,i+1,givc->ve[i],givs->ve[i],rhs);
  6521. -     
  6522. -     set_col(R,i,r);
  6523. -
  6524. -     nres = fabs((double) rhs->ve[i+1]);
  6525. -     if (ip->info) ip->info(ip,nres,VNULL,VNULL);
  6526. -     if ( ip->stop_crit(ip,nres,VNULL,VNULL) ||
  6527. -         ip->steps >= ip->limit ) {
  6528. -        done = TRUE;
  6529. -        break;
  6530. -     }
  6531. -      }
  6532. -      
  6533. -      /* use ixi submatrix of R */
  6534. -
  6535. -      if (nres <= 0.0) {
  6536. -     i--;
  6537. -     done = TRUE;
  6538. -      }
  6539. -      if (i == ip->k) i = ip->k - 1;
  6540. -
  6541. -      R = m_resize(R,i+1,i+1);
  6542. -      rhs = v_resize(rhs,i+1);
  6543. -      
  6544. -      /* test only */
  6545. -      /* test_gmres(ip,i,Q,R,givc,givs,last_h);  */
  6546. -      
  6547. -      Usolve(R,rhs,rhs,0.0);      /* solve a system: R*x = rhs */
  6548. -
  6549. -      /* new approximation */
  6550. -
  6551. -      for (j = 0; j <= i; j++) {
  6552. -     v.ve = Q->me[j]; 
  6553. -     v_mltadd(ip->x,&v,rhs->ve[j],ip->x);
  6554. -      }
  6555. -
  6556. -      if (done) break;
  6557. -
  6558. -      /* back to old dimensions */
  6559. -
  6560. -      rhs = v_resize(rhs,ip->k+1);
  6561. -      R = m_resize(R,ip->k+1,ip->k);
  6562. -
  6563. -   }
  6564. -
  6565. -   return ip->x;
  6566. -}
  6567. -
  6568. -/* iter_spgmres - a simple interface to iter_gmres */
  6569. -
  6570. -VEC    *iter_spgmres(A,B,b,tol,x,k,limit,steps)
  6571. -SPMAT    *A, *B;
  6572. -VEC    *b, *x;
  6573. -double    tol;
  6574. -int *steps,k,limit;
  6575. -{
  6576. -   ITER *ip;
  6577. -   
  6578. -   ip = iter_get(0,0);
  6579. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  6580. -   ip->A_par = (void *) A;
  6581. -   if (B) {
  6582. -      ip->Bx = (Fun_Ax) sp_mv_mlt;
  6583. -      ip->B_par = (void *) B;
  6584. -   }
  6585. -   else {
  6586. -      ip->Bx = (Fun_Ax) NULL;
  6587. -      ip->B_par = NULL;
  6588. -   }
  6589. -   ip->k = k;
  6590. -   ip->limit = limit;
  6591. -   ip->info = (Fun_info) NULL;
  6592. -   ip->b = b;
  6593. -   ip->eps = tol;
  6594. -   ip->x = x;
  6595. -   iter_gmres(ip);
  6596. -   x = ip->x;
  6597. -   if (steps) *steps = ip->steps;
  6598. -   ip->shared_x = ip->shared_b = TRUE;
  6599. -   iter_free(ip);   /* release only ITER structure */
  6600. -   return x;        
  6601. -}
  6602. -
  6603. -
  6604. -/* for testing mgcr */
  6605. -static void test_mgcr(ip,i,Q,R)
  6606. -ITER *ip;
  6607. -int i;
  6608. -MAT *Q, *R;
  6609. -{
  6610. -   VEC vt, vt1;
  6611. -   static MAT *R1;
  6612. -   static VEC *r, *r1;
  6613. -   VEC *rr;
  6614. -   int k,j;
  6615. -   Real sm;
  6616. -   
  6617. -   
  6618. -   /* check Q*Q^T = I */
  6619. -   vt.dim = vt.max_dim = ip->b->dim;
  6620. -   vt1.dim = vt1.max_dim = ip->b->dim;
  6621. -   
  6622. -   Q = m_resize(Q,i+1,ip->b->dim);
  6623. -   R1 = m_resize(R1,i+1,i+1);
  6624. -   r = v_resize(r,ip->b->dim);
  6625. -   r1 = v_resize(r1,ip->b->dim);
  6626. -   MEM_STAT_REG(R1,TYPE_MAT);
  6627. -   MEM_STAT_REG(r,TYPE_VEC);
  6628. -   MEM_STAT_REG(r1,TYPE_VEC);
  6629. -
  6630. -   m_zero(R1);
  6631. -   for (k=1; k <= i; k++)
  6632. -     for (j=1; j <= i; j++) {
  6633. -    vt.ve = Q->me[k];
  6634. -    vt1.ve = Q->me[j];
  6635. -    R1->me[k][j] = in_prod(&vt,&vt1);
  6636. -     }
  6637. -   for (j=1; j <= i; j++)
  6638. -     R1->me[j][j] -= 1.0;
  6639. -   if (m_norm_inf(R1) > MACHEPS*ip->b->dim)
  6640. -     printf(" ! (mgcr:) m_norm_inf(Q*Q^T) = %g\n",m_norm_inf(R1));  
  6641. -
  6642. -   /* check (r_i,Ap_j) = 0 for j <= i */
  6643. -   
  6644. -   ip->Ax(ip->A_par,ip->x,r);
  6645. -   v_sub(ip->b,r,r);
  6646. -   rr = r;
  6647. -   if (ip->Bx) {
  6648. -      ip->Bx(ip->B_par,r,r1);
  6649. -      rr = r1;
  6650. -   }
  6651. -   
  6652. -   printf(" ||r|| = %g\n",v_norm2(rr));
  6653. -   sm = 0.0;
  6654. -   for (j = 1; j <= i; j++) {
  6655. -      vt.ve = Q->me[j];
  6656. -      sm = max(sm,in_prod(&vt,rr));
  6657. -   }
  6658. -   if (sm >= MACHEPS*ip->b->dim)
  6659. -     printf(" ! (mgcr:) max_j (r,Ap_j) = %g\n",sm);
  6660. -
  6661. -}
  6662. -
  6663. -
  6664. -
  6665. -
  6666. -/* 
  6667. -  iter_mgcr -- modified generalized conjugate residual algorithm;
  6668. -  fast version of GCR;
  6669. -*/
  6670. -VEC *iter_mgcr(ip)
  6671. -ITER *ip;
  6672. -{
  6673. -   static VEC *As, *beta, *alpha, *z;
  6674. -   static MAT *N, *H;
  6675. -   
  6676. -   VEC *rr, v, s;  /* additional pointer and structures */
  6677. -   Real nres;      /* norm of a residual */
  6678. -   Real dd;        /* coefficient d_i */
  6679. -   int i,j;
  6680. -   int done;      /* if TRUE then stop the iterative process */
  6681. -   int dim;       /* dimension of the problem */
  6682. -   
  6683. -   /* ip cannot be NULL */
  6684. -   if (ip == INULL) error(E_NULL,"mgcr");
  6685. -   /* Ax, b and stopping criterion must be given */
  6686. -   if (! ip->Ax || ! ip->b || ! ip->stop_crit) 
  6687. -     error(E_NULL,"mgcr");
  6688. -   /* at least one direction vector must exist */
  6689. -   if ( ip->k <= 0) error(E_BOUNDS,"mgcr");
  6690. -   /* if the vector x is given then b and x must have the same dimension */
  6691. -   if ( ip->x && ip->x->dim != ip->b->dim)
  6692. -     error(E_SIZES,"mgcr");
  6693. -   
  6694. -   dim = ip->b->dim;
  6695. -   As = v_resize(As,dim);
  6696. -   alpha = v_resize(alpha,ip->k);
  6697. -   beta = v_resize(beta,ip->k);
  6698. -   
  6699. -   MEM_STAT_REG(As,TYPE_VEC);
  6700. -   MEM_STAT_REG(alpha,TYPE_VEC);
  6701. -   MEM_STAT_REG(beta,TYPE_VEC);
  6702. -   
  6703. -   H = m_resize(H,ip->k,ip->k);
  6704. -   N = m_resize(N,ip->k,dim);
  6705. -   
  6706. -   MEM_STAT_REG(H,TYPE_MAT);
  6707. -   MEM_STAT_REG(N,TYPE_MAT);
  6708. -   
  6709. -   /* if a preconditioner is defined */
  6710. -   if (ip->Bx) {
  6711. -      z = v_resize(z,dim);
  6712. -      MEM_STAT_REG(z,TYPE_VEC);
  6713. -   }
  6714. -   
  6715. -   /* if x is NULL then it is assumed that x has 
  6716. -      entries with value zero */
  6717. -   if ( ! ip->x ) {
  6718. -      ip->x = v_get(ip->b->dim);
  6719. -      ip->shared_x = FALSE;
  6720. -   }
  6721. -   
  6722. -   /* v and s are additional pointers to rows of N */
  6723. -   /* they must have the same dimension as rows of N */
  6724. -   v.dim = v.max_dim = s.dim = s.max_dim = dim;
  6725. -   
  6726. -   
  6727. -   done = FALSE;
  6728. -   ip->steps = 0;
  6729. -   while (TRUE) {
  6730. -      (*ip->Ax)(ip->A_par,ip->x,As);         /* As = A*x */
  6731. -      v_sub(ip->b,As,As);                    /* As = b - A*x */
  6732. -      rr = As;                               /* rr is an additional pointer */
  6733. -      
  6734. -      /* if a preconditioner is defined */
  6735. -      if (ip->Bx) {
  6736. -     (*ip->Bx)(ip->B_par,As,z);               /* z = B*(b-A*x)  */
  6737. -     rr = z;                                  
  6738. -      }
  6739. -      
  6740. -      /* norm of the residual */
  6741. -      nres = v_norm2(rr);
  6742. -      dd = nres*nres;                            /* dd = ||r_i||^2  */
  6743. -      
  6744. -      /* we need to check if the norm of the residual is small enough 
  6745. -     only when we start the iterative process;
  6746. -     otherwise it has been checked yet. 
  6747. -     Also the member ip->init_res is updated indirectly by 
  6748. -     ip->stop_crit.
  6749. -     */
  6750. -      if (ip->steps == 0) {                /* information for a user */
  6751. -     if (ip->info) (*ip->info)(ip,nres,As,rr); 
  6752. -     if ( (*ip->stop_crit)(ip,nres,As,rr) ) { 
  6753. -          /* iterative process is finished */
  6754. -        done = TRUE; 
  6755. -        break;
  6756. -     }
  6757. -      }
  6758. -      else if (nres <= 0.0) 
  6759. -    break;  /* residual is zero -> finish the process */ 
  6760. -      
  6761. -      /* save this residual in the first row of N */
  6762. -      v.ve = N->me[0];
  6763. -      v_copy(rr,&v);
  6764. -      
  6765. -      for (i = 0; i < ip->k && ip->steps <= ip->limit; i++) {
  6766. -     ip->steps++;
  6767. -     v.ve = N->me[i];                /* pointer to a row of N (=s_i) */
  6768. -     /* note that we must use here &v, not v */
  6769. -     (*ip->Ax)(ip->A_par,&v,As); 
  6770. -     rr = As;                        /* As = A*s_i */
  6771. -     if (ip->Bx) {
  6772. -        (*ip->Bx)(ip->B_par,As,z);    /* z = B*A*s_i  */
  6773. -        rr = z;
  6774. -     }
  6775. -     
  6776. -     if (i < ip->k - 1) {
  6777. -        s.ve = N->me[i+1];         /* pointer to a row of N (=s_{i+1}) */
  6778. -        v_copy(rr,&s);                   /* s_{i+1} = B*A*s_i */
  6779. -        for (j = 0; j <= i-1; j++) {
  6780. -           v.ve = N->me[j+1];      /* pointer to a row of N (=s_{j+1}) */
  6781. -           beta->ve[j] = in_prod(&v,rr);    /* beta_{j,i} */
  6782. -                   /* s_{i+1} -= beta_{j,i}*s_{j+1} */
  6783. -           v_mltadd(&s,&v,- beta->ve[j],&s);    
  6784. -        }
  6785. -        
  6786. -         /* beta_{i,i} = ||s_{i+1}||_2 */
  6787. -        beta->ve[i] = nres = v_norm2(&s);     
  6788. -        if ( nres <= 0.0) break;         /* if s_{i+1} == 0 then finish */
  6789. -        sv_mlt(1.0/nres,&s,&s);           /* normalize s_{i+1} */
  6790. -        
  6791. -        v.ve = N->me[0];
  6792. -        alpha->ve[i] = in_prod(&v,&s);     /* alpha_i = (s_0 , s_{i+1}) */
  6793. -        
  6794. -     }
  6795. -     else {
  6796. -        for (j = 0; j <= i-1; j++) {
  6797. -           v.ve = N->me[j+1];      /* pointer to a row of N (=s_{j+1}) */
  6798. -           beta->ve[j] = in_prod(&v,rr);       /* beta_{j,i} */
  6799. -        }
  6800. -        
  6801. -        nres = in_prod(rr,rr);                 /* rr = B*A*s_{k-1} */
  6802. -        for (j = 0; j <= i-1; j++)
  6803. -              nres -= beta->ve[j]*beta->ve[j];
  6804. -        if (nres <= 0.0)  break;               /* s_k is zero */
  6805. -        else beta->ve[i] = sqrt(nres);         /* beta_{k-1,k-1} */
  6806. -        
  6807. -        v.ve = N->me[0];
  6808. -        alpha->ve[i] = in_prod(&v,rr); 
  6809. -        for (j = 0; j <= i-1; j++)
  6810. -              alpha->ve[i] -= beta->ve[j]*alpha->ve[j];
  6811. -        alpha->ve[i] /= beta->ve[i];                /* alpha_{k-1} */
  6812. -        
  6813. -     }
  6814. -     
  6815. -     set_col(H,i,beta);
  6816. -     
  6817. -     dd -= alpha->ve[i]*alpha->ve[i];
  6818. -     nres = sqrt(fabs((double) dd));
  6819. -     if (dd < 0.0)  {     /* do restart */
  6820. -        if (ip->info) (*ip->info)(ip,-nres,VNULL,VNULL);  
  6821. -        break;
  6822. -     }
  6823. -     
  6824. -     if (ip->info) (*ip->info)(ip,nres,VNULL,VNULL);     
  6825. -     if ( ip->stop_crit(ip,nres,VNULL,VNULL) ) {
  6826. -        /* stopping criterion is satisfied */
  6827. -        done = TRUE;
  6828. -        break;
  6829. -     }
  6830. -     
  6831. -      } /* end of for */
  6832. -      
  6833. -      if (nres <= 0.0) {
  6834. -     i--;
  6835. -     done = TRUE;
  6836. -      }
  6837. -      if (i >= ip->k) i = ip->k - 1;
  6838. -      
  6839. -      /* use (i+1) by (i+1) submatrix of H */
  6840. -      H = m_resize(H,i+1,i+1);
  6841. -      alpha = v_resize(alpha,i+1);
  6842. -      Usolve(H,alpha,alpha,0.0);       /* c_i is saved in alpha */
  6843. -      
  6844. -      for (j = 0; j <= i; j++) {
  6845. -     v.ve = N->me[j];
  6846. -     v_mltadd(ip->x,&v,alpha->ve[j],ip->x);
  6847. -      }
  6848. -      
  6849. -      
  6850. -      if (done) break;              /* stop the iterative process */
  6851. -      alpha = v_resize(alpha,ip->k);
  6852. -      H = m_resize(H,ip->k,ip->k);
  6853. -      
  6854. -   }  /* end of while */
  6855. -   
  6856. -   return ip->x;                    /* return the solution */
  6857. -}
  6858. -
  6859. -
  6860. -
  6861. -/* iter_spmgcr - a simple interface to iter_mgcr */
  6862. -/* no preconditioner */
  6863. -VEC    *iter_spmgcr(A,B,b,tol,x,k,limit,steps)
  6864. -SPMAT    *A, *B;
  6865. -VEC    *b, *x;
  6866. -double    tol;
  6867. -int *steps,k,limit;
  6868. -{
  6869. -   ITER *ip;
  6870. -   
  6871. -   ip = iter_get(0,0);
  6872. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  6873. -   ip->A_par = (void *) A;
  6874. -   if (B) {
  6875. -      ip->Bx = (Fun_Ax) sp_mv_mlt;
  6876. -      ip->B_par = (void *) B;
  6877. -   }
  6878. -   else {
  6879. -      ip->Bx = (Fun_Ax) NULL;
  6880. -      ip->B_par = NULL;
  6881. -   }
  6882. -
  6883. -   ip->k = k;
  6884. -   ip->limit = limit;
  6885. -   ip->info = (Fun_info) NULL;
  6886. -   ip->b = b;
  6887. -   ip->eps = tol;
  6888. -   ip->x = x;
  6889. -   iter_mgcr(ip);
  6890. -   x = ip->x;
  6891. -   if (steps) *steps = ip->steps;
  6892. -   ip->shared_x = ip->shared_b = TRUE;
  6893. -   iter_free(ip);   /* release only ITER structure */
  6894. -   return x;        
  6895. -}
  6896. -
  6897. -
  6898. -
  6899. -/* 
  6900. -  Conjugate gradients method for a normal equation
  6901. -  a preconditioner B must be symmetric !!
  6902. -*/
  6903. -VEC  *iter_cgne(ip)
  6904. -ITER *ip;
  6905. -{
  6906. -   static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL;
  6907. -   Real    alpha, beta, inner, old_inner, nres;
  6908. -   VEC *rr1;   /* pointer only */
  6909. -   
  6910. -   if (ip == INULL)
  6911. -     error(E_NULL,"iter_cgne");
  6912. -   if (!ip->Ax || ! ip->ATx || !ip->b)
  6913. -     error(E_NULL,"iter_cgne");
  6914. -   if ( ip->x == ip->b )
  6915. -     error(E_INSITU,"iter_cgne");
  6916. -   if (!ip->stop_crit)
  6917. -     error(E_NULL,"iter_cgne");
  6918. -   
  6919. -   if ( ip->eps <= 0.0 )
  6920. -     ip->eps = MACHEPS;
  6921. -   
  6922. -   r = v_resize(r,ip->b->dim);
  6923. -   p = v_resize(p,ip->b->dim);
  6924. -   q = v_resize(q,ip->b->dim);
  6925. -
  6926. -   MEM_STAT_REG(r,TYPE_VEC);
  6927. -   MEM_STAT_REG(p,TYPE_VEC);
  6928. -   MEM_STAT_REG(q,TYPE_VEC);
  6929. -
  6930. -   z = v_resize(z,ip->b->dim);
  6931. -   MEM_STAT_REG(z,TYPE_VEC);
  6932. -
  6933. -   if (ip->x) {
  6934. -      if (ip->x->dim != ip->b->dim)
  6935. -    error(E_SIZES,"iter_cgne");
  6936. -      ip->Ax(ip->A_par,ip->x,p);            /* p = A*x */
  6937. -      v_sub(ip->b,p,z);                 /* z = b - A*x */
  6938. -   }
  6939. -   else {  /* ip->x == 0 */
  6940. -      ip->x = v_get(ip->b->dim);
  6941. -      ip->shared_x = FALSE;
  6942. -      v_copy(ip->b,z);
  6943. -   }
  6944. -   rr1 = z;
  6945. -   if (ip->Bx) {
  6946. -      (ip->Bx)(ip->B_par,rr1,p);
  6947. -      rr1 = p;
  6948. -   }
  6949. -   (ip->ATx)(ip->AT_par,rr1,r);        /* r = A^T*B*(b-A*x)  */
  6950. -
  6951. -
  6952. -   old_inner = 0.0;
  6953. -   for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ )
  6954. -   {
  6955. -      rr1 = r;
  6956. -      if ( ip->Bx ) {
  6957. -     (ip->Bx)(ip->B_par,r,z);        /* rr = B*r */
  6958. -     rr1 = z;
  6959. -      }
  6960. -
  6961. -      inner = in_prod(r,rr1);
  6962. -      nres = sqrt(fabs(inner));
  6963. -      if (ip->info) ip->info(ip,nres,r,rr1);
  6964. -      if ( ip->stop_crit(ip,nres,r,rr1) ) break;
  6965. -
  6966. -      if ( ip->steps )    /* if ( ip->steps > 0 ) ... */
  6967. -      {
  6968. -     beta = inner/old_inner;
  6969. -     p = v_mltadd(rr1,p,beta,p);
  6970. -      }
  6971. -      else        /* if ( ip->steps == 0 ) ... */
  6972. -      {
  6973. -     beta = 0.0;
  6974. -     p = v_copy(rr1,p);
  6975. -     old_inner = 0.0;
  6976. -      }
  6977. -      (ip->Ax)(ip->A_par,p,q);     /* q = A*p */
  6978. -      if (ip->Bx) {
  6979. -     (ip->Bx)(ip->B_par,q,z);
  6980. -     (ip->ATx)(ip->AT_par,z,q);
  6981. -     rr1 = q;            /* q = A^T*B*A*p */
  6982. -      }
  6983. -      else {
  6984. -     (ip->ATx)(ip->AT_par,q,z);    /* z = A^T*A*p */
  6985. -     rr1 = z;
  6986. -      }
  6987. -
  6988. -      alpha = inner/in_prod(rr1,p);
  6989. -      v_mltadd(ip->x,p,alpha,ip->x);
  6990. -      v_mltadd(r,rr1,-alpha,r);
  6991. -      old_inner = inner;
  6992. -   }
  6993. -
  6994. -   return ip->x;
  6995. -}
  6996. -
  6997. -/* iter_spcgne -- a simple interface to iter_cgne() which 
  6998. -   uses sparse matrix data structures
  6999. -   -- assumes that B contains an actual preconditioner (or NULL)
  7000. -   use always as follows:
  7001. -      x = iter_spcgne(A,B,b,eps,x,limit,steps);
  7002. -   or 
  7003. -      x = iter_spcgne(A,B,b,eps,VNULL,limit,steps);
  7004. -   In the second case the solution vector is created.
  7005. -*/
  7006. -VEC  *iter_spcgne(A,B,b,eps,x,limit,steps)
  7007. -SPMAT    *A, *B;
  7008. -VEC    *b, *x;
  7009. -double    eps;
  7010. -int *steps, limit;
  7011. -{    
  7012. -   ITER *ip;
  7013. -   
  7014. -   ip = iter_get(0,0);
  7015. -   ip->Ax = (Fun_Ax) sp_mv_mlt;
  7016. -   ip->A_par = (void *)A;
  7017. -   ip->ATx = (Fun_Ax) sp_vm_mlt;
  7018. -   ip->AT_par = (void *)A;
  7019. -   if (B) {
  7020. -      ip->Bx = (Fun_Ax) sp_mv_mlt;
  7021. -      ip->B_par = (void *)B;
  7022. -   }
  7023. -   else {
  7024. -      ip->Bx = (Fun_Ax) NULL;
  7025. -      ip->B_par = NULL;
  7026. -   }
  7027. -   ip->info = (Fun_info) NULL;
  7028. -   ip->b = b;
  7029. -   ip->eps = eps;
  7030. -   ip->limit = limit;
  7031. -   ip->x = x;
  7032. -   iter_cgne(ip);
  7033. -   x = ip->x;
  7034. -   if (steps) *steps = ip->steps;
  7035. -   ip->shared_x = ip->shared_b = TRUE;
  7036. -   iter_free(ip);   /* release only ITER structure */
  7037. -   return x;        
  7038. -}
  7039. -
  7040. -
  7041. -
  7042. -
  7043. //GO.SYSIN DD iternsym.c
  7044.