void solveSingleScatterers(LSMSSystemParameters &lsms, LocalTypeInfo &local,
                           std::vector<Matrix<Real> > &vr, Complex energy,
                           std::vector<NonRelativisticSingleScattererSolution> &solution,int iie)
{
// ========================== SINGLE SCATTERER STUFF
  Complex prel=std::sqrt(energy*(1.0+energy*c2inv));
  Complex pnrel=std::sqrt(energy);


  for(int i=0; i<local.num_local; i++)
    solution[i].init(lsms,local.atom[i],&local.tmatStore(iie*local.blkSizeTmatStore,i));

  if(lsms.nrelv>0) prel=pnrel;

  if(local.atom.size()>solution.size()) solution.resize(local.atom.size());

// this is not ready for multithreading yet
// else: pragma omp parallel for
  // if(lsms.global.iprint>=0) printf("calculate single scatterer solutions.\n");
  for(int i=0; i<local.atom.size(); i++)
  {
    // if(lsms.global.iprint>=1) printf("calc single scatterer %d.%d\n",comm.rank,i);
    //printf("calc single scatterer atom no. = %d\n",i);
    calculateSingleScattererSolution(lsms,local.atom[i],vr[i],energy,prel,pnrel,solution[i]);
// calculate pmat_m (needed for tr_pxtau)
    int kkrsz=local.atom[i].kkrsz;
    int kkrszsqr=kkrsz*kkrsz;
    int info;
    int ipvt[kkrsz];
    if(lsms.n_spin_cant==2 && lsms.nrel_rel==0)
    {
      local.atom[i].pmat_m[iie].resize(kkrsz,kkrsz);
      Complex *pmat = new Complex[kkrszsqr];
      Complex *wbig = new Complex[kkrszsqr];
      Complex *pmat_m_ptr=&local.atom[i].pmat_m[iie](0,0);
      cblas_zcopy(kkrszsqr,&solution[i].tmat_l(0,0,0),1,pmat,1);
      cblas_zcopy(kkrszsqr,&solution[i].tmat_l(0,0,1),1,pmat_m_ptr,1);
      zgetrf_(&kkrsz,&kkrsz,pmat_m_ptr,&kkrsz,ipvt,&info);
      zgetri_(&kkrsz,pmat_m_ptr,&kkrsz,ipvt,wbig,&kkrszsqr,&info);
//    -------------------------------------------------------------
      zgetrf_(&kkrsz,&kkrsz,pmat,&kkrsz,ipvt,&info);
      zgetri_(&kkrsz,pmat,&kkrsz,ipvt,wbig,&kkrszsqr,&info);

      for(int j=0; j<kkrszsqr; j++) pmat_m_ptr[j]-=pmat[j];

      delete [] wbig;
      delete [] pmat;
    }
  }



// ========= END SINGLE SCATTERER STUFF ======================
}
  void QuasiNewton<dcomplex>::symmNonHerDiag(int NTrial, ostream &output){
    char JOBVL = 'N';
    char JOBVR = 'V';
    int TwoNTrial = 2*NTrial;
    int *IPIV = new int[TwoNTrial];
    int INFO;

    ComplexCMMap  SSuper(this->SSuperMem, TwoNTrial,TwoNTrial);
    ComplexCMMap  ASuper(this->ASuperMem, TwoNTrial,TwoNTrial);
    ComplexCMMap    SCPY(this->SCPYMem,   TwoNTrial,TwoNTrial);
    ComplexCMMap NHrProd(this->NHrProdMem,TwoNTrial,TwoNTrial);

    SCPY = SSuper; // Copy of original matrix to use for re-orthogonalization

    // Invert the metric (maybe not needed?)
    zgetrf_(&TwoNTrial,&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,&INFO);
    zgetri_(&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,this->WORK,&this->LWORK,
            &INFO);
    delete [] IPIV;

    NHrProd = SSuper * ASuper;
//  cout << "PROD" << endl << NHrProd << endl;

    zgeev_(&JOBVL,&JOBVR,&TwoNTrial,NHrProd.data(),&TwoNTrial,this->ERMem,
           this->SSuperMem,&TwoNTrial,this->SSuperMem,&TwoNTrial,
           this->WORK,&this->LWORK,this->RWORK,&INFO);
    // Sort eigensystem using Bubble Sort
    ComplexVecMap E(this->ERMem,TwoNTrial);
    ComplexCMMap  VR(this->SSuperMem,TwoNTrial,TwoNTrial);
//  cout << endl << ER << endl;
    this->eigSrt(VR,E);
//  cout << endl << ER << endl;
  
    // Grab the "positive paired" roots (throw away other element of the pair)
    this->ERMem += NTrial;
    new (&E    ) ComplexVecMap(this->ERMem,NTrial);
    new (&SSuper) ComplexCMMap(this->SSuperMem+2*NTrial*NTrial,2*NTrial,NTrial);
    RealVecMap ER(this->RealEMem,NTrial);
    ER = E.real();

    /*
     * Re-orthogonalize the eigenvectors with respect to the metric S(R)
     * because DSYGV orthogonalzies the vectors with respect to E(R)
     * because we solve the opposite problem.
     *
     * Gramm-Schmidt
     */
    this->metBiOrth(SSuper,SCPY);

    // Separate the eigenvectors into gerade and ungerade parts
    ComplexCMMap XTSigmaR(this->XTSigmaRMem,NTrial,NTrial);
    ComplexCMMap XTSigmaL(this->XTSigmaLMem,NTrial,NTrial);
    XTSigmaR = SSuper.block(0,     0,NTrial,NTrial);
    XTSigmaL = SSuper.block(NTrial,0,NTrial,NTrial);
//  CErr();
  }
