/* DECK DBOLSM */ /* Subroutine */ int dbolsm_(doublereal *w, integer *mdw, integer *minput, integer *ncols, doublereal *bl, doublereal *bu, integer *ind, integer *iopt, doublereal *x, doublereal *rnorm, integer *mode, doublereal * rw, doublereal *ww, doublereal *scl, integer *ibasis, integer *ibb) { /* System generated locals */ address a__1[3], a__2[4], a__3[6], a__4[5], a__5[2], a__6[7]; integer w_dim1, w_offset, i__1[3], i__2[4], i__3, i__4[6], i__5[5], i__6[ 2], i__7[7], i__8, i__9, i__10; doublereal d__1, d__2; char ch__1[47], ch__2[50], ch__3[79], ch__4[53], ch__5[94], ch__6[75], ch__7[83], ch__8[92], ch__9[105], ch__10[102], ch__11[61], ch__12[ 110], ch__13[134], ch__14[44], ch__15[76]; /* Local variables */ static integer i__, j; static doublereal t, t1, t2, sc; static integer ip, jp, lp; static doublereal ss, wt, cl1, cl2, cl3, fac, big; static integer lds; static doublereal bou, beta; static integer jbig, jmag, ioff, jcol; static doublereal wbig; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); static doublereal wmag; static integer mval, iter; extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *); static doublereal xnew; extern doublereal dnrm2_(integer *, doublereal *, integer *); static char xern1[8], xern2[8], xern3[16], xern4[16]; static doublereal alpha; static logical found; static integer nsetb; extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer igopr, itmax, itemp; extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static integer lgopr; extern /* Subroutine */ int dmout_(integer *, integer *, integer *, doublereal *, char *, integer *, ftnlen); static integer jdrop; extern doublereal d1mach_(integer *); extern /* Subroutine */ int dvout_(integer *, doublereal *, char *, integer *, ftnlen), ivout_(integer *, integer *, char *, integer * , ftnlen); static integer mrows, jdrop1, jdrop2, jlarge; static doublereal colabv, colblo, wlarge, tolind; extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen); static integer iprint; static logical constr; static doublereal tolsze; /* Fortran I/O blocks */ static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___4 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___6 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___9 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___12 = { 0, xern3, 0, "(1PD15.6)", 16, 1 }; static icilist io___14 = { 0, xern4, 0, "(1PD15.6)", 16, 1 }; static icilist io___15 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___16 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___17 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___18 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___31 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___32 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___33 = { 0, xern3, 0, "(1PD15.6)", 16, 1 }; static icilist io___34 = { 0, xern4, 0, "(1PD15.6)", 16, 1 }; static icilist io___35 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___36 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___37 = { 0, xern3, 0, "(1PD15.6)", 16, 1 }; static icilist io___38 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___39 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___40 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___41 = { 0, xern3, 0, "(1PD15.6)", 16, 1 }; static icilist io___42 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___43 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___44 = { 0, xern3, 0, "(1PD15.6)", 16, 1 }; static icilist io___45 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___54 = { 0, xern1, 0, "(I8)", 8, 1 }; /* ***BEGIN PROLOGUE DBOLSM */ /* ***SUBSIDIARY */ /* ***PURPOSE Subsidiary to DBOCLS and DBOLS */ /* ***LIBRARY SLATEC */ /* ***TYPE DOUBLE PRECISION (SBOLSM-S, DBOLSM-D) */ /* ***AUTHOR (UNKNOWN) */ /* ***DESCRIPTION */ /* **** Double Precision Version of SBOLSM **** */ /* **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** */ /* Solve E*X = F (least squares sense) with bounds on */ /* selected X values. */ /* The user must have DIMENSION statements of the form: */ /* DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), */ /* * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) */ /* INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) */ /* (Here NX=number of extra locations required for options 1,...,7; */ /* NX=0 for no options; here NI=number of extra locations possibly */ /* required for options 1-7; NI=0 for no options; NI=14 if all the */ /* options are simultaneously in use.) */ /* INPUT */ /* ----- */ /* -------------------- */ /* W(MDW,*),MINPUT,NCOLS */ /* -------------------- */ /* The array W(*,*) contains the matrix [E:F] on entry. The matrix */ /* [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in */ /* the array W(*,*) with E occupying the first NCOLS columns and the */ /* right side vector F in column NCOLS+1. The row dimension, MDW, of */ /* the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. */ /* Other values of MDW are errors. The values of MINPUT and NCOLS */ /* must be positive. Other values are errors. */ /* ------------------ */ /* BL(*),BU(*),IND(*) */ /* ------------------ */ /* These arrays contain the information about the bounds that the */ /* solution values are to satisfy. The value of IND(J) tells the */ /* type of bound and BL(J) and BU(J) give the explicit values for */ /* the respective upper and lower bounds. */ /* 1. For IND(J)=1, require X(J) .ge. BL(J). */ /* 2. For IND(J)=2, require X(J) .le. BU(J). */ /* 3. For IND(J)=3, require X(J) .ge. BL(J) and */ /* X(J) .le. BU(J). */ /* 4. For IND(J)=4, no bounds on X(J) are required. */ /* The values of BL(*),BL(*) are modified by the subprogram. Values */ /* other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 */ /* (upper and lower bounds) the condition BL(J) .gt. BU(J) is an */ /* error. */ /* ------- */ /* IOPT(*) */ /* ------- */ /* This is the array where the user can specify nonstandard options */ /* for DBOLSM. Most of the time this feature can be ignored by */ /* setting the input value IOPT(1)=99. Occasionally users may have */ /* needs that require use of the following subprogram options. For */ /* details about how to use the options see below: IOPT(*) CONTENTS. */ /* Option Number Brief Statement of Purpose */ /* ----- ------ ----- --------- -- ------- */ /* 1 Move the IOPT(*) processing pointer. */ /* 2 Change rank determination tolerance. */ /* 3 Change blow-up factor that determines the */ /* size of variables being dropped from active */ /* status. */ /* 4 Reset the maximum number of iterations to use */ /* in solving the problem. */ /* 5 The data matrix is triangularized before the */ /* problem is solved whenever (NCOLS/MINPUT) .lt. */ /* FAC. Change the value of FAC. */ /* 6 Redefine the weighting matrix used for */ /* linear independence checking. */ /* 7 Debug output is desired. */ /* 99 No more options to change. */ /* ---- */ /* X(*) */ /* ---- */ /* This array is used to pass data associated with options 1,2,3 and */ /* 5. Ignore this input parameter if none of these options are used. */ /* Otherwise see below: IOPT(*) CONTENTS. */ /* ---------------- */ /* IBASIS(*),IBB(*) */ /* ---------------- */ /* These arrays must be initialized by the user. The values */ /* IBASIS(J)=J, J=1,...,NCOLS */ /* IBB(J) =1, J=1,...,NCOLS */ /* are appropriate except when using nonstandard features. */ /* ------ */ /* SCL(*) */ /* ------ */ /* This is the array of scaling factors to use on the columns of the */ /* matrix E. These values must be defined by the user. To suppress */ /* any column scaling set SCL(J)=1.0, J=1,...,NCOLS. */ /* OUTPUT */ /* ------ */ /* ---------- */ /* X(*),RNORM */ /* ---------- */ /* The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) */ /* for the constrained least squares problem. The value RNORM is the */ /* minimum residual vector length. */ /* ---- */ /* MODE */ /* ---- */ /* The sign of mode determines whether the subprogram has completed */ /* normally, or encountered an error condition or abnormal status. */ /* A value of MODE .ge. 0 signifies that the subprogram has completed */ /* normally. The value of MODE (.ge. 0) is the number of variables */ /* in an active status: not at a bound nor at the value ZERO, for */ /* the case of free variables. A negative value of MODE will be one */ /* of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond */ /* to an abnormal completion of the subprogram. To understand the */ /* abnormal completion codes see below: ERROR MESSAGES for DBOLSM */ /* An approximate solution will be returned to the user only when */ /* maximum iterations is reached, MODE=-22. */ /* ----------- */ /* RW(*),WW(*) */ /* ----------- */ /* These are working arrays each with NCOLS entries. The array RW(*) */ /* contains the working (scaled, nonactive) solution values. The */ /* array WW(*) contains the working (scaled, active) gradient vector */ /* values. */ /* ---------------- */ /* IBASIS(*),IBB(*) */ /* ---------------- */ /* These arrays contain information about the status of the solution */ /* when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the */ /* nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are */ /* the active variables. The value (IBB(J)-1) is the number of times */ /* variable J was reflected from its upper bound. (Normally the user */ /* can ignore these parameters.) */ /* IOPT(*) CONTENTS */ /* ------- -------- */ /* The option array allows a user to modify internal variables in */ /* the subprogram without recompiling the source code. A central */ /* goal of the initial software design was to do a good job for most */ /* people. Thus the use of options will be restricted to a select */ /* group of users. The processing of the option array proceeds as */ /* follows: a pointer, here called LP, is initially set to the value */ /* 1. The value is updated as the options are processed. At the */ /* pointer position the option number is extracted and used for */ /* locating other information that allows for options to be changed. */ /* The portion of the array IOPT(*) that is used for each option is */ /* fixed; the user and the subprogram both know how many locations */ /* are needed for each option. A great deal of error checking is */ /* done by the subprogram on the contents of the option array. */ /* Nevertheless it is still possible to give the subprogram optional */ /* input that is meaningless. For example, some of the options use */ /* the location X(NCOLS+IOFF) for passing data. The user must manage */ /* the allocation of these locations when more than one piece of */ /* option data is being passed to the subprogram. */ /* 1 */ /* - */ /* Move the processing pointer (either forward or backward) to the */ /* location IOPT(LP+1). The processing pointer is moved to location */ /* LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over */ /* locations 3,...,NCOLS+2 of IOPT(*), */ /* IOPT(1)=1 */ /* IOPT(2)=NCOLS+3 */ /* (IOPT(I), I=3,...,NCOLS+2 are not defined here.) */ /* IOPT(NCOLS+3)=99 */ /* CALL DBOLSM */ /* CAUTION: Misuse of this option can yield some very hard-to-find */ /* bugs. Use it with care. */ /* 2 */ /* - */ /* The algorithm that solves the bounded least squares problem */ /* iteratively drops columns from the active set. This has the */ /* effect of joining a new column vector to the QR factorization of */ /* the rectangular matrix consisting of the partially triangularized */ /* nonactive columns. After triangularizing this matrix a test is */ /* made on the size of the pivot element. The column vector is */ /* rejected as dependent if the magnitude of the pivot element is */ /* .le. TOL* magnitude of the column in components strictly above */ /* the pivot element. Nominally the value of this (rank) tolerance */ /* is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for */ /* example, */ /* X(NCOLS+1)=TOL */ /* IOPT(1)=2 */ /* IOPT(2)=1 */ /* IOPT(3)=99 */ /* CALL DBOLSM */ /* Generally, if LP is the processing pointer for IOPT(*), */ /* X(NCOLS+IOFF)=TOL */ /* IOPT(LP)=2 */ /* IOPT(LP+1)=IOFF */ /* . */ /* CALL DBOLSM */ /* The required length of IOPT(*) is increased by 2 if option 2 is */ /* used; The required length of X(*) is increased by 1. A value of */ /* IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a */ /* warning message; it is not considered an error. */ /* 3 */ /* - */ /* A solution component is left active (not used) if, roughly */ /* speaking, it seems too large. Mathematically the new component is */ /* left active if the magnitude is .ge.((vector norm of F)/(matrix */ /* norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). */ /* To change only the value of BLOWUP, for example, */ /* X(NCOLS+2)=BLOWUP */ /* IOPT(1)=3 */ /* IOPT(2)=2 */ /* IOPT(3)=99 */ /* CALL DBOLSM */ /* Generally, if LP is the processing pointer for IOPT(*), */ /* X(NCOLS+IOFF)=BLOWUP */ /* IOPT(LP)=3 */ /* IOPT(LP+1)=IOFF */ /* . */ /* CALL DBOLSM */ /* The required length of IOPT(*) is increased by 2 if option 3 is */ /* used; the required length of X(*) is increased by 1. A value of */ /* IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. */ /* 4 */ /* - */ /* Normally the algorithm for solving the bounded least squares */ /* problem requires between NCOLS/3 and NCOLS drop-add steps to */ /* converge. (this remark is based on examining a small number of */ /* test cases.) The amount of arithmetic for such problems is */ /* typically about twice that required for linear least squares if */ /* there are no bounds and if plane rotations are used in the */ /* solution method. Convergence of the algorithm, while */ /* mathematically certain, can be much slower than indicated. To */ /* avoid this potential but unlikely event ITMAX drop-add steps are */ /* permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the */ /* value of ITMAX, for example, */ /* IOPT(1)=4 */ /* IOPT(2)=ITMAX */ /* IOPT(3)=99 */ /* CALL DBOLSM */ /* Generally, if LP is the processing pointer for IOPT(*), */ /* IOPT(LP)=4 */ /* IOPT(LP+1)=ITMAX */ /* . */ /* CALL DBOLSM */ /* The value of ITMAX must be .gt. 0. Other values are errors. Use */ /* of this option increases the required length of IOPT(*) by 2. */ /* 5 */ /* - */ /* For purposes of increased efficiency the MINPUT by NCOLS+1 data */ /* matrix [E:F] is triangularized as a first step whenever MINPUT */ /* satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the */ /* value of FAC, */ /* X(NCOLS+3)=FAC */ /* IOPT(1)=5 */ /* IOPT(2)=3 */ /* IOPT(3)=99 */ /* CALL DBOLSM */ /* Generally, if LP is the processing pointer for IOPT(*), */ /* X(NCOLS+IOFF)=FAC */ /* IOPT(LP)=5 */ /* IOPT(LP+1)=IOFF */ /* . */ /* CALL DBOLSM */ /* The value of FAC must be nonnegative. Other values are errors. */ /* Resetting FAC=0.0 suppresses the initial triangularization step. */ /* Use of this option increases the required length of IOPT(*) by 2; */ /* The required length of of X(*) is increased by 1. */ /* 6 */ /* - */ /* The norm used in testing the magnitudes of the pivot element */ /* compared to the mass of the column above the pivot line can be */ /* changed. The type of change that this option allows is to weight */ /* the components with an index larger than MVAL by the parameter */ /* WT. Normally MVAL=0 and WT=1. To change both the values MVAL and */ /* WT, where LP is the processing pointer for IOPT(*), */ /* X(NCOLS+IOFF)=WT */ /* IOPT(LP)=6 */ /* IOPT(LP+1)=IOFF */ /* IOPT(LP+2)=MVAL */ /* Use of this option increases the required length of IOPT(*) by 3. */ /* The length of X(*) is increased by 1. Values of MVAL must be */ /* nonnegative and not greater than MINPUT. Other values are errors. */ /* The value of WT must be positive. Any other value is an error. If */ /* either error condition is present a message will be printed. */ /* 7 */ /* - */ /* Debug output, showing the detailed add-drop steps for the */ /* constrained least squares problem, is desired. This option is */ /* intended to be used to locate suspected bugs. */ /* 99 */ /* -- */ /* There are no more options to change. */ /* The values for options are 1,...,7,99, and are the only ones */ /* permitted. Other values are errors. Options -99,-1,...,-7 mean */ /* that the repective options 99,1,...,7 are left at their default */ /* values. An example is the option to modify the (rank) tolerance: */ /* X(NCOLS+1)=TOL */ /* IOPT(1)=-2 */ /* IOPT(2)=1 */ /* IOPT(3)=99 */ /* Error Messages for DBOLSM */ /* ----- -------- --- --------- */ /* -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST */ /* SQUARES PROBLEM. */ /* -23 THE OPTION NUMBER = ... IS NOT DEFINED. */ /* -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE */ /* FOR OPTION NUMBER 2. */ /* -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN */ /* MACHINE PRECISION = .... */ /* -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */ /* FOR OPTION NUMBER 3. */ /* -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES */ /* MUST BE POSITIVE. NOW = .... */ /* -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. */ /* -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */ /* FOR OPTION NUMBER 5. */ /* -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS */ /* PERFORMED MUST BE NONNEGATIVE. NOW = .... */ /* -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. */ /* -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. */ /* -33 THE ROW DIMENSION OF W(,) = ... MUST BE .GE. THE NUMBER OF */ /* ROWS = .... */ /* -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. */ /* -35 FOR J = ... THE LOWER BOUND = ... IS .GT. THE UPPER BOUND = */ /* .... */ /* -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS */ /* = .... */ /* -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE */ /* POSITIVE. NOW = .... */ /* -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN */ /* 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. */ /* ***SEE ALSO DBOCLS, DBOLS */ /* ***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DMOUT, DNRM2, DROT, */ /* DROTG, DSWAP, DVOUT, IVOUT, XERMSG */ /* ***REVISION HISTORY (YYMMDD) */ /* 821220 DATE WRITTEN */ /* 891214 Prologue converted to Version 4.0 format. (BAB) */ /* 900328 Added TYPE section. (WRB) */ /* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */ /* 920422 Fixed usage of MINPUT. (WRB) */ /* 901009 Editorial changes, code now reads from top to bottom. (RWC) */ /* ***END PROLOGUE DBOLSM */ /* PURPOSE */ /* ------- */ /* THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED */ /* LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: */ /* SOLVE E*X = F (LEAST SQUARES SENSE) */ /* WITH BOUNDS ON SELECTED X VALUES. */ /* TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN */ /* EDITING AT THE CARD 'C++'. */ /* CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS */ /* /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, */ /* /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, */ /* /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, */ /* /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, */ /* /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, */ /* /REAL / TO /DOUBLE PRECISION/. */ /* ++ */ /* ***FIRST EXECUTABLE STATEMENT DBOLSM */ /* Verify that the problem dimensions are defined properly. */ /* Parameter adjustments */ w_dim1 = *mdw; w_offset = 1 + w_dim1; w -= w_offset; --bl; --bu; --ind; --iopt; --x; --rw; --ww; --scl; --ibasis; --ibb; /* Function Body */ if (*minput <= 0) { s_wsfi(&io___2); do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 21, a__1[0] = "THE NUMBER OF ROWS = "; i__1[1] = 8, a__1[1] = xern1; i__1[2] = 18, a__1[2] = " MUST BE POSITIVE."; s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)47); xermsg_("SLATEC", "DBOLSM", ch__1, &c__31, &c__1, (ftnlen)6, (ftnlen) 6, (ftnlen)47); *mode = -31; return 0; } if (*ncols <= 0) { s_wsfi(&io___3); do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 24, a__1[0] = "THE NUMBER OF COLUMNS = "; i__1[1] = 8, a__1[1] = xern1; i__1[2] = 18, a__1[2] = " MUST BE POSITIVE."; s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)50); xermsg_("SLATEC", "DBOLSM", ch__2, &c__32, &c__1, (ftnlen)6, (ftnlen) 6, (ftnlen)50); *mode = -32; return 0; } if (*mdw < *minput) { s_wsfi(&io___4); do_fio(&c__1, (char *)&(*mdw), (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___6); do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__2[0] = 28, a__2[0] = "THE ROW DIMENSION OF W(,) = "; i__2[1] = 8, a__2[1] = xern1; i__2[2] = 35, a__2[2] = " MUST BE .GE. THE NUMBER OF ROWS = "; i__2[3] = 8, a__2[3] = xern2; s_cat(ch__3, a__2, i__2, &c__4, (ftnlen)79); xermsg_("SLATEC", "DBOLSM", ch__3, &c__33, &c__1, (ftnlen)6, (ftnlen) 6, (ftnlen)79); *mode = -33; return 0; } /* Verify that bound information is correct. */ i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (ind[j] < 1 || ind[j] > 4) { s_wsfi(&io___8); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___9); do_fio(&c__1, (char *)&ind[j], (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 8, a__1[0] = "FOR J = "; i__1[1] = 8, a__1[1] = xern1; i__1[2] = 37, a__1[2] = " THE CONSTRAINT INDICATOR MUST BE 1-4"; s_cat(ch__4, a__1, i__1, &c__3, (ftnlen)53); xermsg_("SLATEC", "DBOLSM", ch__4, &c__34, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)53); *mode = -34; return 0; } /* L10: */ } i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (ind[j] == 3) { if (bu[j] < bl[j]) { s_wsfi(&io___10); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___12); do_fio(&c__1, (char *)&bl[j], (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___14); do_fio(&c__1, (char *)&bu[j], (ftnlen)sizeof(doublereal)); e_wsfi(); /* Writing concatenation */ i__4[0] = 8, a__3[0] = "FOR J = "; i__4[1] = 8, a__3[1] = xern1; i__4[2] = 19, a__3[2] = " THE LOWER BOUND = "; i__4[3] = 16, a__3[3] = xern3; i__4[4] = 27, a__3[4] = " IS .GT. THE UPPER BOUND = "; i__4[5] = 16, a__3[5] = xern4; s_cat(ch__5, a__3, i__4, &c__6, (ftnlen)94); xermsg_("SLATEC", "DBOLSM", ch__5, &c__35, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)94); *mode = -35; return 0; } } /* L20: */ } /* Check that permutation and polarity arrays have been set. */ i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (ibasis[j] < 1 || ibasis[j] > *ncols) { s_wsfi(&io___15); do_fio(&c__1, (char *)&ibasis[j], (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___16); do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__2[0] = 29, a__2[0] = "THE INPUT ORDER OF COLUMNS = "; i__2[1] = 8, a__2[1] = xern1; i__2[2] = 30, a__2[2] = " IS NOT BETWEEN 1 AND NCOLS = "; i__2[3] = 8, a__2[3] = xern2; s_cat(ch__6, a__2, i__2, &c__4, (ftnlen)75); xermsg_("SLATEC", "DBOLSM", ch__6, &c__36, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)75); *mode = -36; return 0; } if (ibb[j] <= 0) { s_wsfi(&io___17); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___18); do_fio(&c__1, (char *)&ibb[j], (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__2[0] = 41, a__2[0] = "THE BOUND POLARITY FLAG IN COMPONENT J " "= "; i__2[1] = 8, a__2[1] = xern1; i__2[2] = 26, a__2[2] = " MUST BE POSITIVE.$$NOW = "; i__2[3] = 8, a__2[3] = xern2; s_cat(ch__7, a__2, i__2, &c__4, (ftnlen)83); xermsg_("SLATEC", "DBOLSM", ch__7, &c__37, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)83); *mode = -37; return 0; } /* L30: */ } /* Process the option array. */ fac = .75; tolind = sqrt(d1mach_(&c__4)); tolsze = sqrt(d1mach_(&c__4)); itmax = max(*minput,*ncols) * 5; wt = 1.; mval = 0; iprint = 0; /* Changes to some parameters can occur through the option array, */ /* IOPT(*). Process this array looking carefully for input data */ /* errors. */ lp = 0; lds = 0; /* Test for no more options. */ L590: lp += lds; ip = iopt[lp + 1]; jp = abs(ip); if (ip == 99) { goto L470; } else if (jp == 99) { lds = 1; } else if (jp == 1) { /* Move the IOPT(*) processing pointer. */ if (ip > 0) { lp = iopt[lp + 2] - 1; lds = 0; } else { lds = 2; } } else if (jp == 2) { /* Change tolerance for rank determination. */ if (ip > 0) { ioff = iopt[lp + 2]; if (ioff <= 0) { s_wsfi(&io___31); do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___32); do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__5[0] = 13, a__4[0] = "THE OFFSET = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = "; i__5[3] = 8, a__4[3] = xern2; i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER" " 2."; s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92); xermsg_("SLATEC", "DBOLSM", ch__8, &c__24, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)92); *mode = -24; return 0; } tolind = x[*ncols + ioff]; if (tolind < d1mach_(&c__4)) { s_wsfi(&io___33); do_fio(&c__1, (char *)&tolind, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___34); d__1 = d1mach_(&c__4); do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal)); e_wsfi(); /* Writing concatenation */ i__2[0] = 39, a__2[0] = "THE TOLERANCE FOR RANK DETERMINATIO" "N = "; i__2[1] = 16, a__2[1] = xern3; i__2[2] = 34, a__2[2] = " IS LESS THAN MACHINE PRECISION = "; i__2[3] = 16, a__2[3] = xern4; s_cat(ch__9, a__2, i__2, &c__4, (ftnlen)105); xermsg_("SLATEC", "DBOLSM", ch__9, &c__25, &c__0, (ftnlen)6, ( ftnlen)6, (ftnlen)105); *mode = -25; } } lds = 2; } else if (jp == 3) { /* Change blowup factor for allowing variables to become */ /* inactive. */ if (ip > 0) { ioff = iopt[lp + 2]; if (ioff <= 0) { s_wsfi(&io___35); do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___36); do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__5[0] = 13, a__4[0] = "THE OFFSET = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = "; i__5[3] = 8, a__4[3] = xern2; i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER" " 3."; s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92); xermsg_("SLATEC", "DBOLSM", ch__8, &c__26, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)92); *mode = -26; return 0; } tolsze = x[*ncols + ioff]; if (tolsze <= 0.) { s_wsfi(&io___37); do_fio(&c__1, (char *)&tolsze, (ftnlen)sizeof(doublereal)); e_wsfi(); /* Writing concatenation */ i__6[0] = 86, a__5[0] = "THE RECIPROCAL OF THE BLOW-UP FACTO" "R FOR REJECTING VARIABLES MUST BE POSITIVE.$$NOW = "; i__6[1] = 16, a__5[1] = xern3; s_cat(ch__10, a__5, i__6, &c__2, (ftnlen)102); xermsg_("SLATEC", "DBOLSM", ch__10, &c__27, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)102); *mode = -27; return 0; } } lds = 2; } else if (jp == 4) { /* Change the maximum number of iterations allowed. */ if (ip > 0) { itmax = iopt[lp + 2]; if (itmax <= 0) { s_wsfi(&io___38); do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 35, a__1[0] = "THE MAXIMUM NUMBER OF ITERATIONS = "; i__1[1] = 8, a__1[1] = xern1; i__1[2] = 18, a__1[2] = " MUST BE POSITIVE."; s_cat(ch__11, a__1, i__1, &c__3, (ftnlen)61); xermsg_("SLATEC", "DBOLSM", ch__11, &c__28, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)61); *mode = -28; return 0; } } lds = 2; } else if (jp == 5) { /* Change the factor for pretriangularizing the data matrix. */ if (ip > 0) { ioff = iopt[lp + 2]; if (ioff <= 0) { s_wsfi(&io___39); do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___40); do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__5[0] = 13, a__4[0] = "THE OFFSET = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = "; i__5[3] = 8, a__4[3] = xern2; i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER" " 5."; s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92); xermsg_("SLATEC", "DBOLSM", ch__8, &c__29, &c__1, (ftnlen)6, ( ftnlen)6, (ftnlen)92); *mode = -29; return 0; } fac = x[*ncols + ioff]; if (fac < 0.) { s_wsfi(&io___41); do_fio(&c__1, (char *)&fac, (ftnlen)sizeof(doublereal)); e_wsfi(); /* Writing concatenation */ i__6[0] = 94, a__5[0] = "THE FACTOR (NCOLS/MINPUT) WHERE PRE" "-TRIANGULARIZING IS PERFORMED MUST BE NON-NEGATIVE.$" "$NOW = "; i__6[1] = 16, a__5[1] = xern3; s_cat(ch__12, a__5, i__6, &c__2, (ftnlen)110); xermsg_("SLATEC", "DBOLSM", ch__12, &c__30, &c__0, (ftnlen)6, (ftnlen)6, (ftnlen)110); *mode = -30; return 0; } } lds = 2; } else if (jp == 6) { /* Change the weighting factor (from 1.0) to apply to components */ /* numbered .gt. MVAL (initially set to 1.) This trick is needed */ /* for applications of this subprogram to the heavily weighted */ /* least squares problem that come from equality constraints. */ if (ip > 0) { ioff = iopt[lp + 2]; mval = iopt[lp + 3]; wt = x[*ncols + ioff]; } if (mval < 0 || mval > *minput || wt <= 0.) { s_wsfi(&io___42); do_fio(&c__1, (char *)&mval, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___43); do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___44); do_fio(&c__1, (char *)&wt, (ftnlen)sizeof(doublereal)); e_wsfi(); /* Writing concatenation */ i__7[0] = 38, a__6[0] = "THE ROW SEPARATOR TO APPLY WEIGHTING ("; i__7[1] = 8, a__6[1] = xern1; i__7[2] = 34, a__6[2] = ") MUST LIE BETWEEN 0 AND MINPUT = "; i__7[3] = 8, a__6[3] = xern2; i__7[4] = 12, a__6[4] = ".$$WEIGHT = "; i__7[5] = 16, a__6[5] = xern3; i__7[6] = 18, a__6[6] = " MUST BE POSITIVE."; s_cat(ch__13, a__6, i__7, &c__7, (ftnlen)134); xermsg_("SLATEC", "DBOLSM", ch__13, &c__38, &c__0, (ftnlen)6, ( ftnlen)6, (ftnlen)134); *mode = -38; return 0; } lds = 3; } else if (jp == 7) { /* Turn on debug output. */ if (ip > 0) { iprint = 1; } lds = 2; } else { s_wsfi(&io___45); do_fio(&c__1, (char *)&ip, (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 20, a__1[0] = "THE OPTION NUMBER = "; i__1[1] = 8, a__1[1] = xern1; i__1[2] = 16, a__1[2] = " IS NOT DEFINED."; s_cat(ch__14, a__1, i__1, &c__3, (ftnlen)44); xermsg_("SLATEC", "DBOLSM", ch__14, &c__23, &c__1, (ftnlen)6, (ftnlen) 6, (ftnlen)44); *mode = -23; return 0; } goto L590; /* Pretriangularize rectangular arrays of certain sizes for */ /* increased efficiency. */ L470: if (fac * *minput > (doublereal) (*ncols)) { i__3 = *ncols + 1; for (j = 1; j <= i__3; ++j) { i__8 = j + mval + 1; for (i__ = *minput; i__ >= i__8; --i__) { drotg_(&w[i__ - 1 + j * w_dim1], &w[i__ + j * w_dim1], &sc, & ss); w[i__ + j * w_dim1] = 0.; i__9 = *ncols - j + 1; drot_(&i__9, &w[i__ - 1 + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) * w_dim1], mdw, &sc, &ss); /* L480: */ } /* L490: */ } mrows = *ncols + mval + 1; } else { mrows = *minput; } /* Set the X(*) array to zero so all components are defined. */ dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1); /* The arrays IBASIS(*) and IBB(*) are initialized by the calling */ /* program and the column scaling is defined in the calling program. */ /* 'BIG' is plus infinity on this machine. */ big = d1mach_(&c__2); i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (ind[j] == 1) { bu[j] = big; } else if (ind[j] == 2) { bl[j] = -big; } else if (ind[j] == 4) { bl[j] = -big; bu[j] = big; } /* L550: */ } i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (bl[j] <= 0. && 0. <= bu[j] && (d__1 = bu[j], abs(d__1)) < (d__2 = bl[j], abs(d__2)) || bu[j] < 0.) { t = bu[j]; bu[j] = -bl[j]; bl[j] = -t; scl[j] = -scl[j]; i__8 = mrows; for (i__ = 1; i__ <= i__8; ++i__) { w[i__ + j * w_dim1] = -w[i__ + j * w_dim1]; /* L560: */ } } /* Indices in set T(=TIGHT) are denoted by negative values */ /* of IBASIS(*). */ if (bl[j] >= 0.) { ibasis[j] = -ibasis[j]; t = -bl[j]; bu[j] += t; daxpy_(&mrows, &t, &w[j * w_dim1 + 1], &c__1, &w[(*ncols + 1) * w_dim1 + 1], &c__1); } /* L570: */ } nsetb = 0; iter = 0; if (iprint > 0) { i__3 = *ncols + 1; dmout_(&mrows, &i__3, mdw, &w[w_offset], "(' PRETRI. INPUT MATRIX')", &c_n4, (ftnlen)25); dvout_(ncols, &bl[1], "(' LOWER BOUNDS')", &c_n4, (ftnlen)17); dvout_(ncols, &bu[1], "(' UPPER BOUNDS')", &c_n4, (ftnlen)17); } L580: ++iter; if (iter > itmax) { s_wsfi(&io___54); do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 18, a__1[0] = "MORE THAN ITMAX = "; i__1[1] = 8, a__1[1] = xern1; i__1[2] = 50, a__1[2] = " ITERATIONS SOLVING BOUNDED LEAST SQUARES P" "ROBLEM."; s_cat(ch__15, a__1, i__1, &c__3, (ftnlen)76); xermsg_("SLATEC", "DBOLSM", ch__15, &c__22, &c__1, (ftnlen)6, (ftnlen) 6, (ftnlen)76); *mode = -22; /* Rescale and translate variables. */ igopr = 1; goto L130; } /* Find a variable to become non-active. */ /* T */ /* Compute (negative) of gradient vector, W = E *(F-E*X). */ dcopy_(ncols, &c_b185, &c__0, &ww[1], &c__1); i__3 = *ncols; for (j = nsetb + 1; j <= i__3; ++j) { jcol = (i__8 = ibasis[j], abs(i__8)); i__8 = mrows - nsetb; /* Computing MIN */ i__9 = nsetb + 1; /* Computing MIN */ i__10 = nsetb + 1; ww[j] = ddot_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1, &w[min( i__10,mrows) + (*ncols + 1) * w_dim1], &c__1) * (d__1 = scl[ jcol], abs(d__1)); /* L200: */ } if (iprint > 0) { dvout_(ncols, &ww[1], "(' GRADIENT VALUES')", &c_n4, (ftnlen)20); ivout_(ncols, &ibasis[1], "(' INTERNAL VARIABLE ORDER')", &c_n4, ( ftnlen)28); ivout_(ncols, &ibb[1], "(' BOUND POLARITY')", &c_n4, (ftnlen)19); } /* If active set = number of total rows, quit. */ L210: if (nsetb == mrows) { found = FALSE_; goto L120; } /* Choose an extremal component of gradient vector for a candidate */ /* to become non-active. */ wlarge = -big; wmag = -big; i__3 = *ncols; for (j = nsetb + 1; j <= i__3; ++j) { t = ww[j]; if (t == big) { goto L220; } itemp = ibasis[j]; jcol = abs(itemp); i__8 = mval - nsetb; /* Computing MIN */ i__9 = nsetb + 1; t1 = dnrm2_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1); if (itemp < 0) { if (ibb[jcol] % 2 == 0) { t = -t; } if (t < 0.) { goto L220; } if (mval > nsetb) { t = t1; } if (t > wlarge) { wlarge = t; jlarge = j; } } else { if (mval > nsetb) { t = t1; } if (abs(t) > wmag) { wmag = abs(t); jmag = j; } } L220: ; } /* Choose magnitude of largest component of gradient for candidate. */ jbig = 0; wbig = 0.; if (wlarge > 0.) { jbig = jlarge; wbig = wlarge; } if (wmag >= wbig) { jbig = jmag; wbig = wmag; } if (jbig == 0) { found = FALSE_; if (iprint > 0) { ivout_(&c__0, &i__, "(' FOUND NO VARIABLE TO ENTER')", &c_n4, ( ftnlen)31); } goto L120; } /* See if the incoming column is sufficiently independent. This */ /* test is made before an elimination is performed. */ if (iprint > 0) { ivout_(&c__1, &jbig, "(' TRY TO BRING IN THIS COL.')", &c_n4, (ftnlen) 30); } if (mval <= nsetb) { cl1 = dnrm2_(&mval, &w[jbig * w_dim1 + 1], &c__1); i__3 = nsetb - mval; /* Computing MIN */ i__8 = mval + 1; cl2 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], & c__1); i__3 = mrows - nsetb; /* Computing MIN */ i__8 = nsetb + 1; cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], & c__1); drotg_(&cl1, &cl2, &sc, &ss); colabv = abs(cl1); colblo = cl3; } else { cl1 = dnrm2_(&nsetb, &w[jbig * w_dim1 + 1], &c__1); i__3 = mval - nsetb; /* Computing MIN */ i__8 = nsetb + 1; cl2 = dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &c__1); i__3 = mrows - mval; /* Computing MIN */ i__8 = mval + 1; cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], & c__1); colabv = cl1; drotg_(&cl2, &cl3, &sc, &ss); colblo = abs(cl2); } if (colblo <= tolind * colabv) { ww[jbig] = big; if (iprint > 0) { ivout_(&c__0, &i__, "(' VARIABLE IS DEPENDENT, NOT USED.')", & c_n4, (ftnlen)37); } goto L210; } /* Swap matrix columns NSETB+1 and JBIG, plus pointer information, */ /* and gradient values. */ ++nsetb; if (nsetb != jbig) { dswap_(&mrows, &w[nsetb * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], & c__1); dswap_(&c__1, &ww[nsetb], &c__1, &ww[jbig], &c__1); itemp = ibasis[nsetb]; ibasis[nsetb] = ibasis[jbig]; ibasis[jbig] = itemp; } /* Eliminate entries below the pivot line in column NSETB. */ if (mrows > nsetb) { i__3 = nsetb + 1; for (i__ = mrows; i__ >= i__3; --i__) { if (i__ == mval + 1) { goto L230; } drotg_(&w[i__ - 1 + nsetb * w_dim1], &w[i__ + nsetb * w_dim1], & sc, &ss); w[i__ + nsetb * w_dim1] = 0.; i__8 = *ncols - nsetb + 1; drot_(&i__8, &w[i__ - 1 + (nsetb + 1) * w_dim1], mdw, &w[i__ + ( nsetb + 1) * w_dim1], mdw, &sc, &ss); L230: ; } if (mval >= nsetb && mval < mrows) { drotg_(&w[nsetb + nsetb * w_dim1], &w[mval + 1 + nsetb * w_dim1], &sc, &ss); w[mval + 1 + nsetb * w_dim1] = 0.; i__3 = *ncols - nsetb + 1; drot_(&i__3, &w[nsetb + (nsetb + 1) * w_dim1], mdw, &w[mval + 1 + (nsetb + 1) * w_dim1], mdw, &sc, &ss); } } if (w[nsetb + nsetb * w_dim1] == 0.) { ww[nsetb] = big; --nsetb; if (iprint > 0) { ivout_(&c__0, &i__, "(' PIVOT IS ZERO, NOT USED.')", &c_n4, ( ftnlen)29); } goto L210; } /* Check that new variable is moving in the right direction. */ itemp = ibasis[nsetb]; jcol = abs(itemp); xnew = w[nsetb + (*ncols + 1) * w_dim1] / w[nsetb + nsetb * w_dim1] / ( d__1 = scl[jcol], abs(d__1)); if (itemp < 0) { /* IF(WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) exit(quit) */ /* IF(WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) exit(quit) */ if (ww[nsetb] >= 0. && xnew <= 0. || ww[nsetb] <= 0. && xnew >= 0.) { goto L240; } } found = TRUE_; goto L120; L240: ww[nsetb] = big; --nsetb; if (iprint > 0) { ivout_(&c__0, &i__, "(' VARIABLE HAS BAD DIRECTION, NOT USED.')", & c_n4, (ftnlen)42); } goto L210; /* Solve the triangular system. */ L270: dcopy_(&nsetb, &w[(*ncols + 1) * w_dim1 + 1], &c__1, &rw[1], &c__1); for (j = nsetb; j >= 1; --j) { rw[j] /= w[j + j * w_dim1]; jcol = (i__3 = ibasis[j], abs(i__3)); t = rw[j]; if (ibb[jcol] % 2 == 0) { rw[j] = -rw[j]; } i__3 = j - 1; d__1 = -t; daxpy_(&i__3, &d__1, &w[j * w_dim1 + 1], &c__1, &rw[1], &c__1); rw[j] /= (d__1 = scl[jcol], abs(d__1)); /* L280: */ } if (iprint > 0) { dvout_(&nsetb, &rw[1], "(' SOLN. VALUES')", &c_n4, (ftnlen)17); ivout_(&nsetb, &ibasis[1], "(' COLS. USED')", &c_n4, (ftnlen)15); } if (lgopr == 2) { dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1); i__3 = nsetb; for (j = 1; j <= i__3; ++j) { itemp = ibasis[j]; jcol = abs(itemp); if (itemp < 0) { bou = 0.; } else { bou = bl[jcol]; } if (-bou != big) { bou /= (d__1 = scl[jcol], abs(d__1)); } if (x[j] <= bou) { jdrop1 = j; goto L340; } bou = bu[jcol]; if (bou != big) { bou /= (d__1 = scl[jcol], abs(d__1)); } if (x[j] >= bou) { jdrop2 = j; goto L340; } /* L450: */ } goto L340; } /* See if the unconstrained solution (obtained by solving the */ /* triangular system) satisfies the problem bounds. */ alpha = 2.; beta = 2.; x[nsetb] = 0.; i__3 = nsetb; for (j = 1; j <= i__3; ++j) { itemp = ibasis[j]; jcol = abs(itemp); t1 = 2.; t2 = 2.; if (itemp < 0) { bou = 0.; } else { bou = bl[jcol]; } if (-bou != big) { bou /= (d__1 = scl[jcol], abs(d__1)); } if (rw[j] <= bou) { t1 = (x[j] - bou) / (x[j] - rw[j]); } bou = bu[jcol]; if (bou != big) { bou /= (d__1 = scl[jcol], abs(d__1)); } if (rw[j] >= bou) { t2 = (bou - x[j]) / (rw[j] - x[j]); } /* If not, then compute a step length so that the variables remain */ /* feasible. */ if (t1 < alpha) { alpha = t1; jdrop1 = j; } if (t2 < beta) { beta = t2; jdrop2 = j; } /* L310: */ } constr = alpha < 2. || beta < 2.; if (! constr) { /* Accept the candidate because it satisfies the stated bounds */ /* on the variables. */ dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1); goto L580; } /* Take a step that is as large as possible with all variables */ /* remaining feasible. */ i__3 = nsetb; for (j = 1; j <= i__3; ++j) { x[j] += min(alpha,beta) * (rw[j] - x[j]); /* L330: */ } if (alpha <= beta) { jdrop2 = 0; } else { jdrop1 = 0; } L340: if (jdrop1 + jdrop2 <= 0 || nsetb <= 0) { goto L580; } /* L350: */ jdrop = jdrop1 + jdrop2; itemp = ibasis[jdrop]; jcol = abs(itemp); if (jdrop2 > 0) { /* Variable is at an upper bound. Subtract multiple of this */ /* column from right hand side. */ t = bu[jcol]; if (itemp > 0) { bu[jcol] = t - bl[jcol]; bl[jcol] = -t; itemp = -itemp; scl[jcol] = -scl[jcol]; i__3 = jdrop; for (i__ = 1; i__ <= i__3; ++i__) { w[i__ + jdrop * w_dim1] = -w[i__ + jdrop * w_dim1]; /* L360: */ } } else { ++ibb[jcol]; if (ibb[jcol] % 2 == 0) { t = -t; } } /* Variable is at a lower bound. */ } else { if ((doublereal) itemp < 0.) { t = 0.; } else { t = -bl[jcol]; bu[jcol] += t; itemp = -itemp; } } daxpy_(&jdrop, &t, &w[jdrop * w_dim1 + 1], &c__1, &w[(*ncols + 1) * w_dim1 + 1], &c__1); /* Move certain columns left to achieve upper Hessenberg form. */ dcopy_(&jdrop, &w[jdrop * w_dim1 + 1], &c__1, &rw[1], &c__1); i__3 = nsetb; for (j = jdrop + 1; j <= i__3; ++j) { ibasis[j - 1] = ibasis[j]; x[j - 1] = x[j]; dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[(j - 1) * w_dim1 + 1], &c__1) ; /* L370: */ } ibasis[nsetb] = itemp; w[nsetb * w_dim1 + 1] = 0.; i__3 = mrows - jdrop; dcopy_(&i__3, &w[nsetb * w_dim1 + 1], &c__0, &w[jdrop + 1 + nsetb * w_dim1], &c__1); dcopy_(&jdrop, &rw[1], &c__1, &w[nsetb * w_dim1 + 1], &c__1); /* Transform the matrix from upper Hessenberg form to upper */ /* triangular form. */ --nsetb; i__3 = nsetb; for (i__ = jdrop; i__ <= i__3; ++i__) { /* Look for small pivots and avoid mixing weighted and */ /* nonweighted rows. */ if (i__ == mval) { t = 0.; i__8 = nsetb; for (j = i__; j <= i__8; ++j) { jcol = (i__9 = ibasis[j], abs(i__9)); t1 = (d__1 = w[i__ + j * w_dim1] * scl[jcol], abs(d__1)); if (t1 > t) { jbig = j; t = t1; } /* L380: */ } goto L400; } drotg_(&w[i__ + i__ * w_dim1], &w[i__ + 1 + i__ * w_dim1], &sc, &ss); w[i__ + 1 + i__ * w_dim1] = 0.; i__8 = *ncols - i__ + 1; drot_(&i__8, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + (i__ + 1) * w_dim1], mdw, &sc, &ss); /* L390: */ } goto L430; /* The triangularization is completed by giving up the Hessenberg */ /* form and triangularizing a rectangular matrix. */ L400: dswap_(&mrows, &w[i__ * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &c__1); dswap_(&c__1, &ww[i__], &c__1, &ww[jbig], &c__1); dswap_(&c__1, &x[i__], &c__1, &x[jbig], &c__1); itemp = ibasis[i__]; ibasis[i__] = ibasis[jbig]; ibasis[jbig] = itemp; jbig = i__; i__3 = nsetb; for (j = jbig; j <= i__3; ++j) { i__8 = mrows; for (i__ = j + 1; i__ <= i__8; ++i__) { drotg_(&w[j + j * w_dim1], &w[i__ + j * w_dim1], &sc, &ss); w[i__ + j * w_dim1] = 0.; i__9 = *ncols - j + 1; drot_(&i__9, &w[j + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) * w_dim1], mdw, &sc, &ss); /* L410: */ } /* L420: */ } /* See if the remaining coefficients are feasible. They should be */ /* because of the way MIN(ALPHA,BETA) was chosen. Any that are not */ /* feasible will be set to their bounds and appropriately translated. */ L430: jdrop1 = 0; jdrop2 = 0; lgopr = 2; goto L270; /* Find a variable to become non-active. */ L120: if (found) { lgopr = 1; goto L270; } /* Rescale and translate variables. */ igopr = 2; L130: dcopy_(&nsetb, &x[1], &c__1, &rw[1], &c__1); dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1); i__3 = nsetb; for (j = 1; j <= i__3; ++j) { jcol = (i__8 = ibasis[j], abs(i__8)); x[jcol] = rw[j] * (d__1 = scl[jcol], abs(d__1)); /* L140: */ } i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (ibb[j] % 2 == 0) { x[j] = bu[j] - x[j]; } /* L150: */ } i__3 = *ncols; for (j = 1; j <= i__3; ++j) { jcol = ibasis[j]; if (jcol < 0) { x[-jcol] = bl[-jcol] + x[-jcol]; } /* L160: */ } i__3 = *ncols; for (j = 1; j <= i__3; ++j) { if (scl[j] < 0.) { x[j] = -x[j]; } /* L170: */ } i__ = max(nsetb,mval); i__3 = mrows - i__; /* Computing MIN */ i__8 = i__ + 1; *rnorm = dnrm2_(&i__3, &w[min(i__8,mrows) + (*ncols + 1) * w_dim1], &c__1) ; if (igopr == 2) { *mode = nsetb; } return 0; } /* dbolsm_ */
/* Subroutine */ int znaitr_(integer *ido, char *bmat, integer *n, integer *k, integer *np, integer *nb, doublecomplex *resid, doublereal *rnorm, doublecomplex *v, integer *ldv, doublecomplex *h__, integer *ldh, integer *ipntr, doublecomplex *workd, integer *info, ftnlen bmat_len) { /* Initialized data */ static logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2, i__3; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; /* Builtin functions */ double d_imag(doublecomplex *), sqrt(doublereal); /* Local variables */ static integer i__, j; static real t0, t1, t2, t3, t4, t5; static integer jj, ipj, irj, ivj; static doublereal ulp, tst1; static integer ierr, iter; static doublereal unfl, ovfl; static integer itry; static doublereal temp1; static logical orth1, orth2, step3, step4; static doublereal betaj; static integer infol; static doublecomplex cnorm; extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static doublereal rtemp[2]; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); static doublereal wnorm; extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zmout_(integer *, integer *, integer *, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(integer *, integer *, doublecomplex *, integer *, char *, ftnlen); extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); extern doublereal dznrm2_(integer *, doublecomplex *, integer *); static doublereal rnorm1; extern /* Subroutine */ int zgetv0_(integer *, char *, integer *, logical *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, integer *, doublecomplex *, integer *, ftnlen); extern doublereal dlamch_(char *, ftnlen); extern /* Subroutine */ int second_(real *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); static logical rstart; static integer msglvl; static doublereal smlnum; extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, doublecomplex *, ftnlen); extern /* Subroutine */ int zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, integer *, ftnlen); /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %--------------% */ /* | Local Arrays | */ /* %--------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------% */ /* | Data statements | */ /* %-----------------% */ /* Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --ipntr; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ if (first) { /* %-----------------------------------------% */ /* | Set machine-dependent constants for the | */ /* | the splitting and deflation criterion. | */ /* | If norm(H) <= sqrt(OVFL), | */ /* | overflow should not occur. | */ /* | REFERENCE: LAPACK subroutine zlahqr | */ /* %-----------------------------------------% */ unfl = dlamch_("safe minimum", (ftnlen)12); z__1.r = 1. / unfl, z__1.i = 0. / unfl; ovfl = z__1.r; dlabad_(&unfl, &ovfl); ulp = dlamch_("precision", (ftnlen)9); smlnum = unfl * (*n / ulp); first = FALSE_; } if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ second_(&t0); msglvl = debug_1.mcaitr; /* %------------------------------% */ /* | Initial call to this routine | */ /* %------------------------------% */ *info = 0; step3 = FALSE_; step4 = FALSE_; rstart = FALSE_; orth1 = FALSE_; orth2 = FALSE_; j = *k + 1; ipj = 1; irj = ipj + *n; ivj = irj + *n; } /* %-------------------------------------------------% */ /* | When in reverse communication mode one of: | */ /* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */ /* | will be .true. when .... | */ /* | STEP3: return from computing OP*v_{j}. | */ /* | STEP4: return from computing B-norm of OP*v_{j} | */ /* | ORTH1: return from computing B-norm of r_{j+1} | */ /* | ORTH2: return from computing B-norm of | */ /* | correction to the residual vector. | */ /* | RSTART: return from OP computations needed by | */ /* | zgetv0. | */ /* %-------------------------------------------------% */ if (step3) { goto L50; } if (step4) { goto L60; } if (orth1) { goto L70; } if (orth2) { goto L90; } if (rstart) { goto L30; } /* %-----------------------------% */ /* | Else this is the first step | */ /* %-----------------------------% */ /* %--------------------------------------------------------------% */ /* | | */ /* | A R N O L D I I T E R A T I O N L O O P | */ /* | | */ /* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */ /* %--------------------------------------------------------------% */ L1000: if (msglvl > 1) { ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat" "ing Arnoldi vector number", (ftnlen)40); dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no" "rm of the current residual is", (ftnlen)41); } /* %---------------------------------------------------% */ /* | STEP 1: Check if the B norm of j-th residual | */ /* | vector is zero. Equivalent to determine whether | */ /* | an exact j-step Arnoldi factorization is present. | */ /* %---------------------------------------------------% */ betaj = *rnorm; if (*rnorm > 0.) { goto L40; } /* %---------------------------------------------------% */ /* | Invariant subspace found, generate a new starting | */ /* | vector which is orthogonal to the current Arnoldi | */ /* | basis and continue the iteration. | */ /* %---------------------------------------------------% */ if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** " "RESTART AT STEP ******", (ftnlen)37); } /* %---------------------------------------------% */ /* | ITRY is the loop variable that controls the | */ /* | maximum amount of times that a restart is | */ /* | attempted. NRSTRT is used by stat.h | */ /* %---------------------------------------------% */ betaj = 0.; ++timing_1.nrstrt; itry = 1; L20: rstart = TRUE_; *ido = 0; L30: /* %--------------------------------------% */ /* | If in reverse communication mode and | */ /* | RSTART = .true. flow returns here. | */ /* %--------------------------------------% */ zgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1], rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1); if (*ido != 99) { goto L9000; } if (ierr < 0) { ++itry; if (itry <= 3) { goto L20; } /* %------------------------------------------------% */ /* | Give up after several restart attempts. | */ /* | Set INFO to the size of the invariant subspace | */ /* | which spans OP and exit. | */ /* %------------------------------------------------% */ *info = j - 1; second_(&t1); timing_1.tcaitr += t1 - t0; *ido = 99; goto L9000; } L40: /* %---------------------------------------------------------% */ /* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */ /* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */ /* | when reciprocating a small RNORM, test against lower | */ /* | machine bound. | */ /* %---------------------------------------------------------% */ zcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1); if (*rnorm >= unfl) { temp1 = 1. / *rnorm; zdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1); zdscal_(n, &temp1, &workd[ipj], &c__1); } else { /* %-----------------------------------------% */ /* | To scale both v_{j} and p_{j} carefully | */ /* | use LAPACK routine zlascl | */ /* %-----------------------------------------% */ zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &v[j * v_dim1 + 1], n, &infol, (ftnlen)7); zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &workd[ipj], n, &infol, (ftnlen)7); } /* %------------------------------------------------------% */ /* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */ /* | Note that this is not quite yet r_{j}. See STEP 4 | */ /* %------------------------------------------------------% */ step3 = TRUE_; ++timing_1.nopx; second_(&t2); zcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1); ipntr[1] = ivj; ipntr[2] = irj; ipntr[3] = ipj; *ido = 1; /* %-----------------------------------% */ /* | Exit in order to compute OP*v_{j} | */ /* %-----------------------------------% */ goto L9000; L50: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */ /* | if step3 = .true. | */ /* %----------------------------------% */ second_(&t3); timing_1.tmvopx += t3 - t2; step3 = FALSE_; /* %------------------------------------------% */ /* | Put another copy of OP*v_{j} into RESID. | */ /* %------------------------------------------% */ zcopy_(n, &workd[irj], &c__1, &resid[1], &c__1); /* %---------------------------------------% */ /* | STEP 4: Finish extending the Arnoldi | */ /* | factorization to length j. | */ /* %---------------------------------------% */ second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; step4 = TRUE_; ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-------------------------------------% */ /* | Exit in order to compute B*OP*v_{j} | */ /* %-------------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L60: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */ /* | if step4 = .true. | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } step4 = FALSE_; /* %-------------------------------------% */ /* | The following is needed for STEP 5. | */ /* | Compute the B-norm of OP*v_{j}. | */ /* %-------------------------------------% */ if (*(unsigned char *)bmat == 'G') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); wnorm = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { wnorm = dznrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------% */ /* | Compute the j-th residual corresponding | */ /* | to the j step factorization. | */ /* | Use Classical Gram Schmidt and compute: | */ /* | w_{j} <- V_{j}^T * B * OP * v_{j} | */ /* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */ /* %-----------------------------------------% */ /* %------------------------------------------% */ /* | Compute the j Fourier coefficients w_{j} | */ /* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */ /* %------------------------------------------% */ zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, & h__[j * h_dim1 + 1], &c__1, (ftnlen)1); /* %--------------------------------------% */ /* | Orthogonalize r_{j} against V_{j}. | */ /* | RESID contains OP*v_{j}. See STEP 3. | */ /* %--------------------------------------% */ z__1.r = -1., z__1.i = -0.; zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1, &c_b1, &resid[1], &c__1, (ftnlen)1); if (j > 1) { i__1 = j + (j - 1) * h_dim1; z__1.r = betaj, z__1.i = 0.; h__[i__1].r = z__1.r, h__[i__1].i = z__1.i; } second_(&t4); orth1 = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %----------------------------------% */ /* | Exit in order to compute B*r_{j} | */ /* %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L70: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH1 = .true. | */ /* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } orth1 = FALSE_; /* %------------------------------% */ /* | Compute the B-norm of r_{j}. | */ /* %------------------------------% */ if (*(unsigned char *)bmat == 'G') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); *rnorm = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { *rnorm = dznrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------------------------% */ /* | STEP 5: Re-orthogonalization / Iterative refinement phase | */ /* | Maximum NITER_ITREF tries. | */ /* | | */ /* | s = V_{j}^T * B * r_{j} | */ /* | r_{j} = r_{j} - V_{j}*s | */ /* | alphaj = alphaj + s_{j} | */ /* | | */ /* | The stopping criteria used for iterative refinement is | */ /* | discussed in Parlett's book SEP, page 107 and in Gragg & | */ /* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */ /* | Determine if we need to correct the residual. The goal is | */ /* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */ /* | The following test determines whether the sine of the | */ /* | angle between OP*x and the computed residual is less | */ /* | than or equal to 0.717. | */ /* %-----------------------------------------------------------% */ if (*rnorm > wnorm * .717f) { goto L100; } iter = 0; ++timing_1.nrorth; /* %---------------------------------------------------% */ /* | Enter the Iterative refinement phase. If further | */ /* | refinement is necessary, loop back here. The loop | */ /* | variable is ITER. Perform a step of Classical | */ /* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */ /* %---------------------------------------------------% */ L80: if (msglvl > 2) { rtemp[0] = wnorm; rtemp[1] = *rnorm; dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: re-o" "rthogonalization; wnorm and rnorm are", (ftnlen)49); zvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit, "_naitr: j-th column of H", (ftnlen)24); } /* %----------------------------------------------------% */ /* | Compute V_{j}^T * B * r_{j}. | */ /* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */ /* %----------------------------------------------------% */ zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, & workd[irj], &c__1, (ftnlen)1); /* %---------------------------------------------% */ /* | Compute the correction to the residual: | */ /* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */ /* | The correction to H is v(:,1:J)*H(1:J,1:J) | */ /* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */ /* %---------------------------------------------% */ z__1.r = -1., z__1.i = -0.; zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &workd[irj], &c__1, &c_b1, & resid[1], &c__1, (ftnlen)1); zaxpy_(&j, &c_b1, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1); orth2 = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-----------------------------------% */ /* | Exit in order to compute B*r_{j}. | */ /* | r_{j} is the corrected residual. | */ /* %-----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L90: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH2 = .true. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } /* %-----------------------------------------------------% */ /* | Compute the B-norm of the corrected residual r_{j}. | */ /* %-----------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); rnorm1 = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { rnorm1 = dznrm2_(n, &resid[1], &c__1); } if (msglvl > 0 && iter > 0) { ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati" "ve refinement for Arnoldi residual", (ftnlen)49); if (msglvl > 2) { rtemp[0] = *rnorm; rtemp[1] = rnorm1; dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: " "iterative refinement ; rnorm and rnorm1 are", (ftnlen)51); } } /* %-----------------------------------------% */ /* | Determine if we need to perform another | */ /* | step of re-orthogonalization. | */ /* %-----------------------------------------% */ if (rnorm1 > *rnorm * .717f) { /* %---------------------------------------% */ /* | No need for further refinement. | */ /* | The cosine of the angle between the | */ /* | corrected residual vector and the old | */ /* | residual vector is greater than 0.717 | */ /* | In other words the corrected residual | */ /* | and the old residual vector share an | */ /* | angle of less than arcCOS(0.717) | */ /* %---------------------------------------% */ *rnorm = rnorm1; } else { /* %-------------------------------------------% */ /* | Another step of iterative refinement step | */ /* | is required. NITREF is used by stat.h | */ /* %-------------------------------------------% */ ++timing_1.nitref; *rnorm = rnorm1; ++iter; if (iter <= 1) { goto L80; } /* %-------------------------------------------------% */ /* | Otherwise RESID is numerically in the span of V | */ /* %-------------------------------------------------% */ i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { i__2 = jj; resid[i__2].r = 0., resid[i__2].i = 0.; /* L95: */ } *rnorm = 0.; } /* %----------------------------------------------% */ /* | Branch here directly if iterative refinement | */ /* | wasn't necessary or after at most NITER_REF | */ /* | steps of iterative refinement. | */ /* %----------------------------------------------% */ L100: rstart = FALSE_; orth2 = FALSE_; second_(&t5); timing_1.titref += t5 - t4; /* %------------------------------------% */ /* | STEP 6: Update j = j+1; Continue | */ /* %------------------------------------% */ ++j; if (j > *k + *np) { second_(&t1); timing_1.tcaitr += t1 - t0; *ido = 99; i__1 = *k + *np - 1; for (i__ = max(1,*k); i__ <= i__1; ++i__) { /* %--------------------------------------------% */ /* | Check for splitting and deflation. | */ /* | Use a standard test as in the QR algorithm | */ /* | REFERENCE: LAPACK subroutine zlahqr | */ /* %--------------------------------------------% */ i__2 = i__ + i__ * h_dim1; d__1 = h__[i__2].r; d__2 = d_imag(&h__[i__ + i__ * h_dim1]); i__3 = i__ + 1 + (i__ + 1) * h_dim1; d__3 = h__[i__3].r; d__4 = d_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]); tst1 = dlapy2_(&d__1, &d__2) + dlapy2_(&d__3, &d__4); if (tst1 == 0.) { i__2 = *k + *np; tst1 = zlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1] , (ftnlen)1); } i__2 = i__ + 1 + i__ * h_dim1; d__1 = h__[i__2].r; d__2 = d_imag(&h__[i__ + 1 + i__ * h_dim1]); /* Computing MAX */ d__3 = ulp * tst1; if (dlapy2_(&d__1, &d__2) <= max(d__3,smlnum)) { i__3 = i__ + 1 + i__ * h_dim1; h__[i__3].r = 0., h__[i__3].i = 0.; } /* L110: */ } if (msglvl > 2) { i__1 = *k + *np; i__2 = *k + *np; zmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, & debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H" " of order K+NP", (ftnlen)53); } goto L9000; } /* %--------------------------------------------------------% */ /* | Loop back to extend the factorization by another step. | */ /* %--------------------------------------------------------% */ goto L1000; /* %---------------------------------------------------------------% */ /* | | */ /* | E N D O F M A I N I T E R A T I O N L O O P | */ /* | | */ /* %---------------------------------------------------------------% */ L9000: return 0; /* %---------------% */ /* | End of znaitr | */ /* %---------------% */ } /* znaitr_ */
/* Subroutine */ int pdnaup2_(integer *comm, integer *ido, char *bmat, integer *n, char *which, integer *nev, integer *np, doublereal *tol, doublereal *resid, integer *mode, integer *iupd, integer *ishift, integer *mxiter, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, doublereal *ritzr, doublereal *ritzi, doublereal * bounds, doublereal *q, integer *ldq, doublereal *workl, integer * ipntr, doublereal *workd, integer *info, ftnlen bmat_len, ftnlen which_len) { /* System generated locals */ integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2; doublereal d__1, d__2; /* Builtin functions */ double pow_dd(doublereal *, doublereal *); integer s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); double sqrt(doublereal); /* Local variables */ static integer j; static real t0, t1, t2, t3; static doublereal rnorm_buf__; static integer kp[4], np0, nev0; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); static doublereal eps23; static integer ierr, iter; static doublereal temp; static logical getv0, cnorm; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer nconv; static logical initv; static doublereal rnorm; extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), mpi_allreduce__(doublereal *, doublereal *, integer *, integer *, integer *, integer *, integer *); extern doublereal dlapy2_(doublereal *, doublereal *); static integer nevbef; static char wprime[2]; static logical update, ushift; static integer kplusp, msglvl, nptemp, numcnv; extern /* Subroutine */ int dnconv_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), pdvout_(integer *, integer *, integer *, doublereal *, integer *, char *, ftnlen), pivout_(integer *, integer *, integer *, integer *, integer *, char *, ftnlen), second_(real *), dsortc_(char *, logical *, integer *, doublereal *, doublereal *, doublereal *, ftnlen), pdmout_(integer *, integer *, integer *, integer *, doublereal *, integer *, integer *, char *, ftnlen), pdgetv0_(integer *, integer *, char *, integer *, logical *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen); extern doublereal pdnorm2_(integer *, integer *, doublereal *, integer *), pdlamch_(integer *, char *, ftnlen); extern /* Subroutine */ int pdneigh_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *), pdnaitr_( integer *, integer *, char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, doublereal *, integer *, ftnlen), pdngets_(integer *, integer *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, ftnlen), pdnapps_(integer *, integer * , integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *); /* %---------------% */ /* | MPI Variables | */ /* %---------------% */ /* /+ */ /* * */ /* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */ /* * All rights reserved. See COPYRIGHT in top-level directory. */ /* +/ */ /* /+ user include file for MPI programs, with no dependencies +/ */ /* /+ return codes +/ */ /* We handle datatypes by putting the variables that hold them into */ /* common. This way, a Fortran program can directly use the various */ /* datatypes and can even give them to C programs. */ /* MPI_BOTTOM needs to be a known address; here we put it at the */ /* beginning of the common block. The point-to-point and collective */ /* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */ /* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */ /* Their values are zero if they are not available. Note that */ /* using these reduces the portability of code (though may enhance */ /* portability between Crays and other systems) */ /* All other MPI routines are subroutines */ /* The attribute copy/delete functions are symbols that can be passed */ /* to MPI routines */ /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %-----------------------% */ /* | Local array arguments | */ /* %-----------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* Parameter adjustments */ --workd; --resid; --workl; --bounds; --ritzi; --ritzr; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --ipntr; /* Function Body */ if (*ido == 0) { second_(&t0); msglvl = debug_1.mnaup2; /* %-------------------------------------% */ /* | Get the machine dependent constant. | */ /* %-------------------------------------% */ eps23 = pdlamch_(comm, "Epsilon-Machine", (ftnlen)15); eps23 = pow_dd(&eps23, &c_b3); nev0 = *nev; np0 = *np; /* %-------------------------------------% */ /* | kplusp is the bound on the largest | */ /* | Lanczos factorization built. | */ /* | nconv is the current number of | */ /* | "converged" eigenvlues. | */ /* | iter is the counter on the current | */ /* | iteration step. | */ /* %-------------------------------------% */ kplusp = *nev + *np; nconv = 0; iter = 0; /* %---------------------------------------% */ /* | Set flags for computing the first NEV | */ /* | steps of the Arnoldi factorization. | */ /* %---------------------------------------% */ getv0 = TRUE_; update = FALSE_; ushift = FALSE_; cnorm = FALSE_; if (*info != 0) { /* %--------------------------------------------% */ /* | User provides the initial residual vector. | */ /* %--------------------------------------------% */ initv = TRUE_; *info = 0; } else { initv = FALSE_; } } /* %---------------------------------------------% */ /* | Get a possibly random starting vector and | */ /* | force it into the range of the operator OP. | */ /* %---------------------------------------------% */ /* L10: */ if (getv0) { pdgetv0_(comm, ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[1], &rnorm, &ipntr[1], &workd[1], &workl[1], info, ( ftnlen)1); if (*ido != 99) { goto L9000; } if (rnorm == 0.) { /* %-----------------------------------------% */ /* | The initial vector is zero. Error exit. | */ /* %-----------------------------------------% */ *info = -9; goto L1100; } getv0 = FALSE_; *ido = 0; } /* %-----------------------------------% */ /* | Back from reverse communication : | */ /* | continue with update step | */ /* %-----------------------------------% */ if (update) { goto L20; } /* %-------------------------------------------% */ /* | Back from computing user specified shifts | */ /* %-------------------------------------------% */ if (ushift) { goto L50; } /* %-------------------------------------% */ /* | Back from computing residual norm | */ /* | at the end of the current iteration | */ /* %-------------------------------------% */ if (cnorm) { goto L100; } /* %----------------------------------------------------------% */ /* | Compute the first NEV steps of the Arnoldi factorization | */ /* %----------------------------------------------------------% */ pdnaitr_(comm, ido, bmat, n, &c__0, nev, mode, &resid[1], &rnorm, &v[ v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], &workl[ 1], info, (ftnlen)1); /* %---------------------------------------------------% */ /* | ido .ne. 99 implies use of reverse communication | */ /* | to compute operations involving OP and possibly B | */ /* %---------------------------------------------------% */ if (*ido != 99) { goto L9000; } if (*info > 0) { *np = *info; *mxiter = iter; *info = -9999; goto L1200; } /* %--------------------------------------------------------------% */ /* | | */ /* | M A I N ARNOLDI I T E R A T I O N L O O P | */ /* | Each iteration implicitly restarts the Arnoldi | */ /* | factorization in place. | */ /* | | */ /* %--------------------------------------------------------------% */ L1000: ++iter; if (msglvl > 0) { pivout_(comm, &debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_naup" "2: **** Start of major iteration number ****", (ftnlen)49); } /* %-----------------------------------------------------------% */ /* | Compute NP additional steps of the Arnoldi factorization. | */ /* | Adjust NP since NEV might have been updated by last call | */ /* | to the shift application routine pdnapps . | */ /* %-----------------------------------------------------------% */ *np = kplusp - *nev; if (msglvl > 1) { pivout_(comm, &debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_naup2:" " The length of the current Arnoldi factorization", (ftnlen)55) ; pivout_(comm, &debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: " "Extend the Arnoldi factorization by", (ftnlen)43); } /* %-----------------------------------------------------------% */ /* | Compute NP additional steps of the Arnoldi factorization. | */ /* %-----------------------------------------------------------% */ *ido = 0; L20: update = TRUE_; pdnaitr_(comm, ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[ v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], &workl[ 1], info, (ftnlen)1); /* %---------------------------------------------------% */ /* | ido .ne. 99 implies use of reverse communication | */ /* | to compute operations involving OP and possibly B | */ /* %---------------------------------------------------% */ if (*ido != 99) { goto L9000; } if (*info > 0) { *np = *info; *mxiter = iter; *info = -9999; goto L1200; } update = FALSE_; if (msglvl > 1) { pdvout_(comm, &debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_nau" "p2: Corresponding B-norm of the residual", (ftnlen)44); } /* %--------------------------------------------------------% */ /* | Compute the eigenvalues and corresponding error bounds | */ /* | of the current upper Hessenberg matrix. | */ /* %--------------------------------------------------------% */ pdneigh_(comm, &rnorm, &kplusp, &h__[h_offset], ldh, &ritzr[1], &ritzi[1], &bounds[1], &q[q_offset], ldq, &workl[1], &ierr); if (ierr != 0) { *info = -8; goto L1200; } /* %----------------------------------------------------% */ /* | Make a copy of eigenvalues and corresponding error | */ /* | bounds obtained from pdneigh . | */ /* %----------------------------------------------------% */ /* Computing 2nd power */ i__1 = kplusp; dcopy_(&kplusp, &ritzr[1], &c__1, &workl[i__1 * i__1 + 1], &c__1); /* Computing 2nd power */ i__1 = kplusp; dcopy_(&kplusp, &ritzi[1], &c__1, &workl[i__1 * i__1 + kplusp + 1], &c__1) ; /* Computing 2nd power */ i__1 = kplusp; dcopy_(&kplusp, &bounds[1], &c__1, &workl[i__1 * i__1 + (kplusp << 1) + 1] , &c__1); /* %---------------------------------------------------% */ /* | Select the wanted Ritz values and their bounds | */ /* | to be used in the convergence test. | */ /* | The wanted part of the spectrum and corresponding | */ /* | error bounds are in the last NEV loc. of RITZR, | */ /* | RITZI and BOUNDS respectively. The variables NEV | */ /* | and NP may be updated if the NEV-th wanted Ritz | */ /* | value has a non zero imaginary part. In this case | */ /* | NEV is increased by one and NP decreased by one. | */ /* | NOTE: The last two arguments of pdngets are no | */ /* | longer used as of version 2.1. | */ /* %---------------------------------------------------% */ *nev = nev0; *np = np0; numcnv = *nev; pdngets_(comm, ishift, which, nev, np, &ritzr[1], &ritzi[1], &bounds[1], & workl[1], &workl[*np + 1], (ftnlen)2); if (*nev == nev0 + 1) { numcnv = nev0 + 1; } /* %-------------------% */ /* | Convergence test. | */ /* %-------------------% */ dcopy_(nev, &bounds[*np + 1], &c__1, &workl[(*np << 1) + 1], &c__1); dnconv_(nev, &ritzr[*np + 1], &ritzi[*np + 1], &workl[(*np << 1) + 1], tol, &nconv); if (msglvl > 2) { kp[0] = *nev; kp[1] = *np; kp[2] = numcnv; kp[3] = nconv; pivout_(comm, &debug_1.logfil, &c__4, kp, &debug_1.ndigit, "_naup2: " "NEV, NP, NUMCNV, NCONV are", (ftnlen)34); pdvout_(comm, &debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit, "_naup2: Real part of the eigenvalues of H", (ftnlen)41); pdvout_(comm, &debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit, "_naup2: Imaginary part of the eigenvalues of H", (ftnlen)46); pdvout_(comm, &debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_naup2: Ritz estimates of the current NCV Ritz values", ( ftnlen)53); } /* %---------------------------------------------------------% */ /* | Count the number of unwanted Ritz values that have zero | */ /* | Ritz estimates. If any Ritz estimates are equal to zero | */ /* | then a leading block of H of order equal to at least | */ /* | the number of Ritz values with zero Ritz estimates has | */ /* | split off. None of these Ritz values may be removed by | */ /* | shifting. Decrease NP the number of shifts to apply. If | */ /* | no shifts may be applied, then prepare to exit | */ /* %---------------------------------------------------------% */ nptemp = *np; i__1 = nptemp; for (j = 1; j <= i__1; ++j) { if (bounds[j] == 0.) { --(*np); ++(*nev); } /* L30: */ } if (nconv >= numcnv || iter > *mxiter || *np == 0) { if (msglvl > 4) { /* Computing 2nd power */ i__1 = kplusp; dvout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + 1], & debug_1.ndigit, "_naup2: Real part of the eig computed b" "y _neigh:", (ftnlen)48); /* Computing 2nd power */ i__1 = kplusp; dvout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + kplusp + 1], &debug_1.ndigit, "_naup2: Imag part of the eig computed" " by _neigh:", (ftnlen)48); /* Computing 2nd power */ i__1 = kplusp; dvout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + (kplusp << 1) + 1], &debug_1.ndigit, "_naup2: Ritz estimates comput" "ed by _neigh:", (ftnlen)42); } /* %------------------------------------------------% */ /* | Prepare to exit. Put the converged Ritz values | */ /* | and corresponding bounds in RITZ(1:NCONV) and | */ /* | BOUNDS(1:NCONV) respectively. Then sort. Be | */ /* | careful when NCONV > NP | */ /* %------------------------------------------------% */ /* %------------------------------------------% */ /* | Use h( 3,1 ) as storage to communicate | */ /* | rnorm to _neupd if needed | */ /* %------------------------------------------% */ h__[h_dim1 + 3] = rnorm; /* %----------------------------------------------% */ /* | To be consistent with dngets , we first do a | */ /* | pre-processing sort in order to keep complex | */ /* | conjugate pairs together. This is similar | */ /* | to the pre-processing sort used in dngets | */ /* | except that the sort is done in the opposite | */ /* | order. | */ /* %----------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } dsortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); /* %----------------------------------------------% */ /* | Now sort Ritz values so that converged Ritz | */ /* | values appear within the first NEV locations | */ /* | of ritzr, ritzi and bounds, and the most | */ /* | desired one appears at the front. | */ /* %----------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SI", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LI", (ftnlen)2, (ftnlen)2); } dsortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); /* %--------------------------------------------------% */ /* | Scale the Ritz estimate of each Ritz value | */ /* | by 1 / max(eps23,magnitude of the Ritz value). | */ /* %--------------------------------------------------% */ i__1 = numcnv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = eps23, d__2 = dlapy2_(&ritzr[j], &ritzi[j]); temp = max(d__1,d__2); bounds[j] /= temp; /* L35: */ } /* %----------------------------------------------------% */ /* | Sort the Ritz values according to the scaled Ritz | */ /* | esitmates. This will push all the converged ones | */ /* | towards the front of ritzr, ritzi, bounds | */ /* | (in the case when NCONV < NEV.) | */ /* %----------------------------------------------------% */ s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2); dsortc_(wprime, &c_true, &numcnv, &bounds[1], &ritzr[1], &ritzi[1], ( ftnlen)2); /* %----------------------------------------------% */ /* | Scale the Ritz estimate back to its original | */ /* | value. | */ /* %----------------------------------------------% */ i__1 = numcnv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = eps23, d__2 = dlapy2_(&ritzr[j], &ritzi[j]); temp = max(d__1,d__2); bounds[j] *= temp; /* L40: */ } /* %------------------------------------------------% */ /* | Sort the converged Ritz values again so that | */ /* | the "threshold" value appears at the front of | */ /* | ritzr, ritzi and bound. | */ /* %------------------------------------------------% */ dsortc_(which, &c_true, &nconv, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); if (msglvl > 1) { dvout_(&debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit, "_naup2: Sorted real part of the eigenvalues", (ftnlen)43) ; dvout_(&debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit, "_naup2: Sorted imaginary part of the eigenvalues", ( ftnlen)48); dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_naup2: Sorted ritz estimates.", (ftnlen)30); } /* %------------------------------------% */ /* | Max iterations have been exceeded. | */ /* %------------------------------------% */ if (iter > *mxiter && nconv < numcnv) { *info = 1; } /* %---------------------% */ /* | No shifts to apply. | */ /* %---------------------% */ if (*np == 0 && nconv < numcnv) { *info = 2; } *np = nconv; goto L1100; } else if (nconv < numcnv && *ishift == 1) { /* %-------------------------------------------------% */ /* | Do not have all the requested eigenvalues yet. | */ /* | To prevent possible stagnation, adjust the size | */ /* | of NEV. | */ /* %-------------------------------------------------% */ nevbef = *nev; /* Computing MIN */ i__1 = nconv, i__2 = *np / 2; *nev += min(i__1,i__2); if (*nev == 1 && kplusp >= 6) { *nev = kplusp / 2; } else if (*nev == 1 && kplusp > 3) { *nev = 2; } *np = kplusp - *nev; /* %---------------------------------------% */ /* | If the size of NEV was just increased | */ /* | resort the eigenvalues. | */ /* %---------------------------------------% */ if (nevbef < *nev) { pdngets_(comm, ishift, which, nev, np, &ritzr[1], &ritzi[1], & bounds[1], &workl[1], &workl[*np + 1], (ftnlen)2); } } if (msglvl > 0) { pivout_(comm, &debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_nau" "p2: no. of \"converged\" Ritz values at this iter.", (ftnlen) 52); if (msglvl > 1) { kp[0] = *nev; kp[1] = *np; pivout_(comm, &debug_1.logfil, &c__2, kp, &debug_1.ndigit, "_nau" "p2: NEV and NP are", (ftnlen)22); pdvout_(comm, &debug_1.logfil, nev, &ritzr[*np + 1], & debug_1.ndigit, "_naup2: \"wanted\" Ritz values -- real " "part", (ftnlen)41); pdvout_(comm, &debug_1.logfil, nev, &ritzi[*np + 1], & debug_1.ndigit, "_naup2: \"wanted\" Ritz values -- imag " "part", (ftnlen)41); pdvout_(comm, &debug_1.logfil, nev, &bounds[*np + 1], & debug_1.ndigit, "_naup2: Ritz estimates of the \"wante" "d\" values ", (ftnlen)46); } } if (*ishift == 0) { /* %-------------------------------------------------------% */ /* | User specified shifts: reverse comminucation to | */ /* | compute the shifts. They are returned in the first | */ /* | 2*NP locations of WORKL. | */ /* %-------------------------------------------------------% */ ushift = TRUE_; *ido = 3; goto L9000; } L50: /* %------------------------------------% */ /* | Back from reverse communication; | */ /* | User specified shifts are returned | */ /* | in WORKL(1:2*NP) | */ /* %------------------------------------% */ ushift = FALSE_; if (*ishift == 0) { /* %----------------------------------% */ /* | Move the NP shifts from WORKL to | */ /* | RITZR, RITZI to free up WORKL | */ /* | for non-exact shift case. | */ /* %----------------------------------% */ dcopy_(np, &workl[1], &c__1, &ritzr[1], &c__1); dcopy_(np, &workl[*np + 1], &c__1, &ritzi[1], &c__1); } if (msglvl > 2) { pivout_(comm, &debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: " "The number of shifts to apply ", (ftnlen)38); pdvout_(comm, &debug_1.logfil, np, &ritzr[1], &debug_1.ndigit, "_nau" "p2: Real part of the shifts", (ftnlen)31); pdvout_(comm, &debug_1.logfil, np, &ritzi[1], &debug_1.ndigit, "_nau" "p2: Imaginary part of the shifts", (ftnlen)36); if (*ishift == 1) { pdvout_(comm, &debug_1.logfil, np, &bounds[1], &debug_1.ndigit, "_naup2: Ritz estimates of the shifts", (ftnlen)36); } } /* %---------------------------------------------------------% */ /* | Apply the NP implicit shifts by QR bulge chasing. | */ /* | Each shift is applied to the whole upper Hessenberg | */ /* | matrix H. | */ /* | The first 2*N locations of WORKD are used as workspace. | */ /* %---------------------------------------------------------% */ pdnapps_(comm, n, nev, np, &ritzr[1], &ritzi[1], &v[v_offset], ldv, &h__[ h_offset], ldh, &resid[1], &q[q_offset], ldq, &workl[1], &workd[1] ); /* %---------------------------------------------% */ /* | Compute the B-norm of the updated residual. | */ /* | Keep B*RESID in WORKD(1:N) to be used in | */ /* | the first step of the next call to pdnaitr . | */ /* %---------------------------------------------% */ cnorm = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; dcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; /* %----------------------------------% */ /* | Exit in order to compute B*RESID | */ /* %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { dcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L100: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(1:N) := B*RESID | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { rnorm_buf__ = ddot_(n, &resid[1], &c__1, &workd[1], &c__1); mpi_allreduce__(&rnorm_buf__, &rnorm, &c__1, & mpipriv_1.mpi_double_precision__, &mpipriv_1.mpi_sum__, comm, &ierr); rnorm = sqrt((abs(rnorm))); } else if (*(unsigned char *)bmat == 'I') { rnorm = pdnorm2_(comm, n, &resid[1], &c__1); } cnorm = FALSE_; if (msglvl > 2) { pdvout_(comm, &debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_nau" "p2: B-norm of residual for compressed factorization", (ftnlen) 55); pdmout_(comm, &debug_1.logfil, nev, nev, &h__[h_offset], ldh, & debug_1.ndigit, "_naup2: Compressed upper Hessenberg matrix H" , (ftnlen)44); } goto L1000; /* %---------------------------------------------------------------% */ /* | | */ /* | E N D O F M A I N I T E R A T I O N L O O P | */ /* | | */ /* %---------------------------------------------------------------% */ L1100: *mxiter = iter; *nev = numcnv; L1200: *ido = 99; /* %------------% */ /* | Error Exit | */ /* %------------% */ second_(&t1); timing_1.tnaup2 = t1 - t0; L9000: /* %----------------% */ /* | End of pdnaup2 | */ /* %----------------% */ return 0; } /* pdnaup2_ */
/* Subroutine */ int zgetv0_(integer *ido, char *bmat, integer *itry, logical *initv, integer *n, integer *j, doublecomplex *v, integer *ldv, doublecomplex *resid, doublereal *rnorm, integer *ipntr, doublecomplex *workd, integer *ierr, ftnlen bmat_len) { /* Initialized data */ static logical inits = TRUE_; /* System generated locals */ integer v_dim1, v_offset, i__1, i__2; doublereal d__1, d__2; doublecomplex z__1; /* Local variables */ static real t0, t1, t2, t3; static integer jj, iter; static logical orth; static integer iseed[4], idist; static doublecomplex cnorm; extern /* Double Complex */ void zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static logical first; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen), dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zvout_(integer *, integer *, doublecomplex *, integer *, char *, ftnlen); extern doublereal dlapy2_(doublereal *, doublereal *), dznrm2_(integer *, doublecomplex *, integer *); static doublereal rnorm0; extern /* Subroutine */ int arscnd_(real *); static integer msglvl; extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *, doublecomplex *); /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %------------------------% */ /* | Local Scalars & Arrays | */ /* %------------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %-----------------% */ /* | Data Statements | */ /* %-----------------% */ /* Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --ipntr; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %-----------------------------------% */ /* | Initialize the seed of the LAPACK | */ /* | random number generator | */ /* %-----------------------------------% */ if (inits) { iseed[0] = 1; iseed[1] = 3; iseed[2] = 5; iseed[3] = 7; inits = FALSE_; } if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ arscnd_(&t0); msglvl = debug_1.mgetv0; *ierr = 0; iter = 0; first = FALSE_; orth = FALSE_; /* %-----------------------------------------------------% */ /* | Possibly generate a random starting vector in RESID | */ /* | Use a LAPACK random number generator used by the | */ /* | matrix generation routines. | */ /* | idist = 1: uniform (0,1) distribution; | */ /* | idist = 2: uniform (-1,1) distribution; | */ /* | idist = 3: normal (0,1) distribution; | */ /* %-----------------------------------------------------% */ if (! (*initv)) { idist = 2; zlarnv_(&idist, iseed, n, &resid[1]); } /* %----------------------------------------------------------% */ /* | Force the starting vector into the range of OP to handle | */ /* | the generalized problem when B is possibly (singular). | */ /* %----------------------------------------------------------% */ arscnd_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nopx; ipntr[1] = 1; ipntr[2] = *n + 1; zcopy_(n, &resid[1], &c__1, &workd[1], &c__1); *ido = -1; goto L9000; } } /* %----------------------------------------% */ /* | Back from computing B*(initial-vector) | */ /* %----------------------------------------% */ if (first) { goto L20; } /* %-----------------------------------------------% */ /* | Back from computing B*(orthogonalized-vector) | */ /* %-----------------------------------------------% */ if (orth) { goto L40; } arscnd_(&t3); timing_1.tmvopx += t3 - t2; /* %------------------------------------------------------% */ /* | Starting vector is now in the range of OP; r = OP*r; | */ /* | Compute B-norm of starting vector. | */ /* %------------------------------------------------------% */ arscnd_(&t2); first = TRUE_; if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; zcopy_(n, &workd[*n + 1], &c__1, &resid[1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; goto L9000; } else if (*(unsigned char *)bmat == 'I') { zcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L20: if (*(unsigned char *)bmat == 'G') { arscnd_(&t3); timing_1.tmvbx += t3 - t2; } first = FALSE_; if (*(unsigned char *)bmat == 'G') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[1], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); rnorm0 = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { rnorm0 = dznrm2_(n, &resid[1], &c__1); } *rnorm = rnorm0; /* %---------------------------------------------% */ /* | Exit if this is the very first Arnoldi step | */ /* %---------------------------------------------% */ if (*j == 1) { goto L50; } /* %---------------------------------------------------------------- */ /* | Otherwise need to B-orthogonalize the starting vector against | */ /* | the current Arnoldi basis using Gram-Schmidt with iter. ref. | */ /* | This is the case where an invariant subspace is encountered | */ /* | in the middle of the Arnoldi factorization. | */ /* | | */ /* | s = V^{T}*B*r; r = r - V*s; | */ /* | | */ /* | Stopping criteria used for iter. ref. is discussed in | */ /* | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | */ /* %---------------------------------------------------------------% */ orth = TRUE_; L30: i__1 = *j - 1; zgemv_("C", n, &i__1, &c_b1, &v[v_offset], ldv, &workd[1], &c__1, &c_b2, & workd[*n + 1], &c__1, (ftnlen)1); i__1 = *j - 1; z__1.r = -1., z__1.i = -0.; zgemv_("N", n, &i__1, &z__1, &v[v_offset], ldv, &workd[*n + 1], &c__1, & c_b1, &resid[1], &c__1, (ftnlen)1); /* %----------------------------------------------------------% */ /* | Compute the B-norm of the orthogonalized starting vector | */ /* %----------------------------------------------------------% */ arscnd_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; zcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; goto L9000; } else if (*(unsigned char *)bmat == 'I') { zcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L40: if (*(unsigned char *)bmat == 'G') { arscnd_(&t3); timing_1.tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[1], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); *rnorm = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { *rnorm = dznrm2_(n, &resid[1], &c__1); } /* %--------------------------------------% */ /* | Check for further orthogonalization. | */ /* %--------------------------------------% */ if (msglvl > 2) { dvout_(&debug_1.logfil, &c__1, &rnorm0, &debug_1.ndigit, "_getv0: re" "-orthonalization ; rnorm0 is", (ftnlen)38); dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_getv0: re-o" "rthonalization ; rnorm is", (ftnlen)37); } if (*rnorm > rnorm0 * .717f) { goto L50; } ++iter; if (iter <= 1) { /* %-----------------------------------% */ /* | Perform iterative refinement step | */ /* %-----------------------------------% */ rnorm0 = *rnorm; goto L30; } else { /* %------------------------------------% */ /* | Iterative refinement step "failed" | */ /* %------------------------------------% */ i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { i__2 = jj; resid[i__2].r = 0., resid[i__2].i = 0.; /* L45: */ } *rnorm = 0.; *ierr = -1; } L50: if (msglvl > 0) { dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_getv0: B-no" "rm of initial / restarted starting vector", (ftnlen)53); } if (msglvl > 2) { zvout_(&debug_1.logfil, n, &resid[1], &debug_1.ndigit, "_getv0: init" "ial / restarted starting vector", (ftnlen)43); } *ido = 99; arscnd_(&t1); timing_1.tgetv0 += t1 - t0; L9000: return 0; /* %---------------% */ /* | End of zgetv0 | */ /* %---------------% */ } /* zgetv0_ */
/* Subroutine */ int dsaup2_(integer *ido, char *bmat, integer *n, char * which, integer *nev, integer *np, doublereal *tol, doublereal *resid, integer *mode, integer *iupd, integer *ishift, integer *mxiter, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, doublereal *ritz, doublereal *bounds, doublereal *q, integer *ldq, doublereal *workl, integer *ipntr, doublereal *workd, integer *info, ftnlen bmat_len, ftnlen which_len) { /* System generated locals */ integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2, i__3; doublereal d__1, d__2, d__3; /* Local variables */ static integer j; static real t0, t1, t2, t3; static integer kp[3], np0, nev0; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); static doublereal eps23; static integer ierr, iter; static doublereal temp; static integer nevd2; extern doublereal dnrm2_(integer *, doublereal *, integer *); static logical getv0; static integer nevm2; static logical cnorm; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *); static integer nconv; static logical initv; static doublereal rnorm; extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), ivout_(integer *, integer *, integer * , integer *, char *, ftnlen), dgetv0_(integer *, char *, integer * , logical *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen); extern doublereal dlamch_(char *, ftnlen); static integer nevbef; extern /* Subroutine */ int arscnd_(real *); static logical update; static char wprime[2]; static logical ushift; static integer kplusp, msglvl, nptemp; extern /* Subroutine */ int dsaitr_(integer *, char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, ftnlen), dsconv_(integer *, doublereal *, doublereal *, doublereal *, integer *), dseigt_(doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *), dsgets_(integer *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *, ftnlen), dsapps_( integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *), dsortr_(char *, logical *, integer *, doublereal *, doublereal *, ftnlen); /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* Parameter adjustments */ --workd; --resid; --workl; --bounds; --ritz; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --ipntr; /* Function Body */ if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ arscnd_(&t0); msglvl = debug_1.msaup2; /* %---------------------------------% */ /* | Set machine dependent constant. | */ /* %---------------------------------% */ eps23 = dlamch_("Epsilon-Machine", (ftnlen)15); eps23 = pow_dd(&eps23, &c_b3); /* %-------------------------------------% */ /* | nev0 and np0 are integer variables | */ /* | hold the initial values of NEV & NP | */ /* %-------------------------------------% */ nev0 = *nev; np0 = *np; /* %-------------------------------------% */ /* | kplusp is the bound on the largest | */ /* | Lanczos factorization built. | */ /* | nconv is the current number of | */ /* | "converged" eigenvlues. | */ /* | iter is the counter on the current | */ /* | iteration step. | */ /* %-------------------------------------% */ kplusp = nev0 + np0; nconv = 0; iter = 0; /* %--------------------------------------------% */ /* | Set flags for computing the first NEV steps | */ /* | of the Lanczos factorization. | */ /* %--------------------------------------------% */ getv0 = TRUE_; update = FALSE_; ushift = FALSE_; cnorm = FALSE_; if (*info != 0) { /* %--------------------------------------------% */ /* | User provides the initial residual vector. | */ /* %--------------------------------------------% */ initv = TRUE_; *info = 0; } else { initv = FALSE_; } } /* %---------------------------------------------% */ /* | Get a possibly random starting vector and | */ /* | force it into the range of the operator OP. | */ /* %---------------------------------------------% */ /* L10: */ if (getv0) { dgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[ 1], &rnorm, &ipntr[1], &workd[1], info, (ftnlen)1); if (*ido != 99) { goto L9000; } if (rnorm == 0.) { /* %-----------------------------------------% */ /* | The initial vector is zero. Error exit. | */ /* %-----------------------------------------% */ *info = -9; goto L1200; } getv0 = FALSE_; *ido = 0; } /* %------------------------------------------------------------% */ /* | Back from reverse communication: continue with update step | */ /* %------------------------------------------------------------% */ if (update) { goto L20; } /* %-------------------------------------------% */ /* | Back from computing user specified shifts | */ /* %-------------------------------------------% */ if (ushift) { goto L50; } /* %-------------------------------------% */ /* | Back from computing residual norm | */ /* | at the end of the current iteration | */ /* %-------------------------------------% */ if (cnorm) { goto L100; } /* %----------------------------------------------------------% */ /* | Compute the first NEV steps of the Lanczos factorization | */ /* %----------------------------------------------------------% */ dsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1); /* %---------------------------------------------------% */ /* | ido .ne. 99 implies use of reverse communication | */ /* | to compute operations involving OP and possibly B | */ /* %---------------------------------------------------% */ if (*ido != 99) { goto L9000; } if (*info > 0) { /* %-----------------------------------------------------% */ /* | dsaitr was unable to build an Lanczos factorization | */ /* | of length NEV0. INFO is returned with the size of | */ /* | the factorization built. Exit main loop. | */ /* %-----------------------------------------------------% */ *np = *info; *mxiter = iter; *info = -9999; goto L1200; } /* %--------------------------------------------------------------% */ /* | | */ /* | M A I N LANCZOS I T E R A T I O N L O O P | */ /* | Each iteration implicitly restarts the Lanczos | */ /* | factorization in place. | */ /* | | */ /* %--------------------------------------------------------------% */ L1000: ++iter; if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_saup2: ****" " Start of major iteration number ****", (ftnlen)49); } if (msglvl > 1) { ivout_(&debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_saup2: The le" "ngth of the current Lanczos factorization", (ftnlen)55); ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_saup2: Extend " "the Lanczos factorization by", (ftnlen)43); } /* %------------------------------------------------------------% */ /* | Compute NP additional steps of the Lanczos factorization. | */ /* %------------------------------------------------------------% */ *ido = 0; L20: update = TRUE_; dsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1); /* %---------------------------------------------------% */ /* | ido .ne. 99 implies use of reverse communication | */ /* | to compute operations involving OP and possibly B | */ /* %---------------------------------------------------% */ if (*ido != 99) { goto L9000; } if (*info > 0) { /* %-----------------------------------------------------% */ /* | dsaitr was unable to build an Lanczos factorization | */ /* | of length NEV0+NP0. INFO is returned with the size | */ /* | of the factorization built. Exit main loop. | */ /* %-----------------------------------------------------% */ *np = *info; *mxiter = iter; *info = -9999; goto L1200; } update = FALSE_; if (msglvl > 1) { dvout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: Cur" "rent B-norm of residual for factorization", (ftnlen)52); } /* %--------------------------------------------------------% */ /* | Compute the eigenvalues and corresponding error bounds | */ /* | of the current symmetric tridiagonal matrix. | */ /* %--------------------------------------------------------% */ dseigt_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritz[1], &bounds[1], & workl[1], &ierr); if (ierr != 0) { *info = -8; goto L1200; } /* %----------------------------------------------------% */ /* | Make a copy of eigenvalues and corresponding error | */ /* | bounds obtained from _seigt. | */ /* %----------------------------------------------------% */ dcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1); dcopy_(&kplusp, &bounds[1], &c__1, &workl[(kplusp << 1) + 1], &c__1); /* %---------------------------------------------------% */ /* | Select the wanted Ritz values and their bounds | */ /* | to be used in the convergence test. | */ /* | The selection is based on the requested number of | */ /* | eigenvalues instead of the current NEV and NP to | */ /* | prevent possible misconvergence. | */ /* | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | */ /* | * Shifts := RITZ(1:NP) := WORKL(1:NP) | */ /* %---------------------------------------------------% */ *nev = nev0; *np = np0; dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (ftnlen) 2); /* %-------------------% */ /* | Convergence test. | */ /* %-------------------% */ dcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1); dsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv); if (msglvl > 2) { kp[0] = *nev; kp[1] = *np; kp[2] = nconv; ivout_(&debug_1.logfil, &c__3, kp, &debug_1.ndigit, "_saup2: NEV, NP" ", NCONV are", (ftnlen)26); dvout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_saup2:" " The eigenvalues of H", (ftnlen)28); dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_saup" "2: Ritz estimates of the current NCV Ritz values", (ftnlen)53) ; } /* %---------------------------------------------------------% */ /* | Count the number of unwanted Ritz values that have zero | */ /* | Ritz estimates. If any Ritz estimates are equal to zero | */ /* | then a leading block of H of order equal to at least | */ /* | the number of Ritz values with zero Ritz estimates has | */ /* | split off. None of these Ritz values may be removed by | */ /* | shifting. Decrease NP the number of shifts to apply. If | */ /* | no shifts may be applied, then prepare to exit | */ /* %---------------------------------------------------------% */ nptemp = *np; i__1 = nptemp; for (j = 1; j <= i__1; ++j) { if (bounds[j] == 0.) { --(*np); ++(*nev); } /* L30: */ } if (nconv >= nev0 || iter > *mxiter || *np == 0) { /* %------------------------------------------------% */ /* | Prepare to exit. Put the converged Ritz values | */ /* | and corresponding bounds in RITZ(1:NCONV) and | */ /* | BOUNDS(1:NCONV) respectively. Then sort. Be | */ /* | careful when NCONV > NP since we don't want to | */ /* | swap overlapping locations. | */ /* %------------------------------------------------% */ if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %-----------------------------------------------------% */ /* | Both ends of the spectrum are requested. | */ /* | Sort the eigenvalues into algebraically decreasing | */ /* | order first then swap low end of the spectrum next | */ /* | to high end in appropriate locations. | */ /* | NOTE: when np < floor(nev/2) be careful not to swap | */ /* | overlapping locations. | */ /* %-----------------------------------------------------% */ s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2); dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2) ; nevd2 = nev0 / 2; nevm2 = nev0 - nevd2; if (*nev > 1) { i__1 = min(nevd2,*np); /* Computing MAX */ i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1; dswap_(&i__1, &ritz[nevm2 + 1], &c__1, &ritz[max(i__2,i__3)], &c__1); i__1 = min(nevd2,*np); /* Computing MAX */ i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1; dswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2, i__3)], &c__1); } } else { /* %--------------------------------------------------% */ /* | LM, SM, LA, SA case. | */ /* | Sort the eigenvalues of H into the an order that | */ /* | is opposite to WHICH, and apply the resulting | */ /* | order to BOUNDS. The eigenvalues are sorted so | */ /* | that the wanted part are always within the first | */ /* | NEV locations. | */ /* %--------------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2); } dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2) ; } /* %--------------------------------------------------% */ /* | Scale the Ritz estimate of each Ritz value | */ /* | by 1 / max(eps23,magnitude of the Ritz value). | */ /* %--------------------------------------------------% */ i__1 = nev0; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1)); temp = max(d__2,d__3); bounds[j] /= temp; /* L35: */ } /* %----------------------------------------------------% */ /* | Sort the Ritz values according to the scaled Ritz | */ /* | esitmates. This will push all the converged ones | */ /* | towards the front of ritzr, ritzi, bounds | */ /* | (in the case when NCONV < NEV.) | */ /* %----------------------------------------------------% */ s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2); dsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1], (ftnlen)2); /* %----------------------------------------------% */ /* | Scale the Ritz estimate back to its original | */ /* | value. | */ /* %----------------------------------------------% */ i__1 = nev0; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1)); temp = max(d__2,d__3); bounds[j] *= temp; /* L40: */ } /* %--------------------------------------------------% */ /* | Sort the "converged" Ritz values again so that | */ /* | the "threshold" values and their associated Ritz | */ /* | estimates appear at the appropriate position in | */ /* | ritz and bound. | */ /* %--------------------------------------------------% */ if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %------------------------------------------------% */ /* | Sort the "converged" Ritz values in increasing | */ /* | order. The "threshold" values are in the | */ /* | middle. | */ /* %------------------------------------------------% */ s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2); dsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2); } else { /* %----------------------------------------------% */ /* | In LM, SM, LA, SA case, sort the "converged" | */ /* | Ritz values according to WHICH so that the | */ /* | "threshold" value appears at the front of | */ /* | ritz. | */ /* %----------------------------------------------% */ dsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2); } /* %------------------------------------------% */ /* | Use h( 1,1 ) as storage to communicate | */ /* | rnorm to _seupd if needed | */ /* %------------------------------------------% */ h__[h_dim1 + 1] = rnorm; if (msglvl > 1) { dvout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_sa" "up2: Sorted Ritz values.", (ftnlen)27); dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_saup2: Sorted ritz estimates.", (ftnlen)30); } /* %------------------------------------% */ /* | Max iterations have been exceeded. | */ /* %------------------------------------% */ if (iter > *mxiter && nconv < *nev) { *info = 1; } /* %---------------------% */ /* | No shifts to apply. | */ /* %---------------------% */ if (*np == 0 && nconv < nev0) { *info = 2; } *np = nconv; goto L1100; } else if (nconv < *nev && *ishift == 1) { /* %---------------------------------------------------% */ /* | Do not have all the requested eigenvalues yet. | */ /* | To prevent possible stagnation, adjust the number | */ /* | of Ritz values and the shifts. | */ /* %---------------------------------------------------% */ nevbef = *nev; /* Computing MIN */ i__1 = nconv, i__2 = *np / 2; *nev += min(i__1,i__2); if (*nev == 1 && kplusp >= 6) { *nev = kplusp / 2; } else if (*nev == 1 && kplusp > 2) { *nev = 2; } *np = kplusp - *nev; /* %---------------------------------------% */ /* | If the size of NEV was just increased | */ /* | resort the eigenvalues. | */ /* %---------------------------------------% */ if (nevbef < *nev) { dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], ( ftnlen)2); } } if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_saup2: no." " of \"converged\" Ritz values at this iter.", (ftnlen)52); if (msglvl > 1) { kp[0] = *nev; kp[1] = *np; ivout_(&debug_1.logfil, &c__2, kp, &debug_1.ndigit, "_saup2: NEV" " and NP are", (ftnlen)22); dvout_(&debug_1.logfil, nev, &ritz[*np + 1], &debug_1.ndigit, "_saup2: \"wanted\" Ritz values.", (ftnlen)29); dvout_(&debug_1.logfil, nev, &bounds[*np + 1], &debug_1.ndigit, "_saup2: Ritz estimates of the \"wanted\" values ", ( ftnlen)46); } } if (*ishift == 0) { /* %-----------------------------------------------------% */ /* | User specified shifts: reverse communication to | */ /* | compute the shifts. They are returned in the first | */ /* | NP locations of WORKL. | */ /* %-----------------------------------------------------% */ ushift = TRUE_; *ido = 3; goto L9000; } L50: /* %------------------------------------% */ /* | Back from reverse communication; | */ /* | User specified shifts are returned | */ /* | in WORKL(1:*NP) | */ /* %------------------------------------% */ ushift = FALSE_; /* %---------------------------------------------------------% */ /* | Move the NP shifts to the first NP locations of RITZ to | */ /* | free up WORKL. This is for the non-exact shift case; | */ /* | in the exact shift case, dsgets already handles this. | */ /* %---------------------------------------------------------% */ if (*ishift == 0) { dcopy_(np, &workl[1], &c__1, &ritz[1], &c__1); } if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_saup2: The num" "ber of shifts to apply ", (ftnlen)38); dvout_(&debug_1.logfil, np, &workl[1], &debug_1.ndigit, "_saup2: shi" "fts selected", (ftnlen)23); if (*ishift == 1) { dvout_(&debug_1.logfil, np, &bounds[1], &debug_1.ndigit, "_saup2" ": corresponding Ritz estimates", (ftnlen)36); } } /* %---------------------------------------------------------% */ /* | Apply the NP0 implicit shifts by QR bulge chasing. | */ /* | Each shift is applied to the entire tridiagonal matrix. | */ /* | The first 2*N locations of WORKD are used as workspace. | */ /* | After dsapps is done, we have a Lanczos | */ /* | factorization of length NEV. | */ /* %---------------------------------------------------------% */ dsapps_(n, nev, np, &ritz[1], &v[v_offset], ldv, &h__[h_offset], ldh, & resid[1], &q[q_offset], ldq, &workd[1]); /* %---------------------------------------------% */ /* | Compute the B-norm of the updated residual. | */ /* | Keep B*RESID in WORKD(1:N) to be used in | */ /* | the first step of the next call to dsaitr. | */ /* %---------------------------------------------% */ cnorm = TRUE_; arscnd_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; dcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; /* %----------------------------------% */ /* | Exit in order to compute B*RESID | */ /* %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { dcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L100: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(1:N) := B*RESID | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { arscnd_(&t3); timing_1.tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { rnorm = ddot_(n, &resid[1], &c__1, &workd[1], &c__1); rnorm = sqrt((abs(rnorm))); } else if (*(unsigned char *)bmat == 'I') { rnorm = dnrm2_(n, &resid[1], &c__1); } cnorm = FALSE_; /* L130: */ if (msglvl > 2) { dvout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: B-n" "orm of residual for NEV factorization", (ftnlen)48); dvout_(&debug_1.logfil, nev, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit, "_saup2: main diagonal of compressed H matrix", (ftnlen)44); i__1 = *nev - 1; dvout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit, "_saup2: subdiagonal of compressed H matrix", (ftnlen)42); } goto L1000; /* %---------------------------------------------------------------% */ /* | | */ /* | E N D O F M A I N I T E R A T I O N L O O P | */ /* | | */ /* %---------------------------------------------------------------% */ L1100: *mxiter = iter; *nev = nconv; L1200: *ido = 99; /* %------------% */ /* | Error exit | */ /* %------------% */ arscnd_(&t1); timing_1.tsaup2 = t1 - t0; L9000: return 0; /* %---------------% */ /* | End of dsaup2 | */ /* %---------------% */ } /* dsaup2_ */
/* Subroutine */ int dneigh_(doublereal *rnorm, integer *n, doublereal *h__, integer *ldh, doublereal *ritzr, doublereal *ritzi, doublereal * bounds, doublereal *q, integer *ldq, doublereal *workl, integer *ierr) { /* System generated locals */ integer h_dim1, h_offset, q_dim1, q_offset, i__1; doublereal d__1, d__2; /* Local variables */ static integer i__; static real t0, t1; static doublereal vl[1], temp; extern doublereal dnrm2_(integer *, doublereal *, integer *); extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); static integer iconj; extern /* Subroutine */ int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen), dmout_(integer *, integer *, integer *, doublereal *, integer *, integer *, char *, ftnlen), dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen); extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlaqrb_(logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *), second_(real *); static logical select[1]; static integer msglvl; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, ftnlen), dtrevc_(char *, char *, logical *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *, ftnlen, ftnlen); /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %------------------------% */ /* | Local Scalars & Arrays | */ /* %------------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ /* Parameter adjustments */ --workl; --bounds; --ritzi; --ritzr; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; /* Function Body */ second_(&t0); msglvl = debug_1.mneigh; if (msglvl > 2) { dmout_(&debug_1.logfil, n, n, &h__[h_offset], ldh, &debug_1.ndigit, "_neigh: Entering upper Hessenberg matrix H ", (ftnlen)43); } /* %-----------------------------------------------------------% */ /* | 1. Compute the eigenvalues, the last components of the | */ /* | corresponding Schur vectors and the full Schur form T | */ /* | of the current upper Hessenberg matrix H. | */ /* | dlaqrb returns the full Schur form of H in WORKL(1:N**2) | */ /* | and the last components of the Schur vectors in BOUNDS. | */ /* %-----------------------------------------------------------% */ dlacpy_("All", n, n, &h__[h_offset], ldh, &workl[1], n, (ftnlen)3); dlaqrb_(&c_true, n, &c__1, n, &workl[1], n, &ritzr[1], &ritzi[1], &bounds[ 1], ierr); if (*ierr != 0) { goto L9000; } if (msglvl > 1) { dvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: las" "t row of the Schur matrix for H", (ftnlen)42); } /* %-----------------------------------------------------------% */ /* | 2. Compute the eigenvectors of the full Schur form T and | */ /* | apply the last components of the Schur vectors to get | */ /* | the last components of the corresponding eigenvectors. | */ /* | Remember that if the i-th and (i+1)-st eigenvalues are | */ /* | complex conjugate pairs, then the real & imaginary part | */ /* | of the eigenvector components are split across adjacent | */ /* | columns of Q. | */ /* %-----------------------------------------------------------% */ dtrevc_("R", "A", select, n, &workl[1], n, vl, n, &q[q_offset], ldq, n, n, &workl[*n * *n + 1], ierr, (ftnlen)1, (ftnlen)1); if (*ierr != 0) { goto L9000; } /* %------------------------------------------------% */ /* | Scale the returning eigenvectors so that their | */ /* | euclidean norms are all one. LAPACK subroutine | */ /* | dtrevc returns each eigenvector normalized so | */ /* | that the element of largest magnitude has | */ /* | magnitude 1; here the magnitude of a complex | */ /* | number (x,y) is taken to be |x| + |y|. | */ /* %------------------------------------------------% */ iconj = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = ritzi[i__], abs(d__1)) <= 0.) { /* %----------------------% */ /* | Real eigenvalue case | */ /* %----------------------% */ temp = dnrm2_(n, &q[i__ * q_dim1 + 1], &c__1); d__1 = 1. / temp; dscal_(n, &d__1, &q[i__ * q_dim1 + 1], &c__1); } else { /* %-------------------------------------------% */ /* | Complex conjugate pair case. Note that | */ /* | since the real and imaginary part of | */ /* | the eigenvector are stored in consecutive | */ /* | columns, we further normalize by the | */ /* | square root of two. | */ /* %-------------------------------------------% */ if (iconj == 0) { d__1 = dnrm2_(n, &q[i__ * q_dim1 + 1], &c__1); d__2 = dnrm2_(n, &q[(i__ + 1) * q_dim1 + 1], &c__1); temp = dlapy2_(&d__1, &d__2); d__1 = 1. / temp; dscal_(n, &d__1, &q[i__ * q_dim1 + 1], &c__1); d__1 = 1. / temp; dscal_(n, &d__1, &q[(i__ + 1) * q_dim1 + 1], &c__1); iconj = 1; } else { iconj = 0; } } /* L10: */ } dgemv_("T", n, n, &c_b18, &q[q_offset], ldq, &bounds[1], &c__1, &c_b20, & workl[1], &c__1, (ftnlen)1); if (msglvl > 1) { dvout_(&debug_1.logfil, n, &workl[1], &debug_1.ndigit, "_neigh: Last" " row of the eigenvector matrix for H", (ftnlen)48); } /* %----------------------------% */ /* | Compute the Ritz estimates | */ /* %----------------------------% */ iconj = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = ritzi[i__], abs(d__1)) <= 0.) { /* %----------------------% */ /* | Real eigenvalue case | */ /* %----------------------% */ bounds[i__] = *rnorm * (d__1 = workl[i__], abs(d__1)); } else { /* %-------------------------------------------% */ /* | Complex conjugate pair case. Note that | */ /* | since the real and imaginary part of | */ /* | the eigenvector are stored in consecutive | */ /* | columns, we need to take the magnitude | */ /* | of the last components of the two vectors | */ /* %-------------------------------------------% */ if (iconj == 0) { bounds[i__] = *rnorm * dlapy2_(&workl[i__], &workl[i__ + 1]); bounds[i__ + 1] = bounds[i__]; iconj = 1; } else { iconj = 0; } } /* L20: */ } if (msglvl > 2) { dvout_(&debug_1.logfil, n, &ritzr[1], &debug_1.ndigit, "_neigh: Real" " part of the eigenvalues of H", (ftnlen)41); dvout_(&debug_1.logfil, n, &ritzi[1], &debug_1.ndigit, "_neigh: Imag" "inary part of the eigenvalues of H", (ftnlen)46); dvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: Rit" "z estimates for the eigenvalues of H", (ftnlen)47); } second_(&t1); timing_1.tneigh += t1 - t0; L9000: return 0; /* %---------------% */ /* | End of dneigh | */ /* %---------------% */ } /* dneigh_ */
/* ----------------------------------------------------------------------- */ /* Subroutine */ int dseupd_(logical *rvec, char *howmny, logical *select, doublereal *d__, doublereal *z__, integer *ldz, doublereal *sigma, char *bmat, integer *n, char *which, integer *nev, doublereal *tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl, integer *lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len, ftnlen which_len) { /* System generated locals */ integer v_dim1, v_offset, z_dim1, z_offset, i__1; doublereal d__1, d__2, d__3; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); double pow_dd(doublereal *, doublereal *); /* Local variables */ static integer j, k, ih, jj, iq, np, iw, ibd, ihb, ihd, ldh, ldq, irz; extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); static integer mode; static doublereal eps23; static integer ierr; static doublereal temp; static integer next; static char type__[6]; static integer ritz; extern doublereal dnrm2_(integer *, doublereal *, integer *); static doublereal temp1; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); static logical reord; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer nconv; static doublereal rnorm; extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), ivout_(integer *, integer *, integer * , integer *, char *, ftnlen), dgeqr2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static doublereal bnorm2; extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen); extern doublereal dlamch_(char *, ftnlen); static integer bounds, msglvl, ishift, numcnv; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, ftnlen), dsesrt_(char *, logical *, integer *, doublereal *, integer *, doublereal *, integer *, ftnlen), dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen), dsortr_(char *, logical *, integer *, doublereal *, doublereal *, ftnlen), dsgets_(integer *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *, ftnlen); static integer leftptr, rghtptr; /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %------------------------% */ /* | Set default parameters | */ /* %------------------------% */ /* Parameter adjustments */ --workd; --resid; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --d__; --select; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ msglvl = debug_1.mseupd; mode = iparam[7]; nconv = iparam[5]; *info = 0; /* %--------------% */ /* | Quick return | */ /* %--------------% */ if (nconv == 0) { goto L9000; } ierr = 0; if (nconv <= 0) { ierr = -14; } if (*n <= 0) { ierr = -1; } if (*nev <= 0) { ierr = -2; } if (*ncv <= *nev || *ncv > *n) { ierr = -3; } if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", ( ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LA", (ftnlen)2, ( ftnlen)2) != 0 && s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } if (*(unsigned char *)howmny != 'A' && *(unsigned char *)howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) { ierr = -15; } if (*rvec && *(unsigned char *)howmny == 'S') { ierr = -16; } /* Computing 2nd power */ i__1 = *ncv; if (*rvec && *lworkl < i__1 * i__1 + (*ncv << 3)) { ierr = -7; } if (mode == 1 || mode == 2) { s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6); } else if (mode == 3) { s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6); } else if (mode == 4) { s_copy(type__, "BUCKLE", (ftnlen)6, (ftnlen)6); } else if (mode == 5) { s_copy(type__, "CAYLEY", (ftnlen)6, (ftnlen)6); } else { ierr = -10; } if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } if (*nev == 1 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { ierr = -12; } /* %------------% */ /* | Error Exit | */ /* %------------% */ if (ierr != 0) { *info = ierr; goto L9000; } /* %-------------------------------------------------------% */ /* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */ /* | etc... and the remaining workspace. | */ /* | Also update pointer to be used on output. | */ /* | Memory is laid out as follows: | */ /* | workl(1:2*ncv) := generated tridiagonal matrix H | */ /* | The subdiagonal is stored in workl(2:ncv). | */ /* | The dead spot is workl(1) but upon exiting | */ /* | dsaupd stores the B-norm of the last residual | */ /* | vector in workl(1). We use this !!! | */ /* | workl(2*ncv+1:2*ncv+ncv) := ritz values | */ /* | The wanted values are in the first NCONV spots. | */ /* | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | */ /* | The wanted values are in the first NCONV spots. | */ /* | NOTE: workl(1:4*ncv) is set by dsaupd and is not | */ /* | modified by dseupd . | */ /* %-------------------------------------------------------% */ /* %-------------------------------------------------------% */ /* | The following is used and set by dseupd . | */ /* | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | */ /* | computation of the eigenvectors of H. Stores | */ /* | the diagonal of H. Upon EXIT contains the NCV | */ /* | Ritz values of the original system. The first | */ /* | NCONV spots have the wanted values. If MODE = | */ /* | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | */ /* | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | */ /* | computation of the eigenvectors of H. Stores | */ /* | the subdiagonal of H. Upon EXIT contains the | */ /* | NCV corresponding Ritz estimates of the | */ /* | original system. The first NCONV spots have the | */ /* | wanted values. If MODE = 1,2 then will equal | */ /* | workl(3*ncv+1:4*ncv). | */ /* | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | */ /* | the eigenvector matrix for H as returned by | */ /* | dsteqr . Not referenced if RVEC = .False. | */ /* | Ordering follows that of workl(4*ncv+1:5*ncv) | */ /* | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | */ /* | Workspace. Needed by dsteqr and by dseupd . | */ /* | GRAND total of NCV*(NCV+8) locations. | */ /* %-------------------------------------------------------% */ ih = ipntr[5]; ritz = ipntr[6]; bounds = ipntr[7]; ldh = *ncv; ldq = *ncv; ihd = bounds + ldh; ihb = ihd + ldh; iq = ihb + ldh; iw = iq + ldh * *ncv; next = iw + (*ncv << 1); ipntr[4] = next; ipntr[8] = ihd; ipntr[9] = ihb; ipntr[10] = iq; /* %----------------------------------------% */ /* | irz points to the Ritz values computed | */ /* | by _seigt before exiting _saup2. | */ /* | ibd points to the Ritz estimates | */ /* | computed by _seigt before exiting | */ /* | _saup2. | */ /* %----------------------------------------% */ irz = ipntr[11] + *ncv; ibd = irz + *ncv; /* %---------------------------------% */ /* | Set machine dependent constant. | */ /* %---------------------------------% */ eps23 = dlamch_("Epsilon-Machine", (ftnlen)15); eps23 = pow_dd(&eps23, &c_b21); /* %---------------------------------------% */ /* | RNORM is B-norm of the RESID(1:N). | */ /* | BNORM2 is the 2 norm of B*RESID(1:N). | */ /* | Upon exit of dsaupd WORKD(1:N) has | */ /* | B*RESID(1:N). | */ /* %---------------------------------------% */ rnorm = workl[ih]; if (*(unsigned char *)bmat == 'I') { bnorm2 = rnorm; } else if (*(unsigned char *)bmat == 'G') { bnorm2 = dnrm2_(n, &workd[1], &c__1); } if (msglvl > 2) { dvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seupd: " "Ritz values passed in from _SAUPD.", (ftnlen)42); dvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_seupd: " "Ritz estimates passed in from _SAUPD.", (ftnlen)45); } if (*rvec) { reord = FALSE_; /* %---------------------------------------------------% */ /* | Use the temporary bounds array to store indices | */ /* | These will be used to mark the select array later | */ /* %---------------------------------------------------% */ i__1 = *ncv; for (j = 1; j <= i__1; ++j) { workl[bounds + j - 1] = (doublereal) j; select[j] = FALSE_; /* L10: */ } /* %-------------------------------------% */ /* | Select the wanted Ritz values. | */ /* | Sort the Ritz values so that the | */ /* | wanted ones appear at the tailing | */ /* | NEV positions of workl(irr) and | */ /* | workl(iri). Move the corresponding | */ /* | error estimates in workl(bound) | */ /* | accordingly. | */ /* %-------------------------------------% */ np = *ncv - *nev; ishift = 0; dsgets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], &workl[ 1], (ftnlen)2); if (msglvl > 2) { dvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seu" "pd: Ritz values after calling _SGETS.", (ftnlen)41); dvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit, "_seupd: Ritz value indices after calling _SGETS.", ( ftnlen)48); } /* %-----------------------------------------------------% */ /* | Record indices of the converged wanted Ritz values | */ /* | Mark the select array for possible reordering | */ /* %-----------------------------------------------------% */ numcnv = 0; i__1 = *ncv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + *ncv - j], abs(d__1)); temp1 = max(d__2,d__3); jj = (integer) workl[bounds + *ncv - j]; if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) { select[jj] = TRUE_; ++numcnv; if (jj > *nev) { reord = TRUE_; } } /* L11: */ } /* %-----------------------------------------------------------% */ /* | Check the count (numcnv) of converged Ritz values with | */ /* | the number (nconv) reported by _saupd. If these two | */ /* | are different then there has probably been an error | */ /* | caused by incorrect passing of the _saupd data. | */ /* %-----------------------------------------------------------% */ if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_seupd" ": Number of specified eigenvalues", (ftnlen)39); ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_seupd:" " Number of \"converged\" eigenvalues", (ftnlen)41); } if (numcnv != nconv) { *info = -17; goto L9000; } /* %-----------------------------------------------------------% */ /* | Call LAPACK routine _steqr to compute the eigenvalues and | */ /* | eigenvectors of the final symmetric tridiagonal matrix H. | */ /* | Initialize the eigenvector matrix Q to the identity. | */ /* %-----------------------------------------------------------% */ i__1 = *ncv - 1; dcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1); dcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1); dsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, & workl[iw], &ierr, (ftnlen)8); if (ierr != 0) { *info = -8; goto L9000; } if (msglvl > 1) { dcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1); dvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seu" "pd: NCV Ritz values of the final H matrix", (ftnlen)45); dvout_(&debug_1.logfil, ncv, &workl[iw], &debug_1.ndigit, "_seup" "d: last row of the eigenvector matrix for H", (ftnlen)48); } if (reord) { /* %---------------------------------------------% */ /* | Reordered the eigenvalues and eigenvectors | */ /* | computed by _steqr so that the "converged" | */ /* | eigenvalues appear in the first NCONV | */ /* | positions of workl(ihd), and the associated | */ /* | eigenvectors appear in the first NCONV | */ /* | columns. | */ /* %---------------------------------------------% */ leftptr = 1; rghtptr = *ncv; if (*ncv == 1) { goto L30; } L20: if (select[leftptr]) { /* %-------------------------------------------% */ /* | Search, from the left, for the first Ritz | */ /* | value that has not converged. | */ /* %-------------------------------------------% */ ++leftptr; } else if (! select[rghtptr]) { /* %----------------------------------------------% */ /* | Search, from the right, the first Ritz value | */ /* | that has converged. | */ /* %----------------------------------------------% */ --rghtptr; } else { /* %----------------------------------------------% */ /* | Swap the Ritz value on the left that has not | */ /* | converged with the Ritz value on the right | */ /* | that has converged. Swap the associated | */ /* | eigenvector of the tridiagonal matrix H as | */ /* | well. | */ /* %----------------------------------------------% */ temp = workl[ihd + leftptr - 1]; workl[ihd + leftptr - 1] = workl[ihd + rghtptr - 1]; workl[ihd + rghtptr - 1] = temp; dcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, &workl[ iw], &c__1); dcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, &workl[ iq + *ncv * (leftptr - 1)], &c__1); dcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * (rghtptr - 1)], &c__1); ++leftptr; --rghtptr; } if (leftptr < rghtptr) { goto L20; } L30: ; } if (msglvl > 2) { dvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seu" "pd: The eigenvalues of H--reordered", (ftnlen)39); } /* %----------------------------------------% */ /* | Load the converged Ritz values into D. | */ /* %----------------------------------------% */ dcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1); } else { /* %-----------------------------------------------------% */ /* | Ritz vectors not required. Load Ritz values into D. | */ /* %-----------------------------------------------------% */ dcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1); dcopy_(ncv, &workl[ritz], &c__1, &workl[ihd], &c__1); } /* %------------------------------------------------------------------% */ /* | Transform the Ritz values and possibly vectors and corresponding | */ /* | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | */ /* | (and corresponding data) are returned in ascending order. | */ /* %------------------------------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { /* %---------------------------------------------------------% */ /* | Ascending sort of wanted Ritz values, vectors and error | */ /* | bounds. Not necessary if only Ritz values are desired. | */ /* %---------------------------------------------------------% */ if (*rvec) { dsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq, ( ftnlen)2); } else { dcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1); } } else { /* %-------------------------------------------------------------% */ /* | * Make a copy of all the Ritz values. | */ /* | * Transform the Ritz values back to the original system. | */ /* | For TYPE = 'SHIFTI' the transformation is | */ /* | lambda = 1/theta + sigma | */ /* | For TYPE = 'BUCKLE' the transformation is | */ /* | lambda = sigma * theta / ( theta - 1 ) | */ /* | For TYPE = 'CAYLEY' the transformation is | */ /* | lambda = sigma * (theta + 1) / (theta - 1 ) | */ /* | where the theta are the Ritz values returned by dsaupd . | */ /* | NOTES: | */ /* | *The Ritz vectors are not affected by the transformation. | */ /* | They are only reordered. | */ /* %-------------------------------------------------------------% */ dcopy_(ncv, &workl[ihd], &c__1, &workl[iw], &c__1); if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = 1. / workl[ihd + k - 1] + *sigma; /* L40: */ } } else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = *sigma * workl[ihd + k - 1] / (workl[ihd + k - 1] - 1.); /* L50: */ } } else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = *sigma * (workl[ihd + k - 1] + 1.) / ( workl[ihd + k - 1] - 1.); /* L60: */ } } /* %-------------------------------------------------------------% */ /* | * Store the wanted NCONV lambda values into D. | */ /* | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | */ /* | into ascending order and apply sort to the NCONV theta | */ /* | values in the transformed system. We will need this to | */ /* | compute Ritz estimates in the original system. | */ /* | * Finally sort the lambda`s into ascending order and apply | */ /* | to Ritz vectors if wanted. Else just sort lambda`s into | */ /* | ascending order. | */ /* | NOTES: | */ /* | *workl(iw:iw+ncv-1) contain the theta ordered so that they | */ /* | match the ordering of the lambda. We`ll use them again for | */ /* | Ritz vector purification. | */ /* %-------------------------------------------------------------% */ dcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1); dsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw], (ftnlen)2); if (*rvec) { dsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq, ( ftnlen)2); } else { dcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1); d__1 = bnorm2 / rnorm; dscal_(ncv, &d__1, &workl[ihb], &c__1); dsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb], (ftnlen)2); } } /* %------------------------------------------------% */ /* | Compute the Ritz vectors. Transform the wanted | */ /* | eigenvectors of the symmetric tridiagonal H by | */ /* | the Lanczos basis matrix V. | */ /* %------------------------------------------------% */ if (*rvec && *(unsigned char *)howmny == 'A') { /* %----------------------------------------------------------% */ /* | Compute the QR factorization of the matrix representing | */ /* | the wanted invariant subspace located in the first NCONV | */ /* | columns of workl(iq,ldq). | */ /* %----------------------------------------------------------% */ dgeqr2_(ncv, &nconv, &workl[iq], &ldq, &workl[iw + *ncv], &workl[ihb], &ierr); /* %--------------------------------------------------------% */ /* | * Postmultiply V by Q. | */ /* | * Copy the first NCONV columns of VQ into Z. | */ /* | The N by NCONV matrix Z is now a matrix representation | */ /* | of the approximate invariant subspace associated with | */ /* | the Ritz values in workl(ihd). | */ /* %--------------------------------------------------------% */ dorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], &ldq, & workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], &ierr, ( ftnlen)5, (ftnlen)11); dlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, ( ftnlen)3); /* %-----------------------------------------------------% */ /* | In order to compute the Ritz estimates for the Ritz | */ /* | values in both systems, need the last row of the | */ /* | eigenvector matrix. Remember, it`s in factored form | */ /* %-----------------------------------------------------% */ i__1 = *ncv - 1; for (j = 1; j <= i__1; ++j) { workl[ihb + j - 1] = 0.; /* L65: */ } workl[ihb + *ncv - 1] = 1.; dorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], &ldq, & workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr, (ftnlen)4, ( ftnlen)9); } else if (*rvec && *(unsigned char *)howmny == 'S') { /* Not yet implemented. See remark 2 above. */ } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && *rvec) { i__1 = *ncv; for (j = 1; j <= i__1; ++j) { workl[ihb + j - 1] = rnorm * (d__1 = workl[ihb + j - 1], abs(d__1) ); /* L70: */ } } else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && *rvec) { /* %-------------------------------------------------% */ /* | * Determine Ritz estimates of the theta. | */ /* | If RVEC = .true. then compute Ritz estimates | */ /* | of the theta. | */ /* | If RVEC = .false. then copy Ritz estimates | */ /* | as computed by dsaupd . | */ /* | * Determine Ritz estimates of the lambda. | */ /* %-------------------------------------------------% */ dscal_(ncv, &bnorm2, &workl[ihb], &c__1); if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* Computing 2nd power */ d__2 = workl[iw + k - 1]; workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1], abs(d__1)) / (d__2 * d__2); /* L80: */ } } else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* Computing 2nd power */ d__2 = workl[iw + k - 1] - 1.; workl[ihb + k - 1] = *sigma * (d__1 = workl[ihb + k - 1], abs( d__1)) / (d__2 * d__2); /* L90: */ } } else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1] / workl[iw + k - 1] * (workl[iw + k - 1] - 1.), abs(d__1)); /* L100: */ } } } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) { dvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_seupd: U" "ntransformed converged Ritz values", (ftnlen)43); dvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seup" "d: Ritz estimates of the untransformed Ritz values", (ftnlen) 55); } else if (msglvl > 1) { dvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_seupd: C" "onverged Ritz values", (ftnlen)29); dvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seup" "d: Associated Ritz estimates", (ftnlen)33); } /* %-------------------------------------------------% */ /* | Ritz vector purification step. Formally perform | */ /* | one of inverse subspace iteration. Only used | */ /* | for MODE = 3,4,5. See reference 7 | */ /* %-------------------------------------------------% */ if (*rvec && (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 || s_cmp( type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0)) { i__1 = nconv - 1; for (k = 0; k <= i__1; ++k) { workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / workl[iw + k]; /* L110: */ } } else if (*rvec && s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = nconv - 1; for (k = 0; k <= i__1; ++k) { workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / (workl[iw + k] - 1.); /* L120: */ } } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0) { dger_(n, &nconv, &c_b110, &resid[1], &c__1, &workl[iw], &c__1, &z__[ z_offset], ldz); } L9000: return 0; /* %---------------% */ /* | End of dseupd | */ /* %---------------% */ } /* dseupd_ */
/* Subroutine */ int dsgets_(integer *ishift, char *which, integer *kev, integer *np, doublereal *ritz, doublereal *bounds, doublereal *shifts, ftnlen which_len) { /* System generated locals */ integer i__1; /* Local variables */ static real t0, t1; static integer kevd2; extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), arscnd_(real *); static integer msglvl; extern /* Subroutine */ int dsortr_(char *, logical *, integer *, doublereal *, doublereal *, ftnlen); /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ /* Parameter adjustments */ --shifts; --bounds; --ritz; /* Function Body */ arscnd_(&t0); msglvl = debug_1.msgets; if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %-----------------------------------------------------% */ /* | Both ends of the spectrum are requested. | */ /* | Sort the eigenvalues into algebraically increasing | */ /* | order first then swap high end of the spectrum next | */ /* | to low end in appropriate locations. | */ /* | NOTE: when np < floor(kev/2) be careful not to swap | */ /* | overlapping locations. | */ /* %-----------------------------------------------------% */ i__1 = *kev + *np; dsortr_("LA", &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2); kevd2 = *kev / 2; if (*kev > 1) { i__1 = min(kevd2,*np); dswap_(&i__1, &ritz[1], &c__1, &ritz[max(kevd2,*np) + 1], &c__1); i__1 = min(kevd2,*np); dswap_(&i__1, &bounds[1], &c__1, &bounds[max(kevd2,*np) + 1], & c__1); } } else { /* %----------------------------------------------------% */ /* | LM, SM, LA, SA case. | */ /* | Sort the eigenvalues of H into the desired order | */ /* | and apply the resulting order to BOUNDS. | */ /* | The eigenvalues are sorted so that the wanted part | */ /* | are always in the last KEV locations. | */ /* %----------------------------------------------------% */ i__1 = *kev + *np; dsortr_(which, &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2); } if (*ishift == 1 && *np > 0) { /* %-------------------------------------------------------% */ /* | Sort the unwanted Ritz values used as shifts so that | */ /* | the ones with largest Ritz estimates are first. | */ /* | This will tend to minimize the effects of the | */ /* | forward instability of the iteration when the shifts | */ /* | are applied in subroutine dsapps. | */ /* %-------------------------------------------------------% */ dsortr_("SM", &c_true, np, &bounds[1], &ritz[1], (ftnlen)2); dcopy_(np, &ritz[1], &c__1, &shifts[1], &c__1); } arscnd_(&t1); timing_1.tsgets += t1 - t0; if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_sgets: KEV is", (ftnlen)14); ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_sgets: NP is", ( ftnlen)13); i__1 = *kev + *np; dvout_(&debug_1.logfil, &i__1, &ritz[1], &debug_1.ndigit, "_sgets: E" "igenvalues of current H matrix", (ftnlen)39); i__1 = *kev + *np; dvout_(&debug_1.logfil, &i__1, &bounds[1], &debug_1.ndigit, "_sgets:" " Associated Ritz estimates", (ftnlen)33); } return 0; /* %---------------% */ /* | End of dsgets | */ /* %---------------% */ } /* dsgets_ */
/* Subroutine */ int dnaupd_(integer *ido, char *bmat, integer *n, char * which, integer *nev, doublereal *tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl, integer *lworkl, integer *info, ftnlen bmat_len, ftnlen which_len) { /* Format strings */ static char fmt_1000[] = "(//,5x,\002===================================" "==========\002,/5x,\002= Nonsymmetric implicit Arnoldi update co" "de =\002,/5x,\002= Version Number: \002,\002 2.4\002,21x,\002 " "=\002,/5x,\002= Version Date: \002,\002 07/31/96\002,16x,\002 =" "\002,/5x,\002=============================================\002,/" "5x,\002= Summary of timing statistics =\002,/5x," "\002=============================================\002,//)"; static char fmt_1100[] = "(5x,\002Total number update iterations " " = \002,i5,/5x,\002Total number of OP*x operations " " = \002,i5,/5x,\002Total number of B*x operations = " "\002,i5,/5x,\002Total number of reorthogonalization steps = " "\002,i5,/5x,\002Total number of iterative refinement steps = " "\002,i5,/5x,\002Total number of restart steps = " "\002,i5,/5x,\002Total time in user OP*x operation = " "\002,f12.6,/5x,\002Total time in user B*x operation =" " \002,f12.6,/5x,\002Total time in Arnoldi update routine = " "\002,f12.6,/5x,\002Total time in naup2 routine =" " \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = " "\002,f12.6,/5x,\002Total time in reorthogonalization phase =" " \002,f12.6,/5x,\002Total time in (re)start vector generation = " "\002,f12.6,/5x,\002Total time in Hessenberg eig. subproblem =" " \002,f12.6,/5x,\002Total time in getting the shifts = " "\002,f12.6,/5x,\002Total time in applying the shifts =" " \002,f12.6,/5x,\002Total time in convergence testing = " "\002,f12.6,/5x,\002Total time in computing final Ritz vectors =" " \002,f12.6/)"; /* System generated locals */ integer v_dim1, v_offset, i__1, i__2; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe( void), do_fio(integer *, char *, ftnlen); /* Local variables */ static integer j; static real t0, t1; static integer nb, ih, iq, np, iw, ldh, ldq, nev0, mode, ierr, iupd, next, ritzi; extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), ivout_(integer *, integer *, integer * , integer *, char *, ftnlen); static integer ritzr; extern /* Subroutine */ int dnaup2_(integer *, char *, integer *, char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen); extern doublereal dlamch_(char *, ftnlen); extern /* Subroutine */ int second_(real *); static integer bounds, ishift, msglvl, mxiter; extern /* Subroutine */ int dstatn_(void); /* Fortran I/O blocks */ static cilist io___22 = { 0, 6, 0, fmt_1000, 0 }; static cilist io___23 = { 0, 6, 0, fmt_1100, 0 }; /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ dstatn_(); second_(&t0); msglvl = debug_1.mnaupd; /* %----------------% */ /* | Error checking | */ /* %----------------% */ ierr = 0; ishift = iparam[1]; /* levec = iparam(2) */ mxiter = iparam[3]; /* nb = iparam(4) */ nb = 1; /* %--------------------------------------------% */ /* | Revision 2 performs only implicit restart. | */ /* %--------------------------------------------% */ iupd = 1; mode = iparam[7]; if (*n <= 0) { ierr = -1; } else if (*nev <= 0) { ierr = -2; } else if (*ncv <= *nev + 1 || *ncv > *n) { ierr = -3; } else if (mxiter <= 0) { ierr = 4; } else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp( which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, ( ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } else /* if(complicated condition) */ { /* Computing 2nd power */ i__1 = *ncv; if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) { ierr = -7; } else if (mode < 1 || mode > 4) { ierr = -10; } else if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } else if (ishift < 0 || ishift > 1) { ierr = -12; } } /* %------------% */ /* | Error Exit | */ /* %------------% */ if (ierr != 0) { *info = ierr; *ido = 99; goto L9000; } /* %------------------------% */ /* | Set default parameters | */ /* %------------------------% */ if (nb <= 0) { nb = 1; } if (*tol <= 0.) { *tol = dlamch_("EpsMach", (ftnlen)7); } /* %----------------------------------------------% */ /* | NP is the number of additional steps to | */ /* | extend the length NEV Lanczos factorization. | */ /* | NEV0 is the local variable designating the | */ /* | size of the invariant subspace desired. | */ /* %----------------------------------------------% */ np = *ncv - *nev; nev0 = *nev; /* %-----------------------------% */ /* | Zero out internal workspace | */ /* %-----------------------------% */ /* Computing 2nd power */ i__2 = *ncv; i__1 = i__2 * i__2 * 3 + *ncv * 6; for (j = 1; j <= i__1; ++j) { workl[j] = 0.; /* L10: */ } /* %-------------------------------------------------------------% */ /* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */ /* | etc... and the remaining workspace. | */ /* | Also update pointer to be used on output. | */ /* | Memory is laid out as follows: | */ /* | workl(1:ncv*ncv) := generated Hessenberg matrix | */ /* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */ /* | parts of ritz values | */ /* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */ /* | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | */ /* | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | */ /* | The final workspace is needed by subroutine dneigh called | */ /* | by dnaup2. Subroutine dneigh calls LAPACK routines for | */ /* | calculating eigenvalues and the last row of the eigenvector | */ /* | matrix. | */ /* %-------------------------------------------------------------% */ ldh = *ncv; ldq = *ncv; ih = 1; ritzr = ih + ldh * *ncv; ritzi = ritzr + *ncv; bounds = ritzi + *ncv; iq = bounds + *ncv; iw = iq + ldq * *ncv; /* Computing 2nd power */ i__1 = *ncv; next = iw + i__1 * i__1 + *ncv * 3; ipntr[4] = next; ipntr[5] = ih; ipntr[6] = ritzr; ipntr[7] = ritzi; ipntr[8] = bounds; ipntr[14] = iw; } /* %-------------------------------------------------------% */ /* | Carry out the Implicitly restarted Arnoldi Iteration. | */ /* %-------------------------------------------------------% */ dnaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, & ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[ ritzr], &workl[ritzi], &workl[bounds], &workl[iq], &ldq, &workl[ iw], &ipntr[1], &workd[1], info, (ftnlen)1, (ftnlen)2); /* %--------------------------------------------------% */ /* | ido .ne. 99 implies use of reverse communication | */ /* | to compute operations involving OP or shifts. | */ /* %--------------------------------------------------% */ if (*ido == 3) { iparam[8] = np; } if (*ido != 99) { goto L9000; } iparam[3] = mxiter; iparam[5] = np; iparam[9] = timing_1.nopx; iparam[10] = timing_1.nbx; iparam[11] = timing_1.nrorth; /* %------------------------------------% */ /* | Exit if there was an informational | */ /* | error within dnaup2. | */ /* %------------------------------------% */ if (*info < 0) { goto L9000; } if (*info == 2) { *info = 3; } if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &mxiter, &debug_1.ndigit, "_naupd: Nu" "mber of update iterations taken", (ftnlen)41); ivout_(&debug_1.logfil, &c__1, &np, &debug_1.ndigit, "_naupd: Number" " of wanted \"converged\" Ritz values", (ftnlen)48); dvout_(&debug_1.logfil, &np, &workl[ritzr], &debug_1.ndigit, "_naupd" ": Real part of the final Ritz values", (ftnlen)42); dvout_(&debug_1.logfil, &np, &workl[ritzi], &debug_1.ndigit, "_naupd" ": Imaginary part of the final Ritz values", (ftnlen)47); dvout_(&debug_1.logfil, &np, &workl[bounds], &debug_1.ndigit, "_naup" "d: Associated Ritz estimates", (ftnlen)33); } second_(&t1); timing_1.tnaupd = t1 - t0; if (msglvl > 0) { /* %--------------------------------------------------------% */ /* | Version Number & Version Date are defined in version.h | */ /* %--------------------------------------------------------% */ s_wsfe(&io___22); e_wsfe(); s_wsfe(&io___23); do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&timing_1.nopx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&timing_1.nbx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&timing_1.nrorth, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&timing_1.nitref, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&timing_1.nrstrt, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&timing_1.tmvopx, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tmvbx, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tnaupd, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tnaup2, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tnaitr, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.titref, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tgetv0, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tneigh, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tngets, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tnapps, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.tnconv, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&timing_1.trvec, (ftnlen)sizeof(real)); e_wsfe(); } L9000: return 0; /* %---------------% */ /* | End of dnaupd | */ /* %---------------% */ } /* dnaupd_ */