Actual source code: unary.c
1: /*$Id: unary.c,v 1.4 2001/08/06 21:15:14 bsmith Exp $*/
2: /* unary.f -- translated by f2c (version of 25 March 1992 12:58:56).
4: This code is protected by the GNU copyright. See the file
5: ilut.c in this directory for the full copyright. See below for the Author.
6: */
7: #include petsc.h
8: /* ----------------------------------------------------------------------- */
9: static int SPARSEKIT2rperm(int *nrow,PetscScalar *a,int *ja,int *ia,PetscScalar *ao,int *jao,int *iao,int *perm,int *job)
10: {
11: /* System generated locals */
12: int i__1,i__2;
14: /* Local variables */
15: int i,j,k,ii,ko;
16: int values;
18: /* -----------------------------------------------------------------------
19: */
20: /* this subroutine permutes the rows of a matrix in CSR format. */
21: /* rperm computes B = P A where P is a permutation matrix. */
22: /* the permutation P is defined through the array perm: for each j, */
23: /* perm(j) represents the destination row number of row number j. */
24: /* Youcef Saad -- recoded Jan 28, 1991. */
25: /* -----------------------------------------------------------------------
26: */
27: /* on entry: */
28: /* ---------- */
29: /* n = dimension of the matrix */
30: /* a, ja, ia = input matrix in csr format */
31: /* perm = integer array of length nrow containing the permutation arrays
32: */
33: /* for the rows: perm(i) is the destination of row i in the */
34: /* permuted matrix. */
35: /* ---> a(i,j) in the original matrix becomes a(perm(i),j) */
36: /* in the output matrix. */
38: /* job = integer indicating the work to be done: */
39: /* job = 1 permute a, ja, ia into ao, jao, iao */
40: /* (including the copying of real values ao and */
41: /* the array iao). */
42: /* job .ne. 1 : ignore real values. */
43: /* (in which case arrays a and ao are not needed nor
44: */
45: /* used). */
47: /* ------------ */
48: /* on return: */
49: /* ------------ */
50: /* ao, jao, iao = input matrix in a, ja, ia format */
51: /* note : */
52: /* if (job.ne.1) then the arrays a and ao are not used. */
53: /* ----------------------------------------------------------------------c
54: */
55: /* Y. Saad, May 2, 1990 c
56: */
57: /* ----------------------------------------------------------------------c
58: */
59: /* Parameter adjustments */
60: --perm;
61: --iao;
62: --jao;
63: --ao;
64: --ia;
65: --ja;
66: --a;
68: /* Function Body */
69: values = *job == 1;
71: /* determine pointers for output matix. */
73: i__1 = *nrow;
74: for (j = 1; j <= i__1; ++j) {
75: i = perm[j];
76: iao[i + 1] = ia[j + 1] - ia[j];
77: /* L50: */
78: }
80: /* get pointers from lengths */
82: iao[1] = 1;
83: i__1 = *nrow;
84: for (j = 1; j <= i__1; ++j) {
85: iao[j + 1] += iao[j];
86: /* L51: */
87: }
89: /* copying */
91: i__1 = *nrow;
92: for (ii = 1; ii <= i__1; ++ii) {
94: /* old row = ii -- new row = iperm(ii) -- ko = new pointer */
96: ko = iao[perm[ii]];
97: i__2 = ia[ii + 1] - 1;
98: for (k = ia[ii]; k <= i__2; ++k) {
99: jao[ko] = ja[k];
100: if (values) {
101: ao[ko] = a[k];
102: }
103: ++ko;
104: /* L60: */
105: }
106: /* L100: */
107: }
109: return 0;
110: /* ---------end-of-rperm -------------------------------------------------
111: */
112: /* -----------------------------------------------------------------------
113: */
114: } /* rperm_ */
116: /* ----------------------------------------------------------------------- */
117: static int SPARSEKIT2cperm(int *nrow,PetscScalar * a,int * ja,int * ia,PetscScalar * ao,int * jao,int * iao,int * perm,int * job)
118: {
119: /* System generated locals */
120: int i__1;
122: /* Local variables */
123: int i,k,nnz;
125: /* -----------------------------------------------------------------------
126: */
127: /* this subroutine permutes the columns of a matrix a, ja, ia. */
128: /* the result is written in the output matrix ao, jao, iao. */
129: /* cperm computes B = A P, where P is a permutation matrix */
130: /* that maps column j into column perm(j), i.e., on return */
131: /* a(i,j) becomes a(i,perm(j)) in new matrix */
132: /* Y. Saad, May 2, 1990 / modified Jan. 28, 1991. */
133: /* -----------------------------------------------------------------------
134: */
135: /* on entry: */
136: /* ---------- */
137: /* nrow = row dimension of the matrix */
139: /* a, ja, ia = input matrix in csr format. */
141: /* perm = integer array of length ncol (number of columns of A */
142: /* containing the permutation array the columns: */
143: /* a(i,j) in the original matrix becomes a(i,perm(j)) */
144: /* in the output matrix. */
146: /* job = integer indicating the work to be done: */
147: /* job = 1 permute a, ja, ia into ao, jao, iao */
148: /* (including the copying of real values ao and */
149: /* the array iao). */
150: /* job .ne. 1 : ignore real values ao and ignore iao. */
152: /* ------------ */
153: /* on return: */
154: /* ------------ */
155: /* ao, jao, iao = input matrix in a, ja, ia format (array ao not needed)
156: */
158: /* Notes: */
159: /* ------- */
160: /* 1. if job=1 then ao, iao are not used. */
161: /* 2. This routine is in place: ja, jao can be the same. */
162: /* 3. If the matrix is initially sorted (by increasing column number) */
163: /* then ao,jao,iao may not be on return. */
165: /* ----------------------------------------------------------------------c
166: */
167: /* local parameters: */
169: /* Parameter adjustments */
170: --perm;
171: --iao;
172: --jao;
173: --ao;
174: --ia;
175: --ja;
176: --a;
178: /* Function Body */
179: nnz = ia[*nrow + 1] - 1;
180: i__1 = nnz;
181: for (k = 1; k <= i__1; ++k) {
182: jao[k] = perm[ja[k]];
183: /* L100: */
184: }
186: /* done with ja array. return if no need to touch values. */
188: if (*job != 1) {
189: return 0;
190: }
192: /* else get new pointers -- and copy values too. */
194: i__1 = *nrow + 1;
195: for (i = 1; i <= i__1; ++i) {
196: iao[i] = ia[i];
197: /* L1: */
198: }
200: i__1 = nnz;
201: for (k = 1; k <= i__1; ++k) {
202: ao[k] = a[k];
203: /* L2: */
204: }
206: return 0;
207: /* ---------end-of-cperm--------------------------------------------------
208: */
209: /* -----------------------------------------------------------------------
210: */
211: } /* cperm_ */
213: /* ----------------------------------------------------------------------- */
214: int SPARSEKIT2dperm(int *nrow,PetscScalar *a,int *ja,int *ia,PetscScalar *ao,int *jao,int *iao,int *perm,int *qperm,int *job)
215: {
216: int locjob;
218: /* -----------------------------------------------------------------------
219: */
220: /* This routine permutes the rows and columns of a matrix stored in CSR */
222: /* format. i.e., it computes P A Q, where P, Q are permutation matrices.
223: */
224: /* P maps row i into row perm(i) and Q maps column j into column qperm(j):
225: */
226: /* a(i,j) becomes a(perm(i),qperm(j)) in new matrix */
227: /* In the particular case where Q is the transpose of P (symmetric */
228: /* permutation of A) then qperm is not needed. */
229: /* note that qperm should be of length ncol (number of columns) but this
230: */
231: /* is not checked. */
232: /* -----------------------------------------------------------------------
233: */
234: /* Y. Saad, Sep. 21 1989 / recoded Jan. 28 1991. */
235: /* -----------------------------------------------------------------------
236: */
237: /* on entry: */
238: /* ---------- */
239: /* n = dimension of the matrix */
240: /* a, ja, */
241: /* ia = input matrix in a, ja, ia format */
242: /* perm = integer array of length n containing the permutation arrays */
243: /* for the rows: perm(i) is the destination of row i in the */
244: /* permuted matrix -- also the destination of column i in case */
245: /* permutation is symmetric (job .le. 2) */
247: /* qperm = same thing for the columns. This should be provided only */
248: /* if job=3 or job=4, i.e., only in the case of a nonsymmetric */
249: /* permutation of rows and columns. Otherwise qperm is a dummy */
251: /* job = integer indicating the work to be done: */
252: /* * job = 1,2 permutation is symmetric Ao :== P * A * transp(P) */
253: /* job = 1 permute a, ja, ia into ao, jao, iao */
254: /* job = 2 permute matrix ignoring real values. */
255: /* * job = 3,4 permutation is non-symmetric Ao :== P * A * Q */
256: /* job = 3 permute a, ja, ia into ao, jao, iao */
257: /* job = 4 permute matrix ignoring real values. */
259: /* on return: */
260: /* ----------- */
261: /* ao, jao, iao = input matrix in a, ja, ia format */
263: /* in case job .eq. 2 or job .eq. 4, a and ao are never referred to */
264: /* and can be dummy arguments. */
265: /* Notes: */
266: /* ------- */
267: /* 1) algorithm is in place */
268: /* 2) column indices may not be sorted on return even though they may be
269: */
270: /* on entry. */
271: /* ----------------------------------------------------------------------c
272: */
273: /* local variables */
275: /* locjob indicates whether or not real values must be copied. */
277: /* Parameter adjustments */
278: --qperm;
279: --perm;
280: --iao;
281: --jao;
282: --ao;
283: --ia;
284: --ja;
285: --a;
287: /* Function Body */
288: locjob = *job % 2;
290: /* permute rows first */
292: SPARSEKIT2rperm(nrow, &a[1], &ja[1], &ia[1], &ao[1], &jao[1], &iao[1], &perm[1], &locjob);
294: /* then permute columns */
296: locjob = 0;
298: if (*job <= 2) {
299: SPARSEKIT2cperm(nrow, &ao[1], &jao[1], &iao[1], &ao[1], &jao[1], &iao[1], &perm[1], &locjob);
300: } else {
301: SPARSEKIT2cperm(nrow, &ao[1], &jao[1], &iao[1], &ao[1], &jao[1], &iao[1], &qperm[1], &locjob);
302: }
304: return 0;
305: /* -------end-of-dperm----------------------------------------------------
306: */
307: /* -----------------------------------------------------------------------
308: */
309: } /* dperm_ */
311: /* ----------------------------------------------------------------------- */
312: int SPARSEKIT2msrcsr(int *n,PetscScalar * a,int * ja,PetscScalar * ao,int * jao,int * iao,PetscScalar * wk,int * iwk)
313: {
314: /* System generated locals */
315: int i__1, i__2;
317: /* Local variables */
318: int iptr;
319: int added;
320: int i, j, k, idiag, ii;
322: /* -----------------------------------------------------------------------
323: */
324: /* Modified - Sparse Row to Compressed Sparse Row */
326: /* -----------------------------------------------------------------------
327: */
328: /* converts a compressed matrix using a separated diagonal */
329: /* (modified sparse row format) in the Compressed Sparse Row */
330: /* format. */
331: /* does not check for zero elements in the diagonal. */
334: /* on entry : */
335: /* --------- */
336: /* n = row dimension of matrix */
337: /* a, ja = sparse matrix in msr sparse storage format */
338: /* see routine csrmsr for details on data structure */
340: /* on return : */
341: /* ----------- */
343: /* ao,jao,iao = output matrix in csr format. */
345: /* work arrays: */
346: /* ------------ */
347: /* wk = real work array of length n */
348: /* iwk = integer work array of length n+1 */
350: /* notes: */
351: /* The original version of this was NOT in place, but has */
352: /* been modified by adding the vector iwk to be in place. */
353: /* The original version had ja instead of iwk everywhere in */
354: /* loop 500. Modified Sun 29 May 1994 by R. Bramley (Indiana). */
356: /* -----------------------------------------------------------------------
357: */
358: /* Parameter adjustments */
359: --iwk;
360: --wk;
361: --iao;
362: --jao;
363: --ao;
364: --ja;
365: --a;
367: /* Function Body */
368: i__1 = *n;
369: for (i = 1; i <= i__1; ++i) {
370: wk[i] = a[i];
371: iwk[i] = ja[i];
372: /* L1: */
373: }
374: iwk[*n + 1] = ja[*n + 1];
375: iao[1] = 1;
376: iptr = 1;
377: /* --------- */
378: i__1 = *n;
379: for (ii = 1; ii <= i__1; ++ii) {
380: added = 0;
381: idiag = iptr + (iwk[ii + 1] - iwk[ii]);
382: i__2 = iwk[ii + 1] - 1;
383: for (k = iwk[ii]; k <= i__2; ++k) {
384: j = ja[k];
385: if (j < ii) {
386: ao[iptr] = a[k];
387: jao[iptr] = j;
388: ++iptr;
389: } else if (added) {
390: ao[iptr] = a[k];
391: jao[iptr] = j;
392: ++iptr;
393: } else {
394: /* add diag element - only reserve a position for it. */
395: idiag = iptr;
396: ++iptr;
397: added = 1;
398: /* then other element */
399: ao[iptr] = a[k];
400: jao[iptr] = j;
401: ++iptr;
402: }
403: /* L100: */
404: }
405: ao[idiag] = wk[ii];
406: jao[idiag] = ii;
407: if (! added) {
408: ++iptr;
409: }
410: iao[ii + 1] = iptr;
411: /* L500: */
412: }
413: return 0;
414: } /* msrcsr_ */