示例#3
0
	DLLEXPORT MKL_INT z_lu_inverse_factored(MKL_INT n, MKL_Complex16 a[], MKL_INT ipiv[], MKL_Complex16 work[], MKL_INT lwork)
	{
		MKL_INT i;
		for(i = 0; i < n; ++i ){
			ipiv[i] += 1;
		}

		MKL_INT info = 0;
		zgetri_(&n,a,&n,ipiv,work,&lwork,&info);

		for(i = 0; i < n; ++i ){
			ipiv[i] -= 1;
		}
		return info;
	}
示例#4
0
	DLLEXPORT MKL_INT z_lu_inverse(MKL_INT n, MKL_Complex16 a[], MKL_Complex16 work[], MKL_INT lwork)
	{
		MKL_INT* ipiv = new MKL_INT[n];
		MKL_INT info = 0;
		zgetrf_(&n,&n,a,&n,ipiv,&info);

		if (info != 0){
			delete[] ipiv;
			return info;
		}

		zgetri_(&n,a,&n,ipiv,work,&lwork,&info);
		delete[] ipiv;
		return info;
	}
示例#5
0
	DLLEXPORT int z_lu_inverse_factored(int n, doublecomplex a[], int ipiv[], doublecomplex work[], int lwork)
	{
		int i;
		for(i = 0; i < n; ++i ){
			ipiv[i] += 1;
		}

		int info = 0;
		zgetri_(&n,a,&n,ipiv,work,&lwork,&info);

		for(i = 0; i < n; ++i ){
			ipiv[i] -= 1;
		}
		return info;
	}
示例#6
0
	DLLEXPORT int z_lu_inverse(int n, doublecomplex a[], doublecomplex work[], int lwork)
	{
		int* ipiv = new int[n];
		int info = 0;
		zgetrf_(&n,&n,a,&n,ipiv,&info);

		if (info != 0){
			delete[] ipiv;
			return info;
		}

		zgetri_(&n,a,&n,ipiv,work,&lwork,&info);
		delete[] ipiv;
		return info;
	}
