00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 static integer c__1 = 1;
00019
00020 int alareq_(char *path, integer *nmats, logical *dotype,
00021 integer *ntypes, integer *nin, integer *nout)
00022 {
00023
00024
00025 static char intstr[10] = "0123456789";
00026
00027
00028 static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
00029 "ine\002,/a79)";
00030 static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
00031 " this line or \002,\002adjust NTYPES on previous line\002)";
00032 static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
00033 " \002,i2,\002 of input\002,\002 line:\002,/a79)";
00034 static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
00035 "x type \002,i2,\002 for \002,a3)";
00036 static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
00037 "\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
00038 static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
00039 "read matrix \002,\002types for \002,a3,/\002 *** Check that you "
00040 "are requesting the\002,\002 right number of types for each pat"
00041 "h\002,/)";
00042
00043
00044 integer i__1;
00045 cilist ci__1;
00046
00047
00048 integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
00049 i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
00050 cilist *), e_wsle(void);
00051 int s_stop(char *, ftnlen);
00052
00053
00054 integer i__, j, k;
00055 char c1[1];
00056 integer i1, ic, nt;
00057 char line[80];
00058 integer lenp, nreq[100];
00059 logical firstt;
00060
00061
00062 static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
00063 static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
00064 static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
00065 static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
00066 static cilist io___17 = { 0, 0, 0, 0, 0 };
00067 static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
00068 static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
00069 static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
00070 static cilist io___21 = { 0, 0, 0, 0, 0 };
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128 --dotype;
00129
00130
00131
00132
00133
00134 if (*nmats >= *ntypes) {
00135
00136
00137
00138 i__1 = *ntypes;
00139 for (i__ = 1; i__ <= i__1; ++i__) {
00140 dotype[i__] = TRUE_;
00141
00142 }
00143 } else {
00144 i__1 = *ntypes;
00145 for (i__ = 1; i__ <= i__1; ++i__) {
00146 dotype[i__] = FALSE_;
00147
00148 }
00149 firstt = TRUE_;
00150
00151
00152
00153 if (*nmats > 0) {
00154 ci__1.cierr = 0;
00155 ci__1.ciend = 1;
00156 ci__1.ciunit = *nin;
00157 ci__1.cifmt = "(A80)";
00158 i__1 = s_rsfe(&ci__1);
00159 if (i__1 != 0) {
00160 goto L90;
00161 }
00162 i__1 = do_fio(&c__1, line, (ftnlen)80);
00163 if (i__1 != 0) {
00164 goto L90;
00165 }
00166 i__1 = e_rsfe();
00167 if (i__1 != 0) {
00168 goto L90;
00169 }
00170 lenp = i_len(line, (ftnlen)80);
00171 i__ = 0;
00172 i__1 = *nmats;
00173 for (j = 1; j <= i__1; ++j) {
00174 nreq[j - 1] = 0;
00175 i1 = 0;
00176 L30:
00177 ++i__;
00178 if (i__ > lenp) {
00179 if (j == *nmats && i1 > 0) {
00180 goto L60;
00181 } else {
00182 io___9.ciunit = *nout;
00183 s_wsfe(&io___9);
00184 do_fio(&c__1, line, (ftnlen)80);
00185 e_wsfe();
00186 io___10.ciunit = *nout;
00187 s_wsfe(&io___10);
00188 do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
00189 integer));
00190 e_wsfe();
00191 goto L80;
00192 }
00193 }
00194 if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
00195 char *)&line[i__ - 1] != ',') {
00196 i1 = i__;
00197 *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
00198
00199
00200
00201 for (k = 1; k <= 10; ++k) {
00202 if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
00203 k - 1]) {
00204 ic = k - 1;
00205 goto L50;
00206 }
00207
00208 }
00209 io___14.ciunit = *nout;
00210 s_wsfe(&io___14);
00211 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
00212 do_fio(&c__1, line, (ftnlen)80);
00213 e_wsfe();
00214 io___15.ciunit = *nout;
00215 s_wsfe(&io___15);
00216 do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
00217 e_wsfe();
00218 goto L80;
00219 L50:
00220 nreq[j - 1] = nreq[j - 1] * 10 + ic;
00221 goto L30;
00222 } else if (i1 > 0) {
00223 goto L60;
00224 } else {
00225 goto L30;
00226 }
00227 L60:
00228 ;
00229 }
00230 }
00231 i__1 = *nmats;
00232 for (i__ = 1; i__ <= i__1; ++i__) {
00233 nt = nreq[i__ - 1];
00234 if (nt > 0 && nt <= *ntypes) {
00235 if (dotype[nt]) {
00236 if (firstt) {
00237 io___17.ciunit = *nout;
00238 s_wsle(&io___17);
00239 e_wsle();
00240 }
00241 firstt = FALSE_;
00242 io___18.ciunit = *nout;
00243 s_wsfe(&io___18);
00244 do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
00245 do_fio(&c__1, path, (ftnlen)3);
00246 e_wsfe();
00247 }
00248 dotype[nt] = TRUE_;
00249 } else {
00250 io___19.ciunit = *nout;
00251 s_wsfe(&io___19);
00252 do_fio(&c__1, path, (ftnlen)3);
00253 do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
00254 do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
00255 e_wsfe();
00256 }
00257
00258 }
00259 L80:
00260 ;
00261 }
00262 return 0;
00263
00264 L90:
00265 io___20.ciunit = *nout;
00266 s_wsfe(&io___20);
00267 do_fio(&c__1, path, (ftnlen)3);
00268 e_wsfe();
00269 io___21.ciunit = *nout;
00270 s_wsle(&io___21);
00271 e_wsle();
00272 s_stop("", (ftnlen)0);
00273
00274
00275
00276 return 0;
00277 }