FIX FieldExp management through assign.
[scilab.git] / scilab / modules / arnoldi / sci_gateway / c / sci_dnaupd.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(dnaupd)(int *ido, char *bmat, int *n, char *which, int *nev,
22                        double *tol, double *resid, int *ncv, double *v,
23                        int *ldv, int *iparam, int *ipntr, double *workd,
24                        double *workl, int *lworkl, int *info,
25                        unsigned long bmat_len, unsigned long which_len);
26 /*--------------------------------------------------------------------------*/
27 int sci_dnaupd(char *fname, unsigned long fname_len)
28 {
29     int IDO,   mIDO,   nIDO,    pIDO;
30     int mBMAT,  nBMAT,   pBMAT;
31     int mN,     nN,      pN;
32     int mWHICH, nWHICH,  pWHICH;
33     int mNEV,   nNEV,    pNEV;
34     int mTOL,   nTOL,    pTOL;
35     int RESID, mRESID, nRESID,  pRESID;
36     int mNCV,   nNCV,    pNCV;
37     int V,     mV,     nV,      pV;
38     int IPARAM, mIPARAM, nIPARAM, pIPARAM;
39     int IPNTR, mIPNTR, nIPNTR,  pIPNTR;
40     int WORKD, mWORKD, nWORKD,  pWORKD;
41     int WORKL, mWORKL, nWORKL,  pWORKL;
42     int INFO,  mINFO,  nINFO,   pINFO;
43
44     int minlhs = 1, minrhs = 14, maxlhs = 8, maxrhs = 14;
45     int LDV, LWORKL;
46     int sizeWORKL = 0;
47
48     /* [IDO,RESID,V,IPARAM,IPNTR,WORKD,WORKL,INFO]=dnaupd...
49        (ID0,BMAT,N,WHICH,NEV,TOL,RESID,NCV,V,IPARAM,IPNTR,WORKD,WORKL,INFO) */
50
51     CheckRhs(minrhs, maxrhs);
52     CheckLhs(minlhs, maxlhs);
53
54     /*                                                  VARIABLE = NUMBER   */
55     GetRhsVar( 1, MATRIX_OF_INTEGER_DATATYPE, &mIDO,    &nIDO,    &pIDO);
56     IDO =  1;
57     GetRhsVar( 2, STRING_DATATYPE,            &mBMAT,   &nBMAT,   &pBMAT);
58     GetRhsVar( 3, MATRIX_OF_INTEGER_DATATYPE, &mN,      &nN,      &pN);
59     GetRhsVar( 4, STRING_DATATYPE,            &mWHICH,  &nWHICH,  &pWHICH);
60     GetRhsVar( 5, MATRIX_OF_INTEGER_DATATYPE, &mNEV,    &nNEV,    &pNEV);
61     GetRhsVar( 6, MATRIX_OF_DOUBLE_DATATYPE,  &mTOL,    &nTOL,    &pTOL);
62     GetRhsVar( 7, MATRIX_OF_DOUBLE_DATATYPE,  &mRESID,  &nRESID,  &pRESID);
63     RESID =  7;
64     GetRhsVar( 8, MATRIX_OF_INTEGER_DATATYPE, &mNCV,    &nNCV,    &pNCV);
65     GetRhsVar( 9, MATRIX_OF_DOUBLE_DATATYPE,  &mV,      &nV,      &pV);
66     V =  9;
67     GetRhsVar(10, MATRIX_OF_INTEGER_DATATYPE, &mIPARAM, &nIPARAM, &pIPARAM);
68     IPARAM = 10;
69     GetRhsVar(11, MATRIX_OF_INTEGER_DATATYPE, &mIPNTR,  &nIPNTR,  &pIPNTR);
70     IPNTR = 11;
71     GetRhsVar(12, MATRIX_OF_DOUBLE_DATATYPE,  &mWORKD,  &nWORKD,  &pWORKD);
72     WORKD = 12;
73     GetRhsVar(13, MATRIX_OF_DOUBLE_DATATYPE,  &mWORKL,  &nWORKL,  &pWORKL);
74     WORKL = 13;
75     GetRhsVar(14, MATRIX_OF_INTEGER_DATATYPE, &mINFO,   &nINFO,   &pINFO);
76     INFO = 14;
77
78     LWORKL = mWORKL * nWORKL;
79     LDV = Max(1, *istk(pN));
80
81     /* Don't call dnaupd if ido == 99 */
82     if (*istk(pIDO) == 99)
83     {
84         Scierror(999, _("%s: the computation is already terminated\n"), fname);
85         return 0;
86     }
87
88     /* Check some sizes */
89     if (mIPARAM*nIPARAM != 11)
90     {
91         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "IPARAM", 11);
92         return 0;
93     }
94
95     if (mIPNTR*nIPNTR != 14)
96     {
97         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "IPNTR", 14);
98         return 0;
99     }
100
101     if (mRESID*nRESID != *istk(pN))
102     {
103         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "RESID", *istk(pN));
104         return 0;
105     }
106
107     if ((mV != *istk(pN)) || (nV != *istk(pNCV)))
108     {
109         Scierror(999, _("%s: Wrong size for input argument %s: A matrix of size %dx%d expected.\n"), fname, "V", *istk(pN), *istk(pNCV));
110         return 0;
111     }
112
113     if (mWORKD * nWORKD < 3 * *istk(pN))
114     {
115         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "WORKD", 3 * *istk(pN));
116         return 0;
117     }
118
119     sizeWORKL = 3 * *istk(pNCV) * *istk(pNCV) + 6 * *istk(pNCV);
120
121     if (mWORKL * nWORKL < sizeWORKL)
122     {
123         Scierror(999, _("%s: Wrong size for input argument %s: An array of size %d expected.\n"), fname, "WORKL", sizeWORKL);
124         return 0;
125     }
126
127     C2F(dnaupd)(istk(pIDO),   cstk(pBMAT),  istk(pN),
128                 cstk(pWHICH), istk(pNEV),   stk(pTOL),
129                 stk(pRESID), istk(pNCV),   stk(pV), &LDV,
130                 istk(pIPARAM), istk(pIPNTR), stk(pWORKD),
131                 stk(pWORKL), &LWORKL,      istk(pINFO), 1L, 2L);
132
133     if (*istk(pINFO) < 0)
134     {
135         C2F(errorinfo)("dnaupd", istk(pINFO), 6L);
136         return 0;
137     }
138
139     LhsVar(1) = IDO;
140     LhsVar(2) = RESID;
141     LhsVar(3) = V;
142     LhsVar(4) = IPARAM;
143     LhsVar(5) = IPNTR;
144     LhsVar(6) = WORKD;
145     LhsVar(7) = WORKL;
146     LhsVar(8) = INFO;
147
148     PutLhsVar();
149
150     return 0;
151 }
152 /*--------------------------------------------------------------------------*/