示例#7
0
bool inv(const cmat &X, cmat &Y)
{
  // it_assert1(X.rows() == X.cols(), "inv: matrix is not square");

  int m = X.rows(), info, lwork;
  lwork = m; // may be choosen better

  ivec p(m);
  Y = X;
  cvec work(lwork);

  zgetrf_(&m, &m, Y._data(), &m, p._data(), &info); // LU-factorization
  if (info!=0)
    return false;

  zgetri_(&m, Y._data(), &m, p._data(), work._data(), &lwork, &info);
  return (info==0);
}
void zinverma ( doubleComplex* in, doubleComplex* out, int leadDimIn )
{
   int info = 0 ;
   int* vectPivot = (int*) malloc ( sizeof(int) * (unsigned int)( leadDimIn) );
   doubleComplex* work  =  (doubleComplex*) malloc ( sizeof(doubleComplex) * (unsigned int) (leadDimIn*leadDimIn) );

   int i = 0 ;

   for ( i = 0 ; i < leadDimIn*leadDimIn ; i ++)
      {
         out[i] = in[i] ;
      }

    zgetrf_ ( &leadDimIn, &leadDimIn, out, &leadDimIn, vectPivot, &info );  
    zgetri_ ( &leadDimIn, out, &leadDimIn , vectPivot,  work , &leadDimIn , &info ); 

    free(vectPivot);
    free(work);
}
示例#9
0
文件: lapack.c 项目: yigao1983/TDDMRG
// Interface to lapack routine zgetri
// nn: nrow and ncol of A
void lapack_zgetri(int nn, dcmplx *AA, int *ipiv)
{
  int     lda, lwork, info;
  dcmplx  *work = NULL;
  
  lda = (1 > nn) ? 1 : nn;
  lwork = lda;
  
  work = (dcmplx *) calloc(lwork, sizeof(dcmplx));
  check_mem(work, "work");
  
  zgetri_(&nn, AA, &lda, ipiv, work, &lwork, &info);
  check(info == 0, "Failed zgetri, info = %d", info);
  
  freeup(work);
  
  return;
  
 error:
  if(work) freeup(work);
  abort();
}
示例#10
0
matrix inv(const matrix& A)
{	static StopWatch watch("inv(matrix)");
	watch.start();
	int N = A.nRows();
	myassert(N > 0);
	myassert(N == A.nCols());
	matrix invA(A); //destructible copy
	int ldA = A.nRows(); //leading dimension
	std::vector<int> iPivot(N); //pivot info
	int info; //error code in return
	//LU decomposition (in place):
	zgetrf_(&N, &N, invA.data(), &ldA, iPivot.data(), &info);
	if(info<0) { logPrintf("Argument# %d to LAPACK LU decomposition routine ZGETRF is invalid.\n", -info); stackTraceExit(1); }
	if(info>0) { logPrintf("LAPACK LU decomposition routine ZGETRF found input matrix to be singular at the %d'th step.\n", info); stackTraceExit(1); }
	//Compute inverse in place:
	int lWork = (64+1)*N;
	std::vector<complex> work(lWork);
	zgetri_(&N, invA.data(), &ldA, iPivot.data(), work.data(), &lWork, &info);
	if(info<0) { logPrintf("Argument# %d to LAPACK matrix inversion routine ZGETRI is invalid.\n", -info); stackTraceExit(1); }
	if(info>0) { logPrintf("LAPACK matrix inversion routine ZGETRI found input matrix to be singular at the %d'th step.\n", info); stackTraceExit(1); }
	watch.stop();
	return invA;
}
示例#11
0
文件: dlm_gel.c 项目: gitgun/dLabPro
/**
 * <p>Same as {@link dlm_invert_gel} but for complex input</p>
 *
 */
