abdelrahman/agent_compositor_test
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
bb6d2eae14e7d0fd7d8733698162696d1905322d
agent_compositor_test/references/igraph-1.0.1/vendor/lapack/dsaitr.c
T
Abdelrahman Said a11edf0c53 Add graph references
2026-06-28 13:49:01 +01:00

951 lines
31 KiB
C
Raw Blame History

/* -- translated by f2c (version 20240504).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include "f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static logical c_false = FALSE_;
static doublereal c_b24 = 1.;
static doublereal c_b49 = 0.;
static doublereal c_b57 = -1.;
static integer c__2 = 2;
/* -----------------------------------------------------------------------
\BeginDoc
\Name: dsaitr
\Description:
Reverse communication interface for applying NP additional steps to
a K step symmetric Arnoldi factorization.
Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
where OP and B are as in dsaupd. The B-norm of r_{k+p} is also
computed and returned.
\Usage:
call dsaitr
( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH,
IPNTR, WORKD, INFO )
\Arguments
IDO Integer. (INPUT/OUTPUT)
Reverse communication flag.
-------------------------------------------------------------
IDO = 0: first call to the reverse communication interface
IDO = -1: compute Y = OP * X where
IPNTR(1) is the pointer into WORK for X,
IPNTR(2) is the pointer into WORK for Y.
This is for the restart phase to force the new
starting vector into the range of OP.
IDO = 1: compute Y = OP * X where
IPNTR(1) is the pointer into WORK for X,
IPNTR(2) is the pointer into WORK for Y,
IPNTR(3) is the pointer into WORK for B * X.
IDO = 2: compute Y = B * X where
IPNTR(1) is the pointer into WORK for X,
IPNTR(2) is the pointer into WORK for Y.
IDO = 99: done
-------------------------------------------------------------
When the routine is used in the "shift-and-invert" mode, the
vector B * Q is already available and does not need to be
recomputed in forming OP * Q.
BMAT Character*1. (INPUT)
BMAT specifies the type of matrix B that defines the
semi-inner product for the operator OP. See dsaupd.
B = 'I' -> standard eigenvalue problem A*x = lambda*x
B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x
N Integer. (INPUT)
Dimension of the eigenproblem.
K Integer. (INPUT)
Current order of H and the number of columns of V.
NP Integer. (INPUT)
Number of additional Arnoldi steps to take.
MODE Integer. (INPUT)
Signifies which form for "OP". If MODE=2 then
a reduction in the number of B matrix vector multiplies
is possible since the B-norm of OP*x is equivalent to
the inv(B)-norm of A*x.
RESID Double precision array of length N. (INPUT/OUTPUT)
On INPUT: RESID contains the residual vector r_{k}.
On OUTPUT: RESID contains the residual vector r_{k+p}.
RNORM Double precision scalar. (INPUT/OUTPUT)
On INPUT the B-norm of r_{k}.
On OUTPUT the B-norm of the updated residual r_{k+p}.
V Double precision N by K+NP array. (INPUT/OUTPUT)
On INPUT: V contains the Arnoldi vectors in the first K
columns.
On OUTPUT: V contains the new NP Arnoldi vectors in the next
NP columns. The first K columns are unchanged.
LDV Integer. (INPUT)
Leading dimension of V exactly as declared in the calling
program.
H Double precision (K+NP) by 2 array. (INPUT/OUTPUT)
H is used to store the generated symmetric tridiagonal matrix
with the subdiagonal in the first column starting at H(2,1)
and the main diagonal in the second column.
LDH Integer. (INPUT)
Leading dimension of H exactly as declared in the calling
program.
IPNTR Integer array of length 3. (OUTPUT)
Pointer to mark the starting locations in the WORK for
vectors used by the Arnoldi iteration.
-------------------------------------------------------------
IPNTR(1): pointer to the current operand vector X.
IPNTR(2): pointer to the current result vector Y.
IPNTR(3): pointer to the vector B * X when used in the
shift-and-invert mode. X is the current operand.
-------------------------------------------------------------
WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
Distributed array to be used in the basic Arnoldi iteration
for reverse communication. The calling program should not
use WORKD as temporary workspace during the iteration !!!!!!
On INPUT, WORKD(1:N) = B*RESID where RESID is associated
with the K step Arnoldi factorization. Used to save some
computation at the first step.
On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated
with the K+NP step Arnoldi factorization.
INFO Integer. (OUTPUT)
= 0: Normal exit.
> 0: Size of an invariant subspace of OP is found that is
less than K + NP.
\EndDoc
-----------------------------------------------------------------------
\BeginLib
\Local variables:
xxxxxx real
\Routines called:
dgetv0 ARPACK routine to generate the initial vector.
ivout ARPACK utility routine that prints integers.
dmout ARPACK utility routine that prints matrices.
dvout ARPACK utility routine that prints vectors.
dlamch LAPACK routine that determines machine constants.
dlascl LAPACK routine for careful scaling of a matrix.
dgemv Level 2 BLAS routine for matrix vector multiplication.
daxpy Level 1 BLAS that computes a vector triad.
dscal Level 1 BLAS that scales a vector.
dcopy Level 1 BLAS that copies one vector to another .
ddot Level 1 BLAS that computes the scalar product of two vectors.
dnrm2 Level 1 BLAS that computes the norm of a vector.
\Author
Danny Sorensen Phuong Vu
Richard Lehoucq CRPC / Rice University
Dept. of Computational & Houston, Texas
Applied Mathematics
Rice University
Houston, Texas
\Revision history:
xx/xx/93: Version ' 2.4'
\SCCS Information: @(#)
FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2
\Remarks
The algorithm implemented is:
restart = .false.
Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
r_{k} contains the initial residual vector even for k = 0;
Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
computed by the calling program.
betaj = rnorm ; p_{k+1} = B*r_{k} ;
For j = k+1, ..., k+np Do
1) if ( betaj < tol ) stop or restart depending on j.
if ( restart ) generate a new starting vector.
2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
p_{j} = p_{j}/betaj
3) r_{j} = OP*v_{j} where OP is defined as in dsaupd
For shift-invert mode p_{j} = B*v_{j} is already available.
wnorm = || OP*v_{j} ||
4) Compute the j-th step residual vector.
w_{j} = V_{j}^T * B * OP * v_{j}
r_{j} = OP*v_{j} - V_{j} * w_{j}
alphaj <- j-th component of w_{j}
rnorm = || r_{j} ||
betaj+1 = rnorm
If (rnorm > 0.717*wnorm) accept step and go back to 1)
5) Re-orthogonalization step:
s = V_{j}'*B*r_{j}
r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
alphaj = alphaj + s_{j};
6) Iterative refinement step:
If (rnorm1 > 0.717*rnorm) then
rnorm = rnorm1
accept step and go back to 1)
Else
rnorm = rnorm1
If this is the first time in step 6), go to 5)
Else r_{j} lies in the span of V_{j} numerically.
Set r_{j} = 0 and rnorm = 0; go to 1)
EndIf
End Do
\EndLib
-----------------------------------------------------------------------
Subroutine */ int igraphdsaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *mode, doublereal *resid, doublereal *rnorm,
doublereal *v, integer *ldv, doublereal *h__, integer *ldh, integer *
ipntr, doublereal *workd, integer *info)
{
/* Initialized data */
IGRAPH_F77_SAVE logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
IGRAPH_F77_SAVE integer j;
real t0, t1, t2, t3, t4, t5;
integer jj;
IGRAPH_F77_SAVE integer ipj, irj;
integer nbx=0;
IGRAPH_F77_SAVE integer ivj;
extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
IGRAPH_F77_SAVE integer ierr, iter;
integer nopx=0;
IGRAPH_F77_SAVE integer itry;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
doublereal temp1;
IGRAPH_F77_SAVE logical orth1, orth2, step3, step4;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *), igraphdgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
integer infol;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal xtemp[2];
real tmvbx=0;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen);
IGRAPH_F77_SAVE doublereal wnorm;
extern /* Subroutine */ int igraphivout_(integer *, integer *, integer *,
integer *, char *, ftnlen), igraphdgetv0_(integer *, char *, integer *,
logical *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
IGRAPH_F77_SAVE doublereal rnorm1;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), igrapharscnd_(real *);
integer logfil=6;
IGRAPH_F77_SAVE doublereal safmin;
integer ndigit=-3, nitref=0;
real titref=0;
integer msaitr=0;
IGRAPH_F77_SAVE integer msglvl;
real tsaitr=0;
integer nrorth=0;
IGRAPH_F77_SAVE logical rstart;
integer nrstrt=0;
real tmvopx=0;
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%---------------%
| Local Scalars |
%---------------%
%-----------------------%
| Local Array Arguments |
%-----------------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External 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) {
first = FALSE_;
/* %--------------------------------%
| safmin = safe minimum is such |
| that 1/sfmin does not overflow |
%--------------------------------% */
safmin = igraphdlamch_("safmin");
}
if (*ido == 0) {
/* %-------------------------------%
| Initialize timing statistics |
| & message level for debugging |
%-------------------------------% */
igrapharscnd_(&t0);
msglvl = msaitr;
/* %------------------------------%
| Initial call to this routine |
%------------------------------% */
*info = 0;
step3 = FALSE_;
step4 = FALSE_;
rstart = FALSE_;
orth1 = FALSE_;
orth2 = FALSE_;
/* %--------------------------------%
| Pointer to the current step of |
| the factorization to build |
%--------------------------------% */
j = *k + 1;
/* %------------------------------------------%
| Pointers used for reverse communication |
| when using WORKD. |
%------------------------------------------% */
ipj = 1;
irj = ipj + *n;
ivj = irj + *n;
}
/* %-------------------------------------------------%
| When in reverse communication mode one of: |
| STEP3, STEP4, ORTH1, ORTH2, RSTART |
| will be .true. |
| 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 |
| dgetv0. |
%-------------------------------------------------% */
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 > 2) {
igraphivout_(&logfil, &c__1, &j, &ndigit, "_saitr: generating Arnoldi vect"
"or no.", (ftnlen)37);
igraphdvout_(&logfil, &c__1, rnorm, &ndigit, "_saitr: B-norm of the curren"
"t residual =", (ftnlen)40);
}
/* %---------------------------------------------------------%
| Check for exact zero. Equivalent to determining whether |
| a j-step Arnoldi factorization is present. |
%---------------------------------------------------------% */
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) {
igraphivout_(&logfil, &c__1, &j, &ndigit, "_saitr: ****** 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 |
%---------------------------------------------% */
++nrstrt;
itry = 1;
L20:
rstart = TRUE_;
*ido = 0;
L30:
/* %--------------------------------------%
| If in reverse communication mode and |
| RSTART = .true. flow returns here. |
%--------------------------------------% */
igraphdgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1],
rnorm, &ipntr[1], &workd[1], &ierr);
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;
igrapharscnd_(&t1);
tsaitr += 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. |
%---------------------------------------------------------% */
igraphdcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
if (*rnorm >= safmin) {
temp1 = 1. / *rnorm;
igraphdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
igraphdscal_(n, &temp1, &workd[ipj], &c__1);
} else {
/* %-----------------------------------------%
| To scale both v_{j} and p_{j} carefully |
| use LAPACK routine SLASCL |
%-----------------------------------------% */
igraphdlascl_("General", &i__, &i__, rnorm, &c_b24, n, &c__1, &v[j * v_dim1
+ 1], n, &infol);
igraphdlascl_("General", &i__, &i__, rnorm, &c_b24, n, &c__1, &workd[ipj],
n, &infol);
}
/* %------------------------------------------------------%
| 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_;
++nopx;
igrapharscnd_(&t2);
igraphdcopy_(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}. |
%-----------------------------------% */
igrapharscnd_(&t3);
tmvopx += t3 - t2;
step3 = FALSE_;
/* %------------------------------------------%
| Put another copy of OP*v_{j} into RESID. |
%------------------------------------------% */
igraphdcopy_(n, &workd[irj], &c__1, &resid[1], &c__1);
/* %-------------------------------------------%
| STEP 4: Finish extending the symmetric |
| Arnoldi to length j. If MODE = 2 |
| then B*OP = B*inv(B)*A = A and |
| we don't need to compute B*OP. |
| NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is |
| assumed to have A*v_{j}. |
%-------------------------------------------% */
if (*mode == 2) {
goto L65;
}
igrapharscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++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') {
igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L60:
/* %-----------------------------------%
| Back from reverse communication; |
| WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. |
%-----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
igrapharscnd_(&t3);
tmvbx += t3 - t2;
}
step4 = FALSE_;
/* %-------------------------------------%
| The following is needed for STEP 5. |
| Compute the B-norm of OP*v_{j}. |
%-------------------------------------% */
L65:
if (*mode == 2) {
/* %----------------------------------%
| Note that the B-norm of OP*v_{j} |
| is the inv(B)-norm of A*v_{j}. |
%----------------------------------% */
wnorm = igraphddot_(n, &resid[1], &c__1, &workd[ivj], &c__1);
wnorm = sqrt((abs(wnorm)));
} else if (*(unsigned char *)bmat == 'G') {
wnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
wnorm = sqrt((abs(wnorm)));
} else if (*(unsigned char *)bmat == 'I') {
wnorm = igraphdnrm2_(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}. |
%------------------------------------------% */
if (*mode != 2) {
igraphdgemv_("T", n, &j, &c_b24, &v[v_offset], ldv, &workd[ipj], &c__1, &
c_b49, &workd[irj], &c__1);
} else if (*mode == 2) {
igraphdgemv_("T", n, &j, &c_b24, &v[v_offset], ldv, &workd[ivj], &c__1, &
c_b49, &workd[irj], &c__1);
}
/* %--------------------------------------%
| Orthgonalize r_{j} against V_{j}. |
| RESID contains OP*v_{j}. See STEP 3. |
%--------------------------------------% */
igraphdgemv_("N", n, &j, &c_b57, &v[v_offset], ldv, &workd[irj], &c__1, &c_b24,
&resid[1], &c__1);
/* %--------------------------------------%
| Extend H to have j rows and columns. |
%--------------------------------------% */
h__[j + (h_dim1 << 1)] = workd[irj + j - 1];
if (j == 1 || rstart) {
h__[j + h_dim1] = 0.;
} else {
h__[j + h_dim1] = *rnorm;
}
igrapharscnd_(&t4);
orth1 = TRUE_;
iter = 0;
igrapharscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++nbx;
igraphdcopy_(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') {
igraphdcopy_(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') {
igrapharscnd_(&t3);
tmvbx += t3 - t2;
}
orth1 = FALSE_;
/* %------------------------------%
| Compute the B-norm of r_{j}. |
%------------------------------% */
if (*(unsigned char *)bmat == 'G') {
*rnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
*rnorm = sqrt((abs(*rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = igraphdnrm2_(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} || |
%-----------------------------------------------------------% */
if (*rnorm > wnorm * .717f) {
goto L100;
}
++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) {
xtemp[0] = wnorm;
xtemp[1] = *rnorm;
igraphdvout_(&logfil, &c__2, xtemp, &ndigit, "_saitr: re-orthonalization ;"
" wnorm and rnorm are", (ftnlen)48);
}
/* %----------------------------------------------------%
| Compute V_{j}^T * B * r_{j}. |
| WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
%----------------------------------------------------% */
igraphdgemv_("T", n, &j, &c_b24, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b49,
&workd[irj], &c__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, but only |
| H(j,j) is updated. |
%----------------------------------------------% */
igraphdgemv_("N", n, &j, &c_b57, &v[v_offset], ldv, &workd[irj], &c__1, &c_b24,
&resid[1], &c__1);
if (j == 1 || rstart) {
h__[j + h_dim1] = 0.;
}
h__[j + (h_dim1 << 1)] += workd[irj + j - 1];
orth2 = TRUE_;
igrapharscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++nbx;
igraphdcopy_(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') {
igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L90:
/* %---------------------------------------------------%
| Back from reverse communication if ORTH2 = .true. |
%---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
igrapharscnd_(&t3);
tmvbx += t3 - t2;
}
/* %-----------------------------------------------------%
| Compute the B-norm of the corrected residual r_{j}. |
%-----------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
rnorm1 = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
rnorm1 = sqrt((abs(rnorm1)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm1 = igraphdnrm2_(n, &resid[1], &c__1);
}
if (msglvl > 0 && iter > 0) {
igraphivout_(&logfil, &c__1, &j, &ndigit, "_saitr: Iterative refinement fo"
"r Arnoldi residual", (ftnlen)49);
if (msglvl > 2) {
xtemp[0] = *rnorm;
xtemp[1] = rnorm1;
igraphdvout_(&logfil, &c__2, xtemp, &ndigit, "_saitr: iterative refine"
"ment ; 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 |
%--------------------------------% */
*rnorm = rnorm1;
} else {
/* %-------------------------------------------%
| Another step of iterative refinement step |
| is required. NITREF is used by stat.h |
%-------------------------------------------% */
++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) {
resid[jj] = 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_;
igrapharscnd_(&t5);
titref += t5 - t4;
/* %----------------------------------------------------------%
| Make sure the last off-diagonal element is non negative |
| If not perform a similarity transformation on H(1:j,1:j) |
| and scale v(:,j) by -1. |
%----------------------------------------------------------% */
if (h__[j + h_dim1] < 0.) {
h__[j + h_dim1] = -h__[j + h_dim1];
if (j < *k + *np) {
igraphdscal_(n, &c_b57, &v[(j + 1) * v_dim1 + 1], &c__1);
} else {
igraphdscal_(n, &c_b57, &resid[1], &c__1);
}
}
/* %------------------------------------%
| STEP 6: Update j = j+1; Continue |
%------------------------------------% */
++j;
if (j > *k + *np) {
igrapharscnd_(&t1);
tsaitr += t1 - t0;
*ido = 99;
if (msglvl > 1) {
i__1 = *k + *np;
igraphdvout_(&logfil, &i__1, &h__[(h_dim1 << 1) + 1], &ndigit, "_saitr"
": main diagonal of matrix H of step K+NP.", (ftnlen)47);
if (*k + *np > 1) {
i__1 = *k + *np - 1;
igraphdvout_(&logfil, &i__1, &h__[h_dim1 + 2], &ndigit, "_saitr: s"
"ub diagonal of matrix H of step K+NP.", (ftnlen)46);
}
}
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 dsaitr |
%---------------% */
} /* igraphdsaitr_ */
Reference in New Issue View Git Blame Copy Permalink