diff options
Diffstat (limited to 'sys/osb')
116 files changed, 4820 insertions, 0 deletions
diff --git a/sys/osb/README b/sys/osb/README new file mode 100644 index 00000000..c3fda892 --- /dev/null +++ b/sys/osb/README @@ -0,0 +1,4 @@ +OSB -- Bit and byte primitives. + + zzeps.f - a program to compute the machine epsilon. + (not part of the library) diff --git a/sys/osb/_proto b/sys/osb/_proto new file mode 100644 index 00000000..c247bb87 --- /dev/null +++ b/sys/osb/_proto @@ -0,0 +1,77 @@ +extern int bitmov_(integer *a, integer *aoff, integer *b, integer *boff, integer *nbits); +extern int bswap2_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int bswap4_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int bytmov_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int chrpak_(shortint *a, integer *aoff, char *b, integer *boff, integer *nchars, ftnlen b_len); +extern int chrupk_(char *a, integer *aoff, shortint *b, integer *boff, integer *nchars, ftnlen a_len); +extern int f77pak_(shortint *sppstr, char *f77str, integer *maxch, ftnlen f77str_len); +extern int f77upk_(char *f77str, shortint *sppstr, integer *maxch, ftnlen f77str_len); +extern int ieevpd_(doublereal *native, doublereal *ieee, integer *nelem); +extern int ieevud_(doublereal *ieee, doublereal *native, integer *nelem); +extern int ieepad_(doublereal *x); +extern int ieeupd_(doublereal *x); +extern int ieesnd_(doublereal *x); +extern int ieegnd_(doublereal *x); +extern int ieestd_(integer *onin, integer *onout); +extern int ieezsd_(void); +extern int ieemad_(integer *inval, integer *outval); +extern int ieegmd_(integer *inval, integer *outval); +extern int ieesmd_(integer *inval, integer *outval); +extern int ieevpr_(real *native, real *ieee, integer *nelem); +extern int ieevur_(real *ieee, real *native, integer *nelem); +extern int ieepar_(real *x); +extern int ieeupr_(real *x); +extern int ieesnr_(real *x); +extern int ieegnr_(real *x); +extern int ieestr_(integer *onin, integer *onout); +extern int ieezsr_(void); +extern int ieemar_(integer *inval, integer *outval); +extern int ieegmr_(integer *inval, integer *outval); +extern int ieesmr_(integer *inval, integer *outval); +extern integer miilen_(integer *nelems, integer *miidae); +extern integer miinem_(integer *nchars, integer *miitye); +extern int miipak_(integer *spp, integer *mii, integer *nelems, integer *sppdae, integer *miidae); +extern int miipa6_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipa2_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipa8_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipad_(integer *spp, doublereal *mii, integer *nelems, integer *sppdae); +extern int miipar_(integer *spp, real *mii, integer *nelems, integer *sppdae); +extern integer miipke_(integer *nelems, integer *miitye); +extern int miiupk_(integer *mii, integer *spp, integer *nelems, integer *miidae, integer *sppdae); +extern int miiup6_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiup2_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiup8_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiupd_(doublereal *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiupr_(real *mii, integer *spp, integer *nelems, integer *sppdae); +extern integer nmilen_(integer *nelems, integer *nmidae); +extern integer nminem_(integer *nchars, integer *nmitye); +extern int nmipak_(integer *spp, integer *nmi, integer *nelems, integer *sppdae, integer *nmidae); +extern int nmipa6_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipa2_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipa8_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipad_(integer *spp, doublereal *nmi, integer *nelems, integer *sppdae); +extern int nmipar_(integer *spp, real *nmi, integer *nelems, integer *sppdae); +extern integer nmipke_(integer *nelems, integer *nmitye); +extern int nmiupk_(integer *nmi, integer *spp, integer *nelems, integer *nmidae, integer *sppdae); +extern int nmiup6_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiup2_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiup8_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiupd_(doublereal *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiupr_(real *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int strpak_(shortint *instr, char *outstr, integer *maxch, ftnlen outstr_len); +extern int strupk_(char *instr, shortint *outstr, integer *maxch, ftnlen instr_len); +extern real urand_(integer *lseed); +extern integer xori_(integer *a, integer *b); +extern shortint xors_(shortint *a, shortint *b); +extern integer xorl_(integer *a, integer *b); +extern integer sysruk_(shortint *task, shortint *cmd, integer *rukarf, integer *rukint); +extern int sbit_(void); +extern int tbit_(void); +extern int cseps_(real *seps); +extern logical sgt_(real *value); +extern int cdeps_(doublereal *deps); +extern logical dgt_(doublereal *value); +extern int cseps_(real *seps); +extern logical sgt_(real *value, real *ref); +extern int cdeps_(doublereal *deps); +extern logical dgt_(doublereal *value, doublereal *ref); diff --git a/sys/osb/abs.c b/sys/osb/abs.c new file mode 100644 index 00000000..90bd3ad6 --- /dev/null +++ b/sys/osb/abs.c @@ -0,0 +1,13 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#include <iraf.h> + +/* ABS -- Integer absolute value. + */ +XINT +abs_ (XINT *a) +{ + return (abs(a)); +} diff --git a/sys/osb/achtb.gc b/sys/osb/achtb.gc new file mode 100644 index 00000000..dd5f97d2 --- /dev/null +++ b/sys/osb/achtb.gc @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTB$T ( + XCHAR *a, + $if (datatype == B) + XCHAR *b, + $else + XPIXEL *b, + $endif + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XPIXEL *op; + + for (ip = &first[*npix], op = &((XPIXEL *)b)[*npix]; ip > first; ) + $if (datatype == x) + (--op)->r = (float) *--ip; + $else + *--op = *--ip; + $endif +} diff --git a/sys/osb/achtbb.c b/sys/osb/achtbb.c new file mode 100644 index 00000000..26a48e99 --- /dev/null +++ b/sys/osb/achtbb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBB ( + XCHAR *a, + XCHAR *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XUBYTE *op; + + for (ip = &first[*npix], op = &((XUBYTE *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbc.c b/sys/osb/achtbc.c new file mode 100644 index 00000000..a1a778c2 --- /dev/null +++ b/sys/osb/achtbc.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBC ( + XCHAR *a, + XCHAR *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XCHAR *op; + + for (ip = &first[*npix], op = &((XCHAR *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbd.c b/sys/osb/achtbd.c new file mode 100644 index 00000000..deb2f23a --- /dev/null +++ b/sys/osb/achtbd.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBD ( + XCHAR *a, + XDOUBLE *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XDOUBLE *op; + + for (ip = &first[*npix], op = &((XDOUBLE *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbi.c b/sys/osb/achtbi.c new file mode 100644 index 00000000..41733ce8 --- /dev/null +++ b/sys/osb/achtbi.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBI ( + XCHAR *a, + XINT *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XINT *op; + + for (ip = &first[*npix], op = &((XINT *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbl.c b/sys/osb/achtbl.c new file mode 100644 index 00000000..a1090d62 --- /dev/null +++ b/sys/osb/achtbl.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBL ( + XCHAR *a, + XLONG *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XLONG *op; + + for (ip = &first[*npix], op = &((XLONG *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbr.c b/sys/osb/achtbr.c new file mode 100644 index 00000000..72839ce9 --- /dev/null +++ b/sys/osb/achtbr.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBR ( + XCHAR *a, + XREAL *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XREAL *op; + + for (ip = &first[*npix], op = &((XREAL *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbs.c b/sys/osb/achtbs.c new file mode 100644 index 00000000..da68e65d --- /dev/null +++ b/sys/osb/achtbs.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBS ( + XCHAR *a, + XSHORT *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XSHORT *op; + + for (ip = &first[*npix], op = &((XSHORT *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbu.c b/sys/osb/achtbu.c new file mode 100644 index 00000000..45b523ca --- /dev/null +++ b/sys/osb/achtbu.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBU ( + XCHAR *a, + XUSHORT *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XUSHORT *op; + + for (ip = &first[*npix], op = &((XUSHORT *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbx.c b/sys/osb/achtbx.c new file mode 100644 index 00000000..a62a48c1 --- /dev/null +++ b/sys/osb/achtbx.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBX ( + XCHAR *a, + XCOMPLEX *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XCOMPLEX *op; + + for (ip = &first[*npix], op = &((XCOMPLEX *)b)[*npix]; ip > first; ) + (--op)->r = (float) *--ip; +} diff --git a/sys/osb/achtcb.c b/sys/osb/achtcb.c new file mode 100644 index 00000000..d9749e62 --- /dev/null +++ b/sys/osb/achtcb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTCB ( + XCHAR *a, + XCHAR *b, + XINT *npix +) +{ + register XCHAR *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XCHAR *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtcu.c b/sys/osb/achtcu.c new file mode 100644 index 00000000..1a0b3d1c --- /dev/null +++ b/sys/osb/achtcu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTCU ( + XCHAR *a, + XUSHORT *b, + XINT *npix +) +{ + register XCHAR *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtdb.c b/sys/osb/achtdb.c new file mode 100644 index 00000000..e7cd0663 --- /dev/null +++ b/sys/osb/achtdb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTDB ( + XDOUBLE *a, + XCHAR *b, + XINT *npix +) +{ + register XDOUBLE *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XDOUBLE *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtdu.c b/sys/osb/achtdu.c new file mode 100644 index 00000000..bcea4762 --- /dev/null +++ b/sys/osb/achtdu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTDU ( + XDOUBLE *a, + XUSHORT *b, + XINT *npix +) +{ + register XDOUBLE *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtib.c b/sys/osb/achtib.c new file mode 100644 index 00000000..74977f40 --- /dev/null +++ b/sys/osb/achtib.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTIB ( + XINT *a, + XCHAR *b, + XINT *npix +) +{ + register XINT *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XINT *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtiu.c b/sys/osb/achtiu.c new file mode 100644 index 00000000..5b14bd43 --- /dev/null +++ b/sys/osb/achtiu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTIU ( + XINT *a, + XUSHORT *b, + XINT *npix +) +{ + register XINT *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtlb.c b/sys/osb/achtlb.c new file mode 100644 index 00000000..fcf63a87 --- /dev/null +++ b/sys/osb/achtlb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTLB ( + XLONG *a, + XCHAR *b, + XINT *npix +) +{ + register XLONG *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XLONG *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtlu.c b/sys/osb/achtlu.c new file mode 100644 index 00000000..a669577e --- /dev/null +++ b/sys/osb/achtlu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTLU ( + XLONG *a, + XUSHORT *b, + XINT *npix +) +{ + register XLONG *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtrb.c b/sys/osb/achtrb.c new file mode 100644 index 00000000..47d27e87 --- /dev/null +++ b/sys/osb/achtrb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTRB ( + XREAL *a, + XCHAR *b, + XINT *npix +) +{ + register XREAL *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XREAL *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtru.c b/sys/osb/achtru.c new file mode 100644 index 00000000..70a99f7f --- /dev/null +++ b/sys/osb/achtru.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTRU ( + XREAL *a, + XUSHORT *b, + XINT *npix +) +{ + register XREAL *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtsb.c b/sys/osb/achtsb.c new file mode 100644 index 00000000..f8453873 --- /dev/null +++ b/sys/osb/achtsb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTSB ( + XSHORT *a, + XCHAR *b, + XINT *npix +) +{ + register XSHORT *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XSHORT *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtsu.c b/sys/osb/achtsu.c new file mode 100644 index 00000000..269a5122 --- /dev/null +++ b/sys/osb/achtsu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTSU ( + XSHORT *a, + XUSHORT *b, + XINT *npix +) +{ + register XSHORT *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtu.gc b/sys/osb/achtu.gc new file mode 100644 index 00000000..35e8f226 --- /dev/null +++ b/sys/osb/achtu.gc @@ -0,0 +1,37 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTU$T ( + XUSHORT *a, + XPIXEL *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XPIXEL *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + $if (datatype == x) + (--op)->r = (float) *--ip; + $else + *--op = *--ip; + $endif + } else { + for (ip=a, op=b; --n >= 0; ) + $if (datatype == x) + (op++)->r = (float) *ip++; + $else + *op++ = *ip++; + $endif + } +} diff --git a/sys/osb/achtub.c b/sys/osb/achtub.c new file mode 100644 index 00000000..a772f3f0 --- /dev/null +++ b/sys/osb/achtub.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUB ( + XUSHORT *a, + XUBYTE *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XUBYTE *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtuc.c b/sys/osb/achtuc.c new file mode 100644 index 00000000..7779e036 --- /dev/null +++ b/sys/osb/achtuc.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUC ( + XUSHORT *a, + XCHAR *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XCHAR *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtud.c b/sys/osb/achtud.c new file mode 100644 index 00000000..0d825c3b --- /dev/null +++ b/sys/osb/achtud.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUD ( + XUSHORT *a, + XDOUBLE *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XDOUBLE *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtui.c b/sys/osb/achtui.c new file mode 100644 index 00000000..dea6c326 --- /dev/null +++ b/sys/osb/achtui.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUI ( + XUSHORT *a, + XINT *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XINT *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtul.c b/sys/osb/achtul.c new file mode 100644 index 00000000..f6b0b94e --- /dev/null +++ b/sys/osb/achtul.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUL ( + XUSHORT *a, + XLONG *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XLONG *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtur.c b/sys/osb/achtur.c new file mode 100644 index 00000000..eebaba1c --- /dev/null +++ b/sys/osb/achtur.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUR ( + XUSHORT *a, + XREAL *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XREAL *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtus.c b/sys/osb/achtus.c new file mode 100644 index 00000000..dc940362 --- /dev/null +++ b/sys/osb/achtus.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUS ( + XUSHORT *a, + XSHORT *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XSHORT *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtuu.c b/sys/osb/achtuu.c new file mode 100644 index 00000000..55168dea --- /dev/null +++ b/sys/osb/achtuu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUU ( + XUSHORT *a, + XUSHORT *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtux.c b/sys/osb/achtux.c new file mode 100644 index 00000000..bf44a0ce --- /dev/null +++ b/sys/osb/achtux.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUX ( + XUSHORT *a, + XCOMPLEX *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XCOMPLEX *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + (--op)->r = (float) *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + (op++)->r = (float) *ip++; + } +} diff --git a/sys/osb/achtxb.c b/sys/osb/achtxb.c new file mode 100644 index 00000000..62dd0274 --- /dev/null +++ b/sys/osb/achtxb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTXB ( + XCOMPLEX *a, + XCHAR *b, + XINT *npix +) +{ + register XCOMPLEX *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XCOMPLEX *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = (int) (ip++)->r; +} diff --git a/sys/osb/achtxu.c b/sys/osb/achtxu.c new file mode 100644 index 00000000..a5bd8a71 --- /dev/null +++ b/sys/osb/achtxu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTXU ( + XCOMPLEX *a, + XUSHORT *b, + XINT *npix +) +{ + register XCOMPLEX *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = (int) (--ip)->r; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = (int) (ip++)->r; + } +} diff --git a/sys/osb/achtzb.gc b/sys/osb/achtzb.gc new file mode 100644 index 00000000..27ef9a48 --- /dev/null +++ b/sys/osb/achtzb.gc @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHT$TB ( + $if (datatype == B) + XCHAR *a, + $else + XPIXEL *a, + $endif + XCHAR *b, + XINT *npix +) +{ + register XPIXEL *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XPIXEL *)a, op=(XUBYTE *)b; --n >= 0; ) + $if (datatype == x) + *op++ = (int) (ip++)->r; + $else + *op++ = *ip++; + $endif +} diff --git a/sys/osb/achtzu.gc b/sys/osb/achtzu.gc new file mode 100644 index 00000000..4e5faacd --- /dev/null +++ b/sys/osb/achtzu.gc @@ -0,0 +1,37 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHT$TU ( + XPIXEL *a, + XUSHORT *b, + XINT *npix +) +{ + register XPIXEL *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + $if (datatype == x) + *--op = (int) (--ip)->r; + $else + *--op = *--ip; + $endif + } else { + for (ip=a, op=b; --n >= 0; ) + $if (datatype == x) + *op++ = (int) (ip++)->r; + $else + *op++ = *ip++; + $endif + } +} diff --git a/sys/osb/aclrb.c b/sys/osb/aclrb.c new file mode 100644 index 00000000..15d63e39 --- /dev/null +++ b/sys/osb/aclrb.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ACLRB -- Clear a block of memory. + */ +void +ACLRB (XCHAR *a, XINT *nbytes) +{ + register char *p; + register int n; + + for (p=(char *)a, n = *nbytes; --n >= 0; ) + *p++ = 0; +} diff --git a/sys/osb/and.c b/sys/osb/and.c new file mode 100644 index 00000000..98dcbb07 --- /dev/null +++ b/sys/osb/and.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ANDI -- Bitwise boolean AND of two integer variables. + */ +XINT +ANDI (XINT *a, XINT *b) +{ + return (*a & *b); +} + + +/* ANDS -- Bitwise boolean AND of two short integer variables. + */ +XSHORT +ANDS (XSHORT *a, XSHORT *b) +{ + return (*a & *b); +} + + +/* ANDL -- Bitwise boolean AND of two long integer variables. + */ +XLONG +ANDL (XLONG *a, XLONG *b) +{ + return (*a & *b); +} diff --git a/sys/osb/bitfields.c b/sys/osb/bitfields.c new file mode 100644 index 00000000..3275c542 --- /dev/null +++ b/sys/osb/bitfields.c @@ -0,0 +1,70 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* + * BITFIELDS.C -- Portable C routines for extracting and inserting small + * integers into an integer value. + */ + +unsigned XINT bitmask[] = { 0, /* MACHDEP */ + 01, 03, 07, + 017, 037, 077, + 0177, 0377, 0777, + 01777, 03777, 07777, + 017777, 037777, 077777, + 0177777, 0377777, 0777777, + 01777777, 03777777, 07777777, + 017777777, 037777777, 077777777, + 0177777777, 0377777777, 0777777777, + 01777777777, 03777777777, 07777777777, + 017777777777, 037777777777, 077777777777, + 0177777777777, 0377777777777, 0777777777777, + 01777777777777, 03777777777777, 07777777777777, + 017777777777777, 037777777777777, 077777777777777, + 0177777777777777, 0377777777777777, 0777777777777777, + 01777777777777777, 03777777777777777, 07777777777777777, + 017777777777777777, 037777777777777777, 077777777777777777, + 0177777777777777777, 0377777777777777777, 0777777777777777777, + 01777777777777777777, 03777777777777777777, 07777777777777777777, + 017777777777777777777, 037777777777777777777, 077777777777777777777, + 0177777777777777777777, 0377777777777777777777, 0777777777777777777777, + 01777777777777777777777, 03777777777777777777777, 07777777777777777777777 +}; + + + +/* BITPAK -- Pack an unsigned integer value into a bitfield in a longword. + * The size of the bitfield may not exceed the number of bits in an integer. + */ +void +BITPAK ( + unsigned XINT *ival, /* value to be placed in bitfield */ + unsigned XINT *wordp, /* longword to be written into */ + XINT *offset, /* one-indexed offset of first bit */ + XINT *nbits /* number of bits to be set */ +) +{ + register unsigned XINT shift; + register unsigned XINT mask; + + shift = *offset - 1; + mask = bitmask[*nbits] << shift; + *wordp = (*wordp & ~mask) | ((*ival << shift) & mask); +} + + +/* BITUPK -- Unpack an unsigned integer bit field from a longword. + */ +XINT +BITUPK ( + unsigned XINT *wordp, /* longword to be examined */ + XINT *offset, /* one-indexed offset of first bit */ + XINT *nbits /* number of bits to be set */ +) +{ + return ((*wordp >> (*offset-1)) & bitmask[*nbits]); +} diff --git a/sys/osb/bitmov.x b/sys/osb/bitmov.x new file mode 100644 index 00000000..f6784b2a --- /dev/null +++ b/sys/osb/bitmov.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# BITMOV -- Move a sequence of bits in a bit array of arbitrary length. + +procedure bitmov (a, a_off, b, b_off, nbits) + +int a[ARB] # input bit array +int a_off # first bit to be moved +int b[ARB] # output bit array +int b_off # first bit to be written +int nbits # number of bits to be moved + +int ip, op, ip_top, nbits_left +int bitupk() + +begin + ip_top = a_off + nbits - NBITS_INT + op = b_off + + for (ip = a_off; ip <= ip_top; ip = ip + NBITS_INT) { + call bitpak (bitupk(a,ip,NBITS_INT), b, op, NBITS_INT) + op = op + NBITS_INT + } + + nbits_left = (a_off + nbits) - ip + if (nbits_left > 0) + call bitpak (bitupk(a,ip,nbits_left), b, op, nbits_left) +end diff --git a/sys/osb/bswap2.c b/sys/osb/bswap2.c new file mode 100644 index 00000000..a2c08030 --- /dev/null +++ b/sys/osb/bswap2.c @@ -0,0 +1,38 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* BSWAP2 - Move bytes from array "a" to array "b", swapping successive + * pairs of bytes. The two arrays may be the same but may not be offset + * and overlapping. + */ +BSWAP2 (a, aoff, b, boff, nbytes) +XCHAR *a; /* input array */ +XINT *aoff; /* first byte in input array */ +XCHAR *b; /* output array */ +XINT *boff; /* first byte in output array */ +XINT *nbytes; /* number of bytes to swap */ +{ + register char *ip, *op, *otop; + register unsigned temp; + + ip = (char *)a + *aoff - 1; + op = (char *)b + *boff - 1; + otop = op + (*nbytes & ~1); + + /* Swap successive pairs of bytes. + */ + while (op < otop) { + temp = *ip++; + *op++ = *ip++; + *op++ = temp; + } + + /* If there is an odd byte left, move it to the output array. + */ + if (*nbytes & 1) + *op = *ip; +} diff --git a/sys/osb/bswap2.f b/sys/osb/bswap2.f new file mode 100644 index 00000000..700c8498 --- /dev/null +++ b/sys/osb/bswap2.f @@ -0,0 +1,20 @@ +c BSWAP2 - Move bytes from array "a" to array "b", swapping successive +c pairs of bytes. + + subroutine bswap2 (a, aoff, b, boff, nbytes) + + character*1 a(*), b(*), temp + integer aoff, boff, nbytes, i + integer aoff1, boff1 + + aoff1 = aoff + 1 + boff1 = boff + 1 + + do 10 i = 0, nbytes-1, 2 + temp = a(aoff1+i) + if (i .ne. nbytes) then + b(boff1+i) = a(aoff+i) + endif + b(boff+i) = temp + 10 continue + end diff --git a/sys/osb/bswap4.c b/sys/osb/bswap4.c new file mode 100644 index 00000000..763633a5 --- /dev/null +++ b/sys/osb/bswap4.c @@ -0,0 +1,46 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* BSWAP4 - Move bytes from array "a" to array "b", swapping the four bytes + * in each successive 4 byte group, i.e., 12345678 becomes 43218765. + * The input and output arrays may be the same but may not partially overlap. + */ +BSWAP4 (a, aoff, b, boff, nbytes) +XCHAR *a; /* input array */ +XINT *aoff; /* first byte in input array */ +XCHAR *b; /* output array */ +XINT *boff; /* first byte in output array */ +XINT *nbytes; /* number of bytes to swap */ +{ + register char *ip, *op, *tp; + register int n; + static char temp[4]; + + tp = temp; + ip = (char *)a + *aoff - 1; + op = (char *)b + *boff - 1; + + /* Swap successive four byte groups. + */ + for (n = *nbytes >> 2; --n >= 0; ) { + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + } + + /* If there are any odd bytes left, move them to the output array. + * Do not bother to swap as it is unclear how to swap a partial + * group, and really incorrect if the data is not modulus 4. + */ + for (n = *nbytes & 03; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/bswap4.f b/sys/osb/bswap4.f new file mode 100644 index 00000000..1cfa107c --- /dev/null +++ b/sys/osb/bswap4.f @@ -0,0 +1,29 @@ +c BSWAP4 - Move bytes from array "a" to array "b", swapping the four bytes +c in each successive 4 byte group, i.e., 12345678 becomes 43218765. + + subroutine bswap4 (a, aoff, b, boff, nbytes) + + character*1 a(*), b(*), temp + integer aoff, boff, nbytes, i + integer aoff1, boff1, aoff2, boff2, aoff3, boff3 + + if (nbytes .le. 4) then + return + endif + + aoff1 = aoff + 1 + boff1 = boff + 1 + aoff2 = aoff + 2 + boff2 = boff + 2 + aoff3 = aoff + 3 + boff3 = boff + 3 + + do 10 i = 0, nbytes-3, 4 + temp = a(aoff1+i) + b(boff1+i) = a(aoff2+i) + b(boff2+i) = temp + temp = a(aoff3+i) + b(boff3+i) = a(aoff+i) + b(boff+i) = temp + 10 continue + end diff --git a/sys/osb/bswap8.c b/sys/osb/bswap8.c new file mode 100644 index 00000000..ff544b7d --- /dev/null +++ b/sys/osb/bswap8.c @@ -0,0 +1,54 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* BSWAP8 - Move bytes from array "a" to array "b", swapping the eight bytes + * in each successive 8 byte group, i.e., 12345678 becomes 87654321. + * The input and output arrays may be the same but may not partially overlap. + */ +BSWAP8 (a, aoff, b, boff, nbytes) +XCHAR *a; /* input array */ +XINT *aoff; /* first byte in input array */ +XCHAR *b; /* output array */ +XINT *boff; /* first byte in output array */ +XINT *nbytes; /* number of bytes to swap */ +{ + register char *ip, *op, *tp; + register int n; + static char temp[8]; + + tp = temp; + ip = (char *)a + *aoff - 1; + op = (char *)b + *boff - 1; + + /* Swap successive eight byte groups. + */ + for (n = *nbytes >> 3; --n >= 0; ) { + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + } + + /* If there are any odd bytes left, move them to the output array. + * Do not bother to swap as it is unclear how to swap a partial + * group, and really incorrect if the data is not modulus 8. + */ + for (n = *nbytes & 03; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/bytmov.c b/sys/osb/bytmov.c new file mode 120000 index 00000000..90b667eb --- /dev/null +++ b/sys/osb/bytmov.c @@ -0,0 +1 @@ +/iraf/iraf/unix/as/bytmov.c
\ No newline at end of file diff --git a/sys/osb/bytmov.f b/sys/osb/bytmov.f new file mode 100644 index 00000000..b866e852 --- /dev/null +++ b/sys/osb/bytmov.f @@ -0,0 +1,27 @@ +c BYTMOV -- Byte move from array "a" to array "b". The move must be +c nondestructive, allowing a byte array to be shifted left or right a +c few bytes, hence calls to zlocva() are required to get the addresses of +c the arrays. + + subroutine bytmov (a, aoff, b, boff, nbytes) + + character*1 a(*), b(*) + integer aoff, boff, nbytes + integer fwaa, lwaa, fwab, i + + call zlocva (a(aoff), fwaa) + call zlocva (a(aoff+nbytes-1), lwaa) + call zlocva (b(boff), fwab) + + if (fwaa .eq. fwab) then + return + else if (fwab .ge. fwaa .and. fwab .le. lwaa) then + do 10 i = nbytes-1, 0, -1 + b(boff+i) = a(aoff+i) + 10 continue + else + do 20 i = 0, nbytes-1 + b(boff+i) = a(aoff+i) + 20 continue + endif + end diff --git a/sys/osb/chrpak.c b/sys/osb/chrpak.c new file mode 100644 index 00000000..3a1356a8 --- /dev/null +++ b/sys/osb/chrpak.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* CHRPAK -- Pack a counted string of XCHAR into bytes. This routine does not + * know about EOS terminators. The input and output arrays may be the same. + * Note that while XCHAR is signed, the signedness of the C char is unspecified, + * hence we pack the chars in unsigned bytes, dealing explicitly with any + * negative values. + */ +CHRPAK (a, a_off, b, b_off, nchars) +XCHAR *a, *b; +XINT *a_off, *b_off, *nchars; +{ + register XCHAR *ip; + register unsigned char *op; + register int n, ch; + + ip = &a[*a_off-1]; + op = &((unsigned char *)b)[*b_off-1]; + n = *nchars; + + while (--n >= 0) + *op++ = ((ch = *ip++) >= 0) ? ch : ch + 256; +} diff --git a/sys/osb/chrpak.f b/sys/osb/chrpak.f new file mode 100644 index 00000000..e34812fc --- /dev/null +++ b/sys/osb/chrpak.f @@ -0,0 +1,13 @@ +c CHRPAK -- Pack XCHAR (integer*2) into bytes. Should work on most byte +c addressable machines. The input and output arrays may be the same. + + subroutine chrpak (a, aoff, b, boff, nchars) + + integer*2 a(*) + character*1 b(*) + integer aoff, boff, nchars, i + + do 10 i = 0, nchars-1 + b(boff+i) = char (a(aoff+i)) + 10 continue + end diff --git a/sys/osb/chrupk.c b/sys/osb/chrupk.c new file mode 100644 index 00000000..f909c8d9 --- /dev/null +++ b/sys/osb/chrupk.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* CHRUPK -- Unpack a byte string into XCHAR. This routine does not + * know about EOS terminators. The input and output arrays may be the same. + * Note that while XCHAR is signed, the signedness of the C char is unspecified, + * hence we pack the chars into unsigned bytes and restore the sign explicitly. + */ +CHRUPK (a, a_off, b, b_off, nchars) +XCHAR *a, *b; +XINT *a_off, *b_off, *nchars; +{ + register unsigned char *ip; + register XCHAR *op; + register int n, ch; + + /* Set pointers to last char plus one so that we can unpack the array + * in the reverse direction. + */ + n = *nchars; + ip = &((unsigned char *)a)[*a_off-1+n]; + op = &b[*b_off-1+n]; + + /* Unpack string from right to left. + */ + while (--n >= 0) + *--op = ((ch = *--ip) <= 127) ? ch : ch - 256; +} diff --git a/sys/osb/chrupk.f b/sys/osb/chrupk.f new file mode 100644 index 00000000..3a1d7f44 --- /dev/null +++ b/sys/osb/chrupk.f @@ -0,0 +1,13 @@ +c CHRUPK -- Unpack bytes into XCHAR (integer*2). Should work on most byte +c addressable machines. The input and output arrays may be the same. + + subroutine chrupk (a, aoff, b, boff, nchars) + + character*1 a(*) + integer*2 b(*) + integer aoff, boff, nchars, i + + do 10 i = 0, nchars-1 + b(boff+i) = ichar (a(aoff+i)) + 10 continue + end diff --git a/sys/osb/d1mach.f b/sys/osb/d1mach.f new file mode 120000 index 00000000..12ea8148 --- /dev/null +++ b/sys/osb/d1mach.f @@ -0,0 +1 @@ +/iraf/iraf/unix/hlib/d1mach.f
\ No newline at end of file diff --git a/sys/osb/f77pak.f b/sys/osb/f77pak.f new file mode 100644 index 00000000..db7df6f0 --- /dev/null +++ b/sys/osb/f77pak.f @@ -0,0 +1,32 @@ +c F77PAK -- Convert an SPP string into a Fortran 77 string. +c + subroutine f77pak (sppstr, f77str, maxch) +c + integer*2 sppstr(*) + character*(*) f77str + integer maxch + integer i, ch, last, maxout, EOS + parameter (EOS=0) +c + maxout = min (maxch, len(f77str)) +c +c # Unpack the EOS delimited SPP string. + last = maxout + do 10 i = 1, maxout + ch = sppstr(i) + if (ch .eq. EOS) then + last = i - 1 + goto 20 + endif + f77str(i:i) = char (ch) + 10 continue + 20 continue +c +c # Pad on the right with blanks. + if (last .gt. maxch) last = maxch + if (last .le. 0) then + f77str = ' ' + else + f77str = f77str(1:last) + endif + end diff --git a/sys/osb/f77upk.f b/sys/osb/f77upk.f new file mode 100644 index 00000000..fc875008 --- /dev/null +++ b/sys/osb/f77upk.f @@ -0,0 +1,26 @@ +c F77UPK -- Convert a Fortran 77 string into an SPP string. Unpack +c each Fortran character into an SPP char and trim the blank padding +c at the right. +c + subroutine f77upk (f77str, sppstr, maxch) +c + character*(*) f77str + integer*2 sppstr(*) + integer maxch + integer lastch, nchars, i + integer EOS, BLANK + parameter (EOS=0, BLANK=32) +c +c -- Unpack string. + nchars = min (maxch, len(f77str)) + lastch = 0 + do 10 i = 1, nchars + sppstr(i) = ichar (f77str(i:i)) + if (sppstr(i) .gt. BLANK) lastch = i + 10 continue +c +c -- Add EOS delimiter to SPP string, trimming blank padding at right. + if (lastch .gt. maxch) lastch = maxch + sppstr(lastch+1) = EOS +c + end diff --git a/sys/osb/i1mach.f b/sys/osb/i1mach.f new file mode 120000 index 00000000..3cfa7dae --- /dev/null +++ b/sys/osb/i1mach.f @@ -0,0 +1 @@ +/iraf/iraf/unix/hlib/i1mach.f
\ No newline at end of file diff --git a/sys/osb/i32to64.c b/sys/osb/i32to64.c new file mode 100644 index 00000000..4b4b00d1 --- /dev/null +++ b/sys/osb/i32to64.c @@ -0,0 +1,42 @@ +#define import_spp +#define import_knames +#include <iraf.h> + +/* I32TO64 - Convert big endian 32bit integer array into 64bit. + */ +int +I32TO64 (void *a, void *b, XINT *nelems) +{ + XINT i, j, k; + char *ip = (char *) a, + *op = (char *) b; + + + j = *nelems * 8; + k = *nelems * 4; + + if ( ip < op ) { + for ( i = k ; 0 < i ; i-- ) + op[i-1] = ip[i-1]; + } + else if ( op < ip ) { + for ( i = 0 ; i < k ; i++ ) + op[i] = ip[i]; + } + + for ( i=0 ; i < *nelems ; i++ ) { + char pad; + op[--j] = op[--k]; + op[--j] = op[--k]; + op[--j] = op[--k]; + op[--j] = op[--k]; + if ( (op[k] & 0x080) != 0 ) pad = 0x0ff; + else pad = 0; + op[--j] = pad; + op[--j] = pad; + op[--j] = pad; + op[--j] = pad; + } + + return 0; +} diff --git a/sys/osb/i64to32.c b/sys/osb/i64to32.c new file mode 100644 index 00000000..2b6a619c --- /dev/null +++ b/sys/osb/i64to32.c @@ -0,0 +1,98 @@ +#define import_spp +#define import_knames +#include <iraf.h> + +/* I64TO32 - Convert big endian 64bit integer array into 32bit. + */ +int +I64TO32 (void *a, void *b, XINT *nelems) +{ + char *ip = (char *)a, + *op = (char *)b; + XINT i; + + + /* + * in |--------| + * out |----| + */ + if ( op <= ip ) { + for ( i=0 ; i < *nelems ; i++ ) { + ip += 4; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + } + } + else { + + char *ipe = (char *)a + *nelems * 8 - 1; + char *ope = (char *)b + *nelems * 4 - 1; + + /* + * in |--------| + * out |----| + */ + if ( ipe <= ope ) { + for ( i=0 ; i < *nelems ; i++ ) { + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + ipe -= 4; + } + } + /* + * in |--------| + * out |----| + */ + else { + + for ( i=0 ; i < *nelems ; i++ ) { + /* --------> */ + ip += 4; + if ( op < ip ) { + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + } + else { + op += 4; + ip += 4; + } + /* <-------- */ + if ( ipe < ope ) { + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + } + else { + ope -= 4; + ipe -= 4; + } + ipe -= 4; + } + } + } + + return 0; +} diff --git a/sys/osb/iand32.c b/sys/osb/iand32.c new file mode 100644 index 00000000..b812cad5 --- /dev/null +++ b/sys/osb/iand32.c @@ -0,0 +1,12 @@ + +#define iand32 iand32_ + +long +iand32 (long *a, long *b) +{ + long val = 0; + int ia = (int) (*a >> 32), ib = (int) *b; + + val = (ia & ib); + return ((long) val); +} diff --git a/sys/osb/ieee.gx b/sys/osb/ieee.gx new file mode 100644 index 00000000..64659cd3 --- /dev/null +++ b/sys/osb/ieee.gx @@ -0,0 +1,391 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (ival, val) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (val, ival) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/sys/osb/ieeed.x b/sys/osb/ieeed.x new file mode 100644 index 00000000..f29c1aa3 --- /dev/null +++ b/sys/osb/ieeed.x @@ -0,0 +1,356 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (ival, val) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (val, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/sys/osb/ieeer.x b/sys/osb/ieeer.x new file mode 100644 index 00000000..59ce8566 --- /dev/null +++ b/sys/osb/ieeer.x @@ -0,0 +1,345 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in <mach.h>. + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (ival, val) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (val, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/sys/osb/imul32.c b/sys/osb/imul32.c new file mode 100644 index 00000000..237bd5fa --- /dev/null +++ b/sys/osb/imul32.c @@ -0,0 +1,24 @@ +#define import_spp +#define import_knames +#include <iraf.h> + + +/* IMUL32 - Multiply two integer values and return the result. This is + * needed to allow e.g. the normal overflow condition to occur for algorithms + * such as random number generators. + */ +int +IMUL32 (long *a, long *b) +{ + int val = 0; + int ia = (int) *a; + int ib = (int) *b; + + + /* MACHDEP - Depends on integer overflow behavior for a specific + * platform. + */ + val = ia * ib; + + return ((int) val); +} diff --git a/sys/osb/ipak16.c b/sys/osb/ipak16.c new file mode 100644 index 00000000..94670857 --- /dev/null +++ b/sys/osb/ipak16.c @@ -0,0 +1,20 @@ +#define import_spp +#define import_knames +#include <iraf.h> + +/* IPAK16 - Pack an array of native ints into and array of 16-bit short. + */ +void +IPAK16 (void *a, void *b, XINT *nelems) +{ + /* MACHDEP - Works only for little-endian systems (e.g. x86) + */ + int i = 0; + int *ip = (int *) a; + short *op = (short *) b; + + for (i=0; i < *nelems; i++) { + *op = (int) *ip; + op++, ip++; + } +} diff --git a/sys/osb/ipak32.c b/sys/osb/ipak32.c new file mode 100644 index 00000000..a4f5061b --- /dev/null +++ b/sys/osb/ipak32.c @@ -0,0 +1,23 @@ +#define import_spp +#define import_knames +#include <iraf.h> + +/* IPAK32 - Pack 64-bit int into and array of 32-bit int. + */ +void +IPAK32 (void *a, void *b, XINT *nelems) +{ + /* MACHDEP - Works only for little-endian systems (e.g. x86) + */ + XINT *ip = (XINT *) a; + int *op = (int *) calloc (*nelems, sizeof (int)); + int *tmp, i; + + tmp = op; + for (i=0; i < *nelems; i++, ip++) { + *tmp++ = (int) (*ip); + } + memmove (b, op, *nelems * sizeof (int)); + + free (op); +} diff --git a/sys/osb/iscl32.c b/sys/osb/iscl32.c new file mode 100644 index 00000000..75e51082 --- /dev/null +++ b/sys/osb/iscl32.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <stdlib.h> +#include <iraf.h> + + +/* ISCL32 - Scale a pixel array stored as SPP chars to the desired type. + */ +ISCL32 (a, b, npix, bscale, bzero) +XCHAR *a; /* input array */ +XCHAR *b; /* output array */ +XINT *npix; /* number of bytes to swap */ +XDOUBLE *bscale, *bzero; /* scaling factors */ +{ + int i, pix; + int *ip = (int *) a; + float *rp = (float *) calloc (*npix, sizeof (float)); + float *tmp; + + tmp = rp; + for (i=0; i < *npix; i++) { + pix = *ip; + *tmp = (float) (pix * (*bscale) + (*bzero)); + tmp++, ip++; + } + + memmove (b, rp, (*npix * sizeof (float))); +} diff --git a/sys/osb/iscl64.c b/sys/osb/iscl64.c new file mode 100644 index 00000000..6a8b624c --- /dev/null +++ b/sys/osb/iscl64.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <stdlib.h> +#include <iraf.h> + + +/* ISCL64 - Scale a pixel array stored as SPP chars to the desired type. + */ +ISCL64 (a, b, npix, bscale, bzero) +XCHAR *a; /* input array */ +XCHAR *b; /* output array */ +XINT *npix; /* number of bytes to swap */ +XDOUBLE *bscale, *bzero; /* scaling factors */ +{ + int i, pix; + int *ip = (int *) a; + double *dp = (double *) calloc (*npix, sizeof (double)); + double *tmp; + + tmp = dp; + for (i=0; i < *npix; i++) { + pix = *ip; + *tmp = (double) (pix * (*bscale) + (*bzero)); + tmp++, ip++; + } + + memmove (b, dp, (*npix * sizeof (double))); +} diff --git a/sys/osb/iupk16.c b/sys/osb/iupk16.c new file mode 100644 index 00000000..10b5c064 --- /dev/null +++ b/sys/osb/iupk16.c @@ -0,0 +1,21 @@ +#define import_spp +#define import_knames +#include <iraf.h> + + +/* IUPK16 - Unpack 16-bit int into and array of native integers. + */ +void +IUPK16 (void *a, void *b, XINT *nelems) +{ + int i; + int *op = (int *) calloc (*nelems, sizeof (int)), *tmp; + short *ip = (short *) a; + + tmp = op; + for (i=0; i < *nelems; i++) + *tmp++ = *ip++; + + memmove (b, op, *nelems * sizeof (int)); + free (op); +} diff --git a/sys/osb/iupk32.c b/sys/osb/iupk32.c new file mode 100644 index 00000000..a280b805 --- /dev/null +++ b/sys/osb/iupk32.c @@ -0,0 +1,23 @@ +#define import_spp +#define import_knames +#include <iraf.h> + + +/* IUPK32 - Unpack 32-bit int into and array of 64-bit int. + */ +void +IUPK32 (void *a, void *b, XINT *nelems) +{ + XINT i, *tmp; + XINT *op = (XINT *) calloc (*nelems, sizeof (XINT)); + int *ip = (int *) a; + + + tmp = op; + for (i=0; i < *nelems; i++) { + *tmp++ = *ip++; + } + memmove (b, op, *nelems * sizeof (XINT)); + + free (op); +} diff --git a/sys/osb/miilen.x b/sys/osb/miilen.x new file mode 100644 index 00000000..1eb16d1a --- /dev/null +++ b/sys/osb/miilen.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIILEN -- Determine the number of SPP integers to store nelems of type +# mii_type. The mii_type are defined in mii.h. +# +# THIS PROCEDURE HAS BEEN OBSOLETED BY MIIPAKLEN. + +int procedure miilen (nelems, mii_datatype) + +int nelems #I number of MII data elements +int mii_datatype #I datatype of MII data + +begin + return (((nelems * abs(mii_datatype) / NBITS_BYTE + SZB_CHAR - 1) / + SZB_CHAR + SZ_INT32 - 1) / SZ_INT32) +end diff --git a/sys/osb/miinelem.x b/sys/osb/miinelem.x new file mode 100644 index 00000000..2ae53882 --- /dev/null +++ b/sys/osb/miinelem.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIINELEM -- Determine the number of MII elements of the given datatype +# which can be stored in an SPP char array of the indicated length. +# The mii_type codes are defined in mii.h; we assume here that the codes +# used are the number of bits in each MII type. + +int procedure miinelem (nchars, mii_type) + +int nchars #I size in chars of packed array +int mii_type #I MII type of packed data + +int nbits + +begin + nbits = abs (mii_type) + return ((nchars * SZB_CHAR * NBITS_BYTE) / nbits) +end diff --git a/sys/osb/miipak.x b/sys/osb/miipak.x new file mode 100644 index 00000000..b86bc054 --- /dev/null +++ b/sys/osb/miipak.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mii.h> + +.help mii +.nf ___________________________________________________________________________ +MII -- Machine independent integer format conversion routines. The MII integer +format provides for three machine independent integer datatypes: + + MII_BYTE 8 bit unsigned byte + MII_SHORT 16 bit twos complement signed integer + MII_LONG 32 bit twos complement signed integer + +plus, more recently, two IEEE floating point formats: + + MII_REAL 32 bit IEEE floating point + MII_DOUBLE 64 bit IEEE floating point + +The MII datatypes are the same as are used in the FITS transportable image +format. In the case of the short and long integers, the most significant +bytes of an integer are given first. + +The routines in this package are provided for converting to and from the +MII format and the SPP format. The latter format, of course, is potentially +quite machine dependent. The implementation given here assumes that the +SPP datatypes include 16 bit and 32 bit twos complement integers; the ordering +of the bytes within these integer formats is described by the machine +constants BYTE_SWAP2 and BYTE_SWAP4. Byte swapping for the IEEE floating +formats is defined by the machine constants IEEE_SWAP4 and IEEE_SWAP8. +.endhelp ______________________________________________________________________ + + +# MIIPAK -- Pack a SPP array of type spp_type into a MII array of type +# mii_type. The mii_types are defined in mii.h. + +procedure miipak (spp, mii, nelems, spp_datatype, mii_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code +int mii_datatype #I MII datatype code + +begin + switch (mii_datatype) { + case MII_BYTE: + call miipak8 (spp, mii, nelems, spp_datatype) + case MII_SHORT: + call miipak16 (spp, mii, nelems, spp_datatype) + case MII_LONG: + call miipak32 (spp, mii, nelems, spp_datatype) + case MII_REAL: + call miipakr (spp, mii, nelems, spp_datatype) + case MII_DOUBLE: + call miipakd (spp, mii, nelems, spp_datatype) + } +end diff --git a/sys/osb/miipak16.x b/sys/osb/miipak16.x new file mode 100644 index 00000000..d972c0fa --- /dev/null +++ b/sys/osb/miipak16.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIPAK16 -- Pack an SPP array of the indicated datatype into an 16 bit +# signed MII array. + +procedure miipak16 (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbs (spp, mii, nelems) + case TY_USHORT: + call achtus (spp, mii, nelems) + case TY_CHAR: + call achtcs (spp, mii, nelems) + case TY_SHORT: + call achtss (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtis (spp, mii, nelems) + case TY_LONG: + call achtls (spp, mii, nelems) + case TY_REAL: + call achtrs (spp, mii, nelems) + case TY_DOUBLE: + call achtds (spp, mii, nelems) + case TY_COMPLEX: + call achtxs (spp, mii, nelems) + } + + if (BYTE_SWAP2 == YES) + call bswap2 (mii, 1, mii, 1, nelems * (16 / NBITS_BYTE)) +end diff --git a/sys/osb/miipak32.x b/sys/osb/miipak32.x new file mode 100644 index 00000000..1586f4ea --- /dev/null +++ b/sys/osb/miipak32.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIPAK32 -- Pack an SPP array of the indicated datatype into an 32 bit +# signed MII array. + +procedure miipak32 (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int mii_bytes +int spp_bytes +int sizeof() +pointer tmpp + +begin + call malloc (tmpp, nelems, TY_LONG) + + mii_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + switch (spp_datatype) { + case TY_UBYTE: + call achtbl (spp, Meml[tmpp], nelems) + case TY_USHORT: + call achtul (spp, Meml[tmpp], nelems) + case TY_CHAR: + call achtcl (spp, Meml[tmpp], nelems) + case TY_SHORT: + call achtsl (spp, Meml[tmpp], nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtil (spp, Meml[tmpp], nelems) + case TY_LONG: + call achtll (spp, Meml[tmpp], nelems) + case TY_REAL: + call achtrl (spp, Meml[tmpp], nelems) + case TY_DOUBLE: + call achtdl (spp, Meml[tmpp], nelems) + case TY_COMPLEX: + call achtxl (spp, Meml[tmpp], nelems) + } + + if ( mii_bytes == spp_bytes ) { + if (BYTE_SWAP4 == YES) + call bswap4 (Meml[tmpp], 1, mii, 1, nelems * (mii_bytes)) + else if (BYTE_SWAP2 == YES) + call bswap2 (Meml[tmpp], 1, mii, 1, nelems * (mii_bytes)) + } + else if ( 2 * mii_bytes == spp_bytes ) { + if (BYTE_SWAP8 == YES) + call bswap8 (Meml[tmpp], 1, Meml[tmpp], 1, nelems * (spp_bytes)) + else if (BYTE_SWAP4 == YES) + call bswap4 (Meml[tmpp], 1, Meml[tmpp], 1, nelems * (spp_bytes)) + else if (BYTE_SWAP2 == YES) + call bswap2 (Meml[tmpp], 1, Meml[tmpp], 1, nelems * (spp_bytes)) + call i64to32 ( Meml[tmpp], mii, nelems ) + } + else { + call eprintf("[ERROR] miipak32.x: unexpected integer size\n") + } + + call mfree (tmpp, TY_LONG) +end diff --git a/sys/osb/miipak8.x b/sys/osb/miipak8.x new file mode 100644 index 00000000..ea4e16ea --- /dev/null +++ b/sys/osb/miipak8.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MIIPAK8 -- Pack an SPP array of the indicated datatype into an 8 bit +# unsigned MII array. + +procedure miipak8 (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbb (spp, mii, nelems) + case TY_USHORT: + call achtub (spp, mii, nelems) + case TY_CHAR: + call achtcb (spp, mii, nelems) + case TY_SHORT: + call achtsb (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtib (spp, mii, nelems) + case TY_LONG: + call achtlb (spp, mii, nelems) + case TY_REAL: + call achtrb (spp, mii, nelems) + case TY_DOUBLE: + call achtdb (spp, mii, nelems) + case TY_COMPLEX: + call achtxb (spp, mii, nelems) + } +end diff --git a/sys/osb/miipakd.x b/sys/osb/miipakd.x new file mode 100644 index 00000000..b0766221 --- /dev/null +++ b/sys/osb/miipakd.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIPAKD -- Pack an SPP array of the indicated datatype into an 64 bit +# IEEE floating format. + +procedure miipakd (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +double mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_DOUBLE) + call ieevpakd (spp, mii, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbd (spp, mii, nelems) + case TY_USHORT: + call achtud (spp, mii, nelems) + case TY_CHAR: + call achtcd (spp, mii, nelems) + case TY_SHORT: + call achtsd (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtid (spp, mii, nelems) + case TY_LONG: + call achtld (spp, mii, nelems) + case TY_REAL: + call achtrd (spp, mii, nelems) + case TY_COMPLEX: + call achtxd (spp, mii, nelems) + default: + call amovd (spp, mii, nelems) + } + + call ieevpakd (mii, mii, nelems) + } +end diff --git a/sys/osb/miipakr.x b/sys/osb/miipakr.x new file mode 100644 index 00000000..e6d0a5be --- /dev/null +++ b/sys/osb/miipakr.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIPAKR -- Pack an SPP array of the indicated datatype into an 32 bit +# IEEE floating format. + +procedure miipakr (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +real mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_REAL) + call ieevpakr (spp, mii, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbr (spp, mii, nelems) + case TY_USHORT: + call achtur (spp, mii, nelems) + case TY_CHAR: + call achtcr (spp, mii, nelems) + case TY_SHORT: + call achtsr (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtir (spp, mii, nelems) + case TY_LONG: + call achtlr (spp, mii, nelems) + case TY_DOUBLE: + call achtdr (spp, mii, nelems) + case TY_COMPLEX: + call achtxr (spp, mii, nelems) + default: + call amovr (spp, mii, nelems) + } + + call ieevpakr (mii, mii, nelems) + } +end diff --git a/sys/osb/miipksize.x b/sys/osb/miipksize.x new file mode 100644 index 00000000..16791e95 --- /dev/null +++ b/sys/osb/miipksize.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIPKSIZE -- Determine the size in SPP chars of the array required to store +# nelems of type mii_type in MII packed form. The mii_type codes are defined +# in mii.h; we assume here that the integer codes are the sizes of the MII +# types in bits. + +int procedure miipksize (nelems, mii_type) + +int nelems #I number of MII elements of type mii_type +int mii_type #I <mii.h> type code (=8,16,32,-32,-64) + +begin + return ((nelems * abs(mii_type) / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR) +end diff --git a/sys/osb/miiupk.x b/sys/osb/miiupk.x new file mode 100644 index 00000000..bb536987 --- /dev/null +++ b/sys/osb/miiupk.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mii.h> + +# MIIUPK -- Unpack a MII array of type mii_type into a SPP array of type +# spp_type. The mii_types are defined in mii.h. + +procedure miiupk (mii, spp, nelems, mii_datatype, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int mii_datatype #I MII datatype code +int spp_datatype #I SPP datatype code + +begin + switch (mii_datatype) { + case MII_BYTE: + call miiupk8 (mii, spp, nelems, spp_datatype) + case MII_SHORT: + call miiupk16 (mii, spp, nelems, spp_datatype) + case MII_LONG: + call miiupk32 (mii, spp, nelems, spp_datatype) + case MII_REAL: + call miiupkr (mii, spp, nelems, spp_datatype) + case MII_DOUBLE: + call miiupkd (mii, spp, nelems, spp_datatype) + } +end diff --git a/sys/osb/miiupk16.x b/sys/osb/miiupk16.x new file mode 100644 index 00000000..2e24b3dd --- /dev/null +++ b/sys/osb/miiupk16.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIUPK16 -- Unpack a 16 bit signed MII array into an SPP array of the +# indicated datatype. + +procedure miiupk16 (mii, spp, nelems, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (BYTE_SWAP2 == YES) { + call bswap2 (mii, 1, spp, 1, nelems * (16 / NBITS_BYTE)) + call achts (spp, spp, nelems, spp_datatype) + } else + call achts (mii, spp, nelems, spp_datatype) +end diff --git a/sys/osb/miiupk32.x b/sys/osb/miiupk32.x new file mode 100644 index 00000000..183805f7 --- /dev/null +++ b/sys/osb/miiupk32.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIUPK32 -- Unpack a 32 bit signed MII array into an SPP array of the +# indicated datatype. + +procedure miiupk32 (mii, spp, nelems, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int mii_bytes +int spp_bytes +int sizeof() + +begin + mii_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + if ( mii_bytes == spp_bytes ) { + if (BYTE_SWAP4 == YES) { + call bswap4 (mii, 1, spp, 1, nelems * (mii_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else if (BYTE_SWAP2 == YES) { + call bswap2 (mii, 1, spp, 1, nelems * (mii_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else + call achtl (mii, spp, nelems, spp_datatype) + + } else if ( 2 * mii_bytes == spp_bytes ) { + call i32to64 (mii, spp, nelems) # for 64bit integer + if (BYTE_SWAP8 == YES) { + call bswap8 (spp, 1, spp, 1, nelems * (spp_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else if (BYTE_SWAP4 == YES) { + call bswap4 (spp, 1, spp, 1, nelems * (spp_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else if (BYTE_SWAP2 == YES) { + call bswap2 (spp, 1, spp, 1, nelems * (spp_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else + call achtl (spp, spp, nelems, spp_datatype) + + } else { + call eprintf("[ERROR] miiupk32.x: unexpected integer size\n") + } +end diff --git a/sys/osb/miiupk8.x b/sys/osb/miiupk8.x new file mode 100644 index 00000000..34a3a378 --- /dev/null +++ b/sys/osb/miiupk8.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MIIUPK8 -- Unpack an 8 bit unsigned MII array into an SPP array of the +# indicated datatype. + +procedure miiupk8 (mii, spp, nelems, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call achtb (mii, spp, nelems, spp_datatype) +end diff --git a/sys/osb/miiupkd.x b/sys/osb/miiupkd.x new file mode 100644 index 00000000..b509ef3a --- /dev/null +++ b/sys/osb/miiupkd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIUPKD -- Unpack a 64 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure miiupkd (mii, spp, nelems, spp_datatype) + +double mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkd (mii, spp, nelems) + if (spp_datatype != TY_DOUBLE) + call achtd (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/miiupkr.x b/sys/osb/miiupkr.x new file mode 100644 index 00000000..2ff27ff8 --- /dev/null +++ b/sys/osb/miiupkr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# MIIUPKR -- Unpack a 32 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure miiupkr (mii, spp, nelems, spp_datatype) + +real mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkr (mii, spp, nelems) + if (spp_datatype != TY_REAL) + call achtr (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/mkpkg b/sys/osb/mkpkg new file mode 100644 index 00000000..267b5ba6 --- /dev/null +++ b/sys/osb/mkpkg @@ -0,0 +1,167 @@ +# Make the OSB (bit and byte primitives) portion of the VOPS library. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +generic: + # Convert the generic files into typed files. + $set GFLAGS = "-k -t UBcsilrdx" + $ifolder (achtiu.c, achtzu.gc) + $generic $(GFLAGS) achtzu.gc -o acht\$$tu.c $endif + $ifolder (achtib.c, achtzb.gc) + $generic $(GFLAGS) achtzb.gc -o acht\$$tb.c $endif + $ifolder (achtui.c, achtu.gc) + $generic $(GFLAGS) achtu.gc $endif + $ifolder (achtbi.c, achtb.gc) + $generic $(GFLAGS) achtb.gc $endif + $ifolder (ieeer.x, ieee.gx) + $generic -k -t rd ieee.gx $endif + ; + +libvops.a: + # Generic preprocessing is normally done only on the development system, + # and need not be available on all systems. + + $ifeq (USE_GENERIC, yes) $call generic $endif + + # The following contain machine dependent constants. + hlib$i1mach.f + hlib$d1mach.f + hlib$r1mach.f + + # The following should normally be optimized in assembler (see the + # special file list in "hlib$mkpkg.sf"). + + $ifeq (USE_CCOMPILER, yes) + bytmov.c + $else + bytmov.f + $end + + bitfields.c + aclrb.c # see also vops/ak/aclr*.x + + # The operation of the following depends upon integer overflow, which + # may result in an exception on some hosts. + + urand.x <mach.h> + imul32.c # added to support 64-bit + iscl32.c # added to support 64-bit + iscl64.c # added to support 64-bit + iand32.c # added to support 64-bit + strsum.c # added for VO integration support + + # If a C compiler is not available for the following they will have + # to be written in assembler or some other low level language, and + # added to the special file list. + + achtbb.c + achtbc.c + achtbd.c + achtbi.c + achtbl.c + achtbr.c + achtbs.c + achtbu.c + achtbx.c + achtcb.c + achtcu.c + achtdb.c + achtdu.c + achtib.c + achtiu.c + achtlb.c + achtlu.c + achtrb.c + achtru.c + achtsb.c + achtsu.c + achtub.c + achtuc.c + achtud.c + achtui.c + achtul.c + achtur.c + achtus.c + achtuu.c + achtux.c + achtxb.c + achtxu.c + and.c + not.c + or.c + shift.c + abs.c + i32to64.c + i64to32.c + ipak32.c + iupk32.c + ipak16.c + iupk16.c + + + # Both C and Fortran versions of the following are provided. + # The C versions are normally preferred and are the most portable. + + $ifeq (USE_CCOMPILER, yes) + bswap2.c + bswap4.c + bswap8.c + chrpak.c + chrupk.c + strpak.c + strupk.c + $else + bswap2.f + bswap4.f + bswap8.f # not written; wait until we need it + chrpak.f + chrupk.f + strpak.f + strupk.f + $endif + + # The following are fairly portable, but potentially machine dependent. + + ieeer.x <mach.h> + ieeed.x <mach.h> + + miilen.x <mach.h> + miinelem.x <mach.h> + miipak.x <mii.h> + miipak16.x <mach.h> + miipak32.x <mach.h> + miipak8.x + miipakd.x <mach.h> + miipakr.x <mach.h> + miipksize.x <mach.h> + miiupk.x <mii.h> + miiupk16.x <mach.h> + miiupk32.x <mach.h> + miiupk8.x + miiupkd.x <mach.h> + miiupkr.x <mach.h> + + nmilen.x <mach.h> + nminelem.x <mach.h> + nmipak.x <nmi.h> + nmipak16.x <mach.h> + nmipak32.x <mach.h> + nmipak8.x + nmipakd.x <mach.h> + nmipakr.x <mach.h> + nmipksize.x <mach.h> + nmiupk.x <nmi.h> + nmiupk16.x <mach.h> + nmiupk32.x <mach.h> + nmiupk8.x + nmiupkd.x <mach.h> + nmiupkr.x <mach.h> + + f77pak.f + f77upk.f + bitmov.x <mach.h> + xor.x + ; diff --git a/sys/osb/nmilen.x b/sys/osb/nmilen.x new file mode 100644 index 00000000..32cc2055 --- /dev/null +++ b/sys/osb/nmilen.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMILEN -- Determine the number of SPP integers to store nelems of type +# nmi_type. The nmi_type are defined in nmi.h. +# +# THIS PROCEDURE HAS BEEN OBSOLETED BY NMIPAKLEN. + +int procedure nmilen (nelems, nmi_datatype) + +int nelems #I number of NMI data elements +int nmi_datatype #I datatype of NMI data + +begin + return (((nelems * abs(nmi_datatype) / NBITS_BYTE + SZB_CHAR - 1) / + SZB_CHAR + SZ_INT - 1) / SZ_INT) +end diff --git a/sys/osb/nminelem.x b/sys/osb/nminelem.x new file mode 100644 index 00000000..4a21c3e6 --- /dev/null +++ b/sys/osb/nminelem.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMINELEM -- Determine the number of NMI elements of the given datatype +# which can be stored in an SPP char array of the indicated length. +# The nmi_type codes are defined in nmi.h; we assume here that the codes +# used are the number of bits in each NMI type. + +int procedure nminelem (nchars, nmi_type) + +int nchars #I size in chars of packed array +int nmi_type #I NMI type of packed data + +int nbits + +begin + nbits = abs (nmi_type) + return ((nchars * SZB_CHAR * NBITS_BYTE) / nbits) +end diff --git a/sys/osb/nmipak.x b/sys/osb/nmipak.x new file mode 100644 index 00000000..3c6a5e15 --- /dev/null +++ b/sys/osb/nmipak.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <nmi.h> + +.help nmi +.nf ___________________________________________________________________________ +NMI -- Machine independent integer format conversion routines. The NMI integer +format provides for three machine independent integer datatypes: + + NMI_BYTE 8 bit unsigned byte + NMI_SHORT 16 bit twos complement signed integer + NMI_LONG 32 bit twos complement signed integer + +plus, more recently, two IEEE floating point formats: + + NMI_REAL 32 bit IEEE floating point + NMI_DOUBLE 64 bit IEEE floating point + +The NMI datatypes are the same as are used in the FITS transportable image +format. In the case of the short and long integers, the most significant +bytes of an integer are given first. + +The routines in this package are provided for converting to and from the +NMI format and the SPP format. The latter format, of course, is potentially +quite machine dependent. The implementation given here assumes that the +SPP datatypes include 16 bit and 32 bit twos complement integers; the ordering +of the bytes within these integer formats is described by the machine +constants BYTE_SWAP2 and BYTE_SWAP4. Byte swapping for the IEEE floating +formats is defined by the machine constants IEEE_SWAP4 and IEEE_SWAP8. +.endhelp ______________________________________________________________________ + + +# NMIPAK -- Pack a SPP array of type spp_type into a NMI array of type +# nmi_type. The nmi_types are defined in nmi.h. + +procedure nmipak (spp, nmi, nelems, spp_datatype, nmi_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code +int nmi_datatype #I NMI datatype code + +begin + switch (nmi_datatype) { + case NMI_BYTE: + call nmipak8 (spp, nmi, nelems, spp_datatype) + case NMI_SHORT: + call nmipak16 (spp, nmi, nelems, spp_datatype) + case NMI_LONG: + call nmipak32 (spp, nmi, nelems, spp_datatype) + case NMI_REAL: + call nmipakr (spp, nmi, nelems, spp_datatype) + case NMI_DOUBLE: + call nmipakd (spp, nmi, nelems, spp_datatype) + } +end diff --git a/sys/osb/nmipak16.x b/sys/osb/nmipak16.x new file mode 100644 index 00000000..eeae2a3d --- /dev/null +++ b/sys/osb/nmipak16.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIPAK16 -- Pack an SPP array of the indicated datatype into an 16 bit +# signed NMI array. + +procedure nmipak16 (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbs (spp, nmi, nelems) + case TY_USHORT: + call achtus (spp, nmi, nelems) + case TY_CHAR: + call achtcs (spp, nmi, nelems) + case TY_SHORT: + call achtss (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtis (spp, nmi, nelems) + case TY_LONG: + call achtls (spp, nmi, nelems) + case TY_REAL: + call achtrs (spp, nmi, nelems) + case TY_DOUBLE: + call achtds (spp, nmi, nelems) + case TY_COMPLEX: + call achtxs (spp, nmi, nelems) + } +end diff --git a/sys/osb/nmipak32.x b/sys/osb/nmipak32.x new file mode 100644 index 00000000..73abfd25 --- /dev/null +++ b/sys/osb/nmipak32.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIPAK32 -- Pack an SPP array of the indicated datatype into an 32 bit +# signed NMI array. + +procedure nmipak32 (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int nmi_bytes +int spp_bytes +int sizeof() +pointer tmpp + +begin + call malloc (tmpp, nelems, TY_INT) + + nmi_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + switch (spp_datatype) { + case TY_UBYTE: + call achtbi (spp, Memi[tmpp], nelems) + case TY_USHORT: + call achtui (spp, Memi[tmpp], nelems) + case TY_CHAR: + call achtci (spp, Memi[tmpp], nelems) + case TY_SHORT: + call achtsi (spp, Memi[tmpp], nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtii (spp, Memi[tmpp], nelems) + case TY_LONG: + call achtli (spp, Memi[tmpp], nelems) + case TY_REAL: + call achtri (spp, Memi[tmpp], nelems) + case TY_DOUBLE: + call achtdi (spp, Memi[tmpp], nelems) + case TY_COMPLEX: + call achtxi (spp, Memi[tmpp], nelems) + } + + if ( 2 * nmi_bytes == spp_bytes ) + call ipak32 (Memi[tmpp], nmi, nelems) + + call mfree (tmpp, TY_INT) +end diff --git a/sys/osb/nmipak8.x b/sys/osb/nmipak8.x new file mode 100644 index 00000000..6cf2720d --- /dev/null +++ b/sys/osb/nmipak8.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NMIPAK8 -- Pack an SPP array of the indicated datatype into an 8 bit +# unsigned NMI array. + +procedure nmipak8 (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbb (spp, nmi, nelems) + case TY_USHORT: + call achtub (spp, nmi, nelems) + case TY_CHAR: + call achtcb (spp, nmi, nelems) + case TY_SHORT: + call achtsb (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtib (spp, nmi, nelems) + case TY_LONG: + call achtlb (spp, nmi, nelems) + case TY_REAL: + call achtrb (spp, nmi, nelems) + case TY_DOUBLE: + call achtdb (spp, nmi, nelems) + case TY_COMPLEX: + call achtxb (spp, nmi, nelems) + } +end diff --git a/sys/osb/nmipakd.x b/sys/osb/nmipakd.x new file mode 100644 index 00000000..b1cb8ad3 --- /dev/null +++ b/sys/osb/nmipakd.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIPAKD -- Pack an SPP array of the indicated datatype into an 64 bit +# IEEE floating format. + +procedure nmipakd (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +double nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_DOUBLE) + call ieevpakd (spp, nmi, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbd (spp, nmi, nelems) + case TY_USHORT: + call achtud (spp, nmi, nelems) + case TY_CHAR: + call achtcd (spp, nmi, nelems) + case TY_SHORT: + call achtsd (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtid (spp, nmi, nelems) + case TY_LONG: + call achtld (spp, nmi, nelems) + case TY_REAL: + call achtrd (spp, nmi, nelems) + case TY_COMPLEX: + call achtxd (spp, nmi, nelems) + default: + call amovd (spp, nmi, nelems) + } + + call ieevpakd (nmi, nmi, nelems) + } +end diff --git a/sys/osb/nmipakr.x b/sys/osb/nmipakr.x new file mode 100644 index 00000000..ac710a2b --- /dev/null +++ b/sys/osb/nmipakr.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIPAKR -- Pack an SPP array of the indicated datatype into an 32 bit +# IEEE floating format. + +procedure nmipakr (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +real nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_REAL) + call ieevpakr (spp, nmi, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbr (spp, nmi, nelems) + case TY_USHORT: + call achtur (spp, nmi, nelems) + case TY_CHAR: + call achtcr (spp, nmi, nelems) + case TY_SHORT: + call achtsr (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtir (spp, nmi, nelems) + case TY_LONG: + call achtlr (spp, nmi, nelems) + case TY_DOUBLE: + call achtdr (spp, nmi, nelems) + case TY_COMPLEX: + call achtxr (spp, nmi, nelems) + default: + call amovr (spp, nmi, nelems) + } + + call ieevpakr (nmi, nmi, nelems) + } +end diff --git a/sys/osb/nmipksize.x b/sys/osb/nmipksize.x new file mode 100644 index 00000000..8ccd8297 --- /dev/null +++ b/sys/osb/nmipksize.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIPKSIZE -- Determine the size in SPP chars of the array required to store +# nelems of type nmi_type in NMI packed form. The nmi_type codes are defined +# in nmi.h; we assume here that the integer codes are the sizes of the NMI +# types in bits. + +int procedure nmipksize (nelems, nmi_type) + +int nelems #I number of NMI elements of type nmi_type +int nmi_type #I <nmi.h> type code (=8,16,32,-32,-64) + +begin + return ((nelems * abs(nmi_type) / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR) +end diff --git a/sys/osb/nmiupk.x b/sys/osb/nmiupk.x new file mode 100644 index 00000000..074f74bb --- /dev/null +++ b/sys/osb/nmiupk.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <nmi.h> + +# NMIUPK -- Unpack a NMI array of type nmi_type into a SPP array of type +# spp_type. The nmi_types are defined in nmi.h. + +procedure nmiupk (nmi, spp, nelems, nmi_datatype, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int nmi_datatype #I NMI datatype code +int spp_datatype #I SPP datatype code + +begin + switch (nmi_datatype) { + case NMI_BYTE: + call nmiupk8 (nmi, spp, nelems, spp_datatype) + case NMI_SHORT: + call nmiupk16 (nmi, spp, nelems, spp_datatype) + case NMI_LONG: + call nmiupk32 (nmi, spp, nelems, spp_datatype) + case NMI_REAL: + call nmiupkr (nmi, spp, nelems, spp_datatype) + case NMI_DOUBLE: + call nmiupkd (nmi, spp, nelems, spp_datatype) + } +end diff --git a/sys/osb/nmiupk16.x b/sys/osb/nmiupk16.x new file mode 100644 index 00000000..abe20bee --- /dev/null +++ b/sys/osb/nmiupk16.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIUPK16 -- Unpack a 16 bit signed NMI array into an SPP array of the +# indicated datatype. + +procedure nmiupk16 (nmi, spp, nelems, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call achts (nmi, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupk32.x b/sys/osb/nmiupk32.x new file mode 100644 index 00000000..f42907fa --- /dev/null +++ b/sys/osb/nmiupk32.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIUPK32 -- Unpack a 32 bit signed NMI array into an SPP array of the +# indicated datatype. + +procedure nmiupk32 (nmi, spp, nelems, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int nmi_bytes +int spp_bytes +int sizeof() + +begin + nmi_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + # for 64bit integer + if ( 2 * nmi_bytes == spp_bytes ) + call iupk32 (nmi, spp, nelems) + + call achti (nmi, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupk8.x b/sys/osb/nmiupk8.x new file mode 100644 index 00000000..4c7f0e8e --- /dev/null +++ b/sys/osb/nmiupk8.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NMIUPK8 -- Unpack an 8 bit unsigned NMI array into an SPP array of the +# indicated datatype. + +procedure nmiupk8 (nmi, spp, nelems, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call achtb (nmi, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupkd.x b/sys/osb/nmiupkd.x new file mode 100644 index 00000000..35d16631 --- /dev/null +++ b/sys/osb/nmiupkd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIUPKD -- Unpack a 64 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure nmiupkd (nmi, spp, nelems, spp_datatype) + +double nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkd (nmi, spp, nelems) + if (spp_datatype != TY_DOUBLE) + call achtd (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupkr.x b/sys/osb/nmiupkr.x new file mode 100644 index 00000000..474662f5 --- /dev/null +++ b/sys/osb/nmiupkr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# NMIUPKR -- Unpack a 32 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure nmiupkr (nmi, spp, nelems, spp_datatype) + +real nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkr (nmi, spp, nelems) + if (spp_datatype != TY_REAL) + call achtr (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/not.c b/sys/osb/not.c new file mode 100644 index 00000000..bbb2ed9e --- /dev/null +++ b/sys/osb/not.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* NOTI -- Bitwise boolean NOT of an integer variable. + */ +XINT +NOTI (XINT *a) +{ + return (~(*a)); +} + + +/* NOTS -- Bitwise boolean NOT of a short integer variable. + */ +XSHORT +NOTS (XSHORT *a) +{ + return (~(*a)); +} + + +/* NOTL -- Bitwise boolean NOT of a long integer variable. + */ +XLONG +NOTL (XLONG *a) +{ + return (~(*a)); +} diff --git a/sys/osb/or.c b/sys/osb/or.c new file mode 100644 index 00000000..88c8711c --- /dev/null +++ b/sys/osb/or.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* ORI -- Bitwise boolean OR of two integer variables. + */ +XINT +ORI (XINT *a, XINT *b) +{ + return (*a | *b); +} + + +/* ORS -- Bitwise boolean OR of two short integer variables. + */ +XSHORT +ORS (XSHORT *a, XSHORT *b) +{ + return (*a | *b); +} + + +/* ORL -- Bitwise boolean OR of two long integer variables. + */ +XLONG +ORL (XLONG *a, XLONG *b) +{ + return (*a | *b); +} diff --git a/sys/osb/r1mach.f b/sys/osb/r1mach.f new file mode 120000 index 00000000..c64a1953 --- /dev/null +++ b/sys/osb/r1mach.f @@ -0,0 +1 @@ +/iraf/iraf/unix/hlib/r1mach.f
\ No newline at end of file diff --git a/sys/osb/shift.c b/sys/osb/shift.c new file mode 100644 index 00000000..86eacfb3 --- /dev/null +++ b/sys/osb/shift.c @@ -0,0 +1,49 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* + * SHIFT.C -- Bitwise shift operators. A positive bitshift shifts to the left, + * zero-filling at the right, i.e., a left shift by 1 is equivalent to a + * multiplication by 2 (but does not cause integer overflow). A negative shift + * shifts to the right and is equivalent to a division. + */ + +/* SHIFTI -- Bitwise boolean SHIFT of two integer variables. + */ +XINT +SHIFTI ( + XINT *a_a, /* operand to be shifted */ + XINT *a_bits /* number of bits to shift */ +) +{ + register XINT a = *a_a, bits = *a_bits; + return (bits > 0 ? (a << bits) : (a >> -bits)); +} + +/* SHIFTS -- Bitwise boolean SHIFT of two short-integer variables. + */ +XSHORT +SHIFTS ( + XSHORT *a_a, /* operand to be shifted */ + XSHORT *a_bits /* number of bits to shift */ +) +{ + register XSHORT a = *a_a, bits = *a_bits; + return (bits > 0 ? (a << bits) : (a >> -bits)); +} + +/* SHIFTL -- Bitwise boolean SHIFT of two long-integer variables. + */ +XLONG +SHIFTL ( + XLONG *a_a, /* operand to be shifted */ + XLONG *a_bits /* number of bits to shift */ +) +{ + register XLONG a = *a_a, bits = *a_bits; + return (bits > 0 ? (a << bits) : (a >> -bits)); +} diff --git a/sys/osb/strpak.c b/sys/osb/strpak.c new file mode 100644 index 00000000..4f88123d --- /dev/null +++ b/sys/osb/strpak.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* STRPAK -- Pack an SPP character string into a C string, i.e., a sequence + * of characters stored one per byte, delimited by EOS='\0'. The operation + * may be performed in place. This version assumes that the host character + * set is ASCII and hence no lookup table reference to map character sets is + * needed. If this is not the case, code must be added to convert to the host + * character set. + * + * N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, + * and the operation is being performed in place, then this procedure should + * do nothing. + */ +STRPAK (instr, outstr, maxch) +XCHAR *instr; +PKCHAR *outstr; +XINT *maxch; +{ + register XCHAR *ip = instr; + register char *op = (char *)outstr; + register int n = *maxch; + + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; +} diff --git a/sys/osb/strpak.f b/sys/osb/strpak.f new file mode 100644 index 00000000..8c66f6f0 --- /dev/null +++ b/sys/osb/strpak.f @@ -0,0 +1,29 @@ +c STRPAK -- Pack an SPP character string into a C string, i.e., a sequence +c of characters stored one per byte, delimited by EOS='\0'. The operation +c may be performed in place. This version assumes that the host character +c set is ASCII and hence no lookup table reference to map character sets is +c needed. If this is not the case, code must be added to convert to the host +c character set. +c +c N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, +c and the operation is being performed in place, then this procedure should +c do nothing. +c +c N.B.: This code ASSUMES that XCHAR is implemented as INTEGER*2 and that +c both XEOS and EOS are 0. + + subroutine strpak (instr, outstr, maxch) + + integer*2 instr(*), ch, EOS + character*1 outstr(*) + integer maxch + parameter (EOS=0) + integer i + + do 10 i = 1, maxch + ch = instr(i) + outstr(i) = char (ch) + if (ch .eq. EOS) return + 10 continue + outstr(maxch+1) = char (EOS) + end diff --git a/sys/osb/strsum.c b/sys/osb/strsum.c new file mode 100644 index 00000000..71655b3f --- /dev/null +++ b/sys/osb/strsum.c @@ -0,0 +1,100 @@ +#define import_spp +#define import_knames +#include <iraf.h> + + +#ifdef INT32_SUM + +/** + * STRSUM -- Compute the 32-bit checksum of an SPP string. + */ + +int +STRSUM (XCHAR *array, XINT *length, XINT *maxch) +{ + int i, len, carry=0, newcarry=0; + unsigned int *iarray, sum = 0; + char pkstr[*maxch]; + + register int n = *maxch; + register XCHAR *ip = array; + register char *op = (char *) pkstr; + + + /* Convert the input string to a packed char array. + */ + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; + + /* Compute the checksum. + */ + iarray = (unsigned int *) pkstr; + len = *length / 4; + + for (i=0; i<len; i++) { + if (iarray[i] > ~ sum) + carry++; + + sum += iarray[i]; + } + + while (carry) { + if (carry > ~ sum) + newcarry++; + sum += carry; + carry = newcarry; + newcarry = 0; + } + + return (sum); +} + +#else + +/** + * STRSUM -- Compute the 32-bit checksum of an SPP string. + */ + +int +STRSUM (XCHAR *array, XINT *length, XINT *maxch) +{ + int i, len, carry=0, newcarry=0; + unsigned int *iarray, sum = 0; + unsigned long lsum = 0; + char pkstr[*maxch]; + + register int n = *maxch; + register XCHAR *ip = array; + register char *op = (char *) pkstr; + + + /* Convert the input string to a packed char array. + */ + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; + + /* Compute the checksum. + */ + iarray = (unsigned int *) pkstr; + len = *length / 4; + + for (i=0; i<len; i++) { + if (iarray[i] > ~ lsum) + carry++; + lsum += iarray[i]; + } + + while (carry) { + if (carry > ~ lsum) + newcarry++; + lsum += carry; + carry = newcarry; + newcarry = 0; + } + + return (abs(sum = lsum)); +} + +#endif diff --git a/sys/osb/strupk.c b/sys/osb/strupk.c new file mode 100644 index 00000000..97bd1bc1 --- /dev/null +++ b/sys/osb/strupk.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include <iraf.h> + +/* STRUPK -- Unpack a kernel (C style) string into an SPP string. The unpacking + * operation can be performed in place. A kernel string consists of a sequence + * of host characters stored one character per byte, delimited by EOS='\0'. + * We assume here that the host character set is ASCII. If this is not the + * case code must be added to convert from the host character set to ASCII in + * the unpacked string. + * + * N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, + * and the operation is being performed in place, then this procedure should + * do nothing. + */ +STRUPK (instr, outstr, maxch) +PKCHAR *instr; +XCHAR *outstr; +XINT *maxch; +{ + register char *ip = (char *)instr; + register XCHAR *op = outstr; + register int n; + + /* Is is necessary to determine the length of the string in order to + * be able to unpack the string in place, i.e., from right to left. + */ + for (n=0; *ip++; n++) + ; + n = (n < *maxch) ? n : *maxch; + op[n] = XEOS; + + for (ip = (char *)instr; --n >= 0; ) + op[n] = ip[n]; + op[*maxch] = XEOS; +} diff --git a/sys/osb/strupk.f b/sys/osb/strupk.f new file mode 100644 index 00000000..1123e2ac --- /dev/null +++ b/sys/osb/strupk.f @@ -0,0 +1,39 @@ +c STRUPK -- Unpack a kernel (C style) string into an SPP string. The unpacking +c operation can be performed in place. A kernel string consists of a sequence +c of host characters stored one character per byte, delimited by EOS='\0'. +c We assume here that the host character set is ASCII. If this is not the +c case code must be added to convert from the host character set to ASCII in +c the unpacked string. +c +c N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, +c and the operation is being performed in place, then this procedure should +c do nothing. +c +c N.B.: This code ASSUMES that XCHAR is implemented as INTEGER*2 and that +c both XEOS and EOS are 0. + + subroutine strupk (instr, outstr, maxch) + + character*1 instr(*) + integer*2 outstr(*) + integer maxch, EOS + parameter (EOS=0) + integer i + + +c Determine length of string so that we can unpack it in the reverse +c direction. + i = 1 + 10 continue + if (ichar (instr(i)) .eq. EOS .or. i .gt. maxch) goto 20 + i = i + 1 + goto 10 + 20 continue + +c Unpack the string from right to left. +c + outstr(i) = EOS + do 30 i=i, 1, -1 + outstr(i) = ichar (instr(i)) + 30 continue + end diff --git a/sys/osb/urand.x b/sys/osb/urand.x new file mode 100644 index 00000000..84e1fc67 --- /dev/null +++ b/sys/osb/urand.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# URAND -- Universal Random Number Generator. From "Computer Methods for +# Mathematical Computations", by Forsythe, Malcolm, and Moler, 1977. +# Urand is a uniform random number generator based on theory and suggestions +# given in D.E. Knuth (1969), Vol 2. Values of URAND will be returned in the +# interval (0,1). Random numbers are generated by the recursion relation +# (r' = r * a + c) where the art lies in choosing the values for A and C. +# +# [MACHDEP] - NOTE - This routine will not work on machines that do not permit +# integer overflow during multiplication. In such a case a machine dependent +# routine should be provided in host$as. + +real procedure urand (lseed) + +long lseed # seed value on first call +long n, a, c, m, mic + +real scale +data m /0/ + +int imul32() + +begin + # When first called, compute multiplier, increment, and miscellaneous + # constants. + + if (m == 0) { + m = MAX_LONG / 2 + 1 + a = 8 * int (m * atan (1.d0 / 8.d0)) + 5 + c = 2 * int (m * (0.5d0 - sqrt (3.d0) / 6.d0)) + 1 + mic = (m - c) + m + scale = 0.5 / m + lseed = max (1, lseed) + } + + # Compute next random number, taking care not to cause an arithmetic + # exception. + + n = imul32 (lseed, a) # [MACHDEP] - integer overflow + if (n > mic) + n = (n - m) - m + n = n + c + + if (n / 2 > m) + n = (n - m) - m + + if (n < 0) + n = (n + m) + m + + lseed = n + return (n * scale) +end diff --git a/sys/osb/xor.x b/sys/osb/xor.x new file mode 100644 index 00000000..3ba0dd85 --- /dev/null +++ b/sys/osb/xor.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XORI -- Boolean exclusive or of two integer operands. + +int procedure xori (a, b) + +int a, b +int not(), and(), or() + +begin + return (or (and(a,not(b)), and(not(a),b))) +end + + +# XORS -- Boolean exclusive or of two short integer operands. + +short procedure xors (a, b) + +short a, b +short nots(), ands(), ors() + +begin + return (ors (ands(a,nots(b)), ands(nots(a),b))) +end + + +# XORL -- Boolean exclusive or of two long integer operands. + +long procedure xorl (a, b) + +long a, b +long notl(), andl(), orl() + +begin + return (orl (andl(a,notl(b)), andl(notl(a),b))) +end diff --git a/sys/osb/zzdebug.x b/sys/osb/zzdebug.x new file mode 100644 index 00000000..f15f3fd4 --- /dev/null +++ b/sys/osb/zzdebug.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +task sbit, tbit + +define NWORDS 1 # limited to 1 longword at present + + +# SBIT, TBIT -- Test the bitpak and bitupk primitives. + +procedure sbit() + +int b[NWORDS] +int offset, nbits, value, i +int bitupk(), clgeti() + +begin + offset = clgeti ("offset") + nbits = clgeti ("nbits") + value = clgeti ("value") + + if (offset < 1 || offset > NWORDS * NBITS_INT) + call error (1, "bit offset out of range") + + call bitpak (value, b, offset, nbits) + + call printf ("\n") + call printf ("\t21098765432109876543210987654321\n") + call printf ("\t 3 2 1 0\n") + do i = 1, NWORDS { + call printf ("%4d\t%032r2 (%011oB)\n") + call pargi ((i-1) * 32 + 1) + call pargi (b[i]) + call pargi (b[i]) + } + return + +entry tbit() + offset = clgeti ("offset") + nbits = clgeti ("nbits") + + call printf ("bitfield=%d\n") + call pargi (bitupk (b, offset, nbits)) +end diff --git a/sys/osb/zzeps.f b/sys/osb/zzeps.f new file mode 100644 index 00000000..680af1b0 --- /dev/null +++ b/sys/osb/zzeps.f @@ -0,0 +1,114 @@ + +c------------------------------------------------------------------------- +c Compute machine epsilon, i.e, the smallest real or double precision +c number EPS such that (1.0 + EPS > 1.0). This calculation is tricky +c because of the optimizations performed by some compilers, and because +c a comparison performed in registers may be done to a higher precision +c than one involving variables. This program contains some minor +c violations of the F78 standard. +c------------------------------------------------------------------------- + + + program epsilo + + real seps + double precision deps + + write (*,*) 'Calculate Machine Epsilon ------' + call cseps (seps) + call cdeps (deps) + write (*,*) ' single precision epsilon: ', seps + write (*,*) ' double precision epsilon: ', deps + + write (*,*) ' ' + write (*,*) 'Verify Values -----' + + write (*, '('' enter s.p. epsilon: '',$)') + read (*,*) seps + if (1.0 + seps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + write (*, '('' enter d.p. epsilon: '',$)') + read (*,*) deps + if (1.0 + deps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + stop + end + + +c -- Compute the single precision epsilon. + + subroutine cseps (seps) + + real seps + real sval + double precision dval + logical sgt + common /eps/ sval, dval + save /eps/ + + sval = 1.0 + 10 seps = sval + sval = sval / 2.0 + if (sgt (1.0)) then + goto 10 + endif + end + + + +c -- Is SVAL + 1.0 greater than 1.0? + + logical function sgt (value) + + real value, sval, stemp + double precision dval + common /eps/ sval, dval + save /eps/ + + stemp = sval + 1.0 + sgt = (stemp .gt. value) + end + + + +c -- Compute the double precision epsilon. + + subroutine cdeps (deps) + + double precision deps + double precision dval + real sval + logical dgt + common /eps/ sval, dval + save /eps/ + + dval = 1.0d0 + 10 deps = dval + dval = dval / 2.0d0 + if (dgt (1.0d0)) then + goto 10 + endif + end + + +c -- Is DVAL + 1.0 greater than 1.0? + + logical function dgt (value) + + double precision value + double precision dval, dtemp + real sval + common /eps/ sval, dval + save /eps/ + + dtemp = dval + 1.0d0 + dgt = (dtemp .gt. value) + end diff --git a/sys/osb/zzeps2.f b/sys/osb/zzeps2.f new file mode 100644 index 00000000..d52ffe20 --- /dev/null +++ b/sys/osb/zzeps2.f @@ -0,0 +1,110 @@ +c------------------------------------------------------------------------- +c ZZEPS2.F -- Alternate version of ZZEPS. This version may avoid problems +c seen on some systems of excess precision causing an artificially large +c value of the single precision epsilon to be computed, due to the epsilon +c value being computed in registers. Use whichever version produces the +c smaller epsilon. +c +c Compute machine epsilon, i.e, the smallest real or double precision +c number EPS such that (1.0 + EPS > 1.0). This calculation is tricky +c because of the optimizations performed by some compilers, and because +c a comparison performed in registers may be done to a higher precision +c than one involving variables. This program contains some minor +c violations of the F78 standard. +c------------------------------------------------------------------------- + + + program epsilo + + real seps + double precision deps + + write (*,*) 'Calculate Machine Epsilon ------' + call cseps (seps) + call cdeps (deps) + write (*,*) ' single precision epsilon: ', seps + write (*,*) ' double precision epsilon: ', deps + + write (*,*) ' ' + write (*,*) 'Verify Values -----' + + write (*, '('' enter s.p. epsilon: '',$)') + read (*,*) seps + if (1.0 + seps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + write (*, '('' enter d.p. epsilon: '',$)') + read (*,*) deps + if (1.0 + deps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + stop + end + + +c -- Compute the single precision epsilon. + + subroutine cseps (seps) + + real seps + real sval + double precision dval + logical sgt + common /eps/ sval, dval + save /eps/ + + sval = 1.0 + 10 seps = sval + sval = sval / 2.0 + if (sgt (sval + 1.0, 1.0)) then + goto 10 + endif + end + + + +c -- Is SVAL + 1.0 greater than 1.0? + + logical function sgt (value, ref) + + real value, ref + + sgt = (value .gt. ref) + end + + + +c -- Compute the double precision epsilon. + + subroutine cdeps (deps) + + double precision deps + double precision dval + real sval + logical dgt + common /eps/ sval, dval + save /eps/ + + dval = 1.0d0 + 10 deps = dval + dval = dval / 2.0d0 + if (dgt (dval + 1.0d0, 1.0d0)) then + goto 10 + endif + end + + +c -- Is DVAL + 1.0 greater than 1.0? + + logical function dgt (value, ref) + + double precision value, ref + + dgt = (value .gt. ref) + end |