INT16 dlm_invert_gelC(COMPLEX64* A, INT32 nXA, COMPLEX64* lpnDet) {
  integer n = (integer) nXA;
  integer c__1 = 1;
  integer c_n1 = -1;
  integer info = 0;
  integer* ipiv = dlp_calloc(n, sizeof(integer));
  void* work = NULL;
  char opts[1] = { ' ' };
  extern integer ilaenv_(integer*,char*,char*,integer*,integer*,integer*,integer*,ftnlen,ftnlen);

#ifdef __MAX_TYPE_32BIT
  extern int cgetrf_(integer*,integer*,complex*,integer*,integer*,integer*);
  extern int cgetri_(integer*,complex*,integer*,integer*,complex*,integer*,integer*);
  char name[8] = { 'C', 'G', 'E', 'T', 'R', 'I' };
  integer lwork = n * ilaenv_(&c__1, name, opts, &n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
  work = dlp_calloc(lwork, sizeof(complex));
  if(!ipiv || !work) return ERR_MEM;
  cgetrf_(&n,&n,(complex*)A,&n,ipiv,&info);
  if(lpnDet != NULL) *lpnDet = (info > 0) ? CMPLX(0.0) : dlm_get_det_trfC(A, nXA, ipiv);
  cgetri_(&n,(complex*)A,&n,ipiv,work,&lwork,&info);
#else
  extern int zgetrf_(integer*,integer*,doublecomplex*,integer*,integer*,integer*);
  extern int zgetri_(integer*,doublecomplex*,integer*,integer*,doublecomplex*,integer*,integer*);
  char name[8] = { 'Z', 'G', 'E', 'T', 'R', 'I' };
  integer lwork = n * ilaenv_(&c__1, name, opts, &n, &c_n1, &c_n1, &c_n1, (ftnlen) 6, (ftnlen) 1);
  work = dlp_calloc(lwork, sizeof(doublecomplex));
  if (!ipiv || !work) return ERR_MEM;
  zgetrf_(&n, &n, (doublecomplex*) A, &n, ipiv, &info);
  if (lpnDet != NULL) *lpnDet = (info > 0) ? CMPLX(0.0) : dlm_get_det_trfC(A, nXA, ipiv);
  zgetri_(&n, (doublecomplex*) A, &n, ipiv, work, &lwork, &info);
#endif

  dlp_free(work);
  dlp_free(ipiv);
  return (info == 0) ? O_K : NOT_EXEC;
}
示例#12
0
文件: zerrge.c 项目: kstraube/hysim
/* Subroutine */ int zerrge_(char *path, integer *nunit)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2;
    doublecomplex z__1;

    /* Builtin functions */
    integer s_wsle(cilist *), e_wsle(void);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    doublecomplex a[16]	/* was [4][4] */, b[4];
    integer i__, j;
    doublereal r__[4];
    doublecomplex w[8], x[4];
    char c2[2];
    doublereal r1[4], r2[4];
    doublecomplex af[16]	/* was [4][4] */;
    integer ip[4], info;
    doublereal anrm, ccond, rcond;
    extern /* Subroutine */ int zgbtf2_(integer *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, integer *, integer *), 
	    zgetf2_(integer *, integer *, doublecomplex *, integer *, integer 
	    *, integer *), alaesm_(char *, logical *, integer *);
    extern logical lsamen_(integer *, char *, char *);
    extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer 
	    *, doublecomplex *, integer *, integer *, doublereal *, 
	    doublereal *, doublecomplex *, doublereal *, integer *), 
	    chkxer_(char *, integer *, integer *, logical *, logical *), zgecon_(char *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublecomplex *, doublereal *, 
	    integer *), zgbequ_(integer *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublereal *, doublereal *, 
	     doublereal *, doublereal *, doublereal *, integer *), zgbrfs_(
	    char *, integer *, integer *, integer *, integer *, doublecomplex 
	    *, integer *, doublecomplex *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublecomplex *, doublereal *, 
	    integer *), zgbtrf_(integer *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, integer *, integer *), 
	    zgeequ_(integer *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *), zgerfs_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *, 
	     doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublecomplex *, doublereal *, 
	    integer *), zgetrf_(integer *, integer *, doublecomplex *, 
	     integer *, integer *, integer *), zgetri_(integer *, 
	    doublecomplex *, integer *, integer *, doublecomplex *, integer *, 
	     integer *), zgbtrs_(char *, integer *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, integer *, doublecomplex *, 
	     integer *, integer *), zgetrs_(char *, integer *, 
	    integer *, doublecomplex *, integer *, integer *, doublecomplex *, 
	     integer *, integer *);

    /* Fortran I/O blocks */
    static cilist io___1 = { 0, 0, 0, 0, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZERRGE tests the error exits for the COMPLEX*16 routines */
/*  for general matrices. */

/*  Arguments */
/*  ========= */

/*  PATH    (input) CHARACTER*3 */
/*          The LAPACK path name for the routines to be tested. */

/*  NUNIT   (input) INTEGER */
/*          The unit number for output. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    infoc_1.nout = *nunit;
    io___1.ciunit = infoc_1.nout;
    s_wsle(&io___1);
    e_wsle();
    s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);

/*     Set the variables to innocuous values. */

    for (j = 1; j <= 4; ++j) {
	for (i__ = 1; i__ <= 4; ++i__) {
	    i__1 = i__ + (j << 2) - 5;
	    d__1 = 1. / (doublereal) (i__ + j);
	    d__2 = -1. / (doublereal) (i__ + j);
	    z__1.r = d__1, z__1.i = d__2;
	    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
	    i__1 = i__ + (j << 2) - 5;
	    d__1 = 1. / (doublereal) (i__ + j);
	    d__2 = -1. / (doublereal) (i__ + j);
	    z__1.r = d__1, z__1.i = d__2;
	    af[i__1].r = z__1.r, af[i__1].i = z__1.i;
/* L10: */
	}
	i__1 = j - 1;
	b[i__1].r = 0., b[i__1].i = 0.;
	r1[j - 1] = 0.;
	r2[j - 1] = 0.;
	i__1 = j - 1;
	w[i__1].r = 0., w[i__1].i = 0.;
	i__1 = j - 1;
	x[i__1].r = 0., x[i__1].i = 0.;
	ip[j - 1] = j;
/* L20: */
    }
    infoc_1.ok = TRUE_;

/*     Test error exits of the routines that use the LU decomposition */
/*     of a general matrix. */

    if (lsamen_(&c__2, c2, "GE")) {

/*        ZGETRF */

	s_copy(srnamc_1.srnamt, "ZGETRF", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
	chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
	chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGETF2 */

	s_copy(srnamc_1.srnamt, "ZGETF2", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
	chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
	chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGETRI */

	s_copy(srnamc_1.srnamt, "ZGETRI", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info);
	chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgetri_(&c__2, a, &c__1, ip, w, &c__2, &info);
	chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	zgetri_(&c__2, a, &c__2, ip, w, &c__1, &info);
	chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGETRS */

	s_copy(srnamc_1.srnamt, "ZGETRS", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
	chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
	chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
	chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	zgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
	chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 8;
	zgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
	chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGERFS */

	s_copy(srnamc_1.srnamt, "ZGERFS", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
		c__1, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
		c__1, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
		c__1, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	zgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
		c__2, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 7;
	zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
		c__2, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 10;
	zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
		c__2, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 12;
	zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
		c__1, r1, r2, w, r__, &info);
	chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGECON */

	s_copy(srnamc_1.srnamt, "ZGECON", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
		;
	chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
		;
	chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
		;
	chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGEEQU */

	s_copy(srnamc_1.srnamt, "ZGEEQU", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
	chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
	chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
	chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*     Test error exits of the routines that use the LU decomposition */
/*     of a general band matrix. */

    } else if (lsamen_(&c__2, c2, "GB")) {

/*        ZGBTRF */

	s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
	chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	zgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
	chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGBTF2 */

	s_copy(srnamc_1.srnamt, "ZGBTF2", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
	chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
	chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	zgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
	chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGBTRS */

	s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	zgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 7;
	zgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 10;
	zgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
		info);
	chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGBRFS */

	s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
		c__1, x, &c__1, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
		c__1, x, &c__1, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
		c__1, x, &c__1, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
		c__1, x, &c__1, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	zgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
		c__1, x, &c__1, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 7;
	zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
		c__2, x, &c__2, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 9;
	zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
		c__2, x, &c__2, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 12;
	zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
		c__1, x, &c__2, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 14;
	zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
		c__2, x, &c__1, r1, r2, w, r__, &info);
	chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGBCON */

	s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__, 
		 &info);
	chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__, 
		 &info);
	chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__, 
		 &info);
	chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__, 
		 &info);
	chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	zgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__, 
		 &info);
	chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        ZGBEQU */

	s_copy(srnamc_1.srnamt, "ZGBEQU", (ftnlen)6, (ftnlen)6);
	infoc_1.infot = 1;
	zgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond, 
		&anrm, &info);
	chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	zgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond, 
		&anrm, &info);
	chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	zgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, 
		&anrm, &info);
	chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	zgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, 
		&anrm, &info);
	chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	zgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond, 
		&anrm, &info);
	chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
    }

