/* ----------------------------------------------- purpose -- to write the matrix in matlab format created -- 98may01, cca ----------------------------------------------- */ void A2_writeForMatlab ( A2 *mtx, char *mtxname, FILE *fp ) { int irow, jcol, ncol, nrow ; if ( mtx == NULL || mtxname == NULL || fp == NULL ) { fprintf(stderr, "\n fatal error in A2_writeForMatlab(%p,%p,%p)" "\n bad input\n", mtx, mtxname, fp) ; spoolesFatal(); } nrow = A2_nrow(mtx) ; ncol = A2_ncol(mtx) ; for ( irow = 0 ; irow < nrow ; irow++ ) { for ( jcol = 0 ; jcol < ncol ; jcol++ ) { if ( A2_IS_REAL(mtx) ) { double value ; A2_realEntry(mtx, irow, jcol, &value) ; fprintf(fp, "\n %s(%d,%d) = %24.16e ;", mtxname, irow+1, jcol+1, value) ; } else if ( A2_IS_COMPLEX(mtx) ) { double imag, real ; A2_complexEntry(mtx, irow, jcol, &real, &imag) ; fprintf(fp, "\n %s(%d,%d) = %24.16e + %24.16e*i ;", mtxname, irow+1, jcol+1, real, imag) ; } } } return ; }
/* ---------------------------------------------------- store the factor entries of the reduced front matrix created -- 98may25, cca ---------------------------------------------------- */ void FrontMtx_QR_storeFront ( FrontMtx *frontmtx, int J, A2 *frontJ, int msglvl, FILE *msgFile ) { A2 tempA2 ; double fac, ifac, imag, real, rfac ; double *entDJJ, *entUJJ, *entUJN, *row ; int inc1, inc2, irow, jcol, ncol, ncolJ, nD, nentD, nentUJJ, nfront, nrow, nU ; int *colind, *colindJ, *firstlocs, *sizes ; SubMtx *mtx ; /* --------------- check the input --------------- */ if ( frontmtx == NULL || frontJ == NULL || (msglvl > 0 && msgFile == NULL) ) { fprintf(stderr, "\n fatal error in FrontMtx_QR_storeFront()" "\n bad input\n") ; exit(-1) ; } nfront = FrontMtx_nfront(frontmtx) ; FrontMtx_columnIndices(frontmtx, J, &ncolJ, &colindJ) ; nrow = A2_nrow(frontJ) ; ncol = A2_ncol(frontJ) ; A2_setDefaultFields(&tempA2) ; nD = FrontMtx_frontSize(frontmtx, J) ; nU = ncol - nD ; /* -------------------------------------- scale the rows and square the diagonal -------------------------------------- */ row = A2_entries(frontJ) ; if ( A2_IS_REAL(frontJ) ) { for ( irow = 0 ; irow < nD ; irow++ ) { if ( row[irow] != 0.0 ) { fac = 1./row[irow] ; for ( jcol = irow + 1 ; jcol < ncol ; jcol++ ) { row[jcol] *= fac ; } row[irow] = row[irow] * row[irow] ; } row += ncol ; } } else if ( A2_IS_COMPLEX(frontJ) ) { for ( irow = 0 ; irow < nD ; irow++ ) { real = row[2*irow] ; imag = row[2*irow+1] ; if ( real != 0.0 || imag != 0.0 ) { Zrecip(real, imag, &rfac, &ifac) ; ZVscale(ncol - irow - 1, & row[2*irow+2], rfac, ifac) ; row[2*irow] = real*real + imag*imag ; row[2*irow+1] = 0.0 ; } row += 2*ncol ; } } if ( msglvl > 3 ) { fprintf(msgFile, "\n after scaling rows of A") ; A2_writeForHumanEye(frontJ, msgFile) ; fflush(msgFile) ; } /* ------------------------- copy the diagonal entries ------------------------- */ mtx = FrontMtx_diagMtx(frontmtx, J) ; SubMtx_diagonalInfo(mtx, &nentD, &entDJJ) ; A2_subA2(&tempA2, frontJ, 0, nD-1, 0, nD-1) ; A2_copyEntriesToVector(&tempA2, nentD, entDJJ, A2_DIAGONAL, A2_BY_ROWS) ; SubMtx_columnIndices(mtx, &ncol, &colind) ; IVcopy(nD, colind, colindJ) ; if ( msglvl > 3 ) { fprintf(msgFile, "\n diagonal factor matrix") ; SubMtx_writeForHumanEye(mtx, msgFile) ; fflush(msgFile) ; } if ( (mtx = FrontMtx_upperMtx(frontmtx, J, J)) != NULL ) { /* ------------------------ copy the U_{J,J} entries ------------------------ */ SubMtx_denseSubcolumnsInfo(mtx, &nD, &nentUJJ, &firstlocs, &sizes, &entUJJ) ; A2_copyEntriesToVector(&tempA2, nentUJJ, entUJJ, A2_STRICT_UPPER, A2_BY_COLUMNS) ; SubMtx_columnIndices(mtx, &ncol, &colind) ; IVcopy(nD, colind, colindJ) ; if ( msglvl > 3 ) { fprintf(msgFile, "\n UJJ factor matrix") ; SubMtx_writeForHumanEye(mtx, msgFile) ; fflush(msgFile) ; } } if ( ncolJ > nD ) { /* ----------------------------- copy the U_{J,bnd{J}} entries ----------------------------- */ mtx = FrontMtx_upperMtx(frontmtx, J, nfront) ; SubMtx_denseInfo(mtx, &nD, &nU, &inc1, &inc2, &entUJN) ; A2_subA2(&tempA2, frontJ, 0, nD-1, nD, ncolJ-1) ; A2_copyEntriesToVector(&tempA2, nD*nU, entUJN, A2_ALL_ENTRIES, A2_BY_COLUMNS) ; SubMtx_columnIndices(mtx, &ncol, &colind) ; IVcopy(nU, colind, colindJ + nD) ; if ( msglvl > 3 ) { fprintf(msgFile, "\n UJN factor matrix") ; SubMtx_writeForHumanEye(mtx, msgFile) ; fflush(msgFile) ; } } return ; }
/* ----------------------------------------------------------- A contains the following data from the A = QR factorization A(1:ncolA,1:ncolA) = R A(j+1:nrowA,j) is v_j, the j-th householder vector, where v_j[j] = 1.0 NOTE: A and Q must be column major created -- 98dec10, cca ----------------------------------------------------------- */ void A2_computeQ ( A2 *Q, A2 *A, DV *workDV, int msglvl, FILE *msgFile ) { double *betas ; int irowA, jcolA, ncolA, nrowA ; /* --------------- check the input --------------- */ if ( Q == NULL ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n Q is NULL\n") ; exit(-1) ; } if ( A == NULL ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n A is NULL\n") ; exit(-1) ; } if ( workDV == NULL ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n workDV is NULL\n") ; exit(-1) ; } if ( msglvl > 0 && msgFile == NULL ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n msglvl > 0 and msgFile is NULL\n") ; exit(-1) ; } nrowA = A2_nrow(A) ; ncolA = A2_ncol(A) ; if ( nrowA <= 0 ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n nrowA = %d\n", nrowA) ; exit(-1) ; } if ( ncolA <= 0 ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n ncolA = %d\n", nrowA) ; exit(-1) ; } if ( nrowA != A2_nrow(Q) ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n nrowA = %d, nrowQ = %d\n", nrowA, A2_nrow(Q)) ; exit(-1) ; } if ( ncolA != A2_ncol(Q) ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n ncolA = %d, ncolQ = %d\n", ncolA, A2_ncol(Q)) ; exit(-1) ; } switch ( A->type ) { case SPOOLES_REAL : case SPOOLES_COMPLEX : break ; default : fprintf(stderr, "\n fatal error in A2_computeQ()" "\n invalid type for A\n") ; exit(-1) ; } if ( A->type != Q->type ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n A->type = %d, Q->type = %d\n", A->type, Q->type) ; exit(-1) ; } if ( A2_inc1(A) != 1 ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n A->inc1 = %d \n", A2_inc1(A)) ; exit(-1) ; } if ( A2_inc1(Q) != 1 ) { fprintf(stderr, "\n fatal error in A2_computeQ()" "\n Q->inc1 = %d, \n", A2_inc1(Q)) ; exit(-1) ; } /* -------------------------------------------------- compute the beta values, beta_j = 2./(V_j^H * V_j) -------------------------------------------------- */ DV_setSize(workDV, ncolA) ; betas = DV_entries(workDV) ; if ( A2_IS_REAL(A) ) { int irowA, jcolA ; double sum ; double *colA ; for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) { sum = 1.0 ; colA = A2_column(A, jcolA) ; for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) { sum += colA[irowA] * colA[irowA] ; } betas[jcolA] = 2./sum ; } } else { double ival, rval, sum ; double *colA ; for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) { sum = 1.0 ; colA = A2_column(A, jcolA) ; for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) { rval = colA[2*irowA] ; ival = colA[2*irowA+1] ; sum += rval*rval + ival*ival ; } betas[jcolA] = 2./sum ; } } /* ------------------------------------------- loop over the number of householder vectors ------------------------------------------- */ for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) { double *V, *X ; int jcolV ; if ( msglvl > 2 ) { fprintf(msgFile, "\n\n %% jcolA = %d", jcolA) ; fflush(msgFile) ; } /* ------------------ set X[] to e_jcolA ------------------ */ X = A2_column(Q, jcolA) ; if ( A2_IS_REAL(Q) ) { DVzero(nrowA, X) ; X[jcolA] = 1.0 ; } else { DVzero(2*nrowA, X) ; X[2*jcolA] = 1.0 ; } for ( jcolV = jcolA ; jcolV >= 0 ; jcolV-- ) { double beta ; if ( msglvl > 2 ) { fprintf(msgFile, "\n %% jcolV = %d", jcolV) ; fflush(msgFile) ; } /* ----------------------------------------------------- update X = (I - beta_jcolV * V_jcolV * V_jcolV^T)X = X - beta_jcolV * V_jcolV * V_jcolV^T * X = X - (beta_jcolV * V_jcolV^T * X) * V_jcolV ----------------------------------------------------- */ V = A2_column(A, jcolV) ; beta = betas[jcolV] ; if ( msglvl > 2 ) { fprintf(msgFile, "\n %% beta = %12.4e", beta) ; fflush(msgFile) ; } if ( A2_IS_REAL(Q) ) { double fac, sum = X[jcolV] ; int irow ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { if ( msglvl > 2 ) { fprintf(msgFile, "\n %% V[%d] = %12.4e, X[%d] = %12.4e", irow, V[irow], irow, X[irow]) ; fflush(msgFile) ; } sum += V[irow] * X[irow] ; } if ( msglvl > 2 ) { fprintf(msgFile, "\n %% sum = %12.4e", sum) ; fflush(msgFile) ; } fac = beta * sum ; if ( msglvl > 2 ) { fprintf(msgFile, "\n %% fac = %12.4e", fac) ; fflush(msgFile) ; } X[jcolV] -= fac ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { X[irow] -= fac * V[irow] ; } } else { double rfac, ifac, rsum = X[2*jcolV], isum = X[2*jcolV+1] ; int irow ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { double Vi, Vr, Xi, Xr ; Vr = V[2*irow] ; Vi = V[2*irow+1] ; Xr = X[2*irow] ; Xi = X[2*irow+1] ; rsum += Vr*Xr + Vi*Xi ; isum += Vr*Xi - Vi*Xr ; } rfac = beta * rsum ; ifac = beta * isum ; X[2*jcolV] -= rfac ; X[2*jcolV+1] -= ifac ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { double Vi, Vr ; Vr = V[2*irow] ; Vi = V[2*irow+1] ; X[2*irow] -= rfac*Vr - ifac*Vi ; X[2*irow+1] -= rfac*Vi + ifac*Vr ; } } } } return ; }
/* ----------------------------------------------------------- A contains the following data from the A = QR factorization A(1:ncolA,1:ncolA) = R A(j+1:nrowA,j) is v_j, the j-th householder vector, where v_j[j] = 1.0 we compute Y = Q^T X when A is real and Y = Q^H X when A is complex NOTE: A, Y and X must be column major. NOTE: Y and X can be the same object, in which case X is overwritten with Y created -- 98dec10, cca ----------------------------------------------------------- */ void A2_applyQT ( A2 *Y, A2 *A, A2 *X, DV *workDV, int msglvl, FILE *msgFile ) { double *betas ; int irowA, jcolA, jcolX, ncolA, ncolX, nrowA ; /* --------------- check the input --------------- */ if ( A == NULL ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n A is NULL\n") ; exit(-1) ; } if ( X == NULL ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n X is NULL\n") ; exit(-1) ; } if ( workDV == NULL ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n workDV is NULL\n") ; exit(-1) ; } if ( msglvl > 0 && msgFile == NULL ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n msglvl > 0 and msgFile is NULL\n") ; exit(-1) ; } nrowA = A2_nrow(A) ; ncolA = A2_ncol(A) ; ncolX = A2_ncol(X) ; if ( nrowA <= 0 ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n nrowA = %d\n", nrowA) ; exit(-1) ; } if ( ncolA <= 0 ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n ncolA = %d\n", nrowA) ; exit(-1) ; } if ( nrowA != A2_nrow(X) ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n nrowA = %d, nrowX = %d\n", nrowA, A2_nrow(X)) ; exit(-1) ; } switch ( A->type ) { case SPOOLES_REAL : case SPOOLES_COMPLEX : break ; default : fprintf(stderr, "\n fatal error in A2_applyQT()" "\n invalid type for A\n") ; exit(-1) ; } if ( A->type != X->type ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n A->type = %d, X->type = %d\n", A->type, X->type) ; exit(-1) ; } if ( A2_inc1(A) != 1 ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n A->inc1 = %d \n", A2_inc1(A)) ; exit(-1) ; } if ( A2_inc1(X) != 1 ) { fprintf(stderr, "\n fatal error in A2_applyQT()" "\n X->inc1 = %d, \n", A2_inc1(X)) ; exit(-1) ; } /* -------------------------------------------------- compute the beta values, beta_j = 2./(V_j^H * V_j) -------------------------------------------------- */ DV_setSize(workDV, ncolA) ; betas = DV_entries(workDV) ; if ( A2_IS_REAL(A) ) { int irowA, jcolA ; double sum ; double *colA ; for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) { sum = 1.0 ; colA = A2_column(A, jcolA) ; for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) { sum += colA[irowA] * colA[irowA] ; } betas[jcolA] = 2./sum ; } } else { double ival, rval, sum ; double *colA ; for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) { sum = 1.0 ; colA = A2_column(A, jcolA) ; for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) { rval = colA[2*irowA] ; ival = colA[2*irowA+1] ; sum += rval*rval + ival*ival ; } betas[jcolA] = 2./sum ; } } /* ------------------------------------------ loop over the number of columns in X and Y ------------------------------------------ */ for ( jcolX = 0 ; jcolX < ncolX ; jcolX++ ) { double *V, *colX, *colY ; int jcolV ; if ( msglvl > 2 ) { fprintf(msgFile, "\n\n %% jcolX = %d", jcolX) ; fflush(msgFile) ; } /* ------------------------------- copy X(:,jcolX) into Y(:,jcolX) ------------------------------- */ colY = A2_column(Y, jcolX) ; colX = A2_column(X, jcolX) ; if ( A2_IS_REAL(A) ) { DVcopy(nrowA, colY, colX) ; } else { DVcopy(2*nrowA, colY, colX) ; } for ( jcolV = 0 ; jcolV < ncolA ; jcolV++ ) { double beta ; if ( msglvl > 2 ) { fprintf(msgFile, "\n %% jcolV = %d", jcolV) ; fflush(msgFile) ; } /* ------------------------------------------------------------ update colY = (I - beta_jcolV * V_jcolV * V_jcolV^T)colY = colY - beta_jcolV * V_jcolV * V_jcolV^T * colY = colY - (beta_jcolV * V_jcolV^T * Y) * V_jcolV ------------------------------------------------------------ */ V = A2_column(A, jcolV) ; beta = betas[jcolV] ; if ( msglvl > 2 ) { fprintf(msgFile, "\n %% beta = %12.4e", beta) ; fflush(msgFile) ; } if ( A2_IS_REAL(A) ) { double fac, sum = colY[jcolV] ; int irow ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { if ( msglvl > 2 ) { fprintf(msgFile, "\n %% V[%d] = %12.4e, X[%d] = %12.4e", irow, V[irow], irow, colY[irow]) ; fflush(msgFile) ; } sum += V[irow] * colY[irow] ; } if ( msglvl > 2 ) { fprintf(msgFile, "\n %% sum = %12.4e", sum) ; fflush(msgFile) ; } fac = beta * sum ; if ( msglvl > 2 ) { fprintf(msgFile, "\n %% fac = %12.4e", fac) ; fflush(msgFile) ; } colY[jcolV] -= fac ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { colY[irow] -= fac * V[irow] ; } } else { double rfac, ifac, rsum = colY[2*jcolV], isum = colY[2*jcolV+1] ; int irow ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { double Vi, Vr, Yi, Yr ; Vr = V[2*irow] ; Vi = V[2*irow+1] ; Yr = colY[2*irow] ; Yi = colY[2*irow+1] ; rsum += Vr*Yr + Vi*Yi ; isum += Vr*Yi - Vi*Yr ; } rfac = beta * rsum ; ifac = beta * isum ; colY[2*jcolV] -= rfac ; colY[2*jcolV+1] -= ifac ; for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) { double Vi, Vr ; Vr = V[2*irow] ; Vi = V[2*irow+1] ; colY[2*irow] -= rfac*Vr - ifac*Vi ; colY[2*irow+1] -= rfac*Vi + ifac*Vr ; } } } } return ; }
/* -------------------------------------------------------------- purpose -- compute A = QR, where Q is a product of householder vectors, (I - beta_j v_j v_j^T). on return, v_j is found in the lower triangle of A, v_j(j) = 1.0. return value -- # of floating point operations created -- 98may25, cca -------------------------------------------------------------- */ double A2_QRreduce ( A2 *mtxA, DV *workDV, int msglvl, FILE *msgFile ) { A2 tempA ; double nops ; double beta0 ; double *colA, *H0, *W0 ; int inc1, inc2, jcol, lastrow, length, ncolA, nrowA, nstep ; /* --------------- check the input --------------- */ if ( mtxA == NULL || workDV == NULL || (msglvl > 0 && msgFile == NULL) ) { fprintf(stderr, "\n fatal error in A2_QRreduce()" "\n bad input\n") ; exit(-1) ; } if ( ! (A2_IS_REAL(mtxA) || A2_IS_COMPLEX(mtxA)) ) { fprintf(stderr, "\n fatal error in A2_QRreduce()" "\n matrix must be real or complex\n") ; exit(-1) ; } nrowA = A2_nrow(mtxA) ; ncolA = A2_ncol(mtxA) ; inc1 = A2_inc1(mtxA) ; inc2 = A2_inc2(mtxA) ; if ( A2_IS_REAL(mtxA) ) { DV_setSize(workDV, nrowA + ncolA) ; H0 = DV_entries(workDV) ; W0 = H0 + nrowA ; } else if ( A2_IS_COMPLEX(mtxA) ) { DV_setSize(workDV, 2*(nrowA + ncolA)) ; H0 = DV_entries(workDV) ; W0 = H0 + 2*nrowA ; } /* ------------------------------------------------- determine the number of steps = min(ncolA, nrowA) ------------------------------------------------- */ nstep = (ncolA <= nrowA) ? ncolA : nrowA ; /* ------------------- loop over the steps ------------------- */ nops = 0.0 ; for ( jcol = 0 ; jcol < nstep ; jcol++ ) { if ( msglvl > 3 ) { fprintf(msgFile, "\n %% jcol = %d", jcol) ; } /* ---------------------------------- copy the column of A into a vector and find the last nonzero element ---------------------------------- */ A2_subA2(&tempA, mtxA, jcol, nrowA-1, jcol, ncolA-1) ; length = 1 + copyIntoVec1(&tempA, H0, msglvl, msgFile) ; lastrow = jcol + length - 1 ; if ( msglvl > 5 ) { fprintf(msgFile, "\n %% return from copyIntoVec1, length = %d, lastrow = %d", length, lastrow) ; } /* ------------------------------ compute the Householder vector and place into the column of A ------------------------------ */ colA = A2_column(mtxA, jcol) ; if ( A2_IS_REAL(mtxA) ) { nops += getHouseholderVector1(SPOOLES_REAL, length, H0, &beta0, msglvl, msgFile) ; A2_subA2(&tempA, mtxA, jcol, lastrow, jcol, jcol) ; A2_setColumn(&tempA, H0, 0) ; H0[0] = 1.0 ; } else if ( A2_IS_COMPLEX(mtxA) ) { nops += getHouseholderVector1(SPOOLES_COMPLEX, length, H0, &beta0, msglvl, msgFile) ; A2_subA2(&tempA, mtxA, jcol, lastrow, jcol, jcol) ; A2_setColumn(&tempA, H0, 0) ; H0[0] = 1.0 ; H0[1] = 0.0 ; } if ( msglvl > 5 && jcol == 0 ) { fprintf(msgFile, "\n %% beta0 = %12.4e;", beta0) ; } if ( beta0 != 0.0 && jcol + 1 < ncolA ) { A2_subA2(&tempA, mtxA, jcol, lastrow, jcol+1, ncolA-1) ; /* ------------------------------------------------ compute w = v^T * A(jcol:lastrow,jcol+1:nrowA-1) ------------------------------------------------ */ if ( msglvl > 3 ) { fprintf(msgFile, "\n %% compute w") ; } nops += computeW1(&tempA, H0, W0, msglvl, msgFile) ; /* ------------------------------------------------- update A(jcol:lastrow,jcol+1:nrowA-1) -= beta*v*w ------------------------------------------------- */ if ( msglvl > 3 ) { fprintf(msgFile, "\n %% update A") ; } nops += updateA1(&tempA, H0, beta0, W0, msglvl, msgFile) ; } } return(nops) ; }