FIX FieldExp management through assign.
[scilab.git] / scilab / modules / arnoldi / sci_gateway / c / sci_dseupd.c
1 /*
2  * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3  * Copyright (C) ????-2008 - INRIA
4  *
5  * This file must be used under the terms of the CeCILL.
6  * This source file is licensed as described in the file COPYING, which
7  * you should have received as part of this distribution.  The terms
8  * are also available at
9  * http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
10  *
11  */
12
13 #include <math.h>
14 #include <string.h>
15 #include "stack-c.h"
16 #include "core_math.h"
17 #include "gw_arnoldi.h"
18 #include "localization.h"
19 #include "Scierror.h"
20 /*--------------------------------------------------------------------------*/
21 extern int C2F(dseupd)(int *rvec, char *howmny, int *select, double *d,
22                        double *z, int *ldz, double *sigma, char *bmat,
23                        int *n, char *which, int *nev , double *tol,
24                        double *resid, int *ncv, double *v , int *ldv,
25                        int *iparam, int *ipntr, double *workd, double *workl,
26                        int *lworkl, int *info, unsigned long rvec_length,
27                        unsigned long howmany_length,
28                        unsigned long bmat_length, unsigned long which_len);
29 /*--------------------------------------------------------------------------*/
30 int sci_dseupd(char *fname, unsigned long fname_len)
31 {
32     int mRVEC,     nRVEC,      pRVEC;
33     int mHOWMANY,  nHOWMANY,   pHOWMANY;
34     int mSELECT,   nSELECT,    pSELECT;
35     int D,        mD,        nD,         pD;
36     int Z,        mZ,        nZ,         pZ;
37     int mSIGMA,    nSIGMA,     pSIGMA;
38     int mBMAT,     nBMAT,      pBMAT;
39     int mN,        nN,         pN;
40     int mWHICH,    nWHICH,     pWHICH;
41     int mNEV,      nNEV,       pNEV;
42     int mTOL,      nTOL,       pTOL;
43     int RESID,    mRESID,    nRESID,     pRESID;
44     int mNCV,      nNCV,       pNCV;
45     int V,        mV,        nV,         pV;
46     int IPARAM,   mIPARAM,   nIPARAM,    pIPARAM;
47     int IPNTR,    mIPNTR,    nIPNTR,     pIPNTR;
48     int WORKD,    mWORKD,    nWORKD,     pWORKD;
49     int WORKL,    mWORKL,    nWORKL,     pWORKL;
50     int INFO,     mINFO,     nINFO,      pINFO;
51
52     int minlhs = 1, minrhs = 19, maxlhs = 9, maxrhs = 19;
53     int LDZ, LDV, LWORKL;
54     int sizeWORKL = 0;
55
56     /* [D,Z,RESID,V,IPARAM,IPNTR,WORKD,WORKL,INFO]=dseupd...
57        (RVEC,HOWMANY,SELECT,D,Z,SIGMA,BMAT,N,WHICH,NEV,TOL,RESID,NCV,V,IPARAM,IPNTR,WORKD,WORKL,INFO) */
58
59     CheckRhs(minrhs, maxrhs);
60     CheckLhs(minlhs, maxlhs);
61
62     /*                                                  VARIABLE = NUMBER   */
63     GetRhsVar( 1, MATRIX_OF_INTEGER_DATATYPE, &mRVEC,   &nRVEC,   &pRVEC);
64     GetRhsVar( 2, STRING_DATATYPE,            &mHOWMANY, &nHOWMANY, &pHOWMANY);
65     GetRhsVar( 3, MATRIX_OF_INTEGER_DATATYPE, &mSELECT, &nSELECT, &pSELECT);
66     GetRhsVar( 4, MATRIX_OF_DOUBLE_DATATYPE,  &mD,      &nD,      &pD);
67     D =  4;
68     GetRhsVar( 5, MATRIX_OF_DOUBLE_DATATYPE,  &mZ,      &nZ,      &pZ);
69     Z =  5;
70     GetRhsVar( 6, MATRIX_OF_DOUBLE_DATATYPE,  &mSIGMA,  &nSIGMA,  &pSIGMA);
71     GetRhsVar( 7, STRING_DATATYPE,            &mBMAT,   &nBMAT,   &pBMAT);
72     GetRhsVar( 8, MATRIX_OF_INTEGER_DATATYPE, &mN,      &nN,      &pN);
73     GetRhsVar( 9, STRING_DATATYPE,            &mWHICH,  &nWHICH,  &pWHICH);
74     GetRhsVar(10, MATRIX_OF_INTEGER_DATATYPE, &mNEV,    &nNEV,    &pNEV);
75     GetRhsVar(11, MATRIX_OF_DOUBLE_DATATYPE,  &mTOL,    &nTOL,    &pTOL);
76     GetRhsVar(12, MATRIX_OF_DOUBLE_DATATYPE,  &mRESID,  &nRESID,  &pRESID);
77     RESID = 12;
78     GetRhsVar(13, MATRIX_OF_INTEGER_DATATYPE, &mNCV,    &nNCV,    &pNCV);
79     GetRhsVar(14, MATRIX_OF_DOUBLE_DATATYPE,  &mV,      &nV,      &pV);
80     V = 14;
81     GetRhsVar(15, MATRIX_OF_INTEGER_DATATYPE, &mIPARAM, &nIPARAM, &pIPARAM);
82     IPARAM = 15;
83     GetRhsVar(16, MATRIX_OF_INTEGER_DATATYPE, &mIPNTR,  &nIPNTR,  &pIPNTR);
84     IPNTR = 16;
85     GetRhsVar(17, MATRIX_OF_DOUBLE_DATATYPE,  &mWORKD,  &nWORKD,  &pWORKD);
86     WORKD = 17;
87     GetRhsVar(18, MATRIX_OF_DOUBLE_DATATYPE,  &mWORKL,  &nWORKL,  &pWORKL);
88     WORKL = 18;
89     GetRhsVar(19, MATRIX_OF_INTEGER_DATATYPE, &mINFO,   &nINFO,   &pINFO);
90     INFO = 19;
91
92     LWORKL = mWORKL * nWORKL;
93     LDV = Max(1, *istk(pN));
94     LDZ = LDV;
95
96     /* Check some sizes */
97     if (mIPARAM*nIPARAM != 11)
98     {
99         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "IPARAM", 11);
100         return 0;
101     }
102
103     if (mIPNTR*nIPNTR != 14)
104     {
105         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "IPNTR", 14);
106         return 0;
107     }
108
109     if (mRESID*nRESID != *istk(pN))
110     {
111         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "RESID", *istk(pN));
112         return 0;
113     }
114
115     if (mWORKD * nWORKD < 3 * *istk(pN))
116     {
117         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "WORKD", 3 * *istk(pN));
118         return 0;
119     }
120
121     if (mSELECT*nSELECT != *istk(pNCV))
122     {
123         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "SELECT", *istk(pNCV));
124         return 0;
125     }
126
127     if (mD*nD != (*istk(pNEV)))
128     {
129         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "D", *istk(pNEV));
130         return 0;
131     }
132
133     if ((mZ != *istk(pN)) || (nZ != *istk(pNEV)))
134     {
135         Scierror(999, _("%s: Wrong size for input argument %s: A matrix of size %dx%d expected.\n"), fname, "Z", *istk(pN), *istk(pNEV));
136         return 0;
137     }
138
139     if ((mV != *istk(pN)) || (nV != *istk(pNCV)))
140     {
141         Scierror(999, _("%s: Wrong size for input argument %s: A matrix of size %dx%d expected.\n"), fname, "V", *istk(pN), *istk(pNCV));
142         return 0;
143     }
144
145     sizeWORKL = *istk(pNCV) * *istk(pNCV) + 8 * *istk(pNCV);
146
147     if ((mWORKL * nWORKL < sizeWORKL))
148     {
149         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "WORKL", sizeWORKL);
150         return 0;
151     }
152
153     C2F(dseupd)(istk(pRVEC), cstk(pHOWMANY),  istk(pSELECT),
154                 stk(pD), stk(pZ),   &LDZ,
155                 stk(pSIGMA), cstk(pBMAT), istk(pN), cstk(pWHICH),
156                 istk(pNEV), stk(pTOL), stk(pRESID),
157                 istk(pNCV), stk(pV), &LDV,
158                 istk(pIPARAM), istk(pIPNTR),
159                 stk(pWORKD), stk(pWORKL), &LWORKL,
160                 istk(pINFO), 1L, 1L, 1L, 2L);
161
162     if (*istk(pINFO) < 0)
163     {
164         C2F(errorinfo)("dseupd", istk(pINFO), 6L);
165         return 0;
166     }
167
168     LhsVar(1) = D;
169     LhsVar(2) = Z;
170     LhsVar(3) = RESID;
171     LhsVar(4) = V;
172     LhsVar(5) = IPARAM;
173     LhsVar(6) = IPNTR;
174     LhsVar(7) = WORKD;
175     LhsVar(8) = WORKL;
176     LhsVar(9) = INFO;
177
178     PutLhsVar();
179
180     return 0;
181 }
182 /*--------------------------------------------------------------------------*/
183