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