1 /*=========================================================================
2 *
3 * Copyright Insight Software Consortium
4 *
5 * Licensed under the Apache License, Version 2.0 (the "License");
6 * you may not use this file except in compliance with the License.
7 * You may obtain a copy of the License at
8 *
9 * http://www.apache.org/licenses/LICENSE-2.0.txt
10 *
11 * Unless required by applicable law or agreed to in writing, software
12 * distributed under the License is distributed on an "AS IS" BASIS,
13 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14 * See the License for the specific language governing permissions and
15 * limitations under the License.
16 *
17 *=========================================================================*/
18 /** dsrc2c: THIS FILE HAS BEEN MODIFIED AFTER f2c
19 * Modifications were
20 * - removed zbrent - copyright issue
21 * - removed eqrt1s - copyright issue
22 * - In eigvns_, replaced call to eqrt1s with call to v3p_netlib_tqlrat_
23 * - removed eigvss_ - required zbrent
24 * - use eigvns_ instead
25 **/
26
27 #define V3P_NETLIB_SRC
28 #include "v3p_netlib.h"
29
30 /* Modified by Peter Vanroose, Oct 2003: manual optimisation and clean-up */
31
32 extern double log(double), sqrt(double); /* #include <math.h> */
33 extern long time(long *timer); /* #include <time.h> */
34
35 extern doublereal cheby_(doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *);
36 extern doublereal determ_(integer *, doublereal *, doublereal *);
37 extern doublereal eigvns_(integer *, doublereal *, doublereal *, doublereal *, integer *);
38 extern doublereal itpackddot_(integer *, doublereal *, integer *, doublereal *, integer *);
39 extern doublereal pbeta_(integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *);
40 extern doublereal pvtbv_(integer *, integer *, integer *, doublereal *, doublereal *);
41 extern doublereal tau_(integer *);
42 extern doublereal dsrc_timer_(real *);
43 extern integer bisrch_(integer *, integer *, integer *);
44 extern integer ipstr_(doublereal *);
45 extern logical chgsme_(doublereal *, integer *);
46 extern logical omgchg_(integer *);
47 extern logical omgstr_(integer *);
48 extern logical tstchg_(integer *);
49
50 /***** BEGIN VXL ADDITIONS ****/
51
52 /* Turn off warnings in f2c generated code */
53 #if defined(_MSC_VER)
54 # if defined(__ICL)
55 # pragma warning(disable: 239 264 1011 )
56 # else
57 # pragma warning(disable: 4101 4244 4554 4756 4723)
58 # endif
59 #endif
60
61 /***** END VXL ADDITIONS ****/
62
63 int echout_(integer *iparm, doublereal *rparm, integer *imthd);
64 int echall_(integer *nn, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
65 integer *iparm, doublereal *rparm, integer *icall);
66 int ivfill_(integer *n, integer *iv, integer *ival);
67 int vfill_(integer *n, doublereal *v, doublereal *val);
68 int sbelm_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, integer *iw,
69 doublereal *rw, doublereal *tol, integer *isym, integer *level, integer *nout, integer *ier);
70 int prbndx_(integer *n, integer *nblack, integer *ia, integer *ja, integer *p,
71 integer *ip, integer *level, integer *nout, integer *ier);
72 int permat_(integer *n, integer *ia, integer *ja, doublereal *a, integer *p,
73 integer *newia, integer *isym, integer * level, integer *nout, integer* ierr);
74 int pervec_(integer *n, doublereal *v, integer *p);
75 int scal_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
76 doublereal *u, doublereal *d, integer *level, integer *nout, integer *ier);
77 int itpackdcopy_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy);
78 int pjac_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs);
79 int vevmw_(integer *n, doublereal *v, doublereal *w);
80
81 int perror_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
82 doublereal *u, doublereal *w, doublereal *digtt1, doublereal *digtt2, integer *idgtts);
83 int itjsi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
84 doublereal *u, doublereal *u1, doublereal *d, integer *icnt);
85 int itsor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u, doublereal *wk);
86 int omeg_(doublereal *dnrm, integer *iflag);
87 int pfsor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs);
88 int itsrcg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
89 doublereal *u, doublereal *u1, doublereal *c, doublereal *c1,
90 doublereal *d, doublereal *dl, doublereal *wk, doublereal *tri);
91 int itsrsi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
92 doublereal *u1, doublereal *c, doublereal *d, doublereal *ctwd, doublereal *wk);
93 int chgcon_(doublereal *tri, doublereal *gamold, doublereal *rhoold, integer *ibmth);
94 int pstop_(integer *n, doublereal *u, doublereal *dnrm, doublereal *ccon, integer *iflag, logical *q1);
95 int parcon_(doublereal *dtnrm, doublereal *c1, doublereal *c2, doublereal *c3, doublereal *c4,
96 doublereal *gamold, doublereal * rhotmp, integer *ibmth);
97 int sum3_(integer *n, doublereal *c1, doublereal *x1, doublereal *c2, doublereal *x2, doublereal *c3, doublereal *x3);
98 int iterm_(integer *nn, doublereal *a, doublereal *u, doublereal *wk, integer *imthdd);
99 int chgsi_(doublereal *dtnrm, integer *ibmth);
100 int itpackdaxpy_(integer *n, doublereal *da, doublereal *dx, integer *incx, doublereal *dy, integer *incy);
101 int pfsor1_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs);
102 int vevpw_(integer *n, doublereal *v, doublereal *w);
103 int pbsor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs);
104 int wevmw_(integer *n, doublereal *v, doublereal *w);
105 int pssor1_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u,
106 doublereal *rhs, doublereal *fr, doublereal *br);
107 int pmult_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *w);
108 int vout_(integer *n, doublereal *v, integer *iswt, integer *nout);
109 int unscal_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u, doublereal *d);
110 int prsred_(integer *nb, integer *nr, integer *ia, integer *ja, doublereal *a, doublereal *ub, doublereal *vr);
111 int itrscg_(integer *n, integer *nb, integer *ia, integer *ja, doublereal *a, doublereal *ub,
112 doublereal *ub1, doublereal *db, doublereal *db1, doublereal *wb, doublereal *tri);
113 int itrssi_(integer *n, integer *nb, integer *ia, integer *ja, doublereal *a,
114 doublereal *rhs, doublereal *ub, doublereal *ub1, doublereal *db);
115 int parsi_(doublereal *c1, doublereal *c2, doublereal *c3, integer *ibmth);
116 int itjcg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *u1,
117 doublereal *d, doublereal *d1, doublereal *dtwd, doublereal *tri);
118 int prsblk_(integer *nb, integer *nr, integer *ia, integer *ja, doublereal *a, doublereal *ur, doublereal *vb);
119
120 /* Common Block Declarations */
121
122 static struct {
123 integer in;
124 integer is;
125 integer isym;
126 integer itmax;
127 integer level;
128 integer nout;
129 } itcom1_;
130
131 #define itcom1_1 itcom1_
132
133 static struct {
134 logical adapt;
135 logical betadt;
136 logical caseii;
137 logical halt;
138 logical partad;
139 } itcom2_;
140
141 #define itcom2_1 itcom2_
142
143 static struct {
144 doublereal bdelnm;
145 doublereal betab;
146 doublereal cme;
147 doublereal delnnm;
148 doublereal delsnm;
149 doublereal ff;
150 doublereal gamma;
151 doublereal omega;
152 doublereal qa;
153 doublereal qt;
154 doublereal rho;
155 doublereal rrr;
156 doublereal sige;
157 doublereal sme;
158 doublereal specr;
159 doublereal spr;
160 doublereal drelpr;
161 doublereal stptst;
162 doublereal udnm;
163 doublereal zeta;
164 } itcom3_;
165
166 #define itcom3_1 itcom3_
167
168 /* Table of constant values */
169
170 static integer c__1 = 1;
171 static integer c__0 = 0;
172 static doublereal c_b21 = 0.;
173 static integer c__2 = 2;
174 static integer c__3 = 3;
175 static integer c__4 = 4;
176 static doublereal c_b286 = 1.;
177 static integer c__5 = 5;
178 static integer c__6 = 6;
179 static integer c__7 = 7;
180
181 /* Subroutine */
jcg_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)182 int jcg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
183 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer *ierr)
184 {
185 /* Local variables */
186 static integer n3, nb, ib1, ib2, ib3, ib4, ib5, ier;
187 static doublereal tol;
188 static doublereal temp;
189 static integer loop;
190 static doublereal time1, time2;
191 static real timi1, timj1, timi2, timj2;
192 static integer idgts;
193 static doublereal digit1, digit2;
194 static integer itmax1;
195 static integer ierper;
196
197 /* ITPACK 2C MAIN SUBROUTINE JCG (JACOBI CONJUGATE GRADIENT) */
198 /* EACH OF THE MAIN SUBROUTINES: */
199 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
200 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
201
202 /* THIS SUBROUTINE, JCG, DRIVES THE JACOBI CONJUGATE */
203 /* GRADIENT ALGORITHM. */
204 /* */
205 /* ... PARAMETER LIST: */
206 /* */
207 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
208 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
209 /* THE SPARSE MATRIX REPRESENTATION. */
210 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
211 /* MATRIX REPRESENTATION. */
212 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
213 /* OF THE MATRIX PROBLEM. */
214 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
215 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
216 /* THE LATEST ESTIMATE TO THE SOLUTION. */
217 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
218 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
219 /* IPARM(8) IS AMOUNT USED. */
220 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. JACOBI CONJUGATE */
221 /* GRADIENT NEEDS THIS TO BE IN LENGTH AT LEAST */
222 /* 4*N + 2*ITMAX, IF ISYM = 0 (SYMMETRIC STORAGE) */
223 /* 4*N + 4*ITMAX, IF ISYM = 1 (NONSYMMETRIC STORAGE) */
224 /* HERE ITMAX = IPARM(1) AND ISYM = IPARM(5) */
225 /* (ITMAX IS THE MAXIMUM ALLOWABLE NUMBER OF ITERATIONS) */
226 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
227 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. */
228 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
229 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
230 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
231 /* */
232 /* ... JCG SUBPROGRAM REFERENCES: */
233 /* */
234 /* FROM ITPACK BISRCH, CHGCON, DETERM, DFAULT, ECHALL, */
235 /* ECHOUT, EIGVNS, EIGVSS, EQRT1S, ITERM, TIMER, */
236 /* ITJCG, IVFILL, PARCON, PERMAT, */
237 /* PERROR, PERVEC, PJAC, PMULT, PRBNDX, */
238 /* PSTOP, QSORT, DAXPY, SBELM, SCAL, DCOPY, */
239 /* DDOT, SUM3, UNSCAL, VEVMW, VFILL, VOUT, */
240 /* WEVMW, ZBRENT */
241 /* SYSTEM DABS, DLOG10, DBLE(AMAX0), DMAX1, MOD, DSQRT */
242 /* */
243 /* VERSION: ITPACK 2C (MARCH 1982) */
244 /* */
245 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
246 /* CENTER FOR NUMERICAL ANALYSIS */
247 /* UNIVERSITY OF TEXAS */
248 /* AUSTIN, TX 78712 */
249 /* (512) 471-1242 */
250 /* */
251 /* FOR ADDITIONAL DETAILS ON THE */
252 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
253 /* (B) ALGORITHM SEE CNA REPORT 150 */
254 /* */
255 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
256 /* */
257 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
258 /* L. HAGEMAN, D. YOUNG */
259 /* ACADEMIC PRESS, 1981 */
260 /* */
261 /* ************************************************** */
262 /* * IMPORTANT NOTE * */
263 /* * * */
264 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
265 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
266 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
267 /* * * */
268 /* * DRELPR MACHINE RELATIVE PRECISION * */
269 /* * RPARM(1) STOPPING CRITERION * */
270 /* * * */
271 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
272 /* * SECOND USED IN TIMER * */
273 /* * * */
274 /* ************************************************** */
275 /* */
276 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
277 /* */
278 /* IN - ITERATION NUMBER */
279 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
280 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
281 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
282 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
283 /* NOUT - OUTPUT UNIT NUMBER */
284 /* */
285 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
286 /* */
287 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
288 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
289 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
290 /* HALT - STOPPING TEST SWITCH */
291 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
292 /* */
293 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
294 /* */
295 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
296 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
297 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
298 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
299 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
300 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
301 /* GAMMA - ACCELERATION PARAMETER */
302 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
303 /* QA - PSEUDO-RESIDUAL RATIO */
304 /* QT - VIRTUAL SPECTRAL RADIUS */
305 /* RHO - ACCELERATION PARAMETER */
306 /* RRR - ADAPTIVE PARAMETER */
307 /* SIGE - PARAMETER SIGMA-SUB-E */
308 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
309 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
310 /* DRELPR - MACHINE RELATIVE PRECISION */
311 /* STPTST - STOPPING PARAMETER */
312 /* UDNM - TWO NORM OF U */
313 /* ZETA - STOPPING CRITERION */
314
315 itcom1_1.level = iparm[1];
316 itcom1_1.nout = iparm[3];
317 ier = 0;
318 if (iparm[0] <= 0)
319 return 0;
320
321 if (iparm[10] == 0)
322 {
323 timj1 = (real)( dsrc_timer_((real*)0) );
324 }
325
326 if (itcom1_1.level < 3)
327 {
328 echout_(iparm, rparm, &c__1);
329 }
330 else
331 {
332 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
333 }
334
335 temp = itcom3_1.drelpr * 500.;
336 if (itcom3_1.zeta < temp)
337 {
338 itcom3_1.zeta = temp;
339 }
340
341 time1 = rparm[8];
342 time2 = rparm[9];
343 digit1 = rparm[10];
344 digit2 = rparm[11];
345
346 /* ... VERIFY N */
347
348 if (*n <= 0) {
349 ier = 11;
350 goto L370;
351 }
352
353 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
354
355 if (iparm[9] != 0) {
356 tol = rparm[7];
357 ivfill_(n, iwksp, &c__0);
358 vfill_(n, wksp, &c_b21);
359 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
360 if (ier != 0)
361 goto L370;
362 }
363
364 /* ... INITIALIZE WKSP BASE ADDRESSES. */
365
366 ib1 = 0;
367 ib2 = ib1 + *n;
368 ib3 = ib2 + *n;
369 ib4 = ib3 + *n;
370 ib5 = ib4 + *n;
371 iparm[7] = (*n << 2) + (itcom1_1.itmax << 1);
372 if (itcom1_1.isym != 0)
373 iparm[7] += itcom1_1.itmax << 1;
374
375 if (*nw < iparm[7]) {
376 ier = 12;
377 goto L370;
378 }
379
380 /* ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED */
381
382 nb = iparm[8];
383 if (nb < 0)
384 goto L170;
385
386 n3 = *n * 3;
387 ivfill_(&n3, iwksp, &c__0);
388 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
389 if (ier != 0)
390 goto L370;
391
392 /* ... PERMUTE MATRIX AND RHS */
393
394 permat_(n, ia, ja, a, iwksp, &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
395 if (ier != 0)
396 goto L370;
397
398 pervec_(n, rhs, iwksp);
399 pervec_(n, u, iwksp);
400
401 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE DIAGONAL ELEMENTS. */
402
403 L170:
404 vfill_(&iparm[7], wksp, &c_b21);
405 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
406 if (ier != 0)
407 goto L370;
408
409 if (iparm[10] == 0)
410 {
411 timi1 = (real)( dsrc_timer_((real*)0) );
412 }
413
414 /* ... COMPUTE INITIAL PSEUDO-RESIDUAL */
415
416 itpackdcopy_(n, rhs, &c__1, &wksp[ib2], &c__1);
417 pjac_(n, ia, ja, a, u, &wksp[ib2]);
418 vevmw_(n, &wksp[ib2], u);
419
420 /* ... ITERATION SEQUENCE */
421
422 itmax1 = itcom1_1.itmax + 1;
423 for (loop = 1; loop <= itmax1; ++loop) {
424 itcom1_1.in = loop - 1;
425 if (itcom1_1.in % 2 == 1)
426 goto L240;
427
428 /* ... CODE FOR THE EVEN ITERATIONS. */
429
430 /* U = U(IN) WKSP(IB2) = DEL(IN) */
431 /* WKSP(IB1) = U(IN-1) WKSP(IB3) = DEL(IN-1) */
432
433 itjcg_(n, ia, ja, a, u, &wksp[ib1], &wksp[ib2], &wksp[ib3], &wksp[ib4], &wksp[ib5]);
434
435 if (itcom2_1.halt)
436 goto L280;
437
438 continue;
439
440 /* ... CODE FOR THE ODD ITERATIONS. */
441
442 /* U = U(IN-1) WKSP(IB2) = DEL(IN-1) */
443 /* WKSP(IB1) = U(IN) WKSP(IB3) = DEL(IN) */
444
445 L240:
446 itjcg_(n, ia, ja, a, &wksp[ib1], u, &wksp[ib3], &wksp[ib2], &wksp[ib4], &wksp[ib5]);
447
448 if (itcom2_1.halt)
449 goto L280;
450 }
451
452 /* ... ITMAX HAS BEEN REACHED */
453
454 if (iparm[10] == 0) {
455 timi2 = (real)( dsrc_timer_((real*)0) );
456 time1 = (doublereal) (timi2 - timi1);
457 }
458 ier = 13;
459 if (iparm[2] == 0)
460 rparm[0] = itcom3_1.stptst;
461
462 goto L310;
463
464 /* ... METHOD HAS CONVERGED */
465
466 L280:
467 if (iparm[10] == 0) {
468 timi2 = (real)( dsrc_timer_((real*)0) );
469 time1 = (doublereal) (timi2 - timi1);
470 }
471
472 /* ... PUT SOLUTION INTO U IF NOT ALREADY THERE. */
473
474 L310:
475 if (itcom1_1.in % 2 == 1)
476 itpackdcopy_(n, &wksp[ib1], &c__1, u, &c__1);
477
478 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
479
480 unscal_(n, ia, ja, a, rhs, u, wksp);
481
482 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
483
484 if (iparm[8] < 0)
485 goto L340;
486
487 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
488 if (ierper != 0) {
489 if (ier == 0)
490 ier = ierper;
491
492 goto L370;
493 }
494
495 pervec_(n, rhs, &iwksp[ib2]);
496 pervec_(n, u, &iwksp[ib2]);
497
498 /* ... OPTIONAL ERROR ANALYSIS */
499
500 L340:
501 idgts = iparm[11];
502 if (idgts >= 0) {
503 if (iparm[1] <= 0)
504 idgts = 0;
505
506 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
507 }
508
509 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
510
511 iparm[7] -= (itcom1_1.itmax - itcom1_1.in) << 1;
512 if (iparm[10] == 0) {
513 timj2 = (real)( dsrc_timer_((real*)0) );
514 time2 = (doublereal) (timj2 - timj1);
515 }
516 if (itcom1_1.isym != 0)
517 iparm[7] -= (itcom1_1.itmax - itcom1_1.in) << 1;
518
519 if (iparm[2] == 0) {
520 iparm[0] = itcom1_1.in;
521 iparm[8] = nb;
522 rparm[1] = itcom3_1.cme;
523 rparm[2] = itcom3_1.sme;
524 rparm[8] = time1;
525 rparm[9] = time2;
526 rparm[10] = digit1;
527 rparm[11] = digit2;
528 }
529
530 L370:
531 *ierr = ier;
532 if (itcom1_1.level >= 3)
533 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
534
535 return 0;
536 } /* jcg_ */
537
538 /* Subroutine */
jsi_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)539 int jsi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
540 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer *ierr)
541 {
542 /* Local variables */
543 static integer n3, nb, ib1, ib2, ib3, ier;
544 static doublereal tol;
545 static integer icnt;
546 static doublereal temp;
547 static integer loop;
548 static doublereal time1, time2;
549 static real timi1, timj1, timi2, timj2;
550 static integer idgts;
551 static doublereal digit1, digit2;
552 static integer itmax1;
553 static integer ierper;
554
555 /* ITPACK 2C MAIN SUBROUTINE JSI (JACOBI SEMI-ITERATIVE) */
556 /* EACH OF THE MAIN SUBROUTINES: */
557 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
558 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
559
560 /* THIS SUBROUTINE, JSI, DRIVES THE JACOBI SEMI- */
561 /* ITERATION ALGORITHM. */
562 /* */
563 /* ... PARAMETER LIST: */
564 /* */
565 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
566 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
567 /* THE SPARSE MATRIX REPRESENTATION. */
568 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
569 /* MATRIX REPRESENTATION. */
570 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
571 /* OF THE MATRIX PROBLEM. */
572 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
573 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
574 /* THE LATEST ESTIMATE TO THE SOLUTION. */
575 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
576 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
577 /* IPARM(8) IS AMOUNT USED. */
578 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. JACOBI SI */
579 /* NEEDS THIS TO BE IN LENGTH AT LEAST */
580 /* 2*N */
581 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
582 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. */
583 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
584 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
585 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
586 /* */
587 /* ... JSI SUBPROGRAM REFERENCES: */
588 /* */
589 /* FROM ITPACK BISRCH, CHEBY, CHGSI, CHGSME, DFAULT, ECHALL, */
590 /* ECHOUT, ITERM, TIMER, ITJSI, IVFILL, PAR */
591 /* PERMAT, PERROR, PERVEC, PJAC, PMULT, PRBNDX, */
592 /* PSTOP, PVTBV, QSORT, DAXPY, SBELM, SCAL, */
593 /* DCOPY, DDOT, SUM3, TSTCHG, UNSCAL, VEVMW, */
594 /* VFILL, VOUT, WEVMW */
595 /* SYSTEM DABS, DLOG10, DBLE(AMAX0), DMAX1, DBLE(FLOAT), */
596 /* MOD,DSQRT */
597 /* */
598 /* VERSION: ITPACK 2C (MARCH 1982) */
599 /* */
600 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
601 /* CENTER FOR NUMERICAL ANALYSIS */
602 /* UNIVERSITY OF TEXAS */
603 /* AUSTIN, TX 78712 */
604 /* (512) 471-1242 */
605 /* */
606 /* FOR ADDITIONAL DETAILS ON THE */
607 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
608 /* (B) ALGORITHM SEE CNA REPORT 150 */
609 /* */
610 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
611 /* */
612 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
613 /* L. HAGEMAN, D. YOUNG */
614 /* ACADEMIC PRESS, 1981 */
615 /* */
616 /* ************************************************** */
617 /* * IMPORTANT NOTE * */
618 /* * * */
619 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
620 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
621 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
622 /* * * */
623 /* * DRELPR MACHINE RELATIVE PRECISION * */
624 /* * RPARM(1) STOPPING CRITERION * */
625 /* * * */
626 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
627 /* * SECOND USED IN TIMER * */
628 /* * * */
629 /* ************************************************** */
630 /* */
631 /* SPECIFICATIONS FOR ARGUMENTS */
632 /* */
633 /* SPECIFICATIONS FOR LOCAL VARIABLES */
634 /* */
635 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
636 /* */
637 /* IN - ITERATION NUMBER */
638 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
639 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
640 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
641 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
642 /* NOUT - OUTPUT UNIT NUMBER */
643 /* */
644 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
645 /* */
646 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
647 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
648 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
649 /* HALT - STOPPING TEST SWITCH */
650 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
651 /* */
652 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
653 /* */
654 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
655 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
656 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
657 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
658 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
659 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
660 /* GAMMA - ACCELERATION PARAMETER */
661 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
662 /* QA - PSEUDO-RESIDUAL RATIO */
663 /* QT - VIRTUAL SPECTRAL RADIUS */
664 /* RHO - ACCELERATION PARAMETER */
665 /* RRR - ADAPTIVE PARAMETER */
666 /* SIGE - PARAMETER SIGMA-SUB-E */
667 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
668 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
669 /* DRELPR - MACHINE RELATIVE PRECISION */
670 /* STPTST - STOPPING PARAMETER */
671 /* UDNM - TWO NORM OF U */
672 /* ZETA - STOPPING CRITERION */
673
674 itcom1_1.level = iparm[1];
675 itcom1_1.nout = iparm[3];
676 ier = 0;
677 if (iparm[0] <= 0)
678 return 0;
679
680 if (iparm[10] == 0)
681 timj1 = (real)( dsrc_timer_((real*)0) );
682
683 if (itcom1_1.level < 3)
684 echout_(iparm, rparm, &c__2);
685 else
686 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
687 temp = itcom3_1.drelpr * 500.;
688 if (itcom3_1.zeta < temp)
689 itcom3_1.zeta = temp;
690
691 time1 = rparm[8];
692 time2 = rparm[9];
693 digit1 = rparm[10];
694 digit2 = rparm[11];
695
696 /* ... VERIFY N */
697
698 if (*n <= 0) {
699 ier = 21;
700 goto L360;
701 }
702
703 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
704
705 if (iparm[9] != 0) {
706 tol = rparm[7];
707 ivfill_(n, iwksp, &c__0);
708 vfill_(n, wksp, &c_b21);
709 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
710 if (ier != 0)
711 goto L360;
712 }
713
714 /* ... INITIALIZE WKSP BASE ADDRESSES. */
715
716 ib1 = 0;
717 ib2 = ib1 + *n;
718 ib3 = ib2 + *n;
719 iparm[7] = *n << 1;
720 if (*nw < iparm[7]) {
721 ier = 22;
722 goto L360;
723 }
724
725 /* ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED */
726
727 nb = iparm[8];
728 if (nb < 0)
729 goto L170;
730
731 n3 = *n * 3;
732 ivfill_(&n3, iwksp, &c__0);
733 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
734 if (ier != 0)
735 goto L360;
736
737 /* ... PERMUTE MATRIX AND RHS */
738
739 permat_(n, ia, ja, a, iwksp, &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
740 if (ier != 0)
741 goto L360;
742
743 pervec_(n, rhs, iwksp);
744 pervec_(n, u, iwksp);
745
746 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE DIAGONAL ELEMENTS. */
747
748 L170:
749 vfill_(&iparm[7], wksp, &c_b21);
750 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
751 if (ier != 0)
752 goto L360;
753
754 if (iparm[10] == 0)
755 {
756 timi1 = (real)( dsrc_timer_((real*)0) );
757 }
758
759 /* ... ITERATION SEQUENCE */
760
761 itmax1 = itcom1_1.itmax + 1;
762 for (loop = 1; loop <= itmax1; ++loop) {
763 itcom1_1.in = loop - 1;
764 if (itcom1_1.in % 2 == 1)
765 goto L230;
766
767 /* ... CODE FOR THE EVEN ITERATIONS. */
768
769 /* U = U(IN) */
770 /* WKSP(IB1) = U(IN-1) */
771
772 itjsi_(n, ia, ja, a, rhs, u, &wksp[ib1], &wksp[ib2], &icnt);
773
774 if (itcom2_1.halt)
775 goto L270;
776
777 continue;
778
779 /* ... CODE FOR THE ODD ITERATIONS. */
780
781 /* U = U(IN-1) */
782 /* WKSP(IB1) = U(IN) */
783
784 L230:
785 itjsi_(n, ia, ja, a, rhs, &wksp[ib1], u, &wksp[ib2], &icnt);
786
787 if (itcom2_1.halt)
788 goto L270;
789 }
790
791 /* ... ITMAX HAS BEEN REACHED */
792
793 if (iparm[10] == 0) {
794 timi2 = (real)( dsrc_timer_((real*)0) );
795 time1 = (doublereal) (timi2 - timi1);
796 }
797 ier = 23;
798 if (iparm[2] == 0)
799 rparm[0] = itcom3_1.stptst;
800
801 goto L300;
802
803 /* ... METHOD HAS CONVERGED */
804
805 L270:
806 if (iparm[10] == 0) {
807 timi2 = (real)( dsrc_timer_((real*)0) );
808 time1 = (doublereal) (timi2 - timi1);
809 }
810
811 /* ... PUT SOLUTION INTO U IF NOT ALREADY THERE. */
812
813 L300:
814 if (itcom1_1.in % 2 == 1)
815 itpackdcopy_(n, &wksp[ib1], &c__1, u, &c__1);
816
817 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
818
819 unscal_(n, ia, ja, a, rhs, u, wksp);
820
821 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
822
823 if (iparm[8] < 0)
824 goto L330;
825
826 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
827 if (ierper != 0) {
828 if (ier == 0)
829 ier = ierper;
830
831 goto L360;
832 }
833
834 pervec_(n, rhs, &iwksp[ib2]);
835 pervec_(n, u, &iwksp[ib2]);
836
837 /* ... OPTIONAL ERROR ANALYSIS */
838
839 L330:
840 idgts = iparm[11];
841 if (idgts >= 0) {
842 if (iparm[1] <= 0)
843 idgts = 0;
844
845 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
846 }
847
848 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
849
850 if (iparm[10] == 0) {
851 timj2 = (real)( dsrc_timer_((real*)0) );
852 time2 = (doublereal) (timj2 - timj1);
853 }
854 if (iparm[2] == 0) {
855 iparm[0] = itcom1_1.in;
856 iparm[8] = nb;
857 rparm[1] = itcom3_1.cme;
858 rparm[2] = itcom3_1.sme;
859 rparm[8] = time1;
860 rparm[9] = time2;
861 rparm[10] = digit1;
862 rparm[11] = digit2;
863 }
864
865 L360:
866 *ierr = ier;
867 if (itcom1_1.level >= 3)
868 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
869
870 return 0;
871 } /* jsi_ */
872
873 /* Subroutine */
sor_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)874 int sor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
875 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer* ierr)
876 {
877 /* Local variables */
878 static integer n3, nb, ib1, ib2, ib3, ier;
879 static doublereal tol;
880 static doublereal temp;
881 static integer loop;
882 static doublereal time1, time2;
883 static real timi1, timj1, timi2, timj2;
884 static integer idgts;
885 static doublereal digit1, digit2;
886 static integer itmax1;
887 static integer ierper;
888
889 /* ITPACK 2C MAIN SUBROUTINE SOR (SUCCESSIVE OVERRELATION) */
890 /* EACH OF THE MAIN SUBROUTINES: */
891 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
892 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
893
894 /* THIS SUBROUTINE, SOR, DRIVES THE SUCCESSIVE */
895 /* OVERRELAXATION ALGORITHM. */
896 /* */
897 /* ... PARAMETER LIST: */
898 /* */
899 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
900 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
901 /* THE SPARSE MATRIX REPRESENTATION. */
902 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
903 /* MATRIX REPRESENTATION */
904 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
905 /* OF THE MATRIX PROBLEM. */
906 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
907 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
908 /* THE LATEST ESTIMATE TO THE SOLUTION. */
909 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
910 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
911 /* IPARM(8) IS AMOUNT USED. */
912 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. SOR NEEDS THIS */
913 /* TO BE IN LENGTH AT LEAST N */
914 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
915 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. */
916 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
917 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
918 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
919 /* */
920 /* ... SOR SUBPROGRAM REFERENCES: */
921 /* */
922 /* FROM ITPACK BISRCH, DFAULT, ECHALL, ECHOUT, IPSTR, ITERM, */
923 /* TIMER, ITSOR, IVFILL, PERMAT, PERROR, */
924 /* PERVEC, PFSOR1, PMULT, PRBNDX, PSTOP, QSORT, */
925 /* SBELM, SCAL, DCOPY, DDOT, TAU, UNSCAL, VFILL, */
926 /* VOUT, WEVMW */
927 /* SYSTEM DABS, DLOG10, DBLE(AMAX0), DMAX1, DBLE(FLOAT), */
928 /* DSQRT */
929 /* */
930 /* VERSION: ITPACK 2C (MARCH 1982) */
931 /* */
932 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
933 /* CENTER FOR NUMERICAL ANALYSIS */
934 /* UNIVERSITY OF TEXAS */
935 /* AUSTIN, TX 78712 */
936 /* (512) 471-1242 */
937 /* */
938 /* FOR ADDITIONAL DETAILS ON THE */
939 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
940 /* (B) ALGORITHM SEE CNA REPORT 150 */
941 /* */
942 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
943 /* */
944 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
945 /* L. HAGEMAN, D. YOUNG */
946 /* ACADEMIC PRESS, 1981 */
947 /* */
948 /* ************************************************** */
949 /* * IMPORTANT NOTE * */
950 /* * * */
951 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
952 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
953 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
954 /* * * */
955 /* * DRELPR MACHINE RELATIVE PRECISION * */
956 /* * RPARM(1) STOPPING CRITERION * */
957 /* * * */
958 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
959 /* * SECOND USED IN TIMER * */
960 /* * * */
961 /* ************************************************** */
962 /* */
963 /* SPECIFICATIONS FOR ARGUMENTS */
964 /* */
965 /* SPECIFICATIONS FOR LOCAL VARIABLES */
966 /* */
967 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
968 /* */
969 /* IN - ITERATION NUMBER */
970 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
971 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
972 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
973 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
974 /* NOUT - OUTPUT UNIT NUMBER */
975 /* */
976 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
977 /* */
978 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
979 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
980 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
981 /* HALT - STOPPING TEST SWITCH */
982 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
983 /* */
984 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
985 /* */
986 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
987 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
988 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
989 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
990 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
991 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
992 /* GAMMA - ACCELERATION PARAMETER */
993 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
994 /* QA - PSEUDO-RESIDUAL RATIO */
995 /* QT - VIRTUAL SPECTRAL RADIUS */
996 /* RHO - ACCELERATION PARAMETER */
997 /* RRR - ADAPTIVE PARAMETER */
998 /* SIGE - PARAMETER SIGMA-SUB-E */
999 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
1000 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
1001 /* DRELPR - MACHINE RELATIVE PRECISION */
1002 /* STPTST - STOPPING PARAMETER */
1003 /* UDNM - TWO NORM OF U */
1004 /* ZETA - STOPPING CRITERION */
1005
1006 itcom1_1.level = iparm[1];
1007 itcom1_1.nout = iparm[3];
1008 ier = 0;
1009 if (iparm[0] <= 0)
1010 return 0;
1011
1012 if (iparm[10] == 0)
1013 {
1014 timj1 = (real)( dsrc_timer_((real*)0) );
1015 }
1016
1017 if (itcom1_1.level < 3)
1018 echout_(iparm, rparm, &c__3);
1019 else
1020 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
1021 temp = itcom3_1.drelpr * 500.;
1022 if (itcom3_1.zeta < temp)
1023 itcom3_1.zeta = temp;
1024
1025 time1 = rparm[8];
1026 time2 = rparm[9];
1027 digit1 = rparm[10];
1028 digit2 = rparm[11];
1029
1030 /* ... VERIFY N */
1031
1032 if (*n <= 0) {
1033 ier = 31;
1034 goto L360;
1035 }
1036
1037 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
1038
1039 if (iparm[9] != 0) {
1040 tol = rparm[7];
1041 ivfill_(n, iwksp, &c__0);
1042 vfill_(n, wksp, &c_b21);
1043 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
1044 if (ier != 0)
1045 goto L360;
1046 }
1047
1048 /* ... INITIALIZE WKSP BASE ADDRESSES. */
1049
1050 ib1 = 0;
1051 ib2 = ib1 + *n;
1052 ib3 = ib2 + *n;
1053 iparm[7] = *n;
1054 if (*nw < iparm[7]) {
1055 ier = 32;
1056 goto L360;
1057 }
1058
1059 /* ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED */
1060
1061 nb = iparm[8];
1062 if (nb < 0)
1063 goto L170;
1064
1065 n3 = *n * 3;
1066 ivfill_(&n3, iwksp, &c__0);
1067 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
1068 if (ier != 0)
1069 goto L360;
1070
1071 /* ... PERMUTE MATRIX AND RHS */
1072
1073 permat_(n, ia, ja, a, iwksp, &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
1074 if (ier != 0)
1075 goto L360;
1076
1077 pervec_(n, rhs, iwksp);
1078 pervec_(n, u, iwksp);
1079
1080 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE */
1081 /* ... DIAGONAL ELEMENTS. */
1082
1083 L170:
1084 vfill_(&iparm[7], wksp, &c_b21);
1085 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
1086 if (ier != 0)
1087 goto L360;
1088
1089 if (iparm[10] == 0)
1090 timi1 = (real)( dsrc_timer_((real*)0) );
1091
1092 /* ... ITERATION SEQUENCE */
1093
1094 itmax1 = itcom1_1.itmax + 1;
1095 for (loop = 1; loop <= itmax1; ++loop) {
1096 itcom1_1.in = loop - 1;
1097
1098 /* ... CODE FOR ONE ITERATION. */
1099
1100 /* U = U(IN) */
1101
1102 itsor_(n, ia, ja, a, rhs, u, &wksp[ib1]);
1103
1104 if (itcom2_1.halt)
1105 goto L270;
1106 }
1107
1108 /* ... ITMAX HAS BEEN REACHED */
1109
1110 if (iparm[10] == 0) {
1111 timi2 = (real)( dsrc_timer_((real*)0) );
1112 time1 = (doublereal) (timi2 - timi1);
1113 }
1114 ier = 33;
1115 if (iparm[2] == 0)
1116 rparm[0] = itcom3_1.stptst;
1117
1118 goto L300;
1119
1120 /* ... METHOD HAS CONVERGED */
1121
1122 L270:
1123 if (iparm[10] == 0) {
1124 timi2 = (real)( dsrc_timer_((real*)0) );
1125 time1 = (doublereal) (timi2 - timi1);
1126 }
1127
1128 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
1129
1130 L300:
1131 unscal_(n, ia, ja, a, rhs, u, wksp);
1132
1133 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
1134
1135 if (iparm[8] < 0)
1136 goto L330;
1137
1138 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
1139 if (ierper != 0) {
1140 if (ier == 0)
1141 ier = ierper;
1142
1143 goto L360;
1144 }
1145
1146 pervec_(n, rhs, &iwksp[ib2]);
1147 pervec_(n, u, &iwksp[ib2]);
1148
1149 /* ... OPTIONAL ERROR ANALYSIS */
1150
1151 L330:
1152 idgts = iparm[11];
1153 if (idgts >= 0) {
1154 if (iparm[1] <= 0)
1155 idgts = 0;
1156
1157 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
1158 }
1159
1160 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
1161
1162 if (iparm[10] == 0) {
1163 timj2 = (real)( dsrc_timer_((real*)0) );
1164 time2 = (doublereal) (timj2 - timj1);
1165 }
1166 if (iparm[2] == 0) {
1167 iparm[0] = itcom1_1.in;
1168 iparm[8] = nb;
1169 rparm[1] = itcom3_1.cme;
1170 rparm[2] = itcom3_1.sme;
1171 rparm[4] = itcom3_1.omega;
1172 rparm[8] = time1;
1173 rparm[9] = time2;
1174 rparm[10] = digit1;
1175 rparm[11] = digit2;
1176 }
1177
1178 L360:
1179 *ierr = ier;
1180 if (itcom1_1.level >= 3)
1181 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
1182
1183 return 0;
1184 } /* sor_ */
1185
1186 /* Subroutine */
ssorcg_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)1187 int ssorcg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
1188 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer* ierr)
1189 {
1190 /* Local variables */
1191 static integer n3, nb, ib1, ib2, ib3, ib4, ib5, ib6, ib7, ier;
1192 static doublereal tol;
1193 static doublereal temp;
1194 static integer loop;
1195 static doublereal time1, time2;
1196 static real timi1, timj1, timi2, timj2;
1197 static integer idgts;
1198 static doublereal digit1, digit2;
1199 static integer itmax1;
1200 static doublereal betnew;
1201 static integer ierper;
1202
1203 /* ITPACK 2C MAIN SUBROUTINE SSORCG (SYMMETRIC SUCCESSIVE OVER- */
1204 /* RELAXATION CONJUGATE GRADIENT) */
1205 /* EACH OF THE MAIN SUBROUTINES: */
1206 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
1207 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
1208
1209 /* THIS SUBROUTINE, SSORCG, DRIVES THE SYMMETRIC SOR-CG */
1210 /* ALGORITHM. */
1211 /* */
1212 /* ... PARAMETER LIST: */
1213 /* */
1214 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
1215 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
1216 /* THE SPARSE MATRIX REPRESENTATION. */
1217 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
1218 /* MATRIX REPRESENTATION. */
1219 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
1220 /* OF THE MATRIX PROBLEM. */
1221 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
1222 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
1223 /* THE LATEST ESTIMATE TO THE SOLUTION. */
1224 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
1225 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
1226 /* IPARM(8) IS AMOUNT USED. */
1227 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. SSOR-CG */
1228 /* NEEDS TO BE IN LENGTH AT LEAST */
1229 /* 6*N + 2*ITMAX, IF IPARM(5)=0 (SYMMETRIC STORAGE) */
1230 /* 6*N + 4*ITMAX, IF IPARM(5)=1 (NONSYMMETRIC STORAGE) */
1231 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
1232 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF */
1233 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
1234 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
1235 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
1236 /* */
1237 /* ... SSORCG SUBPROGRAM REFERENCES: */
1238 /* */
1239 /* FROM ITPACK BISRCH, CHGCON, DETERM, DFAULT, ECHALL, */
1240 /* ECHOUT, EIGVNS, EIGVSS, EQRT1S, ITERM, TIMER, */
1241 /* ITSRCG, IVFILL, OMEG, OMGCHG, OMGSTR, */
1242 /* PARCON, PBETA, PBSOR, PERMAT, PERROR, */
1243 /* PERVEC, PFSOR, PJAC, PMULT, PRBNDX, PSTOP, PVT */
1244 /* QSORT, SBELM, SCAL, DCOPY, DDOT, SUM3, */
1245 /* UNSCAL, VEVMW, VEVPW, VFILL, VOUT, WEVMW, */
1246 /* ZBRENT */
1247 /* SYSTEM DABS, DLOG, DLOG10, DBLE(AMAX0), DMAX1, AMIN1, */
1248 /* MOD, DSQRT */
1249 /* */
1250 /* VERSION: ITPACK 2C (MARCH 1982) */
1251 /* */
1252 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
1253 /* CENTER FOR NUMERICAL ANALYSIS */
1254 /* UNIVERSITY OF TEXAS */
1255 /* AUSTIN, TX 78712 */
1256 /* (512) 471-1242 */
1257 /* */
1258 /* FOR ADDITIONAL DETAILS ON THE */
1259 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
1260 /* (B) ALGORITHM SEE CNA REPORT 150 */
1261 /* */
1262 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
1263 /* */
1264 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
1265 /* L. HAGEMAN, D. YOUNG */
1266 /* ACADEMIC PRESS, 1981 */
1267 /* */
1268 /* ************************************************** */
1269 /* * IMPORTANT NOTE * */
1270 /* * * */
1271 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
1272 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
1273 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
1274 /* * * */
1275 /* * DRELPR MACHINE RELATIVE PRECISION * */
1276 /* * RPARM(1) STOPPING CRITERION * */
1277 /* * * */
1278 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
1279 /* * SECOND USED IN TIMER * */
1280 /* * * */
1281 /* ************************************************** */
1282 /* */
1283 /* SPECIFICATIONS FOR ARGUMENTS */
1284 /* */
1285 /* SPECIFICATIONS FOR LOCAL VARIABLES */
1286 /* */
1287 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
1288 /* */
1289 /* IN - ITERATION NUMBER */
1290 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
1291 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
1292 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
1293 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
1294 /* NOUT - OUTPUT UNIT NUMBER */
1295 /* */
1296 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
1297 /* */
1298 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
1299 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
1300 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
1301 /* HALT - STOPPING TEST SWITCH */
1302 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
1303 /* */
1304 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
1305 /* */
1306 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
1307 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
1308 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
1309 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
1310 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
1311 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
1312 /* GAMMA - ACCELERATION PARAMETER */
1313 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
1314 /* QA - PSEUDO-RESIDUAL RATIO */
1315 /* QT - VIRTUAL SPECTRAL RADIUS */
1316 /* RHO - ACCELERATION PARAMETER */
1317 /* RRR - ADAPTIVE PARAMETER */
1318 /* SIGE - PARAMETER SIGMA-SUB-E */
1319 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
1320 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
1321 /* DRELPR - MACHINE RELATIVE PRECISION */
1322 /* STPTST - STOPPING PARAMETER */
1323 /* UDNM - TWO NORM OF U */
1324 /* ZETA - STOPPING CRITERION */
1325
1326 itcom1_1.level = iparm[1];
1327 itcom1_1.nout = iparm[3];
1328 if (iparm[8] >= 0)
1329 iparm[5] = 2;
1330
1331 ier = 0;
1332 if (iparm[0] <= 0)
1333 return 0;
1334
1335 if (iparm[10] == 0)
1336 timj1 = (real)( dsrc_timer_((real*)0) );
1337
1338 if (itcom1_1.level < 3)
1339 echout_(iparm, rparm, &c__4);
1340 else
1341 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
1342 temp = itcom3_1.drelpr * 500.;
1343 if (itcom3_1.zeta < temp)
1344 itcom3_1.zeta = temp;
1345
1346 time1 = rparm[8];
1347 time2 = rparm[9];
1348 digit1 = rparm[10];
1349 digit2 = rparm[11];
1350
1351 /* ... VERIFY N */
1352
1353 if (*n <= 0) {
1354 ier = 41;
1355 goto L390;
1356 }
1357
1358 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
1359
1360 if (iparm[9] != 0) {
1361 tol = rparm[7];
1362 ivfill_(n, iwksp, &c__0);
1363 vfill_(n, wksp, &c_b21);
1364 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
1365 if (ier != 0)
1366 goto L390;
1367 }
1368
1369 /* ... INITIALIZE WKSP BASE ADDRESSES. */
1370
1371 ib1 = 0;
1372 ib2 = ib1 + *n;
1373 ib3 = ib2 + *n;
1374 ib4 = ib3 + *n;
1375 ib5 = ib4 + *n;
1376 ib6 = ib5 + *n;
1377 ib7 = ib6 + *n;
1378 iparm[7] = *n * 6 + (itcom1_1.itmax << 1);
1379 if (itcom1_1.isym != 0)
1380 iparm[7] += itcom1_1.itmax << 1;
1381
1382 if (*nw < iparm[7]) {
1383 ier = 42;
1384 goto L390;
1385 }
1386
1387 /* ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED */
1388
1389 nb = iparm[8];
1390 if (nb < 0)
1391 goto L170;
1392
1393 n3 = *n * 3;
1394 ivfill_(&n3, iwksp, &c__0);
1395 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
1396 if (ier != 0)
1397 goto L390;
1398
1399 /* ... PERMUTE MATRIX AND RHS */
1400
1401 permat_(n, ia, ja, a, iwksp, &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
1402 if (ier != 0)
1403 goto L390;
1404
1405 pervec_(n, rhs, iwksp);
1406 pervec_(n, u, iwksp);
1407
1408 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE */
1409 /* ... DIAGONAL ELEMENTS. */
1410
1411 L170:
1412 vfill_(&iparm[7], wksp, &c_b21);
1413 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
1414 if (ier != 0)
1415 goto L390;
1416
1417 if (iparm[10] == 0)
1418 timi1 = (real)( dsrc_timer_((real*)0) );
1419
1420 /* ... SPECIAL PROCEDURE FOR FULLY ADAPTIVE CASE. */
1421
1422 if (! itcom2_1.adapt)
1423 goto L250;
1424
1425 if (itcom2_1.betadt) {
1426 vfill_(n, &wksp[ib1], &c_b286);
1427 betnew = pbeta_(n, ia, ja, a, &wksp[ib1], &wksp[ib2], &wksp[ib3]) / (doublereal)(*n);
1428 itcom3_1.betab = max(max(itcom3_1.betab,.25),betnew);
1429 }
1430
1431 omeg_(&c_b21, &c__1);
1432 itcom1_1.is = 0;
1433
1434 /* ... INITIALIZE FORWARD PSEUDO-RESIDUAL */
1435
1436 L250:
1437 itpackdcopy_(n, rhs, &c__1, &wksp[ib1], &c__1);
1438 itpackdcopy_(n, u, &c__1, &wksp[ib2], &c__1);
1439 pfsor_(n, ia, ja, a, &wksp[ib2], &wksp[ib1]);
1440 vevmw_(n, &wksp[ib2], u);
1441
1442 /* ... ITERATION SEQUENCE */
1443
1444 itmax1 = itcom1_1.itmax + 1;
1445 for (loop = 1; loop <= itmax1; ++loop) {
1446 itcom1_1.in = loop - 1;
1447 if (itcom1_1.in % 2 == 1)
1448 goto L260;
1449
1450 /* ... CODE FOR THE EVEN ITERATIONS. */
1451
1452 /* U = U(IN) WKSP(IB2) = C(IN) */
1453 /* WKSP(IB1) = U(IN-1) WKSP(IB3) = C(IN-1) */
1454
1455 itsrcg_(n, ia, ja, a, rhs, u, &wksp[ib1], &wksp[ib2], &wksp[ib3], &wksp[ib4], &wksp[ib5], &wksp[ib6], &wksp[ib7]);
1456
1457 if (itcom2_1.halt)
1458 goto L300;
1459
1460 continue;
1461
1462 /* ... CODE FOR THE ODD ITERATIONS. */
1463
1464 /* U = U(IN-1) WKSP(IB2) = C(IN-1) */
1465 /* WKSP(IB1) = U(IN) WKSP(IB3) =C(IN) */
1466
1467 L260:
1468 itsrcg_(n, ia, ja, a, rhs, &wksp[ib1], u, &wksp[ib3], &wksp[ib2], &wksp[ib4], &wksp[ib5], &wksp[ib6], &wksp[ib7]);
1469
1470 if (itcom2_1.halt)
1471 goto L300;
1472 }
1473
1474 /* ... ITMAX HAS BEEN REACHED */
1475
1476 if (iparm[10] == 0) {
1477 timi2 = (real)( dsrc_timer_((real*)0) );
1478 time1 = (doublereal) (timi2 - timi1);
1479 }
1480 ier = 43;
1481 if (iparm[2] == 0)
1482 rparm[0] = itcom3_1.stptst;
1483
1484 goto L330;
1485
1486 /* ... METHOD HAS CONVERGED */
1487
1488 L300:
1489 if (iparm[10] == 0) {
1490 timi2 = (real)( dsrc_timer_((real*)0) );
1491 time1 = (doublereal) (timi2 - timi1);
1492 }
1493
1494 /* ... PUT SOLUTION INTO U IF NOT ALREADY THERE. */
1495
1496 L330:
1497 if (itcom1_1.in % 2 == 1)
1498 itpackdcopy_(n, &wksp[ib1], &c__1, u, &c__1);
1499
1500 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
1501
1502 unscal_(n, ia, ja, a, rhs, u, wksp);
1503
1504 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
1505
1506 if (iparm[8] < 0)
1507 goto L360;
1508
1509 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
1510 if (ierper != 0) {
1511 if (ier == 0)
1512 ier = ierper;
1513
1514 goto L390;
1515 }
1516
1517 pervec_(n, rhs, &iwksp[ib2]);
1518 pervec_(n, u, &iwksp[ib2]);
1519
1520 /* ... OPTIONAL ERROR ANALYSIS */
1521
1522 L360:
1523 idgts = iparm[11];
1524 if (idgts >= 0) {
1525 if (iparm[1] <= 0)
1526 idgts = 0;
1527
1528 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
1529 }
1530
1531 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
1532
1533 if (iparm[10] == 0) {
1534 timj2 = (real)( dsrc_timer_((real*)0) );
1535 time2 = (doublereal) (timj2 - timj1);
1536 }
1537 iparm[7] -= (itcom1_1.itmax - itcom1_1.in) << 1;
1538 if (itcom1_1.isym != 0)
1539 iparm[7] -= (itcom1_1.itmax - itcom1_1.in) << 1;
1540
1541 if (iparm[2] == 0) {
1542 iparm[0] = itcom1_1.in;
1543 iparm[8] = nb;
1544 rparm[1] = itcom3_1.cme;
1545 rparm[2] = itcom3_1.sme;
1546 rparm[4] = itcom3_1.omega;
1547 rparm[5] = itcom3_1.specr;
1548 rparm[6] = itcom3_1.betab;
1549 rparm[8] = time1;
1550 rparm[9] = time2;
1551 rparm[10] = digit1;
1552 rparm[11] = digit2;
1553 }
1554
1555 L390:
1556 *ierr = ier;
1557 if (itcom1_1.level >= 3)
1558 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
1559
1560 return 0;
1561 } /* ssorcg_ */
1562
1563 /* Subroutine */
ssorsi_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)1564 int ssorsi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
1565 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer* ierr)
1566 {
1567 /* Local variables */
1568 static integer n3, nb, ib1, ib2, ib3, ib4, ib5, ier;
1569 static doublereal tol;
1570 static doublereal temp;
1571 static integer loop;
1572 static doublereal time1, time2;
1573 static real timi1, timj1, timi2, timj2;
1574 static integer idgts;
1575 static doublereal digit1, digit2;
1576 static integer itmax1;
1577 static doublereal betnew;
1578 static integer ierper;
1579
1580 /* ITPACK 2C MAIN SUBROUTINE SSORSI (SYMMETRIC SUCCESSIVE RELAX- */
1581 /* ATION SEMI-ITERATION) */
1582 /* EACH OF THE MAIN SUBROUTINES: */
1583 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
1584 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
1585
1586 /* THIS SUBROUTINE, SSORSI, DRIVES THE SYMMETRIC SOR-SI */
1587 /* ALGORITHM. */
1588 /* */
1589 /* ... PARAMETER LIST: */
1590 /* */
1591 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
1592 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
1593 /* THE SPARSE MATRIX REPRESENTATION. */
1594 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
1595 /* MATRIX REPRESENTATION. */
1596 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
1597 /* OF THE MATRIX PROBLEM. */
1598 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
1599 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
1600 /* THE LATEST ESTIMATE TO THE SOLUTION. */
1601 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
1602 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
1603 /* IPARM(8) IS AMOUNT USED. */
1604 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. SSORSI */
1605 /* NEEDS THIS TO BE IN LENGTH AT LEAST 5*N */
1606 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
1607 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF */
1608 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
1609 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
1610 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
1611 /* */
1612 /* ... SSORSI SUBPROGRAM REFERENCES: */
1613 /* */
1614 /* FROM ITPACK BISRCH, CHEBY, CHGSI, DFAULT, ECHALL, ECHOUT, */
1615 /* ITERM, TIMER, ITSRSI, IVFILL, OMEG, */
1616 /* OMGSTR, PARSI, PBETA, PERMAT, PERROR, */
1617 /* PERVEC, PFSOR, PMULT, PRBNDX, PSSOR1, */
1618 /* PSTOP, PVTBV, QSORT, SBELM, SCAL, DCOPY, */
1619 /* DDOT, SUM3, TSTCHG, UNSCAL, VEVPW, VFILL, */
1620 /* VOUT, WEVMW */
1621 /* SYSTEM DABS, DLOG, DLOG10, DBLE(AMAX0), DMAX1, */
1622 /* DBLE(FMOD), DSQRT */
1623 /* */
1624 /* VERSION: ITPACK 2C (MARCH 1982) */
1625 /* */
1626 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
1627 /* CENTER FOR NUMERICAL ANALYSIS */
1628 /* UNIVERSITY OF TEXAS */
1629 /* AUSTIN, TX 78712 */
1630 /* (512) 471-1242 */
1631 /* */
1632 /* FOR ADDITIONAL DETAILS ON THE */
1633 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
1634 /* (B) ALGORITHM SEE CNA REPORT 150 */
1635 /* */
1636 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
1637 /* */
1638 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
1639 /* L. HAGEMAN, D. YOUNG */
1640 /* ACADEMIC PRESS, 1981 */
1641 /* */
1642 /* ************************************************** */
1643 /* * IMPORTANT NOTE * */
1644 /* * * */
1645 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
1646 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
1647 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
1648 /* * * */
1649 /* * DRELPR MACHINE RELATIVE PRECISION * */
1650 /* * RPARM(1) STOPPING CRITERION * */
1651 /* * * */
1652 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
1653 /* * SECOND USED IN TIMER * */
1654 /* * * */
1655 /* ************************************************** */
1656 /* */
1657 /* SPECIFICATIONS FOR ARGUMENTS */
1658 /* */
1659 /* SPECIFICATIONS FOR LOCAL VARIABLES */
1660 /* */
1661 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
1662 /* */
1663 /* IN - ITERATION NUMBER */
1664 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
1665 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
1666 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
1667 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
1668 /* NOUT - OUTPUT UNIT NUMBER */
1669 /* */
1670 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
1671 /* */
1672 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
1673 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
1674 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
1675 /* HALT - STOPPING TEST SWITCH */
1676 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
1677 /* */
1678 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
1679 /* */
1680 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
1681 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
1682 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
1683 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
1684 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
1685 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
1686 /* GAMMA - ACCELERATION PARAMETER */
1687 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
1688 /* QA - PSEUDO-RESIDUAL RATIO */
1689 /* QT - VIRTUAL SPECTRAL RADIUS */
1690 /* RHO - ACCELERATION PARAMETER */
1691 /* RRR - ADAPTIVE PARAMETER */
1692 /* SIGE - PARAMETER SIGMA-SUB-E */
1693 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
1694 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
1695 /* DRELPR - MACHINE RELATIVE PRECISION */
1696 /* STPTST - STOPPING PARAMETER */
1697 /* UDNM - TWO NORM OF U */
1698 /* ZETA - STOPPING CRITERION */
1699
1700 itcom1_1.level = iparm[1];
1701 itcom1_1.nout = iparm[3];
1702 if (iparm[8] >= 0)
1703 iparm[5] = 2;
1704
1705 ier = 0;
1706 if (iparm[0] <= 0)
1707 return 0;
1708
1709 if (iparm[10] == 0)
1710 timj1 = (real)( dsrc_timer_((real*)0) );
1711
1712 if (itcom1_1.level < 3)
1713 echout_(iparm, rparm, &c__5);
1714 else
1715 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
1716 temp = itcom3_1.drelpr * 500.;
1717 if (itcom3_1.zeta < temp)
1718 itcom3_1.zeta = temp;
1719
1720 time1 = rparm[8];
1721 time2 = rparm[9];
1722 digit1 = rparm[10];
1723 digit2 = rparm[11];
1724
1725 /* ... VERIFY N */
1726
1727 if (*n <= 0) {
1728 ier = 51;
1729 goto L380;
1730 }
1731
1732 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
1733
1734 if (iparm[9] != 0) {
1735 tol = rparm[7];
1736 ivfill_(n, iwksp, &c__0);
1737 vfill_(n, wksp, &c_b21);
1738 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
1739 if (ier != 0)
1740 goto L380;
1741 }
1742
1743 /* ... INITIALIZE WKSP BASE ADDRESSES. */
1744
1745 ib1 = 0;
1746 ib2 = ib1 + *n;
1747 ib3 = ib2 + *n;
1748 ib4 = ib3 + *n;
1749 ib5 = ib4 + *n;
1750 iparm[7] = *n * 5;
1751 if (*nw < iparm[7])
1752 ier = 52;
1753
1754 /* ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED */
1755
1756 nb = iparm[8];
1757 if (nb < 0)
1758 goto L170;
1759
1760 n3 = *n * 3;
1761 ivfill_(&n3, iwksp, &c__0);
1762 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
1763 if (ier != 0)
1764 goto L380;
1765
1766 /* ... PERMUTE MATRIX AND RHS */
1767
1768 permat_(n, ia, ja, a, iwksp, &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
1769 if (ier != 0)
1770 goto L380;
1771
1772 pervec_(n, rhs, iwksp);
1773 pervec_(n, u, iwksp);
1774
1775 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE */
1776 /* ... DIAGONAL ELEMENTS. */
1777
1778 L170:
1779 vfill_(&iparm[7], wksp, &c_b21);
1780 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
1781 if (ier != 0)
1782 goto L380;
1783
1784 if (iparm[10] == 0)
1785 timi1 = (real)( dsrc_timer_((real*)0) );
1786
1787 /* ... SPECIAL PROCEDURE FOR FULLY ADAPTIVE CASE. */
1788
1789 if (! itcom2_1.adapt)
1790 goto L240;
1791
1792 if (itcom2_1.betadt) {
1793 vfill_(n, &wksp[ib1], &c_b286);
1794 betnew = pbeta_(n, ia, ja, a, &wksp[ib1], &wksp[ib2], &wksp[ib3]) / (doublereal)(*n);
1795 itcom3_1.betab = max(max(itcom3_1.betab,.25),betnew);
1796 }
1797
1798 omeg_(&c_b21, &c__1);
1799 itcom1_1.is = 0;
1800
1801 /* ... ITERATION SEQUENCE */
1802
1803 L240:
1804 itmax1 = itcom1_1.itmax + 1;
1805 for (loop = 1; loop <= itmax1; ++loop) {
1806 itcom1_1.in = loop - 1;
1807 if (itcom1_1.in % 2 == 1)
1808 goto L250;
1809
1810 /* ... CODE FOR THE EVEN ITERATIONS. */
1811
1812 /* U = U(IN) */
1813 /* WKSP(IB1) = U(IN-1) */
1814
1815 itsrsi_(n, ia, ja, a, rhs, u, &wksp[ib1], &wksp[ib2], &wksp[ib3], &wksp[ib4], &wksp[ib5]);
1816
1817 if (itcom2_1.halt)
1818 goto L290;
1819
1820 continue;
1821
1822 /* ... CODE FOR THE ODD ITERATIONS. */
1823
1824 /* U = U(IN-1) */
1825 /* WKSP(IB1) = U(IN) */
1826
1827 L250:
1828 itsrsi_(n, ia, ja, a, rhs, &wksp[ib1], u, &wksp[ib2], &wksp[ib3], &wksp[ib4], &wksp[ib5]);
1829
1830 if (itcom2_1.halt)
1831 goto L290;
1832 }
1833
1834 /* ... ITMAX HAS BEEN REACHED */
1835
1836 if (iparm[10] == 0) {
1837 timi2 = (real)( dsrc_timer_((real*)0) );
1838 time1 = (doublereal) (timi2 - timi1);
1839 }
1840 ier = 53;
1841 if (iparm[2] == 0)
1842 rparm[0] = itcom3_1.stptst;
1843
1844 goto L320;
1845
1846 /* ... METHOD HAS CONVERGED */
1847
1848 L290:
1849 if (iparm[10] == 0) {
1850 timi2 = (real)( dsrc_timer_((real*)0) );
1851 time1 = (doublereal) (timi2 - timi1);
1852 }
1853
1854 /* ... PUT SOLUTION INTO U IF NOT ALREADY THERE. */
1855
1856 L320:
1857 if (itcom1_1.in % 2 == 1)
1858 itpackdcopy_(n, &wksp[ib1], &c__1, u, &c__1);
1859
1860 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
1861
1862 unscal_(n, ia, ja, a, rhs, u, wksp);
1863
1864 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
1865
1866 if (iparm[8] < 0)
1867 goto L350;
1868
1869 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[ib3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
1870 if (ierper != 0) {
1871 if (ier == 0)
1872 ier = ierper;
1873
1874 goto L380;
1875 }
1876
1877 pervec_(n, rhs, &iwksp[ib2]);
1878 pervec_(n, u, &iwksp[ib2]);
1879
1880 /* ... OPTIONAL ERROR ANALYSIS */
1881
1882 L350:
1883 idgts = iparm[11];
1884 if (idgts >= 0) {
1885 if (iparm[1] <= 0)
1886 idgts = 0;
1887
1888 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
1889 }
1890
1891 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
1892
1893 if (iparm[10] == 0) {
1894 timj2 = (real)( dsrc_timer_((real*)0) );
1895 time2 = (doublereal) (timj2 - timj1);
1896 }
1897 if (iparm[2] == 0) {
1898 iparm[0] = itcom1_1.in;
1899 iparm[8] = nb;
1900 rparm[1] = itcom3_1.cme;
1901 rparm[2] = itcom3_1.sme;
1902 rparm[4] = itcom3_1.omega;
1903 rparm[5] = itcom3_1.specr;
1904 rparm[6] = itcom3_1.betab;
1905 rparm[8] = time1;
1906 rparm[9] = time2;
1907 rparm[10] = digit1;
1908 rparm[11] = digit2;
1909 }
1910
1911 L380:
1912 *ierr = ier;
1913 if (itcom1_1.level >= 3)
1914 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
1915
1916 return 0;
1917 } /* ssorsi_ */
1918
1919 /* Subroutine */
rscg_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)1920 int rscg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
1921 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer* ierr)
1922 {
1923 /* Local variables */
1924 static integer n3, nb, nr, ib1, ib2, ib3, ib4, ib5, jb3, ier;
1925 static doublereal tol;
1926 static doublereal temp;
1927 static integer loop;
1928 static doublereal time1, time2;
1929 static real timi1, timj1, timi2, timj2;
1930 static integer idgts;
1931 static doublereal digit1, digit2;
1932 static integer itmax1;
1933 static integer ierper;
1934
1935 /* ITPACK 2C MAIN SUBROUTINE RSCG (REDUCED SYSTEM CONJUGATE */
1936 /* GRADIENT) */
1937 /* EACH OF THE MAIN SUBROUTINES: */
1938 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
1939 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
1940
1941 /* THIS SUBROUTINE, RSCG, DRIVES THE REDUCED SYSTEM CG */
1942 /* ALGORITHM. */
1943 /* */
1944 /* ... PARAMETER LIST: */
1945 /* */
1946 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
1947 /* IN THE RED-BLACK MATRIX. */
1948 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
1949 /* THE SPARSE MATRIX REPRESENTATION. */
1950 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
1951 /* MATRIX REPRESENTATION. */
1952 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
1953 /* OF THE MATRIX PROBLEM. */
1954 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
1955 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
1956 /* THE LATEST ESTIMATE TO THE SOLUTION. */
1957 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
1958 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
1959 /* IPARM(8) IS AMOUNT USED. */
1960 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. RSCG NEEDS */
1961 /* THIS TO BE IN LENGTH AT LEAST */
1962 /* N+3*NB+2*ITMAX, IF IPARM(5)=0 (SYMMETRIC STORAGE) */
1963 /* N+3*NB+4*ITMAX, IF IPARM(5)=1 (NONSYMMETRIC STORAGE) */
1964 /* HERE NB IS THE ORDER OF THE BLACK SUBSYSTEM */
1965 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
1966 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF */
1967 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
1968 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
1969 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
1970 /* */
1971 /* ... RSCG SUBPROGRAM REFERENCES: */
1972 /* */
1973 /* FROM ITPACK BISRCH, CHGCON, DETERM, DFAULT, ECHALL, */
1974 /* ECHOUT, EIGVNS, EIGVSS, EQRT1S, ITERM, TIMER */
1975 /* ITRSCG, IVFILL, PARCON, PERMAT, */
1976 /* PERROR, PERVEC, PMULT, PRBNDX, PRSBLK, */
1977 /* PRSRED, PSTOP, QSORT, SBELM, SCAL, DCOPY, */
1978 /* DDOT, SUM3, UNSCAL, VFILL, VOUT, WEVMW, */
1979 /* ZBRENT */
1980 /* SYSTEM DABS, DLOG10, DBLE(AMAX0), DMAX1, MOD, DSQRT */
1981 /* */
1982 /* VERSION: ITPACK 2C (MARCH 1982) */
1983 /* */
1984 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
1985 /* CENTER FOR NUMERICAL ANALYSIS */
1986 /* UNIVERSITY OF TEXAS */
1987 /* AUSTIN, TX 78712 */
1988 /* (512) 471-1242 */
1989 /* */
1990 /* FOR ADDITIONAL DETAILS ON THE */
1991 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
1992 /* (B) ALGORITHM SEE CNA REPORT 150 */
1993 /* */
1994 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
1995 /* */
1996 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
1997 /* L. HAGEMAN, D. YOUNG */
1998 /* ACADEMIC PRESS, 1981 */
1999 /* */
2000 /* ************************************************** */
2001 /* * IMPORTANT NOTE * */
2002 /* * * */
2003 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
2004 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
2005 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
2006 /* * * */
2007 /* * DRELPR MACHINE RELATIVE PRECISION * */
2008 /* * RPARM(1) STOPPING CRITERION * */
2009 /* * * */
2010 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
2011 /* * SECOND USED IN TIMER * */
2012 /* * * */
2013 /* ************************************************** */
2014 /* */
2015 /* SPECIFICATIONS FOR ARGUMENTS */
2016 /* */
2017 /* SPECIFICATIONS FOR LOCAL VARIABLES */
2018 /* */
2019 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
2020 /* */
2021 /* IN - ITERATION NUMBER */
2022 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
2023 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
2024 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
2025 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
2026 /* NOUT - OUTPUT UNIT NUMBER */
2027 /* */
2028 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
2029 /* */
2030 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
2031 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
2032 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
2033 /* HALT - STOPPING TEST SWITCH */
2034 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
2035 /* */
2036 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
2037 /* */
2038 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
2039 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
2040 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
2041 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
2042 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
2043 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
2044 /* GAMMA - ACCELERATION PARAMETER */
2045 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
2046 /* QA - PSEUDO-RESIDUAL RATIO */
2047 /* QT - VIRTUAL SPECTRAL RADIUS */
2048 /* RHO - ACCELERATION PARAMETER */
2049 /* RRR - ADAPTIVE PARAMETER */
2050 /* SIGE - PARAMETER SIGMA-SUB-E */
2051 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
2052 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
2053 /* DRELPR - MACHINE RELATIVE PRECISION */
2054 /* STPTST - STOPPING PARAMETER */
2055 /* UDNM - TWO NORM OF U */
2056 /* ZETA - STOPPING CRITERION */
2057
2058 itcom1_1.level = iparm[1];
2059 itcom1_1.nout = iparm[3];
2060 ier = 0;
2061 if (iparm[0] <= 0)
2062 return 0;
2063
2064 if (iparm[10] == 0)
2065 timj1 = (real)( dsrc_timer_((real*)0) );
2066
2067 if (itcom1_1.level < 3)
2068 echout_(iparm, rparm, &c__6);
2069 else
2070 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
2071 temp = itcom3_1.drelpr * 500.;
2072 if (itcom3_1.zeta < temp)
2073 itcom3_1.zeta = temp;
2074
2075 time1 = rparm[8];
2076 time2 = rparm[9];
2077 digit1 = rparm[10];
2078 digit2 = rparm[11];
2079
2080 /* ... VERIFY N */
2081
2082 if (*n <= 0) {
2083 ier = 61;
2084 goto L430;
2085 }
2086
2087 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
2088
2089 if (iparm[9] != 0) {
2090 tol = rparm[7];
2091 ivfill_(n, iwksp, &c__0);
2092 vfill_(n, wksp, &c_b21);
2093 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
2094 if (ier != 0)
2095 goto L430;
2096 }
2097
2098 /* ... INITIALIZE WKSP BASE ADDRESSES. */
2099
2100 ib1 = 0;
2101 ib2 = ib1 + *n;
2102 jb3 = ib2 + *n;
2103
2104 /* ... PERMUTE TO RED-BLACK SYSTEM IF POSSIBLE */
2105
2106 nb = iparm[8];
2107 if (nb < 0) {
2108 n3 = *n * 3;
2109 ivfill_(&n3, iwksp, &c__0);
2110 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
2111 if (ier != 0)
2112 goto L430;
2113 }
2114
2115 if (nb < 0 || nb > *n) {
2116 ier = 64;
2117 goto L430;
2118 }
2119 if (nb == 0 || nb == *n)
2120 nb = *n / 2;
2121
2122 /* ... PERMUTE MATRIX AND RHS */
2123
2124 if (iparm[8] < 0) {
2125 permat_(n, ia, ja, a, iwksp, &iwksp[jb3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
2126 if (ier != 0)
2127 goto L430;
2128
2129 pervec_(n, rhs, iwksp);
2130 pervec_(n, u, iwksp);
2131 }
2132
2133 /* ... FINISH WKSP BASE ADDRESSES */
2134
2135 ib3 = ib2 + nb;
2136 ib4 = ib3 + nb;
2137 ib5 = ib4 + nb;
2138 nr = *n - nb;
2139 iparm[7] = *n + nb * 3 + (itcom1_1.itmax << 1);
2140 if (itcom1_1.isym != 0)
2141 iparm[7] += itcom1_1.itmax << 1;
2142
2143 if (*nw < iparm[7]) {
2144 ier = 62;
2145 goto L430;
2146 }
2147
2148 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE */
2149 /* ... DIAGONAL ELEMENTS. */
2150
2151 vfill_(&iparm[7], wksp, &c_b21);
2152 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
2153 if (ier != 0)
2154 goto L430;
2155
2156 if (iparm[10] == 0)
2157 timi1 = (real)( dsrc_timer_((real*)0) );
2158
2159 /* ... INITIALIZE FORWARD PSEUDO-RESIDUAL */
2160
2161 if (*n <= 1) {
2162 u[0] = rhs[0];
2163 goto L330;
2164 }
2165 itpackdcopy_(&nr, rhs, &c__1, &wksp[ib1], &c__1);
2166 prsred_(&nb, &nr, ia, ja, a, &u[nr], &wksp[ib1]);
2167 itpackdcopy_(&nb, &rhs[nr], &c__1, &wksp[ib2], &c__1);
2168 prsblk_(&nb, &nr, ia, ja, a, &wksp[ib1], &wksp[ib2]);
2169 vevmw_(&nb, &wksp[ib2], &u[nr]);
2170
2171 /* ... ITERATION SEQUENCE */
2172
2173 itmax1 = itcom1_1.itmax + 1;
2174 for (loop = 1; loop <= itmax1; ++loop) {
2175 itcom1_1.in = loop - 1;
2176 if (itcom1_1.in % 2 == 1)
2177 goto L290;
2178
2179 /* ... CODE FOR THE EVEN ITERATIONS. */
2180
2181 /* U = U(IN) WKSP(IB2) = D(IN) */
2182 /* WKSP(IB1) = U(IN-1) WKSP(IB3) = D(IN-1) */
2183
2184 itrscg_(n, &nb, ia, ja, a, u, &wksp[ib1], &wksp[ib2], &wksp[ib3], &wksp[ib4], &wksp[ib5]);
2185
2186 if (itcom2_1.halt)
2187 goto L330;
2188
2189 continue;
2190
2191 /* ... CODE FOR THE ODD ITERATIONS. */
2192
2193 /* U = U(IN-1) WKSP(IB2) = D(IN-1) */
2194 /* WKSP(IB1) = U(IN) WKSP(IB3) = D(IN) */
2195
2196 L290:
2197 itrscg_(n, &nb, ia, ja, a, &wksp[ib1], u, &wksp[ib3], &wksp[ib2], &wksp[ib4], &wksp[ib5]);
2198
2199 if (itcom2_1.halt)
2200 goto L330;
2201 }
2202
2203 /* ... ITMAX HAS BEEN REACHED */
2204
2205 if (iparm[10] == 0) {
2206 timi2 = (real)( dsrc_timer_((real*)0) );
2207 time1 = (doublereal) (timi2 - timi1);
2208 }
2209 ier = 63;
2210 if (iparm[2] == 0)
2211 rparm[0] = itcom3_1.stptst;
2212
2213 goto L360;
2214
2215 /* ... METHOD HAS CONVERGED */
2216
2217 L330:
2218 if (iparm[10] == 0) {
2219 timi2 = (real)( dsrc_timer_((real*)0) );
2220 time1 = (doublereal) (timi2 - timi1);
2221 }
2222
2223 /* ... PUT SOLUTION INTO U IF NOT ALREADY THERE. */
2224
2225 L360:
2226 if (*n != 1) {
2227 if (itcom1_1.in % 2 == 1)
2228 itpackdcopy_(n, &wksp[ib1], &c__1, u, &c__1);
2229
2230 itpackdcopy_(&nr, rhs, &c__1, u, &c__1);
2231 prsred_(&nb, &nr, ia, ja, a, &u[nr], u);
2232 }
2233
2234 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
2235
2236 unscal_(n, ia, ja, a, rhs, u, wksp);
2237
2238 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
2239
2240 if (iparm[8] >= 0)
2241 goto L400;
2242
2243 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[jb3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
2244 if (ierper != 0) {
2245 if (ier == 0)
2246 ier = ierper;
2247
2248 goto L430;
2249 }
2250
2251 pervec_(n, rhs, &iwksp[ib2]);
2252 pervec_(n, u, &iwksp[ib2]);
2253
2254 /* ... OPTIONAL ERROR ANALYSIS */
2255
2256 L400:
2257 idgts = iparm[11];
2258 if (idgts >= 0) {
2259 if (iparm[1] <= 0)
2260 idgts = 0;
2261
2262 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
2263 }
2264
2265 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
2266
2267 if (iparm[10] == 0) {
2268 timj2 = (real)( dsrc_timer_((real*)0) );
2269 time2 = (doublereal) (timj2 - timj1);
2270 }
2271 iparm[7] -= (itcom1_1.itmax - itcom1_1.in) << 1;
2272 if (itcom1_1.isym != 0)
2273 iparm[7] -= (itcom1_1.itmax - itcom1_1.in) << 1;
2274
2275 if (iparm[2] == 0) {
2276 iparm[0] = itcom1_1.in;
2277 iparm[8] = nb;
2278 rparm[1] = itcom3_1.cme;
2279 rparm[2] = itcom3_1.sme;
2280 rparm[8] = time1;
2281 rparm[9] = time2;
2282 rparm[10] = digit1;
2283 rparm[11] = digit2;
2284 }
2285
2286 L430:
2287 *ierr = ier;
2288 if (itcom1_1.level >= 3)
2289 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
2290
2291 return 0;
2292 } /* rscg_ */
2293
2294 /* Subroutine */
rssi_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,integer * iwksp,integer * nw,doublereal * wksp,integer * iparm,doublereal * rparm,integer * ierr)2295 int rssi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
2296 integer *iwksp, integer *nw, doublereal *wksp, integer *iparm, doublereal *rparm, integer* ierr)
2297 {
2298 /* Local variables */
2299 static integer n3, nb, nr, ib1, ib2, jb3, ier;
2300 static doublereal tol;
2301 static doublereal temp;
2302 static integer loop;
2303 static doublereal time1, time2;
2304 static real timi1, timj1, timi2, timj2;
2305 static integer idgts;
2306 static doublereal digit1, digit2;
2307 static integer itmax1;
2308 static integer ierper;
2309
2310 /* ITPACK 2C MAIN SUBROUTINE RSSI (REDUCED SYSTEM SEMI-ITERATIVE) */
2311 /* EACH OF THE MAIN SUBROUTINES: */
2312 /* JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI */
2313 /* CAN BE USED INDEPENDENTLY OF THE OTHERS */
2314
2315 /* THIS SUBROUTINE, RSSI, DRIVES THE REDUCED SYSTEM SI */
2316 /* ALGORITHM. */
2317 /* */
2318 /* ... PARAMETER LIST: */
2319 /* */
2320 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
2321 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
2322 /* THE SPARSE MATRIX REPRESENTATION. */
2323 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
2324 /* MATRIX REPRESENTATION. */
2325 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
2326 /* OF THE MATRIX PROBLEM. */
2327 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
2328 /* INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS */
2329 /* THE LATEST ESTIMATE TO THE SOLUTION. */
2330 /* IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N */
2331 /* NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, */
2332 /* IPARM(8) IS AMOUNT USED. */
2333 /* WKSP D.P. VECTOR USED FOR WORKING SPACE. RSSI */
2334 /* NEEDS THIS TO BE IN LENGTH AT LEAST N + NB */
2335 /* HERE NB IS THE ORDER OF THE BLACK SUBSYSTEM */
2336 /* IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY */
2337 /* SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF */
2338 /* RPARM D.P. VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME */
2339 /* D.P. PARAMETERS WHICH AFFECT THE METHOD. */
2340 /* IER OUTPUT INTEGER. ERROR FLAG. (= IERR) */
2341 /* */
2342 /* ... RSSI SUBPROGRAM REFERENCES: */
2343 /* */
2344 /* FROM ITPACK BISRCH, CHEBY, CHGSI, DFAULT, ECHALL, */
2345 /* ECHOUT, ITERM, TIMER, ITRSSI, IVFILL, */
2346 /* PARSI, PERMAT, PERROR, PERVEC, PMULT, */
2347 /* PRBNDX, PRSBLK, PRSRED, PSTOP, QSORT, */
2348 /* DAXPY, SBELM, SCAL, DCOPY, DDOT, SUM3, */
2349 /* TSTCHG, UNSCAL, VEVMW, VFILL, VOUT, */
2350 /* WEVMW */
2351 /* SYSTEM DABS, DLOG10, DBLE(AMAX0), DMAX1, DBLE(FLOAT), */
2352 /* DSQRT */
2353 /* */
2354 /* VERSION: ITPACK 2C (MARCH 1982) */
2355 /* */
2356 /* CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS */
2357 /* CENTER FOR NUMERICAL ANALYSIS */
2358 /* UNIVERSITY OF TEXAS */
2359 /* AUSTIN, TX 78712 */
2360 /* (512) 471-1242 */
2361 /* */
2362 /* FOR ADDITIONAL DETAILS ON THE */
2363 /* (A) SUBROUTINE SEE TOMS ARTICLE 1982 */
2364 /* (B) ALGORITHM SEE CNA REPORT 150 */
2365 /* */
2366 /* BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN */
2367 /* */
2368 /* REFERENCE THE BOOK: APPLIED ITERATIVE METHODS */
2369 /* L. HAGEMAN, D. YOUNG */
2370 /* ACADEMIC PRESS, 1981 */
2371 /* */
2372 /* ************************************************** */
2373 /* * IMPORTANT NOTE * */
2374 /* * * */
2375 /* * WHEN INSTALLING ITPACK ROUTINES ON A * */
2376 /* * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * */
2377 /* * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * */
2378 /* * * */
2379 /* * DRELPR MACHINE RELATIVE PRECISION * */
2380 /* * RPARM(1) STOPPING CRITERION * */
2381 /* * * */
2382 /* * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * */
2383 /* * SECOND USED IN TIMER * */
2384 /* * * */
2385 /* ************************************************** */
2386 /* */
2387 /* SPECIFICATIONS FOR ARGUMENTS */
2388 /* */
2389 /* SPECIFICATIONS FOR LOCAL VARIABLES */
2390 /* */
2391 /* ... VARIABLES IN COMMON BLOCK - ITCOM1 */
2392 /* */
2393 /* IN - ITERATION NUMBER */
2394 /* IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED */
2395 /* ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH */
2396 /* ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED */
2397 /* LEVEL - LEVEL OF OUTPUT CONTROL SWITCH */
2398 /* NOUT - OUTPUT UNIT NUMBER */
2399 /* */
2400 /* ... VARIABLES IN COMMON BLOCK - ITCOM2 */
2401 /* */
2402 /* ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH */
2403 /* BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA */
2404 /* CASEII - ADAPTIVE PROCEDURE CASE SWITCH */
2405 /* HALT - STOPPING TEST SWITCH */
2406 /* PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH */
2407 /* */
2408 /* ... VARIABLES IN COMMON BLOCK - ITCOM3 */
2409 /* */
2410 /* BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N */
2411 /* BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX */
2412 /* CME - ESTIMATE OF LARGEST EIGENVALUE */
2413 /* DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N */
2414 /* DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S */
2415 /* FF - ADAPTIVE PROCEDURE DAMPING FACTOR */
2416 /* GAMMA - ACCELERATION PARAMETER */
2417 /* OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR */
2418 /* QA - PSEUDO-RESIDUAL RATIO */
2419 /* QT - VIRTUAL SPECTRAL RADIUS */
2420 /* RHO - ACCELERATION PARAMETER */
2421 /* RRR - ADAPTIVE PARAMETER */
2422 /* SIGE - PARAMETER SIGMA-SUB-E */
2423 /* SME - ESTIMATE OF SMALLEST EIGENVALUE */
2424 /* SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR */
2425 /* DRELPR - MACHINE RELATIVE PRECISION */
2426 /* STPTST - STOPPING PARAMETER */
2427 /* UDNM - TWO NORM OF U */
2428 /* ZETA - STOPPING CRITERION */
2429
2430 itcom1_1.level = iparm[1];
2431 itcom1_1.nout = iparm[3];
2432 ier = 0;
2433 if (iparm[0] <= 0)
2434 return 0;
2435
2436 if (iparm[10] == 0)
2437 timj1 = (real)( dsrc_timer_((real*)0) );
2438
2439 if (itcom1_1.level < 3)
2440 echout_(iparm, rparm, &c__7);
2441 else
2442 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__1);
2443 temp = itcom3_1.drelpr * 500.;
2444 if (itcom3_1.zeta < temp)
2445 itcom3_1.zeta = temp;
2446
2447 time1 = rparm[8];
2448 time2 = rparm[9];
2449 digit1 = rparm[10];
2450 digit2 = rparm[11];
2451
2452 /* ... VERIFY N */
2453
2454 if (*n <= 0) {
2455 ier = 71;
2456 goto L420;
2457 }
2458
2459 /* ... REMOVE ROWS AND COLUMNS IF REQUESTED */
2460
2461 if (iparm[9] != 0) {
2462 tol = rparm[7];
2463 ivfill_(n, iwksp, &c__0);
2464 vfill_(n, wksp, &c_b21);
2465 sbelm_(n, ia, ja, a, rhs, iwksp, wksp, &tol, &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
2466 }
2467
2468 /* ... INITIALIZE WKSP BASE ADDRESSES. */
2469
2470 ib1 = 0;
2471 ib2 = ib1 + *n;
2472 jb3 = ib2 + *n;
2473
2474 /* ... PERMUTE TO RED-BLACK SYSTEM IF POSSIBLE */
2475
2476 nb = iparm[8];
2477 if (nb < 0) {
2478 n3 = *n * 3;
2479 ivfill_(&n3, iwksp, &c__0);
2480 prbndx_(n, &nb, ia, ja, iwksp, &iwksp[ib2], &itcom1_1.level, &itcom1_1.nout, &ier);
2481 if (ier != 0)
2482 goto L420;
2483 }
2484
2485 if (nb < 0 || nb > *n) {
2486 ier = 74;
2487 goto L420;
2488 }
2489 if (nb == 0 || nb == *n)
2490 nb = *n / 2;
2491
2492 /* ... PERMUTE MATRIX AND RHS */
2493
2494 if (iparm[8] < 0) {
2495 permat_(n, ia, ja, a, iwksp, &iwksp[jb3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ier);
2496 if (ier != 0)
2497 goto L420;
2498
2499 pervec_(n, rhs, iwksp);
2500 pervec_(n, u, iwksp);
2501 }
2502
2503 /* ... INITIALIZE WKSP BASE ADDRESSES */
2504
2505 nr = *n - nb;
2506
2507 iparm[7] = *n + nb;
2508 if (*nw < iparm[7]) {
2509 ier = 72;
2510 goto L420;
2511 }
2512
2513 /* ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE */
2514 /* ... DIAGONAL ELEMENTS. */
2515
2516 vfill_(&iparm[7], wksp, &c_b21);
2517 scal_(n, ia, ja, a, rhs, u, wksp, &itcom1_1.level, &itcom1_1.nout, &ier);
2518 if (ier != 0)
2519 goto L420;
2520
2521 if (iparm[10] == 0)
2522 timi1 = (real)( dsrc_timer_((real*)0) );
2523
2524 /* ... ITERATION SEQUENCE */
2525
2526 if (*n <= 1) {
2527 u[0] = rhs[0];
2528 goto L320;
2529 }
2530 itmax1 = itcom1_1.itmax + 1;
2531 for (loop = 1; loop <= itmax1; ++loop) {
2532 itcom1_1.in = loop - 1;
2533 if (itcom1_1.in % 2 == 1)
2534 goto L280;
2535
2536 /* ... CODE FOR THE EVEN ITERATIONS. */
2537
2538 /* U = U(IN) */
2539 /* WKSP(IB1) = U(IN-1) */
2540
2541 itrssi_(n, &nb, ia, ja, a, rhs, u, &wksp[ib1], &wksp[ib2]);
2542
2543 if (itcom2_1.halt)
2544 goto L320;
2545
2546 continue;
2547
2548 /* ... CODE FOR THE ODD ITERATIONS. */
2549
2550 /* U = U(IN-1) */
2551 /* WKSP(IB1) = U(IN) */
2552
2553 L280:
2554 itrssi_(n, &nb, ia, ja, a, rhs, &wksp[ib1], u, &wksp[ib2]);
2555
2556 if (itcom2_1.halt)
2557 goto L320;
2558 }
2559
2560 /* ... ITMAX HAS BEEN REACHED */
2561
2562 if (iparm[10] == 0) {
2563 timi2 = (real)( dsrc_timer_((real*)0) );
2564 time1 = (doublereal) (timi2 - timi1);
2565 }
2566 ier = 73;
2567 if (iparm[2] == 0)
2568 rparm[0] = itcom3_1.stptst;
2569
2570 goto L350;
2571
2572 /* ... METHOD HAS CONVERGED */
2573
2574 L320:
2575 if (iparm[10] == 0) {
2576 timi2 = (real)( dsrc_timer_((real*)0) );
2577 time1 = (doublereal) (timi2 - timi1);
2578 }
2579
2580 /* ... PUT SOLUTION INTO U IF NOT ALREADY THERE. */
2581
2582 L350:
2583 if (*n != 1) {
2584 if (itcom1_1.in % 2 == 1)
2585 itpackdcopy_(n, &wksp[ib1], &c__1, u, &c__1);
2586
2587 itpackdcopy_(&nr, rhs, &c__1, u, &c__1);
2588 prsred_(&nb, &nr, ia, ja, a, &u[nr], u);
2589 }
2590
2591 /* ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. */
2592
2593 unscal_(n, ia, ja, a, rhs, u, wksp);
2594
2595 /* ... UN-PERMUTE MATRIX,RHS, AND SOLUTION */
2596
2597 if (iparm[8] >= 0)
2598 goto L390;
2599
2600 permat_(n, ia, ja, a, &iwksp[ib2], &iwksp[jb3], &itcom1_1.isym, &itcom1_1.level, &itcom1_1.nout, &ierper);
2601 if (ierper != 0) {
2602 if (ier == 0)
2603 ier = ierper;
2604
2605 goto L420;
2606 }
2607
2608 pervec_(n, rhs, &iwksp[ib2]);
2609 pervec_(n, u, &iwksp[ib2]);
2610
2611 /* ... OPTIONAL ERROR ANALYSIS */
2612
2613 L390:
2614 idgts = iparm[11];
2615 if (idgts >= 0) {
2616 if (iparm[1] <= 0)
2617 idgts = 0;
2618
2619 perror_(n, ia, ja, a, rhs, u, wksp, &digit1, &digit2, &idgts);
2620 }
2621
2622 /* ... SET RETURN PARAMETERS IN IPARM AND RPARM */
2623
2624 if (iparm[10] == 0) {
2625 timj2 = (real)( dsrc_timer_((real*)0) );
2626 time2 = (doublereal) (timj2 - timj1);
2627 }
2628 if (iparm[2] == 0) {
2629 iparm[0] = itcom1_1.in;
2630 iparm[8] = nb;
2631 rparm[1] = itcom3_1.cme;
2632 rparm[2] = itcom3_1.sme;
2633 rparm[8] = time1;
2634 rparm[9] = time2;
2635 rparm[10] = digit1;
2636 rparm[11] = digit2;
2637 }
2638
2639 L420:
2640 *ierr = ier;
2641 if (itcom1_1.level >= 3)
2642 echall_(n, ia, ja, a, rhs, iparm, rparm, &c__2);
2643
2644 return 0;
2645 } /* rssi_ */
2646
2647 /* Subroutine */
itjcg_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * u1,doublereal * d,doublereal * d1,doublereal * dtwd,doublereal * tri)2648 int itjcg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *u1,
2649 doublereal *d, doublereal *d1, doublereal *dtwd, doublereal *tri)
2650 {
2651 static doublereal c1, c2, c3, c4;
2652 static logical q1;
2653 static doublereal con;
2654 static doublereal dnrm;
2655 static doublereal dtnrm;
2656 static doublereal gamold;
2657 static doublereal rhoold;
2658
2659 /* THIS SUBROUTINE, ITJCG, PERFORMS ONE ITERATION OF THE */
2660 /* JACOBI CONJUGATE GRADIENT ALGORITHM. IT IS CALLED BY JCG. */
2661 /* */
2662 /* ... PARAMETER LIST: */
2663 /* */
2664 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
2665 /* IA,JA INPUT INTEGER VECTORS. CONTAINS INFORMATION DEFINING */
2666 /* THE SPARSE MATRIX REPRESENTATION. */
2667 /* A INPUT D.P. VECTOR. CONTAINS THE NONZERO VALUES OF THE */
2668 /* LINEAR SYSTEM. */
2669 /* U INPUT D.P. VECTOR. CONTAINS THE VALUE OF THE */
2670 /* SOLUTION VECTOR AT THE END OF IN ITERATIONS. */
2671 /* U1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, IT CONTAINS */
2672 /* THE VALUE OF THE SOLUTION AT THE END OF THE IN-1 */
2673 /* ITERATION. ON OUTPUT, IT WILL CONTAIN THE NEWEST */
2674 /* ESTIMATE FOR THE SOLUTION VECTOR. */
2675 /* D INPUT D.P. VECTOR. CONTAINS THE PSEUDO-RESIDUAL */
2676 /* VECTOR AFTER IN ITERATIONS. */
2677 /* D1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, D1 CONTAINS */
2678 /* THE PSEUDO-RESIDUAL VECTOR AFTER IN-1 ITERATIONS. ON */
2679 /* OUTPUT, IT WILL CONTAIN THE NEWEST PSEUDO-RESIDUAL */
2680 /* VECTOR. */
2681 /* DTWD D.P. ARRAY. USED IN THE COMPUTATIONS OF THE */
2682 /* ACCELERATION PARAMETER GAMMA AND THE NEW PSEUDO- */
2683 /* RESIDUAL. */
2684 /* TRI D.P. ARRAY. STORES THE TRIDIAGONAL MATRIX ASSOCIATED */
2685 /* WITH THE EIGENVALUES OF THE CONJUGATE GRADIENT */
2686 /* POLYNOMIAL. */
2687
2688 /* ... COMPUTE NEW ESTIMATE FOR CME IF ADAPT = .TRUE. */
2689
2690 if (itcom2_1.adapt)
2691 chgcon_(tri, &gamold, &rhoold, &c__1);
2692
2693 /* ... TEST FOR STOPPING */
2694
2695 itcom3_1.delnnm = itpackddot_(n, d, &c__1, d, &c__1);
2696 dnrm = itcom3_1.delnnm;
2697 con = itcom3_1.cme;
2698 pstop_(n, u, &dnrm, &con, &c__1, &q1);
2699 if (itcom2_1.halt)
2700 goto L30;
2701
2702 /* ... COMPUTE RHO AND GAMMA - ACCELERATION PARAMETERS */
2703
2704 vfill_(n, dtwd, &c_b21);
2705 pjac_(n, ia, ja, a, d, dtwd);
2706 dtnrm = itpackddot_(n, d, &c__1, dtwd, &c__1);
2707 if (itcom1_1.isym != 0)
2708 rhoold = itpackddot_(n, dtwd, &c__1, d1, &c__1);
2709
2710 parcon_(&dtnrm, &c1, &c2, &c3, &c4, &gamold, &rhoold, &c__1);
2711
2712 /* ... COMPUTE U(IN+1) AND D(IN+1) */
2713
2714 sum3_(n, &c1, d, &c2, u, &c3, u1);
2715 sum3_(n, &c1, dtwd, &c4, d, &c3, d1);
2716
2717 /* ... OUTPUT INTERMEDIATE INFORMATION */
2718
2719 L30:
2720 iterm_(n, a, u, dtwd, &c__1);
2721
2722 return 0;
2723 } /* itjcg_ */
2724
2725 /* Subroutine */
itjsi_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * u1,doublereal * d,integer * icnt)2726 int itjsi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
2727 doublereal *u, doublereal *u1, doublereal *d, integer *icnt)
2728 {
2729 static doublereal c1, c2, c3;
2730 static logical q1;
2731 static doublereal con;
2732 static doublereal dnrm;
2733 static doublereal dtnrm;
2734 static doublereal oldnrm;
2735
2736 /* THIS SUBROUTINE, ITJSI, PERFORMS ONE ITERATION OF THE */
2737 /* JACOBI SEMI-ITERATIVE ALGORITHM. IT IS CALLED BY JSI. */
2738 /* */
2739 /* ... PARAMETER LIST: */
2740 /* */
2741 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
2742 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
2743 /* THE SPARSE MATRIX REPRESENTATION. */
2744 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
2745 /* MATRIX REPRESENTATION. */
2746 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
2747 /* OF THE MATRIX PROBLEM. */
2748 /* U INPUT D.P. VECTOR. CONTAINS THE ESTIMATE FOR THE */
2749 /* SOLUTION VECTOR AFTER IN ITERATIONS. */
2750 /* U1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, U1 CONTAINS THE */
2751 /* SOLUTION VECTOR AFTER IN-1 ITERATIONS. ON OUTPUT, */
2752 /* IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION */
2753 /* VECTOR. */
2754 /* D D.P. ARRAY. D IS USED FOR THE COMPUTATION OF THE */
2755 /* PSEUDO-RESIDUAL ARRAY FOR THE CURRENT ITERATION. */
2756 /* ICNT NUMBER OF ITERATIONS SINCE LAST CHANGE OF SME */
2757
2758 if (itcom1_1.in == 0)
2759 *icnt = 0;
2760
2761 /* ... COMPUTE PSEUDO-RESIDUALS */
2762
2763 itpackdcopy_(n, rhs, &c__1, d, &c__1);
2764 pjac_(n, ia, ja, a, u, d);
2765 vevmw_(n, d, u);
2766
2767 /* ... STOPPING AND ADAPTIVE CHANGE TESTS */
2768
2769 oldnrm = itcom3_1.delnnm;
2770 itcom3_1.delnnm = itpackddot_(n, d, &c__1, d, &c__1);
2771 dnrm = itcom3_1.delnnm;
2772 con = itcom3_1.cme;
2773 pstop_(n, u, &dnrm, &con, &c__1, &q1);
2774 if (itcom2_1.halt)
2775 goto L40;
2776
2777 if (! itcom2_1.adapt)
2778 goto L30;
2779
2780 if (! tstchg_(&c__1))
2781 goto L10;
2782
2783 /* ... CHANGE ITERATIVE PARAMETERS (CME) */
2784
2785 dtnrm = pvtbv_(n, ia, ja, a, d);
2786 chgsi_(&dtnrm, &c__1);
2787 if (! itcom2_1.adapt)
2788 goto L30;
2789
2790 goto L20;
2791
2792 /* ... TEST IF SME NEEDS TO BE CHANGED AND CHANGE IF NECESSARY. */
2793
2794 L10:
2795 if (itcom2_1.caseii)
2796 goto L30;
2797
2798 if (! chgsme_(&oldnrm, icnt))
2799 goto L30;
2800
2801 *icnt = 0;
2802
2803 /* ... COMPUTE U(IN+1) AFTER CHANGE OF PARAMETERS */
2804
2805 L20:
2806 itpackdcopy_(n, u, &c__1, u1, &c__1);
2807 itpackdaxpy_(n, &itcom3_1.gamma, d, &c__1, u1, &c__1);
2808 goto L40;
2809
2810 /* ... COMPUTE U(IN+1) WITHOUT CHANGE OF PARAMETERS */
2811
2812 L30:
2813 parsi_(&c1, &c2, &c3, &c__1);
2814 sum3_(n, &c1, d, &c2, u, &c3, u1);
2815
2816 /* ... OUTPUT INTERMEDIATE INFORMATION */
2817
2818 L40:
2819 iterm_(n, a, u, d, &c__2);
2820
2821 return 0;
2822 } /* itjsi_ */
2823
2824 /* Subroutine */
itsor_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * wk)2825 int itsor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u, doublereal *wk)
2826 {
2827 /* System generated locals */
2828 doublereal d__1;
2829
2830 /* Local variables */
2831 static doublereal h;
2832 static logical q1;
2833 static integer ip;
2834 static integer iss;
2835 static doublereal dnrm;
2836 static integer iphat;
2837 static doublereal spcrm1;
2838 static logical change;
2839 static doublereal omegap;
2840 static integer ipstar;
2841
2842 /* THIS SUBROUTINE, ITSOR, PERFORMS ONE ITERATION OF THE */
2843 /* SUCCESSIVE OVERRELAXATION ALGORITHM. IT IS CALLED BY SOR. */
2844 /* */
2845 /* ... PARAMETER LIST: */
2846 /* */
2847 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
2848 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
2849 /* THE SPARSE MATRIX REPRESENTATION. */
2850 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
2851 /* MATRIX REPRESENTATION. */
2852 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
2853 /* OF THE MATRIX PROBLEM. */
2854 /* U INPUT/OUTPUT D.P. VECTOR. ON INPUT, U CONTAINS THE */
2855 /* SOLUTION VECTOR AFTER IN ITERATIONS. ON OUTPUT, */
2856 /* IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION */
2857 /* VECTOR. */
2858 /* WK D.P. ARRAY. WORK VECTOR OF LENGTH N. */
2859
2860 /* ... SET INITIAL PARAMETERS NOT ALREADY SET */
2861
2862 if (itcom1_1.in != 0)
2863 goto L20;
2864
2865 pstop_(n, u, &c_b21, &c_b21, &c__0, &q1);
2866 if (! itcom2_1.adapt) {
2867 change = FALSE_;
2868 ip = 0;
2869 iphat = 2;
2870 iss = 0;
2871 goto L30;
2872 }
2873
2874 change = TRUE_;
2875 ip = 0;
2876 omegap = itcom3_1.omega;
2877 itcom3_1.omega = 1.;
2878 iss = 0;
2879 iphat = 2;
2880 ipstar = 4;
2881 if (omegap <= 1.)
2882 change = FALSE_;
2883
2884 /* ... RESET OMEGA, IPHAT, AND IPSTAR (CIRCLE A IN FLOWCHART) */
2885
2886 L20:
2887 if (change) {
2888 change = FALSE_;
2889 ++itcom1_1.is;
2890 ip = 0;
2891 iss = 0;
2892 itcom3_1.omega = min(omegap,tau_(&itcom1_1.is));
2893 iphat = max(3, (integer)((itcom3_1.omega-1.)/(2.-itcom3_1.omega)));
2894 ipstar = ipstr_(&itcom3_1.omega);
2895 }
2896
2897 /* ... COMPUTE U (IN + 1) AND NORM OF DEL(S,P) - CIRCLE B IN FLOW CHART */
2898
2899 L30:
2900 itcom3_1.delsnm = itcom3_1.delnnm;
2901 spcrm1 = itcom3_1.specr;
2902 itpackdcopy_(n, rhs, &c__1, wk, &c__1);
2903 pfsor1_(n, ia, ja, a, u, wk);
2904 if (itcom3_1.delnnm == 0.)
2905 goto L40;
2906
2907 if (itcom1_1.in != 0)
2908 itcom3_1.specr = itcom3_1.delnnm / itcom3_1.delsnm;
2909
2910 if (ip < iphat)
2911 goto L70;
2912
2913 /* ... STOPPING TEST, SET H */
2914
2915 if (itcom3_1.specr >= 1.)
2916 goto L70;
2917
2918 if (itcom3_1.specr > itcom3_1.omega - 1.) {
2919 h = itcom3_1.specr;
2920 goto L50;
2921 }
2922 L40:
2923 ++iss;
2924 h = itcom3_1.omega - 1.;
2925
2926 /* ... PERFORM STOPPING TEST. */
2927
2928 L50:
2929 dnrm = itcom3_1.delnnm * itcom3_1.delnnm;
2930 pstop_(n, u, &dnrm, &h, &c__1, &q1);
2931 if (itcom2_1.halt)
2932 goto L70;
2933
2934 /* ... METHOD HAS NOT CONVERGED YET, TEST FOR CHANGING OMEGA */
2935
2936 if (! itcom2_1.adapt)
2937 goto L70;
2938
2939 if (ip < ipstar)
2940 goto L70;
2941
2942 if (itcom3_1.omega <= 1.) {
2943 itcom3_1.cme = sqrt((abs(itcom3_1.specr)));
2944 omegap = 2. / (sqrt(abs(1. - itcom3_1.specr)) + 1.);
2945 change = TRUE_;
2946 goto L70;
2947 }
2948
2949 if (iss != 0)
2950 goto L70;
2951
2952 d__1 = itcom3_1.omega - 1.;
2953 if (itcom3_1.specr <= pow_dd(&d__1, &itcom3_1.ff))
2954 goto L70;
2955
2956 /* ... CHANGE PARAMETERS */
2957
2958 if (itcom3_1.specr + 5e-5 > spcrm1) {
2959 itcom3_1.cme = (itcom3_1.specr + itcom3_1.omega - 1.) /
2960 (sqrt((abs(itcom3_1.specr))) * itcom3_1.omega);
2961 omegap = 2. / (sqrt(abs(1. - itcom3_1.cme * itcom3_1.cme)) + 1.);
2962 change = TRUE_;
2963 }
2964
2965 /* ... OUTPUT INTERMEDIATE INFORMATION */
2966
2967 L70:
2968 iterm_(n, a, u, wk, &c__3);
2969 ++ip;
2970
2971 return 0;
2972 } /* itsor_ */
2973
2974 /* Subroutine */
itsrcg_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * u1,doublereal * c,doublereal * c1,doublereal * d,doublereal * dl,doublereal * wk,doublereal * tri)2975 int itsrcg_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
2976 doublereal *u, doublereal *u1, doublereal *c, doublereal *c1,
2977 doublereal *d, doublereal *dl, doublereal *wk, doublereal *tri)
2978 {
2979 /* System generated locals */
2980 doublereal d__1;
2981
2982 /* Local variables */
2983 static logical q1;
2984 static doublereal t1, t2, t3, t4, con;
2985 static doublereal dnrm;
2986 static doublereal gamold;
2987 static doublereal betnew, rhoold;
2988
2989 /* THIS SUBROUTINE, ITSRCG, PERFORMS ONE ITERATION OF THE */
2990 /* SYMMETRIC SOR CONJUGATE GRADIENT ALGORITHM. IT IS CALLED BY */
2991 /* SSORCG. */
2992 /* */
2993 /* ... PARAMETER LIST: */
2994 /* */
2995 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
2996 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
2997 /* THE SPARSE MATRIX REPRESENTATION. */
2998 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
2999 /* MATRIX REPRESENTATION. */
3000 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
3001 /* OF THE MATRIX PROBLEM. */
3002 /* U INPUT D.P. VECTOR. CONTAINS THE ESTIMATE OF THE */
3003 /* SOLUTION VECTOR AFTER IN ITERATIONS. */
3004 /* U1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, U1 CONTAINS THE */
3005 /* THE ESTIMATE FOR THE SOLUTION AFTER IN-1 ITERATIONS. */
3006 /* ON OUTPUT, U1 CONTAINS THE UPDATED ESTIMATE. */
3007 /* C INPUT D.P. VECTOR. CONTAINS THE FORWARD RESIDUAL */
3008 /* AFTER IN ITERATIONS. */
3009 /* C1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, C1 CONTAINS */
3010 /* THE FORWARD RESIDUAL AFTER IN-1 ITERATIONS. ON */
3011 /* OUTPUT, C1 CONTAINS THE UPDATED FORWARD RESIDUAL. */
3012 /* D D.P. VECTOR. IS USED TO COMPUTE THE BACKWARD PSEUDO- */
3013 /* RESIDUAL VECTOR FOR THE CURRENT ITERATION. */
3014 /* DL D.P. VECTOR. IS USED IN THE COMPUTATIONS OF THE */
3015 /* ACCELERATION PARAMETERS. */
3016 /* WK D.P. VECTOR. WORKING SPACE OF LENGTH N. */
3017 /* TRI D.P. VECTOR. STORES THE TRIDIAGONAL MATRIX ASSOCIATED */
3018 /* WITH THE CONJUGATE GRADIENT ACCELERATION. */
3019
3020 /* ... CALCULATE S-PRIME FOR ADAPTIVE PROCEDURE. */
3021
3022 if (itcom2_1.adapt || itcom2_1.partad)
3023 chgcon_(tri, &gamold, &rhoold, &c__3);
3024
3025 /* ... COMPUTE BACKWARD RESIDUAL */
3026
3027 itpackdcopy_(n, rhs, &c__1, wk, &c__1);
3028 itpackdcopy_(n, c, &c__1, d, &c__1);
3029 vevpw_(n, d, u);
3030 pbsor_(n, ia, ja, a, d, wk);
3031 vevmw_(n, d, u);
3032
3033 /* ... COMPUTE ACCELERATION PARAMETERS AND THEN U(IN+1) (IN U1) */
3034
3035 itpackdcopy_(n, d, &c__1, dl, &c__1);
3036 vfill_(n, wk, &c_b21);
3037 pfsor_(n, ia, ja, a, dl, wk);
3038 wevmw_(n, d, dl);
3039 itcom3_1.delnnm = itpackddot_(n, c, &c__1, c, &c__1);
3040 if (itcom3_1.delnnm != 0.) {
3041 dnrm = itpackddot_(n, c, &c__1, dl, &c__1);
3042 if (dnrm != 0.) {
3043 if (itcom1_1.isym != 0)
3044 rhoold = itpackddot_(n, c, &c__1, c1, &c__1) - itpackddot_(n, dl, &c__1, c1, &c__1);
3045
3046 parcon_(&dnrm, &t1, &t2, &t3, &t4, &gamold, &rhoold, &c__3);
3047 sum3_(n, &t1, d, &t2, u, &t3, u1);
3048 }
3049 }
3050
3051 /* ... TEST FOR STOPPING */
3052
3053 itcom3_1.bdelnm = itpackddot_(n, d, &c__1, d, &c__1);
3054 dnrm = itcom3_1.bdelnm;
3055 con = itcom3_1.specr;
3056 pstop_(n, u, &dnrm, &con, &c__1, &q1);
3057 if (itcom2_1.halt)
3058 goto L100;
3059
3060 /* ... IF NON- OR PARTIALLY-ADAPTIVE, COMPUTE C(IN+1) AND EXIT. */
3061
3062 if (! itcom2_1.adapt) {
3063 d__1 = -t1;
3064 sum3_(n, &d__1, dl, &t2, c, &t3, c1);
3065 goto L100;
3066 }
3067
3068 /* ... FULLY ADAPTIVE PROCEDURE */
3069
3070 if (omgstr_(&c__1))
3071 goto L90;
3072
3073 /* ... PARAMETERS HAVE BEEN UNCHANGED. COMPUTE C(IN+1) AND EXIT. */
3074
3075 if (! omgchg_(&c__1)) {
3076 d__1 = -t1;
3077 sum3_(n, &d__1, dl, &t2, c, &t3, c1);
3078 goto L100;
3079 }
3080
3081 /* ... IT HAS BEEN DECIDED TO CHANGE PARAMETERS */
3082 /* (1) COMPUTE NEW BETAB IF BETADT = .TRUE. */
3083
3084 if (itcom2_1.betadt) {
3085 betnew = pbeta_(n, ia, ja, a, d, wk, c1) / itcom3_1.bdelnm;
3086 itcom3_1.betab = max(max(itcom3_1.betab,.25),betnew);
3087 }
3088
3089 /* ... (2) COMPUTE NEW CME, OMEGA, AND SPECR */
3090
3091 if (! itcom2_1.caseii) {
3092 dnrm = pvtbv_(n, ia, ja, a, d);
3093 goto L80;
3094 }
3095 vfill_(n, wk, &c_b21);
3096 pjac_(n, ia, ja, a, d, wk);
3097 dnrm = itpackddot_(n, wk, &c__1, wk, &c__1);
3098 L80:
3099 omeg_(&dnrm, &c__3);
3100
3101 /* ... (3) COMPUTE NEW FORWARD RESIDUAL SINCE OMEGA HAS BEEN CHANGED. */
3102
3103 L90:
3104 itpackdcopy_(n, rhs, &c__1, wk, &c__1);
3105 itpackdcopy_(n, u1, &c__1, c1, &c__1);
3106 pfsor_(n, ia, ja, a, c1, wk);
3107 vevmw_(n, c1, u1);
3108
3109 /* ... OUTPUT INTERMEDIATE RESULTS. */
3110
3111 L100:
3112 iterm_(n, a, u, wk, &c__4);
3113
3114 return 0;
3115 } /* itsrcg_ */
3116
3117 /* Subroutine */
itsrsi_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * u1,doublereal * c,doublereal * d,doublereal * ctwd,doublereal * wk)3118 int itsrsi_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u,
3119 doublereal *u1, doublereal *c, doublereal *d, doublereal *ctwd, doublereal *wk)
3120 {
3121 /* Local variables */
3122 static doublereal c1, c2, c3;
3123 static logical q1;
3124 static doublereal con;
3125 static doublereal dnrm;
3126 static doublereal betnew;
3127
3128 /* THIS SUBROUTINE, ITSRSI, PERFORMS ONE ITERATION OF THE */
3129 /* SYMMETRIC SOR SEMI-ITERATION ALGORITHM. IT IS CALLED BY */
3130 /* SSORSI. */
3131 /* */
3132 /* ... PARAMETER LIST: */
3133 /* */
3134 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
3135 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
3136 /* THE SPARSE MATRIX REPRESENTATION. */
3137 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
3138 /* MATRIX REPRESENTATION. */
3139 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
3140 /* OF THE MATRIX PROBLEM. */
3141 /* U INPUT D.P. VECTOR. CONTAINS THE ESTIMATE OF THE */
3142 /* SOLUTION VECTOR AFTER IN ITERATIONS. */
3143 /* U1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, U1 CONTAINS THE */
3144 /* THE ESTIMATE FOR THE SOLUTION AFTER IN-1 ITERATIONS. */
3145 /* ON OUTPUT, U1 CONTAINS THE UPDATED ESTIMATE. */
3146 /* C D.P. VECTOR. IS USED TO COMPUTE THE FORWARD PSEUDO- */
3147 /* RESIDUAL VECTOR FOR THE CURRENT ITERATION. */
3148 /* D D.P. VECTOR. IS USED TO COMPUTE THE BACKWARD PSEUDO- */
3149 /* RESIDUAL VECTOR FOR THE CURRENT ITERATION. */
3150 /* CTWD D.P. VECTOR. IS USED IN THE COMPUTATIONS OF THE */
3151 /* ACCELERATION PARAMETERS. */
3152 /* WK D.P. VECTOR. WORKING SPACE OF LENGTH N. */
3153
3154 /* ... COMPUTE PSEUDO-RESIDUALS (FORWARD AND BACKWARD) */
3155
3156 itpackdcopy_(n, rhs, &c__1, wk, &c__1);
3157 itpackdcopy_(n, u, &c__1, ctwd, &c__1);
3158 pssor1_(n, ia, ja, a, ctwd, wk, c, d);
3159
3160 /* ... COMPUTE U(IN+1) -- CONTAINED IN THE VECTOR U1. */
3161
3162 parsi_(&c1, &c2, &c3, &c__3);
3163 sum3_(n, &c1, d, &c2, u, &c3, u1);
3164
3165 /* ... TEST FOR STOPPING */
3166
3167 itcom3_1.bdelnm = itpackddot_(n, d, &c__1, d, &c__1);
3168 dnrm = itcom3_1.bdelnm;
3169 con = itcom3_1.specr;
3170 pstop_(n, u, &dnrm, &con, &c__1, &q1);
3171 if (itcom2_1.halt || ! (itcom2_1.adapt || itcom2_1.partad))
3172 goto L40;
3173
3174 /* ... ADAPTIVE PROCEDURE */
3175
3176 if (omgstr_(&c__1))
3177 goto L40;
3178
3179 itcom3_1.delnnm = itpackddot_(n, c, &c__1, c, &c__1);
3180 if (itcom1_1.in == itcom1_1.is)
3181 itcom3_1.delsnm = itcom3_1.delnnm;
3182
3183 if (itcom1_1.in == 0 || ! tstchg_(&c__1))
3184 goto L40;
3185
3186 /* ... IT HAS BEEN DECIDED TO CHANGE PARAMETERS. */
3187 /* ... (1) COMPUTE CTWD */
3188
3189 itpackdcopy_(n, d, &c__1, ctwd, &c__1);
3190 vfill_(n, wk, &c_b21);
3191 pfsor_(n, ia, ja, a, ctwd, wk);
3192 vevpw_(n, ctwd, c);
3193 vevmw_(n, ctwd, d);
3194
3195 /* ... (2) COMPUTE NEW SPECTRAL RADIUS FOR CURRENT OMEGA. */
3196
3197 dnrm = itpackddot_(n, c, &c__1, ctwd, &c__1);
3198 chgsi_(&dnrm, &c__3);
3199 if (! itcom2_1.adapt)
3200 goto L40;
3201
3202 /* ... (3) COMPUTE NEW BETAB IF BETADT = .TRUE. */
3203
3204 if (itcom2_1.betadt) {
3205 betnew = pbeta_(n, ia, ja, a, d, wk, ctwd) / itcom3_1.bdelnm;
3206 itcom3_1.betab = max(max(itcom3_1.betab,.25),betnew);
3207 }
3208
3209 /* ... (4) COMPUTE NEW CME, OMEGA, AND SPECR. */
3210
3211 if (! itcom2_1.caseii) {
3212 dnrm = pvtbv_(n, ia, ja, a, d);
3213 goto L30;
3214 }
3215 vfill_(n, wk, &c_b21);
3216 pjac_(n, ia, ja, a, d, wk);
3217 dnrm = itpackddot_(n, wk, &c__1, wk, &c__1);
3218 L30:
3219 omeg_(&dnrm, &c__3);
3220
3221 /* ... OUTPUT INTERMEDIATE INFORMATION */
3222
3223 L40:
3224 iterm_(n, a, u, wk, &c__5);
3225
3226 return 0;
3227 } /* itsrsi_ */
3228
3229 /* Subroutine */
itrscg_(integer * n,integer * nb,integer * ia,integer * ja,doublereal * a,doublereal * ub,doublereal * ub1,doublereal * db,doublereal * db1,doublereal * wb,doublereal * tri)3230 int itrscg_(integer *n, integer *nb, integer *ia, integer *ja, doublereal *a, doublereal *ub,
3231 doublereal *ub1, doublereal *db, doublereal *db1, doublereal *wb, doublereal *tri)
3232 {
3233 static doublereal c1, c2, c3, c4;
3234 static logical q1;
3235 static integer nr;
3236 static doublereal con;
3237 static doublereal dnrm;
3238 static doublereal gamold;
3239 static doublereal rhoold;
3240
3241 /* THIS SUBROUTINE, ITRSCG, PERFORMS ONE ITERATION OF THE */
3242 /* REDUCED SYSTEM CONJUGATE GRADIENT ALGORITHM. IT IS */
3243 /* CALLED BY RSCG. */
3244 /* */
3245 /* ... PARAMETER LIST: */
3246 /* */
3247 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
3248 /* NB INPUT INTEGER. CONTAINS THE NUMBER OF BLACK POINTS */
3249 /* IN THE RED-BLACK MATRIX. */
3250 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
3251 /* THE SPARSE MATRIX REPRESENTATION. */
3252 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
3253 /* MATRIX REPRESENTATION. */
3254 /* UB INPUT D.P. VECTOR. CONTAINS THE ESTIMATE FOR THE */
3255 /* SOLUTION ON THE BLACK POINTS AFTER IN ITERATIONS. */
3256 /* UB1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, UB1 CONTAINS THE */
3257 /* SOLUTION VECTOR AFTER IN-1 ITERATIONS. ON OUTPUT, */
3258 /* IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION */
3259 /* VECTOR. THIS IS ONLY FOR THE BLACK POINTS. */
3260 /* DB INPUT D.P. ARRAY. DB CONTAINS THE VALUE OF THE */
3261 /* CURRENT PSEUDO-RESIDUAL ON THE BLACK POINTS. */
3262 /* DB1 INPUT/OUTPUT D.P. ARRAY. DB1 CONTAINS THE PSEUDO- */
3263 /* RESIDUAL ON THE BLACK POINTS FOR THE IN-1 ITERATION */
3264 /* ON INPUT. ON OUTPUT, IT IS FOR THE IN+1 ITERATION. */
3265 /* WB D.P. ARRAY. WB IS USED FOR COMPUTATIONS INVOLVING */
3266 /* BLACK VECTORS. */
3267 /* TRI D.P. ARRAY. STORES THE TRIDIAGONAL MATRIX ASSOCIATED */
3268 /* WITH CONJUGATE GRADIENT ACCELERATION. */
3269
3270 /* ... COMPUTE NEW ESTIMATE FOR CME IF ADAPT = .TRUE. */
3271
3272 nr = *n - *nb;
3273 if (itcom2_1.adapt)
3274 chgcon_(tri, &gamold, &rhoold, &c__2);
3275
3276 /* ... TEST FOR STOPPING */
3277
3278 itcom3_1.delnnm = itpackddot_(nb, db, &c__1, db, &c__1);
3279 dnrm = itcom3_1.delnnm;
3280 con = itcom3_1.cme;
3281 pstop_(nb, &ub[nr], &dnrm, &con, &c__2, &q1);
3282 if (itcom2_1.halt)
3283 goto L30;
3284
3285 /* ... COMPUTE ACCELERATION PARAMETERS */
3286
3287 vfill_(&nr, ub1, &c_b21);
3288 prsred_(nb, &nr, ia, ja, a, db, ub1);
3289 vfill_(nb, wb, &c_b21);
3290 prsblk_(nb, &nr, ia, ja, a, ub1, wb);
3291 dnrm = itpackddot_(nb, db, &c__1, wb, &c__1);
3292 if (itcom1_1.isym != 0)
3293 rhoold = itpackddot_(nb, wb, &c__1, db1, &c__1);
3294
3295 parcon_(&dnrm, &c1, &c2, &c3, &c4, &gamold, &rhoold, &c__2);
3296
3297 /* ... COMPUTE UB(IN+1) AND DB(IN+1) */
3298
3299 sum3_(nb, &c1, db, &c2, &ub[nr], &c3, &ub1[nr]);
3300 sum3_(nb, &c1, wb, &c4, db, &c3, db1);
3301
3302 /* ... OUTPUT INTERMEDIATE INFORMATION */
3303
3304 L30:
3305 iterm_(nb, &a[nr], &ub[nr], wb, &c__6);
3306
3307 return 0;
3308 } /* itrscg_ */
3309
3310 /* Subroutine */
itrssi_(integer * n,integer * nb,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * ub,doublereal * ub1,doublereal * db)3311 int itrssi_(integer *n, integer *nb, integer *ia, integer *ja, doublereal *a,
3312 doublereal *rhs, doublereal *ub, doublereal *ub1, doublereal *db)
3313 {
3314 static doublereal c1, c2, c3;
3315 static logical q1;
3316 static integer nr;
3317 static doublereal dnrm;
3318 static doublereal cnst;
3319
3320 /* THIS SUBROUTINE, ITRSSI, PERFORMS ONE ITERATION OF THE */
3321 /* REDUCED SYSTEM SEMI-ITERATION ALGORITHM. IT IS */
3322 /* CALLED BY RSSI. */
3323 /* */
3324 /* ... PARAMETER LIST: */
3325 /* */
3326 /* N INPUT INTEGER. DIMENSION OF THE MATRIX. */
3327 /* NB INPUT INTEGER. CONTAINS THE NUMBER OF BLACK POINTS */
3328 /* IN THE RED-BLACK MATRIX. */
3329 /* IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF */
3330 /* THE SPARSE MATRIX REPRESENTATION. */
3331 /* A INPUT D.P. VECTOR. THE D.P. ARRAY OF THE SPARSE */
3332 /* MATRIX REPRESENTATION. */
3333 /* RHS INPUT D.P. VECTOR. CONTAINS THE RIGHT HAND SIDE */
3334 /* OF THE MATRIX PROBLEM. */
3335 /* UB INPUT D.P. VECTOR. CONTAINS THE ESTIMATE FOR THE */
3336 /* SOLUTION ON THE BLACK POINTS AFTER IN ITERATIONS. */
3337 /* UB1 INPUT/OUTPUT D.P. VECTOR. ON INPUT, UB1 CONTAINS THE */
3338 /* SOLUTION VECTOR AFTER IN-1 ITERATIONS. ON OUTPUT, */
3339 /* IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION */
3340 /* VECTOR. THIS IS ONLY FOR THE BLACK POINTS. */
3341 /* DB INPUT D.P. ARRAY. DB CONTAINS THE VALUE OF THE */
3342 /* CURRENT PSEUDO-RESIDUAL ON THE BLACK POINTS. */
3343
3344 /* ... COMPUTE UR(IN) INTO UB */
3345
3346 nr = *n - *nb;
3347 itpackdcopy_(&nr, rhs, &c__1, ub, &c__1);
3348 prsred_(nb, &nr, ia, ja, a, &ub[nr], ub);
3349
3350 /* ... COMPUTE PSEUDO-RESIDUAL, DB(IN) */
3351
3352 itpackdcopy_(nb, &rhs[nr], &c__1, db, &c__1);
3353 prsblk_(nb, &nr, ia, ja, a, ub, db);
3354 vevmw_(nb, db, &ub[nr]);
3355
3356 /* ... TEST FOR STOPPING */
3357
3358 itcom3_1.delnnm = itpackddot_(nb, db, &c__1, db, &c__1);
3359 dnrm = itcom3_1.delnnm;
3360 cnst = itcom3_1.cme;
3361 pstop_(nb, &ub[nr], &dnrm, &cnst, &c__2, &q1);
3362 if (itcom2_1.halt)
3363 goto L20;
3364
3365 if (! itcom2_1.adapt)
3366 goto L10;
3367
3368 /* ... TEST TO CHANGE PARAMETERS */
3369
3370 if (! tstchg_(&c__2))
3371 goto L10;
3372
3373 /* ... CHANGE PARAMETERS */
3374
3375 vfill_(&nr, ub1, &c_b21);
3376 prsred_(nb, &nr, ia, ja, a, db, ub1);
3377 dnrm = itpackddot_(&nr, ub1, &c__1, ub1, &c__1);
3378 chgsi_(&dnrm, &c__2);
3379 if (itcom2_1.adapt) { /* ... COMPUTE UB(N+1) AFTER CHANGING PARAMETERS */
3380 itpackdcopy_(nb, &ub[nr], &c__1, &ub1[nr], &c__1);
3381 itpackdaxpy_(nb, &itcom3_1.gamma, db, &c__1, &ub1[nr], &c__1);
3382 goto L20;
3383 }
3384 /* ... COMPUTE UB(N+1) WITHOUT CHANGE OF PARAMETERS */
3385 L10:
3386 parsi_(&c1, &c2, &c3, &c__2);
3387 sum3_(nb, &c1, db, &c2, &ub[nr], &c3, &ub1[nr]);
3388
3389 /* ... OUTPUT INTERMEDIATE INFORMATION */
3390
3391 L20:
3392 iterm_(nb, &a[nr], &ub[nr], db, &c__7);
3393
3394 return 0;
3395 } /* itrssi_ */
3396
bisrch_(integer * n,integer * k,integer * l)3397 integer bisrch_(integer *n, integer *k, integer *l)
3398 {
3399 /* Local variables */
3400 static integer jmid, jleft, jright;
3401
3402 /* ... BISRCH IS AN INTEGER FUNCTION WHICH USES A BISECTION SEARCH */
3403 /* TO FIND THE ENTRY J IN THE ARRAY K SUCH THAT THE VALUE L IS */
3404 /* GREATER THAN OR EQUAL TO K(J) AND STRICTLY LESS THAN K(J+1). */
3405
3406 /* ... PARAMETER LIST: */
3407
3408 /* N INTEGER LENGTH OF VECTOR K */
3409 /* K INTEGER VECTOR */
3410 /* L INTEGER CONSTANT SUCH THAT K(J) .GE. L .LT. K(J+1) */
3411 /* WITH J RETURNED AS VALUE OF INTEGER FUNCTION BISRCH */
3412
3413 if (*n == 2)
3414 return 1;
3415
3416 jleft = 1;
3417 jright = *n;
3418 jmid = (*n + 1) / 2;
3419
3420 L10:
3421 if (*l >= k[jmid-1]) /* ...... L .GE. K(LEFT) AND L .LT. K(JMID) */
3422 jleft = jmid;
3423 else /* ...... L .GE. K(JMID) AND L .LT. K(JRIGHT) */
3424 jright = jmid;
3425
3426 /* ...... TEST FOR CONVERGENCE */
3427
3428 if (jright - jleft == 1) /* ...... BISECTION SEARCH FINISHED */
3429 return jleft;
3430
3431 jmid = jleft + (jright - jleft + 1) / 2;
3432 goto L10;
3433 } /* bisrch_ */
3434
cheby_(doublereal * qa,doublereal * qt,doublereal * rrr,integer * ip,doublereal * cme,doublereal * sme)3435 doublereal cheby_(doublereal *qa, doublereal *qt, doublereal *rrr, integer *
3436 ip, doublereal *cme, doublereal *sme)
3437 {
3438 /* System generated locals */
3439 doublereal d__1;
3440
3441 /* Local variables */
3442 static doublereal x, y, z;
3443
3444 /* COMPUTES THE SOLUTION TO THE CHEBYSHEV EQUATION */
3445
3446 /* ... PARAMETER LIST: */
3447
3448 /* QA RATIO OF PSEUDO-RESIDUALS */
3449 /* QT VIRTUAL SPECTRAL RADIUS */
3450 /* RRR ADAPTIVE PARAMETER */
3451 /* IP NUMBER OF ITERATIONS SINCE LAST CHANGE OF */
3452 /* PARAMETERS */
3453 /* CME, ESTIMATES FOR THE LARGEST AND SMALLEST EIGEN- */
3454 /* SME VALUES OF THE ITERATION MATRIX */
3455
3456 z = (*qa + sqrt(abs(*qa * *qa - *qt * *qt))) * .5 * (pow_di(rrr, ip) + 1.);
3457 d__1 = 1. / (doublereal) ((real) (*ip));
3458 x = pow_dd(&z, &d__1);
3459 y = (x + *rrr / x) / (*rrr + 1.);
3460
3461 return (*cme + *sme + y * (2. - *cme - *sme)) * .5;
3462 } /* cheby_ */
3463
3464 /* Subroutine */
chgcon_(doublereal * tri,doublereal * gamold,doublereal * rhoold,integer * ibmth)3465 int chgcon_(doublereal *tri, doublereal *gamold, doublereal *rhoold, integer *ibmth)
3466 {
3467 /* Local variables */
3468 static integer ip, ib3;
3469 static doublereal end;
3470 static integer ier;
3471 static doublereal cmold, start;
3472
3473 /* COMPUTES THE NEW ESTIMATE FOR THE LARGEST EIGENVALUE FOR */
3474 /* CONJUGATE GRADIENT ACCELERATION. */
3475
3476 /* ... PARAMETER LIST: */
3477
3478 /* TRI TRIDIAGONAL MATRIX ASSOCIATED WITH THE EIGENVALUES */
3479 /* OF THE CONJUGATE GRADIENT POLYNOMIAL */
3480 /* GAMOLD */
3481 /* AND */
3482 /* RHOOLD PREVIOUS VALUES OF ACCELERATION PARAMETERS */
3483 /* IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY CG */
3484 /* IBMTH = 1, JACOBI */
3485 /* = 2, REDUCED SYSTEM */
3486 /* = 3, SSOR */
3487
3488 switch (*ibmth) {
3489 case 1: goto L10;
3490 case 2: goto L20;
3491 case 3: goto L30;
3492 }
3493
3494 /* ... JACOBI CONJUGATE GRADIENT */
3495
3496 L10:
3497 start = itcom3_1.cme;
3498 ip = itcom1_1.in;
3499 goto L40;
3500
3501 /* ... REDUCED SYSTEM CG */
3502
3503 L20:
3504 start = itcom3_1.cme * itcom3_1.cme;
3505 ip = itcom1_1.in;
3506 goto L40;
3507
3508 /* ... SSOR CG */
3509
3510 L30:
3511 if (itcom2_1.adapt)
3512 start = itcom3_1.spr;
3513
3514 if (! itcom2_1.adapt)
3515 start = itcom3_1.specr;
3516
3517 ip = itcom1_1.in - itcom1_1.is;
3518
3519 /* ... DEFINE THE MATRIX */
3520
3521 L40:
3522 if (ip >= 2)
3523 goto L60;
3524
3525 if (ip != 1) { /* ... IP = 0 */
3526 end = 0.;
3527 cmold = 0.;
3528 }
3529 else { /* ... IP = 1 */
3530 end = 1. - 1. / itcom3_1.gamma;
3531 tri[0] = end;
3532 tri[1] = 0.;
3533 }
3534 goto L110;
3535
3536 /* ... IP > 1 */
3537
3538 L60:
3539 if (ip > 2 && abs(start - cmold) <= itcom3_1.zeta * start)
3540 goto L120;
3541 cmold = start;
3542
3543 /* ... COMPUTE THE LARGEST EIGENVALUE */
3544
3545 tri[(ip << 1) - 2] = 1. - 1. / itcom3_1.gamma;
3546 tri[(ip << 1) - 1] = (itcom3_1.rho - 1.) / (itcom3_1.rho * *rhoold * itcom3_1.gamma * *gamold);
3547 ib3 = ip + ip / 2 + 1;
3548 end = eigvns_(&ip, tri, &tri[ip << 1], &tri[ib3 << 1], &ier);
3549
3550 if (ier != 0)
3551 goto L130;
3552
3553 /* ... SET SPECTRAL RADIUS FOR THE VARIOUS METHODS */
3554
3555 L110:
3556 if (*ibmth == 1)
3557 itcom3_1.cme = end;
3558
3559 if (*ibmth == 2)
3560 itcom3_1.cme = sqrt((abs(end)));
3561
3562 if (*ibmth == 3 && itcom2_1.adapt)
3563 itcom3_1.spr = end;
3564
3565 if (*ibmth == 3 && ! itcom2_1.adapt)
3566 itcom3_1.specr = end;
3567
3568 return 0;
3569
3570 /* ... RELATIVE CHANGE IN CME IS LESS THAN ZETA. THEREFORE STOP */
3571 /* CHANGING. */
3572
3573 L120:
3574 itcom2_1.adapt = FALSE_;
3575 itcom2_1.partad = FALSE_;
3576 return 0;
3577
3578 /* ... ESTIMATE FOR CME > 1.D0. THEREFORE NEED TO STOP ADAPTIVE */
3579 /* PROCEDURE AND KEEP OLD VALUE OF CME. */
3580
3581 L130:
3582 itcom2_1.adapt = FALSE_;
3583 itcom2_1.partad = FALSE_;
3584
3585 return 0;
3586 } /* chgcon_ */
3587
3588 /* Subroutine */
chgsi_(doublereal * dtnrm,integer * ibmth)3589 int chgsi_(doublereal *dtnrm, integer *ibmth)
3590 {
3591 /* System generated locals */
3592 integer i__1;
3593
3594 /* Local variables */
3595 static doublereal zm1, zm2;
3596 static doublereal cmold;
3597
3598 /* ... COMPUTES NEW CHEBYSHEV ACCELERATION PARAMETERS ADAPTIVELY. */
3599
3600 /* ... PARAMETER LIST: */
3601
3602 /* DTNRM NUMERATOR OF RAYLEIGH QUOTIENT */
3603 /* IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY SI */
3604 /* IBMTH = 1, JACOBI */
3605 /* = 2, REDUCED SYSTEM */
3606 /* = 3, SYMMETRIC SOR */
3607
3608 switch (*ibmth) {
3609 case 1: goto L10;
3610 case 2: goto L30;
3611 case 3: goto L50;
3612 }
3613
3614 /* --------------------- */
3615 /* ... JACOBI SEMI-ITERATIVE */
3616 /* --------------------- */
3617
3618 /* ... CHEBYSHEV EQUATION */
3619
3620 L10:
3621 if (itcom1_1.in == 0)
3622 zm1 = itcom3_1.cme;
3623
3624 if (itcom1_1.in != 0) {
3625 i__1 = itcom1_1.in - itcom1_1.is;
3626 zm1 = cheby_(&itcom3_1.qa, &itcom3_1.qt, &itcom3_1.rrr, &i__1, &itcom3_1.cme, &itcom3_1.sme);
3627 }
3628
3629 /* ... RAYLEIGH QUOTIENT */
3630
3631 zm2 = *dtnrm / itcom3_1.delnnm;
3632
3633 /* ... COMPUTATION OF ITERATIVE PARAMETERS */
3634
3635 cmold = itcom3_1.cme;
3636 itcom3_1.cme = max(max(zm1,zm2),cmold);
3637 if (itcom3_1.cme >= 1.)
3638 goto L20;
3639
3640 if (itcom2_1.caseii)
3641 itcom3_1.sme = -itcom3_1.cme;
3642
3643 itcom3_1.sige = (itcom3_1.cme - itcom3_1.sme) / (2. - itcom3_1.cme - itcom3_1.sme);
3644 itcom3_1.gamma = 2. / (2. - itcom3_1.cme - itcom3_1.sme);
3645 itcom3_1.rrr = (1. - sqrt(abs(1. - itcom3_1.sige * itcom3_1.sige))) /
3646 (sqrt(abs(1. - itcom3_1.sige * itcom3_1.sige)) + 1.);
3647 itcom1_1.is = itcom1_1.in;
3648 itcom3_1.delsnm = itcom3_1.delnnm;
3649 itcom3_1.rho = 1.;
3650 return 0;
3651
3652 /* ... ADAPTIVE PROCEDURE FAILED FOR JACOBI SI */
3653
3654 L20:
3655 itcom3_1.cme = cmold;
3656 itcom2_1.adapt = FALSE_;
3657 return 0;
3658
3659 /* ----------------------------- */
3660 /* ... REDUCED SYSTEM SEMI-ITERATIVE */
3661 /* ----------------------------- */
3662
3663 /* ... CHEBYSHEV EQUATION */
3664
3665 L30:
3666 if (itcom1_1.in == 0)
3667 zm1 = itcom3_1.cme;
3668
3669 if (itcom1_1.in != 0) {
3670 i__1 = (itcom1_1.in - itcom1_1.is) << 1;
3671 zm1 = cheby_(&itcom3_1.qa, &itcom3_1.qt, &itcom3_1.rrr, &i__1, &c_b21, &c_b21);
3672 }
3673
3674 /* ... RAYLEIGH QUOTIENT */
3675
3676 zm2 = sqrt(abs(*dtnrm / itcom3_1.delnnm));
3677
3678 /* ... COMPUTATION OF NEW ITERATIVE PARAMETERS */
3679
3680 cmold = itcom3_1.cme;
3681 itcom3_1.cme = max(max(zm1,zm2),cmold);
3682 if (itcom3_1.cme >= 1.) {
3683 /* ... ADAPTIVE PROCEDURE FAILED FOR REDUCED SYSTEM SI */
3684 itcom3_1.cme = cmold;
3685 itcom2_1.adapt = FALSE_;
3686 return 0;
3687 }
3688 itcom3_1.sige = itcom3_1.cme * itcom3_1.cme / (2. - itcom3_1.cme * itcom3_1.cme);
3689 itcom3_1.gamma = 2. / (2. - itcom3_1.cme * itcom3_1.cme);
3690 itcom3_1.rrr = (1. - sqrt(abs(1. - itcom3_1.cme * itcom3_1.cme))) /
3691 (sqrt(abs(1. - itcom3_1.cme * itcom3_1.cme)) + 1.);
3692 itcom1_1.is = itcom1_1.in;
3693 itcom3_1.delsnm = itcom3_1.delnnm;
3694 itcom3_1.rho = 1.;
3695 return 0;
3696
3697 /* ----------------------------- */
3698 /* ... SYMMETRIC SOR SEMI-ITERATIVE */
3699 /* ---------------------------- */
3700
3701 L50:
3702 if (itcom3_1.specr == 0.)
3703 itcom3_1.specr = .171572875;
3704
3705 if (itcom1_1.in != 0) {
3706 i__1 = itcom1_1.in - itcom1_1.is;
3707 zm1 = cheby_(&itcom3_1.qa, &itcom3_1.qt, &itcom3_1.rrr, &i__1, &itcom3_1.specr, &c_b21);
3708 }
3709 else {
3710 zm1 = itcom3_1.specr;
3711 itcom3_1.spr = itcom3_1.specr;
3712 }
3713
3714 /* ... RAYLEIGH QUOTIENT */
3715
3716 zm2 = *dtnrm / itcom3_1.delnnm;
3717
3718 /* ... COMPUTATION OF NEW ESTIMATE FOR SPECTRAL RADIUS */
3719
3720 /* ... PARTIALLY ADAPTIVE SSOR SI */
3721
3722 if (! itcom2_1.adapt) {
3723 itcom3_1.specr = max(max(zm1,zm2),itcom3_1.specr);
3724 itcom1_1.is = itcom1_1.in + 1;
3725 itcom3_1.delsnm = itcom3_1.delnnm;
3726 return 0;
3727 }
3728
3729 /* ... FULLY ADAPTIVE SSOR SI */
3730
3731 itcom3_1.spr = max(max(zm1,zm2),itcom3_1.spr);
3732 return 0;
3733 } /* chgsi_ */
3734
chgsme_(doublereal * oldnrm,integer * icnt)3735 logical chgsme_(doublereal *oldnrm, integer *icnt)
3736 {
3737 /* System generated locals */
3738 integer i__1;
3739 doublereal d__1, d__2;
3740
3741 /* Local variables */
3742 static doublereal q, z;
3743 static integer ip;
3744 static doublereal rn, wp, sm1, sm2;
3745
3746 /* ... THIS FUNCTION TESTS FOR JACOBI SI WHETHER SME SHOULD BE CHANGED */
3747 /* ... WHEN CASEII = .FALSE.. IF THE TEST IS POSITIVE THE NEW VALUE */
3748 /* ... OF SME IS COMPUTED. */
3749
3750 /* ... PARAMETER LIST: */
3751
3752 /* OLDNRM SQUARE OF THE NORM OF THE PSEUDO-RESIDUAL */
3753 /* AT THE LAST ITERATION */
3754 /* ICNT NUMBER OF ITERATIONS SINCE LAST CHANGE OF */
3755 /* PARAMETERS */
3756
3757 rn = sqrt(itcom3_1.delnnm / *oldnrm);
3758 if (! (itcom3_1.qa > 1. && rn > 1.))
3759 return FALSE_;
3760
3761 if (itcom1_1.in <= itcom1_1.is + 2)
3762 return FALSE_;
3763
3764 ++(*icnt);
3765 if (*icnt < 3)
3766 return FALSE_;
3767
3768 /* ... CHANGE SME IN J-SI ADAPTIVE PROCEDURE */
3769
3770 sm1 = 0.;
3771 sm2 = 0.;
3772 if (itcom3_1.sme >= itcom3_1.cme)
3773 goto L10;
3774
3775 /* ... COMPUTE SM1 */
3776
3777 ip = itcom1_1.in - itcom1_1.is;
3778 q = itcom3_1.qa * (pow_di(&itcom3_1.rrr, &ip) + 1.) / (sqrt(pow_di(&itcom3_1.rrr, &ip)) * 2.);
3779 d__1 = q + sqrt(q * q - 1.);
3780 d__2 = 1. / (doublereal) ((real) ip);
3781 z = pow_dd(&d__1, &d__2);
3782 wp = (z * z + 1.) / (z * 2.);
3783 sm1 = (itcom3_1.cme + itcom3_1.sme - wp * (itcom3_1.cme - itcom3_1.sme)) * .5;
3784
3785 /* ... COMPUTE SM2 */
3786
3787 i__1 = ip - 1;
3788 q = rn * (pow_di(&itcom3_1.rrr, &ip) + 1.) / ((pow_di(&itcom3_1.rrr, &i__1) + 1.) * sqrt(itcom3_1.rrr));
3789 wp = (q * q + 1.) / (q * 2.);
3790 sm2 = (itcom3_1.cme + itcom3_1.sme - wp * (itcom3_1.cme - itcom3_1.sme)) *
3791 .5;
3792
3793 L10:
3794 itcom3_1.sme = min(min(min(sm1 * 1.25,sm2 * 1.25),itcom3_1.sme),-1.);
3795 itcom3_1.sige = (itcom3_1.cme - itcom3_1.sme) / (2. - itcom3_1.cme - itcom3_1.sme);
3796 itcom3_1.gamma = 2. / (2. - itcom3_1.cme - itcom3_1.sme);
3797 itcom3_1.rrr = (1. - sqrt(1. - itcom3_1.sige * itcom3_1.sige)) /
3798 (sqrt(1. - itcom3_1.sige * itcom3_1.sige) + 1.);
3799 itcom1_1.is = itcom1_1.in;
3800 itcom3_1.delsnm = itcom3_1.delnnm;
3801 itcom3_1.rho = 1.;
3802
3803 return TRUE_;
3804 } /* chgsme_ */
3805
3806 /* Subroutine */
itpackdaxpy_(integer * n,doublereal * da,doublereal * dx,integer * incx,doublereal * dy,integer * incy)3807 int itpackdaxpy_(integer *n, doublereal *da, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
3808 {
3809 /* Local variables */
3810 static integer i, m, ix, iy, ns;
3811
3812 /* OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. */
3813
3814 if (*n <= 0 || *da == 0.)
3815 return 0;
3816
3817 if (*incx == *incy) {
3818 if (*incx < 1)
3819 goto L10;
3820 else if (*incx == 1)
3821 goto L30;
3822 else
3823 goto L70;
3824 }
3825 L10:
3826
3827 /* CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. */
3828
3829 ix = 0;
3830 iy = 0;
3831 if (*incx < 0)
3832 ix = (-(*n) + 1) * *incx;
3833
3834 if (*incy < 0)
3835 iy = (-(*n) + 1) * *incy;
3836
3837 for (i = 0; i < *n; ++i) {
3838 dy[iy] += *da * dx[ix];
3839 ix += *incx;
3840 iy += *incy;
3841 }
3842 return 0;
3843
3844 /* CODE FOR BOTH INCREMENTS EQUAL TO 1 */
3845
3846 /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. */
3847
3848 L30:
3849 m = *n - (*n / 4 << 2);
3850 for (i = 0; i < m; ++i)
3851 dy[i] += *da * dx[i];
3852
3853 for (i = m; i < *n; i += 4) {
3854 dy[i] += *da * dx[i];
3855 dy[i + 1] += *da * dx[i + 1];
3856 dy[i + 2] += *da * dx[i + 2];
3857 dy[i + 3] += *da * dx[i + 3];
3858 }
3859 return 0;
3860
3861 /* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. */
3862
3863 L70:
3864 ns = *n * *incx;
3865 for (i = 0; *incx < 0 ? i >= ns-1 : i < ns; i += *incx)
3866 dy[i] = *da * dx[i] + dy[i];
3867
3868 return 0;
3869 } /* itpackdaxpy_ */
3870
3871 /* Subroutine */
itpackdcopy_(integer * n,doublereal * dx,integer * incx,doublereal * dy,integer * incy)3872 int itpackdcopy_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
3873 {
3874 /* Local variables */
3875 static integer i, m, ix, iy, ns;
3876
3877 /* COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. */
3878
3879 if (*n <= 0)
3880 return 0;
3881
3882 if (*incx == *incy) {
3883 if (*incx < 1)
3884 goto L10;
3885 else if (*incx == 1)
3886 goto L30;
3887 else
3888 goto L70;
3889 }
3890 L10:
3891
3892 /* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. */
3893
3894 ix = 0;
3895 iy = 0;
3896 if (*incx < 0)
3897 ix = (-(*n) + 1) * *incx;
3898
3899 if (*incy < 0)
3900 iy = (-(*n) + 1) * *incy;
3901
3902 for (i = 0; i < *n; ++i) {
3903 dy[iy] = dx[ix];
3904 ix += *incx;
3905 iy += *incy;
3906 }
3907 return 0;
3908
3909 /* CODE FOR BOTH INCREMENTS EQUAL TO 1 */
3910
3911 /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. */
3912
3913 L30:
3914 m = *n - *n / 7 * 7;
3915 for (i = 0; i < m; ++i)
3916 dy[i] = dx[i];
3917
3918 for (i = m; i < *n; i += 7) {
3919 dy[i] = dx[i];
3920 dy[i + 1] = dx[i + 1];
3921 dy[i + 2] = dx[i + 2];
3922 dy[i + 3] = dx[i + 3];
3923 dy[i + 4] = dx[i + 4];
3924 dy[i + 5] = dx[i + 5];
3925 dy[i + 6] = dx[i + 6];
3926 }
3927 return 0;
3928
3929 /* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. */
3930
3931 L70:
3932 ns = *n * *incx;
3933 for (i = 0; *incx < 0 ? i >= ns-1 : i < ns; i += *incx)
3934 dy[i] = dx[i];
3935
3936 return 0;
3937 } /* itpackdcopy_ */
3938
itpackddot_(integer * n,doublereal * dx,integer * incx,doublereal * dy,integer * incy)3939 doublereal itpackddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
3940 {
3941 /* System generated locals */
3942 doublereal ret_val;
3943
3944 /* Local variables */
3945 static integer i, m, ix, iy, ns;
3946
3947 /* RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. */
3948
3949 ret_val = 0.;
3950 if (*n <= 0)
3951 return 0.;
3952
3953 if (*incx == *incy) {
3954 if (*incx < 1)
3955 goto L10;
3956 else if (*incx == 1)
3957 goto L30;
3958 else
3959 goto L70;
3960 }
3961 L10:
3962
3963 /* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. */
3964
3965 ix = 0;
3966 iy = 0;
3967 if (*incx < 0)
3968 ix = (-(*n) + 1) * *incx;
3969
3970 if (*incy < 0)
3971 iy = (-(*n) + 1) * *incy;
3972
3973 for (i = 0; i < *n; ++i) {
3974 ret_val += dx[ix] * dy[iy];
3975 ix += *incx;
3976 iy += *incy;
3977 }
3978 return ret_val;
3979
3980 /* CODE FOR BOTH INCREMENTS EQUAL TO 1. */
3981
3982 /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. */
3983
3984 L30:
3985 m = *n - *n / 5 * 5;
3986 for (i = 0; i < m; ++i)
3987 ret_val += dx[i] * dy[i];
3988
3989 for (i = m; i < *n; i += 5)
3990 ret_val += dx[i]*dy[i] + dx[i+1]*dy[i+1] + dx[i+2]*dy[i+2] + dx[i+3]*dy[i+3] + dx[i+4]*dy[i+4];
3991 return ret_val;
3992
3993 /* CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. */
3994
3995 L70:
3996 ns = *n * *incx;
3997 for (i = 0; *incx < 0 ? i >= ns-1 : i < ns; i += *incx)
3998 ret_val += dx[i] * dy[i];
3999
4000 return ret_val;
4001 } /* itpackddot_ */
4002
determ_(integer * n,doublereal * tri,doublereal * xlmda)4003 doublereal determ_(integer *n, doublereal *tri, doublereal *xlmda)
4004 {
4005 /* Local variables */
4006 static integer l;
4007 static doublereal d1, d2, d3;
4008 static integer icnt;
4009
4010 /* THIS SUBROUTINE COMPUTES THE DETERMINANT OF A SYMMETRIC */
4011 /* TRIDIAGONAL MATRIX GIVEN BY TRI. DET(TRI - XLMDA*I) = 0 */
4012
4013 /* ... PARAMETER LIST */
4014
4015 /* N ORDER OF TRIDIAGONAL SYSTEM */
4016 /* TRI SYMMETRIC TRIDIAGONAL MATRIX OF ORDER N */
4017 /* XLMDA ARGUMENT FOR CHARACTERISTIC EQUATION */
4018
4019 d2 = tri[(*n << 1) - 2] - *xlmda;
4020 d1 = d2 * (tri[(*n << 1) - 4] - *xlmda) - tri[(*n << 1) - 1];
4021 if (*n == 2)
4022 return d1;
4023
4024 for (icnt = 2; icnt < *n; ++icnt) {
4025 l = *n - icnt + 1;
4026 d3 = d2;
4027 d2 = d1;
4028 d1 = (tri[((l - 1) << 1) - 2] - *xlmda) * d2 - d3 * tri[(l << 1) - 1];
4029 }
4030
4031 return d1;
4032 } /* determ_ */
4033
4034 /* Subroutine */
dfault_(integer * iparm,doublereal * rparm)4035 int dfault_(integer *iparm, doublereal *rparm)
4036 {
4037 /* ... THIS SUBROUTINE SETS THE DEFAULT VALUES OF IPARM AND RPARM. */
4038
4039 /* ... PARAMETER LIST: */
4040
4041 /* IPARM */
4042 /* AND */
4043 /* RPARM ARRAYS SPECIFYING OPTIONS AND TOLERANCES */
4044
4045 /* DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE */
4046
4047 /* DRELPR - COMPUTER PRECISION (APPROX.) */
4048 /* IF INSTALLER OF PACKAGE DOES NOT KNOW DRELPR VALUE, */
4049 /* AN APPROXIMATE VALUE CAN BE DETERMINED FROM A SIMPLE */
4050 /* FORTRAN PROGRAM SUCH AS */
4051
4052 /* DOUBLE PRECISION DRELPR, TEMP */
4053 /* DRELPR = 1.0D0 */
4054 /* 2 DRELPR = 0.5D0*DRELPR */
4055 /* TEMP = DRELPR + 1.0D0 */
4056 /* IF(TEMP .GT. 1.0D0) GO TO 2 */
4057 /* WRITE(6,3) DRELPR */
4058 /* 3 FORMAT(5X,D15.8) */
4059 /* STOP */
4060 /* END */
4061
4062 /* SOME VALUES ARE: */
4063
4064 /* DRELPR = 1.26D-29 FOR CDC CYBER 170/750 (APPROX.) 2**-96 */
4065 /* = 2.22D-16 FOR DEC 10 (APPROX.) 2**-52 */
4066 /* = 7.11D-15 FOR VAX 11/780 (APPROX.) 2**-47 */
4067 /* = 1.14D-13 FOR IBM 370/158 (APPROX.) 2**-43 */
4068
4069 /* *** SHOULD BE CHANGED FOR OTHER MACHINES *** */
4070
4071 /* TO FACILITATE CONVERGENCE, RPARM(1) SHOULD BE SET TO */
4072 /* 500.*DRELPR OR LARGER */
4073
4074 itcom3_1.drelpr = 7.11e-15;
4075
4076 iparm[0] = 100;
4077 iparm[1] = 0;
4078 iparm[2] = 0;
4079 iparm[3] = 6;
4080 iparm[4] = 0;
4081 iparm[5] = 1;
4082 iparm[6] = 1;
4083 iparm[7] = 0;
4084 iparm[8] = -1;
4085 iparm[9] = 0;
4086 iparm[10] = 0;
4087 iparm[11] = 0;
4088
4089 rparm[0] = 5e-6;
4090 rparm[1] = 0.;
4091 rparm[2] = 0.;
4092 rparm[3] = .75;
4093 rparm[4] = 1.;
4094 rparm[5] = 0.;
4095 rparm[6] = .25;
4096 rparm[7] = itcom3_1.drelpr * 100.;
4097 rparm[8] = 0.;
4098 rparm[9] = 0.;
4099 rparm[10] = 0.;
4100 rparm[11] = 0.;
4101
4102 return 0;
4103 } /* dfault_ */
4104
4105 /* Subroutine */
echall_(integer * nn,integer * ia,integer * ja,doublereal * a,doublereal * rhs,integer * iparm,doublereal * rparm,integer * icall)4106 int echall_(integer *nn, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
4107 integer *iparm, doublereal *rparm, integer *icall)
4108 {
4109 (void)nn; (void)ia; (void)ja; (void)a; (void)rhs;
4110 /* ... THIS ROUTINE INITIALIZES THE ITPACK COMMON BLOCKS FROM THE */
4111 /* ... INFORMATION CONTAINED IN IPARM AND RPARM. ECHALL ALSO PRINTS THE */
4112 /* ... VALUES OF ALL THE PARAMETERS IN IPARM AND RPARM. */
4113
4114 /* ... PARAMETER LIST: */
4115
4116 /* IPARM */
4117 /* AND */
4118 /* RPARM ARRAYS OF PARAMETERS SPECIFYING OPTIONS AND */
4119 /* TOLERANCES */
4120 /* ICALL INDICATOR OF WHICH PARAMETERS ARE BEING PRINTED */
4121 /* ICALL = 1, INITIAL PARAMETERS */
4122 /* ICALL = 2, FINAL PARAMETERS */
4123
4124 if (*icall != 1)
4125 return 0;
4126
4127 /* ... INITIALIZE ITPACK COMMON */
4128
4129 itcom3_1.zeta = rparm[0];
4130 itcom3_1.cme = rparm[1];
4131 itcom3_1.sme = rparm[2];
4132 itcom3_1.ff = rparm[3];
4133 itcom3_1.omega = rparm[4];
4134 itcom3_1.specr = rparm[5];
4135 itcom3_1.betab = rparm[6];
4136 itcom1_1.itmax = iparm[0];
4137 itcom1_1.level = iparm[1];
4138 itcom1_1.isym = iparm[4];
4139
4140 itcom2_1.adapt = FALSE_;
4141 itcom2_1.partad = FALSE_;
4142 itcom2_1.betadt = FALSE_;
4143 if (iparm[5] == 1 || iparm[5] == 3)
4144 itcom2_1.adapt = TRUE_;
4145
4146 if (iparm[5] == 1)
4147 itcom2_1.betadt = TRUE_;
4148
4149 if (iparm[5] == 2)
4150 itcom2_1.partad = TRUE_;
4151
4152 itcom2_1.caseii = FALSE_;
4153 if (iparm[6] == 2)
4154 itcom2_1.caseii = TRUE_;
4155
4156 if (itcom2_1.caseii)
4157 itcom3_1.sme = -itcom3_1.cme;
4158
4159 if (! itcom2_1.caseii && itcom3_1.sme == 0.)
4160 itcom3_1.sme = -1.;
4161
4162 itcom3_1.spr = itcom3_1.sme;
4163
4164 /* ... SET REST OF COMMON VARIABLES TO ZERO */
4165
4166 itcom1_1.in = 0;
4167 itcom1_1.is = 0;
4168 itcom2_1.halt = FALSE_;
4169 itcom3_1.bdelnm = 0.;
4170 itcom3_1.delnnm = 0.;
4171 itcom3_1.delsnm = 0.;
4172 itcom3_1.gamma = 0.;
4173 itcom3_1.qa = 0.;
4174 itcom3_1.qt = 0.;
4175 itcom3_1.rho = 0.;
4176 itcom3_1.rrr = 0.;
4177 itcom3_1.sige = 0.;
4178 itcom3_1.stptst = 0.;
4179 itcom3_1.udnm = 0.;
4180
4181 if (itcom1_1.level <= 4)
4182 return 0;
4183
4184 /* THIS SECTION OF ECHALL CAUSES PRINTING OF THE LINEAR SYSTEM AND */
4185 /* THE ITERATIVE PARAMETERS */
4186
4187 return 0;
4188 } /* echall_ */
4189
4190 /* Subroutine */
echout_(integer * iparm,doublereal * rparm,integer * imthd)4191 int echout_(integer *iparm, doublereal *rparm, integer *imthd)
4192 {
4193 /* THIS ROUTINE INITIALIZES THE ITPACK COMMON BLOCKS FROM THE */
4194 /* INFORMATION CONTAINED IN IPARM AND RPARM. */
4195
4196 /* ... PARAMETER LIST: */
4197
4198 /* IPARM */
4199 /* AND */
4200 /* RPARM ARRAYS OF PARAMETERS SPECIFYING OPTIONS AND */
4201 /* TOLERANCES */
4202 /* IMTHD INDICATOR OF METHOD */
4203 /* IMTHD = 1, JCG */
4204 /* IMTHD = 2, JSI */
4205 /* IMTHD = 3, SOR */
4206 /* IMTHD = 4, SSORCG */
4207 /* IMTHD = 5, SSORSI */
4208 /* IMTHD = 6, RSCG */
4209 /* IMTHD = 7, RSSI */
4210
4211 itcom3_1.zeta = rparm[0];
4212 itcom3_1.cme = rparm[1];
4213 itcom3_1.sme = rparm[2];
4214 itcom3_1.ff = rparm[3];
4215 itcom3_1.omega = rparm[4];
4216 itcom3_1.specr = rparm[5];
4217 itcom3_1.betab = rparm[6];
4218 itcom1_1.itmax = iparm[0];
4219 itcom1_1.level = iparm[1];
4220 itcom1_1.isym = iparm[4];
4221
4222 itcom2_1.adapt = FALSE_;
4223 itcom2_1.partad = FALSE_;
4224 itcom2_1.betadt = FALSE_;
4225 if (iparm[5] == 1 || iparm[5] == 3)
4226 itcom2_1.adapt = TRUE_;
4227
4228 if (iparm[5] == 1)
4229 itcom2_1.betadt = TRUE_;
4230
4231 if (iparm[5] == 2)
4232 itcom2_1.partad = TRUE_;
4233
4234 itcom2_1.caseii = FALSE_;
4235 if (iparm[6] == 2)
4236 itcom2_1.caseii = TRUE_;
4237
4238 if (itcom2_1.caseii)
4239 itcom3_1.sme = -itcom3_1.cme;
4240
4241 if (! itcom2_1.caseii && itcom3_1.sme == 0.)
4242 itcom3_1.sme = -1.;
4243
4244 itcom3_1.spr = itcom3_1.sme;
4245
4246 /* ... SET REST OF COMMON VARIABLES TO ZERO */
4247
4248 itcom1_1.in = 0;
4249 itcom1_1.is = 0;
4250 itcom2_1.halt = FALSE_;
4251 itcom3_1.bdelnm = 0.;
4252 itcom3_1.delnnm = 0.;
4253 itcom3_1.delsnm = 0.;
4254 itcom3_1.gamma = 0.;
4255 itcom3_1.qa = 0.;
4256 itcom3_1.qt = 0.;
4257 itcom3_1.rho = 0.;
4258 itcom3_1.rrr = 0.;
4259 itcom3_1.sige = 0.;
4260 itcom3_1.stptst = 0.;
4261 itcom3_1.udnm = 0.;
4262 if (itcom1_1.level <= 2)
4263 return 0;
4264
4265 /* ... THIS SECTION OF ECHOUT ECHOES THE INPUT VALUES FOR THE INITIAL */
4266 /* ITERATIVE PARAMETERS */
4267
4268 switch (*imthd) {
4269 case 1: goto L80;
4270 case 2: goto L20;
4271 case 3: goto L100;
4272 case 4: goto L60;
4273 case 5: goto L40;
4274 case 6: goto L80;
4275 case 7: goto L20;
4276 }
4277
4278 /* ... JSI, RSSI */
4279
4280 L20:
4281 return 0;
4282
4283 /* ... SSORSI */
4284
4285 L40:
4286 return 0;
4287
4288 /* ... SSORCG */
4289
4290 L60:
4291 return 0;
4292
4293 /* ... JCG, RSCG */
4294
4295 L80:
4296 if (itcom2_1.adapt)
4297 return 0;
4298
4299 L100:
4300 return 0;
4301 } /* echout_ */
4302
eigvns_(integer * n,doublereal * tri,doublereal * d,doublereal * e2,integer * ier)4303 doublereal eigvns_(integer *n, doublereal *tri, doublereal *d, doublereal *e2, integer *ier)
4304 {
4305 /* Local variables */
4306 static integer i;
4307
4308 /* COMPUTES THE LARGEST EIGENVALUE OF A SYMMETRIC TRIDIAGONAL MATRIX */
4309 /* FOR CONJUGATE GRADIENT ACCELERATION. */
4310
4311 /* ... PARAMETER LIST: */
4312
4313 /* N ORDER OF TRIDIAGONAL SYSTEM */
4314 /* TRI SYMMETRIC TRIDIAGONAL MATRIX OF ORDER N */
4315 /* D ARRAY FOR EQRT1S(NEGATIVE DIAGONAL ELEMENTS) */
4316 /* E2 ARRAY FOR EQRT1S (SUPER DIAGONAL ELEMENTS) */
4317 /* IER ERROR FLAG: ON RETURN, IER=0 INDICATES THAT */
4318 /* THE LARGEST EIGENVALUE OF TRI WAS FOUND. */
4319
4320 d[0] = -tri[0];
4321 for (i = 1; i < *n; ++i) {
4322 d[i] = -tri[i << 1];
4323 e2[i] = abs(tri[(i << 1) + 1]);
4324 }
4325
4326 //eqrt1s_(d, e2, n, &c__1, &c__0, ier);
4327 v3p_netlib_tqlrat_(n, d, e2, ier);
4328
4329 return -d[0];
4330 } /* eigvns_ */
4331
ipstr_(doublereal * omega)4332 integer ipstr_(doublereal *omega)
4333 {
4334 /* System generated locals */
4335 integer i__1;
4336
4337 /* Local variables */
4338 static integer ip;
4339 static doublereal wm1;
4340
4341 /* FINDS THE SMALLEST INTEGER, IPSTR, GREATER THAN 5 SUCH THAT */
4342 /* IPSTR * (OMEGA-1)**(IPSTR-1) .LE. 0.50. IPSTR WILL BE SET */
4343 /* IN LOOP. */
4344
4345 /* ... PARAMETER LIST: */
4346
4347 /* OMEGA RELAXATION FACTOR FOR SOR METHOD */
4348
4349 wm1 = *omega - 1.;
4350
4351 for (ip = 6; ip <= 940; ++ip) {
4352 i__1 = ip - 1;
4353 if ((doublereal) ((real) ip) * pow_di(&wm1, &i__1) <= .5)
4354 return ip;
4355 }
4356 return 940;
4357 } /* ipstr_ */
4358
4359 /* Subroutine */
iterm_(integer * nn,doublereal * a,doublereal * u,doublereal * wk,integer * imthdd)4360 int iterm_(integer *nn, doublereal *a, doublereal *u, doublereal *wk, integer *imthdd)
4361 {
4362 /* Local variables */
4363 static integer i;
4364
4365 (void)imthdd;
4366 /* THIS ROUTINE PRODUCES THE ITERATION SUMMARY LINE AT THE END */
4367 /* OF EACH ITERATION. IF LEVEL = 5, THE LATEST APPROXIMATION */
4368 /* TO THE SOLUTION WILL BE PRINTED. */
4369
4370 /* ... PARAMETER LIST: */
4371
4372 /* NN ORDER OF SYSTEM OR, FOR REDUCED SYSTEM */
4373 /* ROUTINES, ORDER OF BLACK SUBSYSTEM */
4374 /* A ITERATION MATRIX */
4375 /* U SOLUTION ESTIMATE */
4376 /* WK WORK ARRAY OF LENGTH NN */
4377 /* IMTHD INDICATOR OF METHOD (=IMTHDD) */
4378 /* IMTHD = 1, JCG */
4379 /* IMTHD = 2, JSI */
4380 /* IMTHD = 3, SOR */
4381 /* IMTHD = 4, SSORCG */
4382 /* IMTHD = 5, SSORSI */
4383 /* IMTHD = 6, RSCG */
4384 /* IMTHD = 7, RSSI */
4385
4386 /* ... PRINT VARIOUS PARAMETERS AFTER EACH ITERATION */
4387
4388 if (itcom1_1.level < 2)
4389 return 0;
4390
4391 /* ... PRINT HEADER FOR JCG AND RSCG */
4392
4393 /* ... PRINT SUMMARY LINE */
4394
4395 /* ... PRINT HEADER FOR SSOR-SI */
4396
4397 /* ... PRINT SUMMARY LINE */
4398
4399 /* ... PRINT HEADER FOR J-SI AND RS-SI */
4400
4401 /* ... PRINT SUMMARY LINE */
4402
4403 /* ... PRINT VARIOUS PARAMETERS AFTER EACH ITERATION FOR SOR. */
4404
4405 /* ... PRINT HEADER FOR SOR */
4406
4407 /* ... PRINT SUMMARY LINE FOR SOR */
4408
4409 /* ... PRINT VARIOUS PARAMETERS AFTER EACH ITERATION FOR SSOR-CG. */
4410
4411 /* ... PRINT HEADER FOR SSOR-CG */
4412
4413 /* ... PRINT SUMMARY LINE FOR SSOR-CG */
4414
4415 if (itcom1_1.level < 4)
4416 return 0;
4417
4418 for (i = 0; i < *nn; ++i)
4419 wk[i] = u[i] / a[i];
4420
4421 return 0;
4422 } /* iterm_ */
4423
4424 /* Subroutine */
ivfill_(integer * n,integer * iv,integer * ival)4425 int ivfill_(integer *n, integer *iv, integer *ival)
4426 {
4427 /* Local variables */
4428 static integer i, m;
4429
4430 /* FILLS AN INTEGER VECTOR, IV, WITH AN INTEGER VALUE, IVAL. */
4431
4432 /* ... PARAMETER LIST: */
4433
4434 /* N INTEGER LENGTH OF VECTOR IV */
4435 /* IV INTEGER VECTOR */
4436 /* IVAL INTEGER CONSTANT THAT FILLS FIRST N LOCATIONS OF IV */
4437
4438 if (*n <= 0)
4439 return 0;
4440
4441 /* CLEAN UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 10 */
4442
4443 m = *n % 10;
4444 for (i = 0; i < m; ++i)
4445 iv[i] = *ival;
4446
4447 for (i = m; i < *n; i += 10) {
4448 iv[i] = *ival;
4449 iv[i + 1] = *ival;
4450 iv[i + 2] = *ival;
4451 iv[i + 3] = *ival;
4452 iv[i + 4] = *ival;
4453 iv[i + 5] = *ival;
4454 iv[i + 6] = *ival;
4455 iv[i + 7] = *ival;
4456 iv[i + 8] = *ival;
4457 iv[i + 9] = *ival;
4458 }
4459
4460 return 0;
4461 } /* ivfill_ */
4462
4463 /* Subroutine */
omeg_(doublereal * dnrm,integer * iflag)4464 int omeg_(doublereal *dnrm, integer *iflag)
4465 {
4466 /* Local variables */
4467 static doublereal zm1, zm2, temp;
4468
4469 /* COMPUTES NEW VALUES FOR CME, OMEGA, AND SPECR FOR */
4470 /* FULLY ADAPTIVE SSOR METHODS. */
4471
4472 /* ... PARAMETER LIST: */
4473
4474 /* DNRM NUMERATOR OF RAYLEIGH QUOTIENT */
4475 /* IFLAG INDICATOR OF APPROPRIATE ENTRY POINT */
4476
4477 zm1 = 0.;
4478 zm2 = 0.;
4479 if (*iflag == 1)
4480 goto L10;
4481
4482 /* ... IFLAG .NE. 1, COMPUTE NEW ESTIMATE FOR CME */
4483
4484 zm1 = ((1.-itcom3_1.spr) * (itcom3_1.betab * (itcom3_1.omega * itcom3_1.omega) + 1.) - itcom3_1.omega * (2.-itcom3_1.omega)) /
4485 (itcom3_1.omega * (itcom3_1.omega - 1. - itcom3_1.spr));
4486
4487 if (! itcom2_1.caseii)
4488 zm2 = *dnrm / itcom3_1.bdelnm;
4489
4490 if (itcom2_1.caseii)
4491 zm2 = sqrt(abs(*dnrm / itcom3_1.bdelnm));
4492
4493 itcom3_1.cme = max(max(itcom3_1.cme,zm1),zm2);
4494
4495 /* ... IFLAG = 1, OR CONTINUATION OF IFLAG .NE. 1 */
4496
4497 /* COMPUTE NEW VALUES OF OMEGA AND SPECR BASED ON CME AND BETAB */
4498
4499 L10:
4500 itcom1_1.is = itcom1_1.in + 1;
4501 itcom3_1.delsnm = itcom3_1.delnnm;
4502 if (itcom3_1.cme >= itcom3_1.betab * 4.)
4503 goto L30;
4504
4505 /* ... CME .LT. 4.D0*BETAB */
4506
4507 temp = sqrt(abs(1. - itcom3_1.cme * 2. + itcom3_1.betab * 4.));
4508 itcom3_1.omega = max(2. / (temp + 1.),1.);
4509 temp = (1. - itcom3_1.cme) / temp;
4510 itcom3_1.specr = (1. - temp) / (temp + 1.);
4511 if (abs(itcom3_1.omega - 1.) < itcom3_1.drelpr)
4512 itcom3_1.specr = 0.;
4513
4514 return 0;
4515
4516 /* ... CME .GE. 4.D0*BETAB */
4517
4518 /* ... OMEGA-STAR WILL BE CHOSEN */
4519
4520 L30:
4521 itcom3_1.cme = sqrt((abs(itcom3_1.betab))) * 2.;
4522 itcom3_1.omega = 2. / (sqrt(abs(1. - itcom3_1.betab * 4.)) + 1.);
4523 itcom3_1.specr = itcom3_1.omega - 1.;
4524 itcom2_1.adapt = FALSE_;
4525 itcom2_1.partad = FALSE_;
4526
4527 return 0;
4528 } /* omeg_ */
4529
omgchg_(integer * ndummy)4530 logical omgchg_(integer *ndummy)
4531 {
4532 /* System generated locals */
4533 doublereal d__1;
4534
4535 /* Local variables */
4536 static doublereal del1, del2;
4537 (void)ndummy;
4538
4539 /* ... THIS FUNCTION TESTS TO SEE WHETHER OMEGA SHOULD BE CHANGED */
4540 /* ... FOR SSOR CG METHOD. */
4541
4542 /* ... PARAMETER LIST: */
4543
4544 /* NDUMMY ARBITRARY INTEGER PARAMETER */
4545
4546 /* ... STATEMENT FUNCTION PHI(X) */
4547
4548 if (itcom1_1.in - itcom1_1.is < 3)
4549 return FALSE_;
4550
4551 if (itcom3_1.specr == 0.)
4552 goto L10;
4553
4554 if (itcom3_1.specr >= itcom3_1.spr)
4555 return FALSE_;
4556
4557 d__1 = 1. - itcom3_1.specr / itcom3_1.spr;
4558 del1 = -log(abs((1. - sqrt(abs(1.-itcom3_1.specr))) /
4559 (1. + sqrt(abs(1.-itcom3_1.specr))) /
4560 ((1. - sqrt(abs(d__1))) /
4561 (1. + sqrt(abs(d__1))))));
4562 del2 = -log(abs((1. - sqrt(abs(1. - itcom3_1.spr))) / (1. + sqrt(abs(1. - itcom3_1.spr)))));
4563 if (del1 / del2 >= itcom3_1.ff)
4564 return FALSE_;
4565
4566 L10:
4567 return TRUE_;
4568 } /* omgchg_ */
4569
omgstr_(integer * ndummy)4570 logical omgstr_(integer *ndummy)
4571 {
4572 /* System generated locals */
4573 doublereal d__1;
4574
4575 /* Local variables */
4576 static doublereal temp, temp1, omstar;
4577
4578 (void)ndummy;
4579
4580 /* TESTS FOR FULLY ADAPTIVE SSOR METHODS WHETHER OMEGA-STAR */
4581 /* SHOULD BE USED FOR OMEGA AND THE ADAPTIVE PROCESS TURNED */
4582 /* OFF. */
4583
4584 /* ... PARAMETER LIST: */
4585
4586 /* NDUMMY ARBITRARY INTEGER PARAMETER */
4587
4588 /* ... STATEMENT FUNCTION PHI(X) */
4589
4590 if (itcom3_1.betab >= .25 || ! itcom2_1.adapt)
4591 return FALSE_;
4592
4593 omstar = 2. / (sqrt(abs(1. - itcom3_1.betab * 4.)) + 1.);
4594
4595 /* ... TEST TO CHOSE OMEGA-STAR */
4596
4597 if (omstar > 1. && itcom3_1.specr > 0.) {
4598 temp = log(abs((1. - sqrt(abs(2. - omstar))) / (1. + sqrt(abs(2. - omstar)))));
4599 temp1 = log(abs((1. - sqrt(abs(1. - itcom3_1.specr))) / (1. + sqrt(abs(1. - itcom3_1.specr)))));
4600 if (temp / temp1 < itcom3_1.ff)
4601 return FALSE_;
4602 }
4603
4604 /* ... OMEGA-STAR WAS CHOSEN */
4605
4606 itcom3_1.omega = omstar;
4607 itcom3_1.specr = itcom3_1.omega - 1.;
4608 itcom2_1.adapt = FALSE_;
4609 itcom2_1.partad = FALSE_;
4610 itcom3_1.cme = sqrt((abs(itcom3_1.betab))) * 2.;
4611 d__1 = (1. - sqrt(abs(itcom3_1.specr))) / (1. + sqrt(abs(itcom3_1.specr)));
4612 itcom3_1.rrr = d__1 * d__1;
4613 itcom3_1.gamma = 2. / (2. - itcom3_1.specr);
4614 itcom3_1.sige = itcom3_1.specr / (2. - itcom3_1.specr);
4615 itcom3_1.rho = 1.;
4616 itcom1_1.is = itcom1_1.in + 1;
4617 itcom3_1.delsnm = itcom3_1.delnnm;
4618
4619 return TRUE_;
4620 } /* omgstr_ */
4621
4622 /* Subroutine */
parcon_(doublereal * dtnrm,doublereal * c1,doublereal * c2,doublereal * c3,doublereal * c4,doublereal * gamold,doublereal * rhotmp,integer * ibmth)4623 int parcon_(doublereal *dtnrm, doublereal *c1, doublereal *c2, doublereal *c3, doublereal *c4,
4624 doublereal *gamold, doublereal * rhotmp, integer *ibmth)
4625 {
4626 static integer ip;
4627 static doublereal rhoold;
4628
4629 /* COMPUTES ACCELERATION PARAMETERS FOR CONJUGATE GRADIENT */
4630 /* ACCELERATED METHODS. */
4631
4632 /* ... PARAMETER LIST: */
4633
4634 /* DTNRM INNER PRODUCT OF RESIDUALS */
4635 /* C1 OUTPUT: RHO*GAMMA */
4636 /* C2 OUTPUT: RHO */
4637 /* C3 OUTPUT: 1-RHO */
4638 /* C4 OUTPUT: RHO*(1-GAMMA) */
4639 /* GAMOLD OUTPUT: VALUE OF GAMMA AT PRECEDING ITERATION */
4640 /* RHOTMP LAST ESTIMATE FOR VALUE OF RHO */
4641 /* IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY CG */
4642 /* IBMTH = 1, JACOBI */
4643 /* = 2, REDUCED SYSTEM */
4644 /* = 3, SSOR */
4645
4646 ip = itcom1_1.in - itcom1_1.is;
4647
4648 /* ... SET RHOOLD AND GAMOLD */
4649
4650 rhoold = itcom3_1.rho;
4651 *gamold = itcom3_1.gamma;
4652
4653 /* ... COMPUTE GAMMA (IN+1) */
4654
4655 /* ... FOR JACOBI OR REDUCED SYSTEM CG */
4656
4657 if (*ibmth <= 2)
4658 itcom3_1.gamma = 1. / (1. - *dtnrm / itcom3_1.delnnm);
4659
4660 /* ... FOR SSOR CG */
4661
4662 if (*ibmth == 3)
4663 itcom3_1.gamma = itcom3_1.delnnm / *dtnrm;
4664
4665 /* ... COMPUTE RHO (IN+1) */
4666
4667 itcom3_1.rho = 1.;
4668 if (ip != 0) {
4669 if (itcom1_1.isym != 0)
4670 itcom3_1.rho = 1. / (1. - itcom3_1.gamma * *rhotmp / itcom3_1.delsnm);
4671 else
4672 itcom3_1.rho = 1. / (1. - itcom3_1.gamma * itcom3_1.delnnm / (*gamold * itcom3_1.delsnm * rhoold));
4673 }
4674
4675 /* ... COMPUTE CONSTANTS C1, C2, C3, AND C4 */
4676
4677 itcom3_1.delsnm = itcom3_1.delnnm;
4678 *rhotmp = rhoold;
4679 *c1 = itcom3_1.rho * itcom3_1.gamma;
4680 *c2 = itcom3_1.rho;
4681 *c3 = 1. - itcom3_1.rho;
4682 *c4 = itcom3_1.rho * (1. - itcom3_1.gamma);
4683
4684 return 0;
4685 } /* parcon_ */
4686
4687 /* Subroutine */
parsi_(doublereal * c1,doublereal * c2,doublereal * c3,integer * ibmth)4688 int parsi_(doublereal *c1, doublereal *c2, doublereal *c3, integer *ibmth)
4689 {
4690 /* Local variables */
4691 static integer ip;
4692
4693 /* COMPUTES ACCELERATION PARAMETERS FOR SEMI-ITERATIVE */
4694 /* ACCELERATED METHODS. */
4695
4696 /* ... PARAMETER LIST: */
4697
4698 /* C1,C2 */
4699 /* AND */
4700 /* C3 OUTPUT ACCELERATION PARAMETERS */
4701 /* IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY SI */
4702 /* IBMTH = 1, JACOBI */
4703 /* = 2, REDUCED SYSTEM */
4704 /* = 3, SSOR */
4705
4706 ip = itcom1_1.in - itcom1_1.is;
4707 if (ip == 0)
4708 goto L30;
4709
4710 if (ip != 1) {
4711 itcom3_1.rho = 1. / (1. - itcom3_1.sige * itcom3_1.sige * itcom3_1.rho * .25);
4712 goto L20;
4713 }
4714 itcom3_1.rho = 1. / (1. - itcom3_1.sige * itcom3_1.sige * .5);
4715
4716 L20:
4717 *c1 = itcom3_1.rho * itcom3_1.gamma;
4718 *c2 = itcom3_1.rho;
4719 *c3 = 1. - itcom3_1.rho;
4720
4721 return 0;
4722
4723 /* ... NONADAPTIVE INITIALIZATION FOR SEMI-ITERATIVE METHODS */
4724
4725 L30:
4726 switch (*ibmth) {
4727 case 1: goto L40;
4728 case 2: goto L50;
4729 case 3: goto L60;
4730 }
4731
4732 /* ... JSI */
4733
4734 L40:
4735 if (itcom2_1.caseii)
4736 itcom3_1.sme = -itcom3_1.cme;
4737
4738 itcom3_1.gamma = 2. / (2. - itcom3_1.cme - itcom3_1.sme);
4739 itcom3_1.sige = (itcom3_1.cme - itcom3_1.sme) / (2. - itcom3_1.cme - itcom3_1.sme);
4740 goto L70;
4741
4742 /* ... REDUCED SYSTEM SI */
4743
4744 L50:
4745 itcom3_1.gamma = 2. / (2. - itcom3_1.cme * itcom3_1.cme);
4746 itcom3_1.sige = itcom3_1.cme * itcom3_1.cme / (2. - itcom3_1.cme * itcom3_1.cme);
4747 itcom3_1.rrr = (1. - sqrt(abs(1. - itcom3_1.cme * itcom3_1.cme))) / (sqrt(abs(1. - itcom3_1.cme * itcom3_1.cme)) + 1.);
4748 goto L70;
4749
4750 /* ... SSORSI */
4751
4752 L60:
4753 itcom3_1.gamma = 2. / (2. - itcom3_1.specr);
4754 itcom3_1.sige = itcom3_1.specr / (2. - itcom3_1.specr);
4755 itcom3_1.rrr = (1. - sqrt(abs(1. - itcom3_1.sige * itcom3_1.sige))) / (sqrt(abs(1. - itcom3_1.sige * itcom3_1.sige)) + 1.);
4756
4757 L70:
4758 itcom3_1.rho = 1.;
4759 *c1 = itcom3_1.gamma;
4760 *c2 = 1.;
4761 *c3 = 0.;
4762
4763 return 0;
4764 } /* parsi_ */
4765
pbeta_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * v,doublereal * w1,doublereal * w2)4766 doublereal pbeta_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *v, doublereal *w1, doublereal *w2)
4767 {
4768 /* System generated locals */
4769 doublereal ret_val;
4770
4771 /* Local variables */
4772 static integer i, k, ii, jj, jai;
4773 static doublereal sum;
4774 static integer jajj, ibgn, iend, itmp;
4775 static doublereal temp1, temp2;
4776
4777 /* ... COMPUTES THE NUMERATOR FOR THE COMPUTATION OF BETAB IN */
4778 /* ... SSOR METHODS. */
4779
4780 /* ... PARAMETER LIST: */
4781
4782 /* N DIMENSION OF MATRIX */
4783 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
4784 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
4785 /* W1,W2 WORKSPACE VECTORS OF LENGTH N */
4786
4787 ret_val = 0.;
4788 if (itcom1_1.isym == 0)
4789 goto L110;
4790
4791 /* ************** NON - SYMMETRIC SECTION ******************** */
4792
4793 for (i = 0; i < *n; ++i)
4794 w1[i] = v[i];
4795
4796 temp1 = 0.;
4797 temp2 = 0.;
4798 itmp = 2;
4799 ibgn = ia[0] - 1;
4800 iend = ia[itmp-1] - 1;
4801 for (i = ibgn; i < iend; ++i) {
4802 jai = ja[i] - 1;
4803 temp1 -= a[i] * w1[jai];
4804 }
4805 w1[0] = temp1;
4806 w2[0] = 0.;
4807 for (k = 1; k < *n-1; ++k) {
4808 temp1 = 0.;
4809 temp2 = 0.;
4810 ibgn = ia[k] - 1;
4811 iend = ia[k + 1] - 1;
4812 for (i = ibgn; i < iend; ++i) {
4813 jai = ja[i] - 1;
4814 if (jai > k)
4815 temp1 -= a[i] * w1[jai];
4816 else
4817 temp2 -= a[i] * w1[jai];
4818 }
4819 w1[k] = temp1;
4820 w2[k] = temp2;
4821 }
4822 temp2 = 0.;
4823 ibgn = ia[*n-1] - 1;
4824 iend = ia[*n] - 1;
4825 for (i = ibgn; i < iend; ++i) {
4826 jai = ja[i] - 1;
4827 temp2 -= a[i] * w1[jai];
4828 }
4829 w2[*n-1] = temp2;
4830 for (i = 0; i < *n; ++i)
4831 ret_val += v[i] * w2[i];
4832
4833 return ret_val;
4834
4835 /* **************** SYMMETRIC SECTION ************************* */
4836
4837 L110:
4838 for (ii = 0; ii < *n; ++ii) {
4839 ibgn = ia[ii] - 1;
4840 iend = ia[ii + 1] - 1;
4841 if (ibgn >= iend)
4842 continue;
4843 sum = 0.;
4844 for (jj = ibgn; jj < iend; ++jj) {
4845 jajj = ja[jj] - 1;
4846 sum += a[jj] * v[jajj];
4847 }
4848 ret_val += sum * sum;
4849 }
4850 return ret_val;
4851 } /* pbeta_ */
4852
4853 /* Subroutine */
pbsor_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * rhs)4854 int pbsor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs)
4855 {
4856 /* Local variables */
4857 static integer i, ii, jj;
4858 static doublereal ui, sum, omm1;
4859 static integer jajj, ibgn, iend;
4860
4861 /* ... THIS SUBROUTINE COMPUTES A BACKWARD SOR SWEEP. */
4862
4863 /* ... PARAMETER LIST: */
4864
4865 /* N ORDER OF SYSTEM */
4866 /* OMEGA RELAXATION FACTOR */
4867 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
4868 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
4869 /* U LATEST ESTIMATE OF SOLUTION */
4870 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
4871
4872 omm1 = itcom3_1.omega - 1.;
4873 if (itcom1_1.isym == 0)
4874 goto L40;
4875
4876 /* *************** NON - SYMMETRIC SECTION ********************** */
4877
4878 for (i = 0; i < *n; ++i) {
4879 ii = *n - i - 1;
4880 ibgn = ia[ii] - 1;
4881 iend = ia[ii + 1] - 1;
4882 sum = rhs[ii];
4883 for (jj = ibgn; jj < iend; ++jj) {
4884 jajj = ja[jj] - 1;
4885 sum -= a[jj] * u[jajj];
4886 }
4887 u[ii] = itcom3_1.omega * sum - omm1 * u[ii];
4888 }
4889 return 0;
4890
4891 /* ***************** SYMMETRIC SECTION ************************** */
4892
4893 L40:
4894 for (ii = 0; ii < *n; ++ii) {
4895 ui = u[ii];
4896 ibgn = ia[ii] - 1;
4897 iend = ia[ii + 1] - 1;
4898 for (jj = ibgn; jj < iend; ++jj) {
4899 jajj = ja[jj] - 1;
4900 rhs[jajj] -= a[jj] * ui;
4901 }
4902 }
4903
4904 for (i = 0; i < *n; ++i) {
4905 ii = *n - i - 1;
4906 ibgn = ia[ii] - 1;
4907 iend = ia[ii + 1] - 1;
4908 sum = rhs[ii];
4909 for (jj = ibgn; jj < iend; ++jj) {
4910 jajj = ja[jj] - 1;
4911 sum -= a[jj] * u[jajj];
4912 }
4913 u[ii] = itcom3_1.omega * sum - omm1 * u[ii];
4914 }
4915 return 0;
4916 } /* pbsor_ */
4917
4918 /* Subroutine */
qsort_(integer * n,integer * key,doublereal * data,integer * error)4919 int qsort_(integer *n, integer *key, doublereal *data, integer *error)
4920 {
4921 /* Initialized data */
4922
4923 static integer tiny = 9;
4924 static integer stklen = 30;
4925
4926 /* Local variables */
4927 static doublereal d;
4928 static integer i, j, k, v, jm1, ip1, top;
4929 static logical done;
4930 static integer left, llen, rlen, lfrh2, stack[30], right;
4931
4932 /* ================================================================== */
4933
4934 /* Q U I C K S O R T */
4935
4936 /* IN THE STYLE OF THE CACM PAPER BY BOB SEDGEWICK, OCTOBER 1978 */
4937
4938 /* INPUT: */
4939 /* N -- NUMBER OF ELEMENTS TO BE SORTED */
4940 /* KEY -- AN ARRAY OF LENGTH N CONTAINING THE VALUES */
4941 /* WHICH ARE TO BE SORTED */
4942 /* DATA -- A SECOND ARRAY OF LENGTH N CONTAINING DATA */
4943 /* ASSOCIATED WITH THE INDIVIDUAL KEYS. */
4944
4945 /* OUTPUT: */
4946 /* KEY -- WILL BE ARRANGED SO THAT VALUES ARE IN INCREASING */
4947 /* ORDER */
4948 /* DATA -- REARRANGED TO CORRESPOND TO REARRANGED KEYS */
4949 /* ERROR -- WILL BE ZERO UNLESS YOUR INPUT FILE WAS OF TRULY */
4950 /* ENORMOUS LENGTH, IN WHICH CASE IT WILL BE EQUAL TO 1. */
4951
4952 /* ================================================================== */
4953
4954 /* ... PROGRAM IS A DIRECT TRANSLATION INTO FORTRAN OF SEDGEWICK^S */
4955 /* PROGRAM 2, WHICH IS NON-RECURSIVE, IGNORES FILES OF LENGTH */
4956 /* LESS THAN 'TINY' DURING PARTITIONING, AND USES MEDIAN OF THREE */
4957 /* PARTITIONING. */
4958
4959 if (*n == 1)
4960 return 0;
4961
4962 if (*n <= 0)
4963 goto L240;
4964
4965 *error = 0;
4966 top = 1;
4967 left = 0;
4968 right = *n - 1;
4969 done = *n <= tiny;
4970
4971 if (done)
4972 goto L150;
4973
4974 ivfill_(&stklen, stack, &c__0);
4975
4976 /* =========================================================== */
4977 /* QUICKSORT -- PARTITION THE FILE UNTIL NO SUBFILE REMAINS OF */
4978 /* LENGTH GREATER THAN 'TINY' */
4979 /* =========================================================== */
4980
4981 /* ... WHILE NOT DONE DO ... */
4982
4983 L10:
4984 if (done)
4985 goto L150;
4986
4987 /* ... FIND MEDIAN OF LEFT, RIGHT AND MIDDLE ELEMENTS OF CURRENT */
4988 /* SUBFILE, WHICH IS KEY(LEFT), ..., KEY(RIGHT) */
4989
4990 lfrh2 = (left + right) / 2;
4991 k = key[lfrh2];
4992 d = data[lfrh2];
4993 key[lfrh2] = key[left];
4994 data[lfrh2] = data[left];
4995 key[left] = k;
4996 data[left] = d;
4997
4998 if (key[left + 1] > key[right]) {
4999 k = key[left + 1];
5000 d = data[left + 1];
5001 key[left + 1] = key[right];
5002 data[left + 1] = data[right];
5003 key[right] = k;
5004 data[right] = d;
5005 }
5006
5007 if (key[left] > key[right]) {
5008 k = key[left];
5009 d = data[left];
5010 key[left] = key[right];
5011 data[left] = data[right];
5012 key[right] = k;
5013 data[right] = d;
5014 }
5015
5016 if (key[left + 1] > key[left]) {
5017 k = key[left + 1];
5018 d = data[left + 1];
5019 key[left + 1] = key[left];
5020 data[left + 1] = data[left];
5021 key[left] = k;
5022 data[left] = d;
5023 }
5024
5025 v = key[left];
5026
5027 /* ... V IS NOW THE MEDIAN VALUE OF THE THREE KEYS. NOW MOVE */
5028 /* FROM THE LEFT AND RIGHT ENDS SIMULTANEOUSLY, EXCHANGING */
5029 /* KEYS AND DATA UNTIL ALL KEYS LESS THAN V ARE PACKED TO */
5030 /* THE LEFT, ALL KEYS LARGER THAN V ARE PACKED TO THE */
5031 /* RIGHT. */
5032
5033 i = left + 1;
5034 j = right;
5035
5036 /* LOOP */
5037 /* REPEAT I = I+1 UNTIL KEY(I) >= V; */
5038 /* REPEAT J = J-1 UNTIL KEY(J) <= V; */
5039 /* EXIT IF J < I; */
5040 /* << EXCHANGE KEYS I AND J >> */
5041 /* END */
5042
5043 L50:
5044 while (key[++i] < v) ;
5045
5046 while (key[--j] > v) ;
5047
5048 if (j >= i) {
5049 k = key[i];
5050 d = data[i];
5051 key[i] = key[j];
5052 data[i] = data[j];
5053 key[j] = k;
5054 data[j] = d;
5055 goto L50;
5056 }
5057
5058 k = key[left];
5059 d = data[left];
5060 key[left] = key[j];
5061 data[left] = data[j];
5062 key[j] = k;
5063 data[j] = d;
5064
5065 /* ... WE HAVE NOW PARTITIONED THE FILE INTO TWO SUBFILES, */
5066 /* ONE IS (LEFT ... J-1) AND THE OTHER IS (I...RIGHT). */
5067 /* PROCESS THE SMALLER NEXT. STACK THE LARGER ONE. */
5068
5069 llen = j - left;
5070 rlen = right - i + 1;
5071 if (max(llen,rlen) > tiny)
5072 goto L100;
5073
5074 /* ... BOTH SUBFILES ARE TINY, SO UNSTACK NEXT LARGER FILE */
5075
5076 if (top != 1) {
5077 top += -2;
5078 left = stack[top - 1] - 1;
5079 right = stack[top] - 1;
5080 }
5081 else
5082 done = TRUE_;
5083
5084 goto L10;
5085
5086 /* ... ELSE ONE OR BOTH SUBFILES ARE LARGE */
5087
5088 L100:
5089 if (min(llen,rlen) > tiny)
5090 goto L120;
5091
5092 /* ... ONE SUBFILE IS SMALL, ONE LARGE. IGNORE THE SMALL ONE */
5093
5094 if (llen <= rlen)
5095 left = i;
5096 else
5097 right = j - 1;
5098
5099 goto L10;
5100
5101 /* ... ELSE BOTH ARE LARGER THAN TINY. ONE MUST BE STACKED. */
5102
5103 L120:
5104 if (top >= stklen)
5105 goto L240;
5106
5107 if (llen <= rlen) {
5108 stack[top - 1] = i + 1;
5109 stack[top] = right + 1;
5110 right = j - 1;
5111 }
5112 else {
5113 stack[top - 1] = left + 1;
5114 stack[top] = j;
5115 left = i;
5116 }
5117
5118 top += 2;
5119
5120 goto L10;
5121
5122 /* ------------------------------------------------------------ */
5123 /* INSERTION SORT THE ENTIRE FILE, WHICH CONSISTS OF A LIST */
5124 /* OF 'TINY' SUBFILES, LOCALLY OUT OF ORDER, GLOBALLY IN ORDER. */
5125 /* ------------------------------------------------------------ */
5126
5127 /* ... FIRST, FIND LARGEST ELEMENT IN 'KEY' */
5128
5129 L150:
5130 i = *n - 2;
5131 left = max(0, *n-tiny) - 1;
5132 j = *n - 1;
5133 k = key[j];
5134
5135 L160:
5136 if (i <= left)
5137 goto L180;
5138
5139 if (key[i] > k) {
5140 k = key[i];
5141 j = i;
5142 }
5143
5144 --i;
5145 goto L160;
5146
5147 L180:
5148 if (j != *n - 1) {
5149 /* ... LARGEST ELEMENT WILL BE IN KEY(N) */
5150 key[j] = key[*n-1];
5151 key[*n-1] = k;
5152 d = data[*n-1];
5153 data[*n-1] = data[j];
5154 data[j] = d;
5155 }
5156
5157 /* ... INSERTION SORT ... FOR I := N-1 STEP -1 TO 1 DO ... */
5158
5159 i = *n - 2;
5160 ip1 = *n - 1;
5161
5162 L200:
5163 if (key[i] <= key[ip1])
5164 goto L220;
5165
5166 /* ... OUT OF ORDER ... MOVE UP TO CORRECT PLACE */
5167
5168 k = key[i];
5169 d = data[i];
5170 j = ip1;
5171 jm1 = i;
5172
5173 /* ... REPEAT ... UNTIL 'CORRECT PLACE FOR K FOUND' */
5174
5175 L210:
5176 key[jm1] = key[j];
5177 data[jm1] = data[j];
5178 jm1 = j;
5179 ++j;
5180 if (key[j] < k)
5181 goto L210;
5182
5183 key[jm1] = k;
5184 data[jm1] = d;
5185
5186 L220:
5187 ip1 = i;
5188 --i;
5189 if (i >= 0)
5190 goto L200;
5191
5192 L230:
5193 return 0;
5194
5195 L240:
5196 *error = 1;
5197 goto L230;
5198 } /* qsort_ */
5199
5200 /* Subroutine */
permat_(integer * n,integer * ia,integer * ja,doublereal * a,integer * p,integer * newia,integer * isym,integer * level,integer * nout,integer * ierr)5201 int permat_(integer *n, integer *ia, integer *ja, doublereal *a, integer *p,
5202 integer *newia, integer *isym, integer * level, integer *nout, integer* ierr)
5203 {
5204 /* Local variables */
5205 static integer i, j, k, ip, jp, jaj, ier, ipp, ibgn, iend;
5206 static doublereal save;
5207 static integer nels;
5208 static doublereal temp;
5209 static integer next;
5210
5211 (void)level; (void)nout;
5212 /* ********************************************************************* */
5213
5214 /* ... SUBROUTINE PERMAT TAKES THE SPARSE MATRIX REPRESENTATION */
5215 /* OF THE MATRIX STORED IN THE ARRAYS IA, JA, AND A AND */
5216 /* PERMUTES BOTH ROWS AND COLUMNS OVERWRITING THE PREVIOUS */
5217 /* STRUCTURE. */
5218
5219 /* ... PARAMETER LIST: */
5220
5221 /* N ORDER OF SYSTEM */
5222 /* IA,JA INTEGER ARRAYS OF THE SPARSE MATRIX REPRESENTATION */
5223 /* A D.P. ARRAY OF THE SPARSE MATRIX REPRESENTATION */
5224 /* P PERMUTATION VECTOR */
5225 /* NEWIA INTEGER WORK VECTOR OF LENGTH N */
5226 /* ISYM SYMMETRIC/NONSYMMETRIC STORAGE SWITCH */
5227 /* LEVEL SWITCH CONTROLLING LEVEL OF OUTPUT */
5228 /* NOUT OUTPUT UNIT NUMBER */
5229 /* IER OUTPUT ERROR FLAG (= IERR) */
5230
5231 /* IER = 0 NORMAL RETURN */
5232 /* IER = 301 NO ENTRY IN ITH ROW OF ORIGINAL */
5233 /* MATRIX. IF LEVEL IS GREATER THAN */
5234 /* 0, I WILL BE PRINTED */
5235 /* IER = 302 THERE IS NO ENTRY IN THE ITH ROW */
5236 /* OF THE PERMUTED MATRIX */
5237 /* IER = 303 ERROR RETURN FROM QSORT IN */
5238 /* SORTING THE ITH ROW OF THE */
5239 /* PERMUTED MATRIX */
5240 /* ... IT IS ASSUMED THAT THE I-TH ENTRY OF THE PERMUTATION VECTOR */
5241 /* P INDICATES THE ROW THE I-TH ROW GETS MAPPED INTO. (I.E. */
5242 /* IF ( P(I) = J ) ROW I GETS MAPPED INTO ROW J.) */
5243
5244 /* ... THE ARRAY NEWIA IS AN INTEGER WORK VECTOR OF LENGTH N WHICH */
5245 /* KEEPS TRACK OF WHERE THE ROWS BEGIN IN THE PERMUTED STRUCTURE. */
5246
5247 /* ... PERMAT IS CAPABLE OF PERMUTING BOTH THE SYMMETRIC AND NON- */
5248 /* SYMMETRIC FORM OF IA, JA, AND A. IF ( ISYM .EQ. 0 ) SYMMETRIC */
5249 /* FORM IS ASSUMED. */
5250
5251 /* ... TWO EXTERNAL MODULES ARE USED BY PERMAT. THE FIRST IS INTEGER */
5252 /* FUNCTION BISRCH WHICH USES A BISECTION SEARCH ( ORDER LOG-BASE-2 */
5253 /* OF N+1 ) THROUGH THE ARRAY IA TO FIND THE ROW INDEX OF AN ARBI- */
5254 /* TRARY ENTRY EXTRACTED FROM THE ARRAY JA. THE SECOND IS SUBROUTINE */
5255 /* QSORT WHICH PERFORMS A QUICK SORT TO PLACE THE ENTRIES IN */
5256 /* THE PERMUTED ROWS IN COLUMN ORDER. */
5257
5258 /* ********************************************************************* */
5259
5260 /* ... PREPROCESSING PHASE */
5261
5262 /* ...... DETERMINE THE NUMBER OF NONZEROES IN THE ROWS OF THE PERMUTED */
5263 /* MATRIX AND STORE THAT IN NEWIA. THEN SWEEP THRU NEWIA TO MAKE */
5264 /* NEWIA(I) POINT TO THE BEGINNING OF EACH ROW IN THE PERMUTED */
5265 /* DATA STRUCTURE. ALSO NEGATE ALL THE ENTRIES IN JA TO INDICATE */
5266 /* THAT THOSE ENTRIES HAVE NOT BEEN MOVED YET. */
5267
5268 ier = 0;
5269 nels = ia[*n] - 1;
5270 for (i = 0; i < *n; ++i)
5271 newia[i] = 0;
5272
5273 for (i = 0; i < *n; ++i) {
5274 ip = p[i] - 1;
5275 ibgn = ia[i] - 1;
5276 iend = ia[i + 1] - 1;
5277 if (ibgn >= iend)
5278 goto L90;
5279
5280 for (j = ibgn; j < iend; ++j) {
5281 ipp = ip;
5282 jaj = ja[j];
5283 jp = p[jaj-1] - 1;
5284 if (*isym == 0 && ip > jp)
5285 ipp = jp;
5286
5287 ++newia[ipp];
5288 ja[j] = -jaj;
5289 }
5290 }
5291 ibgn = 0;
5292 for (i = 0; i < *n; ++i) {
5293 k = ibgn + newia[i];
5294 newia[i] = ibgn+1;
5295 ibgn = k;
5296 }
5297
5298 /* ...... PREPROCESSING NOW FINISHED. */
5299
5300 /* ...... NOW PERMUTE JA AND A. THIS PERMUTATION WILL PERFORM THE */
5301 /* FOLLOWING STEPS */
5302
5303 /* 1. FIND THE FIRST ENTRY IN JA NOT PERMUTED WHICH IS */
5304 /* INDICATED BY AN NEGATIVE VALUE IN JA */
5305 /* 2. COMPUTE WHICH ROW THE CURRENT ENTRY IS IN. THIS */
5306 /* IS COMPUTED BY A BISECTION SEARCH THRU THE ARRAY */
5307 /* IA. */
5308 /* 3. USING THE PERMUTATION ARRAY P AND THE ARRAY NEWIA */
5309 /* COMPUTE WHERE THE CURRENT ENTRY IS TO BE PLACED. */
5310 /* 4. THEN PICK UP THE ENTRY WHERE THE CURRENT ENTRY WILL */
5311 /* GO. PUT THE CURRENT ENTRY IN PLACE. THEN MAKE THE */
5312 /* DISPLACED ENTRY THE CURRENT ENTRY AND LOOP TO STEP 2. */
5313 /* 5. THIS PROCESS WILL END WHEN THE NEXT ENTRY HAS ALREADY */
5314 /* BEEN MOVED. THEN LOOP TO STEP 1. */
5315
5316 for (j = 0; j < nels; ++j) {
5317 if (ja[j] > 0)
5318 continue;
5319 jaj = -ja[j];
5320 save = a[j];
5321 next = j + 1;
5322 ja[j] = jaj;
5323 L50:
5324 jp = p[jaj-1] - 1;
5325 k = *n + 1;
5326 i = bisrch_(&k, ia, &next) - 1;
5327 ip = p[i] - 1;
5328 ipp = ip;
5329 if (*isym == 0 && ip > jp) {
5330 ipp = jp;
5331 jp = ip;
5332 }
5333 next = newia[ipp] - 1;
5334
5335 temp = save; save = a[next]; a[next] = temp;
5336
5337 jaj = -ja[next];
5338 ja[next] = jp + 1;
5339 ++newia[ipp];
5340 if (jaj > 0) {
5341 ++next;
5342 goto L50;
5343 }
5344 }
5345
5346 /* ...... THE MATRIX IS NOW PERMUTED BUT THE ROWS MAY NOT BE IN */
5347 /* ORDER. THE REMAINDER OF THIS SUBROUTINE PERFORMS */
5348 /* A QUICK SORT ON EACH ROW TO SORT THE ENTRIES IN */
5349 /* COLUMN ORDER. THE IA ARRAY IS ALSO CORRECTED FROM */
5350 /* INFORMATION STORED IN THE NEWIA ARRAY. NEWIA(I) NOW */
5351 /* POINTS TO THE FIRST ENTRY OF ROW I+1. */
5352
5353 ia[0] = 1;
5354 for (i = 0; i < *n; ++i) {
5355 ia[i + 1] = newia[i];
5356 k = ia[i + 1] - ia[i];
5357 if (k == 1)
5358 continue;
5359 if (k < 1)
5360 goto L110;
5361
5362 ibgn = ia[i] - 1;
5363 qsort_(&k, &ja[ibgn], &a[ibgn], &ier);
5364 if (ier != 0)
5365 goto L130;
5366 }
5367
5368 /* ...... END OF MATRIX PERMUTATION */
5369
5370 goto L150;
5371
5372 /* ... ERROR TRAPS */
5373
5374 /* ...... NO ENTRY IN ROW I IN THE ORIGINAL SYSTEM */
5375
5376 L90:
5377 ier = 301;
5378 goto L150;
5379
5380 /* ...... NO ENTRY IN ROW I IN THE PERMUTED SYSTEM */
5381
5382 L110:
5383 ier = 302;
5384 goto L150;
5385
5386 /* ...... ERROR RETURN FROM SUBROUTINE QSORT */
5387
5388 L130:
5389 ier = 303;
5390
5391 L150:
5392 *ierr = ier;
5393 return 0;
5394 } /* permat_ */
5395
5396 /* Subroutine */
perror_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * w,doublereal * digtt1,doublereal * digtt2,integer * idgtts)5397 int perror_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
5398 doublereal *u, doublereal *w, doublereal *digtt1, doublereal *digtt2, integer *idgtts)
5399 {
5400 /* System generated locals */
5401 doublereal d__1;
5402
5403 /* Local variables */
5404 static doublereal bnrm, temp, rnrm;
5405 static integer idgts;
5406 static doublereal digit1, digit2;
5407
5408 /* PERROR COMPUTES THE RESIDUAL, R = RHS - A*U. THE USER */
5409 /* ALSO HAS THE OPTION OF PRINTING THE RESIDUAL AND/OR THE */
5410 /* UNKNOWN VECTOR DEPENDING ON IDGTS. */
5411
5412 /* ... PARAMETER LIST: */
5413
5414 /* N DIMENSION OF MATRIX */
5415 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
5416 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
5417 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
5418 /* U LATEST ESTIMATE OF SOLUTION */
5419 /* W WORKSPACE VECTOR */
5420 /* DIGIT1 OUTPUT: MEASURE OF ACCURACY OF STOPPING TEST (= DIGTT1 */
5421 /* DIGIT2 OUTPUT: MEASURE OF ACCURACY OF SOLUTION (= DIGTT2) */
5422 /* IDGTS PARAMETER CONTROLING LEVEL OF OUTPUT (= IDGTTS) */
5423 /* IF IDGTS < 1 OR IDGTS > 4, THEN NO OUTPUT. */
5424 /* = 1, THEN NUMBER OF DIGITS IS PRINTED, PRO- */
5425 /* VIDED LEVEL .GE. 1 */
5426 /* = 2, THEN SOLUTION VECTOR IS PRINTED, PRO- */
5427 /* VIDED LEVEL .GE. 1 */
5428 /* = 3, THEN RESIDUAL VECTOR IS PRINTED, PRO- */
5429 /* VIDED LEVEL .GE. 1 */
5430 /* = 4, THEN BOTH VECTORS ARE PRINTED, PRO- */
5431 /* VIDED LEVEL .GE. 1 */
5432
5433 idgts = *idgtts;
5434 digit1 = 0.;
5435 digit2 = 0.;
5436 if (*n <= 0)
5437 goto L40;
5438
5439 d__1 = abs(itcom3_1.drelpr);
5440 digit1 = -d_lg10(&d__1);
5441 if (itcom3_1.stptst > 0.) {
5442 d__1 = abs(itcom3_1.stptst);
5443 digit1 = -d_lg10(&d__1);
5444 }
5445 bnrm = itpackddot_(n, rhs, &c__1, rhs, &c__1);
5446 if (bnrm == 0.)
5447 goto L10;
5448
5449 pmult_(n, ia, ja, a, u, w);
5450 wevmw_(n, rhs, w);
5451 rnrm = itpackddot_(n, w, &c__1, w, &c__1);
5452 temp = rnrm / bnrm;
5453 if (temp != 0.) {
5454 d__1 = abs(temp);
5455 digit2 = -d_lg10(&d__1) / 2.;
5456 goto L20;
5457 }
5458 L10:
5459 d__1 = abs(itcom3_1.drelpr);
5460 digit2 = -d_lg10(&d__1);
5461
5462 L20:
5463 if (itcom1_1.level > 0) {
5464 if (idgts == 2 || idgts == 4)
5465 vout_(n, u, &c__2, &itcom1_1.nout);
5466 if (idgts == 3 || idgts == 4)
5467 vout_(n, w, &c__1, &itcom1_1.nout);
5468 }
5469
5470 L40:
5471 *digtt1 = digit1;
5472 *digtt2 = digit2;
5473 return 0;
5474 } /* perror_ */
5475
5476 /* Subroutine */
pervec_(integer * n,doublereal * v,integer * p)5477 int pervec_(integer *n, doublereal *v, integer *p)
5478 {
5479 /* Local variables */
5480 static integer ii, now;
5481 static doublereal save, temp;
5482 static integer next;
5483
5484 /* THIS SUBROUTINE PERMUTES A D.P. VECTOR AS DICTATED BY THE */
5485 /* PERMUTATION VECTOR, P. IF P(I) = J, THEN V(J) GETS V(I). */
5486
5487 /* ... PARAMETER LIST: */
5488
5489 /* V D.P. VECTOR OF LENGTH N */
5490 /* P INTEGER PERMUTATION VECTOR */
5491
5492 if (*n <= 0)
5493 return 0;
5494
5495 for (ii = 0; ii < *n; ++ii) {
5496 if (p[ii] < 0)
5497 continue;
5498
5499 next = p[ii];
5500 save = v[ii];
5501 while (p[next-1] >= 0) {
5502 temp = save;
5503 save = v[next-1];
5504 v[next-1] = temp;
5505
5506 now = next;
5507 next = p[now-1];
5508 p[now-1] = -next;
5509 }
5510 }
5511
5512 for (ii = 0; ii < *n; ++ii)
5513 p[ii] = -p[ii];
5514
5515 return 0;
5516 } /* pervec_ */
5517
5518 /* Subroutine */
pfsor_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * rhs)5519 int pfsor_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs)
5520 {
5521 /* Local variables */
5522 static integer ii, jj;
5523 static doublereal ui, sum, omm1;
5524 static integer jajj, ibgn, iend;
5525
5526 /* THIS SUBROUTINE COMPUTES A FORWARD SOR SWEEP. */
5527
5528 /* ... PARAMETER LIST: */
5529
5530 /* N ORDER OF SYSTEM */
5531 /* OMEGA RELAXATION FACTOR */
5532 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
5533 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
5534 /* U LATEST ESTIMATE OF SOLUTION */
5535 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
5536
5537 omm1 = itcom3_1.omega - 1.;
5538 if (itcom1_1.isym == 0)
5539 goto L40;
5540
5541 /* *********** NON - SYMMETRIC SECTION ********************* */
5542
5543 for (ii = 0; ii < *n; ++ii) {
5544 ibgn = ia[ii] - 1;
5545 iend = ia[ii + 1] - 1;
5546 sum = rhs[ii];
5547 for (jj = ibgn; jj < iend; ++jj) {
5548 jajj = ja[jj] - 1;
5549 sum -= a[jj] * u[jajj];
5550 }
5551 ui = itcom3_1.omega * sum - omm1 * u[ii];
5552 u[ii] = ui;
5553 }
5554 return 0;
5555
5556 /* ************* SYMMETRIC SECTION ************************* */
5557
5558 L40:
5559 for (ii = 0; ii < *n; ++ii) {
5560 ibgn = ia[ii] - 1;
5561 iend = ia[ii + 1] - 1;
5562 sum = rhs[ii];
5563 for (jj = ibgn; jj < iend; ++jj) {
5564 jajj = ja[jj] - 1;
5565 sum -= a[jj] * u[jajj];
5566 }
5567 ui = itcom3_1.omega * sum - omm1 * u[ii];
5568 u[ii] = ui;
5569 for (jj = ibgn; jj < iend; ++jj) {
5570 jajj = ja[jj] - 1;
5571 rhs[jajj] -= a[jj] * ui;
5572 }
5573 }
5574 return 0;
5575 } /* pfsor_ */
5576
5577 /* Subroutine */
pfsor1_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * rhs)5578 int pfsor1_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs)
5579 {
5580 /* System generated locals */
5581 doublereal d__1;
5582
5583 /* Local variables */
5584 static integer ii, jj;
5585 static doublereal ui, sum, omm1;
5586 static integer jajj, ibgn, iend;
5587 static doublereal sumd;
5588
5589 /* THIS SUBROUTINE COMPUTES A FORWARD SOR SWEEP ON U AND */
5590 /* COMPUTES THE NORM OF THE PSEUDO-RESIDUAL VECTOR. */
5591
5592 /* ... PARAMETER LIST: */
5593
5594 /* N ORDER OF SYSTEM */
5595 /* OMEGA RELAXATION FACTOR */
5596 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
5597 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
5598 /* U LATEST ESTIMATE OF SOLUTION */
5599 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
5600
5601 omm1 = itcom3_1.omega - 1.;
5602 sumd = 0.;
5603 if (itcom1_1.isym == 0)
5604 goto L40;
5605
5606 /* **************** NON - SYMMETRIC SECTION ****************** */
5607
5608 for (ii = 0; ii < *n; ++ii) {
5609 ibgn = ia[ii] - 1;
5610 iend = ia[ii + 1] - 1;
5611 sum = rhs[ii];
5612 for (jj = ibgn; jj < iend; ++jj) {
5613 jajj = ja[jj] - 1;
5614 sum -= a[jj] * u[jajj];
5615 }
5616 ui = itcom3_1.omega * sum - omm1 * u[ii];
5617 d__1 = ui - u[ii];
5618 sumd += d__1 * d__1;
5619 u[ii] = ui;
5620 }
5621 goto L90;
5622
5623 /* *************** SYMMETRIC SECTION ************************ */
5624
5625 L40:
5626 for (ii = 0; ii < *n; ++ii) {
5627 ibgn = ia[ii] - 1;
5628 iend = ia[ii + 1] - 1;
5629 sum = rhs[ii];
5630 for (jj = ibgn; jj < iend; ++jj) {
5631 jajj = ja[jj] - 1;
5632 sum -= a[jj] * u[jajj];
5633 }
5634 ui = itcom3_1.omega * sum - omm1 * u[ii];
5635 d__1 = ui - u[ii];
5636 sumd += d__1 * d__1;
5637 u[ii] = ui;
5638 for (jj = ibgn; jj < iend; ++jj) {
5639 jajj = ja[jj] - 1;
5640 rhs[jajj] -= a[jj] * ui;
5641 }
5642 }
5643
5644 L90:
5645 itcom3_1.delnnm = sqrt(sumd);
5646 return 0;
5647 } /* pfsor1_ */
5648
5649 /* Subroutine */
pjac_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * rhs)5650 int pjac_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *rhs)
5651 {
5652 /* Local variables */
5653 static integer ii, jj;
5654 static doublereal uii;
5655 static integer jajj, ibgn, iend;
5656 static doublereal rhsii;
5657
5658 /* ... THIS SUBROUTINE PERFORMS ONE JACOBI ITERATION. */
5659
5660 /* ... PARAMETER LIST: */
5661
5662 /* N DIMENSION OF MATRIX */
5663 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
5664 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
5665 /* U ESTIMATE OF SOLUTION OF A MATRIX PROBLEM */
5666 /* RHS ON INPUT: CONTAINS THE RIGHT HAND SIDE OF */
5667 /* A MATRIX PROBLEM */
5668 /* ON OUTPUT: CONTAINS A*U + RHS */
5669
5670 if (itcom1_1.isym == 0)
5671 goto L30;
5672
5673 /* *************** NON - SYMMETRIC SECTION **************** */
5674
5675 for (ii = 0; ii < *n; ++ii) {
5676 ibgn = ia[ii] - 1;
5677 iend = ia[ii + 1] - 1;
5678 rhsii = rhs[ii];
5679 for (jj = ibgn; jj < iend; ++jj) {
5680 jajj = ja[jj] - 1;
5681 rhsii -= a[jj] * u[jajj];
5682 }
5683 rhs[ii] = rhsii;
5684 }
5685 return 0;
5686
5687 /* ************** SYMMETRIC SECTION ********************** */
5688
5689 L30:
5690 for (ii = 0; ii < *n; ++ii) {
5691 ibgn = ia[ii] - 1;
5692 iend = ia[ii + 1] - 1;
5693 if (ibgn >= iend)
5694 continue;
5695
5696 rhsii = rhs[ii];
5697 uii = u[ii];
5698 for (jj = ibgn; jj < iend; ++jj) {
5699 jajj = ja[jj] - 1;
5700 rhsii -= a[jj] * u[jajj];
5701 rhs[jajj] -= a[jj] * uii;
5702 }
5703 rhs[ii] = rhsii;
5704 }
5705 return 0;
5706 } /* pjac_ */
5707
5708 /* Subroutine */
pmult_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * w)5709 int pmult_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u, doublereal *w)
5710 {
5711 /* Local variables */
5712 static integer ii, jj;
5713 static doublereal uii, wii, sum;
5714 static integer jajj, ibgn, iend;
5715
5716 /* ... THIS SUBROUTINE PERFORMS ONE MATRIX-VECTOR MULTIPLICATION. */
5717
5718 /* ... PARAMETER LIST: */
5719
5720 /* N DIMENSION OF MATRIX */
5721 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
5722 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
5723 /* U LATEST ESTIMATE OF SOLUTION */
5724 /* W ON RETURN W CONTAINS A*U */
5725
5726 if (*n <= 0)
5727 return 0;
5728
5729 if (itcom1_1.isym == 0)
5730 goto L40;
5731
5732 /* *************** NON - SYMMETRIC SECTION ********************** */
5733
5734 for (ii = 0; ii < *n; ++ii) {
5735 ibgn = ia[ii] - 1;
5736 iend = ia[ii + 1] - 1;
5737 sum = 0.;
5738 for (jj = ibgn; jj < iend; ++jj) {
5739 jajj = ja[jj] - 1;
5740 sum += a[jj] * u[jajj];
5741 }
5742 w[ii] = sum;
5743 }
5744 return 0;
5745
5746 /* ***************** SYMMETRIC SECTION ************************** */
5747
5748 L40:
5749 vfill_(n, w, &c_b21);
5750 for (ii = 0; ii < *n; ++ii) {
5751 ibgn = ia[ii] - 1;
5752 iend = ia[ii + 1] - 1;
5753 uii = u[ii];
5754 wii = w[ii];
5755 for (jj = ibgn; jj < iend; ++jj) {
5756 jajj = ja[jj] - 1;
5757 wii += a[jj] * u[jajj];
5758 w[jajj] += a[jj] * uii;
5759 }
5760 w[ii] = wii;
5761 }
5762 return 0;
5763 } /* pmult_ */
5764
5765 /* Subroutine */
prbndx_(integer * n,integer * nblack,integer * ia,integer * ja,integer * p,integer * ip,integer * level,integer * nout,integer * ier)5766 int prbndx_(integer *n, integer *nblack, integer *ia, integer *ja, integer *p,
5767 integer *ip, integer *level, integer *nout, integer *ier)
5768 {
5769 /* Local variables */
5770 static integer i, j, k, old, ibgn, iend, nred, last, next, typ, first, young, curtyp, nxttyp;
5771
5772 (void)level; (void)nout;
5773 /* ************************************************************** */
5774
5775 /* THIS SUBROUTINE COMPUTES THE RED-BLACK PERMUTATION */
5776 /* VECTORS P ( AND ITS INVERSE IP ) IF POSSIBLE. */
5777
5778 /* THE ALGORITHM IS TO MARK THE FIRST NODE AS RED (ARBITRARY). */
5779 /* ALL OF ITS ADJACENT NODES ARE MARKED BLACK AND PLACED IN */
5780 /* A STACK. THE REMAINDER OF THE CODE PULLS THE FIRST NODE */
5781 /* OFF THE TOP OF THE STACK AND TRIES TO TYPE ITS ADJACENT NODES. */
5782 /* THE TYPING OF THE ADJACENT POINT IS A FIVE WAY CASE STATEMENT */
5783 /* WHICH IS WELL COMMENTED BELOW (SEE DO LOOP 100). */
5784
5785 /* THE ARRAY P IS USED BOTH TO KEEP TRACK OF THE COLOR OF A NODE */
5786 /* (RED NODE IS POSITIVE, BLACK IS NEGATIVE) BUT ALSO THE FATHER */
5787 /* NODE THAT CAUSED THE COLOR MARKING OF THAT POINT. SINCE */
5788 /* COMPLETE INFORMATION ON THE ADJACENCY STRUCTURE IS HARD TO COME */
5789 /* BY THIS FORMS A LINK TO ENABLE THE COLOR CHANGE OF A PARTIAL */
5790 /* TREE WHEN A RECOVERABLE COLOR CONFLICT OCCURS. */
5791
5792 /* THE ARRAY IP IS USED AS A STACK TO POINT TO THE SET OF NODES */
5793 /* LEFT TO BE TYPED THAT ARE KNOWN TO BE ADJACENT TO THE CURRENT */
5794 /* FATHER NODE. */
5795
5796 /* ********************************************************************* */
5797
5798 /* INPUT PARAMETERS */
5799
5800 /* N NUMBER OF NODES. (INTEGER, SCALAR) */
5801
5802 /* IA,JA ADJACENCY STRUCTURE ARRAYS. CAN BE EITHER THE */
5803 /* SYMMETRIC OR NONSYMMETRIC FORM. IT IS ASSUMED */
5804 /* THAT FOR EVERY ROW WHERE ONLY ONE ELEMENT IS */
5805 /* STORED THAT ELEMENT CORRESPONDS TO THE DIAGONAL */
5806 /* ENTRY. THE DIAGONAL DOES NOT HAVE TO BE THE FIRST */
5807 /* ENTRY STORED. (INTEGER, ARRAYS) */
5808 /* LEVEL SWITCH FOR PRINTING */
5809 /* NOUT OUTPUT TAPE NUMBER */
5810
5811 /* OUTPUT PARAMETERS */
5812
5813 /* NBLACK NUMBER OF BLACK NODES. NUMBER OF RED NODES IS */
5814 /* N - NBLACK. (INTEGER, SCALAR) */
5815
5816 /* P, IP PERMUTATION AND INVERSE PERMUTATION VECTORS. */
5817 /* (INTEGER, ARRAYS EACH OF LENGTH N) */
5818
5819 /* IER ERROR FLAG. (INTEGER, SCALAR) */
5820
5821 /* IER = 0, NORMAL RETURN. INDEXING PERFORMED */
5822 /* SUCCESSFULLY */
5823 /* IER =201, RED-BLACK INDEXING NOT POSSIBLE. */
5824
5825 /* ******************************************************************** */
5826
5827 *ier = 0;
5828
5829 /* IF ( N .LE. 0 ) GO TO 8000 */
5830
5831 for (i = 0; i < *n; ++i) {
5832 p[i] = 0;
5833 ip[i] = 0;
5834 }
5835
5836 /* ... HANDLE THE FIRST SET OF POINTS UNTIL SOME ADJACENT POINTS ARE FOUND */
5837
5838 first = 0;
5839
5840 L20:
5841 p[first] = first + 1;
5842 if (ia[first + 1] - ia[first] > 1)
5843 goto L40;
5844
5845 /* ... SEARCH FOR NEXT ENTRY THAT HAS NOT BEEN MARKED */
5846
5847 if (first == *n-1)
5848 goto L130;
5849
5850 ibgn = first + 1;
5851 for (i = ibgn; i < *n; ++i) {
5852 if (p[i] == 0) {
5853 first = i;
5854 goto L20;
5855 }
5856 }
5857 goto L130;
5858
5859 /* ... FIRST SET OF ADJACENT POINTS FOUND */
5860
5861 L40:
5862 next = 0;
5863 last = 0;
5864 ip[0] = first + 1;
5865
5866 /* ... LOOP OVER LABELED POINTS INDICATED IN THE STACK STORED IN */
5867 /* ... THE ARRAY IP */
5868
5869 L50:
5870 k = ip[next] - 1;
5871 curtyp = p[k];
5872 nxttyp = -curtyp;
5873 ibgn = ia[k] - 1;
5874 iend = ia[k + 1] - 1;
5875 for (i = ibgn; i < iend; ++i) {
5876 j = ja[i] - 1;
5877 typ = p[j];
5878 if (j == k)
5879 continue;
5880
5881 /* ================================================================== */
5882
5883 /* THE FOLLOWING IS A FIVE WAY CASE STATEMENT DEALING WITH THE */
5884 /* LABELING OF THE ADJACENT NODE. */
5885
5886 /* ... CASE I. IF THE ADJACENT NODE HAS ALREADY BEEN LABELED WITH */
5887 /* LABEL EQUAL TO NXTTYP, THEN SKIP TO THE NEXT ADJACENT NODE. */
5888
5889 else if (typ == nxttyp)
5890 continue;
5891
5892 /* ... CASE II. IF THE ADJACENT NODE HAS NOT BEEN LABELED YET LABEL */
5893 /* IT WITH NXTTYP AND ENTER IT IN THE STACK */
5894
5895 else if (typ == 0) {
5896 ++last;
5897 ip[last] = j + 1;
5898 p[j] = nxttyp;
5899 continue;
5900 }
5901
5902 /* ... CASE III. IF THE ADJACENT NODE HAS ALREADY BEEN LABELED WITH */
5903 /* OPPOSITE COLOR AND THE SAME FATHER SEED, THEN THERE */
5904 /* IS AN IRRECOVERABLE COLOR CONFLICT. */
5905
5906 else if (typ == curtyp) { /* ...... TYPE CONFLICT */
5907 *ier = 201;
5908 return 0;
5909 }
5910
5911 /* ... CASE IV. IF THE ADJACENT NODE HAS THE RIGHT COLOR AND A DIFFERENT */
5912 /* FATHER NODE, THEN CHANGE ALL NODES OF THE YOUNGEST FATHE */
5913 /* NODE TO POINT TO THE OLDEST FATHER SEED AND RETAIN THE */
5914 /* SAME COLORS. */
5915
5916 else if (typ * nxttyp >= 1) {
5917 old = min(abs(typ),abs(nxttyp));
5918 young = max(abs(typ),abs(nxttyp));
5919 for (j = young-1; j < *n; ++j) {
5920 if (abs(p[j]) == young)
5921 p[j] = old*p[j] >= 0 ? old : -old;
5922 }
5923 curtyp = p[k];
5924 nxttyp = -curtyp;
5925 continue;
5926 }
5927
5928 /* ... CASE V. IF THE ADJACENT NODE HAS THE WRONG COLOR AND A DIFFERENT */
5929 /* FATHER NODE, THEN CHANGE ALL NODES OF THE YOUNGEST FATHER */
5930 /* NODE TO POINT TO THE OLDEST FATHER NODE ALONG WITH */
5931 /* CHANGING THEIR COLORS. SINCE UNTIL THIS TIME THE */
5932 /* YOUNGEST FATHER NODE TREE HAS BEEN INDEPENDENT NO OTHER */
5933 /* COLOR CONFLICTS WILL ARISE FROM THIS CHANGE. */
5934
5935 else {
5936 old = min(abs(typ),abs(nxttyp));
5937 young = max(abs(typ),abs(nxttyp));
5938 for (j = young-1; j < *n; ++j) {
5939 if (abs(p[j]) == young)
5940 p[j] = old*p[j] <= 0 ? old : -old;
5941 }
5942 curtyp = p[k];
5943 nxttyp = -curtyp;
5944 continue;
5945 }
5946
5947 /* ... END OF CASE STATEMENT */
5948
5949 /* ================================================================== */
5950 }
5951
5952 /* ... ADVANCE TO NEXT NODE IN THE STACK */
5953
5954 ++next;
5955 if (next <= last)
5956 goto L50;
5957
5958 /* ... ALL NODES IN THE STACK HAVE BEEN REMOVED */
5959
5960 /* ... CHECK FOR NODES NOT LABELED. IF ANY ARE FOUND */
5961 /* ... START THE LABELING PROCESS AGAIN AT THE FIRST */
5962 /* ... NODE FOUND THAT IS NOT LABELED. */
5963
5964 ibgn = first + 1;
5965 for (i = ibgn; i < *n; ++i) {
5966 if (p[i] == 0) {
5967 first = i;
5968 goto L20;
5969 }
5970 }
5971
5972 /* =================================================================== */
5973
5974 /* ... ALL NODES ARE NOW TYPED EITHER RED OR BLACK */
5975
5976 /* ... GENERATE PERMUTATION VECTORS */
5977
5978 L130:
5979 nred = 0;
5980 *nblack = 0;
5981 for (i = 0; i < *n; ++i) {
5982 if (p[i] < 0) /* BLACK POINT */
5983 {
5984 ++(*nblack);
5985 j = *n - *nblack;
5986 ip[j] = i + 1;
5987 p[i] = j + 1;
5988 }
5989 else /* RED POINT */
5990 {
5991 ++nred;
5992 ip[nred-1] = i + 1;
5993 p[i] = nred;
5994 }
5995 }
5996
5997 /* ... SUCCESSFUL RED-BLACK ORDERING COMPLETED */
5998
5999 return 0;
6000
6001 /* ........ ERROR TRAPS */
6002
6003 /* ...... N .LE. 0 */
6004
6005 /* 8000 IER = 200 */
6006 /* GO TO 9000 */
6007 } /* prbndx_ */
6008
6009 /* Subroutine */
prsblk_(integer * nb,integer * nr,integer * ia,integer * ja,doublereal * a,doublereal * ur,doublereal * vb)6010 int prsblk_(integer *nb, integer *nr, integer *ia, integer *ja, doublereal *a, doublereal *ur, doublereal *vb)
6011 {
6012 /* Local variables */
6013 static integer i, j, jaj, inr;
6014 static doublereal uri, sum;
6015 static integer ibgn, iend;
6016
6017 /* ... COMPUTE A BLACK-RS SWEEP ON A RED VECTOR INTO A BLACK VECTOR */
6018
6019 /* ... PARAMETER LIST: */
6020
6021 /* NB NUMBER OF BLACK POINTS */
6022 /* NR NUMBER OF RED POINTS */
6023 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
6024 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
6025 /* UR ESTIMATE OF RED SOLUTION VECTOR */
6026 /* VB OUTPUT: PRESENT ESTIMATE OF BLACK SOLUTION */
6027 /* VECTOR */
6028
6029 if (itcom1_1.isym == 0)
6030 goto L30;
6031
6032 /* *************** NON - SYMMETRIC SECTION ********************** */
6033
6034 for (i = 0; i < *nb; ++i) {
6035 inr = i + *nr;
6036 ibgn = ia[inr] - 1;
6037 iend = ia[inr + 1] - 1;
6038 sum = vb[i];
6039 if (ibgn >= iend)
6040 continue;
6041
6042 for (j = ibgn; j < iend; ++j) {
6043 jaj = ja[j] - 1;
6044 sum -= a[j] * ur[jaj];
6045 }
6046 vb[i] = sum;
6047 }
6048 return 0;
6049
6050 /* ***************** SYMMETRIC SECTION ************************** */
6051
6052 L30:
6053 for (i = 0; i < *nr; ++i) {
6054 ibgn = ia[i] - 1;
6055 iend = ia[i + 1] - 1;
6056 uri = ur[i];
6057 for (j = ibgn; j < iend; ++j) {
6058 jaj = ja[j] - *nr - 1;
6059 vb[jaj] -= a[j] * uri;
6060 }
6061 }
6062
6063 return 0;
6064 } /* prsblk_ */
6065
6066 /* Subroutine */
prsred_(integer * nb,integer * nr,integer * ia,integer * ja,doublereal * a,doublereal * ub,doublereal * vr)6067 int prsred_(integer *nb, integer *nr, integer *ia, integer *ja, doublereal *a, doublereal *ub, doublereal *vr)
6068 {
6069 /* Local variables */
6070 static integer ii, jj;
6071 static doublereal sum;
6072 static integer jajj, ibgn, iend;
6073
6074 /* ... COMPUTES A RED-RS SWEEP ON A BLACK VECTOR INTO A RED VECTOR. */
6075 /* */
6076 /* ... PARAMETER LIST: */
6077 /* */
6078 /* NB NUMBER OF BLACK POINTS (unused!?) */
6079 /* NR NUMBER OF RED POINTS */
6080 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
6081 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
6082 /* UB PRESENT ESTIMATE OF BLACK SOLUTION VECTOR */
6083 /* VR OUTPUT: PRESENT ESTIMATE OF RED SOLUTION VECTOR */
6084 (void)nb;
6085 for (ii = 0; ii < *nr; ++ii) {
6086 ibgn = ia[ii] - 1;
6087 iend = ia[ii + 1] - 1;
6088 if (ibgn >= iend)
6089 continue;
6090
6091 sum = vr[ii];
6092 for (jj = ibgn; jj < iend; ++jj) {
6093 jajj = ja[jj] - *nr - 1;
6094 sum -= a[jj] * ub[jajj];
6095 }
6096 vr[ii] = sum;
6097 }
6098
6099 return 0;
6100 } /* prsred_ */
6101
6102 /* Subroutine */
pssor1_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * u,doublereal * rhs,doublereal * fr,doublereal * br)6103 int pssor1_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *u,
6104 doublereal *rhs, doublereal *fr, doublereal *br)
6105 {
6106 /* Local variables */
6107 static integer i, ii, jj;
6108 static doublereal uii, sum, omm1;
6109 static integer jajj, ibgn, iend;
6110
6111 /* ... COMPUTES COMPLETE SSOR SWEEP ON U. U IS OVERWRITTEN */
6112 /* ... WITH THE NEW ITERANT, FR AND BR WILL CONTAIN */
6113 /* ... THE FORWARD AND BACKWARD RESIDUALS ON OUTPUT. */
6114
6115 /* ... PARAMETER LIST: */
6116
6117 /* N ORDER OF SYSTEM */
6118 /* OMEGA RELAXATION FACTOR */
6119 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
6120 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
6121 /* U ESTIMATE OF SOLUTION */
6122 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
6123 /* FR,BR OUTPUT: FORWARD AND BACKWARD RESIDUALS RESPECTIVELY */
6124
6125 omm1 = itcom3_1.omega - 1.;
6126 if (itcom1_1.isym == 0)
6127 goto L40;
6128
6129 /* *************** NON - SYMMETRIC SECTION ********************** */
6130
6131 /* ... FORWARD SWEEP */
6132
6133 for (ii = 0; ii < *n; ++ii) {
6134 br[ii] = u[ii];
6135 ibgn = ia[ii] - 1;
6136 iend = ia[ii + 1] - 1;
6137 sum = rhs[ii];
6138 for (jj = ibgn; jj < iend; ++jj) {
6139 jajj = ja[jj] - 1;
6140 sum -= a[jj] * u[jajj];
6141 }
6142 uii = itcom3_1.omega * sum - omm1 * u[ii];
6143 fr[ii] = uii - u[ii];
6144 u[ii] = uii;
6145 }
6146 goto L90;
6147
6148 /* ***************** SYMMETRIC SECTION ************************** */
6149
6150 /* ... FORWARD SWEEP */
6151
6152 L40:
6153 for (ii = 0; ii < *n; ++ii) {
6154 br[ii] = u[ii];
6155 ibgn = ia[ii] - 1;
6156 iend = ia[ii + 1] - 1;
6157 sum = rhs[ii];
6158 for (jj = ibgn; jj < iend; ++jj) {
6159 jajj = ja[jj] - 1;
6160 sum -= a[jj] * u[jajj];
6161 }
6162 uii = itcom3_1.omega * sum - omm1 * u[ii];
6163 fr[ii] = uii - u[ii];
6164 u[ii] = uii;
6165 for (jj = ibgn; jj < iend; ++jj) {
6166 jajj = ja[jj] - 1;
6167 rhs[jajj] -= a[jj] * uii;
6168 }
6169 }
6170
6171 /* ... BACKWARD SWEEP */
6172
6173 L90:
6174 for (i = 0; i < *n; ++i) {
6175 ii = *n - i - 1;
6176 ibgn = ia[ii] - 1;
6177 iend = ia[ii + 1] - 1;
6178 uii = rhs[ii];
6179 for (jj = ibgn; jj < iend; ++jj) {
6180 jajj = ja[jj] - 1;
6181 uii -= a[jj] * u[jajj];
6182 }
6183 u[ii] = itcom3_1.omega * uii - omm1 * u[ii];
6184 br[ii] = u[ii] - br[ii];
6185 }
6186
6187 return 0;
6188 } /* pssor1_ */
6189
6190 /* Subroutine */
pstop_(integer * n,doublereal * u,doublereal * dnrm,doublereal * ccon,integer * iflag,logical * q1)6191 int pstop_(integer *n, doublereal *u, doublereal *dnrm, doublereal *ccon, integer *iflag, logical *q1)
6192 {
6193 /* Local variables */
6194 static doublereal tl, tr, con;
6195 static doublereal uold;
6196
6197 /* THIS SUBROUTINE PERFORMS A TEST TO SEE IF THE ITERATIVE */
6198 /* METHOD HAS CONVERGED TO A SOLUTION INSIDE THE ERROR */
6199 /* TOLERANCE, ZETA. */
6200
6201 /* ... PARAMETER LIST: */
6202
6203 /* N ORDER OF SYSTEM */
6204 /* U PRESENT SOLUTION ESTIMATE */
6205 /* DNRM INNER PRODUCT OF PSEUDO-RESIDUALS AT PRECEDING */
6206 /* ITERATION */
6207 /* CON STOPPING TEST PARAMETER (= CCON) */
6208 /* IFLAG STOPPING TEST INTEGER FLAG */
6209 /* IFLAG = 0, SOR ITERATION ZERO */
6210 /* IFLAG = 1, NON-RS METHOD */
6211 /* IFLAG = 2, RS METHOD */
6212 /* Q1 STOPPING TEST LOGICAL FLAG */
6213
6214 con = *ccon;
6215 itcom2_1.halt = FALSE_;
6216
6217 /* SPECIAL PROCEDURE FOR ZEROTH ITERATION */
6218
6219 if (itcom1_1.in < 1) {
6220 *q1 = FALSE_;
6221 itcom3_1.udnm = 1.;
6222 itcom3_1.stptst = 1e3;
6223 if (*iflag <= 0)
6224 return 0;
6225 }
6226
6227 /* ... TEST IF UDNM NEEDS TO BE RECOMPUTED */
6228
6229 if (!*q1 && (itcom1_1.in <= 5 || itcom1_1.in % 5 == 0)) {
6230 uold = itcom3_1.udnm;
6231 itcom3_1.udnm = itpackddot_(n, u, &c__1, u, &c__1);
6232 if (itcom3_1.udnm == 0.)
6233 itcom3_1.udnm = 1.;
6234
6235 if (itcom1_1.in > 5 && abs(itcom3_1.udnm - uold) <= itcom3_1.udnm * itcom3_1.zeta)
6236 *q1 = TRUE_;
6237 }
6238
6239 /* ... COMPUTE STOPPING TEST */
6240
6241 tr = sqrt(itcom3_1.udnm);
6242 tl = 1.;
6243 if (con == 1.)
6244 goto L40;
6245
6246 if (*iflag != 2) {
6247 tl = sqrt(*dnrm);
6248 tr *= 1. - con;
6249 }
6250 else {
6251 tl = sqrt(*dnrm * 2.);
6252 tr *= 1. - con * con;
6253 }
6254 L40:
6255 itcom3_1.stptst = tl / tr;
6256 if (tl >= tr * itcom3_1.zeta)
6257 return 0;
6258
6259 itcom2_1.halt = TRUE_;
6260
6261 return 0;
6262 } /* pstop_ */
6263
pvtbv_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * v)6264 doublereal pvtbv_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *v)
6265 {
6266 /* Local variables */
6267 static integer ii, jj;
6268 static doublereal sum;
6269 static integer jajj, ibgn, iend;
6270 static doublereal sumr;
6271
6272 /* THIS FUNCTION COMPUTES (V**T)*A*V. */
6273
6274 /* ... PARAMETER LIST: */
6275
6276 /* N DIMENSION OF MATRIX */
6277 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
6278 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
6279 /* V D.P. VECTOR OF LENGTH N */
6280
6281 sum = 0.;
6282 for (ii = 0; ii < *n; ++ii) {
6283 ibgn = ia[ii] - 1;
6284 iend = ia[ii + 1] - 1;
6285 if (ibgn >= iend)
6286 continue;
6287
6288 sumr = 0.;
6289 for (jj = ibgn; jj < iend; ++jj) {
6290 jajj = ja[jj] - 1;
6291 sumr -= a[jj] * v[jajj];
6292 }
6293 sum += v[ii] * sumr;
6294 }
6295
6296 if (itcom1_1.isym == 0)
6297 sum *= 2.;
6298
6299 return sum;
6300 } /* pvtbv_ */
6301
6302 /* Subroutine */
sbagn_(integer * n,integer * nz,integer * ia,integer * ja,doublereal * a,integer * iwork,integer * level,integer * nout,integer * ierr)6303 int sbagn_(integer *n, integer *nz, integer *ia, integer *ja, doublereal *a,
6304 integer *iwork, integer *level, integer *nout, integer* ierr)
6305 {
6306 /* Local variables */
6307 static integer i, j, ier, ntn, nto, now, nadd;
6308
6309 (void)level; (void)nout;
6310 /* ... THE ROUTINES SBINI, SBSIJ, AND SBEND CREATE A SPARSE */
6311 /* MATRIX STRUCTURE BY MEANS OF A LINKED LIST WHICH IS */
6312 /* DESTROYED BY SBEND. SBAGN CREATES A NEW LINKED LIST */
6313 /* SO THAT ELEMENTS MAY BE ADDED TO THE MATRIX AFTER SBEND */
6314 /* HAS BEEN CALLED. SBAGN SHOULD BE CALLED WITH THE APPRO- */
6315 /* PRIATE PARAMETERS, AND THEN SBSIJ AND SBEND CAN BE CALLED */
6316 /* TO ADD THE ELEMENTS AND COMPLETE THE SPARSE MATRIX STRUC- */
6317 /* TURE. */
6318
6319 /* ... PARAMETER LIST: */
6320
6321 /* N ORDER OF THE SYSTEM */
6322 /* NZ MAXIMUM NUMBER OF NON-ZERO ELEMENTS */
6323 /* IN THE SYSTEM */
6324 /* IA, JA INTEGER ARRAYS OF THE SPARSE */
6325 /* MATRIX STRUCTURE */
6326 /* A D.P. ARRAY OF THE SPARSE MATRIX */
6327 /* STRUCTURE */
6328 /* IWORK WORK ARRAY OF DIMENSION NZ */
6329 /* LEVEL OUTPUT LEVEL CONTROL (= LEVELL) */
6330 /* NOUT OUTPUT FILE NUMBER */
6331 /* IER ERROR FLAG (= IERR). POSSIBLE RETURNS ARE */
6332 /* IER = 0, SUCCESSFUL COMPLETION */
6333 /* = 703, NZ TOO SMALL - NO MORE */
6334 /* ELEMENTS CAN BE ADDED */
6335
6336 now = ia[*n] - 1;
6337 nadd = *nz - now;
6338 ier = 0;
6339 if (nadd <= 0)
6340 ier = 703;
6341
6342 if (ier != 0)
6343 goto L90;
6344
6345 /* ... SHIFT ELEMENTS OF A AND JA DOWN AND ADD ZERO FILL */
6346
6347 nto = now;
6348 ntn = *nz;
6349 for (i = 0; i < now; ++i) {
6350 --nto; --ntn;
6351 ja[ntn] = ja[nto];
6352 a[ntn] = a[nto];
6353 }
6354 for (i = 0; i < nadd; ++i) {
6355 ja[i] = 0;
6356 a[i] = 0.;
6357 }
6358
6359 /* ... UPDATE IA TO REFLECT DOWNWARD SHIFT IN A AND JA */
6360
6361 for (i = 0; i <= *n; ++i)
6362 ia[i] += nadd;
6363
6364 /* ... CREATE LINKED LIST */
6365
6366 for (i = nadd; i < *nz; ++i)
6367 iwork[i] = i + 2;
6368
6369 for (i = 0; i < nadd; ++i)
6370 iwork[i] = 0;
6371
6372 for (i = 0; i < *n; ++i) {
6373 j = ia[i + 1] - 2;
6374 iwork[j] = -i - 1;
6375 }
6376
6377 /* ... INDICATE IN LAST POSITION OF IA HOW MANY SPACES */
6378 /* ARE LEFT IN A AND JA FOR ADDITION OF ELEMENTS */
6379
6380 ia[*n] = nadd;
6381 return 0;
6382
6383 /* ... ERROR RETURN */
6384
6385 L90:
6386 *ierr = ier;
6387 return 0;
6388 } /* sbagn_ */
6389
6390 /* Subroutine */
sbelm_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,integer * iw,doublereal * rw,doublereal * tol,integer * isym,integer * level,integer * nout,integer * ier)6391 int sbelm_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, integer *iw,
6392 doublereal *rw, doublereal *tol, integer *isym, integer *level, integer *nout, integer *ier)
6393 {
6394 /* Local variables */
6395 static doublereal di;
6396 static integer ii, jj, kk, ibgn, iend, jjdi, icnt;
6397
6398 (void)level; (void)nout;
6399 /* ... SBELM IS DESIGNED TO REMOVE ROWS AND COLUMNS OF THE MATRIX */
6400 /* ... WHERE DABS(A(I,J))/A(I,I) .LE. TOL FOR J = 1 TO N AND A(I,I) */
6401 /* ... .GT. 0. THIS IS TO TAKE CARE OF MATRICES ARISING */
6402 /* ... FROM FINITE ELEMENT DISCRETIZATIONS OF PDE^S WITH DIRICHLET */
6403 /* ... BOUNDARY CONDITIONS. ANY SUCH ROWS AND CORRESPONDING COLUMNS */
6404 /* ... ARE THEN SET TO THE IDENTITY AFTER CORRECTING RHS. */
6405
6406 /* ... PARAMETER LIST: */
6407
6408 /* N DIMENSION OF MATRIX */
6409 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
6410 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
6411 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
6412 /* IW,RW WORK ARRAYS OF LENGTH N */
6413 /* TOL TOLERANCE FACTOR */
6414 /* ISYM FLAG FOR TYPE OF STORAGE FOR SYSTEM */
6415 /* (0: SYMMETRIC, 1:NONSYMMETRIC) */
6416 /* LEVEL PRINTING SWITCH FOR ERROR CONDITION */
6417 /* NOUT OUTPUT TAPE NUMBER */
6418 /* IER ERROR FLAG: NONZERO VALUE ON RETURN MEANS */
6419 /* 101 : DIAGONAL ENTRY NOT POSITIVE */
6420 /* 102 : THERE IS NO DIAGONAL ENTRY IN ROW */
6421
6422 /* ********************************************************************** */
6423
6424 /* UPDATE. SBELM HAS BEEN REWRITTEN TO SPEED UP THE LOCATION OF */
6425 /* OF ROWS WHICH ARE TO BE ELIMINATED. THIS IS DONE BY */
6426 /* FIRST STORING THE LARGEST ELEMENT OF EACH ROW IN */
6427 /* THE ARRAY RW. THE DIAGONAL ENTRY IS THEN COMPARED */
6428 /* WITH THE CORRESPONDING ELEMENT IN RW. IF IT IS */
6429 /* DECIDED TO ELIMINATE THE ROW THEN IT IS MARKED FOR */
6430 /* ELIMINATION. */
6431
6432 /* WHEN A ROW IS TO BE ELIMINATED ITS DIAGONAL ENTRY */
6433 /* IS STORED IN RW AND IW IS MARKED BY A NONZERO */
6434 /* (WHICH IS THIS ROW NUMBER) */
6435
6436 /* ROWS WHICH HAVE ONLY DIAGONAL ENTRIES ARE NOT */
6437 /* ALTERED. */
6438
6439 /* ********************************************************************* */
6440
6441 /* IF (N .GE. 1) GO TO 10 */
6442 /* IER = 100 */
6443 /* RETURN */
6444 /* 10 CONTINUE */
6445
6446 /* ... STORE THE LARGEST (DABSOLUTE VALUE) OFF DIAGONAL ENTRY FOR */
6447 /* ... ROW II IN RW(II). */
6448
6449 *ier = 0;
6450 icnt = 0;
6451 for (ii = 0; ii < *n; ++ii) {
6452 rw[ii] = 0.;
6453 iw[ii] = 0;
6454 }
6455 for (ii = 0; ii < *n; ++ii) {
6456 ibgn = ia[ii] - 1;
6457 iend = ia[ii + 1] - 1;
6458 if (ibgn >= iend)
6459 goto L140;
6460
6461 for (jj = ibgn; jj < iend; ++jj) {
6462 kk = ja[jj] - 1;
6463 if (kk == ii)
6464 continue;
6465
6466 rw[ii] = max(rw[ii],abs(a[jj]));
6467 if (*isym != 0)
6468 continue;
6469
6470 rw[kk] = max(rw[kk],abs(a[jj]));
6471 }
6472 }
6473
6474 /* ... FOR II = 1 TO N FIND THE DIAGONAL ENTRY IN ROW II */
6475
6476 for (ii = 0; ii < *n; ++ii) {
6477 ibgn = ia[ii] - 1;
6478 iend = ia[ii + 1] - 1;
6479 for (jj = ibgn; jj < iend; ++jj) {
6480 if (ja[jj] != ii + 1)
6481 continue;
6482
6483 di = a[jj];
6484 jjdi = jj + 1;
6485 if (di > 0.)
6486 goto L50;
6487
6488 *ier = 101;
6489 return 0;
6490 }
6491 goto L140;
6492 L50:
6493
6494 /* ... CHECK THE SIZE OF THE LARGEST OFF DIAGONAL ELEMENT */
6495 /* ... ( STORED IN RW(II) ) AGAINST THE DIAGONAL ELEMENT DII. */
6496
6497 if (rw[ii] == 0.) {
6498 if (1. / di > *tol)
6499 continue;
6500 }
6501 else if (rw[ii] / di > *tol)
6502 continue;
6503
6504 /* ... THE OFF DIAGONAL ELEMENTS ARE SMALL COMPARED TO THE DIAGONAL */
6505 /* ... THEREFORE MARK IT FOR ELIMINATION AND PERFORM INITIAL PROCESSING */
6506
6507 ++icnt;
6508 iw[ii] = ii + 1;
6509 rw[ii] = di;
6510 a[jjdi - 1] = 1.;
6511 rhs[ii] /= di;
6512 }
6513
6514 /* ... ELIMINATE THE ROWS AND COLUMNS INDICATED BY THE NONZERO */
6515 /* ... ENTRIES IN IW. THERE ARE ICNT OF THEM */
6516
6517 if (icnt == 0)
6518 return 0;
6519
6520 /* ... THE ELIMINATION IS AS FOLLOWS: */
6521
6522 /* FOR II = 1 TO N DO */
6523 /* IF ( IW(II) .NE. 0 ) THEN */
6524 /* SET DIAGONAL VALUE TO 1.0 ( ALREADY DONE ) */
6525 /* SET RHS(II) = RHS(II) / RW(II) ( ALREADY DONE ) */
6526 /* FIND NONZERO OFFDIAGONAL ENTRIES KK */
6527 /* IF ( IW(KK) .EQ. 0 ) FIX UP RHS(KK) WHEN USING SYMMETRIC ST */
6528 /* SET A(II,KK) = 0.0 */
6529 /* ELSE ( I.E. IW(II) .EQ. 0 ) */
6530 /* FIND NONZERO OFFDIAGONAL ENTRIES KK */
6531 /* IF ( IW(KK) .NE. 0 ) FIX UP RHS(II) */
6532 /* AND SET A(II,KK) = 0.0 */
6533 /* END IF */
6534 /* END DO */
6535
6536 for (ii = 0; ii < *n; ++ii) {
6537 ibgn = ia[ii] - 1;
6538 iend = ia[ii + 1] - 1;
6539 if (iw[ii] == 0)
6540 goto L100;
6541
6542 /* ... THE II-TH ROW IS TO BE ELIMINATED */
6543
6544 for (jj = ibgn; jj < iend; ++jj) {
6545 kk = ja[jj] - 1;
6546 if (kk == ii)
6547 continue;
6548
6549 if (iw[kk] == 0 && *isym == 0)
6550 rhs[kk] -= a[jj] * rhs[ii];
6551
6552 a[jj] = 0.;
6553 }
6554 continue;
6555
6556 /* ... THE II-TH ROW IS KEPT. CHECK THE OFF-DIAGONAL ENTRIES */
6557
6558 L100:
6559 for (jj = ibgn; jj < iend; ++jj) {
6560 kk = ja[jj] - 1;
6561 if (kk != ii && iw[kk] != 0) {
6562 rhs[ii] -= a[jj] * rhs[kk];
6563 a[jj] = 0.;
6564 }
6565 }
6566 }
6567
6568 return 0;
6569
6570 /* ... ERROR TRAPS -- NO DIAGONAL ENTRY IN ROW II (ROW MAY BE EMPTY). */
6571
6572 L140:
6573 *ier = 102;
6574
6575 return 0;
6576 } /* sbelm_ */
6577
6578 /* Subroutine */
sbend_(integer * n,integer * nz,integer * ia,integer * ja,doublereal * a,integer * iwork)6579 int sbend_(integer *n, integer *nz, integer *ia, integer *ja, doublereal *a, integer *iwork)
6580 {
6581 /* Local variables */
6582 static integer i, l, jaj;
6583 static doublereal val;
6584 static integer top, ideg, link, next, hlink, mhlink, ohlink, nulink, maxtop;
6585
6586 /* *********************************************************************** */
6587
6588 /* SBEND IS THE THIRD OF A SUITE OF SUBROUTINES TO AID THE */
6589 /* USER TO CONSTRUCT THE IA, JA, A DATA STRUCTURE USED IN */
6590 /* ITPACK. */
6591
6592 /* SBEND RESTRUCTURES THE LINKED LIST DATA STRUCTURE BUILT BY */
6593 /* SBINI AND SBSIJ INTO THE FINAL DATA STRUCTURE REQUIRE BY */
6594 /* ITPACK. THE RESTRUCTURING CAN TAKE PLACE IN THE MINIMUM */
6595 /* AMOUNT OF MEMORY REQUIRED TO HOLD THE NONZERO STRUCTURE OF */
6596 /* THE SPARSE MATRIX BUT WILL RUN QUICKER IF MORE STORAGE */
6597 /* IS ALLOWED. */
6598
6599 /* SBEND IS BASED ON SUBROUTINE BUILD OF THE SPARSE MATRIX */
6600 /* PACKAGE SPARSPAK DEVELOPED BY ALAN GEORGE AND JOSEPH LUI */
6601 /* OF THE UNIVERSITY OF WATERLOO, WATERLOO, ONTARIO. */
6602
6603 /* ... PARAMETERS */
6604
6605 /* ...... INPUT */
6606
6607 /* N THE ORDER OF THE LINEAR SYSTEM */
6608
6609 /* NZ THE LENGTH OF THE ARRAYS JA, IWORK, AND A. */
6610
6611 /* ...... INPUT/OUTPUT */
6612
6613 /* IA INTEGER ARRAY OF LENGTH N+1. THE FIRST N ENTRIES */
6614 /* POINT TO THE BEGINNING OF THE LINKED LIST FOR EACH */
6615 /* ROW. IA(N+1)-1 IS THE TOP OF THE LINKED LISTS */
6616 /* CONTAINED IN JA, IWORK, AND A. ON OUTPUT IA WILL */
6617 /* POINT TO THE FIRST ENTRY OF EACH ROW IN THE FINAL */
6618 /* DATA STRUCTURE. */
6619
6620 /* JA INTEGER ARRAY OF LENGTH NZ. ON INPUT JA STORES THE */
6621 /* COLUMN NUMBERS OF THE NONZERO ENTRIES AS INDICATED */
6622 /* BY THE LINKED LISTS. ON OUTPUT JA STORES THE */
6623 /* COLUMN NUMBERS IN ROW ORDERED FORM. */
6624
6625 /* A D.P. ARRAY OF LENGTH NZ. ON INPUT A STORES THE */
6626 /* VALUE OF THE NOZERO ENTRIES AS INDICATED BY THE */
6627 /* LINKED LISTS. ON OUTPUT A STORES THE VALUES IN */
6628 /* ROW ORDERED FORM. */
6629
6630 /* IWORK INTEGER ARRAY OF LENGTH NZ. ON INPUT IWORK STORES THE */
6631 /* THE LINKS OF THE LINKED LISTS. ON OUTPUT IT IS */
6632 /* DESTROYED. */
6633
6634 /* *********************************************************************** */
6635
6636 /* ... INITIALIZATION */
6637
6638 /* ...... THE VARIABLES NEXT AND TOP RESPECTIVELY POINT TO THE */
6639 /* NEXT AVAILABLE ENTRY FOR THE FINAL DATA STRUCTURE AND */
6640 /* THE TOP OF THE REMAINDER OF THE LINKED LISTS. */
6641
6642 next = 0;
6643 top = ia[*n];
6644 maxtop = *nz - ia[*n];
6645
6646 /* *********************************************************************** */
6647
6648 /* ... CONVERT EACH ROW INTO FINAL FORM */
6649
6650 for (i = 0; i < *n; ++i) {
6651 ideg = 0;
6652 nulink = ia[i] - 1;
6653
6654 /* ... LOOP OVER EACH NODE IN THE LINKED LIST OF ROW I */
6655
6656 L10:
6657 link = nulink;
6658 if (link < 0)
6659 goto L80;
6660
6661 nulink = iwork[link] - 1;
6662 jaj = ja[link];
6663 val = a[link];
6664
6665 /* ... CHECK TO SEE IF A COLLISION BETWEEN THE LINKED LISTS */
6666 /* AND THE FINAL FORM HAS OCCURRED. */
6667
6668 if (next >= top && link != top)
6669 goto L20;
6670
6671 /* ... COLLISION HAS NOT OCCURRED. FREE THE SPACE FOR THE TRIPLE */
6672 /* (JA(LINK), A(LINK), IWORK(LINK)) */
6673
6674 ja[link] = 0;
6675 a[link] = 0.;
6676 iwork[link] = 0;
6677
6678 /* ... SPECIAL CASE TO MOVE TOP DOWN IF LINK .EQ. TOP */
6679
6680 if (link == top)
6681 goto L60;
6682
6683 goto L70;
6684
6685 /* *********************************************************************** */
6686
6687 /* ... COLLISION HAS OCCURRED. CLEAR OFF SOME SPACE FOR THE CURRENT */
6688 /* ENTRY BY MOVING THE TRIPLE ( JA(TOP),A(TOP),IWORK(TOP) ) */
6689 /* DOWNWARDS TO THE FREED TRIPLE ( JA(LINK),A(LINK),IWORK(LINK) ). */
6690 /* THEN ADJUST THE LINK FIELDS. */
6691
6692 /* ...... PATCH UP THE LINKED LIST FOR THE CURRENT ROW I. THEN */
6693 /* TRAVERSE THE LINKED LIST CONTAINING TOP UNTIL THE POINTER */
6694 /* POINTER BACK TO IA IS FOUND. */
6695
6696 L20:
6697 ia[i] = link + 1;
6698 hlink = top;
6699
6700 L30:
6701 hlink = iwork[hlink] - 1;
6702 if (hlink >= 0)
6703 goto L30;
6704
6705 /* ...... NOW FOLLOW THE LINKED LIST BACK TO TOP KEEPING TRACK */
6706 /* OF THE OLD LINK. */
6707
6708 /* ......... SPECIAL CASE IF IA(-HLINK) = TOP */
6709
6710 mhlink = -hlink - 2;
6711 if (ia[mhlink] != top + 1)
6712 goto L40;
6713
6714 iwork[link] = iwork[top];
6715 ja[link] = ja[top];
6716 a[link] = a[top];
6717 ia[mhlink] = link + 1;
6718 if (nulink == top)
6719 nulink = link;
6720
6721 goto L60;
6722
6723 /* ......... USUAL CASE. */
6724
6725 L40:
6726 hlink = ia[mhlink] - 1;
6727 L50:
6728 ohlink = hlink;
6729 hlink = iwork[ohlink] - 1;
6730 if (hlink != top)
6731 goto L50;
6732
6733 iwork[link] = iwork[top];
6734 ja[link] = ja[top];
6735 a[link] = a[top];
6736 if (ohlink != link)
6737 iwork[ohlink] = link + 1;
6738
6739 if (nulink == top)
6740 nulink = link;
6741
6742 /* ... COLLAPSE TOP OF LINK LIST BY AS MUCH AS POSSIBLE */
6743
6744 L60:
6745 while (++top < maxtop && iwork[top] == 0) ;
6746
6747 /* *********************************************************************** */
6748
6749 /* ... PUT THE CURRENT TRIPLE INTO THE FINAL DATA STRUCTURE */
6750
6751 L70:
6752 ja[next] = jaj;
6753 a[next] = val;
6754 ++next;
6755 ++ideg;
6756 goto L10;
6757
6758 /* ... FINAL STRUCTURE FOR ROW I IS COMPLETE. LINKED LIST IS */
6759 /* DESTROYED AND WILL BE RECAPTURED AS NECESSARY BY THE */
6760 /* LOOP ON LABEL 60 */
6761
6762 L80:
6763 ia[i] = ideg;
6764 }
6765
6766 /* *********************************************************************** */
6767
6768 /* ... FINALIZE THE DATA STRUCTURE BY BUILDING THE FINAL VERSION OF */
6769 /* IA. */
6770
6771 l = ia[0] + 1;
6772 ia[0] = 1;
6773 for (i = 0; i < *n; ++i) {
6774 ideg = ia[i + 1];
6775 ia[i + 1] = l;
6776 l += ideg;
6777 }
6778
6779 /* ... FINAL IA, JA, A DATA STRUCTURE BUILT. */
6780
6781 return 0;
6782 } /* sbend_ */
6783
6784 /* Subroutine */
sbini_(integer * n,integer * nz,integer * ia,integer * ja,doublereal * a,integer * iwork)6785 int sbini_(integer *n, integer *nz, integer *ia, integer *ja, doublereal *a, integer *iwork)
6786 {
6787 /* Local variables */
6788 static integer i;
6789
6790 /* *********************************************************************** */
6791
6792 /* SBINI IS THE FIRST OF A SUITE OF THREE SUBROUTINES TO AID */
6793 /* THE USER TO CONSTRUCT THE IA, JA, A DATA STRUCTURE USED */
6794 /* IN ITPACK. */
6795
6796 /* SBINI INITIALIZES THE ARRAYS IA, JA, IWORK, AND A. THE OTHER */
6797 /* SUBROUTINES IN THE SUITE ARE SBSIJ ( WHICH BUILDS A LINKED */
6798 /* LIST REPRESENTATION OF THE MATRIX STRUCTURE ) AND SBEND ( WHICH */
6799 /* RESTRUCTURE THE LINKED LIST FORM INTO THE FINAL FORM ). */
6800
6801 /* ... PARAMETERS */
6802
6803 /* ...... INPUT */
6804
6805 /* N THE ORDER OF THE LINEAR SYSTEM */
6806
6807 /* NZ THE MAXIMUM NUMBER OF NONZEROES ALLOWED IN THE */
6808 /* LINEAR SYSTEM. */
6809
6810 /* ...... OUTPUT */
6811
6812 /* IA INTEGER ARRAY OF LENGTH N+1. SBINI SETS THIS ARRAY */
6813 /* TO -I FOR I = 1 THRU N. IA(N+1) IS SET TO NZ. */
6814
6815 /* JA INTEGER ARRAY OF LENGTH NZ. INITIALIZED TO ZERO HERE. */
6816
6817 /* A D.P. ARRAY OF LENGTH NZ. INITIALIZED TO ZERO HERE. */
6818
6819 /* IWORK INTEGER ARRAY OF LENGTH NZ. INITIALIZED TO ZERO HERE. */
6820
6821 /* *********************************************************************** */
6822
6823 for (i = 0; i < *n; ++i)
6824 ia[i] = -i - 1;
6825
6826 ia[*n] = *nz;
6827
6828 ivfill_(nz, ja, &c__0);
6829 ivfill_(nz, iwork, &c__0);
6830 vfill_(nz, a, &c_b21);
6831
6832 return 0;
6833 } /* sbini_ */
6834
6835 /* Subroutine */
sbsij_(integer * n,integer * nz,integer * ia,integer * ja,doublereal * a,integer * iwork,integer * ii,integer * jj,doublereal * vall,integer * mode,integer * level,integer * nout,integer * ierr)6836 int sbsij_(integer *n, integer *nz, integer *ia, integer *ja, doublereal *a,
6837 integer *iwork, integer *ii, integer *jj, doublereal * vall,
6838 integer *mode, integer *level, integer *nout, integer* ierr)
6839 {
6840 /* Local variables */
6841 static integer i, j, ier;
6842 static doublereal val;
6843 static integer link;
6844 static doublereal temp;
6845 static integer next;
6846
6847 (void)nz; (void)level; (void)nout;
6848
6849 /* *********************************************************************** */
6850
6851 /* SBSIJ IS THE SECOND OF A SUITE OF THREE SUBROUTINES TO AID IN */
6852 /* THE CONSTRUCTION OF THE IA, JA, A DATA STRUCTURE USED IN */
6853 /* ITPACK. */
6854
6855 /* SBSIJ TAKES THE INDIVIDUAL ENTRIES OF THE SPARSE MATRIX AS */
6856 /* GIVEN TO IT AT EACH CALL VIA (I,J,VAL) AND INSERTS IT INTO */
6857 /* A LINKED LIST REPRESENTATION OF THE SPARSE MATRIX. */
6858
6859 /* EACH ROW OF THE SPARSE MATRIX IS ASSOCIATED WITH A CIRCULAR */
6860 /* LINKED LIST BEGINNING AT IA(I). THE LAST ENTERED ELEMENT IN */
6861 /* EACH LIST POINTS BACK TO IA(I) WITH THE VALUE -I. THE LINKS */
6862 /* ARE STORED IN THE ARRAY IWORK, WHILE JA AND A STORE THE COLUMN */
6863 /* NUMBER AND VALUE IN PARALLEL TO IWORK. THE LINKED LISTED ARE */
6864 /* STORED BEGINNING AT ENTRY NZ AND WORKING BACKWARDS TOWARDS 1. */
6865
6866 /* ... PARAMETERS */
6867
6868 /* ...... INPUT */
6869
6870 /* N THE ORDER OF THE LINEAR SYSTEM */
6871
6872 /* NZ THE LENGTH OF THE ARRAYS JA, A, AND IWORK */
6873
6874 /* I, J THE ROW AND COLUMN NUMBERS OF THE ENTRY OF THE SPARSE */
6875 /* LINEAR SYSTEM TO BE ENTERED IN THE DATA STRUCTURE(=II,JJ) */
6876
6877 /* VAL THE NONZERO VALUE ASSOCIATED WITH (I,J) (= VALL) */
6878
6879 /* MODE IF THE (I,J) ENTRY HAS ALREADY BEEN SET, MODE SPECIFIES */
6880 /* THE WAY IN WHICH THE ENTRY IS TO BE TREATED. */
6881 /* IF MODE .LT. 0 LET THE VALUE REMAIN AS IS */
6882 /* .EQ. 0 RESET IT TO THE NEW VALUE */
6883 /* .GT. 0 ADD THE NEW VALUE TO THE OLD VALUE */
6884
6885 /* NOUT OUTPUT FILE NUMBER */
6886
6887 /* LEVEL OUTPUT FILE SWITCH */
6888
6889 /* ... INPUT/OUTPUT */
6890
6891 /* IA INTEGER ARRAY OF LENGTH N+1. THE FIRST N ENTRIES */
6892 /* POINT TO THE BEGINNING OF THE LINKED LIST FOR EACH */
6893 /* ROW. IA(N+1) POINTS TO THE NEXT ENTRY AVAILABLE FOR */
6894 /* STORING THE CURRENT ENTRY INTO THE LINKED LIST. */
6895
6896 /* JA INTEGER ARRAY OF LENGTH NZ. JA STORES THE COLUMN */
6897 /* NUMBERS OF THE NONZERO ENTRIES. */
6898
6899 /* A D.P. ARRAY OF LENGTH NZ. A STORES THE VALUE OF THE */
6900 /* NONZERO ENTRIES. */
6901
6902 /* IWORK INTEGER ARRAY OF LENGTH NZ. IWORK STORES THE LINKS. */
6903
6904 /* IER ERROR FLAG.(= IERR) POSSIBLE RETURNS ARE */
6905 /* IER = 0 SUCCESSFUL COMPLETION */
6906 /* = 700 ENTRY WAS ALREADY SET, VALUE HANDLED */
6907 /* AS SPECIFIED BY MODE. */
6908 /* = 701 IMPROPER VALUE OF EITHER I OR J INDEX */
6909 /* = 702 NO ROOM REMAINING, NZ TOO SMALL. */
6910
6911 /* *********************************************************************** */
6912
6913 /* ... CHECK THE VALIDITY OF THE (I,J) ENTRY */
6914
6915 i = *ii - 1;
6916 j = *jj - 1;
6917 val = *vall;
6918 ier = 0;
6919 if (i < 0 || i >= *n)
6920 ier = 701;
6921
6922 if (j < 0 || j >= *n)
6923 ier = 701;
6924
6925 if (ier != 0)
6926 goto L130;
6927
6928 /* ... TRAVERSE THE LINK LIST POINTED TO BY IA(I) UNTIL EITHER */
6929 /* ... THE J ENTRY OR THE END OF THE LIST HAS BEEN FOUND. */
6930
6931 link = ia[i] - 1;
6932
6933 /* ...... SPECIAL CASE FOR THE FIRST ENTRY IN THE ROW */
6934
6935 if (link >= 0)
6936 goto L30;
6937
6938 next = ia[*n] - 1;
6939 if (next < 0)
6940 goto L110;
6941
6942 ia[i] = next + 1;
6943 ja[next] = j + 1;
6944 a[next] = val;
6945 iwork[next] = -i - 1;
6946 ia[*n] = next;
6947 goto L130;
6948
6949 /* ... FOLLOW THE LINK LIST UNTIL J OR THE END OF THE LIST IS FOUND */
6950
6951 L30:
6952 if (ja[link] == j + 1)
6953 goto L40;
6954
6955 if (iwork[link] <= 0)
6956 goto L100;
6957
6958 link = iwork[link] - 1;
6959 goto L30;
6960
6961 /* : */
6962 /* ... ENTRY (I,J) ALREADY HAS BEEN SET. RESET VALUE DEPENDING ON MODE */
6963
6964 L40:
6965 ier = 700;
6966 if (*mode < 0)
6967 goto L130;
6968
6969 if (*mode < 1) {
6970 a[link] = val;
6971 goto L130;
6972 }
6973 temp = a[link] + val;
6974 a[link] = temp;
6975 goto L130;
6976
6977 /* ... ENTRY (I,J) HAS NOT BEEN SET. ENTER IT INTO THE LINKED LIST */
6978
6979 L100:
6980 next = ia[*n] - 1;
6981 if (next >= 0) {
6982 iwork[link] = next + 1;
6983 ja[next] = j + 1;
6984 a[next] = val;
6985 iwork[next] = -i - 1;
6986 ia[*n] = next;
6987 goto L130;
6988 }
6989
6990 /* *********************************************************************** */
6991
6992 /* ... ERROR TRAP FOR NO ROOM REMAINING */
6993
6994 L110:
6995 ier = 702;
6996
6997 L130:
6998 *ierr = ier;
6999 return 0;
7000 } /* sbsij_ */
7001
7002 /* Subroutine */
scal_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * d,integer * level,integer * nout,integer * ier)7003 int scal_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs,
7004 doublereal *u, doublereal *d, integer *level, integer *nout, integer *ier)
7005 {
7006 /* Local variables */
7007 static integer i, j;
7008 static doublereal di;
7009 static integer ii, jj, im1, jadd, jajj, ibgn, iend, jjpi;
7010
7011 (void)level; (void)nout;
7012 /* ... ORIGINAL MATRIX IS SCALED TO A UNIT DIAGONAL MATRIX. RHS */
7013 /* ... AND U ARE SCALED ACCORDINGLY. THE MATRIX IS THEN SPLIT AND */
7014 /* ... IA, JA, AND A RESHUFFLED. */
7015
7016 /* ... PARAMETER LIST: */
7017
7018 /* N DIMENSION OF MATRIX */
7019 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
7020 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
7021 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
7022 /* U LATEST ESTIMATE OF SOLUTION */
7023 /* D OUTPUT VECTOR CONTAINING THE SQUARE ROOTS */
7024 /* OF THE DIAGONAL ENTRIES */
7025 /* LEVEL PRINTING SWITCH FOR ERROR CONDITION */
7026 /* NOUT OUTPUT TAPE NUMBER */
7027 /* IER ERROR FLAG: ON RETURN NONZERO VALUES MEAN */
7028 /* 401 : THE ITH DIAGONAL ELEMENT IS .LE. 0. */
7029 /* 402 : NO DIAGONAL ELEMENT IN ROW I */
7030
7031 /* ... EXTRACT SQUARE ROOT OF THE DIAGONAL OUT OF A AND SCALE U AND RHS */
7032
7033 *ier = 0;
7034 for (ii = 0; ii < *n; ++ii) {
7035 ibgn = ia[ii] - 1;
7036 iend = ia[ii + 1] - 1;
7037 for (jj = ibgn; jj < iend; ++jj) {
7038 if (ja[jj] != ii + 1)
7039 continue;
7040
7041 di = a[jj];
7042 if (di > 0.)
7043 goto L70;
7044
7045 if (di != 0.) {
7046 *ier = 401;
7047 return 0;
7048 }
7049 *ier = 401;
7050 return 0;
7051 }
7052 *ier = 402;
7053 return 0;
7054
7055 L70:
7056 di = sqrt((abs(di)));
7057 rhs[ii] /= di;
7058 u[ii] *= di;
7059 d[ii] = di;
7060 }
7061
7062 /* ... SHIFT MATRIX TO ELIMINATE DIAGONAL ENTRIES */
7063
7064 if (*n > 1)
7065 for (i = 0; i < *n; ++i) {
7066 im1 = i;
7067 ii = *n - i - 1;
7068 ibgn = ia[ii] - 1;
7069 iend = ia[ii + 1] - 1;
7070 jadd = ibgn + iend + 1;
7071 for (j = ibgn; j < iend; ++j) {
7072 jj = jadd - j - 2;
7073 jjpi = jj + im1;
7074 if (ja[jj] == ii + 1)
7075 im1 = i + 1;
7076
7077 a[jjpi] = a[jj];
7078 ja[jjpi] = ja[jj];
7079 }
7080 ia[ii + 1] = ia[ii + 1] + i;
7081 }
7082
7083 ia[0] += *n;
7084
7085 /* ... SCALE SHIFTED MATRIX AND STORE D ARRAY IN FIRST N ENTRIES OF A */
7086
7087 for (ii = 0; ii < *n; ++ii) {
7088 ibgn = ia[ii] - 1;
7089 iend = ia[ii + 1] - 1;
7090 di = d[ii];
7091 for (jj = ibgn; jj < iend; ++jj) {
7092 jajj = ja[jj] - 1;
7093 a[jj] /= di * d[jajj];
7094 }
7095 a[ii] = di;
7096 }
7097
7098 return 0;
7099 } /* scal_ */
7100
7101 /* Subroutine */
sum3_(integer * n,doublereal * c1,doublereal * x1,doublereal * c2,doublereal * x2,doublereal * c3,doublereal * x3)7102 int sum3_(integer *n, doublereal *c1, doublereal *x1, doublereal *c2, doublereal *x2, doublereal *c3, doublereal *x3)
7103 {
7104 /* Local variables */
7105 static integer i;
7106
7107 /* ... COMPUTES X3 = C1*X1 + C2*X2 + C3*X3 */
7108
7109 /* ... PARAMETER LIST: */
7110
7111 /* N INTEGER LENGTH OF VECTORS X1, X2, X3 */
7112 /* C1,C2,C3 D.P. CONSTANTS */
7113 /* X1,X2,X3 D.P. VECTORS SUCH THAT */
7114 /* X3(I) = C1*X1(I) + C2*X2(I) + C3*X3(I) */
7115 /* X3(I) = C1*X1(I) + C2*X2(I) IF C3 = 0. */
7116
7117 if (*n <= 0)
7118 return 0;
7119
7120 if (*c3 != 0.) {
7121 for (i = 0; i < *n; ++i)
7122 x3[i] = *c1 * x1[i] + *c2 * x2[i] + *c3 * x3[i];
7123 return 0;
7124 }
7125
7126 for (i = 0; i < *n; ++i)
7127 x3[i] = *c1 * x1[i] + *c2 * x2[i];
7128
7129 return 0;
7130 } /* sum3_ */
7131
tau_(integer * ii)7132 doublereal tau_(integer *ii)
7133 {
7134 /* Initialized data */
7135 static doublereal t[8] = { 1.5,1.8,1.85,1.9,1.94,1.96,1.975,1.985 };
7136
7137 /* ... THIS SUBROUTINE SETS TAU(II) FOR THE SOR METHOD. */
7138
7139 /* II NUMBER OF TIMES PARAMETERS HAVE BEEN CHANGED */
7140
7141 if (*ii <= 8)
7142 return t[*ii - 1];
7143 else
7144 return 1.992;
7145 } /* tau_ */
7146
dsrc_timer_(real * dummy)7147 doublereal dsrc_timer_(real* dummy)
7148 {
7149 /* ... TIMER IS A ROUTINE TO RETURN THE EXECUTION TIME IN SECONDS. */
7150
7151 /* ********************************************* */
7152 /* ** ** */
7153 /* ** THIS ROUTINE IS NOT PORTABLE. ** */
7154 /* ** ** */
7155 /* ********************************************* */
7156
7157 (void)dummy;
7158 return (doublereal)time(0L);
7159 } /* dsrc_timer_ */
7160
tstchg_(integer * ibmth)7161 logical tstchg_(integer *ibmth)
7162 {
7163 /* Local variables */
7164 static integer ip;
7165
7166 /* THIS FUNCTION PERFORMS A TEST TO DETERMINE IF PARAMETERS */
7167 /* SHOULD BE CHANGED FOR SEMI-ITERATION ACCELERATED METHODS. */
7168
7169 /* ... PARAMETER LIST: */
7170
7171 /* IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY SI */
7172 /* IBMTH = 1, JACOBI */
7173 /* = 2, REDUCED SYSTEM */
7174 /* = 3, SSOR */
7175
7176 ip = itcom1_1.in - itcom1_1.is;
7177 if (*ibmth == 2)
7178 ip <<= 1;
7179
7180 if (itcom1_1.in == 0)
7181 goto L10;
7182
7183 if (ip < 3)
7184 goto L20;
7185
7186 itcom3_1.qa = sqrt(abs(itcom3_1.delnnm / itcom3_1.delsnm));
7187 itcom3_1.qt = sqrt(abs(pow_di(&itcom3_1.rrr, &ip))) * 2. / (pow_di(&itcom3_1.rrr, &ip) + 1.);
7188 if (itcom3_1.qa >= 1. || itcom3_1.qa < pow_dd(&itcom3_1.qt, &itcom3_1.ff))
7189
7190 goto L20;
7191
7192 /* ... TEST PASSES -- CHANGE PARAMETERS */
7193
7194 L10:
7195 return TRUE_;
7196
7197 /* ... TEST FAILS -- DO NOT CHANGE PARAMETERS */
7198
7199 L20:
7200 return FALSE_;
7201 } /* tstchg_ */
7202
7203 /* Subroutine */
unscal_(integer * n,integer * ia,integer * ja,doublereal * a,doublereal * rhs,doublereal * u,doublereal * d)7204 int unscal_(integer *n, integer *ia, integer *ja, doublereal *a, doublereal *rhs, doublereal *u, doublereal *d)
7205 {
7206 /* Local variables */
7207 static doublereal di;
7208 static integer ii, jj, is, jajj, ibgn, iend, jjpi, inew;
7209
7210 /* ... THIS SUBROUTINE REVERSES THE PROCESS OF SCAL. */
7211
7212 /* ... PARAMETER LIST: */
7213
7214 /* N DIMENSION OF MATRIX */
7215 /* IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION */
7216 /* A D.P. ARRAY OF SPARSE MATRIX REPRESENTATION */
7217 /* RHS RIGHT HAND SIDE OF MATRIX PROBLEM */
7218 /* U LATEST ESTIMATE OF SOLUTION */
7219 /* D VECTOR CONTAINING THE SQUARE ROOTS */
7220 /* OF THE DIAGONAL ENTRIES */
7221
7222 /* ... EXTRACT DIAGONAL FROM SCALED A AND UNSCALE U AND RHS */
7223
7224 for (ii = 0; ii < *n; ++ii) {
7225 di = a[ii];
7226 u[ii] /= di;
7227 rhs[ii] *= di;
7228 d[ii] = di;
7229 }
7230
7231 /* ... UNSCALE A */
7232
7233 for (ii = 0; ii < *n; ++ii) {
7234 ibgn = ia[ii] - 1;
7235 iend = ia[ii + 1] - 1;
7236 di = d[ii];
7237 for (jj = ibgn; jj < iend; ++jj) {
7238 jajj = ja[jj];
7239 a[jj] *= di * d[jajj-1];
7240 }
7241 }
7242
7243 /* ... INSERT DIAGONAL BACK INTO A */
7244
7245 for (ii = 0; ii < *n; ++ii) {
7246 ibgn = ia[ii] - 1;
7247 iend = ia[ii + 1] - 1;
7248 is = *n - ii - 1;
7249 inew = ibgn - is - 1;
7250 a[inew] = d[ii] * d[ii];
7251 ja[inew] = ii + 1;
7252 if (is != 0)
7253 for (jj = ibgn; jj < iend; ++jj) {
7254 jjpi = jj - is;
7255 a[jjpi] = a[jj];
7256 ja[jjpi] = ja[jj];
7257 }
7258 ia[ii] = inew + 1;
7259 }
7260
7261 return 0;
7262 } /* unscal_ */
7263
7264 /* Subroutine */
vevmw_(integer * n,doublereal * v,doublereal * w)7265 int vevmw_(integer *n, doublereal *v, doublereal *w)
7266 {
7267 /* Local variables */
7268 static integer i, m;
7269
7270 /* ... VEVMW COMPUTES V = V - W */
7271
7272 /* ... PARAMETER LIST: */
7273
7274 /* N INTEGER LENGTH OF VECTORS V AND W */
7275 /* V D.P. VECTOR */
7276 /* W D.P. VECTOR SUCH THAT V(I) = V(I) - W(I) */
7277
7278 if (*n <= 0)
7279 return 0;
7280
7281 m = *n % 4;
7282
7283 for (i = 0; i < m; ++i)
7284 v[i] -= w[i];
7285
7286 for (i = m; i < *n; i += 4) {
7287 v[i] -= w[i];
7288 v[i + 1] -= w[i + 1];
7289 v[i + 2] -= w[i + 2];
7290 v[i + 3] -= w[i + 3];
7291 }
7292 return 0;
7293 } /* vevmw_ */
7294
7295 /* Subroutine */
vevpw_(integer * n,doublereal * v,doublereal * w)7296 int vevpw_(integer *n, doublereal *v, doublereal *w)
7297 {
7298 /* Local variables */
7299 static integer i, m;
7300
7301 /* ... VPW COMPUTES V = V + W */
7302
7303 /* ... PARAMETER LIST: */
7304
7305 /* N LENGTH OF VECTORS V AND W */
7306 /* V D.P. VECTOR */
7307 /* W D.P. VECTOR SUCH THAT V(I) = V(I) + W(I) */
7308
7309 if (*n <= 0)
7310 return 0;
7311
7312 m = *n % 4;
7313 for (i = 0; i < m; ++i)
7314 v[i] += w[i];
7315
7316 for (i = m; i < *n; i += 4) {
7317 v[i] += w[i];
7318 v[i + 1] += w[i + 1];
7319 v[i + 2] += w[i + 2];
7320 v[i + 3] += w[i + 3];
7321 }
7322
7323 return 0;
7324 } /* vevpw_ */
7325
7326 /* Subroutine */
vfill_(integer * n,doublereal * v,doublereal * val)7327 int vfill_(integer *n, doublereal *v, doublereal *val)
7328 {
7329 /* Local variables */
7330 static integer i, m;
7331
7332 /* FILLS A VECTOR, V, WITH A CONSTANT VALUE, VAL. */
7333
7334 /* ... PARAMETER LIST: */
7335
7336 /* N INTEGER LENGTH OF VECTOR V */
7337 /* V D.P. VECTOR */
7338 /* VAL D.P. CONSTANT THAT FILLS FIRST N LOCATIONS OF V */
7339
7340 if (*n <= 0)
7341 return 0;
7342
7343 /* CLEAN UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 10 */
7344
7345 m = *n % 10;
7346 for (i = 0; i < m; ++i)
7347 v[i] = *val;
7348
7349 for (i = m; i < *n; i += 10) {
7350 v[i] = *val;
7351 v[i + 1] = *val;
7352 v[i + 2] = *val;
7353 v[i + 3] = *val;
7354 v[i + 4] = *val;
7355 v[i + 5] = *val;
7356 v[i + 6] = *val;
7357 v[i + 7] = *val;
7358 v[i + 8] = *val;
7359 v[i + 9] = *val;
7360 }
7361
7362 return 0;
7363 } /* vfill_ */
7364
7365 /* Subroutine */
vout_(integer * n,doublereal * v,integer * iswt,integer * nout)7366 int vout_(integer *n, doublereal *v, integer *iswt, integer *nout)
7367 {
7368 /* THIS SUBROUTINE EFFECTS PRINTING OF RESIDUAL AND SOLUTION */
7369 /* VECTORS - CALLED FROM PERROR */
7370
7371 /* ... PARAMETER LIST: */
7372
7373 /* V VECTOR OF LENGTH N */
7374 /* ISWT LABELLING INFORMATION */
7375 /* NOUT OUTPUT DEVICE NUMBER */
7376
7377 /* IF (N .LE. 0) RETURN */
7378 (void)n; (void)v; (void)iswt; (void)nout;
7379
7380 return 0;
7381 } /* vout_ */
7382
7383 /* Subroutine */
wevmw_(integer * n,doublereal * v,doublereal * w)7384 int wevmw_(integer *n, doublereal *v, doublereal *w)
7385 {
7386 /* Local variables */
7387 static integer i, m;
7388
7389 /* ... WEVMW COMPUTES W = V - W */
7390
7391 /* ... PARAMETER LIST: */
7392
7393 /* N INTEGER LENGTH OF VECTORS V AND W */
7394 /* V D.P. VECTOR */
7395 /* W D.P. VECTOR SUCH THAT W(I) = V(I) - W(I) */
7396
7397 if (*n <= 0)
7398 return 0;
7399
7400 m = *n % 4;
7401 for (i = 0; i < m; ++i)
7402 w[i] = v[i] - w[i];
7403
7404 for (i = m; i < *n; i += 4) {
7405 w[i] = v[i] - w[i];
7406 w[i + 1] = v[i + 1] - w[i + 1];
7407 w[i + 2] = v[i + 2] - w[i + 2];
7408 w[i + 3] = v[i + 3] - w[i + 3];
7409 }
7410
7411 return 0;
7412 } /* wevmw_ */
7413