/*! \brief Solve system of linear equations
Subroutine to solve the matrix equation lu*x=b where l is a unit
lower triangular matrix and u is an upper triangular matrix both
of which are stored in a. the rhs vector b is input and the
solution is returned through vector b. (matrix transposed)
*/
void solve_lapack( int n, complex_array& a, int_array& ip,
complex_array& b, int64_t ndim )
{
DEBUG_TRACE("solve_lapack(" << n << "," << ndim << ")");
int info = clapack_zgetrs (CblasColMajor, CblasNoTrans,
n, 1, (void*) a.data(), ndim, ip.data(), b.data(), n);
if (0 != info) {
/*
The factorization has been completed, but the factor U is exactly singular,
and division by zero will occur if it is used to solve a system of equations.
*/
throw new nec_exception("nec++: Solving Failed: ",info);
}
}
void lu_decompose(int n, complex_array& a_in, int_array& ip, int ndim)
{
/*
cout << "atlas_a = ";
to_octave(a_in,n,ndim);
*/
// copy the input matrix a_in into a temporary array (transposing as we go)
// complex_array A(n,n);
int_array piv(n);
/* for (int row = 0; row < n; row++ )
{
int col_index = row * ndim;
for (int col = 0; col < n; col++ )
{
A.set(row,col,a_in[col_index++]);
}
}*/
int info = clapack_zgetrf (CblasColMajor, n, n,
(void*) a_in.get_ptr(), ndim, piv.get_ptr());
if (0 != info)
{
/*
The factorization has been completed, but the factor U is exactly singular,
and division by zero will occur if it is used to solve a system of equations.
*/
cout << "nec++: LU Decomposition Failed: " << info;
}
/*
IPIV (output) INTEGER array, dimension (min(M,N))
The pivot indices; for 1 <= i <= min(M,N), row i of the
matrix was interchanged with row IPIV(i).
*/
for (int j = 0; j < n; j++ )
{
ip[j] = piv[j] + 1;
}
// copy the output back into the a_in array.
/* for (int row = 0; row < n; row++ )
{
int col_index = row*ndim;
for (int col = 0; col < n; col++ )
{
a_in[col_index++] = A.get(row,col);
}
}*/
/*
cout << "atlas_solved = ";
to_octave(a_in,n,ndim);
cout << "atlas_ip = ";
to_octave(ip,n);*/
}
void cainteoir::ifft(complex_array &aData)
{
::fft(aData, 1);
float n = aData.size();
for (auto & c : aData)
{
c.re /= n;
c.im /= n;
}
}
/** factrs
For symmetric structure, transforms submatricies to form
matricies of the symmetric modes and calls routine to LU decompose
matricies.
If no symmetry [nrow = np], the routine is called to LU decompose the
complete matrix.
*/
void factrs(nec_output_file& s_output, int64_t np, int64_t nrow, complex_array& a, int_array& ip )
{
DEBUG_TRACE("factrs(" << np << "," << nrow << ")");
if (nrow == np) { // no symmetry
lu_decompose(s_output, np, a, ip, nrow );
return;
}
int num_symmetric_modes = nrow / np;
DEBUG_TRACE("\tnum_symmetric_modes = " << num_symmetric_modes);
for (int mode = 0; mode < num_symmetric_modes; mode++ ) {
int64_t mode_offset = mode * np;
complex_array a_temp = a.segment(mode_offset, a.size()-mode_offset);
int_array ip_temp = ip.segment(mode_offset, ip.size()-mode_offset);
lu_decompose(s_output, np, a_temp, ip_temp, nrow );
}
}
void matrix_setup(complex_array& A)
{ int n = 4;
A.get(0,0) = 3.0;
A.get(0,1) =1.0;
A.get(0,2) =-4.0;
A.get(0,3) =2.0;
A.get(1,0) =3.0;
A.get(1,1) =1.0;
A.get(1,2) =0.0;
A.get(1,3) =2.0;
A.get(2,0) =2.0;
A.get(2,1) =13.0;
A.get(2,2) =-1.0;
A.get(2,3) =0.0;
A.get(3,0) =-2.0;
A.get(3,1) =3.0;
A.get(3,2) =-1.0;
A.get(3,3) =4.0;
for (int i = 1; i < n; i++ )
{
for (int j = 0; j < i; j++ )
std::swap(A.get(i,j),A.get(j,i));
}
}
/**
Subroutine solves, for symmetric structures, handles the
transformation of the right hand side vector and solution
of the matrix eq.
\param neq number of equations?
\param nrh dimension of right hand vector?
*/
void solves(complex_array& a, int_array& ip, complex_array& b, int64_t neq,
int64_t nrh, int64_t np, int64_t n, int64_t mp, int64_t m, int64_t nop,
complex_array& symmetry_array)
{
DEBUG_TRACE("solves(" << neq << "," << nrh << "," << np << "," << n << ")");
DEBUG_TRACE(" ( nop=" << nop << ")");
/* Allocate some scratch memory */
complex_array scm;
scm.resize(n + 2*m);
int npeq= np+ 2*mp;
nec_float fnop = nop;
nec_float fnorm = 1.0/ fnop;
int nrow= neq;
if ( nop != 1) {
for (int ic = 0; ic < nrh; ic++ ) {
int64_t column_offset = ic*neq;
if ( (n != 0) && (m != 0) ) {
for (int i = 0; i < neq; i++ )
scm[i]= b[i+column_offset];
int j= np-1;
for (int k = 0; k < nop; k++ ) {
if ( k != 0 ) {
int ia= np-1;
for (int i = 0; i < np; i++ ) {
ia++;
j++;
b[j+column_offset]= scm[ia];
}
if ( k == (nop-1) )
continue;
} /* if ( k != 0 ) */
int mp2 = 2*mp;
int ib= n-1;
for (int i = 0; i < mp2; i++ ) {
ib++;
j++;
b[j+column_offset]= scm[ib];
}
} /* for( k = 0; k < nop; k++ ) */
} /* if ( (n != 0) && (m != 0) ) */
/* transform matrix eq. rhs vector according to symmetry modes */
for (int i = 0; i < npeq; i++ ) {
for (int k = 0; k < nop; k++ ) {
int64_t ia= i+ k* npeq;
scm[k]= b[ia+column_offset];
}
nec_complex sum_normal(scm[0]);
for (int k = 1; k < nop; k++ )
sum_normal += scm[k];
b[i+column_offset]= sum_normal * fnorm;
for (int k = 1; k < nop; k++ ) {
int ia= i+ k* npeq;
nec_complex sum(scm[0]);
for (int j = 1; j < nop; j++ )
sum += scm[j]* conj( symmetry_array[k+j*nop]);
b[ia+column_offset]= sum* fnorm;
}
} /* for( i = 0; i < npeq; i++ ) */
} /* for( ic = 0; ic < nrh; ic++ ) */
} /* if ( nop != 1) */
/* solve each mode equation */
for (int kk = 0; kk < nop; kk++ ) {
int ia= kk* npeq;
for (int ic = 0; ic < nrh; ic++ ) {
int column_offset = ic*neq;
complex_array a_sub = a.segment(ia, a.size()-ia);
complex_array b_sub = b.segment(ia+column_offset, b.size() - (ia+column_offset) );
int_array ip_sub = ip.segment(ia, ip.size()-ia);
solve( npeq, a_sub, ip_sub, b_sub, nrow );
}
} /* for( kk = 0; kk < nop; kk++ ) */
if ( nop == 1) {
return;
}
/* inverse transform the mode solutions */
for (int ic = 0; ic < nrh; ic++ ) {
int column_offset = ic*neq;
for (int i = 0; i < npeq; i++ ) {
for (int k = 0; k < nop; k++ ) {
int ia= i+ k* npeq;
scm[k]= b[ia+column_offset];
}
nec_complex sum_normal(scm[0]);
for (int k = 1; k < nop; k++ )
sum_normal += scm[k];
b[i+column_offset]= sum_normal;
for (int k = 1; k < nop; k++ ) {
int ia= i+ k* npeq;
nec_complex sum(scm[0]);
for (int j = 1; j < nop; j++ )
sum += scm[j]* symmetry_array[k+j*nop];
b[ia+column_offset]= sum;
}
} /* for( i = 0; i < npeq; i++ ) */
if ( (n == 0) || (m == 0) )
continue;
for (int i = 0; i < neq; i++ )
scm[i]= b[i+column_offset];
int j = np-1;
for (int32_t k = 0; k < nop; k++ ) {
if ( k != 0 ) {
int ia = np-1;
for (int32_t i = 0; i < np; i++ ) {
ia++;
j++;
b[ia+column_offset]= scm[j];
}
if ( k == nop)
continue;
} /* if ( k != 0 ) */
int ib = n-1;
int mp2 = 2* mp;
for (int i = 0; i < mp2; i++ ) {
ib++;
j++;
b[ib+column_offset]= scm[j];
}
} /* for( k = 0; k < nop; k++ ) */
} /* for( ic = 0; ic < nrh; ic++ ) */
}
/*! \brief Use lapack to perform LU decomposition
*/
void lu_decompose_lapack(nec_output_file& s_output, int64_t n, complex_array& a_in, int_array& ip, int64_t ndim)
{
UNUSED(s_output);
DEBUG_TRACE("lu_decompose_lapack(" << n << "," << ndim << ")");
ASSERT(n <= ndim);
#ifdef NEC_MATRIX_CHECK
cout << "atlas_a = ";
to_octave(a_in,n,ndim);
#endif
/* Un-transpose the matrix for Gauss elimination */
for (int i = 1; i < n; i++ ) {
int i_offset = i * ndim;
int j_offset = 0;
for (int j = 0; j < i; j++ ) {
nec_complex aij = a_in[i+j_offset];
a_in[i+j_offset] = a_in[j+i_offset];
a_in[j+i_offset] = aij;
j_offset += ndim;
}
}
/* Now call the LAPACK LU-Decomposition
ZGETRF computes an LU factorization of a general M-by-N matrix A
* using partial pivoting with row interchanges.
*
* The factorization has the form
* A = P * L * U
* where P is a permutation matrix, L is lower triangular with unit
* diagonal elements (lower trapezoidal if m > n), and U is upper
* triangular (upper trapezoidal if m < n).
Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the M-by-N matrix to be factored.
* On exit, the factors L and U from the factorization
* A = P*L*U; the unit diagonal elements of L are not stored.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* IPIV (output) INTEGER array, dimension (min(M,N))
* The pivot indices; for 1 <= i <= min(M,N), row i of the
* matrix was interchanged with row IPIV(i).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, and division by zero will occur if it is used
* to solve a system of equations.
*/
int info = clapack_zgetrf (CblasColMajor, n, n,
(void*) a_in.data(), ndim, ip.data());
if (0 != info) {
/*
The factorization has been completed, but the factor U is exactly singular,
and division by zero will occur if it is used to solve a system of equations.
*/
throw new nec_exception("nec++: LU Decomposition Failed: ",info);
}
#ifdef NEC_MATRIX_CHECK
cout << "atlas_solved = ";
to_octave(a_in,n,ndim);
cout << "atlas_ip = ";
to_octave(ip,n);
#endif
}
void to_octave(complex_array& a, int n, int ndim) {
to_octave(a.data(),n,ndim);
}
void lu_decompose_burke(int n, complex_array& a, int_array& ip, int ndim)
{
/*C
C Un-transpose the matrix for Gauss elimination
C
DO 12 I=2,N
DO 11 J=1,I-1
ARJ=A(I,J)
A(I,J)=A(J,I)
A(J,I)=ARJ
11 CONTINUE
12 CONTINUE
*/
// for (int i = 1; i < n; i++ )
// {
// for (int j = 0; j < i; j++ )
// std::swap(a.get(i,j),a.get(j,i));
// }
/*
IFLG=0
DO 9 R=1,N
*/
complex_array d(n);
for (int r = 0; r < n; r++ )
{
bool iflg=false;
/*C
C STEP 1
C
DO 1 K=1,N
D(K)=A(K,R)
1 CONTINUE*/
for (int k = 0; k < n; k++ )
d[k]= a.get(k,r);
/*
C
C STEPS 2 AND 3
C
RM1=R-1
IF (RM1.LT.1) GO TO 4
DO 3 J=1,RM1
PJ=IP(J)
ARJ=D(PJ)
A(J,R)=ARJ
D(PJ)=D(J)
JP1=J+1
DO 2 I=JP1,N
D(I)=D(I)-A(I,J)*ARJ
2 CONTINUE
3 CONTINUE
4 CONTINUE
*/
int rm1 = r - 1;
if (rm1 >= 0)
{
for (int j=0; j < r; j++)
{
int pj = ip[j];
nec_complex arj = d[pj];
a.set(j,r,arj);
d[pj] = d[j];
int jp1 = j + 1;
for (int i=jp1;i<n;i++)
d[i] -= a.get(i,j)*arj;
}
}
/*
C
C STEP 4
C
DMAX=REAL(D(R)*CONJG(D(R)))
IP(R)=R
RP1=R+1
IF (RP1.GT.N) GO TO 6
DO 5 I=RP1,N
ELMAG=REAL(D(I)*CONJG(D(I)))
IF (ELMAG.LT.DMAX) GO TO 5
DMAX=ELMAG
IP(R)=I
5 CONTINUE
6 CONTINUE
IF (DMAX.LT.1.E-10) IFLG=1
PR=IP(R)
A(R,R)=D(PR)
D(PR)=D(R)
*/
nec_float dmax = norm(d[r]);;
ip[r] = r;
int rp1 = r + 1;
if (rp1 < n)
{
for (int i=rp1; i<n; i++)
{
nec_float elmag = norm(d[i]);
if (elmag >= dmax)
{
dmax = elmag;
ip[r] = i;
}
}
}
if (dmax < 1e-10)
iflg = true;
int pr = ip[r];
a.set(r,r,d[pr]);
d[pr] = d[r];
/*
C
C STEP 5
C
IF (RP1.GT.N) GO TO 8
ARJ=1./A(R,R)
DO 7 I=RP1,N
A(I,R)=D(I)*ARJ
7 CONTINUE
8 CONTINUE
*/
if (rp1 < n)
{
nec_complex arj = cplx_10() / a.get(r,r);
for (int i=rp1; i<n; i++)
{
a.set(i,r,d[i] * arj);
}
}
/*
IF (IFLG.EQ.0) GO TO 9
WRITE(3,10) R,DMAX
IFLG=0
*/
if (iflg == true)
{
cout << "FACTR: PIVOT(" << r << ")=" << dmax;
iflg = false;
}
}
// increment ip array
for (int i=0;i<n;i++)
ip[i] += 1;
/*
cout << "solved = ";
to_octave(a,n,ndim);
cout << "ip = ";
to_octave(ip,n);
*/
}
void to_octave(complex_array& a, int n, int ndim)
{
to_octave(a.get_ptr(),n,ndim);
}