void lapack_ztrexc(const enum lapack_compute_type compq, const int n, void * t, const int ldt, void * q, const int ldq, const int ifst, const int ilst, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_ldt=ldt, F77_ldq=ldq, F77_ifst=ifst, F77_ilst=ilst; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_ldt ldt #define F77_ldq ldq #define F77_ifst ifst #define F77_ilst ilst #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_compq; #else #define F77_compq C_compq #endif char C_compq=' '; if (compq == lapack_not_compute) { C_compq = 'N'; } else if (compq == lapack_unitary) { C_compq = 'I'; } else if (compq == lapack_product) { C_compq = 'V'; } #ifdef F77_CHAR F77_compq = C2F_CHAR(&C_compq) #endif f77_ztrexc(&F77_compq, &F77_n, t, &F77_ldt, q, &F77_ldq, &F77_ifst, &F77_ilst, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

float lapack_clange(const enum lapack_norm_type norm, const int m, const int n, const void * a, const int lda, float * work ) { float output; #ifdef F77_INT F77_INT F77_m=m, F77_n=n, F77_lda=lda; #else #define F77_m m #define F77_n n #define F77_lda lda #endif #ifdef F77_CHAR F77_CHAR F77_norm; #else #define F77_norm C_norm #endif char C_norm=' '; if (norm == lapack_one_norm) { C_norm = '1'; } else if (norm == lapack_inf_norm) { C_norm = 'I'; } else if (norm == lapack_max_norm) { C_norm = 'M'; } else if (norm == lapack_frobenius_norm) { C_norm = 'F'; } #ifdef F77_CHAR F77_norm = C2F_CHAR(&C_norm) #endif f77_clange(&output, &F77_norm, &F77_m, &F77_n, a, &F77_lda, work); #ifdef F77_INT #endif return output; }

void lapack_cpbrfs(const enum lapack_uplo_type uplo, const int n, const int kd, const int nrhs, const void * ab, const int ldab, const void * afb, const int ldafb, const void * b, const int ldb, void * x, const int ldx, float * ferr, float * berr, void * work, float * rwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_kd=kd, F77_nrhs=nrhs, F77_ldab=ldab, F77_ldafb=ldafb, F77_ldb=ldb, F77_ldx=ldx; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_kd kd #define F77_nrhs nrhs #define F77_ldab ldab #define F77_ldafb ldafb #define F77_ldb ldb #define F77_ldx ldx #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_cpbrfs(&F77_uplo, &F77_n, &F77_kd, &F77_nrhs, ab, &F77_ldab, afb, &F77_ldafb, b, &F77_ldb, x, &F77_ldx, ferr, berr, work, rwork, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_csytri(const enum lapack_uplo_type uplo, const int n, void * a, const int lda, const int * ipiv, void * work, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_lda=lda; int i_local; F77_INT F77_ipiv[n*1]; for(i_local=0;i_local<n*1;i_local++) { F77_ipiv[i_local]=(F77_INT) ipiv[i_local]; } F77_INT F77_info[1]; #else #define F77_n n #define F77_lda lda #define F77_ipiv ipiv #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_csytri(&F77_uplo, &F77_n, a, &F77_lda, F77_ipiv, work, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_cbdsqr(const enum lapack_uplo_type uplo, const int n, const int ncvt, const int nru, const int ncc, float * d, float * e, void * vt, const int ldvt, void * u, const int ldu, void * c, const int ldc, float * rwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_ncvt=ncvt, F77_nru=nru, F77_ncc=ncc, F77_ldvt=ldvt, F77_ldu=ldu, F77_ldc=ldc; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_ncvt ncvt #define F77_nru nru #define F77_ncc ncc #define F77_ldvt ldvt #define F77_ldu ldu #define F77_ldc ldc #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_cbdsqr(&F77_uplo, &F77_n, &F77_ncvt, &F77_nru, &F77_ncc, d, e, vt, &F77_ldvt, u, &F77_ldu, c, &F77_ldc, rwork, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_cspcon(const enum lapack_uplo_type uplo, const int n, const void * ap, const int * ipiv, const float anorm, float * rcond, void * work, int * info ) { #ifdef F77_INT F77_INT F77_n=n; int i_local; F77_INT F77_ipiv[n*1]; for(i_local=0;i_local<n*1;i_local++) { F77_ipiv[i_local]=(F77_INT) ipiv[i_local]; } F77_INT F77_info[1]; #else #define F77_n n #define F77_ipiv ipiv #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_cspcon(&F77_uplo, &F77_n, ap, F77_ipiv, &anorm, rcond, work, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

float lapack_slanst(const enum lapack_norm_type norm, const int n, const float * d, const float * e ) { float output; #ifdef F77_INT F77_INT F77_n=n; #else #define F77_n n #endif #ifdef F77_CHAR F77_CHAR F77_norm; #else #define F77_norm C_norm #endif char C_norm=' '; if (norm == lapack_one_norm) { C_norm = '1'; } else if (norm == lapack_inf_norm) { C_norm = 'I'; } else if (norm == lapack_max_norm) { C_norm = 'M'; } else if (norm == lapack_frobenius_norm) { C_norm = 'F'; } #ifdef F77_CHAR F77_norm = C2F_CHAR(&C_norm) #endif f77_slanst(&output, &F77_norm, &F77_n, d, e); #ifdef F77_INT #endif return output; }

void lapack_zpbtrs(const enum lapack_uplo_type uplo, const int n, const int kd, const int nrhs, const void * ab, const int ldab, void * b, const int ldb, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_kd=kd, F77_nrhs=nrhs, F77_ldab=ldab, F77_ldb=ldb; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_kd kd #define F77_nrhs nrhs #define F77_ldab ldab #define F77_ldb ldb #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_zpbtrs(&F77_uplo, &F77_n, &F77_kd, &F77_nrhs, ab, &F77_ldab, b, &F77_ldb, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_claqhb(const enum lapack_uplo_type uplo, const int n, const int kd, void * ab, const int ldab, float * s, const float scond, const float amax, char * equed ) { #ifdef F77_INT F77_INT F77_n=n, F77_kd=kd, F77_ldab=ldab; #else #define F77_n n #define F77_kd kd #define F77_ldab ldab #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif #ifdef F77_CHAR F77_CHAR F77_equed = C2F_STR(equed, strlen(equed)) ; #else #define F77_equed equed #endif f77_claqhb(&F77_uplo, &F77_n, &F77_kd, ab, &F77_ldab, s, &scond, &amax, equed); #ifdef F77_INT #endif }

void lapack_ssygst(const int itype, const enum lapack_uplo_type uplo, const int n, float * a, const int lda, const float * b, const int ldb, int * info ) { #ifdef F77_INT F77_INT F77_itype=itype, F77_n=n, F77_lda=lda, F77_ldb=ldb; int i_local; F77_INT F77_info[1]; #else #define F77_itype itype #define F77_n n #define F77_lda lda #define F77_ldb ldb #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_ssygst(&F77_itype, &F77_uplo, &F77_n, a, &F77_lda, b, &F77_ldb, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_zpteqr(const enum lapack_compute_type compz, const int n, double * d, double * e, void * z, const int ldz, double * work, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_ldz=ldz; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_ldz ldz #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_compz; #else #define F77_compz C_compz #endif char C_compz=' '; if (compz == lapack_not_compute) { C_compz = 'N'; } else if (compz == lapack_unitary) { C_compz = 'I'; } else if (compz == lapack_product) { C_compz = 'V'; } #ifdef F77_CHAR F77_compz = C2F_CHAR(&C_compz) #endif f77_zpteqr(&F77_compz, &F77_n, d, e, z, &F77_ldz, work, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_zpprfs(const enum lapack_uplo_type uplo, const int n, const int nrhs, const void * ap, const void * afp, const void * b, const int ldb, void * x, const int ldx, double * ferr, double * berr, void * work, double * rwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_nrhs=nrhs, F77_ldb=ldb, F77_ldx=ldx; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_nrhs nrhs #define F77_ldb ldb #define F77_ldx ldx #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_zpprfs(&F77_uplo, &F77_n, &F77_nrhs, ap, afp, b, &F77_ldb, x, &F77_ldx, ferr, berr, work, rwork, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_dorgtr(const enum lapack_uplo_type uplo, const int n, double * a, const int lda, const double * tau, double * work, const int lwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_lda=lda, F77_lwork=lwork; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_lda lda #define F77_lwork lwork #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_dorgtr(&F77_uplo, &F77_n, a, &F77_lda, tau, work, &F77_lwork, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_dpbtf2(const enum lapack_uplo_type uplo, const int n, const int kd, double * ab, const int ldab, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_kd=kd, F77_ldab=ldab; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_kd kd #define F77_ldab ldab #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_dpbtf2(&F77_uplo, &F77_n, &F77_kd, ab, &F77_ldab, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_claqhp(const enum lapack_uplo_type uplo, const int n, void * ap, const float * s, const float scond, const float amax, char * equed ) { #ifdef F77_INT F77_INT F77_n=n; #else #define F77_n n #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif #ifdef F77_CHAR F77_CHAR F77_equed = C2F_STR(equed, strlen(equed)) ; #else #define F77_equed equed #endif f77_claqhp(&F77_uplo, &F77_n, ap, s, &scond, &amax, equed); #ifdef F77_INT #endif }

void lapack_dopgtr(const enum lapack_uplo_type uplo, const int n, const double * ap, const double * tau, double * q, const int ldq, double * work, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_ldq=ldq; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_ldq ldq #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_dopgtr(&F77_uplo, &F77_n, ap, tau, q, &F77_ldq, work, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_cpocon(const enum lapack_uplo_type uplo, const int n, const void * a, const int lda, const float anorm, float * rcond, void * work, float * rwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_lda=lda; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_lda lda #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_cpocon(&F77_uplo, &F77_n, a, &F77_lda, &anorm, rcond, work, rwork, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_dstev(const enum lapack_compute_vectors_type jobz, const int n, double * d, double * e, double * z, const int ldz, double * work, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_ldz=ldz; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_ldz ldz #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_jobz; #else #define F77_jobz C_jobz #endif char C_jobz=' '; if (jobz == lapack_no_compute_vectors) { C_jobz = 'N'; } else if (jobz == lapack_compute_vectors) { C_jobz = 'V'; } #ifdef F77_CHAR F77_jobz = C2F_CHAR(&C_jobz) #endif f77_dstev(&F77_jobz, &F77_n, d, e, z, &F77_ldz, work, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_chpgst(const int itype, const enum lapack_uplo_type uplo, const int n, void * ap, const void * bp, int * info ) { #ifdef F77_INT F77_INT F77_itype=itype, F77_n=n; int i_local; F77_INT F77_info[1]; #else #define F77_itype itype #define F77_n n #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_chpgst(&F77_itype, &F77_uplo, &F77_n, ap, bp, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void lapack_clagtm(const enum lapack_trans_type trans, const int n, const int nrhs, const float alpha, const void * dl, const void * d, const void * du, const void * x, const int ldx, const float beta, void * b, const int ldb ) { #ifdef F77_INT F77_INT F77_n=n, F77_nrhs=nrhs, F77_ldx=ldx, F77_ldb=ldb; #else #define F77_n n #define F77_nrhs nrhs #define F77_ldx ldx #define F77_ldb ldb #endif #ifdef F77_CHAR F77_CHAR F77_trans; #else #define F77_trans C_trans #endif char C_trans=' '; if (trans == lapack_no_trans) { C_trans = 'N'; } else if (trans == lapack_trans) { C_trans = 'T'; } else if (trans == lapack_conj_trans) { C_trans = 'C'; } #ifdef F77_CHAR F77_trans = C2F_CHAR(&C_trans) #endif f77_clagtm(&F77_trans, &F77_n, &F77_nrhs, &alpha, dl, d, du, x, &F77_ldx, &beta, b, &F77_ldb); #ifdef F77_INT #endif }

void lapack_zlauum(const enum lapack_uplo_type uplo, const int n, void * a, const int lda, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_lda=lda; int i_local; F77_INT F77_info[1]; #else #define F77_n n #define F77_lda lda #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_uplo; #else #define F77_uplo C_uplo #endif char C_uplo=' '; if (uplo == lapack_upper) { C_uplo = 'U'; } else if (uplo == lapack_lower) { C_uplo = 'L'; } #ifdef F77_CHAR F77_uplo = C2F_CHAR(&C_uplo) #endif f77_zlauum(&F77_uplo, &F77_n, a, &F77_lda, F77_info); #ifdef F77_INT info[0]=(int) F77_info[0]; #endif }

void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, const int N, const float *A, const int lda, float *X, const int incX) { char TA; char UL; char DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_DI; #else #define F77_TA &TA #define F77_UL &UL #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; #else #define F77_N N #define F77_lda lda #define F77_incX incX #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; else { cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; else { cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); } else cblas_xerbla(1, "cblas_strmv", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }

void cblas_zher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const CBLAS_INT_TYPE N, const double alpha, const void *X, const CBLAS_INT_TYPE incX ,void *A, const CBLAS_INT_TYPE lda) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; #else #define F77_N N #define F77_lda lda #define F77_incX incx #endif CBLAS_INT_TYPE n, i, tincx, incx=incX; double *x=(double *)X, *xx=(double *)X, *tx, *st; if (order == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; else { cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n",Uplo ); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_zher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); } else if (order == CblasRowMajor) { if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n", Uplo); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif if (N > 0) { n = N << 1; x = malloc(n*sizeof(double)); tx = x; if( incX > 0 ) { i = incX << 1 ; tincx = 2; st= x+n; } else { i = incX *(-2); tincx = -2; st = x-2; x +=(n-2); } do { *x = *xx; x[1] = -xx[1]; x += tincx ; xx += i; } while (x != st); x=tx; #ifdef F77_INT F77_incX = 1; #else incx = 1; #endif } else x = (double *) X; F77_zher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_zher", "Illegal Order setting, %d\n", order); if(X!=x) free(x); return; }

void lapack_sgesvx(const enum lapack_fact_type fact, const enum lapack_trans_type trans, const int n, const int nrhs, float * a, const int lda, float * af, const int ldaf, int * ipiv, char * equed, float * r, float * c, float * b, const int ldb, float * x, const int ldx, float * rcond, float * ferr, float * berr, float * work, int * iwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_nrhs=nrhs, F77_lda=lda, F77_ldaf=ldaf, F77_ldb=ldb, F77_ldx=ldx; int i_local; F77_INT F77_ipiv[n*1]; for(i_local=0;i_local<n*1;i_local++) { F77_ipiv[i_local]=(F77_INT) ipiv[i_local]; } #define F77_iwork iwork F77_INT F77_info[1]; #else #define F77_n n #define F77_nrhs nrhs #define F77_lda lda #define F77_ldaf ldaf #define F77_ipiv ipiv #define F77_ldb ldb #define F77_ldx ldx #define F77_iwork iwork #define F77_info info #endif #ifdef F77_CHAR F77_CHAR F77_fact, F77_trans; #else #define F77_fact C_fact #define F77_trans C_trans #endif char C_fact=' '; if (fact == lapack_fact_f) { C_fact = 'F'; } else if (fact == lapack_fact_n) { C_fact = 'N'; } else if (fact == lapack_fact_e) { C_fact = 'E'; } char C_trans=' '; if (trans == lapack_no_trans) { C_trans = 'N'; } else if (trans == lapack_trans) { C_trans = 'T'; } else if (trans == lapack_conj_trans) { C_trans = 'C'; } #ifdef F77_CHAR F77_fact = C2F_CHAR(&C_fact) F77_trans = C2F_CHAR(&C_trans) #endif #ifdef F77_CHAR F77_CHAR F77_equed = C2F_STR(equed, strlen(equed)) ; #else #define F77_equed equed #endif f77_sgesvx(&F77_fact, &F77_trans, &F77_n, &F77_nrhs, a, &F77_lda, af, &F77_ldaf, F77_ipiv, equed, r, c, b, &F77_ldb, x, &F77_ldx, rcond, ferr, berr, work, F77_iwork, F77_info); #ifdef F77_INT for(i_local=0;i_local<n*1;i_local++) { ipiv[i_local]=(int) F77_ipiv[i_local]; } info[0]=(int) F77_info[0]; #endif }

void cblas_ztrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, const int N, const void *A, const int lda, void *X, const int incX) { char TA; char UL; char DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_DI; #else #define F77_TA &TA #define F77_UL &UL #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; #else #define F77_N N #define F77_lda lda #define F77_incX incX #endif int n, i=0, tincX; double *st=0,*x=(double *)X; if (order == CblasColMajor) { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; else { cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); return; } if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); } else if (order == CblasRowMajor) { if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); return; } if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) { TA = 'N'; if ( N > 0) { if ( incX > 0 ) tincX = incX; else tincX = -incX; n = N*2*(tincX); x++; st=x+n; i = tincX << 1; do { *x = -(*x); x+=i; } while (x != st); x -= n; } } else { cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); if (TransA == CblasConjTrans) { if (N > 0) { do { *x = -(*x); x += i; } while (x != st); } } } else cblas_xerbla(1, "cblas_ztrsv", "Illegal Order setting, %d\n", order); return; }

void cblas_ssyr2(enum CBLAS_ORDER order, enum CBLAS_UPLO Uplo, f77_int N, const float alpha, const float *X, f77_int incX, const float *Y, f77_int incY, float *A, f77_int lda) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77_lda=lda; #else #define F77_N N #define F77_incX incX #define F77_incY incY #define F77_lda lda #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; else { cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; else { cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else cblas_xerbla(1, "cblas_ssyr2", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }

void lapack_ctgsna(const enum lapack_balance_type job, const enum lapack_how_many_type howmny, const long int * select, const int n, const void * a, const int lda, const void * b, const int ldb, const void * vl, const int ldvl, const void * vr, const int ldvr, float * s, float * dif, const int mm, int * m, void * work, const int lwork, int * iwork, int * info ) { #ifdef F77_INT F77_INT F77_n=n, F77_lda=lda, F77_ldb=ldb, F77_ldvl=ldvl, F77_ldvr=ldvr, F77_mm=mm, F77_lwork=lwork; int i_local; F77_INT F77_m[1]; F77_m[0]=(F77_INT) m[0]; #define F77_iwork iwork F77_INT F77_info[1]; #else #define F77_n n #define F77_lda lda #define F77_ldb ldb #define F77_ldvl ldvl #define F77_ldvr ldvr #define F77_mm mm #define F77_m m #define F77_lwork lwork #define F77_iwork iwork #define F77_info info #endif #ifdef F77_LOG ; int j_local; F77_LOG F77_select[n*1]; for(j_local=0;j_local<n*1;j_local++) { F77_select[j_local]=(F77_LOG) select[j_local]; } #else #define F77_select select #endif #ifdef F77_CHAR F77_CHAR F77_job, F77_howmny; #else #define F77_job C_job #define F77_howmny C_howmny #endif char C_job=' '; if (job == lapack_nothing) { C_job = 'N'; } else if (job == lapack_permute) { C_job = 'P'; } else if (job == lapack_scale) { C_job = 'S'; } else if (job == lapack_permute_scale) { C_job = 'B'; } char C_howmny=' '; if (howmny == lapack_all) { C_howmny = 'A'; } else if (howmny == lapack_backtransform) { C_howmny = 'B'; } else if (howmny == lapack_select) { C_howmny = 'S'; } #ifdef F77_CHAR F77_job = C2F_CHAR(&C_job) F77_howmny = C2F_CHAR(&C_howmny) #endif f77_ctgsna(&F77_job, &F77_howmny, F77_select, &F77_n, a, &F77_lda, b, &F77_ldb, vl, &F77_ldvl, vr, &F77_ldvr, s, dif, &F77_mm, F77_m, work, &F77_lwork, F77_iwork, F77_info); #ifdef F77_INT m[0]=(int) F77_m[0]; info[0]=(int) F77_info[0]; #endif #ifdef F77_LOG #endif }

void cblas_zhemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, const enum CBLAS_UPLO Uplo, const int M, const int N, const void *alpha, const void *A, const int lda, const void *B, const int ldb, const void *beta, void *C, const int ldc) { char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else #define F77_SD &SD #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; F77_INT F77_ldc=ldc; #else #define F77_M M #define F77_N N #define F77_lda lda #define F77_ldb ldb #define F77_ldc ldc #endif if( Order == CblasColMajor ) { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; else { cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); return; } if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; else { cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_SD = C2F_CHAR(&SD); #endif F77_zhemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (Order == CblasRowMajor) { if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; else { cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); return; } if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; else { cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_SD = C2F_CHAR(&SD); #endif F77_zhemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else cblas_xerbla(1, "cblas_zhemm", "Illegal Order setting, %d\n", Order); return; }

void cblas_cgemv(const enum CBLAS_ORDER order, const enum CBLAS_TRANSPOSE TransA, const int M, const int N, const void *alpha, const void *A, const int lda, const void *X, const int incX, const void *beta, void *Y, const int incY) { char TA; #ifdef F77_CHAR F77_CHAR F77_TA; #else #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_M M #define F77_N N #define F77_lda lda #define F77_incX incx #define F77_incY incY #endif int n=0, i=0; const float *xx= (const float *)X; float ALPHA[2],BETA[2]; int tincY, tincx; float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0; const float *stx = x; extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif F77_cgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) { ALPHA[0]= *( (const float *) alpha ); ALPHA[1]= -( *( (const float *) alpha+1) ); BETA[0]= *( (const float *) beta ); BETA[1]= -( *( (const float *) beta+1 ) ); TA = 'N'; if (M > 0) { n = M << 1; x = malloc(n*sizeof(float)); tx = x; if( incX > 0 ) { i = incX << 1 ; tincx = 2; st= x+n; } else { i = incX *(-2); tincx = -2; st = x-2; x +=(n-2); } do { *x = *xx; x[1] = -xx[1]; x += tincx ; xx += i; } while (x != st); x=tx; F77_incX = 1; if(incY > 0) tincY = incY; else tincY = -incY; y++; if (N > 0) { i = tincY << 1; n = i * N ; st = y + n; do { *y = -(*y); y += i; } while(y != st); y -= n; } stx = x; } else stx = (const float *)X; } else { cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif if (TransA == CblasConjTrans) F77_cgemv(F77_TA, &F77_N, &F77_M, ALPHA, A, &F77_lda, stx, &F77_incX, BETA, Y, &F77_incY); else F77_cgemv(F77_TA, &F77_N, &F77_M, alpha, A, &F77_lda, x, &F77_incX, beta, Y, &F77_incY); if (TransA == CblasConjTrans) { if (x != (const float *)X) free(x); if (N > 0) { do { *y = -(*y); y += i; } while (y != st); } } } else cblas_xerbla(1, "cblas_cgemv", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }

void cblas_dsbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N, const int K, const double alpha, const double *A, const int lda, const double *X, const int incX, const double beta, double *Y, const int incY) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_N N #define F77_K K #define F77_lda lda #define F77_incX incX #define F77_incY incY #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; else { cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_dsbmv", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }