Annotation of OpenXM_contrib2/asir2000/builtin/numerical.c, Revision 1.1
1.1 ! noro 1: /* $OpenXM: OpenXM/src/asir99/builtin/numerical.c,v 1.1.1.1 1999/11/10 08:12:25 noro Exp $ */
! 2: #include "ca.h"
! 3: #include "parse.h"
! 4:
! 5: #if LAPACK
! 6: #include <f2c.h>
! 7:
! 8: void Pflinsolve();
! 9:
! 10: struct ftab numerical_tab[] = {
! 11: {"flinsolve",Pflinsolve,2},
! 12: {0,0,0},
! 13: };
! 14:
! 15: void Pflinsolve(arg,rp)
! 16: NODE arg;
! 17: VECT *rp;
! 18: {
! 19: MAT mat;
! 20: VECT b,r;
! 21: int i,j;
! 22: integer n,nrhs,lda,ldb,info;
! 23: integer *ipiv;
! 24: doublereal *m_array,*b_array;
! 25: Num **mb;
! 26: Num *vb;
! 27: Real *rb;
! 28: char trans;
! 29:
! 30: mat=(MAT)ARG0(arg); b=(VECT)ARG1(arg);
! 31: n=mat->row;
! 32: if ( n != mat->col )
! 33: error("flinsolve : non-square matrix");
! 34: if ( n != b->len )
! 35: error("flinsolve : inconsistent rhs");
! 36: m_array = (doublereal *)MALLOC_ATOMIC(n*n*sizeof(double));
! 37: b_array = (doublereal *)MALLOC_ATOMIC(n*sizeof(double));
! 38: ipiv = (integer *)MALLOC_ATOMIC(n*sizeof(integer));
! 39: for ( i = 0, mb = (Num **)mat->body; i < n; i++ )
! 40: for ( j = 0; j < n; j++ )
! 41: m_array[i*n+j] = ToReal(mb[j][i]);
! 42: for ( i = 0, vb = (Num *)b->body; i < n; i++ )
! 43: b_array[i] = ToReal(vb[i]);
! 44: trans = 'N';
! 45: nrhs = 1;
! 46: lda = n;
! 47: ldb = n;
! 48: dgetrf_(&n,&n,m_array,&lda,ipiv,&info);
! 49: if ( info )
! 50: error("flinsolve : LU factorization failed");
! 51: dgetrs_(&trans,&n,&nrhs,m_array,&lda,ipiv,b_array,&ldb,&info);
! 52: if ( info )
! 53: error("flinsolve : solving failed");
! 54: MKVECT(r,n);
! 55: for ( i = 0, rb = (Real *)r->body; i < n; i++ )
! 56: MKReal(b_array[i],rb[i]);
! 57: *rp = r;
! 58: }
! 59: #endif
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>