1 /* -- translated by f2c (version 20100827).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #include "libtinyf2c.h"
14
15 /* Table of constant values */
16
17 static integer c__1 = 1;
18
19 /* ----------------------------------------------------------------------- */
20 /* SBYTES */
21 /* ----------------------------------------------------------------------- */
22 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
23 /* ----------------------------------------------------------------------- */
sbytes_(integer * npack,integer * isam,integer * ibit,integer * nbits,integer * nskip,integer * iter)24 /* Subroutine */ int sbytes_(integer *npack, integer *isam, integer *ibit,
25 integer *nbits, integer *nskip, integer *iter)
26 {
27 /* Initialized data */
28
29 static integer ncall = 0;
30
31 /* System generated locals */
32 integer i__1, i__2, i__3;
33
34 /* Local variables */
35 static integer i__, bpo, wpo, msk1, msk2, mask[32], btmp, rbits, sbits,
36 ubits;
37 extern /* Subroutine */ int gliget_(char *, integer *, ftnlen);
38 extern integer ishift_(integer *, integer *);
39 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
40 ftnlen, ftnlen);
41 static integer bitsep, lshift, rshift, nbitpw;
42
43 /* Parameter adjustments */
44 --isam;
45 --npack;
46
47 /* Function Body */
48 if (ncall == 0) {
49 gliget_("NBITSPW", &nbitpw, (ftnlen)7);
50 if (nbitpw != 32) {
51 msgdmp_("E", "SBYTES", "NUMBER OF BITS PER ONE WORD IS INVALID /"
52 " CHECK BPERI IN THE PARAMETER STATEMENT OF GBYTES AND CH"
53 "ANGE IT CORRECTLY.", (ftnlen)1, (ftnlen)6, (ftnlen)114);
54 }
55 mask[0] = 1;
56 for (i__ = 2; i__ <= 32; ++i__) {
57 mask[i__ - 1] = ishift_(&mask[i__ - 2], &c__1) | 1;
58 /* L10: */
59 }
60 ncall = 1;
61 }
62 if (! (*nbits <= 32 && *nbits > 0)) {
63 msgdmp_("E", "SBYTES", "NBITS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
64 ftnlen)19);
65 }
66 msk1 = mask[*nbits - 1];
67 msk2 = mask[32 - *nbits - 1];
68 bitsep = *nbits + *nskip;
69 i__1 = *iter;
70 for (i__ = 1; i__ <= i__1; ++i__) {
71 sbits = msk1 & isam[i__];
72 bpo = *ibit + (i__ - 1) * bitsep;
73 wpo = bpo / 32 + 1;
74 rbits = (wpo << 5) - bpo;
75 ubits = 32 - rbits;
76 if (rbits >= *nbits) {
77 lshift = 32 - ubits - *nbits;
78 i__2 = lshift + *nbits;
79 npack[wpo] &= ishift_(&msk2, &i__2);
80 npack[wpo] |= ishift_(&sbits, &lshift);
81 } else {
82 rshift = rbits - *nbits;
83 btmp = ishift_(&sbits, &rshift);
84 npack[wpo] &= ishift_(&mask[ubits - 1], &rbits);
85 npack[wpo] |= btmp;
86 i__2 = mask[-rshift - 1] & sbits;
87 i__3 = rshift + 32;
88 btmp = ishift_(&i__2, &i__3);
89 npack[wpo + 1] &= mask[rshift + 31];
90 npack[wpo + 1] |= btmp;
91 }
92 /* L20: */
93 }
94 return 0;
95 } /* sbytes_ */
96
97