/*     Print a summary line. */

    alaesm_(path, &infoc_1.ok, &infoc_1.nout);

    return 0;

/*     End of ZERRGE */

} /* zerrge_ */
示例#13
0
/* Main program */
int main() {
        /* Locals */
        int n = N, info,i,j;
		int iter = 1;
        /* Local arrays */
	
		static complex A2[N][N];
		static complex B2[N][N];
		static complex A[N][N];
		static complex U[N][N];
		static complex b[N];
		
		
			
	    srand (1337);
        static int ipiv[N];

		int max = 0;
		int min = 0;
		int mu = 3;
		int ml = 3;
		int md = ml+mu+1;
		complex sumA = 0;
		complex sumU = 0;
		complex ratio = 0;
		
//Initialize random band matrix		
		for (i=0;i<n;i++){
			for (j=0; j<n; j++){
				A2[i][j]=0;
				B2[i][j]=0;
				U[i][j]=0;				
			}
		}

		for (j=0;j<n;j++){
			max = 0 > j-mu ? 0    : j-mu ;
			min = n < j+ml+1 ? n    : j+ml+1 ;
			for(i=max;i<min;i++){
				A2[i][j] =  ((1 - ( 20.0 * rand() / ( RAND_MAX + 1.0 ) )),(1 - ( 20.0 * rand() / ( RAND_MAX + 1.0 ))));	
			                                       }
						}


		for (i=0;i<n;i++){
				for (j=0;j<n;j++){
					A[i][j]=A2[i][j];
								}			
						}


		for (i=0;i<n;i++){
			U[i][i]=1;	
						}
/// B2(ML+MU+1+i-j,j) = A(i,j) for max(1,j-MU)<=i<=min(N,j+ML)						
		for (j=0;j<n;j++){
			max = (0 < j-mu) ? j-mu : 0    ;
			min = (n < j+ml+1) ? n    : j+ml+1 ;
			for(i=max;i<min;i++){
				B2[j][md+i-j-1]= A[j][i];			
			                     }
						}
						
				 printf( "Matrix A\n" );	
				 						for( i = 0; i < n; i++ ) {
				                for( j = 0; j < n; j++ ) printf( " (%6.2f ,%6.2f) ", A[j][i] );
				                printf( "\n" );
				        }
				 						printf( "Compressed A\n" );
				        for( i = 0; i < n; i++ ) {
				                for( j = 0; j < n; j++ ) printf( " (%6.2f, %6.2f)", B2[j][i] );
				                printf( "\n" );
				        }				
		printf( "Enter General Factor\n" );				
						for (i=0;i<iter;i++){	
//		printf( "Enter General Factor\n" );				
		zgetrf_(&n, &n, A2, &n, ipiv, &info);
//		printf( "%d",info );
//		printf( "Enter Inversion\n" );
		zgetri_( &n, A2, &n, ipiv, b, &n, &info );
//		printf( "%d",info );
//		printf( "Exit inversion\n" );
			}
		printf( "\nExit inversion\n" );				
						
		 printf( "Entering Banded Solve\n" );
		for (i=0;i<iter;i++){			
		zgbsv_( &n, &ml, &mu, &n, B2, &n, ipiv, U, &n, &info );
//		printf( "%d",info );
	     }
		 printf( "Exited Banded Solve\n" );	
		
		for (i=0;i<N;i++){
			for (j=0;j<N;j++){
				sumA = A2[j][i]+sumA;
				sumU = U[j][i]+sumU;

			}
		}
		ratio = sumA/sumU;
		printf( "Accuracy - %f\n",ratio );
		printf( "%d\n",info );

		printf( "Inversed A\n" );
		        for( i = 0; i < n; i++ ) {
		                for( j = 0; j < n; j++ ) printf( "   (%6.8f, %6.2f)", A2[j][i] );
		                printf( "\n" );
		        }
		printf( "Inversed A (solve)\n" );
		        for( i = 0; i < n; i++ ) {
		                for( j = 0; j < n; j++ ) printf( "   (%6.8f, %6.2f)", U[j][i] );
		                printf( "\n" );
		        }

        exit( 0 );
}