diff options
author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
---|---|---|
committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /sys/vops | |
download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz |
Initial commit
Diffstat (limited to 'sys/vops')
711 files changed, 19474 insertions, 0 deletions
diff --git a/sys/vops/README b/sys/vops/README new file mode 100644 index 00000000..1e4c2cd0 --- /dev/null +++ b/sys/vops/README @@ -0,0 +1,10 @@ +VOPS -- Vector OPerators + +This directory contains the (generic) source for the vector operators (VOPS). +These generic procedures are expanded into a set of type specific procedures +by the GENERIC preprocessor, before compilation by XC. Documentation for +the vector operators and for the GENERIC preprocessor is in Vops.hlp. + +The subdirectory "achtgen" contains code for generalized datatype conversion +of vectors. The highest level routine, "acht" implements a full 9 by 9 +type conversion matrix (BUcsilrdx) (the BU are in OSB). diff --git a/sys/vops/aabs.gx b/sys/vops/aabs.gx new file mode 100644 index 00000000..54cbe197 --- /dev/null +++ b/sys/vops/aabs.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabs$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/aadd.gx b/sys/vops/aadd.gx new file mode 100644 index 00000000..361afd6c --- /dev/null +++ b/sys/vops/aadd.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aadd$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/aaddk.gx b/sys/vops/aaddk.gx new file mode 100644 index 00000000..bd45782b --- /dev/null +++ b/sys/vops/aaddk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/aand.gx b/sys/vops/aand.gx new file mode 100644 index 00000000..e42d2d87 --- /dev/null +++ b/sys/vops/aand.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aand$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i +$if (datatype == i) +int and() +$else +PIXEL and$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = and (a[i], b[i]) + $else + c[i] = and$t (a[i], b[i]) + $endif + } +end diff --git a/sys/vops/aandk.gx b/sys/vops/aandk.gx new file mode 100644 index 00000000..bbb3b3b6 --- /dev/null +++ b/sys/vops/aandk.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == i) +int and() +$else +PIXEL and$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = and (a[i], b) + $else + c[i] = and$t (a[i], b) + $endif + } +end diff --git a/sys/vops/aavg.gx b/sys/vops/aavg.gx new file mode 100644 index 00000000..8f90126d --- /dev/null +++ b/sys/vops/aavg.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavg$t (a, npix, mean, sigma) + +PIXEL a[ARB] +int npix +$if (datatype == dl) +double mean, sigma, lcut, hcut +$else +real mean, sigma, lcut, hcut +$endif +int junk, awvg$t() +data lcut /0./, hcut /0./ + +begin + junk = awvg$t (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/abav.gx b/sys/vops/abav.gx new file mode 100644 index 00000000..0f519216 --- /dev/null +++ b/sys/vops/abav.gx @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abav$t (a, b, nblocks, npix_per_block) + +PIXEL a[ARB] # input vector +PIXEL b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +$if (datatype == cs) +long sum, width +$else $if (datatype == il) +real sum, width +$else +PIXEL sum, width +$endif $endif + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + $if (datatype != x) + width = block_length + $else + width = complex (block_length, block_length) + $endif + + if (block_length <= 1) + call amov$t (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/abeq.gx b/sys/vops/abeq.gx new file mode 100644 index 00000000..35324f6a --- /dev/null +++ b/sys/vops/abeq.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeq$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abeqk.gx b/sys/vops/abeqk.gx new file mode 100644 index 00000000..8f7a84aa --- /dev/null +++ b/sys/vops/abeqk.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + if (a[i] == 0$f) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abge.gx b/sys/vops/abge.gx new file mode 100644 index 00000000..76f842dc --- /dev/null +++ b/sys/vops/abge.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abge$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) >= abs (b[i])) + $else + if (a[i] >= b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abgek.gx b/sys/vops/abgek.gx new file mode 100644 index 00000000..a9ad9340 --- /dev/null +++ b/sys/vops/abgek.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgek$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + $if (datatype == x) + call amovki (1, c, npix) + $else + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + $endif + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) >= abs_b) + $else + if (a[i] >= b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abgt.gx b/sys/vops/abgt.gx new file mode 100644 index 00000000..80d7e81a --- /dev/null +++ b/sys/vops/abgt.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgt$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > abs (b[i])) + $else + if (a[i] > b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abgtk.gx b/sys/vops/abgtk.gx new file mode 100644 index 00000000..93be1524 --- /dev/null +++ b/sys/vops/abgtk.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > 0) + $else + if (a[i] > 0) + $endif + c[i] = 1 + else + c[i] = 0 + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > abs_b) + $else + if (a[i] > b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/able.gx b/sys/vops/able.gx new file mode 100644 index 00000000..27553959 --- /dev/null +++ b/sys/vops/able.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure able$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) <= abs (b[i])) + $else + if (a[i] <= b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ablek.gx b/sys/vops/ablek.gx new file mode 100644 index 00000000..16a10d27 --- /dev/null +++ b/sys/vops/ablek.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablek$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) == 0) + $else + if (a[i] <= 0) + $endif + c[i] = 1 + else + c[i] = 0 + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) <= abs_b) + $else + if (a[i] <= b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ablt.gx b/sys/vops/ablt.gx new file mode 100644 index 00000000..212c891e --- /dev/null +++ b/sys/vops/ablt.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure ablt$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) < abs (b[i])) + $else + if (a[i] < b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abltk.gx b/sys/vops/abltk.gx new file mode 100644 index 00000000..8d11cb09 --- /dev/null +++ b/sys/vops/abltk.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + $if (datatype == x) + call aclri (c, npix) + $else + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + $endif + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) < abs_b) + $else + if (a[i] < b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abne.gx b/sys/vops/abne.gx new file mode 100644 index 00000000..6cc4513e --- /dev/null +++ b/sys/vops/abne.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abne$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abnek.gx b/sys/vops/abnek.gx new file mode 100644 index 00000000..4643cd89 --- /dev/null +++ b/sys/vops/abnek.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnek$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + if (a[i] != 0$f) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abor.gx b/sys/vops/abor.gx new file mode 100644 index 00000000..6dcea5d9 --- /dev/null +++ b/sys/vops/abor.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure abor$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i +$if (datatype == i) +int or() +$else +PIXEL or$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = or (a[i], b[i]) + $else + c[i] = or$t (a[i], b[i]) + $endif + } +end diff --git a/sys/vops/abork.gx b/sys/vops/abork.gx new file mode 100644 index 00000000..0c1e5416 --- /dev/null +++ b/sys/vops/abork.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure abork$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == i) +int or() +$else +PIXEL or$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = or (a[i], b) + $else + c[i] = or$t (a[i], b) + $endif + } +end diff --git a/sys/vops/absu.gx b/sys/vops/absu.gx new file mode 100644 index 00000000..6601daae --- /dev/null +++ b/sys/vops/absu.gx @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absu$t (a, b, nblocks, npix_per_block) + +PIXEL a[ARB] # input vector +PIXEL b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +$if (datatype == cs) +long sum +$else $if (datatype == il) +real sum +$else +PIXEL sum +$endif $endif + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amov$t (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/acht.gx b/sys/vops/acht.gx new file mode 100644 index 00000000..e1ad83f4 --- /dev/null +++ b/sys/vops/acht.gx @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure acht$t$$t (a, b, npix) + +PIXEL a[ARB] +$PIXEL b[ARB] +int npix +$$if (datatype != $t) +int i +$$endif + +begin + $$if (datatype == $t) + call amov$t (a, b, npix) + $$else + $$if (sizeof(t) <= sizeof($t)) + do i = 1, npix + $$if (datatype == x) + b[i] = complex(real(a[i]),0.0) + $$else + b[i] = a[i] + $$endif + $$else + do i = npix, 1, -1 + $$if (datatype == x) + b[i] = complex(real(a[i]),0.0) + $$else + b[i] = a[i] + $$endif + $$endif + $$endif +end diff --git a/sys/vops/achtgen/acht.x b/sys/vops/achtgen/acht.x new file mode 100644 index 00000000..ae67ceae --- /dev/null +++ b/sys/vops/achtgen/acht.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT -- General data type conversion based on the generic routines +# The data types are BUcsilrdx. + +procedure acht (a, b, nelem, ty_a, ty_b) + +char a[ARB], b[ARB] +int ty_a, ty_b, nelem + +begin + switch (ty_a) { + case TY_UBYTE: + call achtb (a, b, nelem, ty_b) + case TY_USHORT: + call achtu (a, b, nelem, ty_b) + case TY_CHAR: + call achtc (a, b, nelem, ty_b) + case TY_SHORT: + call achts (a, b, nelem, ty_b) + case TY_INT, TY_POINTER, TY_STRUCT: + call achti (a, b, nelem, ty_b) + case TY_LONG: + call achtl (a, b, nelem, ty_b) + case TY_REAL: + call achtr (a, b, nelem, ty_b) + case TY_DOUBLE: + call achtd (a, b, nelem, ty_b) + case TY_COMPLEX: + call achtx (a, b, nelem, ty_b) + } +end diff --git a/sys/vops/achtgen/achtb.x b/sys/vops/achtgen/achtb.x new file mode 100644 index 00000000..0d8cb8a7 --- /dev/null +++ b/sys/vops/achtgen/achtb.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtb (a, b, nelem, ty_b) + +char a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtbb (a, b, nelem) + case TY_USHORT: + call achtbu (a, b, nelem) + case TY_CHAR: + call achtbc (a, b, nelem) + case TY_SHORT: + call achtbs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtbi (a, b, nelem) + case TY_LONG: + call achtbl (a, b, nelem) + case TY_REAL: + call achtbr (a, b, nelem) + case TY_DOUBLE: + call achtbd (a, b, nelem) + case TY_COMPLEX: + call achtbx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtc.x b/sys/vops/achtgen/achtc.x new file mode 100644 index 00000000..370a0174 --- /dev/null +++ b/sys/vops/achtgen/achtc.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtc (a, b, nelem, ty_b) + +char a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtcb (a, b, nelem) + case TY_USHORT: + call achtcu (a, b, nelem) + case TY_CHAR: + call achtcc (a, b, nelem) + case TY_SHORT: + call achtcs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtci (a, b, nelem) + case TY_LONG: + call achtcl (a, b, nelem) + case TY_REAL: + call achtcr (a, b, nelem) + case TY_DOUBLE: + call achtcd (a, b, nelem) + case TY_COMPLEX: + call achtcx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtd.x b/sys/vops/achtgen/achtd.x new file mode 100644 index 00000000..6f784749 --- /dev/null +++ b/sys/vops/achtgen/achtd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtd (a, b, nelem, ty_b) + +double a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtdb (a, b, nelem) + case TY_USHORT: + call achtdu (a, b, nelem) + case TY_CHAR: + call achtdc (a, b, nelem) + case TY_SHORT: + call achtds (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtdi (a, b, nelem) + case TY_LONG: + call achtdl (a, b, nelem) + case TY_REAL: + call achtdr (a, b, nelem) + case TY_DOUBLE: + call achtdd (a, b, nelem) + case TY_COMPLEX: + call achtdx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achti.x b/sys/vops/achtgen/achti.x new file mode 100644 index 00000000..49df790e --- /dev/null +++ b/sys/vops/achtgen/achti.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achti (a, b, nelem, ty_b) + +int a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtib (a, b, nelem) + case TY_USHORT: + call achtiu (a, b, nelem) + case TY_CHAR: + call achtic (a, b, nelem) + case TY_SHORT: + call achtis (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtii (a, b, nelem) + case TY_LONG: + call achtil (a, b, nelem) + case TY_REAL: + call achtir (a, b, nelem) + case TY_DOUBLE: + call achtid (a, b, nelem) + case TY_COMPLEX: + call achtix (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtl.x b/sys/vops/achtgen/achtl.x new file mode 100644 index 00000000..bf9cc0fa --- /dev/null +++ b/sys/vops/achtgen/achtl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtl (a, b, nelem, ty_b) + +long a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtlb (a, b, nelem) + case TY_USHORT: + call achtlu (a, b, nelem) + case TY_CHAR: + call achtlc (a, b, nelem) + case TY_SHORT: + call achtls (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtli (a, b, nelem) + case TY_LONG: + call achtll (a, b, nelem) + case TY_REAL: + call achtlr (a, b, nelem) + case TY_DOUBLE: + call achtld (a, b, nelem) + case TY_COMPLEX: + call achtlx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtr.x b/sys/vops/achtgen/achtr.x new file mode 100644 index 00000000..add1fdf4 --- /dev/null +++ b/sys/vops/achtgen/achtr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtr (a, b, nelem, ty_b) + +real a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtrb (a, b, nelem) + case TY_USHORT: + call achtru (a, b, nelem) + case TY_CHAR: + call achtrc (a, b, nelem) + case TY_SHORT: + call achtrs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtri (a, b, nelem) + case TY_LONG: + call achtrl (a, b, nelem) + case TY_REAL: + call achtrr (a, b, nelem) + case TY_DOUBLE: + call achtrd (a, b, nelem) + case TY_COMPLEX: + call achtrx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achts.x b/sys/vops/achtgen/achts.x new file mode 100644 index 00000000..c0aa0026 --- /dev/null +++ b/sys/vops/achtgen/achts.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achts (a, b, nelem, ty_b) + +short a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtsb (a, b, nelem) + case TY_USHORT: + call achtsu (a, b, nelem) + case TY_CHAR: + call achtsc (a, b, nelem) + case TY_SHORT: + call achtss (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtsi (a, b, nelem) + case TY_LONG: + call achtsl (a, b, nelem) + case TY_REAL: + call achtsr (a, b, nelem) + case TY_DOUBLE: + call achtsd (a, b, nelem) + case TY_COMPLEX: + call achtsx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtu.x b/sys/vops/achtgen/achtu.x new file mode 100644 index 00000000..5edffe96 --- /dev/null +++ b/sys/vops/achtgen/achtu.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtu (a, b, nelem, ty_b) + +short a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtub (a, b, nelem) + case TY_USHORT: + call achtuu (a, b, nelem) + case TY_CHAR: + call achtuc (a, b, nelem) + case TY_SHORT: + call achtus (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtui (a, b, nelem) + case TY_LONG: + call achtul (a, b, nelem) + case TY_REAL: + call achtur (a, b, nelem) + case TY_DOUBLE: + call achtud (a, b, nelem) + case TY_COMPLEX: + call achtux (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtx.x b/sys/vops/achtgen/achtx.x new file mode 100644 index 00000000..c0d8e04d --- /dev/null +++ b/sys/vops/achtgen/achtx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtx (a, b, nelem, ty_b) + +complex a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtxb (a, b, nelem) + case TY_USHORT: + call achtxu (a, b, nelem) + case TY_CHAR: + call achtxc (a, b, nelem) + case TY_SHORT: + call achtxs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtxi (a, b, nelem) + case TY_LONG: + call achtxl (a, b, nelem) + case TY_REAL: + call achtxr (a, b, nelem) + case TY_DOUBLE: + call achtxd (a, b, nelem) + case TY_COMPLEX: + call achtxx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/mkpkg b/sys/vops/achtgen/mkpkg new file mode 100644 index 00000000..48b7c157 --- /dev/null +++ b/sys/vops/achtgen/mkpkg @@ -0,0 +1,25 @@ +# The files in this directory are the higher level type conversion routines. +# The most general routine is ACHT, which can convert an array of any of the +# nine datatypes UBcsilrdx to any of the other types (it will cause 100 +# additional subroutines to be linked). One level down in the structure tree +# are the ACHTx routines, which will convert an array of type X to any other +# type. At the bottom are the ACHTxy routines, which convert from type X +# to type Y; these procedures are in vops$ak and osb$. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +libvops.a: + acht.x + achtb.x + achtc.x + achtd.x + achti.x + achtl.x + achtr.x + achts.x + achtu.x + achtx.x + ; diff --git a/sys/vops/acjgx.x b/sys/vops/acjgx.x new file mode 100644 index 00000000..1fc9f944 --- /dev/null +++ b/sys/vops/acjgx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACJGX -- Complex conjugate of a complex vector. + +procedure acjgx (a, b, npix) + +complex a[ARB], b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = conjg (a[i]) +end diff --git a/sys/vops/aclr.gx b/sys/vops/aclr.gx new file mode 100644 index 00000000..f3415353 --- /dev/null +++ b/sys/vops/aclr.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclr$t (a, npix) + +PIXEL a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0$f +end diff --git a/sys/vops/acnv.gx b/sys/vops/acnv.gx new file mode 100644 index 00000000..4d729126 --- /dev/null +++ b/sys/vops/acnv.gx @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnv$t (in, out, npix, kernel, knpix) + +PIXEL in[npix+knpix-1] # input vector, including boundary pixels +PIXEL out[ARB] # output vector +int npix # length of output vector +PIXEL kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +PIXEL sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/acnvr.gx b/sys/vops/acnvr.gx new file mode 100644 index 00000000..753b3de2 --- /dev/null +++ b/sys/vops/acnvr.gx @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvr$t (in, out, npix, kernel, knpix) + +PIXEL in[npix+knpix-1] # input vector, including boundary pixels +PIXEL out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/adiv.gx b/sys/vops/adiv.gx new file mode 100644 index 00000000..6b8b4cae --- /dev/null +++ b/sys/vops/adiv.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adiv$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/adivk.gx b/sys/vops/adivk.gx new file mode 100644 index 00000000..a16d0cac --- /dev/null +++ b/sys/vops/adivk.gx @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/adot.gx b/sys/vops/adot.gx new file mode 100644 index 00000000..baadd952 --- /dev/null +++ b/sys/vops/adot.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +$if (datatype == ld) +double procedure adot$t (a, b, npix) +$else +real procedure adot$t (a, b, npix) +$endif + +PIXEL a[ARB], b[ARB] + +$if (datatype == ld) +double sum +$else +real sum +$endif + +int npix, i + +begin + sum = 0$f + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/advz.gx b/sys/vops/advz.gx new file mode 100644 index 00000000..b4bffd80 --- /dev/null +++ b/sys/vops/advz.gx @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advz$t (a, b, c, npix, errfcn) + +PIXEL a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +PIXEL errfcn() # user function, called on divide by zero + +int i +PIXEL divisor +$if (datatype == rd) +PIXEL tol +$endif +extern errfcn() +errchk errfcn + +begin + $if (datatype == r) + tol = 1.0E-20 + $else $if (datatype == d) + tol = 1.0D-20 + $endif $endif + + do i = 1, npix { + divisor = b[i] + $if (datatype == rd) + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a[i]) + next + } + c[i] = a[i] / divisor + + $else + if (divisor == 0$f) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + $endif + } +end diff --git a/sys/vops/aexp.gx b/sys/vops/aexp.gx new file mode 100644 index 00000000..f631e7df --- /dev/null +++ b/sys/vops/aexp.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexp$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/aexpk.gx b/sys/vops/aexpk.gx new file mode 100644 index 00000000..9bd5a58c --- /dev/null +++ b/sys/vops/aexpk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/afftrr.x b/sys/vops/afftrr.x new file mode 100644 index 00000000..024f4456 --- /dev/null +++ b/sys/vops/afftrr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRR -- Forward fourier transform (real transform, real output arrays). +# The forward transform of the real array SR length NPIX is computed and +# returned in the real arrays FR and FI of length NPIX/2+1. Since the real +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure afftrr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # spatial data (input). SI NOT USED. +real fr[ARB], fi[ARB] # real and imag parts of transform (output) +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Copy the real data vector into the work array. + call amovr (sr, Memr[work], npix) + + # Compute the forward transform. + call ffa (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "afftrr: npix not a power of 2") + + # Unpack the real and imaginary parts into the output arrays. + call aupxr (Memr[work], fr, fi, npix / 2 + 1) + + call sfree (sp) +end diff --git a/sys/vops/afftrx.x b/sys/vops/afftrx.x new file mode 100644 index 00000000..ec43b16a --- /dev/null +++ b/sys/vops/afftrx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRX -- Forward fourier transform (real transform, complex output). +# The fourier transform of the real array A of length NPIX pixels is computed +# and the NPIX/2+1 complex transform coefficients are returned in the complex +# array B. The first element of array B upon output contains the dc term at +# zero frequency, and the remaining elements contain the real and imaginary +# components of the harmonics. The transformation may be performed in place +# if desired. NPIX must be a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFA expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure afftrx (a, b, npix) + +real a[ARB] # data (input) +complex b[ARB] # transform (output). Dim npix/2+1 +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovr (a, b, npix) + + # Compute the forward real transform. + call ffa (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/afftxr.x b/sys/vops/afftxr.x new file mode 100644 index 00000000..b09ae0f5 --- /dev/null +++ b/sys/vops/afftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXR -- Forward fourier transform (complex transform, real arrays). +# The fourier transform of the real arrays SR and SI containing complex data +# pairs is computed and the complex transform coefficients are returned in +# the real arrays FR and FI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure afftxr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # data, spatial domain (input) +real fr[ARB], fi[ARB] # transform, frequency domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (sr, fr, npix) + call amovr (si, fi, npix) + + # Compute the forward transform. + call fft842 (0, npix, fr, fi, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/afftxx.x b/sys/vops/afftxx.x new file mode 100644 index 00000000..34eedbf9 --- /dev/null +++ b/sys/vops/afftxx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXX -- Forward fourier transform (complex transform, complex data). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex transform coefficients are returned in the +# complex array B. The transformation may be performed in place if desired. +# NPIX must be a power of 2. + +procedure afftxx (a, b, npix) + +complex a[ARB] # data (input) +complex b[ARB] # transform (output) +int npix + +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the forward transform. + call fft842 (0, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/aglt.gx b/sys/vops/aglt.gx new file mode 100644 index 00000000..54f6ee2f --- /dev/null +++ b/sys/vops/aglt.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure aglt$t (a, b, npix, low, high, kmul, kadd, nrange) + +PIXEL a[ARB], b[ARB], pixval +int npix, i +PIXEL low[nrange], high[nrange] # range limits +$if (datatype == dl) +double kmul[nrange], kadd[nrange] # linear transformation +$else +real kmul[nrange], kadd[nrange] +$endif +$if (datatype == x) +real abs_pixval +$endif +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + $if (datatype == x) + abs_pixval = abs (pixval) + $endif + do nr = 1, nrange + $if (datatype == x) + if (abs_pixval >= abs (low[nr]) && + abs_pixval <= abs (high[nr])) { + $else + if (pixval >= low[nr] && pixval <= high[nr]) { + $endif + $if (datatype == dl) + if (kmul[nr] == 0.0D0) + $else + if (kmul[nr] == 0.0) + $endif + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ahgm.gx b/sys/vops/ahgm.gx new file mode 100644 index 00000000..02e21c07 --- /dev/null +++ b/sys/vops/ahgm.gx @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgm$t (data, npix, hgm, nbins, z1, z2) + +PIXEL data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +PIXEL z1, z2 # greyscale values of first and last bins + +PIXEL z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ahiv.gx b/sys/vops/ahiv.gx new file mode 100644 index 00000000..ba6d487a --- /dev/null +++ b/sys/vops/ahiv.gx @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +PIXEL procedure ahiv$t (a, npix) + +PIXEL a[ARB] +int npix +PIXEL high, pixval +$if (datatype == x) +real abs_high +$endif +int i + +begin + high = a[1] + $if (datatype == x) + abs_high = abs (high) + $endif + + do i = 1, npix { + pixval = a[i] + $if (datatype == x) + if (abs (pixval) > abs_high) { + high = pixval + abs_high = abs (high) + } + $else + if (pixval > high) + high = pixval + $endif + } + + return (high) +end diff --git a/sys/vops/aiftrr.x b/sys/vops/aiftrr.x new file mode 100644 index 00000000..96789581 --- /dev/null +++ b/sys/vops/aiftrr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRR -- Inverse fourier transform (real transform, real output arrays). +# The inverse transform of the real arrays FR and FI of length NPIX/2+1 is +# returned in the real array SR of length NPIX. Since the real inverse +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure aiftrr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # real and imag parts of transform (input) +real sr[ARB], si[ARB] # spatial data (output). SI NOT USED. +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Pack the real and imaginary parts into a complex array as required + # by FFS. + call apkxr (fr, fi, Memr[work], npix / 2 + 1) + + # Compute the inverse transform. + call ffs (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "aiftrr: npix not a power of 2") + + # The work array now contains the real part of the transform; merely + # copy it to the output array. + call amovr (Memr[work], sr, npix) + + call sfree (sp) +end diff --git a/sys/vops/aiftrx.x b/sys/vops/aiftrx.x new file mode 100644 index 00000000..63a9d53d --- /dev/null +++ b/sys/vops/aiftrx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRX -- Inverse discreet fourier transform (real transform, complex data +# array in). The input array A of length NPIX/2+1 contains the DC term and +# the NPIX/2 (real,imag) pairs for each of the NPIX/2 harmonics of the real +# transform. Upon output array B contains the NPIX real data pixels from the +# inverse transform. The transform may be performed in place if desired. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFS expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftrx (a, b, npix) + +complex a[ARB] # transform, npix/2+1 elements +real b[ARB] # output data array +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovx (a, b, npix / 2 + 1) + + # Compute the inverse real transform. + call ffs (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/aiftxr.x b/sys/vops/aiftxr.x new file mode 100644 index 00000000..a9647e7c --- /dev/null +++ b/sys/vops/aiftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXR -- Inverse fourier transform (complex transform, real arrays). +# The inverse transform of the real arrays FR and FI containing complex data +# pairs is computed and the complex spatial data coefficients are returned in +# the real arrays SR and SI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure aiftxr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # transform, frequency domain (input) +real sr[ARB], si[ARB] # data, spatial domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (fr, sr, npix) + call amovr (fi, si, npix) + + # Compute the inverse transform. + call fft842 (1, npix, sr, si, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/aiftxx.x b/sys/vops/aiftxx.x new file mode 100644 index 00000000..2871590f --- /dev/null +++ b/sys/vops/aiftxx.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXX -- Inverse fourier transform (complex transform, complex array). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex data points are returned in the complex array +# B. The transformation may be performed in place if desired. NPIX must be +# a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# A and B to be type COMPLEX arrays in the calling program, but FFT842 expects +# a REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftxx (a, b, npix) + +complex a[ARB] # transform (input) +complex b[ARB] # data (output) +int npix +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the inverse transform. + call fft842 (1, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/aimg.gx b/sys/vops/aimg.gx new file mode 100644 index 00000000..3ba682fe --- /dev/null +++ b/sys/vops/aimg.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimg$t (a, b, npix) + +complex a[ARB] +PIXEL b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aabsd.x b/sys/vops/ak/aabsd.x new file mode 100644 index 00000000..d9a85b4a --- /dev/null +++ b/sys/vops/ak/aabsd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsd (a, b, npix) + +double a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsi.x b/sys/vops/ak/aabsi.x new file mode 100644 index 00000000..b1c677aa --- /dev/null +++ b/sys/vops/ak/aabsi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsl.x b/sys/vops/ak/aabsl.x new file mode 100644 index 00000000..27543118 --- /dev/null +++ b/sys/vops/ak/aabsl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsr.x b/sys/vops/ak/aabsr.x new file mode 100644 index 00000000..824e77d5 --- /dev/null +++ b/sys/vops/ak/aabsr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsr (a, b, npix) + +real a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabss.x b/sys/vops/ak/aabss.x new file mode 100644 index 00000000..2084a7cc --- /dev/null +++ b/sys/vops/ak/aabss.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabss (a, b, npix) + +short a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsx.x b/sys/vops/ak/aabsx.x new file mode 100644 index 00000000..287e22cf --- /dev/null +++ b/sys/vops/ak/aabsx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsx (a, b, npix) + +complex a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aaddd.x b/sys/vops/ak/aaddd.x new file mode 100644 index 00000000..50716bbc --- /dev/null +++ b/sys/vops/ak/aaddd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddi.x b/sys/vops/ak/aaddi.x new file mode 100644 index 00000000..cfaf200c --- /dev/null +++ b/sys/vops/ak/aaddi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddkd.x b/sys/vops/ak/aaddkd.x new file mode 100644 index 00000000..e98dfb57 --- /dev/null +++ b/sys/vops/ak/aaddkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddki.x b/sys/vops/ak/aaddki.x new file mode 100644 index 00000000..f71b5654 --- /dev/null +++ b/sys/vops/ak/aaddki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddkl.x b/sys/vops/ak/aaddkl.x new file mode 100644 index 00000000..9d16f93d --- /dev/null +++ b/sys/vops/ak/aaddkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddkr.x b/sys/vops/ak/aaddkr.x new file mode 100644 index 00000000..07b92d8e --- /dev/null +++ b/sys/vops/ak/aaddkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddks.x b/sys/vops/ak/aaddks.x new file mode 100644 index 00000000..d8256585 --- /dev/null +++ b/sys/vops/ak/aaddks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddkx.x b/sys/vops/ak/aaddkx.x new file mode 100644 index 00000000..ea47e214 --- /dev/null +++ b/sys/vops/ak/aaddkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddl.x b/sys/vops/ak/aaddl.x new file mode 100644 index 00000000..3684265f --- /dev/null +++ b/sys/vops/ak/aaddl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddr.x b/sys/vops/ak/aaddr.x new file mode 100644 index 00000000..ba35b513 --- /dev/null +++ b/sys/vops/ak/aaddr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aadds.x b/sys/vops/ak/aadds.x new file mode 100644 index 00000000..bd53ed59 --- /dev/null +++ b/sys/vops/ak/aadds.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aadds (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddx.x b/sys/vops/ak/aaddx.x new file mode 100644 index 00000000..23239203 --- /dev/null +++ b/sys/vops/ak/aaddx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aandi.x b/sys/vops/ak/aandi.x new file mode 100644 index 00000000..86d6aadc --- /dev/null +++ b/sys/vops/ak/aandi.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aandi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i +int and() + +begin + do i = 1, npix { + c[i] = and (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aandki.x b/sys/vops/ak/aandki.x new file mode 100644 index 00000000..792b491e --- /dev/null +++ b/sys/vops/ak/aandki.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i +int and() + +begin + do i = 1, npix { + c[i] = and (a[i], b) + } +end diff --git a/sys/vops/ak/aandkl.x b/sys/vops/ak/aandkl.x new file mode 100644 index 00000000..c178aa21 --- /dev/null +++ b/sys/vops/ak/aandkl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i +long andl() + +begin + do i = 1, npix { + c[i] = andl (a[i], b) + } +end diff --git a/sys/vops/ak/aandks.x b/sys/vops/ak/aandks.x new file mode 100644 index 00000000..03a64dcb --- /dev/null +++ b/sys/vops/ak/aandks.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i +short ands() + +begin + do i = 1, npix { + c[i] = ands (a[i], b) + } +end diff --git a/sys/vops/ak/aandl.x b/sys/vops/ak/aandl.x new file mode 100644 index 00000000..95990efc --- /dev/null +++ b/sys/vops/ak/aandl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aandl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i +long andl() + +begin + do i = 1, npix { + c[i] = andl (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aands.x b/sys/vops/ak/aands.x new file mode 100644 index 00000000..fe174b83 --- /dev/null +++ b/sys/vops/ak/aands.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aands (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i +short ands() + +begin + do i = 1, npix { + c[i] = ands (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aavgd.x b/sys/vops/ak/aavgd.x new file mode 100644 index 00000000..04c68bf2 --- /dev/null +++ b/sys/vops/ak/aavgd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgd (a, npix, mean, sigma) + +double a[ARB] +int npix +double mean, sigma, lcut, hcut +int junk, awvgd() +data lcut /0./, hcut /0./ + +begin + junk = awvgd (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgi.x b/sys/vops/ak/aavgi.x new file mode 100644 index 00000000..45c8a64e --- /dev/null +++ b/sys/vops/ak/aavgi.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgi (a, npix, mean, sigma) + +int a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgi() +data lcut /0./, hcut /0./ + +begin + junk = awvgi (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgl.x b/sys/vops/ak/aavgl.x new file mode 100644 index 00000000..3c015246 --- /dev/null +++ b/sys/vops/ak/aavgl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgl (a, npix, mean, sigma) + +long a[ARB] +int npix +double mean, sigma, lcut, hcut +int junk, awvgl() +data lcut /0./, hcut /0./ + +begin + junk = awvgl (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgr.x b/sys/vops/ak/aavgr.x new file mode 100644 index 00000000..c4aaa051 --- /dev/null +++ b/sys/vops/ak/aavgr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgr (a, npix, mean, sigma) + +real a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgr() +data lcut /0./, hcut /0./ + +begin + junk = awvgr (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgs.x b/sys/vops/ak/aavgs.x new file mode 100644 index 00000000..2793e2e8 --- /dev/null +++ b/sys/vops/ak/aavgs.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgs (a, npix, mean, sigma) + +short a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgs() +data lcut /0./, hcut /0./ + +begin + junk = awvgs (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgx.x b/sys/vops/ak/aavgx.x new file mode 100644 index 00000000..07949efc --- /dev/null +++ b/sys/vops/ak/aavgx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgx (a, npix, mean, sigma) + +complex a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgx() +data lcut /0./, hcut /0./ + +begin + junk = awvgx (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/abavd.x b/sys/vops/ak/abavd.x new file mode 100644 index 00000000..0e76e230 --- /dev/null +++ b/sys/vops/ak/abavd.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavd (a, b, nblocks, npix_per_block) + +double a[ARB] # input vector +double b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +double sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovd (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavi.x b/sys/vops/ak/abavi.x new file mode 100644 index 00000000..9ca5b267 --- /dev/null +++ b/sys/vops/ak/abavi.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavi (a, b, nblocks, npix_per_block) + +int a[ARB] # input vector +int b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovi (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavl.x b/sys/vops/ak/abavl.x new file mode 100644 index 00000000..29332022 --- /dev/null +++ b/sys/vops/ak/abavl.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavl (a, b, nblocks, npix_per_block) + +long a[ARB] # input vector +long b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovl (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavr.x b/sys/vops/ak/abavr.x new file mode 100644 index 00000000..3e442d8e --- /dev/null +++ b/sys/vops/ak/abavr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavr (a, b, nblocks, npix_per_block) + +real a[ARB] # input vector +real b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovr (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavs.x b/sys/vops/ak/abavs.x new file mode 100644 index 00000000..f3e42dc4 --- /dev/null +++ b/sys/vops/ak/abavs.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavs (a, b, nblocks, npix_per_block) + +short a[ARB] # input vector +short b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +long sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovs (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavx.x b/sys/vops/ak/abavx.x new file mode 100644 index 00000000..7b33c2a3 --- /dev/null +++ b/sys/vops/ak/abavx.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavx (a, b, nblocks, npix_per_block) + +complex a[ARB] # input vector +complex b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +complex sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = complex (block_length, block_length) + + if (block_length <= 1) + call amovx (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abeqc.x b/sys/vops/ak/abeqc.x new file mode 100644 index 00000000..cbd97363 --- /dev/null +++ b/sys/vops/ak/abeqc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqc (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqd.x b/sys/vops/ak/abeqd.x new file mode 100644 index 00000000..d71d2ad8 --- /dev/null +++ b/sys/vops/ak/abeqd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqd (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqi.x b/sys/vops/ak/abeqi.x new file mode 100644 index 00000000..a70fad30 --- /dev/null +++ b/sys/vops/ak/abeqi.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqi (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqkc.x b/sys/vops/ak/abeqkc.x new file mode 100644 index 00000000..10757e50 --- /dev/null +++ b/sys/vops/ak/abeqkc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkd.x b/sys/vops/ak/abeqkd.x new file mode 100644 index 00000000..f4b0950a --- /dev/null +++ b/sys/vops/ak/abeqkd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] == 0.0D0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqki.x b/sys/vops/ak/abeqki.x new file mode 100644 index 00000000..c0a8d33c --- /dev/null +++ b/sys/vops/ak/abeqki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkl.x b/sys/vops/ak/abeqkl.x new file mode 100644 index 00000000..35491d1e --- /dev/null +++ b/sys/vops/ak/abeqkl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkr.x b/sys/vops/ak/abeqkr.x new file mode 100644 index 00000000..5f6625ab --- /dev/null +++ b/sys/vops/ak/abeqkr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] == 0.0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqks.x b/sys/vops/ak/abeqks.x new file mode 100644 index 00000000..f699cdf6 --- /dev/null +++ b/sys/vops/ak/abeqks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkx.x b/sys/vops/ak/abeqkx.x new file mode 100644 index 00000000..c2767408 --- /dev/null +++ b/sys/vops/ak/abeqkx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (a[i] == (0.0,0.0)) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeql.x b/sys/vops/ak/abeql.x new file mode 100644 index 00000000..36d1d195 --- /dev/null +++ b/sys/vops/ak/abeql.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeql (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqr.x b/sys/vops/ak/abeqr.x new file mode 100644 index 00000000..263246b8 --- /dev/null +++ b/sys/vops/ak/abeqr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqr (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqs.x b/sys/vops/ak/abeqs.x new file mode 100644 index 00000000..d133181b --- /dev/null +++ b/sys/vops/ak/abeqs.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqs (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqx.x b/sys/vops/ak/abeqx.x new file mode 100644 index 00000000..858142fb --- /dev/null +++ b/sys/vops/ak/abeqx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqx (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgec.x b/sys/vops/ak/abgec.x new file mode 100644 index 00000000..5f1f03af --- /dev/null +++ b/sys/vops/ak/abgec.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgec (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abged.x b/sys/vops/ak/abged.x new file mode 100644 index 00000000..36565fd6 --- /dev/null +++ b/sys/vops/ak/abged.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abged (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgei.x b/sys/vops/ak/abgei.x new file mode 100644 index 00000000..76b9aca1 --- /dev/null +++ b/sys/vops/ak/abgei.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgei (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgekc.x b/sys/vops/ak/abgekc.x new file mode 100644 index 00000000..dcb495e6 --- /dev/null +++ b/sys/vops/ak/abgekc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekd.x b/sys/vops/ak/abgekd.x new file mode 100644 index 00000000..4443230e --- /dev/null +++ b/sys/vops/ak/abgekd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgeki.x b/sys/vops/ak/abgeki.x new file mode 100644 index 00000000..d819f2e9 --- /dev/null +++ b/sys/vops/ak/abgeki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgeki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekl.x b/sys/vops/ak/abgekl.x new file mode 100644 index 00000000..f599ffff --- /dev/null +++ b/sys/vops/ak/abgekl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekr.x b/sys/vops/ak/abgekr.x new file mode 100644 index 00000000..35141e4c --- /dev/null +++ b/sys/vops/ak/abgekr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgeks.x b/sys/vops/ak/abgeks.x new file mode 100644 index 00000000..04486504 --- /dev/null +++ b/sys/vops/ak/abgeks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgeks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekx.x b/sys/vops/ak/abgekx.x new file mode 100644 index 00000000..f8f43b77 --- /dev/null +++ b/sys/vops/ak/abgekx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + call amovki (1, c, npix) + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) >= abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgel.x b/sys/vops/ak/abgel.x new file mode 100644 index 00000000..385082d7 --- /dev/null +++ b/sys/vops/ak/abgel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgel (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abger.x b/sys/vops/ak/abger.x new file mode 100644 index 00000000..f13f1065 --- /dev/null +++ b/sys/vops/ak/abger.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abger (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abges.x b/sys/vops/ak/abges.x new file mode 100644 index 00000000..c0bed06c --- /dev/null +++ b/sys/vops/ak/abges.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abges (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgex.x b/sys/vops/ak/abgex.x new file mode 100644 index 00000000..bf8affff --- /dev/null +++ b/sys/vops/ak/abgex.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgex (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) >= abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtc.x b/sys/vops/ak/abgtc.x new file mode 100644 index 00000000..85eb410e --- /dev/null +++ b/sys/vops/ak/abgtc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtc (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtd.x b/sys/vops/ak/abgtd.x new file mode 100644 index 00000000..7a5b668d --- /dev/null +++ b/sys/vops/ak/abgtd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtd (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgti.x b/sys/vops/ak/abgti.x new file mode 100644 index 00000000..356e66e9 --- /dev/null +++ b/sys/vops/ak/abgti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgti (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtkc.x b/sys/vops/ak/abgtkc.x new file mode 100644 index 00000000..425db27b --- /dev/null +++ b/sys/vops/ak/abgtkc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkd.x b/sys/vops/ak/abgtkd.x new file mode 100644 index 00000000..239caf24 --- /dev/null +++ b/sys/vops/ak/abgtkd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtki.x b/sys/vops/ak/abgtki.x new file mode 100644 index 00000000..17d67d74 --- /dev/null +++ b/sys/vops/ak/abgtki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkl.x b/sys/vops/ak/abgtkl.x new file mode 100644 index 00000000..1ee43a43 --- /dev/null +++ b/sys/vops/ak/abgtkl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkr.x b/sys/vops/ak/abgtkr.x new file mode 100644 index 00000000..11673299 --- /dev/null +++ b/sys/vops/ak/abgtkr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtks.x b/sys/vops/ak/abgtks.x new file mode 100644 index 00000000..2c27023a --- /dev/null +++ b/sys/vops/ak/abgtks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkx.x b/sys/vops/ak/abgtkx.x new file mode 100644 index 00000000..f7b2a992 --- /dev/null +++ b/sys/vops/ak/abgtkx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (abs (a[i]) > 0) + c[i] = 1 + else + c[i] = 0 + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) > abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtl.x b/sys/vops/ak/abgtl.x new file mode 100644 index 00000000..3b5304b9 --- /dev/null +++ b/sys/vops/ak/abgtl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtr.x b/sys/vops/ak/abgtr.x new file mode 100644 index 00000000..4d900166 --- /dev/null +++ b/sys/vops/ak/abgtr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtr (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgts.x b/sys/vops/ak/abgts.x new file mode 100644 index 00000000..8bb92613 --- /dev/null +++ b/sys/vops/ak/abgts.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgts (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtx.x b/sys/vops/ak/abgtx.x new file mode 100644 index 00000000..c82aef59 --- /dev/null +++ b/sys/vops/ak/abgtx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtx (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) > abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablec.x b/sys/vops/ak/ablec.x new file mode 100644 index 00000000..76806def --- /dev/null +++ b/sys/vops/ak/ablec.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablec (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abled.x b/sys/vops/ak/abled.x new file mode 100644 index 00000000..e1288c98 --- /dev/null +++ b/sys/vops/ak/abled.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure abled (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablei.x b/sys/vops/ak/ablei.x new file mode 100644 index 00000000..d69d184f --- /dev/null +++ b/sys/vops/ak/ablei.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablei (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablekc.x b/sys/vops/ak/ablekc.x new file mode 100644 index 00000000..5a9f776f --- /dev/null +++ b/sys/vops/ak/ablekc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekd.x b/sys/vops/ak/ablekd.x new file mode 100644 index 00000000..f18548da --- /dev/null +++ b/sys/vops/ak/ablekd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ableki.x b/sys/vops/ak/ableki.x new file mode 100644 index 00000000..4ee983f7 --- /dev/null +++ b/sys/vops/ak/ableki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ableki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekl.x b/sys/vops/ak/ablekl.x new file mode 100644 index 00000000..5e480c5b --- /dev/null +++ b/sys/vops/ak/ablekl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekr.x b/sys/vops/ak/ablekr.x new file mode 100644 index 00000000..3e61beae --- /dev/null +++ b/sys/vops/ak/ablekr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ableks.x b/sys/vops/ak/ableks.x new file mode 100644 index 00000000..b8e855da --- /dev/null +++ b/sys/vops/ak/ableks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ableks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekx.x b/sys/vops/ak/ablekx.x new file mode 100644 index 00000000..f29abb93 --- /dev/null +++ b/sys/vops/ak/ablekx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (abs (a[i]) == 0) + c[i] = 1 + else + c[i] = 0 + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) <= abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablel.x b/sys/vops/ak/ablel.x new file mode 100644 index 00000000..b218784b --- /dev/null +++ b/sys/vops/ak/ablel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablel (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abler.x b/sys/vops/ak/abler.x new file mode 100644 index 00000000..88121ab3 --- /dev/null +++ b/sys/vops/ak/abler.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure abler (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ables.x b/sys/vops/ak/ables.x new file mode 100644 index 00000000..3165c0eb --- /dev/null +++ b/sys/vops/ak/ables.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ables (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablex.x b/sys/vops/ak/ablex.x new file mode 100644 index 00000000..98b68857 --- /dev/null +++ b/sys/vops/ak/ablex.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablex (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) <= abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltc.x b/sys/vops/ak/abltc.x new file mode 100644 index 00000000..46c4c86c --- /dev/null +++ b/sys/vops/ak/abltc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltc (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltd.x b/sys/vops/ak/abltd.x new file mode 100644 index 00000000..9b392c1f --- /dev/null +++ b/sys/vops/ak/abltd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltd (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablti.x b/sys/vops/ak/ablti.x new file mode 100644 index 00000000..b567b589 --- /dev/null +++ b/sys/vops/ak/ablti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure ablti (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltkc.x b/sys/vops/ak/abltkc.x new file mode 100644 index 00000000..6917a40b --- /dev/null +++ b/sys/vops/ak/abltkc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkd.x b/sys/vops/ak/abltkd.x new file mode 100644 index 00000000..354c9bfb --- /dev/null +++ b/sys/vops/ak/abltkd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltki.x b/sys/vops/ak/abltki.x new file mode 100644 index 00000000..f20f6455 --- /dev/null +++ b/sys/vops/ak/abltki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkl.x b/sys/vops/ak/abltkl.x new file mode 100644 index 00000000..dc02c284 --- /dev/null +++ b/sys/vops/ak/abltkl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkr.x b/sys/vops/ak/abltkr.x new file mode 100644 index 00000000..02531a40 --- /dev/null +++ b/sys/vops/ak/abltkr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltks.x b/sys/vops/ak/abltks.x new file mode 100644 index 00000000..3cdb07c5 --- /dev/null +++ b/sys/vops/ak/abltks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkx.x b/sys/vops/ak/abltkx.x new file mode 100644 index 00000000..04527b7f --- /dev/null +++ b/sys/vops/ak/abltkx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + call aclri (c, npix) + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) < abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltl.x b/sys/vops/ak/abltl.x new file mode 100644 index 00000000..526a8ba3 --- /dev/null +++ b/sys/vops/ak/abltl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltr.x b/sys/vops/ak/abltr.x new file mode 100644 index 00000000..bdaf39eb --- /dev/null +++ b/sys/vops/ak/abltr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltr (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablts.x b/sys/vops/ak/ablts.x new file mode 100644 index 00000000..a0a9bded --- /dev/null +++ b/sys/vops/ak/ablts.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure ablts (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltx.x b/sys/vops/ak/abltx.x new file mode 100644 index 00000000..354238b3 --- /dev/null +++ b/sys/vops/ak/abltx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltx (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) < abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnec.x b/sys/vops/ak/abnec.x new file mode 100644 index 00000000..7634ce5d --- /dev/null +++ b/sys/vops/ak/abnec.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnec (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abned.x b/sys/vops/ak/abned.x new file mode 100644 index 00000000..74da7d12 --- /dev/null +++ b/sys/vops/ak/abned.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abned (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnei.x b/sys/vops/ak/abnei.x new file mode 100644 index 00000000..57ce41c1 --- /dev/null +++ b/sys/vops/ak/abnei.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnei (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnekc.x b/sys/vops/ak/abnekc.x new file mode 100644 index 00000000..082d2ac9 --- /dev/null +++ b/sys/vops/ak/abnekc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekd.x b/sys/vops/ak/abnekd.x new file mode 100644 index 00000000..7f95e855 --- /dev/null +++ b/sys/vops/ak/abnekd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] != 0.0D0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abneki.x b/sys/vops/ak/abneki.x new file mode 100644 index 00000000..c8e497c8 --- /dev/null +++ b/sys/vops/ak/abneki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abneki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekl.x b/sys/vops/ak/abnekl.x new file mode 100644 index 00000000..4e8537c2 --- /dev/null +++ b/sys/vops/ak/abnekl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekr.x b/sys/vops/ak/abnekr.x new file mode 100644 index 00000000..effd0fc7 --- /dev/null +++ b/sys/vops/ak/abnekr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] != 0.0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abneks.x b/sys/vops/ak/abneks.x new file mode 100644 index 00000000..e587ed1f --- /dev/null +++ b/sys/vops/ak/abneks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abneks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekx.x b/sys/vops/ak/abnekx.x new file mode 100644 index 00000000..8ddaca07 --- /dev/null +++ b/sys/vops/ak/abnekx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (a[i] != (0.0,0.0)) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnel.x b/sys/vops/ak/abnel.x new file mode 100644 index 00000000..3f57b4cb --- /dev/null +++ b/sys/vops/ak/abnel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnel (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abner.x b/sys/vops/ak/abner.x new file mode 100644 index 00000000..a5409272 --- /dev/null +++ b/sys/vops/ak/abner.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abner (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnes.x b/sys/vops/ak/abnes.x new file mode 100644 index 00000000..75c23939 --- /dev/null +++ b/sys/vops/ak/abnes.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnes (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnex.x b/sys/vops/ak/abnex.x new file mode 100644 index 00000000..bc914339 --- /dev/null +++ b/sys/vops/ak/abnex.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnex (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abori.x b/sys/vops/ak/abori.x new file mode 100644 index 00000000..e0ecf2fc --- /dev/null +++ b/sys/vops/ak/abori.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure abori (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i +int or() + +begin + do i = 1, npix { + c[i] = or (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aborki.x b/sys/vops/ak/aborki.x new file mode 100644 index 00000000..760debcc --- /dev/null +++ b/sys/vops/ak/aborki.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure aborki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i +int or() + +begin + do i = 1, npix { + c[i] = or (a[i], b) + } +end diff --git a/sys/vops/ak/aborkl.x b/sys/vops/ak/aborkl.x new file mode 100644 index 00000000..262c113e --- /dev/null +++ b/sys/vops/ak/aborkl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure aborkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i +long orl() + +begin + do i = 1, npix { + c[i] = orl (a[i], b) + } +end diff --git a/sys/vops/ak/aborks.x b/sys/vops/ak/aborks.x new file mode 100644 index 00000000..a8de717a --- /dev/null +++ b/sys/vops/ak/aborks.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure aborks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i +short ors() + +begin + do i = 1, npix { + c[i] = ors (a[i], b) + } +end diff --git a/sys/vops/ak/aborl.x b/sys/vops/ak/aborl.x new file mode 100644 index 00000000..995b3c3b --- /dev/null +++ b/sys/vops/ak/aborl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure aborl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i +long orl() + +begin + do i = 1, npix { + c[i] = orl (a[i], b[i]) + } +end diff --git a/sys/vops/ak/abors.x b/sys/vops/ak/abors.x new file mode 100644 index 00000000..6ae42d4f --- /dev/null +++ b/sys/vops/ak/abors.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure abors (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i +short ors() + +begin + do i = 1, npix { + c[i] = ors (a[i], b[i]) + } +end diff --git a/sys/vops/ak/absud.x b/sys/vops/ak/absud.x new file mode 100644 index 00000000..06a7ae90 --- /dev/null +++ b/sys/vops/ak/absud.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absud (a, b, nblocks, npix_per_block) + +double a[ARB] # input vector +double b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +double sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovd (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absui.x b/sys/vops/ak/absui.x new file mode 100644 index 00000000..ae785103 --- /dev/null +++ b/sys/vops/ak/absui.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absui (a, b, nblocks, npix_per_block) + +int a[ARB] # input vector +int b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovi (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absul.x b/sys/vops/ak/absul.x new file mode 100644 index 00000000..ff803cc6 --- /dev/null +++ b/sys/vops/ak/absul.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absul (a, b, nblocks, npix_per_block) + +long a[ARB] # input vector +long b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovl (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absur.x b/sys/vops/ak/absur.x new file mode 100644 index 00000000..8aaca446 --- /dev/null +++ b/sys/vops/ak/absur.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absur (a, b, nblocks, npix_per_block) + +real a[ARB] # input vector +real b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovr (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absus.x b/sys/vops/ak/absus.x new file mode 100644 index 00000000..9161ed24 --- /dev/null +++ b/sys/vops/ak/absus.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absus (a, b, nblocks, npix_per_block) + +short a[ARB] # input vector +short b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +long sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovs (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/achtcc.x b/sys/vops/ak/achtcc.x new file mode 100644 index 00000000..b531ea80 --- /dev/null +++ b/sys/vops/ak/achtcc.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcc (a, b, npix) + +char a[ARB] +char b[ARB] +int npix + +begin + call amovc (a, b, npix) +end diff --git a/sys/vops/ak/achtcd.x b/sys/vops/ak/achtcd.x new file mode 100644 index 00000000..6b0ea760 --- /dev/null +++ b/sys/vops/ak/achtcd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcd (a, b, npix) + +char a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtci.x b/sys/vops/ak/achtci.x new file mode 100644 index 00000000..3aef94ee --- /dev/null +++ b/sys/vops/ak/achtci.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtci (a, b, npix) + +char a[ARB] +int b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcl.x b/sys/vops/ak/achtcl.x new file mode 100644 index 00000000..8b01968d --- /dev/null +++ b/sys/vops/ak/achtcl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcl (a, b, npix) + +char a[ARB] +long b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcr.x b/sys/vops/ak/achtcr.x new file mode 100644 index 00000000..d95534a8 --- /dev/null +++ b/sys/vops/ak/achtcr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcr (a, b, npix) + +char a[ARB] +real b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcs.x b/sys/vops/ak/achtcs.x new file mode 100644 index 00000000..35e5266d --- /dev/null +++ b/sys/vops/ak/achtcs.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcs (a, b, npix) + +char a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcx.x b/sys/vops/ak/achtcx.x new file mode 100644 index 00000000..1c8e1dc6 --- /dev/null +++ b/sys/vops/ak/achtcx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcx (a, b, npix) + +char a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtdc.x b/sys/vops/ak/achtdc.x new file mode 100644 index 00000000..309ce09b --- /dev/null +++ b/sys/vops/ak/achtdc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdc (a, b, npix) + +double a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdd.x b/sys/vops/ak/achtdd.x new file mode 100644 index 00000000..76520e5a --- /dev/null +++ b/sys/vops/ak/achtdd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdd (a, b, npix) + +double a[ARB] +double b[ARB] +int npix + +begin + call amovd (a, b, npix) +end diff --git a/sys/vops/ak/achtdi.x b/sys/vops/ak/achtdi.x new file mode 100644 index 00000000..7647c94f --- /dev/null +++ b/sys/vops/ak/achtdi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdi (a, b, npix) + +double a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdl.x b/sys/vops/ak/achtdl.x new file mode 100644 index 00000000..303d6e7c --- /dev/null +++ b/sys/vops/ak/achtdl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdl (a, b, npix) + +double a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdr.x b/sys/vops/ak/achtdr.x new file mode 100644 index 00000000..f047d66b --- /dev/null +++ b/sys/vops/ak/achtdr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdr (a, b, npix) + +double a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtds.x b/sys/vops/ak/achtds.x new file mode 100644 index 00000000..08585d68 --- /dev/null +++ b/sys/vops/ak/achtds.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtds (a, b, npix) + +double a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdx.x b/sys/vops/ak/achtdx.x new file mode 100644 index 00000000..0e253f4f --- /dev/null +++ b/sys/vops/ak/achtdx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdx (a, b, npix) + +double a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtic.x b/sys/vops/ak/achtic.x new file mode 100644 index 00000000..17812f52 --- /dev/null +++ b/sys/vops/ak/achtic.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtic (a, b, npix) + +int a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtid.x b/sys/vops/ak/achtid.x new file mode 100644 index 00000000..d030ef99 --- /dev/null +++ b/sys/vops/ak/achtid.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtid (a, b, npix) + +int a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtii.x b/sys/vops/ak/achtii.x new file mode 100644 index 00000000..2bda8301 --- /dev/null +++ b/sys/vops/ak/achtii.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtii (a, b, npix) + +int a[ARB] +int b[ARB] +int npix + +begin + call amovi (a, b, npix) +end diff --git a/sys/vops/ak/achtil.x b/sys/vops/ak/achtil.x new file mode 100644 index 00000000..5397d121 --- /dev/null +++ b/sys/vops/ak/achtil.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtil (a, b, npix) + +int a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtir.x b/sys/vops/ak/achtir.x new file mode 100644 index 00000000..4e17ce9a --- /dev/null +++ b/sys/vops/ak/achtir.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtir (a, b, npix) + +int a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtis.x b/sys/vops/ak/achtis.x new file mode 100644 index 00000000..3f6df01c --- /dev/null +++ b/sys/vops/ak/achtis.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtis (a, b, npix) + +int a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtix.x b/sys/vops/ak/achtix.x new file mode 100644 index 00000000..7413c08a --- /dev/null +++ b/sys/vops/ak/achtix.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtix (a, b, npix) + +int a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtlc.x b/sys/vops/ak/achtlc.x new file mode 100644 index 00000000..67aded51 --- /dev/null +++ b/sys/vops/ak/achtlc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtlc (a, b, npix) + +long a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtld.x b/sys/vops/ak/achtld.x new file mode 100644 index 00000000..a67a5a42 --- /dev/null +++ b/sys/vops/ak/achtld.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtld (a, b, npix) + +long a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtli.x b/sys/vops/ak/achtli.x new file mode 100644 index 00000000..0c06f8ba --- /dev/null +++ b/sys/vops/ak/achtli.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtli (a, b, npix) + +long a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtll.x b/sys/vops/ak/achtll.x new file mode 100644 index 00000000..ca9a5d05 --- /dev/null +++ b/sys/vops/ak/achtll.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtll (a, b, npix) + +long a[ARB] +long b[ARB] +int npix + +begin + call amovl (a, b, npix) +end diff --git a/sys/vops/ak/achtlr.x b/sys/vops/ak/achtlr.x new file mode 100644 index 00000000..a842c431 --- /dev/null +++ b/sys/vops/ak/achtlr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtlr (a, b, npix) + +long a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtls.x b/sys/vops/ak/achtls.x new file mode 100644 index 00000000..8e71fc40 --- /dev/null +++ b/sys/vops/ak/achtls.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtls (a, b, npix) + +long a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtlx.x b/sys/vops/ak/achtlx.x new file mode 100644 index 00000000..ecfc2f68 --- /dev/null +++ b/sys/vops/ak/achtlx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtlx (a, b, npix) + +long a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtrc.x b/sys/vops/ak/achtrc.x new file mode 100644 index 00000000..0c16881a --- /dev/null +++ b/sys/vops/ak/achtrc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrc (a, b, npix) + +real a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrd.x b/sys/vops/ak/achtrd.x new file mode 100644 index 00000000..ef25741d --- /dev/null +++ b/sys/vops/ak/achtrd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrd (a, b, npix) + +real a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtri.x b/sys/vops/ak/achtri.x new file mode 100644 index 00000000..38b137bf --- /dev/null +++ b/sys/vops/ak/achtri.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtri (a, b, npix) + +real a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrl.x b/sys/vops/ak/achtrl.x new file mode 100644 index 00000000..fa30f59c --- /dev/null +++ b/sys/vops/ak/achtrl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrl (a, b, npix) + +real a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrr.x b/sys/vops/ak/achtrr.x new file mode 100644 index 00000000..9825cc95 --- /dev/null +++ b/sys/vops/ak/achtrr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrr (a, b, npix) + +real a[ARB] +real b[ARB] +int npix + +begin + call amovr (a, b, npix) +end diff --git a/sys/vops/ak/achtrs.x b/sys/vops/ak/achtrs.x new file mode 100644 index 00000000..f3bcb1f9 --- /dev/null +++ b/sys/vops/ak/achtrs.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrs (a, b, npix) + +real a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrx.x b/sys/vops/ak/achtrx.x new file mode 100644 index 00000000..047fdad5 --- /dev/null +++ b/sys/vops/ak/achtrx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrx (a, b, npix) + +real a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtsc.x b/sys/vops/ak/achtsc.x new file mode 100644 index 00000000..b8a951bf --- /dev/null +++ b/sys/vops/ak/achtsc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsc (a, b, npix) + +short a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsd.x b/sys/vops/ak/achtsd.x new file mode 100644 index 00000000..a2b5d3af --- /dev/null +++ b/sys/vops/ak/achtsd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsd (a, b, npix) + +short a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsi.x b/sys/vops/ak/achtsi.x new file mode 100644 index 00000000..666530bf --- /dev/null +++ b/sys/vops/ak/achtsi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsi (a, b, npix) + +short a[ARB] +int b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsl.x b/sys/vops/ak/achtsl.x new file mode 100644 index 00000000..867e3f25 --- /dev/null +++ b/sys/vops/ak/achtsl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsl (a, b, npix) + +short a[ARB] +long b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsr.x b/sys/vops/ak/achtsr.x new file mode 100644 index 00000000..7f16c424 --- /dev/null +++ b/sys/vops/ak/achtsr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsr (a, b, npix) + +short a[ARB] +real b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtss.x b/sys/vops/ak/achtss.x new file mode 100644 index 00000000..2d8be27b --- /dev/null +++ b/sys/vops/ak/achtss.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtss (a, b, npix) + +short a[ARB] +short b[ARB] +int npix + +begin + call amovs (a, b, npix) +end diff --git a/sys/vops/ak/achtsx.x b/sys/vops/ak/achtsx.x new file mode 100644 index 00000000..f059d135 --- /dev/null +++ b/sys/vops/ak/achtsx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsx (a, b, npix) + +short a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtxc.x b/sys/vops/ak/achtxc.x new file mode 100644 index 00000000..06625215 --- /dev/null +++ b/sys/vops/ak/achtxc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxc (a, b, npix) + +complex a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxd.x b/sys/vops/ak/achtxd.x new file mode 100644 index 00000000..3548ee23 --- /dev/null +++ b/sys/vops/ak/achtxd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxd (a, b, npix) + +complex a[ARB] +double b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxi.x b/sys/vops/ak/achtxi.x new file mode 100644 index 00000000..403be396 --- /dev/null +++ b/sys/vops/ak/achtxi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxi (a, b, npix) + +complex a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxl.x b/sys/vops/ak/achtxl.x new file mode 100644 index 00000000..eef669dd --- /dev/null +++ b/sys/vops/ak/achtxl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxl (a, b, npix) + +complex a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxr.x b/sys/vops/ak/achtxr.x new file mode 100644 index 00000000..35352510 --- /dev/null +++ b/sys/vops/ak/achtxr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxr (a, b, npix) + +complex a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxs.x b/sys/vops/ak/achtxs.x new file mode 100644 index 00000000..d4e36256 --- /dev/null +++ b/sys/vops/ak/achtxs.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxs (a, b, npix) + +complex a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxx.x b/sys/vops/ak/achtxx.x new file mode 100644 index 00000000..fe5072db --- /dev/null +++ b/sys/vops/ak/achtxx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxx (a, b, npix) + +complex a[ARB] +complex b[ARB] +int npix + +begin + call amovx (a, b, npix) +end diff --git a/sys/vops/ak/acjgx.x b/sys/vops/ak/acjgx.x new file mode 100644 index 00000000..1fc9f944 --- /dev/null +++ b/sys/vops/ak/acjgx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACJGX -- Complex conjugate of a complex vector. + +procedure acjgx (a, b, npix) + +complex a[ARB], b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = conjg (a[i]) +end diff --git a/sys/vops/ak/aclrc.x b/sys/vops/ak/aclrc.x new file mode 100644 index 00000000..03a82c86 --- /dev/null +++ b/sys/vops/ak/aclrc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrc (a, npix) + +char a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrd.x b/sys/vops/ak/aclrd.x new file mode 100644 index 00000000..791eb7c0 --- /dev/null +++ b/sys/vops/ak/aclrd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrd (a, npix) + +double a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0.0D0 +end diff --git a/sys/vops/ak/aclri.x b/sys/vops/ak/aclri.x new file mode 100644 index 00000000..0b022bb3 --- /dev/null +++ b/sys/vops/ak/aclri.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclri (a, npix) + +int a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrl.x b/sys/vops/ak/aclrl.x new file mode 100644 index 00000000..c56fb5b3 --- /dev/null +++ b/sys/vops/ak/aclrl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrl (a, npix) + +long a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrr.x b/sys/vops/ak/aclrr.x new file mode 100644 index 00000000..9102ce7c --- /dev/null +++ b/sys/vops/ak/aclrr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrr (a, npix) + +real a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0.0 +end diff --git a/sys/vops/ak/aclrs.x b/sys/vops/ak/aclrs.x new file mode 100644 index 00000000..a42a6b00 --- /dev/null +++ b/sys/vops/ak/aclrs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrs (a, npix) + +short a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrx.x b/sys/vops/ak/aclrx.x new file mode 100644 index 00000000..a27e555f --- /dev/null +++ b/sys/vops/ak/aclrx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrx (a, npix) + +complex a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = (0.0,0.0) +end diff --git a/sys/vops/ak/acnvd.x b/sys/vops/ak/acnvd.x new file mode 100644 index 00000000..7871ac93 --- /dev/null +++ b/sys/vops/ak/acnvd.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvd (in, out, npix, kernel, knpix) + +double in[npix+knpix-1] # input vector, including boundary pixels +double out[ARB] # output vector +int npix # length of output vector +double kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +double sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvi.x b/sys/vops/ak/acnvi.x new file mode 100644 index 00000000..70a236f8 --- /dev/null +++ b/sys/vops/ak/acnvi.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvi (in, out, npix, kernel, knpix) + +int in[npix+knpix-1] # input vector, including boundary pixels +int out[ARB] # output vector +int npix # length of output vector +int kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +int sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvl.x b/sys/vops/ak/acnvl.x new file mode 100644 index 00000000..98fc18f0 --- /dev/null +++ b/sys/vops/ak/acnvl.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvl (in, out, npix, kernel, knpix) + +long in[npix+knpix-1] # input vector, including boundary pixels +long out[ARB] # output vector +int npix # length of output vector +long kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +long sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvr.x b/sys/vops/ak/acnvr.x new file mode 100644 index 00000000..b1119c29 --- /dev/null +++ b/sys/vops/ak/acnvr.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvr (in, out, npix, kernel, knpix) + +real in[npix+knpix-1] # input vector, including boundary pixels +real out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrd.x b/sys/vops/ak/acnvrd.x new file mode 100644 index 00000000..c6b3fb2f --- /dev/null +++ b/sys/vops/ak/acnvrd.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrd (in, out, npix, kernel, knpix) + +double in[npix+knpix-1] # input vector, including boundary pixels +double out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvri.x b/sys/vops/ak/acnvri.x new file mode 100644 index 00000000..290c093b --- /dev/null +++ b/sys/vops/ak/acnvri.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvri (in, out, npix, kernel, knpix) + +int in[npix+knpix-1] # input vector, including boundary pixels +int out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrl.x b/sys/vops/ak/acnvrl.x new file mode 100644 index 00000000..44df6dad --- /dev/null +++ b/sys/vops/ak/acnvrl.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrl (in, out, npix, kernel, knpix) + +long in[npix+knpix-1] # input vector, including boundary pixels +long out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrr.x b/sys/vops/ak/acnvrr.x new file mode 100644 index 00000000..83f4143c --- /dev/null +++ b/sys/vops/ak/acnvrr.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrr (in, out, npix, kernel, knpix) + +real in[npix+knpix-1] # input vector, including boundary pixels +real out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrs.x b/sys/vops/ak/acnvrs.x new file mode 100644 index 00000000..b00d4a92 --- /dev/null +++ b/sys/vops/ak/acnvrs.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrs (in, out, npix, kernel, knpix) + +short in[npix+knpix-1] # input vector, including boundary pixels +short out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvs.x b/sys/vops/ak/acnvs.x new file mode 100644 index 00000000..9a11eda9 --- /dev/null +++ b/sys/vops/ak/acnvs.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvs (in, out, npix, kernel, knpix) + +short in[npix+knpix-1] # input vector, including boundary pixels +short out[ARB] # output vector +int npix # length of output vector +short kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +short sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/adivd.x b/sys/vops/ak/adivd.x new file mode 100644 index 00000000..73f43925 --- /dev/null +++ b/sys/vops/ak/adivd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivi.x b/sys/vops/ak/adivi.x new file mode 100644 index 00000000..2237363b --- /dev/null +++ b/sys/vops/ak/adivi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivkd.x b/sys/vops/ak/adivkd.x new file mode 100644 index 00000000..3758ab33 --- /dev/null +++ b/sys/vops/ak/adivkd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivki.x b/sys/vops/ak/adivki.x new file mode 100644 index 00000000..ef4a3949 --- /dev/null +++ b/sys/vops/ak/adivki.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivkl.x b/sys/vops/ak/adivkl.x new file mode 100644 index 00000000..cb1ae2e4 --- /dev/null +++ b/sys/vops/ak/adivkl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivkr.x b/sys/vops/ak/adivkr.x new file mode 100644 index 00000000..5f47c21e --- /dev/null +++ b/sys/vops/ak/adivkr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivks.x b/sys/vops/ak/adivks.x new file mode 100644 index 00000000..cb821d21 --- /dev/null +++ b/sys/vops/ak/adivks.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivkx.x b/sys/vops/ak/adivkx.x new file mode 100644 index 00000000..c11a4bfd --- /dev/null +++ b/sys/vops/ak/adivkx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivl.x b/sys/vops/ak/adivl.x new file mode 100644 index 00000000..b449bd31 --- /dev/null +++ b/sys/vops/ak/adivl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivr.x b/sys/vops/ak/adivr.x new file mode 100644 index 00000000..323d6e55 --- /dev/null +++ b/sys/vops/ak/adivr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivs.x b/sys/vops/ak/adivs.x new file mode 100644 index 00000000..ed8785bb --- /dev/null +++ b/sys/vops/ak/adivs.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivs (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivx.x b/sys/vops/ak/adivx.x new file mode 100644 index 00000000..1aa3013c --- /dev/null +++ b/sys/vops/ak/adivx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adotd.x b/sys/vops/ak/adotd.x new file mode 100644 index 00000000..167a82b8 --- /dev/null +++ b/sys/vops/ak/adotd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +double procedure adotd (a, b, npix) + +double a[ARB], b[ARB] + +double sum + +int npix, i + +begin + sum = 0.0D0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adoti.x b/sys/vops/ak/adoti.x new file mode 100644 index 00000000..7bb6bf29 --- /dev/null +++ b/sys/vops/ak/adoti.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adoti (a, b, npix) + +int a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adotl.x b/sys/vops/ak/adotl.x new file mode 100644 index 00000000..0df6d038 --- /dev/null +++ b/sys/vops/ak/adotl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +double procedure adotl (a, b, npix) + +long a[ARB], b[ARB] + +double sum + +int npix, i + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adotr.x b/sys/vops/ak/adotr.x new file mode 100644 index 00000000..309c4f83 --- /dev/null +++ b/sys/vops/ak/adotr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adotr (a, b, npix) + +real a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = 0.0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adots.x b/sys/vops/ak/adots.x new file mode 100644 index 00000000..391fb7ca --- /dev/null +++ b/sys/vops/ak/adots.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adots (a, b, npix) + +short a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adotx.x b/sys/vops/ak/adotx.x new file mode 100644 index 00000000..42006e3d --- /dev/null +++ b/sys/vops/ak/adotx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adotx (a, b, npix) + +complex a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = (0.0,0.0) + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/advzd.x b/sys/vops/ak/advzd.x new file mode 100644 index 00000000..ca5bb0da --- /dev/null +++ b/sys/vops/ak/advzd.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzd (a, b, c, npix, errfcn) + +double a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +double errfcn() # user function, called on divide by zero + +int i +double divisor +double tol +extern errfcn() +errchk errfcn + +begin + tol = 1.0D-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a[i]) + next + } + c[i] = a[i] / divisor + + } +end diff --git a/sys/vops/ak/advzi.x b/sys/vops/ak/advzi.x new file mode 100644 index 00000000..5aa0810e --- /dev/null +++ b/sys/vops/ak/advzi.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzi (a, b, c, npix, errfcn) + +int a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +int errfcn() # user function, called on divide by zero + +int i +int divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/advzl.x b/sys/vops/ak/advzl.x new file mode 100644 index 00000000..22f1a278 --- /dev/null +++ b/sys/vops/ak/advzl.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzl (a, b, c, npix, errfcn) + +long a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +long errfcn() # user function, called on divide by zero + +int i +long divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/advzr.x b/sys/vops/ak/advzr.x new file mode 100644 index 00000000..deb36e3c --- /dev/null +++ b/sys/vops/ak/advzr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzr (a, b, c, npix, errfcn) + +real a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +real errfcn() # user function, called on divide by zero + +int i +real divisor +real tol +extern errfcn() +errchk errfcn + +begin + tol = 1.0E-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a[i]) + next + } + c[i] = a[i] / divisor + + } +end diff --git a/sys/vops/ak/advzs.x b/sys/vops/ak/advzs.x new file mode 100644 index 00000000..98a9603f --- /dev/null +++ b/sys/vops/ak/advzs.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzs (a, b, c, npix, errfcn) + +short a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +short errfcn() # user function, called on divide by zero + +int i +short divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/advzx.x b/sys/vops/ak/advzx.x new file mode 100644 index 00000000..e6089049 --- /dev/null +++ b/sys/vops/ak/advzx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzx (a, b, c, npix, errfcn) + +complex a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +complex errfcn() # user function, called on divide by zero + +int i +complex divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == (0.0,0.0)) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/aexpd.x b/sys/vops/ak/aexpd.x new file mode 100644 index 00000000..f0278777 --- /dev/null +++ b/sys/vops/ak/aexpd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpi.x b/sys/vops/ak/aexpi.x new file mode 100644 index 00000000..0e332a9a --- /dev/null +++ b/sys/vops/ak/aexpi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpkd.x b/sys/vops/ak/aexpkd.x new file mode 100644 index 00000000..7c6f58b9 --- /dev/null +++ b/sys/vops/ak/aexpkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpki.x b/sys/vops/ak/aexpki.x new file mode 100644 index 00000000..609b73c1 --- /dev/null +++ b/sys/vops/ak/aexpki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpkl.x b/sys/vops/ak/aexpkl.x new file mode 100644 index 00000000..941dade0 --- /dev/null +++ b/sys/vops/ak/aexpkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpkr.x b/sys/vops/ak/aexpkr.x new file mode 100644 index 00000000..ee083471 --- /dev/null +++ b/sys/vops/ak/aexpkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpks.x b/sys/vops/ak/aexpks.x new file mode 100644 index 00000000..cfcd1218 --- /dev/null +++ b/sys/vops/ak/aexpks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpkx.x b/sys/vops/ak/aexpkx.x new file mode 100644 index 00000000..4251fca2 --- /dev/null +++ b/sys/vops/ak/aexpkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpl.x b/sys/vops/ak/aexpl.x new file mode 100644 index 00000000..493f7bfa --- /dev/null +++ b/sys/vops/ak/aexpl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpr.x b/sys/vops/ak/aexpr.x new file mode 100644 index 00000000..3e0877ff --- /dev/null +++ b/sys/vops/ak/aexpr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexps.x b/sys/vops/ak/aexps.x new file mode 100644 index 00000000..e0c47207 --- /dev/null +++ b/sys/vops/ak/aexps.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexps (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpx.x b/sys/vops/ak/aexpx.x new file mode 100644 index 00000000..84d1e4c6 --- /dev/null +++ b/sys/vops/ak/aexpx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/afftrr.x b/sys/vops/ak/afftrr.x new file mode 100644 index 00000000..024f4456 --- /dev/null +++ b/sys/vops/ak/afftrr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRR -- Forward fourier transform (real transform, real output arrays). +# The forward transform of the real array SR length NPIX is computed and +# returned in the real arrays FR and FI of length NPIX/2+1. Since the real +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure afftrr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # spatial data (input). SI NOT USED. +real fr[ARB], fi[ARB] # real and imag parts of transform (output) +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Copy the real data vector into the work array. + call amovr (sr, Memr[work], npix) + + # Compute the forward transform. + call ffa (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "afftrr: npix not a power of 2") + + # Unpack the real and imaginary parts into the output arrays. + call aupxr (Memr[work], fr, fi, npix / 2 + 1) + + call sfree (sp) +end diff --git a/sys/vops/ak/afftrx.x b/sys/vops/ak/afftrx.x new file mode 100644 index 00000000..ec43b16a --- /dev/null +++ b/sys/vops/ak/afftrx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRX -- Forward fourier transform (real transform, complex output). +# The fourier transform of the real array A of length NPIX pixels is computed +# and the NPIX/2+1 complex transform coefficients are returned in the complex +# array B. The first element of array B upon output contains the dc term at +# zero frequency, and the remaining elements contain the real and imaginary +# components of the harmonics. The transformation may be performed in place +# if desired. NPIX must be a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFA expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure afftrx (a, b, npix) + +real a[ARB] # data (input) +complex b[ARB] # transform (output). Dim npix/2+1 +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovr (a, b, npix) + + # Compute the forward real transform. + call ffa (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/ak/afftxr.x b/sys/vops/ak/afftxr.x new file mode 100644 index 00000000..b09ae0f5 --- /dev/null +++ b/sys/vops/ak/afftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXR -- Forward fourier transform (complex transform, real arrays). +# The fourier transform of the real arrays SR and SI containing complex data +# pairs is computed and the complex transform coefficients are returned in +# the real arrays FR and FI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure afftxr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # data, spatial domain (input) +real fr[ARB], fi[ARB] # transform, frequency domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (sr, fr, npix) + call amovr (si, fi, npix) + + # Compute the forward transform. + call fft842 (0, npix, fr, fi, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/ak/afftxx.x b/sys/vops/ak/afftxx.x new file mode 100644 index 00000000..34eedbf9 --- /dev/null +++ b/sys/vops/ak/afftxx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXX -- Forward fourier transform (complex transform, complex data). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex transform coefficients are returned in the +# complex array B. The transformation may be performed in place if desired. +# NPIX must be a power of 2. + +procedure afftxx (a, b, npix) + +complex a[ARB] # data (input) +complex b[ARB] # transform (output) +int npix + +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the forward transform. + call fft842 (0, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/ak/agltc.x b/sys/vops/ak/agltc.x new file mode 100644 index 00000000..4f87a8fc --- /dev/null +++ b/sys/vops/ak/agltc.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltc (a, b, npix, low, high, kmul, kadd, nrange) + +char a[ARB], b[ARB], pixval +int npix, i +char low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltd.x b/sys/vops/ak/agltd.x new file mode 100644 index 00000000..c307fe7d --- /dev/null +++ b/sys/vops/ak/agltd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltd (a, b, npix, low, high, kmul, kadd, nrange) + +double a[ARB], b[ARB], pixval +int npix, i +double low[nrange], high[nrange] # range limits +double kmul[nrange], kadd[nrange] # linear transformation +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0D0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/aglti.x b/sys/vops/ak/aglti.x new file mode 100644 index 00000000..c37a650e --- /dev/null +++ b/sys/vops/ak/aglti.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure aglti (a, b, npix, low, high, kmul, kadd, nrange) + +int a[ARB], b[ARB], pixval +int npix, i +int low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltl.x b/sys/vops/ak/agltl.x new file mode 100644 index 00000000..3a416d37 --- /dev/null +++ b/sys/vops/ak/agltl.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltl (a, b, npix, low, high, kmul, kadd, nrange) + +long a[ARB], b[ARB], pixval +int npix, i +long low[nrange], high[nrange] # range limits +double kmul[nrange], kadd[nrange] # linear transformation +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0D0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltr.x b/sys/vops/ak/agltr.x new file mode 100644 index 00000000..974344a4 --- /dev/null +++ b/sys/vops/ak/agltr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltr (a, b, npix, low, high, kmul, kadd, nrange) + +real a[ARB], b[ARB], pixval +int npix, i +real low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/aglts.x b/sys/vops/ak/aglts.x new file mode 100644 index 00000000..ba18d1ac --- /dev/null +++ b/sys/vops/ak/aglts.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure aglts (a, b, npix, low, high, kmul, kadd, nrange) + +short a[ARB], b[ARB], pixval +int npix, i +short low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltx.x b/sys/vops/ak/agltx.x new file mode 100644 index 00000000..c50cfccf --- /dev/null +++ b/sys/vops/ak/agltx.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltx (a, b, npix, low, high, kmul, kadd, nrange) + +complex a[ARB], b[ARB], pixval +int npix, i +complex low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +real abs_pixval +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + abs_pixval = abs (pixval) + do nr = 1, nrange + if (abs_pixval >= abs (low[nr]) && + abs_pixval <= abs (high[nr])) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/ahgmc.x b/sys/vops/ak/ahgmc.x new file mode 100644 index 00000000..b0917e8f --- /dev/null +++ b/sys/vops/ak/ahgmc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmc (data, npix, hgm, nbins, z1, z2) + +char data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +char z1, z2 # greyscale values of first and last bins + +char z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgmd.x b/sys/vops/ak/ahgmd.x new file mode 100644 index 00000000..cd75445f --- /dev/null +++ b/sys/vops/ak/ahgmd.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmd (data, npix, hgm, nbins, z1, z2) + +double data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +double z1, z2 # greyscale values of first and last bins + +double z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgmi.x b/sys/vops/ak/ahgmi.x new file mode 100644 index 00000000..36c11db8 --- /dev/null +++ b/sys/vops/ak/ahgmi.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmi (data, npix, hgm, nbins, z1, z2) + +int data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +int z1, z2 # greyscale values of first and last bins + +int z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgml.x b/sys/vops/ak/ahgml.x new file mode 100644 index 00000000..f515a2e4 --- /dev/null +++ b/sys/vops/ak/ahgml.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgml (data, npix, hgm, nbins, z1, z2) + +long data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +long z1, z2 # greyscale values of first and last bins + +long z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgmr.x b/sys/vops/ak/ahgmr.x new file mode 100644 index 00000000..a1f90d67 --- /dev/null +++ b/sys/vops/ak/ahgmr.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmr (data, npix, hgm, nbins, z1, z2) + +real data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +real z1, z2 # greyscale values of first and last bins + +real z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgms.x b/sys/vops/ak/ahgms.x new file mode 100644 index 00000000..fb656c02 --- /dev/null +++ b/sys/vops/ak/ahgms.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgms (data, npix, hgm, nbins, z1, z2) + +short data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +short z1, z2 # greyscale values of first and last bins + +short z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahivc.x b/sys/vops/ak/ahivc.x new file mode 100644 index 00000000..93a39259 --- /dev/null +++ b/sys/vops/ak/ahivc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +char procedure ahivc (a, npix) + +char a[ARB] +int npix +char high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivd.x b/sys/vops/ak/ahivd.x new file mode 100644 index 00000000..fb851f95 --- /dev/null +++ b/sys/vops/ak/ahivd.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +double procedure ahivd (a, npix) + +double a[ARB] +int npix +double high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivi.x b/sys/vops/ak/ahivi.x new file mode 100644 index 00000000..41effe58 --- /dev/null +++ b/sys/vops/ak/ahivi.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +int procedure ahivi (a, npix) + +int a[ARB] +int npix +int high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivl.x b/sys/vops/ak/ahivl.x new file mode 100644 index 00000000..a6edb516 --- /dev/null +++ b/sys/vops/ak/ahivl.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +long procedure ahivl (a, npix) + +long a[ARB] +int npix +long high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivr.x b/sys/vops/ak/ahivr.x new file mode 100644 index 00000000..0485e6bf --- /dev/null +++ b/sys/vops/ak/ahivr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +real procedure ahivr (a, npix) + +real a[ARB] +int npix +real high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivs.x b/sys/vops/ak/ahivs.x new file mode 100644 index 00000000..2613473f --- /dev/null +++ b/sys/vops/ak/ahivs.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +short procedure ahivs (a, npix) + +short a[ARB] +int npix +short high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivx.x b/sys/vops/ak/ahivx.x new file mode 100644 index 00000000..b487aa8d --- /dev/null +++ b/sys/vops/ak/ahivx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +complex procedure ahivx (a, npix) + +complex a[ARB] +int npix +complex high, pixval +real abs_high +int i + +begin + high = a[1] + abs_high = abs (high) + + do i = 1, npix { + pixval = a[i] + if (abs (pixval) > abs_high) { + high = pixval + abs_high = abs (high) + } + } + + return (high) +end diff --git a/sys/vops/ak/aiftrr.x b/sys/vops/ak/aiftrr.x new file mode 100644 index 00000000..96789581 --- /dev/null +++ b/sys/vops/ak/aiftrr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRR -- Inverse fourier transform (real transform, real output arrays). +# The inverse transform of the real arrays FR and FI of length NPIX/2+1 is +# returned in the real array SR of length NPIX. Since the real inverse +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure aiftrr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # real and imag parts of transform (input) +real sr[ARB], si[ARB] # spatial data (output). SI NOT USED. +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Pack the real and imaginary parts into a complex array as required + # by FFS. + call apkxr (fr, fi, Memr[work], npix / 2 + 1) + + # Compute the inverse transform. + call ffs (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "aiftrr: npix not a power of 2") + + # The work array now contains the real part of the transform; merely + # copy it to the output array. + call amovr (Memr[work], sr, npix) + + call sfree (sp) +end diff --git a/sys/vops/ak/aiftrx.x b/sys/vops/ak/aiftrx.x new file mode 100644 index 00000000..63a9d53d --- /dev/null +++ b/sys/vops/ak/aiftrx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRX -- Inverse discreet fourier transform (real transform, complex data +# array in). The input array A of length NPIX/2+1 contains the DC term and +# the NPIX/2 (real,imag) pairs for each of the NPIX/2 harmonics of the real +# transform. Upon output array B contains the NPIX real data pixels from the +# inverse transform. The transform may be performed in place if desired. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFS expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftrx (a, b, npix) + +complex a[ARB] # transform, npix/2+1 elements +real b[ARB] # output data array +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovx (a, b, npix / 2 + 1) + + # Compute the inverse real transform. + call ffs (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/ak/aiftxr.x b/sys/vops/ak/aiftxr.x new file mode 100644 index 00000000..a9647e7c --- /dev/null +++ b/sys/vops/ak/aiftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXR -- Inverse fourier transform (complex transform, real arrays). +# The inverse transform of the real arrays FR and FI containing complex data +# pairs is computed and the complex spatial data coefficients are returned in +# the real arrays SR and SI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure aiftxr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # transform, frequency domain (input) +real sr[ARB], si[ARB] # data, spatial domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (fr, sr, npix) + call amovr (fi, si, npix) + + # Compute the inverse transform. + call fft842 (1, npix, sr, si, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/ak/aiftxx.x b/sys/vops/ak/aiftxx.x new file mode 100644 index 00000000..2871590f --- /dev/null +++ b/sys/vops/ak/aiftxx.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXX -- Inverse fourier transform (complex transform, complex array). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex data points are returned in the complex array +# B. The transformation may be performed in place if desired. NPIX must be +# a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# A and B to be type COMPLEX arrays in the calling program, but FFT842 expects +# a REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftxx (a, b, npix) + +complex a[ARB] # transform (input) +complex b[ARB] # data (output) +int npix +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the inverse transform. + call fft842 (1, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/ak/aimgd.x b/sys/vops/ak/aimgd.x new file mode 100644 index 00000000..b99b6aa3 --- /dev/null +++ b/sys/vops/ak/aimgd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgd (a, b, npix) + +complex a[ARB] +double b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgi.x b/sys/vops/ak/aimgi.x new file mode 100644 index 00000000..7632f2d0 --- /dev/null +++ b/sys/vops/ak/aimgi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgi (a, b, npix) + +complex a[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgl.x b/sys/vops/ak/aimgl.x new file mode 100644 index 00000000..34958a6a --- /dev/null +++ b/sys/vops/ak/aimgl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgl (a, b, npix) + +complex a[ARB] +long b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgr.x b/sys/vops/ak/aimgr.x new file mode 100644 index 00000000..a6e0e910 --- /dev/null +++ b/sys/vops/ak/aimgr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgr (a, b, npix) + +complex a[ARB] +real b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgs.x b/sys/vops/ak/aimgs.x new file mode 100644 index 00000000..71dbbe67 --- /dev/null +++ b/sys/vops/ak/aimgs.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgs (a, b, npix) + +complex a[ARB] +short b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/mkpkg b/sys/vops/ak/mkpkg new file mode 100644 index 00000000..9841f019 --- /dev/null +++ b/sys/vops/ak/mkpkg @@ -0,0 +1,276 @@ +# Make the VOPS vector operators library, procedures a[a-k]*.x. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +libvops.a: + aabsd.x + aabsi.x + aabsl.x + aabsr.x + aabss.x + aabsx.x + aaddd.x + aaddi.x + aaddkd.x + aaddki.x + aaddkl.x + aaddkr.x + aaddks.x + aaddkx.x + aaddl.x + aaddr.x + aadds.x + aaddx.x + aandi.x + aandki.x + aandkl.x + aandks.x + aandl.x + aands.x + aavgd.x + aavgi.x + aavgl.x + aavgr.x + aavgs.x + aavgx.x + abavd.x + abavi.x + abavl.x + abavr.x + abavs.x + abavx.x + abeqc.x + abeqd.x + abeqi.x + abeqkc.x + abeqkd.x + abeqki.x + abeqkl.x + abeqkr.x + abeqks.x + abeqkx.x + abeql.x + abeqr.x + abeqs.x + abeqx.x + abgec.x + abged.x + abgei.x + abgekc.x + abgekd.x + abgeki.x + abgekl.x + abgekr.x + abgeks.x + abgekx.x + abgel.x + abger.x + abges.x + abgex.x + abgtc.x + abgtd.x + abgti.x + abgtkc.x + abgtkd.x + abgtki.x + abgtkl.x + abgtkr.x + abgtks.x + abgtkx.x + abgtl.x + abgtr.x + abgts.x + abgtx.x + ablec.x + abled.x + ablei.x + ablekc.x + ablekd.x + ableki.x + ablekl.x + ablekr.x + ableks.x + ablekx.x + ablel.x + abler.x + ables.x + ablex.x + abltc.x + abltd.x + ablti.x + abltkc.x + abltkd.x + abltki.x + abltkl.x + abltkr.x + abltks.x + abltkx.x + abltl.x + abltr.x + ablts.x + abltx.x + abnec.x + abned.x + abnei.x + abnekc.x + abnekd.x + abneki.x + abnekl.x + abnekr.x + abneks.x + abnekx.x + abnel.x + abner.x + abnes.x + abnex.x + abori.x + aborki.x + aborkl.x + aborks.x + aborl.x + abors.x + absud.x + absui.x + absul.x + absur.x + absus.x + achtcc.x + achtcd.x + achtci.x + achtcl.x + achtcr.x + achtcs.x + achtcx.x + achtdc.x + achtdd.x + achtdi.x + achtdl.x + achtdr.x + achtds.x + achtdx.x + achtic.x + achtid.x + achtii.x + achtil.x + achtir.x + achtis.x + achtix.x + achtlc.x + achtld.x + achtli.x + achtll.x + achtlr.x + achtls.x + achtlx.x + achtrc.x + achtrd.x + achtri.x + achtrl.x + achtrr.x + achtrs.x + achtrx.x + achtsc.x + achtsd.x + achtsi.x + achtsl.x + achtsr.x + achtss.x + achtsx.x + achtxc.x + achtxd.x + achtxi.x + achtxl.x + achtxr.x + achtxs.x + achtxx.x + acjgx.x + aclrc.x + aclrd.x + aclri.x + aclrl.x + aclrr.x + aclrs.x + aclrx.x + acnvd.x + acnvi.x + acnvl.x + acnvr.x + acnvrd.x + acnvri.x + acnvrl.x + acnvrr.x + acnvrs.x + acnvs.x + adivd.x + adivi.x + adivkd.x + adivki.x + adivkl.x + adivkr.x + adivks.x + adivkx.x + adivl.x + adivr.x + adivs.x + adivx.x + adotd.x + adoti.x + adotl.x + adotr.x + adots.x + adotx.x + advzd.x + advzi.x + advzl.x + advzr.x + advzs.x + advzx.x + aexpd.x + aexpi.x + aexpkd.x + aexpki.x + aexpkl.x + aexpkr.x + aexpks.x + aexpkx.x + aexpl.x + aexpr.x + aexps.x + aexpx.x + afftrr.x + afftrx.x + afftxr.x + afftxx.x + agltc.x + agltd.x + aglti.x + agltl.x + agltr.x + aglts.x + agltx.x + ahgmc.x <mach.h> + ahgmd.x <mach.h> + ahgmi.x <mach.h> + ahgml.x <mach.h> + ahgmr.x <mach.h> + ahgms.x <mach.h> + ahivc.x + ahivd.x + ahivi.x + ahivl.x + ahivr.x + ahivs.x + ahivx.x + aiftrr.x + aiftrx.x + aiftxr.x + aiftxx.x + aimgd.x + aimgi.x + aimgl.x + aimgr.x + aimgs.x + ; diff --git a/sys/vops/alan.gx b/sys/vops/alan.gx new file mode 100644 index 00000000..43b21069 --- /dev/null +++ b/sys/vops/alan.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alan$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alank.gx b/sys/vops/alank.gx new file mode 100644 index 00000000..a8e3c1b1 --- /dev/null +++ b/sys/vops/alank.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alank$t (a, b, c, npix) + +PIXEL a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alim.gx b/sys/vops/alim.gx new file mode 100644 index 00000000..2e9cbf56 --- /dev/null +++ b/sys/vops/alim.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alim$t (a, npix, minval, maxval) + +PIXEL a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + $if (datatype == x) + if (abs(value) < abs(minval)) + minval = value + else if (abs(value) > abs(maxval)) + maxval = value + $else + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + $endif + } +end diff --git a/sys/vops/alln.gx b/sys/vops/alln.gx new file mode 100644 index 00000000..7d6ed921 --- /dev/null +++ b/sys/vops/alln.gx @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure alln$t (a, b, npix, errfcn) + +PIXEL a[ARB], b[ARB] +int npix, i +extern errfcn() +PIXEL errfcn() +errchk errfcn + +begin + do i = 1, npix { + $if (datatype == x) + if (a[i] == 0$f) + $else + if (a[i] <= 0$f) + $endif + b[i] = errfcn (a[i]) + else { + $if (datatype == si) + b[i] = log (real (a[i])) + $else $if (datatype == l) + b[i] = log (double (a[i])) + $else + b[i] = log (a[i]) + $endif $endif + } + } +end diff --git a/sys/vops/alog.gx b/sys/vops/alog.gx new file mode 100644 index 00000000..033f9514 --- /dev/null +++ b/sys/vops/alog.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alog$t (a, b, npix, errfcn) + +PIXEL a[ARB], b[ARB] +int npix, i +extern errfcn() +PIXEL errfcn() +errchk errfcn + +begin + do i = 1, npix { + $if (datatype == x) + if (a[i] == 0$f) + $else + if (a[i] <= 0$f) + $endif + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + $if (datatype == xsi) + b[i] = log10 (real (a[i])) + $else $if (datatype == l) + b[i] = log10 (double (a[i])) + $else + b[i] = log10 (a[i]) + $endif $endif + } + } +end diff --git a/sys/vops/alor.gx b/sys/vops/alor.gx new file mode 100644 index 00000000..e1f7bd67 --- /dev/null +++ b/sys/vops/alor.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alor$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alork.gx b/sys/vops/alork.gx new file mode 100644 index 00000000..ddcd108d --- /dev/null +++ b/sys/vops/alork.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alork$t (a, b, c, npix) + +PIXEL a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alov.gx b/sys/vops/alov.gx new file mode 100644 index 00000000..27a81128 --- /dev/null +++ b/sys/vops/alov.gx @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +PIXEL procedure alov$t (a, npix) + +PIXEL a[ARB] +int npix +PIXEL low, pixval +$if (datatype == x) +real abs_low +$endif +int i + +begin + low = a[1] + $if (datatype == x) + abs_low = abs (low) + $endif + + do i = 1, npix { + pixval = a[i] + $if (datatype == x) + if (abs (pixval) < abs_low) { + low = pixval + abs_low = abs (low) + } + $else + if (pixval < low) + low = pixval + $endif + } + + return (low) +end diff --git a/sys/vops/alta.gx b/sys/vops/alta.gx new file mode 100644 index 00000000..c09bd38f --- /dev/null +++ b/sys/vops/alta.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure alta$t (a, b, npix, k1, k2) + +PIXEL a[ARB], b[ARB] +$if (datatype == ld) +double k1, k2 +$else +real k1, k2 +$endif +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/altm.gx b/sys/vops/altm.gx new file mode 100644 index 00000000..d0f00f94 --- /dev/null +++ b/sys/vops/altm.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altm$t (a, b, npix, k1, k2) + +PIXEL a[ARB], b[ARB] +$if (datatype == ld) +double k1, k2 +$else +real k1, k2 +$endif +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/altr.gx b/sys/vops/altr.gx new file mode 100644 index 00000000..866c9e03 --- /dev/null +++ b/sys/vops/altr.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altr$t (a, b, npix, k1, k2, k3) + +PIXEL a[ARB], b[ARB] +$if (datatype == ld) +double k1, k2, k3 +$else +real k1, k2, k3 +$endif +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/alui.gx b/sys/vops/alui.gx new file mode 100644 index 00000000..535dee9c --- /dev/null +++ b/sys/vops/alui.gx @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure alui$t (a, b, x, npix) + +PIXEL a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/alut.gx b/sys/vops/alut.gx new file mode 100644 index 00000000..f4e01fb3 --- /dev/null +++ b/sys/vops/alut.gx @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alut$t (a, b, npix, lut) + +$if (datatype == rd) +int a[ARB] # input array of indices +$else +PIXEL a[ARB] +$endif + +PIXEL b[ARB] # output data array +PIXEL lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/amag.gx b/sys/vops/amag.gx new file mode 100644 index 00000000..397a7c25 --- /dev/null +++ b/sys/vops/amag.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amag$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + $if (datatype == sir) + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) + $else $if (datatype == dl) + c[i] = sqrt (double(a[i] ** 2) + double(b[i] ** 2)) + $else + c[i] = sqrt (a[i] ** 2 + b[i] ** 2) + $endif $endif +end diff --git a/sys/vops/amap.gx b/sys/vops/amap.gx new file mode 100644 index 00000000..9006b221 --- /dev/null +++ b/sys/vops/amap.gx @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amap$t (a, b, npix, a1, a2, b1, b2) + +PIXEL a[ARB], b[ARB] +PIXEL a1, a2, b1, b2 + +$if (datatype == sil) +long minout, maxout, aoff, boff, pixval +$else +PIXEL minout, maxout, aoff, boff, pixval +$endif + +$if (datatype == ld) +double scalar +$else +real scalar +$endif + +int npix, i + +begin + $if (datatype == ld) + scalar = (double (b2) - double (b1)) / (double (a2) - double (a1)) + $else + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + $endif + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/amax.gx b/sys/vops/amax.gx new file mode 100644 index 00000000..ce61b558 --- /dev/null +++ b/sys/vops/amax.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amax$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) >= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] + $else + c[i] = max (a[i], b[i]) + $endif +end diff --git a/sys/vops/amaxk.gx b/sys/vops/amaxk.gx new file mode 100644 index 00000000..f45bca09 --- /dev/null +++ b/sys/vops/amaxk.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == x) +real abs_b +$endif + +begin + $if (datatype == x) + abs_b = abs (b) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) >= abs_b) + c[i] = a[i] + else + c[i] = b + $else + c[i] = max (a[i], b) + $endif +end diff --git a/sys/vops/amed.gx b/sys/vops/amed.gx new file mode 100644 index 00000000..21a31724 --- /dev/null +++ b/sys/vops/amed.gx @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +PIXEL procedure amed$t (a, npix) + +PIXEL a[ARB] +int npix + +pointer sp, aa +PIXEL median +PIXEL asok$t() # select the Kth smallest element from A +$if (datatype == x) +real a1, a2, a3 +$endif + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + $if (datatype == x) + a1 = abs (a[1]) + a2 = abs (a[2]) + a3 = abs (a[3]) + if (a1 < a2) { + if (a2 < a3) + return (a[2]) + else if (a1 < a3) + return (a[3]) + else + return (a[1]) + } else { + if (a2 > a3) + return (a[2]) + else if (a1 < a3) + return (a[1]) + else + return (a[3]) + } + $else + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + $endif + + default: + call smark (sp) + call salloc (aa, npix, TY_PIXEL) + call amov$t (a, Mem$t[aa], npix) + median = asok$t (Mem$t[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/amed3.gx b/sys/vops/amed3.gx new file mode 100644 index 00000000..37452cb5 --- /dev/null +++ b/sys/vops/amed3.gx @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3$t (a, b, c, m, npix) + +PIXEL a[ARB], b[ARB], c[ARB] # input vectors +PIXEL m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/amed4.gx b/sys/vops/amed4.gx new file mode 100644 index 00000000..fb5fab5e --- /dev/null +++ b/sys/vops/amed4.gx @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4$t (a, b, c, d, m, npix) + +PIXEL a[ARB], b[ARB] # input vectors +PIXEL c[ARB], d[ARB] # input vectors +PIXEL m[ARB] # output vector (median) +int npix + +int i +PIXEL temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/amed5.gx b/sys/vops/amed5.gx new file mode 100644 index 00000000..9d81d243 --- /dev/null +++ b/sys/vops/amed5.gx @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5$t (a, b, c, d, e, m, npix) + +PIXEL a[ARB], b[ARB] # input vectors +PIXEL c[ARB], d[ARB], e[ARB] # input vectors +PIXEL m[ARB] # output vector (median) +int npix + +int i +PIXEL temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/amgs.gx b/sys/vops/amgs.gx new file mode 100644 index 00000000..eb7b3124 --- /dev/null +++ b/sys/vops/amgs.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgs$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/amin.gx b/sys/vops/amin.gx new file mode 100644 index 00000000..4d5ad6ea --- /dev/null +++ b/sys/vops/amin.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amin$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) <= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] + $else + c[i] = min (a[i], b[i]) + $endif +end diff --git a/sys/vops/amink.gx b/sys/vops/amink.gx new file mode 100644 index 00000000..f2775252 --- /dev/null +++ b/sys/vops/amink.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure amink$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == x) +real abs_b +$endif + +begin + $if (datatype == x) + abs_b = abs (b) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) <= abs_b) + c[i] = a[i] + else + c[i] = b + $else + c[i] = min (a[i], b) + $endif +end diff --git a/sys/vops/amod.gx b/sys/vops/amod.gx new file mode 100644 index 00000000..563b3b2a --- /dev/null +++ b/sys/vops/amod.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amod$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/amodk.gx b/sys/vops/amodk.gx new file mode 100644 index 00000000..918eed75 --- /dev/null +++ b/sys/vops/amodk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/amov.gx b/sys/vops/amov.gx new file mode 100644 index 00000000..e500856f --- /dev/null +++ b/sys/vops/amov.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amov$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/amovk.gx b/sys/vops/amovk.gx new file mode 100644 index 00000000..94dfb176 --- /dev/null +++ b/sys/vops/amovk.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovk$t (a, b, npix) + +PIXEL a +PIXEL b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/amul.gx b/sys/vops/amul.gx new file mode 100644 index 00000000..714454d8 --- /dev/null +++ b/sys/vops/amul.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amul$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/amulk.gx b/sys/vops/amulk.gx new file mode 100644 index 00000000..276daa90 --- /dev/null +++ b/sys/vops/amulk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/aneg.gx b/sys/vops/aneg.gx new file mode 100644 index 00000000..6b18e520 --- /dev/null +++ b/sys/vops/aneg.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure aneg$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/anot.gx b/sys/vops/anot.gx new file mode 100644 index 00000000..08f95a47 --- /dev/null +++ b/sys/vops/anot.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anot$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i +$if (datatype == i) +int not() +$else +PIXEL not$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + b[i] = not (a[i]) + $else + b[i] = not$t (a[i]) + $endif + } +end diff --git a/sys/vops/apkx.gx b/sys/vops/apkx.gx new file mode 100644 index 00000000..904e38d6 --- /dev/null +++ b/sys/vops/apkx.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkx$t (a, b, c, npix) + +PIXEL a[ARB] # real component +PIXEL b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + $if (datatype == x) + c[i] = complex (real(a[i]), aimag(b[i])) + $else + c[i] = complex (real(a[i]), real(b[i])) + $endif +end diff --git a/sys/vops/apol.gx b/sys/vops/apol.gx new file mode 100644 index 00000000..04d162c5 --- /dev/null +++ b/sys/vops/apol.gx @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOL -- Evaluate a polynomial at X, given the coefficients of the polynomial +# in COEFF and returning the computed value as the function value. + +PIXEL procedure apol$t (x, coeff, ncoeff) + +PIXEL x # point at which the polynomial is to be evaluated +PIXEL coeff[ncoeff] # coefficients of the polynomial, lower orders first +int ncoeff + +int i +PIXEL pow, sum + +begin + sum = coeff[1] + pow = x + + do i = 2, ncoeff { + sum = sum + pow * coeff[i] + pow = pow * x + } + + return (sum) +end diff --git a/sys/vops/apow.gx b/sys/vops/apow.gx new file mode 100644 index 00000000..c8fca670 --- /dev/null +++ b/sys/vops/apow.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apow$t (a, b, c, npix) + +PIXEL a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/apowk.gx b/sys/vops/apowk.gx new file mode 100644 index 00000000..68e83599 --- /dev/null +++ b/sys/vops/apowk.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowk$t (a, b, c, npix) + +PIXEL a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovk$t (1$f, c, npix) + case 1: + call amov$t (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/arav.gx b/sys/vops/arav.gx new file mode 100644 index 00000000..abc965dd --- /dev/null +++ b/sys/vops/arav.gx @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure arav$t (a, npix, mean, sigma, ksig) + +PIXEL a[ARB] # input data array +$if (datatype == dl) +double mean, sigma, ksig, deviation, lcut, hcut, lgpx +$else +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +$endif +int npix, ngpix, old_ngpix, awvg$t() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvg$t (a, npix, mean, sigma, lcut, hcut) + $if (datatype == dl) + if (ngpix <= 1 || sigma <= EPSILOND) + $else + if (ngpix <= 1 || sigma <= EPSILONR) + $endif + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/arcp.gx b/sys/vops/arcp.gx new file mode 100644 index 00000000..6c7f9dc4 --- /dev/null +++ b/sys/vops/arcp.gx @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcp$t (a, b, c, npix) + +PIXEL a # constant numerator +PIXEL b[ARB] # vector denominator +PIXEL c[ARB] # output vector +int npix +int i + +begin + if (a == 0$f) { + call aclr$t (c, npix) + } else if (a == 1$f) { + do i = 1, npix + c[i] = 1$f / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/arcz.gx b/sys/vops/arcz.gx new file mode 100644 index 00000000..ff8e30e0 --- /dev/null +++ b/sys/vops/arcz.gx @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arcz$t (a, b, c, npix, errfcn) + +PIXEL a # numerator +PIXEL b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +PIXEL errfcn() # user function, called on divide by zero + +int i +PIXEL divisor +$if (datatype == rd) +PIXEL tol +$endif +extern errfcn() +errchk errfcn + +begin + if (a == 0$f) { + call aclr$t (c, npix) + return + } + + $if (datatype == r) + tol = 1.0E-20 + $else $if (datatype == d) + tol = 1.0D-20 + $endif $endif + + do i = 1, npix { + divisor = b[i] + $if (datatype == rd) + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a) + next + } + c[i] = a / divisor + + $else + if (divisor == 0$f) + c[i] = errfcn (a) + else + c[i] = a / divisor + $endif + } +end diff --git a/sys/vops/argt.gx b/sys/vops/argt.gx new file mode 100644 index 00000000..3ac2fbc4 --- /dev/null +++ b/sys/vops/argt.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argt$t (a, npix, ceil, newval) + +PIXEL a[ARB] +int npix +PIXEL ceil, newval +int i +$if (datatype == x) +real abs_ceil +$endif + +begin + $if (datatype == x) + abs_ceil = abs (ceil) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > abs_ceil) + $else + if (a[i] > ceil) + $endif + a[i] = newval +end diff --git a/sys/vops/arlt.gx b/sys/vops/arlt.gx new file mode 100644 index 00000000..8edce34a --- /dev/null +++ b/sys/vops/arlt.gx @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arlt$t (a, npix, floor, newval) + +PIXEL a[ARB] +int npix +PIXEL floor, newval +int i +$if (datatype == x) +real abs_floor +$endif + +begin + $if (datatype == x) + abs_floor = abs (floor) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) < abs_floor) + $else + if (a[i] < floor) + $endif + a[i] = newval +end diff --git a/sys/vops/asel.gx b/sys/vops/asel.gx new file mode 100644 index 00000000..ef978d46 --- /dev/null +++ b/sys/vops/asel.gx @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure asel$t (a, b, c, sel, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/aselk.gx b/sys/vops/aselk.gx new file mode 100644 index 00000000..2d7c54d3 --- /dev/null +++ b/sys/vops/aselk.gx @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselk$t (a, b, c, sel, npix) + +PIXEL a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/asok.gx b/sys/vops/asok.gx new file mode 100644 index 00000000..b508d4ff --- /dev/null +++ b/sys/vops/asok.gx @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +PIXEL procedure asok$t (a, npix, ksel) + +PIXEL a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +PIXEL temp, wtemp +$if (datatype == x) +real abs_temp +$endif + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (a[i]) < abs_temp) + $else + while (a[i] < temp) + $endif + i = i + 1 + $if (datatype == x) + while (abs_temp < abs (a[j])) + $else + while (temp < a[j]) + $endif + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/asqr.gx b/sys/vops/asqr.gx new file mode 100644 index 00000000..1a584853 --- /dev/null +++ b/sys/vops/asqr.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqr$t (a, b, npix, errfcn) + +PIXEL a[ARB], b[ARB] +int npix, i +extern errfcn() +PIXEL errfcn() +errchk errfcn + +begin + do i = 1, npix { + $if (datatype != x) + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + $endif + { + $if (datatype == rdx) + b[i] = sqrt (a[i]) + $else $if (datatype == l) + b[i] = sqrt (double (a[i])) + $else + b[i] = sqrt (real (a[i])) + $endif $endif + } + } +end diff --git a/sys/vops/asrt.gx b/sys/vops/asrt.gx new file mode 100644 index 00000000..ff639b2a --- /dev/null +++ b/sys/vops/asrt.gx @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrt$t (a, b, npix) + +PIXEL a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +PIXEL pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amov$t (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + $if (datatype == x) + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + $else + for (i=i+1; b[i] < pivot; i=i+1) + $endif + ; + for (j=j-1; j > i; j=j-1) + $if (datatype == x) + if (abs(b[j]) <= abs(pivot)) + $else + if (b[j] <= pivot) + $endif + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/assq.gx b/sys/vops/assq.gx new file mode 100644 index 00000000..0189e01e --- /dev/null +++ b/sys/vops/assq.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +$if (datatype == csir) +real procedure assq$t (a, npix) +real sum +$else $if (datatype == ld) +double procedure assq$t (a, npix) +double sum +$else +PIXEL procedure assq$t (a, npix) +PIXEL sum +$endif $endif + +PIXEL a[ARB] +int npix +int i + +begin + sum = 0$f + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/asub.gx b/sys/vops/asub.gx new file mode 100644 index 00000000..547ee29c --- /dev/null +++ b/sys/vops/asub.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asub$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/asubk.gx b/sys/vops/asubk.gx new file mode 100644 index 00000000..2f77e007 --- /dev/null +++ b/sys/vops/asubk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/asum.gx b/sys/vops/asum.gx new file mode 100644 index 00000000..716d2b53 --- /dev/null +++ b/sys/vops/asum.gx @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +$if (datatype == csir) +real procedure asum$t (a, npix) +$else $if (datatype == ld) +double procedure asum$t (a, npix) +$else +PIXEL procedure asum$t (a, npix) +$endif $endif + +PIXEL a[ARB] +int npix +int i + +$if (datatype == csir) +real sum +$else $if (datatype == ld) +double sum +$else +PIXEL sum +$endif $endif + +begin + sum = 0$f + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/aupx.gx b/sys/vops/aupx.gx new file mode 100644 index 00000000..c6a4a66b --- /dev/null +++ b/sys/vops/aupx.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupx$t (a, b, c, npix) + +complex a[ARB] # input vector +PIXEL b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + $if (datatype == x) + b[i] = complex (real(a[i]), 0.0) + c[i] = complex (0.0, aimag(a[i])) + $else + b[i] = real (a[i]) + c[i] = aimag (a[i]) + $endif + } +end diff --git a/sys/vops/aveq.gx b/sys/vops/aveq.gx new file mode 100644 index 00000000..1967102a --- /dev/null +++ b/sys/vops/aveq.gx @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveq$t (a, b, npix) + +PIXEL a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/awsu.gx b/sys/vops/awsu.gx new file mode 100644 index 00000000..ffa5446d --- /dev/null +++ b/sys/vops/awsu.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsu$t (a, b, c, npix, k1, k2) + +PIXEL a[ARB], b[ARB], c[ARB] +$if (datatype == x) +complex k1, k2 +$else $if (datatype == d) +double k1, k2 +$else +real k1, k2 +$endif $endif +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/awvg.gx b/sys/vops/awvg.gx new file mode 100644 index 00000000..7c221bf3 --- /dev/null +++ b/sys/vops/awvg.gx @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvg$t (a, npix, mean, sigma, lcut, hcut) + +PIXEL a[ARB] +$if (datatype == dl) +double mean, sigma, lcut, hcut +$else +real mean, sigma, lcut, hcut +$endif +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + $if (datatype == x) + value = abs (a[i]) + $else + value = a[i] + $endif + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + $if (datatype == x) + value = abs (a[i]) + $else + value = a[i] + $endif + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: +$if (datatype == dl) + mean = $INDEFD + sigma = $INDEFD +$else + mean = $INDEFR + sigma = $INDEFR +$endif + case 1: + mean = sum +$if (datatype == dl) + sigma = $INDEFD +$else + sigma = $INDEFR +$endif + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/axor.gx b/sys/vops/axor.gx new file mode 100644 index 00000000..18fd07fd --- /dev/null +++ b/sys/vops/axor.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axor$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i +$if (datatype == i) +int xor() +$else +PIXEL xor$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = xor (a[i], b[i]) + $else + c[i] = xor$t (a[i], b[i]) + $endif + } +end diff --git a/sys/vops/axork.gx b/sys/vops/axork.gx new file mode 100644 index 00000000..eeb3694c --- /dev/null +++ b/sys/vops/axork.gx @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axork$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == i) +int xor() +$else +PIXEL xor$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = xor (a[i], b) + $else + c[i] = xor$t (a[i], b) + $endif + } +end diff --git a/sys/vops/doc/vops.hlp b/sys/vops/doc/vops.hlp new file mode 100644 index 00000000..dc415afa --- /dev/null +++ b/sys/vops/doc/vops.hlp @@ -0,0 +1,260 @@ + +.help VOPS Feb83 "Vector Primitives" +.sh +Introduction + + The vector primitives are abstract machine instructions which +operate on vectors. The "a" prefixed operators are for one dimensional +arrays, and the "m" prefixed operators are for two dimensional +arrays (matrices). Each generic instruction is implemented as a +set of operators, one for each data type. + +There are no vector primitives for the type BOOL. If a "b" suffix is given, +the vector primitive is understood to operate on unsigned machine bytes. +The "u" suffix is used for the special type unsigned short integer. + +The binary operators ("c = a op b") come in two forms. If the regular +three character instruction mnemonic is used, the B operand must be vector. +If the letter "k" is added to the mnemonic, the B operand must be a constant. +These dual mode operators are flagged (with "(k)") in the table below. + + +.nf + Instruction Operation Data Types + + cht__ b = a (change datatype) UBcsilrdx + clr_ fill a with zeros csilrdx + mov_ (k) b = a (copy vector) csilrdx + + abs_ b = abs(a) silrdx + log_ b = log10(a) silrdx + lln_ b = natural_log(a) silrdx + sqr_ b = sqrt(a) silrdx + srt_ b = sort(a) csilrdx + neg_ b = -a silrdx + map_ b = (a + k1) * k2 silrdx + map_B b = (a + k1) * k2 silrdx + lut_ b = lut[a] (lookup table) csil + lui_ b = interp (a, x) silrd + rep_ a = newval if (low<=a<=high) csilrdx + + add_ (k) c = a + b silrdx + sub_ (k) c = a - b silrdx + mul_ (k) c = a * b silrdx + div_ (k) c = a / b silrdx + min_ (k) c = min(a,b) silrd + max_ (k) c = max(a,b) silrd + mod_ (k) c = mod(a,b) silrd + pow_ (k) c = a ** int_pwr silrdx + exp_ (k) c = a ** real_pwr silrdx + + not_ b = !a sil + and_ (k) c = and(a,b) sil + bor_ (k) c = or(a,b) sil + xor_ (k) c = xor(a,b) sil + + +.tp 4 +other vector primitives: + + lim_ ngpix = lim_ (a, npix; minval, maxval) silrdx + win_ nrej = win_ (a, npix, lcut, hcut) silrdx + avg_ ngpix = avg_ (a, npix; mean, sigma) silrdx + rav_ ngpix = rav_ (a, npix; mean, sigma; ksig) silrdx +? med_ ngpix = med_ (a, ia, npix; median) silrd +.fi + + +For example, "aaddr(a,b,c,npix)" would add the two REAL vectors A and B, +of length NPIX, placing the sum in the vector C. To add a constant K to +the vector A, "aaddkr(a,k,c,npix)" would be used. +The sequence "aclrb(a,nbytes)" would zero NBYTES machine bytes, +starting at location A. + +.sh +Preprocessing Generic Operators + + A preprocessor is provided to convert a generic operator into a set +of type specific operators. By coding only generic operators, the programmer +only has to maintain a single piece of code, reducing the possibility of +an error, and greatly reducing the amount of work. + +The GENERIC preprocessor takes as input files written in either the IRAF +preprocessor language or C (or any other language which provides macro +definitions), with embedded preprocessor directives and keywords. +.sh +Usage + + The calling sequence for the preprocessor (on the UNIX system) +is as follows: + + generic [-t types] [-p prefix] [-o outfile] file [file...] + +Any number of files may be processed. +.sh +Flags + + The following (optional) flags are provided to control the types +and names of the generated files: +.ls 8 +.ls 8 -t +Used to specify the datatypes of the files to be produced. The default +value is "silrdx", meaning types SHORT through COMPLEX. Other possible +types are "BU", i.e., unsigned byte and unsigned short. The generic +preprocessor does not support type boolean. +.le +.ls -p +An optional prefix string to be added to each file name generated. Provided +to make it convenient to place all generated files in a subdirectory. +If the name of the file(s) being preprocessed is "aadd.x", and the prefix +is "d/", the names of the generated files will be "d/aadds.x", "d/aaddi.x", +"d/aaddl.x", and so on. +.le +.ls -o +If an output filename is specified with the -o flag, only a single input file +may be processed. Any "$t" sequences embedded in the output file name +will be replaced by the type "suffix" character to generate the filenames +of the type specific files in the generic family. If no $t sequence is given, +the type suffix is appended to the filename. If no -o output filename is +given, the names of the output files are formed by concatenating the type +suffix to the root of the input filename. +.le +.le +.sh +Directives + + The action of the preprocessor is directed by placing "$xxx" directives +in the text to be processed. The identifiers INDEF and PIXEL are also +known to the preprocessor, and will be replaced by their type specific +equivalents (INDEF --> INDEFS, INDEFI, etc., PIXEL --> short, int, real, etc.) +in the generated text. Comments (#... and /* ... */), quoted strings (".."), +and escaped lines (^%) are passed on unchanged. + +.ls 4 +.ls 20 $/text/ +The text enclosed by the matching slashes is passed through unchanged. +.le +.ls $t +The lowercase value of the current type suffix character (one of [bucsilrdx]). +.le +.ls $T +The uppercase value of the current type suffix character (one of [BUCSILRDX]). +.le +.ls digits$f +Replaced by "digits.0" if the current type is REAL, by "digits.0D0" if the +current type is DOUBLE, by "(digits,digits)" if the type is complex, or by +"digits" for all other datatypes. +.le +.ls $if +Conditional compilation. Two forms of the $if statment are implemented: + +.nf + $if (datatype == <chars>) + $if (datatype != <chars>) + +or + $if (sizeof(<t1>) <relop> sizeof(<t2>)) +.fi + +where <chars>, <t1>, and <t2> are type suffix characters ("silrd", etc.), +and where <relop> is one of the relational operators + + == != <= < >= > + +Nesting is permitted. Conditional statements need not be left justified, +i.e., whitespace may be placed between BOL and a $xx preprocessor directive. +.le +.ls $$if +Replaced by "$if". Not evaluated until the second time the file is +processed. +.le +.ls $else, $$else +Begins a section of code which gets processed if the $if condition was +false. +.le +.ls $endif, $$endif +Terminates a $if or $else construct. +.le +.ls TY_PIXEL +Replaced by TY_INT, TY_REAL, and so on. +.le +.ls SZ_PIXEL +Replaced by SZ_INT, SZ_REAL, and so on. +.le +.ls PIXEL +Replaced by the datatype keyword of the file currently being generated +(int, real, etc.). +.le +.ls XPIXEL +Replaced by the defined type (XCHAR, XINT, ect.). Used in generic C +programs which will be called from the subset preprocessor, and which +must manipulate the subset pp datatypes. +.le +.ls $PIXEL +Replaced by the string "PIXEL" (used to postpone substitution until the +next pass). +.le +.ls INDEF +Replaced by the INDEF parameter for the current datatype (INDEFS, INDEFI, +INDEFL, INDEF, or INDEFX). +.le +.ls $INDEF +Replaced by the string "INDEF". +.le +.le + +.sh +Example + + The following generic operator computes the square root of a vector. +The members of the generic family would be called "asqrs", "asqri", +and so on. + +.ks +.nf + # ASQR -- Compute the square root of a vector (generic) + + procedure asqr$t (a, b, npix) + + PIXEL a[npix], b[npix] + int npix, i + + begin + do i = 1, npix { + if (a[i] < 0$f || a[i] == INDEF) + b[i] = INDEF + else { + $if (datatype != rdx) + b[i] = sqrt(double(a[i])) + $else + b[i] = sqrt(a[i]) + $endif + } + } + end +.fi +.ke + +.sh +Doubly Generic Operators + + The preprocessor can also be used to generate doubly generic operators +(operators which have two type suffixes). A good example is the type +conversion operator ACHTxy, which converts a vector of type X to a vector +of type Y. If there are seven datatypes (csilrdx), this generic family will +consist of 49 members. + +Doubly generic programs are preprocessed once to expand the first suffix, +then each file generated by the first pass is processed to expand the +second suffix. On the UNIX sytstem, this might be done by a command +such as + +.nf + generic acht.x; generic -p dir/ acht[silrd].x + rm acht[silrd].x +.fi + +This would expand "acht" in the current directory (generating 5 files), +then expand each of the "acht$t" files in the subdirectory "dir/", +creating a total of 25 files in the subdirectory. The final command +removes the 5 intermediate files. diff --git a/sys/vops/fftr.f b/sys/vops/fftr.f new file mode 100644 index 00000000..a6885972 --- /dev/null +++ b/sys/vops/fftr.f @@ -0,0 +1,689 @@ +c +c----------------------------------------------------------------------- +c subroutine: ffa +c fast fourier analysis subroutine +c----------------------------------------------------------------------- +c + subroutine ffa (b, nfft, ier) +c +c this subroutine replaces the real vector b(k), (k=1,2,...,n), +c with its finite discrete fourier transform. the dc term is +c returned in location b(1) with b(2) set to 0. thereafter, the +c jth harmonic is returned as a complex number stored as +c b(2*j+1) + i b(2*j+2). note that the n/2 harmonic is returned +c in b(n+1) with b(n+2) set to 0. hence, b must be dimensioned +c to size n+2. +c subroutine is called as ffa (b,n) where n=2**m and b is an +c n term real array. a real-valued, radix 8 algorithm is used +c with in-place reordering and the trig functions are computed as +c needed. +c + dimension b(2) + common /con/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c +c+noao +c iw = i1mach(2) + ier = 0 +c-noao +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + n = 1 + do 10 i=1,31 + m = i + n = n*2 + if (n.eq.nfft) go to 20 + 10 continue +c+noao +c write (iw,9999) +c9999 format (30h nfft not a power of 2 for ffa) +c stop + ier = 1 + return +c-noao + 20 continue + n8pow = m/3 +c +c do a radix 2 or radix 4 iteration first if one is required +c + if (m-n8pow*3-1) 50, 40, 30 + 30 nn = 4 + int = n/nn + call r4tr(int, b(1), b(int+1), b(2*int+1), b(3*int+1)) + go to 60 + 40 nn = 2 + int = n/nn + call r2tr(int, b(1), b(int+1)) + go to 60 + 50 nn = 1 +c +c perform radix 8 iterations +c + 60 if (n8pow) 90, 90, 70 + 70 do 80 it=1,n8pow + nn = nn*8 + int = n/nn + call r8tr(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1), + * b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1), + * b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1), + * b(6*int+1), b(7*int+1)) + 80 continue +c +c perform in-place reordering +c + 90 call ord1(m, b) + call ord2(m, b) + t = b(2) + b(2) = 0. + b(nfft+1) = t + b(nfft+2) = 0. + do 100 i=4,nfft,2 + b(i) = -b(i) + 100 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: ffs +c fast fourier synthesis subroutine +c radix 8-4-2 +c----------------------------------------------------------------------- +c + subroutine ffs (b, nfft, ier) +c +c this subroutine synthesizes the real vector b(k), where +c k=1,2,...,n. the initial fourier coefficients are placed in +c the b array of size n+2. the dc term is in b(1) with +c b(2) equal to 0. +c the jth harmonic is stored as b(2*j+1) + i b(2*j+2). +c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0. +c the subroutine is called as ffs(b,n) where n=2**m and +c b is the n term real array discussed above. +c + dimension b(2) + common /con1/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c +c+noao +c iw = i1mach(2) + ier = 0 +c-noao +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + n = 1 + do 10 i=1,31 + m = i + n = n*2 + if (n.eq.nfft) go to 20 + 10 continue +c+noao +c write (iw,9999) +c9999 format (30h nfft not a power of 2 for ffs) +c stop + ier = 1 + return +c-noao + 20 continue + b(2) = b(nfft+1) + do 30 i=1,nfft + b(i) = b(i)/float(nfft) + 30 continue + do 40 i=4,nfft,2 + b(i) = -b(i) + 40 continue + n8pow = m/3 +c +c reorder the input fourier coefficients +c + call ord2(m, b) + call ord1(m, b) +c + if (n8pow.eq.0) go to 60 +c +c perform the radix 8 iterations +c + nn = n + do 50 it=1,n8pow + int = n/nn + call r8syn(int, nn, b, b(int+1), b(2*int+1), b(3*int+1), + * b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1), + * b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1), + * b(6*int+1), b(7*int+1)) + nn = nn/8 + 50 continue +c +c do a radix 2 or radix 4 iteration if one is required +c + 60 if (m-n8pow*3-1) 90, 80, 70 + 70 int = n/4 + call r4syn(int, b(1), b(int+1), b(2*int+1), b(3*int+1)) + go to 90 + 80 int = n/2 + call r2tr(int, b(1), b(int+1)) + 90 return + end +c +c----------------------------------------------------------------------- +c subroutine: r2tr +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c +c + subroutine r2tr(int, b0, b1) + dimension b0(2), b1(2) + do 10 k=1,int + t = b0(k) + b1(k) + b1(k) = b0(k) - b1(k) + b0(k) = t + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r4tr +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r4tr(int, b0, b1, b2, b3) + dimension b0(2), b1(2), b2(2), b3(2) + do 10 k=1,int + r0 = b0(k) + b2(k) + r1 = b1(k) + b3(k) + b2(k) = b0(k) - b2(k) + b3(k) = b1(k) - b3(k) + b0(k) = r0 + r1 + b1(k) = r0 - r1 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r8tr +c radix 8 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r8tr(int, nn, br0, br1, br2, br3, br4, br5, br6, br7, + * bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7) + dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2), + * br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2), + * bi5(2), bi6(2), bi7(2) + common /con/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c set up counters such that jthet steps through the arguments +c of w, jr steps through starting locations for the real part of the +c intermediate results and ji steps through starting locations +c of the imaginary part of the intermediate results. +c + l(1) = nn/8 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = br0(k) + br4(k) + t1 = br1(k) + br5(k) + t2 = br2(k) + br6(k) + t3 = br3(k) + br7(k) + t4 = br0(k) - br4(k) + t5 = br1(k) - br5(k) + t6 = br2(k) - br6(k) + t7 = br3(k) - br7(k) + br2(k) = t0 - t2 + br3(k) = t1 - t3 + t0 = t0 + t2 + t1 = t1 + t3 + br0(k) = t0 + t1 + br1(k) = t0 - t1 + pr = p7*(t5-t7) + pi = p7*(t5+t7) + br4(k) = t4 + pr + br7(k) = t6 + pi + br6(k) = t4 - pr + br5(k) = pi - t6 + 60 continue + if (nn-8) 120, 120, 70 + 70 k0 = int*8 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + pr = p7*(bi2(k)-bi6(k)) + pi = p7*(bi2(k)+bi6(k)) + tr0 = bi0(k) + pr + ti0 = bi4(k) + pi + tr2 = bi0(k) - pr + ti2 = bi4(k) - pi + pr = p7*(bi3(k)-bi7(k)) + pi = p7*(bi3(k)+bi7(k)) + tr1 = bi1(k) + pr + ti1 = bi5(k) + pi + tr3 = bi1(k) - pr + ti3 = bi5(k) - pi + pr = tr1*c22 - ti1*s22 + pi = ti1*c22 + tr1*s22 + bi0(k) = tr0 + pr + bi6(k) = tr0 - pr + bi7(k) = ti0 + pi + bi1(k) = pi - ti0 + pr = -tr3*s22 - ti3*c22 + pi = tr3*c22 - ti3*s22 + bi2(k) = tr2 + pr + bi4(k) = tr2 - pr + bi5(k) = ti2 + pi + bi3(k) = pi - ti2 + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + int8 = int*8 + j0 = jr*int8 + 1 + k0 = ji*int8 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + tr1 = br1(j)*c1 - bi1(k)*s1 + ti1 = br1(j)*s1 + bi1(k)*c1 + tr2 = br2(j)*c2 - bi2(k)*s2 + ti2 = br2(j)*s2 + bi2(k)*c2 + tr3 = br3(j)*c3 - bi3(k)*s3 + ti3 = br3(j)*s3 + bi3(k)*c3 + tr4 = br4(j)*c4 - bi4(k)*s4 + ti4 = br4(j)*s4 + bi4(k)*c4 + tr5 = br5(j)*c5 - bi5(k)*s5 + ti5 = br5(j)*s5 + bi5(k)*c5 + tr6 = br6(j)*c6 - bi6(k)*s6 + ti6 = br6(j)*s6 + bi6(k)*c6 + tr7 = br7(j)*c7 - bi7(k)*s7 + ti7 = br7(j)*s7 + bi7(k)*c7 +c + t0 = br0(j) + tr4 + t1 = bi0(k) + ti4 + tr4 = br0(j) - tr4 + ti4 = bi0(k) - ti4 + t2 = tr1 + tr5 + t3 = ti1 + ti5 + tr5 = tr1 - tr5 + ti5 = ti1 - ti5 + t4 = tr2 + tr6 + t5 = ti2 + ti6 + tr6 = tr2 - tr6 + ti6 = ti2 - ti6 + t6 = tr3 + tr7 + t7 = ti3 + ti7 + tr7 = tr3 - tr7 + ti7 = ti3 - ti7 +c + tr0 = t0 + t4 + ti0 = t1 + t5 + tr2 = t0 - t4 + ti2 = t1 - t5 + tr1 = t2 + t6 + ti1 = t3 + t7 + tr3 = t2 - t6 + ti3 = t3 - t7 + t0 = tr4 - ti6 + t1 = ti4 + tr6 + t4 = tr4 + ti6 + t5 = ti4 - tr6 + t2 = tr5 - ti7 + t3 = ti5 + tr7 + t6 = tr5 + ti7 + t7 = ti5 - tr7 + br0(j) = tr0 + tr1 + bi7(k) = ti0 + ti1 + bi6(k) = tr0 - tr1 + br1(j) = ti1 - ti0 + br2(j) = tr2 - ti3 + bi5(k) = ti2 + tr3 + bi4(k) = tr2 + ti3 + br3(j) = tr3 - ti2 + pr = p7*(t2-t3) + pi = p7*(t2+t3) + br4(j) = t0 + pr + bi3(k) = t1 + pi + bi2(k) = t0 - pr + br5(j) = pi - t1 + pr = -p7*(t6+t7) + pi = p7*(t6-t7) + br6(j) = t4 + pr + bi1(k) = t5 + pi + bi0(k) = t4 - pr + br7(j) = pi - t5 + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r4syn +c radix 4 synthesis +c----------------------------------------------------------------------- +c + subroutine r4syn(int, b0, b1, b2, b3) + dimension b0(2), b1(2), b2(2), b3(2) + do 10 k=1,int + t0 = b0(k) + b1(k) + t1 = b0(k) - b1(k) + t2 = b2(k) + b2(k) + t3 = b3(k) + b3(k) + b0(k) = t0 + t2 + b2(k) = t0 - t2 + b1(k) = t1 + t3 + b3(k) = t1 - t3 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r8syn +c radix 8 synthesis subroutine +c----------------------------------------------------------------------- +c + subroutine r8syn(int, nn, br0, br1, br2, br3, br4, br5, br6, br7, + * bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7) + dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2), + * br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2), + * bi5(2), bi6(2), bi7(2) + common /con1/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + l(1) = nn/8 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 +c + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = br0(k) + br1(k) + t1 = br0(k) - br1(k) + t2 = br2(k) + br2(k) + t3 = br3(k) + br3(k) + t4 = br4(k) + br6(k) + t6 = br7(k) - br5(k) + t5 = br4(k) - br6(k) + t7 = br7(k) + br5(k) + pr = p7*(t7+t5) + pi = p7*(t7-t5) + tt0 = t0 + t2 + tt1 = t1 + t3 + t2 = t0 - t2 + t3 = t1 - t3 + t4 = t4 + t4 + t5 = pr + pr + t6 = t6 + t6 + t7 = pi + pi + br0(k) = tt0 + t4 + br1(k) = tt1 + t5 + br2(k) = t2 + t6 + br3(k) = t3 + t7 + br4(k) = tt0 - t4 + br5(k) = tt1 - t5 + br6(k) = t2 - t6 + br7(k) = t3 - t7 + 60 continue + if (nn-8) 120, 120, 70 + 70 k0 = int*8 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + t1 = bi0(k) + bi6(k) + t2 = bi7(k) - bi1(k) + t3 = bi0(k) - bi6(k) + t4 = bi7(k) + bi1(k) + pr = t3*c22 + t4*s22 + pi = t4*c22 - t3*s22 + t5 = bi2(k) + bi4(k) + t6 = bi5(k) - bi3(k) + t7 = bi2(k) - bi4(k) + t8 = bi5(k) + bi3(k) + rr = t8*c22 - t7*s22 + ri = -t8*s22 - t7*c22 + bi0(k) = (t1+t5) + (t1+t5) + bi4(k) = (t2+t6) + (t2+t6) + bi1(k) = (pr+rr) + (pr+rr) + bi5(k) = (pi+ri) + (pi+ri) + t5 = t1 - t5 + t6 = t2 - t6 + bi2(k) = p7two*(t6+t5) + bi6(k) = p7two*(t6-t5) + rr = pr - rr + ri = pi - ri + bi3(k) = p7two*(ri+rr) + bi7(k) = p7two*(ri-rr) + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = -sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + int8 = int*8 + j0 = jr*int8 + 1 + k0 = ji*int8 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + tr0 = br0(j) + bi6(k) + ti0 = bi7(k) - br1(j) + tr1 = br0(j) - bi6(k) + ti1 = bi7(k) + br1(j) + tr2 = br2(j) + bi4(k) + ti2 = bi5(k) - br3(j) + tr3 = bi5(k) + br3(j) + ti3 = bi4(k) - br2(j) + tr4 = br4(j) + bi2(k) + ti4 = bi3(k) - br5(j) + t0 = br4(j) - bi2(k) + t1 = bi3(k) + br5(j) + tr5 = p7*(t0+t1) + ti5 = p7*(t1-t0) + tr6 = br6(j) + bi0(k) + ti6 = bi1(k) - br7(j) + t0 = br6(j) - bi0(k) + t1 = bi1(k) + br7(j) + tr7 = -p7*(t0-t1) + ti7 = -p7*(t1+t0) + t0 = tr0 + tr2 + t1 = ti0 + ti2 + t2 = tr1 + tr3 + t3 = ti1 + ti3 + tr2 = tr0 - tr2 + ti2 = ti0 - ti2 + tr3 = tr1 - tr3 + ti3 = ti1 - ti3 + t4 = tr4 + tr6 + t5 = ti4 + ti6 + t6 = tr5 + tr7 + t7 = ti5 + ti7 + ttr6 = ti4 - ti6 + ti6 = tr6 - tr4 + ttr7 = ti5 - ti7 + ti7 = tr7 - tr5 + br0(j) = t0 + t4 + bi0(k) = t1 + t5 + br1(j) = c1*(t2+t6) - s1*(t3+t7) + bi1(k) = c1*(t3+t7) + s1*(t2+t6) + br2(j) = c2*(tr2+ttr6) - s2*(ti2+ti6) + bi2(k) = c2*(ti2+ti6) + s2*(tr2+ttr6) + br3(j) = c3*(tr3+ttr7) - s3*(ti3+ti7) + bi3(k) = c3*(ti3+ti7) + s3*(tr3+ttr7) + br4(j) = c4*(t0-t4) - s4*(t1-t5) + bi4(k) = c4*(t1-t5) + s4*(t0-t4) + br5(j) = c5*(t2-t6) - s5*(t3-t7) + bi5(k) = c5*(t3-t7) + s5*(t2-t6) + br6(j) = c6*(tr2-ttr6) - s6*(ti2-ti6) + bi6(k) = c6*(ti2-ti6) + s6*(tr2-ttr6) + br7(j) = c7*(tr3-ttr7) - s7*(ti3-ti7) + bi7(k) = c7*(ti3-ti7) + s7*(tr3-ttr7) + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: ord1 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ord1(m, b) + dimension b(2) +c + k = 4 + kl = 2 + n = 2**m + do 40 j=4,n,2 + if (k-j) 20, 20, 10 + 10 t = b(j) + b(j) = b(k) + b(k) = t + 20 k = k - 2 + if (k-kl) 30, 30, 40 + 30 k = 2*j + kl = j + 40 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: ord2 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ord2(m, b) + dimension l(15), b(2) + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + n = 2**m + l(1) = n + do 10 k=2,m + l(k) = l(k-1)/2 + 10 continue + do 20 k=m,14 + l(k+1) = 2 + 20 continue + ij = 2 + do 40 j1=2,l1,2 + do 40 j2=j1,l2,l1 + do 40 j3=j2,l3,l2 + do 40 j4=j3,l4,l3 + do 40 j5=j4,l5,l4 + do 40 j6=j5,l6,l5 + do 40 j7=j6,l7,l6 + do 40 j8=j7,l8,l7 + do 40 j9=j8,l9,l8 + do 40 j10=j9,l10,l9 + do 40 j11=j10,l11,l10 + do 40 j12=j11,l12,l11 + do 40 j13=j12,l13,l12 + do 40 j14=j13,l14,l13 + do 40 ji=j14,l15,l14 + if (ij-ji) 30, 40, 40 + 30 t = b(ij-1) + b(ij-1) = b(ji-1) + b(ji-1) = t + t = b(ij) + b(ij) = b(ji) + b(ji) = t + 40 ij = ij + 2 + return + end diff --git a/sys/vops/fftx.f b/sys/vops/fftx.f new file mode 100644 index 00000000..2e8a5620 --- /dev/null +++ b/sys/vops/fftx.f @@ -0,0 +1,277 @@ +c +c----------------------------------------------------------------------- +c subroutine: fft842 +c fast fourier transform for n=2**m +c complex input +c----------------------------------------------------------------------- +c + subroutine fft842 (in, n, x, y, ier) +c +c this program replaces the vector z=x+iy by its finite +c discrete, complex fourier transform if in=0. the inverse transform +c is calculated for in=1. it performs as many base +c 8 iterations as possible and then finishes with a base 4 iteration +c or a base 2 iteration if needed. +c +c the subroutine is called as subroutine fft842 (in,n,x,y). +c the integer n (a power of 2), the n real location array x, and +c the n real location array y must be supplied to the subroutine. +c + dimension x(*), y(*), l(15) + common /con2/ pi2, p7 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c +c iw is a machine dependent write device number +c +c+noao +c iw = i1mach(2) + ier = 0 +c-noao +c + pi2 = 8.*atan(1.) + p7 = 1./sqrt(2.) + do 10 i=1,31 + m = i + nt = 2**i + if (n.eq.nt) go to 20 + 10 continue +c+noao +c write (iw,9999) +c9999 format (35h n is not a power of two for fft842) +c stop + ier = 1 + return +c-noao + 20 n2pow = m + nthpo = n + fn = nthpo + if (in.eq.1) go to 40 + do 30 i=1,nthpo + y(i) = -y(i) + 30 continue + 40 n8pow = n2pow/3 + if (n8pow.eq.0) go to 60 +c +c radix 8 passes,if any. +c + do 50 ipass=1,n8pow + nxtlt = 2**(n2pow-3*ipass) + lengt = 8*nxtlt + call r8tx(nxtlt, nthpo, lengt, x(1), x(nxtlt+1), x(2*nxtlt+1), + * x(3*nxtlt+1), x(4*nxtlt+1), x(5*nxtlt+1), x(6*nxtlt+1), + * x(7*nxtlt+1), y(1), y(nxtlt+1), y(2*nxtlt+1), y(3*nxtlt+1), + * y(4*nxtlt+1), y(5*nxtlt+1), y(6*nxtlt+1), y(7*nxtlt+1)) + 50 continue +c +c is there a four factor left +c + 60 if (n2pow-3*n8pow-1) 90, 70, 80 +c +c go through the base 2 iteration +c +c + 70 call r2tx(nthpo, x(1), x(2), y(1), y(2)) + go to 90 +c +c go through the base 4 iteration +c + 80 call r4tx(nthpo, x(1), x(2), x(3), x(4), y(1), y(2), y(3), y(4)) +c + 90 do 110 j=1,31 + l(j) = 1 + if (j-n2pow) 100, 100, 110 + 100 l(j) = 2**(n2pow+1-j) + 110 continue + ij = 1 + do 130 j1=1,l1 + do 130 j2=j1,l2,l1 + do 130 j3=j2,l3,l2 + do 130 j4=j3,l4,l3 + do 130 j5=j4,l5,l4 + do 130 j6=j5,l6,l5 + do 130 j7=j6,l7,l6 + do 130 j8=j7,l8,l7 + do 130 j9=j8,l9,l8 + do 130 j10=j9,l10,l9 + do 130 j11=j10,l11,l10 + do 130 j12=j11,l12,l11 + do 130 j13=j12,l13,l12 + do 130 j14=j13,l14,l13 + do 130 ji=j14,l15,l14 + if (ij-ji) 120, 130, 130 + 120 r = x(ij) + x(ij) = x(ji) + x(ji) = r + fi = y(ij) + y(ij) = y(ji) + y(ji) = fi + 130 ij = ij + 1 + if (in.eq.1) go to 150 + do 140 i=1,nthpo + y(i) = -y(i) + 140 continue + go to 170 + 150 do 160 i=1,nthpo + x(i) = x(i)/fn + y(i) = y(i)/fn + 160 continue + 170 return + end +c +c----------------------------------------------------------------------- +c subroutine: r2tx +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r2tx(nthpo, cr0, cr1, ci0, ci1) + dimension cr0(2), cr1(2), ci0(2), ci1(2) + do 10 k=1,nthpo,2 + r1 = cr0(k) + cr1(k) + cr1(k) = cr0(k) - cr1(k) + cr0(k) = r1 + fi1 = ci0(k) + ci1(k) + ci1(k) = ci0(k) - ci1(k) + ci0(k) = fi1 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r4tx +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r4tx(nthpo, cr0, cr1, cr2, cr3, ci0, ci1, ci2, ci3) + dimension cr0(2), cr1(2), cr2(2), cr3(2), ci0(2), ci1(2), ci2(2), + * ci3(2) + do 10 k=1,nthpo,4 + r1 = cr0(k) + cr2(k) + r2 = cr0(k) - cr2(k) + r3 = cr1(k) + cr3(k) + r4 = cr1(k) - cr3(k) + fi1 = ci0(k) + ci2(k) + fi2 = ci0(k) - ci2(k) + fi3 = ci1(k) + ci3(k) + fi4 = ci1(k) - ci3(k) + cr0(k) = r1 + r3 + ci0(k) = fi1 + fi3 + cr1(k) = r1 - r3 + ci1(k) = fi1 - fi3 + cr2(k) = r2 - fi4 + ci2(k) = fi2 + r4 + cr3(k) = r2 + fi4 + ci3(k) = fi2 - r4 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r8tx +c radix 8 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r8tx(nxtlt, nthpo, lengt, cr0, cr1, cr2, cr3, cr4, + * cr5, cr6, cr7, ci0, ci1, ci2, ci3, ci4, ci5, ci6, ci7) + dimension cr0(2), cr1(2), cr2(2), cr3(2), cr4(2), cr5(2), cr6(2), + * cr7(2), ci1(2), ci2(2), ci3(2), ci4(2), ci5(2), ci6(2), + * ci7(2), ci0(2) + common /con2/ pi2, p7 +c + scale = pi2/float(lengt) + do 30 j=1,nxtlt + arg = float(j-1)*scale + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + do 20 k=j,nthpo,lengt + ar0 = cr0(k) + cr4(k) + ar1 = cr1(k) + cr5(k) + ar2 = cr2(k) + cr6(k) + ar3 = cr3(k) + cr7(k) + ar4 = cr0(k) - cr4(k) + ar5 = cr1(k) - cr5(k) + ar6 = cr2(k) - cr6(k) + ar7 = cr3(k) - cr7(k) + ai0 = ci0(k) + ci4(k) + ai1 = ci1(k) + ci5(k) + ai2 = ci2(k) + ci6(k) + ai3 = ci3(k) + ci7(k) + ai4 = ci0(k) - ci4(k) + ai5 = ci1(k) - ci5(k) + ai6 = ci2(k) - ci6(k) + ai7 = ci3(k) - ci7(k) + br0 = ar0 + ar2 + br1 = ar1 + ar3 + br2 = ar0 - ar2 + br3 = ar1 - ar3 + br4 = ar4 - ai6 + br5 = ar5 - ai7 + br6 = ar4 + ai6 + br7 = ar5 + ai7 + bi0 = ai0 + ai2 + bi1 = ai1 + ai3 + bi2 = ai0 - ai2 + bi3 = ai1 - ai3 + bi4 = ai4 + ar6 + bi5 = ai5 + ar7 + bi6 = ai4 - ar6 + bi7 = ai5 - ar7 + cr0(k) = br0 + br1 + ci0(k) = bi0 + bi1 + if (j.le.1) go to 10 + cr1(k) = c4*(br0-br1) - s4*(bi0-bi1) + ci1(k) = c4*(bi0-bi1) + s4*(br0-br1) + cr2(k) = c2*(br2-bi3) - s2*(bi2+br3) + ci2(k) = c2*(bi2+br3) + s2*(br2-bi3) + cr3(k) = c6*(br2+bi3) - s6*(bi2-br3) + ci3(k) = c6*(bi2-br3) + s6*(br2+bi3) + tr = p7*(br5-bi5) + ti = p7*(br5+bi5) + cr4(k) = c1*(br4+tr) - s1*(bi4+ti) + ci4(k) = c1*(bi4+ti) + s1*(br4+tr) + cr5(k) = c5*(br4-tr) - s5*(bi4-ti) + ci5(k) = c5*(bi4-ti) + s5*(br4-tr) + tr = -p7*(br7+bi7) + ti = p7*(br7-bi7) + cr6(k) = c3*(br6+tr) - s3*(bi6+ti) + ci6(k) = c3*(bi6+ti) + s3*(br6+tr) + cr7(k) = c7*(br6-tr) - s7*(bi6-ti) + ci7(k) = c7*(bi6-ti) + s7*(br6-tr) + go to 20 + 10 cr1(k) = br0 - br1 + ci1(k) = bi0 - bi1 + cr2(k) = br2 - bi3 + ci2(k) = bi2 + br3 + cr3(k) = br2 + bi3 + ci3(k) = bi2 - br3 + tr = p7*(br5-bi5) + ti = p7*(br5+bi5) + cr4(k) = br4 + tr + ci4(k) = bi4 + ti + cr5(k) = br4 - tr + ci5(k) = bi4 - ti + tr = -p7*(br7+bi7) + ti = p7*(br7-bi7) + cr6(k) = br6 + tr + ci6(k) = bi6 + ti + cr7(k) = br6 - tr + ci7(k) = bi6 - ti + 20 continue + 30 continue + return + end diff --git a/sys/vops/lz/alani.x b/sys/vops/lz/alani.x new file mode 100644 index 00000000..28fb324e --- /dev/null +++ b/sys/vops/lz/alani.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alani (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alanki.x b/sys/vops/lz/alanki.x new file mode 100644 index 00000000..a5523400 --- /dev/null +++ b/sys/vops/lz/alanki.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alanki (a, b, c, npix) + +int a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alankl.x b/sys/vops/lz/alankl.x new file mode 100644 index 00000000..b223303c --- /dev/null +++ b/sys/vops/lz/alankl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alankl (a, b, c, npix) + +long a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alanks.x b/sys/vops/lz/alanks.x new file mode 100644 index 00000000..f63e0371 --- /dev/null +++ b/sys/vops/lz/alanks.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alanks (a, b, c, npix) + +short a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alanl.x b/sys/vops/lz/alanl.x new file mode 100644 index 00000000..b06304bd --- /dev/null +++ b/sys/vops/lz/alanl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alanl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alans.x b/sys/vops/lz/alans.x new file mode 100644 index 00000000..b2ff25c5 --- /dev/null +++ b/sys/vops/lz/alans.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alans (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alimc.x b/sys/vops/lz/alimc.x new file mode 100644 index 00000000..6f05be93 --- /dev/null +++ b/sys/vops/lz/alimc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimc (a, npix, minval, maxval) + +char a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimd.x b/sys/vops/lz/alimd.x new file mode 100644 index 00000000..2e56673d --- /dev/null +++ b/sys/vops/lz/alimd.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimd (a, npix, minval, maxval) + +double a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimi.x b/sys/vops/lz/alimi.x new file mode 100644 index 00000000..0a043976 --- /dev/null +++ b/sys/vops/lz/alimi.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimi (a, npix, minval, maxval) + +int a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/aliml.x b/sys/vops/lz/aliml.x new file mode 100644 index 00000000..abbad1c5 --- /dev/null +++ b/sys/vops/lz/aliml.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure aliml (a, npix, minval, maxval) + +long a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimr.x b/sys/vops/lz/alimr.x new file mode 100644 index 00000000..6845f36c --- /dev/null +++ b/sys/vops/lz/alimr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimr (a, npix, minval, maxval) + +real a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alims.x b/sys/vops/lz/alims.x new file mode 100644 index 00000000..71d5c498 --- /dev/null +++ b/sys/vops/lz/alims.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alims (a, npix, minval, maxval) + +short a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimx.x b/sys/vops/lz/alimx.x new file mode 100644 index 00000000..93a7fe61 --- /dev/null +++ b/sys/vops/lz/alimx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimx (a, npix, minval, maxval) + +complex a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (abs(value) < abs(minval)) + minval = value + else if (abs(value) > abs(maxval)) + maxval = value + } +end diff --git a/sys/vops/lz/allnd.x b/sys/vops/lz/allnd.x new file mode 100644 index 00000000..82ae72bd --- /dev/null +++ b/sys/vops/lz/allnd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnd (a, b, npix, errfcn) + +double a[ARB], b[ARB] +int npix, i +extern errfcn() +double errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0D0) + b[i] = errfcn (a[i]) + else { + b[i] = log (a[i]) + } + } +end diff --git a/sys/vops/lz/allni.x b/sys/vops/lz/allni.x new file mode 100644 index 00000000..9dc1bf4a --- /dev/null +++ b/sys/vops/lz/allni.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allni (a, b, npix, errfcn) + +int a[ARB], b[ARB] +int npix, i +extern errfcn() +int errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + b[i] = log (real (a[i])) + } + } +end diff --git a/sys/vops/lz/allnl.x b/sys/vops/lz/allnl.x new file mode 100644 index 00000000..afc1a62e --- /dev/null +++ b/sys/vops/lz/allnl.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnl (a, b, npix, errfcn) + +long a[ARB], b[ARB] +int npix, i +extern errfcn() +long errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + b[i] = log (double (a[i])) + } + } +end diff --git a/sys/vops/lz/allnr.x b/sys/vops/lz/allnr.x new file mode 100644 index 00000000..469ce448 --- /dev/null +++ b/sys/vops/lz/allnr.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnr (a, b, npix, errfcn) + +real a[ARB], b[ARB] +int npix, i +extern errfcn() +real errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0) + b[i] = errfcn (a[i]) + else { + b[i] = log (a[i]) + } + } +end diff --git a/sys/vops/lz/allns.x b/sys/vops/lz/allns.x new file mode 100644 index 00000000..3d968186 --- /dev/null +++ b/sys/vops/lz/allns.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allns (a, b, npix, errfcn) + +short a[ARB], b[ARB] +int npix, i +extern errfcn() +short errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + b[i] = log (real (a[i])) + } + } +end diff --git a/sys/vops/lz/allnx.x b/sys/vops/lz/allnx.x new file mode 100644 index 00000000..b4527117 --- /dev/null +++ b/sys/vops/lz/allnx.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnx (a, b, npix, errfcn) + +complex a[ARB], b[ARB] +int npix, i +extern errfcn() +complex errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] == (0.0,0.0)) + b[i] = errfcn (a[i]) + else { + b[i] = log (a[i]) + } + } +end diff --git a/sys/vops/lz/alogd.x b/sys/vops/lz/alogd.x new file mode 100644 index 00000000..b5f7b78f --- /dev/null +++ b/sys/vops/lz/alogd.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogd (a, b, npix, errfcn) + +double a[ARB], b[ARB] +int npix, i +extern errfcn() +double errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0D0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (a[i]) + } + } +end diff --git a/sys/vops/lz/alogi.x b/sys/vops/lz/alogi.x new file mode 100644 index 00000000..294289c5 --- /dev/null +++ b/sys/vops/lz/alogi.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogi (a, b, npix, errfcn) + +int a[ARB], b[ARB] +int npix, i +extern errfcn() +int errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (real (a[i])) + } + } +end diff --git a/sys/vops/lz/alogl.x b/sys/vops/lz/alogl.x new file mode 100644 index 00000000..1af0e2f5 --- /dev/null +++ b/sys/vops/lz/alogl.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogl (a, b, npix, errfcn) + +long a[ARB], b[ARB] +int npix, i +extern errfcn() +long errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (double (a[i])) + } + } +end diff --git a/sys/vops/lz/alogr.x b/sys/vops/lz/alogr.x new file mode 100644 index 00000000..049f7cc7 --- /dev/null +++ b/sys/vops/lz/alogr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogr (a, b, npix, errfcn) + +real a[ARB], b[ARB] +int npix, i +extern errfcn() +real errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (a[i]) + } + } +end diff --git a/sys/vops/lz/alogs.x b/sys/vops/lz/alogs.x new file mode 100644 index 00000000..861185a5 --- /dev/null +++ b/sys/vops/lz/alogs.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogs (a, b, npix, errfcn) + +short a[ARB], b[ARB] +int npix, i +extern errfcn() +short errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (real (a[i])) + } + } +end diff --git a/sys/vops/lz/alogx.x b/sys/vops/lz/alogx.x new file mode 100644 index 00000000..adb78cc6 --- /dev/null +++ b/sys/vops/lz/alogx.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogx (a, b, npix, errfcn) + +complex a[ARB], b[ARB] +int npix, i +extern errfcn() +complex errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] == (0.0,0.0)) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (real (a[i])) + } + } +end diff --git a/sys/vops/lz/alori.x b/sys/vops/lz/alori.x new file mode 100644 index 00000000..07fefc59 --- /dev/null +++ b/sys/vops/lz/alori.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alori (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorki.x b/sys/vops/lz/alorki.x new file mode 100644 index 00000000..1fa2089e --- /dev/null +++ b/sys/vops/lz/alorki.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorki (a, b, c, npix) + +int a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorkl.x b/sys/vops/lz/alorkl.x new file mode 100644 index 00000000..eedcb247 --- /dev/null +++ b/sys/vops/lz/alorkl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorkl (a, b, c, npix) + +long a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorks.x b/sys/vops/lz/alorks.x new file mode 100644 index 00000000..a38924c9 --- /dev/null +++ b/sys/vops/lz/alorks.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorks (a, b, c, npix) + +short a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorl.x b/sys/vops/lz/alorl.x new file mode 100644 index 00000000..bd23bcb1 --- /dev/null +++ b/sys/vops/lz/alorl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alors.x b/sys/vops/lz/alors.x new file mode 100644 index 00000000..a87c5915 --- /dev/null +++ b/sys/vops/lz/alors.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alors (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alovc.x b/sys/vops/lz/alovc.x new file mode 100644 index 00000000..39b5ff34 --- /dev/null +++ b/sys/vops/lz/alovc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +char procedure alovc (a, npix) + +char a[ARB] +int npix +char low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovd.x b/sys/vops/lz/alovd.x new file mode 100644 index 00000000..e5de175b --- /dev/null +++ b/sys/vops/lz/alovd.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +double procedure alovd (a, npix) + +double a[ARB] +int npix +double low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovi.x b/sys/vops/lz/alovi.x new file mode 100644 index 00000000..f2045c11 --- /dev/null +++ b/sys/vops/lz/alovi.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +int procedure alovi (a, npix) + +int a[ARB] +int npix +int low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovl.x b/sys/vops/lz/alovl.x new file mode 100644 index 00000000..9fcf4f6d --- /dev/null +++ b/sys/vops/lz/alovl.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +long procedure alovl (a, npix) + +long a[ARB] +int npix +long low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovr.x b/sys/vops/lz/alovr.x new file mode 100644 index 00000000..87e08917 --- /dev/null +++ b/sys/vops/lz/alovr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +real procedure alovr (a, npix) + +real a[ARB] +int npix +real low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovs.x b/sys/vops/lz/alovs.x new file mode 100644 index 00000000..30a83bed --- /dev/null +++ b/sys/vops/lz/alovs.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +short procedure alovs (a, npix) + +short a[ARB] +int npix +short low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovx.x b/sys/vops/lz/alovx.x new file mode 100644 index 00000000..c0d17deb --- /dev/null +++ b/sys/vops/lz/alovx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +complex procedure alovx (a, npix) + +complex a[ARB] +int npix +complex low, pixval +real abs_low +int i + +begin + low = a[1] + abs_low = abs (low) + + do i = 1, npix { + pixval = a[i] + if (abs (pixval) < abs_low) { + low = pixval + abs_low = abs (low) + } + } + + return (low) +end diff --git a/sys/vops/lz/altad.x b/sys/vops/lz/altad.x new file mode 100644 index 00000000..05fca620 --- /dev/null +++ b/sys/vops/lz/altad.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altad (a, b, npix, k1, k2) + +double a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altai.x b/sys/vops/lz/altai.x new file mode 100644 index 00000000..62576263 --- /dev/null +++ b/sys/vops/lz/altai.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altai (a, b, npix, k1, k2) + +int a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altal.x b/sys/vops/lz/altal.x new file mode 100644 index 00000000..d95ca1f4 --- /dev/null +++ b/sys/vops/lz/altal.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altal (a, b, npix, k1, k2) + +long a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altar.x b/sys/vops/lz/altar.x new file mode 100644 index 00000000..031be04d --- /dev/null +++ b/sys/vops/lz/altar.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altar (a, b, npix, k1, k2) + +real a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altas.x b/sys/vops/lz/altas.x new file mode 100644 index 00000000..7b59d86b --- /dev/null +++ b/sys/vops/lz/altas.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altas (a, b, npix, k1, k2) + +short a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altax.x b/sys/vops/lz/altax.x new file mode 100644 index 00000000..7d71e97d --- /dev/null +++ b/sys/vops/lz/altax.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altax (a, b, npix, k1, k2) + +complex a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altmd.x b/sys/vops/lz/altmd.x new file mode 100644 index 00000000..c8a7296b --- /dev/null +++ b/sys/vops/lz/altmd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmd (a, b, npix, k1, k2) + +double a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altmi.x b/sys/vops/lz/altmi.x new file mode 100644 index 00000000..64cb93c4 --- /dev/null +++ b/sys/vops/lz/altmi.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmi (a, b, npix, k1, k2) + +int a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altml.x b/sys/vops/lz/altml.x new file mode 100644 index 00000000..a9727472 --- /dev/null +++ b/sys/vops/lz/altml.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altml (a, b, npix, k1, k2) + +long a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altmr.x b/sys/vops/lz/altmr.x new file mode 100644 index 00000000..a088b75d --- /dev/null +++ b/sys/vops/lz/altmr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmr (a, b, npix, k1, k2) + +real a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altms.x b/sys/vops/lz/altms.x new file mode 100644 index 00000000..292db9dc --- /dev/null +++ b/sys/vops/lz/altms.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altms (a, b, npix, k1, k2) + +short a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altmx.x b/sys/vops/lz/altmx.x new file mode 100644 index 00000000..fca0e274 --- /dev/null +++ b/sys/vops/lz/altmx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmx (a, b, npix, k1, k2) + +complex a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altrd.x b/sys/vops/lz/altrd.x new file mode 100644 index 00000000..57e877b0 --- /dev/null +++ b/sys/vops/lz/altrd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrd (a, b, npix, k1, k2, k3) + +double a[ARB], b[ARB] +double k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altri.x b/sys/vops/lz/altri.x new file mode 100644 index 00000000..5ef70e85 --- /dev/null +++ b/sys/vops/lz/altri.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altri (a, b, npix, k1, k2, k3) + +int a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrl.x b/sys/vops/lz/altrl.x new file mode 100644 index 00000000..7c3d48b8 --- /dev/null +++ b/sys/vops/lz/altrl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrl (a, b, npix, k1, k2, k3) + +long a[ARB], b[ARB] +double k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrr.x b/sys/vops/lz/altrr.x new file mode 100644 index 00000000..f78522f5 --- /dev/null +++ b/sys/vops/lz/altrr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrr (a, b, npix, k1, k2, k3) + +real a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrs.x b/sys/vops/lz/altrs.x new file mode 100644 index 00000000..50458a82 --- /dev/null +++ b/sys/vops/lz/altrs.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrs (a, b, npix, k1, k2, k3) + +short a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrx.x b/sys/vops/lz/altrx.x new file mode 100644 index 00000000..d23ad236 --- /dev/null +++ b/sys/vops/lz/altrx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrx (a, b, npix, k1, k2, k3) + +complex a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/aluid.x b/sys/vops/lz/aluid.x new file mode 100644 index 00000000..d529ba77 --- /dev/null +++ b/sys/vops/lz/aluid.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluid (a, b, x, npix) + +double a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluii.x b/sys/vops/lz/aluii.x new file mode 100644 index 00000000..67d63575 --- /dev/null +++ b/sys/vops/lz/aluii.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluii (a, b, x, npix) + +int a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluil.x b/sys/vops/lz/aluil.x new file mode 100644 index 00000000..177fb4e6 --- /dev/null +++ b/sys/vops/lz/aluil.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluil (a, b, x, npix) + +long a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluir.x b/sys/vops/lz/aluir.x new file mode 100644 index 00000000..33ef1e4b --- /dev/null +++ b/sys/vops/lz/aluir.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluir (a, b, x, npix) + +real a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluis.x b/sys/vops/lz/aluis.x new file mode 100644 index 00000000..d64dfa1a --- /dev/null +++ b/sys/vops/lz/aluis.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluis (a, b, x, npix) + +short a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/alutc.x b/sys/vops/lz/alutc.x new file mode 100644 index 00000000..06d753fe --- /dev/null +++ b/sys/vops/lz/alutc.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutc (a, b, npix, lut) + +char a[ARB] + +char b[ARB] # output data array +char lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/alutd.x b/sys/vops/lz/alutd.x new file mode 100644 index 00000000..d1e22aea --- /dev/null +++ b/sys/vops/lz/alutd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutd (a, b, npix, lut) + +int a[ARB] # input array of indices + +double b[ARB] # output data array +double lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/aluti.x b/sys/vops/lz/aluti.x new file mode 100644 index 00000000..ba3099b3 --- /dev/null +++ b/sys/vops/lz/aluti.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure aluti (a, b, npix, lut) + +int a[ARB] + +int b[ARB] # output data array +int lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/alutl.x b/sys/vops/lz/alutl.x new file mode 100644 index 00000000..ccc95ab5 --- /dev/null +++ b/sys/vops/lz/alutl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutl (a, b, npix, lut) + +long a[ARB] + +long b[ARB] # output data array +long lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/alutr.x b/sys/vops/lz/alutr.x new file mode 100644 index 00000000..a72cc11f --- /dev/null +++ b/sys/vops/lz/alutr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutr (a, b, npix, lut) + +int a[ARB] # input array of indices + +real b[ARB] # output data array +real lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/aluts.x b/sys/vops/lz/aluts.x new file mode 100644 index 00000000..8af08735 --- /dev/null +++ b/sys/vops/lz/aluts.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure aluts (a, b, npix, lut) + +short a[ARB] + +short b[ARB] # output data array +short lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/amagd.x b/sys/vops/lz/amagd.x new file mode 100644 index 00000000..d4238cfd --- /dev/null +++ b/sys/vops/lz/amagd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (double(a[i] ** 2) + double(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagi.x b/sys/vops/lz/amagi.x new file mode 100644 index 00000000..9bddef17 --- /dev/null +++ b/sys/vops/lz/amagi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagl.x b/sys/vops/lz/amagl.x new file mode 100644 index 00000000..31fd69a0 --- /dev/null +++ b/sys/vops/lz/amagl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (double(a[i] ** 2) + double(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagr.x b/sys/vops/lz/amagr.x new file mode 100644 index 00000000..2db3c085 --- /dev/null +++ b/sys/vops/lz/amagr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) +end diff --git a/sys/vops/lz/amags.x b/sys/vops/lz/amags.x new file mode 100644 index 00000000..7f86bc75 --- /dev/null +++ b/sys/vops/lz/amags.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amags (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagx.x b/sys/vops/lz/amagx.x new file mode 100644 index 00000000..2319394d --- /dev/null +++ b/sys/vops/lz/amagx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (a[i] ** 2 + b[i] ** 2) +end diff --git a/sys/vops/lz/amapd.x b/sys/vops/lz/amapd.x new file mode 100644 index 00000000..8f766793 --- /dev/null +++ b/sys/vops/lz/amapd.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapd (a, b, npix, a1, a2, b1, b2) + +double a[ARB], b[ARB] +double a1, a2, b1, b2 + +double minout, maxout, aoff, boff, pixval + +double scalar + +int npix, i + +begin + scalar = (double (b2) - double (b1)) / (double (a2) - double (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amapi.x b/sys/vops/lz/amapi.x new file mode 100644 index 00000000..d559a130 --- /dev/null +++ b/sys/vops/lz/amapi.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapi (a, b, npix, a1, a2, b1, b2) + +int a[ARB], b[ARB] +int a1, a2, b1, b2 + +long minout, maxout, aoff, boff, pixval + +real scalar + +int npix, i + +begin + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amapl.x b/sys/vops/lz/amapl.x new file mode 100644 index 00000000..c9d350bd --- /dev/null +++ b/sys/vops/lz/amapl.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapl (a, b, npix, a1, a2, b1, b2) + +long a[ARB], b[ARB] +long a1, a2, b1, b2 + +long minout, maxout, aoff, boff, pixval + +double scalar + +int npix, i + +begin + scalar = (double (b2) - double (b1)) / (double (a2) - double (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amapr.x b/sys/vops/lz/amapr.x new file mode 100644 index 00000000..d23c44b6 --- /dev/null +++ b/sys/vops/lz/amapr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapr (a, b, npix, a1, a2, b1, b2) + +real a[ARB], b[ARB] +real a1, a2, b1, b2 + +real minout, maxout, aoff, boff, pixval + +real scalar + +int npix, i + +begin + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amaps.x b/sys/vops/lz/amaps.x new file mode 100644 index 00000000..fd3b8fe0 --- /dev/null +++ b/sys/vops/lz/amaps.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amaps (a, b, npix, a1, a2, b1, b2) + +short a[ARB], b[ARB] +short a1, a2, b1, b2 + +long minout, maxout, aoff, boff, pixval + +real scalar + +int npix, i + +begin + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amaxc.x b/sys/vops/lz/amaxc.x new file mode 100644 index 00000000..89c5808b --- /dev/null +++ b/sys/vops/lz/amaxc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxc (a, b, c, npix) + +char a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxd.x b/sys/vops/lz/amaxd.x new file mode 100644 index 00000000..0cd8253b --- /dev/null +++ b/sys/vops/lz/amaxd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxi.x b/sys/vops/lz/amaxi.x new file mode 100644 index 00000000..0b2f4330 --- /dev/null +++ b/sys/vops/lz/amaxi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxkc.x b/sys/vops/lz/amaxkc.x new file mode 100644 index 00000000..1b5d250b --- /dev/null +++ b/sys/vops/lz/amaxkc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkc (a, b, c, npix) + +char a[ARB] +char b +char c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkd.x b/sys/vops/lz/amaxkd.x new file mode 100644 index 00000000..afe6e45e --- /dev/null +++ b/sys/vops/lz/amaxkd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxki.x b/sys/vops/lz/amaxki.x new file mode 100644 index 00000000..6c74ab6e --- /dev/null +++ b/sys/vops/lz/amaxki.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkl.x b/sys/vops/lz/amaxkl.x new file mode 100644 index 00000000..bfede4ea --- /dev/null +++ b/sys/vops/lz/amaxkl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkr.x b/sys/vops/lz/amaxkr.x new file mode 100644 index 00000000..766c12e5 --- /dev/null +++ b/sys/vops/lz/amaxkr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxks.x b/sys/vops/lz/amaxks.x new file mode 100644 index 00000000..31aeb0b0 --- /dev/null +++ b/sys/vops/lz/amaxks.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkx.x b/sys/vops/lz/amaxkx.x new file mode 100644 index 00000000..9c3212eb --- /dev/null +++ b/sys/vops/lz/amaxkx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i +real abs_b + +begin + abs_b = abs (b) + + do i = 1, npix + if (abs(a[i]) >= abs_b) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/amaxl.x b/sys/vops/lz/amaxl.x new file mode 100644 index 00000000..5f12ba92 --- /dev/null +++ b/sys/vops/lz/amaxl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxr.x b/sys/vops/lz/amaxr.x new file mode 100644 index 00000000..c6789d5f --- /dev/null +++ b/sys/vops/lz/amaxr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxs.x b/sys/vops/lz/amaxs.x new file mode 100644 index 00000000..83adb3dc --- /dev/null +++ b/sys/vops/lz/amaxs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxs (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxx.x b/sys/vops/lz/amaxx.x new file mode 100644 index 00000000..7f9b58bb --- /dev/null +++ b/sys/vops/lz/amaxx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + if (abs(a[i]) >= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/amed3c.x b/sys/vops/lz/amed3c.x new file mode 100644 index 00000000..f40f6dc1 --- /dev/null +++ b/sys/vops/lz/amed3c.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3c (a, b, c, m, npix) + +char a[ARB], b[ARB], c[ARB] # input vectors +char m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3d.x b/sys/vops/lz/amed3d.x new file mode 100644 index 00000000..74fba3c4 --- /dev/null +++ b/sys/vops/lz/amed3d.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3d (a, b, c, m, npix) + +double a[ARB], b[ARB], c[ARB] # input vectors +double m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3i.x b/sys/vops/lz/amed3i.x new file mode 100644 index 00000000..2be5fb15 --- /dev/null +++ b/sys/vops/lz/amed3i.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3i (a, b, c, m, npix) + +int a[ARB], b[ARB], c[ARB] # input vectors +int m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3l.x b/sys/vops/lz/amed3l.x new file mode 100644 index 00000000..480d3b05 --- /dev/null +++ b/sys/vops/lz/amed3l.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3l (a, b, c, m, npix) + +long a[ARB], b[ARB], c[ARB] # input vectors +long m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3r.x b/sys/vops/lz/amed3r.x new file mode 100644 index 00000000..276efd03 --- /dev/null +++ b/sys/vops/lz/amed3r.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3r (a, b, c, m, npix) + +real a[ARB], b[ARB], c[ARB] # input vectors +real m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3s.x b/sys/vops/lz/amed3s.x new file mode 100644 index 00000000..8de5ff45 --- /dev/null +++ b/sys/vops/lz/amed3s.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3s (a, b, c, m, npix) + +short a[ARB], b[ARB], c[ARB] # input vectors +short m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed4c.x b/sys/vops/lz/amed4c.x new file mode 100644 index 00000000..34228107 --- /dev/null +++ b/sys/vops/lz/amed4c.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4c (a, b, c, d, m, npix) + +char a[ARB], b[ARB] # input vectors +char c[ARB], d[ARB] # input vectors +char m[ARB] # output vector (median) +int npix + +int i +char temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4d.x b/sys/vops/lz/amed4d.x new file mode 100644 index 00000000..aec95abd --- /dev/null +++ b/sys/vops/lz/amed4d.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4d (a, b, c, d, m, npix) + +double a[ARB], b[ARB] # input vectors +double c[ARB], d[ARB] # input vectors +double m[ARB] # output vector (median) +int npix + +int i +double temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4i.x b/sys/vops/lz/amed4i.x new file mode 100644 index 00000000..f39d01b6 --- /dev/null +++ b/sys/vops/lz/amed4i.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4i (a, b, c, d, m, npix) + +int a[ARB], b[ARB] # input vectors +int c[ARB], d[ARB] # input vectors +int m[ARB] # output vector (median) +int npix + +int i +int temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4l.x b/sys/vops/lz/amed4l.x new file mode 100644 index 00000000..367124ef --- /dev/null +++ b/sys/vops/lz/amed4l.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4l (a, b, c, d, m, npix) + +long a[ARB], b[ARB] # input vectors +long c[ARB], d[ARB] # input vectors +long m[ARB] # output vector (median) +int npix + +int i +long temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4r.x b/sys/vops/lz/amed4r.x new file mode 100644 index 00000000..386ca7a5 --- /dev/null +++ b/sys/vops/lz/amed4r.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4r (a, b, c, d, m, npix) + +real a[ARB], b[ARB] # input vectors +real c[ARB], d[ARB] # input vectors +real m[ARB] # output vector (median) +int npix + +int i +real temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4s.x b/sys/vops/lz/amed4s.x new file mode 100644 index 00000000..3ed8fe1d --- /dev/null +++ b/sys/vops/lz/amed4s.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4s (a, b, c, d, m, npix) + +short a[ARB], b[ARB] # input vectors +short c[ARB], d[ARB] # input vectors +short m[ARB] # output vector (median) +int npix + +int i +short temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed5c.x b/sys/vops/lz/amed5c.x new file mode 100644 index 00000000..8302e080 --- /dev/null +++ b/sys/vops/lz/amed5c.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5c (a, b, c, d, e, m, npix) + +char a[ARB], b[ARB] # input vectors +char c[ARB], d[ARB], e[ARB] # input vectors +char m[ARB] # output vector (median) +int npix + +int i +char temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5d.x b/sys/vops/lz/amed5d.x new file mode 100644 index 00000000..a813f82f --- /dev/null +++ b/sys/vops/lz/amed5d.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5d (a, b, c, d, e, m, npix) + +double a[ARB], b[ARB] # input vectors +double c[ARB], d[ARB], e[ARB] # input vectors +double m[ARB] # output vector (median) +int npix + +int i +double temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5i.x b/sys/vops/lz/amed5i.x new file mode 100644 index 00000000..9738be6a --- /dev/null +++ b/sys/vops/lz/amed5i.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5i (a, b, c, d, e, m, npix) + +int a[ARB], b[ARB] # input vectors +int c[ARB], d[ARB], e[ARB] # input vectors +int m[ARB] # output vector (median) +int npix + +int i +int temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5l.x b/sys/vops/lz/amed5l.x new file mode 100644 index 00000000..33bd869d --- /dev/null +++ b/sys/vops/lz/amed5l.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5l (a, b, c, d, e, m, npix) + +long a[ARB], b[ARB] # input vectors +long c[ARB], d[ARB], e[ARB] # input vectors +long m[ARB] # output vector (median) +int npix + +int i +long temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5r.x b/sys/vops/lz/amed5r.x new file mode 100644 index 00000000..9bce0597 --- /dev/null +++ b/sys/vops/lz/amed5r.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5r (a, b, c, d, e, m, npix) + +real a[ARB], b[ARB] # input vectors +real c[ARB], d[ARB], e[ARB] # input vectors +real m[ARB] # output vector (median) +int npix + +int i +real temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5s.x b/sys/vops/lz/amed5s.x new file mode 100644 index 00000000..31f34696 --- /dev/null +++ b/sys/vops/lz/amed5s.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5s (a, b, c, d, e, m, npix) + +short a[ARB], b[ARB] # input vectors +short c[ARB], d[ARB], e[ARB] # input vectors +short m[ARB] # output vector (median) +int npix + +int i +short temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amedc.x b/sys/vops/lz/amedc.x new file mode 100644 index 00000000..09dcf10c --- /dev/null +++ b/sys/vops/lz/amedc.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +char procedure amedc (a, npix) + +char a[ARB] +int npix + +pointer sp, aa +char median +char asokc() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_CHAR) + call amovc (a, Memc[aa], npix) + median = asokc (Memc[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedd.x b/sys/vops/lz/amedd.x new file mode 100644 index 00000000..c3fbc3aa --- /dev/null +++ b/sys/vops/lz/amedd.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +double procedure amedd (a, npix) + +double a[ARB] +int npix + +pointer sp, aa +double median +double asokd() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_DOUBLE) + call amovd (a, Memd[aa], npix) + median = asokd (Memd[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedi.x b/sys/vops/lz/amedi.x new file mode 100644 index 00000000..69c1ce77 --- /dev/null +++ b/sys/vops/lz/amedi.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +int procedure amedi (a, npix) + +int a[ARB] +int npix + +pointer sp, aa +int median +int asoki() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_INT) + call amovi (a, Memi[aa], npix) + median = asoki (Memi[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedl.x b/sys/vops/lz/amedl.x new file mode 100644 index 00000000..8a993fd2 --- /dev/null +++ b/sys/vops/lz/amedl.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +long procedure amedl (a, npix) + +long a[ARB] +int npix + +pointer sp, aa +long median +long asokl() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_LONG) + call amovl (a, Meml[aa], npix) + median = asokl (Meml[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedr.x b/sys/vops/lz/amedr.x new file mode 100644 index 00000000..e459b22a --- /dev/null +++ b/sys/vops/lz/amedr.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +real procedure amedr (a, npix) + +real a[ARB] +int npix + +pointer sp, aa +real median +real asokr() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_REAL) + call amovr (a, Memr[aa], npix) + median = asokr (Memr[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/ameds.x b/sys/vops/lz/ameds.x new file mode 100644 index 00000000..5d4d28db --- /dev/null +++ b/sys/vops/lz/ameds.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +short procedure ameds (a, npix) + +short a[ARB] +int npix + +pointer sp, aa +short median +short asoks() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_SHORT) + call amovs (a, Mems[aa], npix) + median = asoks (Mems[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedx.x b/sys/vops/lz/amedx.x new file mode 100644 index 00000000..ca2b75dc --- /dev/null +++ b/sys/vops/lz/amedx.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +complex procedure amedx (a, npix) + +complex a[ARB] +int npix + +pointer sp, aa +complex median +complex asokx() # select the Kth smallest element from A +real a1, a2, a3 + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + a1 = abs (a[1]) + a2 = abs (a[2]) + a3 = abs (a[3]) + if (a1 < a2) { + if (a2 < a3) + return (a[2]) + else if (a1 < a3) + return (a[3]) + else + return (a[1]) + } else { + if (a2 > a3) + return (a[2]) + else if (a1 < a3) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_COMPLEX) + call amovx (a, Memx[aa], npix) + median = asokx (Memx[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amgsd.x b/sys/vops/lz/amgsd.x new file mode 100644 index 00000000..36efe58e --- /dev/null +++ b/sys/vops/lz/amgsd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsi.x b/sys/vops/lz/amgsi.x new file mode 100644 index 00000000..e45a8c70 --- /dev/null +++ b/sys/vops/lz/amgsi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsl.x b/sys/vops/lz/amgsl.x new file mode 100644 index 00000000..6ae850e9 --- /dev/null +++ b/sys/vops/lz/amgsl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsr.x b/sys/vops/lz/amgsr.x new file mode 100644 index 00000000..fbfbb880 --- /dev/null +++ b/sys/vops/lz/amgsr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgss.x b/sys/vops/lz/amgss.x new file mode 100644 index 00000000..592d520c --- /dev/null +++ b/sys/vops/lz/amgss.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgss (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsx.x b/sys/vops/lz/amgsx.x new file mode 100644 index 00000000..c40834f4 --- /dev/null +++ b/sys/vops/lz/amgsx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/aminc.x b/sys/vops/lz/aminc.x new file mode 100644 index 00000000..a319819e --- /dev/null +++ b/sys/vops/lz/aminc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminc (a, b, c, npix) + +char a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/amind.x b/sys/vops/lz/amind.x new file mode 100644 index 00000000..e1574051 --- /dev/null +++ b/sys/vops/lz/amind.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amind (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/amini.x b/sys/vops/lz/amini.x new file mode 100644 index 00000000..c7a76820 --- /dev/null +++ b/sys/vops/lz/amini.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amini (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/aminkc.x b/sys/vops/lz/aminkc.x new file mode 100644 index 00000000..a9b91e0e --- /dev/null +++ b/sys/vops/lz/aminkc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkc (a, b, c, npix) + +char a[ARB] +char b +char c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkd.x b/sys/vops/lz/aminkd.x new file mode 100644 index 00000000..6b8a0506 --- /dev/null +++ b/sys/vops/lz/aminkd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminki.x b/sys/vops/lz/aminki.x new file mode 100644 index 00000000..b2793c71 --- /dev/null +++ b/sys/vops/lz/aminki.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkl.x b/sys/vops/lz/aminkl.x new file mode 100644 index 00000000..530b326f --- /dev/null +++ b/sys/vops/lz/aminkl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkr.x b/sys/vops/lz/aminkr.x new file mode 100644 index 00000000..76000fb7 --- /dev/null +++ b/sys/vops/lz/aminkr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminks.x b/sys/vops/lz/aminks.x new file mode 100644 index 00000000..28d1b358 --- /dev/null +++ b/sys/vops/lz/aminks.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkx.x b/sys/vops/lz/aminkx.x new file mode 100644 index 00000000..5f0f852d --- /dev/null +++ b/sys/vops/lz/aminkx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i +real abs_b + +begin + abs_b = abs (b) + + do i = 1, npix + if (abs(a[i]) <= abs_b) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aminl.x b/sys/vops/lz/aminl.x new file mode 100644 index 00000000..d4ae3c7e --- /dev/null +++ b/sys/vops/lz/aminl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/aminr.x b/sys/vops/lz/aminr.x new file mode 100644 index 00000000..1fafcb35 --- /dev/null +++ b/sys/vops/lz/aminr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/amins.x b/sys/vops/lz/amins.x new file mode 100644 index 00000000..5d89f139 --- /dev/null +++ b/sys/vops/lz/amins.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amins (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/aminx.x b/sys/vops/lz/aminx.x new file mode 100644 index 00000000..591b23e4 --- /dev/null +++ b/sys/vops/lz/aminx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + if (abs(a[i]) <= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/amodd.x b/sys/vops/lz/amodd.x new file mode 100644 index 00000000..fce124b6 --- /dev/null +++ b/sys/vops/lz/amodd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amodi.x b/sys/vops/lz/amodi.x new file mode 100644 index 00000000..f1f5a584 --- /dev/null +++ b/sys/vops/lz/amodi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amodkd.x b/sys/vops/lz/amodkd.x new file mode 100644 index 00000000..24db964d --- /dev/null +++ b/sys/vops/lz/amodkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodki.x b/sys/vops/lz/amodki.x new file mode 100644 index 00000000..d2b71438 --- /dev/null +++ b/sys/vops/lz/amodki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodkl.x b/sys/vops/lz/amodkl.x new file mode 100644 index 00000000..ef9ec8b3 --- /dev/null +++ b/sys/vops/lz/amodkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodkr.x b/sys/vops/lz/amodkr.x new file mode 100644 index 00000000..9aa1bd49 --- /dev/null +++ b/sys/vops/lz/amodkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodks.x b/sys/vops/lz/amodks.x new file mode 100644 index 00000000..be5b719c --- /dev/null +++ b/sys/vops/lz/amodks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodl.x b/sys/vops/lz/amodl.x new file mode 100644 index 00000000..5dd47d53 --- /dev/null +++ b/sys/vops/lz/amodl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amodr.x b/sys/vops/lz/amodr.x new file mode 100644 index 00000000..772a1e9c --- /dev/null +++ b/sys/vops/lz/amodr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amods.x b/sys/vops/lz/amods.x new file mode 100644 index 00000000..490d8ec5 --- /dev/null +++ b/sys/vops/lz/amods.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amods (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amovc.x b/sys/vops/lz/amovc.x new file mode 100644 index 00000000..096d1444 --- /dev/null +++ b/sys/vops/lz/amovc.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovc (a, b, npix) + +char a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovd.x b/sys/vops/lz/amovd.x new file mode 100644 index 00000000..3924f141 --- /dev/null +++ b/sys/vops/lz/amovd.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovd (a, b, npix) + +double a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovi.x b/sys/vops/lz/amovi.x new file mode 100644 index 00000000..e97794c7 --- /dev/null +++ b/sys/vops/lz/amovi.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovkc.x b/sys/vops/lz/amovkc.x new file mode 100644 index 00000000..9be3a496 --- /dev/null +++ b/sys/vops/lz/amovkc.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkc (a, b, npix) + +char a +char b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkd.x b/sys/vops/lz/amovkd.x new file mode 100644 index 00000000..4d8eaecd --- /dev/null +++ b/sys/vops/lz/amovkd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkd (a, b, npix) + +double a +double b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovki.x b/sys/vops/lz/amovki.x new file mode 100644 index 00000000..67556a23 --- /dev/null +++ b/sys/vops/lz/amovki.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovki (a, b, npix) + +int a +int b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkl.x b/sys/vops/lz/amovkl.x new file mode 100644 index 00000000..62c96668 --- /dev/null +++ b/sys/vops/lz/amovkl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkl (a, b, npix) + +long a +long b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkr.x b/sys/vops/lz/amovkr.x new file mode 100644 index 00000000..feb34a5c --- /dev/null +++ b/sys/vops/lz/amovkr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkr (a, b, npix) + +real a +real b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovks.x b/sys/vops/lz/amovks.x new file mode 100644 index 00000000..3beff9af --- /dev/null +++ b/sys/vops/lz/amovks.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovks (a, b, npix) + +short a +short b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkx.x b/sys/vops/lz/amovkx.x new file mode 100644 index 00000000..acf90c91 --- /dev/null +++ b/sys/vops/lz/amovkx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkx (a, b, npix) + +complex a +complex b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovl.x b/sys/vops/lz/amovl.x new file mode 100644 index 00000000..4cec6bbd --- /dev/null +++ b/sys/vops/lz/amovl.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovr.x b/sys/vops/lz/amovr.x new file mode 100644 index 00000000..9d6aa8cb --- /dev/null +++ b/sys/vops/lz/amovr.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovr (a, b, npix) + +real a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovs.x b/sys/vops/lz/amovs.x new file mode 100644 index 00000000..9feaf94a --- /dev/null +++ b/sys/vops/lz/amovs.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovs (a, b, npix) + +short a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovx.x b/sys/vops/lz/amovx.x new file mode 100644 index 00000000..04d4fdf2 --- /dev/null +++ b/sys/vops/lz/amovx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovx (a, b, npix) + +complex a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amuld.x b/sys/vops/lz/amuld.x new file mode 100644 index 00000000..b9a5c13b --- /dev/null +++ b/sys/vops/lz/amuld.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amuld (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amuli.x b/sys/vops/lz/amuli.x new file mode 100644 index 00000000..bf2ff538 --- /dev/null +++ b/sys/vops/lz/amuli.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amuli (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amulkd.x b/sys/vops/lz/amulkd.x new file mode 100644 index 00000000..69f28a9a --- /dev/null +++ b/sys/vops/lz/amulkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulki.x b/sys/vops/lz/amulki.x new file mode 100644 index 00000000..773a9a12 --- /dev/null +++ b/sys/vops/lz/amulki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulkl.x b/sys/vops/lz/amulkl.x new file mode 100644 index 00000000..69cef4c0 --- /dev/null +++ b/sys/vops/lz/amulkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulkr.x b/sys/vops/lz/amulkr.x new file mode 100644 index 00000000..71cac10c --- /dev/null +++ b/sys/vops/lz/amulkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulks.x b/sys/vops/lz/amulks.x new file mode 100644 index 00000000..28f6d4ec --- /dev/null +++ b/sys/vops/lz/amulks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulkx.x b/sys/vops/lz/amulkx.x new file mode 100644 index 00000000..c3fe3a36 --- /dev/null +++ b/sys/vops/lz/amulkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amull.x b/sys/vops/lz/amull.x new file mode 100644 index 00000000..bb913fe2 --- /dev/null +++ b/sys/vops/lz/amull.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amull (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amulr.x b/sys/vops/lz/amulr.x new file mode 100644 index 00000000..fe7b204b --- /dev/null +++ b/sys/vops/lz/amulr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amulr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amuls.x b/sys/vops/lz/amuls.x new file mode 100644 index 00000000..ceb5854e --- /dev/null +++ b/sys/vops/lz/amuls.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amuls (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amulx.x b/sys/vops/lz/amulx.x new file mode 100644 index 00000000..1b9aa3dc --- /dev/null +++ b/sys/vops/lz/amulx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amulx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/anegd.x b/sys/vops/lz/anegd.x new file mode 100644 index 00000000..d681464e --- /dev/null +++ b/sys/vops/lz/anegd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegd (a, b, npix) + +double a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegi.x b/sys/vops/lz/anegi.x new file mode 100644 index 00000000..d1221376 --- /dev/null +++ b/sys/vops/lz/anegi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegl.x b/sys/vops/lz/anegl.x new file mode 100644 index 00000000..e3ab64f4 --- /dev/null +++ b/sys/vops/lz/anegl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegr.x b/sys/vops/lz/anegr.x new file mode 100644 index 00000000..449da1b0 --- /dev/null +++ b/sys/vops/lz/anegr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegr (a, b, npix) + +real a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegs.x b/sys/vops/lz/anegs.x new file mode 100644 index 00000000..7b8f320e --- /dev/null +++ b/sys/vops/lz/anegs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegs (a, b, npix) + +short a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegx.x b/sys/vops/lz/anegx.x new file mode 100644 index 00000000..8f958084 --- /dev/null +++ b/sys/vops/lz/anegx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegx (a, b, npix) + +complex a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anoti.x b/sys/vops/lz/anoti.x new file mode 100644 index 00000000..867a8c92 --- /dev/null +++ b/sys/vops/lz/anoti.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anoti (a, b, npix) + +int a[ARB], b[ARB] +int npix, i +int not() + +begin + do i = 1, npix { + b[i] = not (a[i]) + } +end diff --git a/sys/vops/lz/anotl.x b/sys/vops/lz/anotl.x new file mode 100644 index 00000000..3ecb0fce --- /dev/null +++ b/sys/vops/lz/anotl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anotl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i +long notl() + +begin + do i = 1, npix { + b[i] = notl (a[i]) + } +end diff --git a/sys/vops/lz/anots.x b/sys/vops/lz/anots.x new file mode 100644 index 00000000..4c952636 --- /dev/null +++ b/sys/vops/lz/anots.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anots (a, b, npix) + +short a[ARB], b[ARB] +int npix, i +short nots() + +begin + do i = 1, npix { + b[i] = nots (a[i]) + } +end diff --git a/sys/vops/lz/apkxd.x b/sys/vops/lz/apkxd.x new file mode 100644 index 00000000..7c489491 --- /dev/null +++ b/sys/vops/lz/apkxd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxd (a, b, c, npix) + +double a[ARB] # real component +double b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxi.x b/sys/vops/lz/apkxi.x new file mode 100644 index 00000000..c03a0883 --- /dev/null +++ b/sys/vops/lz/apkxi.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxi (a, b, c, npix) + +int a[ARB] # real component +int b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxl.x b/sys/vops/lz/apkxl.x new file mode 100644 index 00000000..5af1f9e0 --- /dev/null +++ b/sys/vops/lz/apkxl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxl (a, b, c, npix) + +long a[ARB] # real component +long b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxr.x b/sys/vops/lz/apkxr.x new file mode 100644 index 00000000..aba0261a --- /dev/null +++ b/sys/vops/lz/apkxr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxr (a, b, c, npix) + +real a[ARB] # real component +real b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxs.x b/sys/vops/lz/apkxs.x new file mode 100644 index 00000000..178683a9 --- /dev/null +++ b/sys/vops/lz/apkxs.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxs (a, b, c, npix) + +short a[ARB] # real component +short b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxx.x b/sys/vops/lz/apkxx.x new file mode 100644 index 00000000..9baef047 --- /dev/null +++ b/sys/vops/lz/apkxx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxx (a, b, c, npix) + +complex a[ARB] # real component +complex b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), aimag(b[i])) +end diff --git a/sys/vops/lz/apold.x b/sys/vops/lz/apold.x new file mode 100644 index 00000000..885ed4fe --- /dev/null +++ b/sys/vops/lz/apold.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOL -- Evaluate a polynomial at X, given the coefficients of the polynomial +# in COEFF and returning the computed value as the function value. + +double procedure apold (x, coeff, ncoeff) + +double x # point at which the polynomial is to be evaluated +double coeff[ncoeff] # coefficients of the polynomial, lower orders first +int ncoeff + +int i +double pow, sum + +begin + sum = coeff[1] + pow = x + + do i = 2, ncoeff { + sum = sum + pow * coeff[i] + pow = pow * x + } + + return (sum) +end diff --git a/sys/vops/lz/apolr.x b/sys/vops/lz/apolr.x new file mode 100644 index 00000000..22912021 --- /dev/null +++ b/sys/vops/lz/apolr.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOL -- Evaluate a polynomial at X, given the coefficients of the polynomial +# in COEFF and returning the computed value as the function value. + +real procedure apolr (x, coeff, ncoeff) + +real x # point at which the polynomial is to be evaluated +real coeff[ncoeff] # coefficients of the polynomial, lower orders first +int ncoeff + +int i +real pow, sum + +begin + sum = coeff[1] + pow = x + + do i = 2, ncoeff { + sum = sum + pow * coeff[i] + pow = pow * x + } + + return (sum) +end diff --git a/sys/vops/lz/apowd.x b/sys/vops/lz/apowd.x new file mode 100644 index 00000000..2f277935 --- /dev/null +++ b/sys/vops/lz/apowd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowd (a, b, c, npix) + +double a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowi.x b/sys/vops/lz/apowi.x new file mode 100644 index 00000000..27d587f9 --- /dev/null +++ b/sys/vops/lz/apowi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowi (a, b, c, npix) + +int a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowkd.x b/sys/vops/lz/apowkd.x new file mode 100644 index 00000000..8aee1a87 --- /dev/null +++ b/sys/vops/lz/apowkd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkd (a, b, c, npix) + +double a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkd (1.0D0, c, npix) + case 1: + call amovd (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowki.x b/sys/vops/lz/apowki.x new file mode 100644 index 00000000..1b756bca --- /dev/null +++ b/sys/vops/lz/apowki.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowki (a, b, c, npix) + +int a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovki (1, c, npix) + case 1: + call amovi (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowkl.x b/sys/vops/lz/apowkl.x new file mode 100644 index 00000000..c7247f3e --- /dev/null +++ b/sys/vops/lz/apowkl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkl (a, b, c, npix) + +long a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkl (1, c, npix) + case 1: + call amovl (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowkr.x b/sys/vops/lz/apowkr.x new file mode 100644 index 00000000..b22be6b7 --- /dev/null +++ b/sys/vops/lz/apowkr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkr (a, b, c, npix) + +real a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkr (1.0, c, npix) + case 1: + call amovr (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowks.x b/sys/vops/lz/apowks.x new file mode 100644 index 00000000..f656115a --- /dev/null +++ b/sys/vops/lz/apowks.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowks (a, b, c, npix) + +short a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovks (1, c, npix) + case 1: + call amovs (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowkx.x b/sys/vops/lz/apowkx.x new file mode 100644 index 00000000..461353be --- /dev/null +++ b/sys/vops/lz/apowkx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkx (a, b, c, npix) + +complex a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkx ((1,1), c, npix) + case 1: + call amovx (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowl.x b/sys/vops/lz/apowl.x new file mode 100644 index 00000000..28cd171f --- /dev/null +++ b/sys/vops/lz/apowl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowl (a, b, c, npix) + +long a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowr.x b/sys/vops/lz/apowr.x new file mode 100644 index 00000000..7d80443f --- /dev/null +++ b/sys/vops/lz/apowr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowr (a, b, c, npix) + +real a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apows.x b/sys/vops/lz/apows.x new file mode 100644 index 00000000..de128595 --- /dev/null +++ b/sys/vops/lz/apows.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apows (a, b, c, npix) + +short a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowx.x b/sys/vops/lz/apowx.x new file mode 100644 index 00000000..77f7814d --- /dev/null +++ b/sys/vops/lz/apowx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowx (a, b, c, npix) + +complex a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/aravd.x b/sys/vops/lz/aravd.x new file mode 100644 index 00000000..7b454fd3 --- /dev/null +++ b/sys/vops/lz/aravd.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravd (a, npix, mean, sigma, ksig) + +double a[ARB] # input data array +double mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgd() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgd (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILOND) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravi.x b/sys/vops/lz/aravi.x new file mode 100644 index 00000000..865e4ecb --- /dev/null +++ b/sys/vops/lz/aravi.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravi (a, npix, mean, sigma, ksig) + +int a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgi() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgi (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravl.x b/sys/vops/lz/aravl.x new file mode 100644 index 00000000..519cd1c8 --- /dev/null +++ b/sys/vops/lz/aravl.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravl (a, npix, mean, sigma, ksig) + +long a[ARB] # input data array +double mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgl() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgl (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILOND) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravr.x b/sys/vops/lz/aravr.x new file mode 100644 index 00000000..c3f0fb8f --- /dev/null +++ b/sys/vops/lz/aravr.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravr (a, npix, mean, sigma, ksig) + +real a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgr() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgr (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravs.x b/sys/vops/lz/aravs.x new file mode 100644 index 00000000..6c734aed --- /dev/null +++ b/sys/vops/lz/aravs.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravs (a, npix, mean, sigma, ksig) + +short a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgs() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgs (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravx.x b/sys/vops/lz/aravx.x new file mode 100644 index 00000000..92f7328c --- /dev/null +++ b/sys/vops/lz/aravx.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravx (a, npix, mean, sigma, ksig) + +complex a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgx() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgx (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/arcpd.x b/sys/vops/lz/arcpd.x new file mode 100644 index 00000000..095d50d3 --- /dev/null +++ b/sys/vops/lz/arcpd.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpd (a, b, c, npix) + +double a # constant numerator +double b[ARB] # vector denominator +double c[ARB] # output vector +int npix +int i + +begin + if (a == 0.0D0) { + call aclrd (c, npix) + } else if (a == 1.0D0) { + do i = 1, npix + c[i] = 1.0D0 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpi.x b/sys/vops/lz/arcpi.x new file mode 100644 index 00000000..193f35e1 --- /dev/null +++ b/sys/vops/lz/arcpi.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpi (a, b, c, npix) + +int a # constant numerator +int b[ARB] # vector denominator +int c[ARB] # output vector +int npix +int i + +begin + if (a == 0) { + call aclri (c, npix) + } else if (a == 1) { + do i = 1, npix + c[i] = 1 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpl.x b/sys/vops/lz/arcpl.x new file mode 100644 index 00000000..3f3c5b39 --- /dev/null +++ b/sys/vops/lz/arcpl.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpl (a, b, c, npix) + +long a # constant numerator +long b[ARB] # vector denominator +long c[ARB] # output vector +int npix +int i + +begin + if (a == 0) { + call aclrl (c, npix) + } else if (a == 1) { + do i = 1, npix + c[i] = 1 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpr.x b/sys/vops/lz/arcpr.x new file mode 100644 index 00000000..f52a1651 --- /dev/null +++ b/sys/vops/lz/arcpr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpr (a, b, c, npix) + +real a # constant numerator +real b[ARB] # vector denominator +real c[ARB] # output vector +int npix +int i + +begin + if (a == 0.0) { + call aclrr (c, npix) + } else if (a == 1.0) { + do i = 1, npix + c[i] = 1.0 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcps.x b/sys/vops/lz/arcps.x new file mode 100644 index 00000000..0e0f8056 --- /dev/null +++ b/sys/vops/lz/arcps.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcps (a, b, c, npix) + +short a # constant numerator +short b[ARB] # vector denominator +short c[ARB] # output vector +int npix +int i + +begin + if (a == 0) { + call aclrs (c, npix) + } else if (a == 1) { + do i = 1, npix + c[i] = 1 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpx.x b/sys/vops/lz/arcpx.x new file mode 100644 index 00000000..626eb6a1 --- /dev/null +++ b/sys/vops/lz/arcpx.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpx (a, b, c, npix) + +complex a # constant numerator +complex b[ARB] # vector denominator +complex c[ARB] # output vector +int npix +int i + +begin + if (a == (0.0,0.0)) { + call aclrx (c, npix) + } else if (a == (1.0,1.0)) { + do i = 1, npix + c[i] = (1.0,1.0) / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arczd.x b/sys/vops/lz/arczd.x new file mode 100644 index 00000000..4f5ad6f2 --- /dev/null +++ b/sys/vops/lz/arczd.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczd (a, b, c, npix, errfcn) + +double a # numerator +double b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +double errfcn() # user function, called on divide by zero + +int i +double divisor +double tol +extern errfcn() +errchk errfcn + +begin + if (a == 0.0D0) { + call aclrd (c, npix) + return + } + + tol = 1.0D-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a) + next + } + c[i] = a / divisor + + } +end diff --git a/sys/vops/lz/arczi.x b/sys/vops/lz/arczi.x new file mode 100644 index 00000000..ce679742 --- /dev/null +++ b/sys/vops/lz/arczi.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczi (a, b, c, npix, errfcn) + +int a # numerator +int b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +int errfcn() # user function, called on divide by zero + +int i +int divisor +extern errfcn() +errchk errfcn + +begin + if (a == 0) { + call aclri (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/arczl.x b/sys/vops/lz/arczl.x new file mode 100644 index 00000000..b89e2cbe --- /dev/null +++ b/sys/vops/lz/arczl.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczl (a, b, c, npix, errfcn) + +long a # numerator +long b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +long errfcn() # user function, called on divide by zero + +int i +long divisor +extern errfcn() +errchk errfcn + +begin + if (a == 0) { + call aclrl (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/arczr.x b/sys/vops/lz/arczr.x new file mode 100644 index 00000000..7c2e9fe2 --- /dev/null +++ b/sys/vops/lz/arczr.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczr (a, b, c, npix, errfcn) + +real a # numerator +real b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +real errfcn() # user function, called on divide by zero + +int i +real divisor +real tol +extern errfcn() +errchk errfcn + +begin + if (a == 0.0) { + call aclrr (c, npix) + return + } + + tol = 1.0E-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a) + next + } + c[i] = a / divisor + + } +end diff --git a/sys/vops/lz/arczs.x b/sys/vops/lz/arczs.x new file mode 100644 index 00000000..4216d38d --- /dev/null +++ b/sys/vops/lz/arczs.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczs (a, b, c, npix, errfcn) + +short a # numerator +short b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +short errfcn() # user function, called on divide by zero + +int i +short divisor +extern errfcn() +errchk errfcn + +begin + if (a == 0) { + call aclrs (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/arczx.x b/sys/vops/lz/arczx.x new file mode 100644 index 00000000..ec23595e --- /dev/null +++ b/sys/vops/lz/arczx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczx (a, b, c, npix, errfcn) + +complex a # numerator +complex b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +complex errfcn() # user function, called on divide by zero + +int i +complex divisor +extern errfcn() +errchk errfcn + +begin + if (a == (0.0,0.0)) { + call aclrx (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == (0.0,0.0)) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/argtd.x b/sys/vops/lz/argtd.x new file mode 100644 index 00000000..bf12e17c --- /dev/null +++ b/sys/vops/lz/argtd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtd (a, npix, ceil, newval) + +double a[ARB] +int npix +double ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argti.x b/sys/vops/lz/argti.x new file mode 100644 index 00000000..dffdce17 --- /dev/null +++ b/sys/vops/lz/argti.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argti (a, npix, ceil, newval) + +int a[ARB] +int npix +int ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argtl.x b/sys/vops/lz/argtl.x new file mode 100644 index 00000000..e776573c --- /dev/null +++ b/sys/vops/lz/argtl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtl (a, npix, ceil, newval) + +long a[ARB] +int npix +long ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argtr.x b/sys/vops/lz/argtr.x new file mode 100644 index 00000000..5ab107f7 --- /dev/null +++ b/sys/vops/lz/argtr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtr (a, npix, ceil, newval) + +real a[ARB] +int npix +real ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argts.x b/sys/vops/lz/argts.x new file mode 100644 index 00000000..815f753f --- /dev/null +++ b/sys/vops/lz/argts.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argts (a, npix, ceil, newval) + +short a[ARB] +int npix +short ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argtx.x b/sys/vops/lz/argtx.x new file mode 100644 index 00000000..53253e01 --- /dev/null +++ b/sys/vops/lz/argtx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtx (a, npix, ceil, newval) + +complex a[ARB] +int npix +complex ceil, newval +int i +real abs_ceil + +begin + abs_ceil = abs (ceil) + + do i = 1, npix + if (abs (a[i]) > abs_ceil) + a[i] = newval +end diff --git a/sys/vops/lz/arltd.x b/sys/vops/lz/arltd.x new file mode 100644 index 00000000..62693331 --- /dev/null +++ b/sys/vops/lz/arltd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltd (a, npix, floor, newval) + +double a[ARB] +int npix +double floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arlti.x b/sys/vops/lz/arlti.x new file mode 100644 index 00000000..6b8ae086 --- /dev/null +++ b/sys/vops/lz/arlti.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arlti (a, npix, floor, newval) + +int a[ARB] +int npix +int floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arltl.x b/sys/vops/lz/arltl.x new file mode 100644 index 00000000..4bda96c3 --- /dev/null +++ b/sys/vops/lz/arltl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltl (a, npix, floor, newval) + +long a[ARB] +int npix +long floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arltr.x b/sys/vops/lz/arltr.x new file mode 100644 index 00000000..3b419556 --- /dev/null +++ b/sys/vops/lz/arltr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltr (a, npix, floor, newval) + +real a[ARB] +int npix +real floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arlts.x b/sys/vops/lz/arlts.x new file mode 100644 index 00000000..ca4e0582 --- /dev/null +++ b/sys/vops/lz/arlts.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arlts (a, npix, floor, newval) + +short a[ARB] +int npix +short floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arltx.x b/sys/vops/lz/arltx.x new file mode 100644 index 00000000..8ea55d5f --- /dev/null +++ b/sys/vops/lz/arltx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltx (a, npix, floor, newval) + +complex a[ARB] +int npix +complex floor, newval +int i +real abs_floor + +begin + abs_floor = abs (floor) + + do i = 1, npix + if (abs (a[i]) < abs_floor) + a[i] = newval +end diff --git a/sys/vops/lz/aselc.x b/sys/vops/lz/aselc.x new file mode 100644 index 00000000..eeed8930 --- /dev/null +++ b/sys/vops/lz/aselc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aselc (a, b, c, sel, npix) + +char a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aseld.x b/sys/vops/lz/aseld.x new file mode 100644 index 00000000..79758363 --- /dev/null +++ b/sys/vops/lz/aseld.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aseld (a, b, c, sel, npix) + +double a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aseli.x b/sys/vops/lz/aseli.x new file mode 100644 index 00000000..c4a8a211 --- /dev/null +++ b/sys/vops/lz/aseli.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aseli (a, b, c, sel, npix) + +int a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aselkc.x b/sys/vops/lz/aselkc.x new file mode 100644 index 00000000..28b5d4a2 --- /dev/null +++ b/sys/vops/lz/aselkc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkc (a, b, c, sel, npix) + +char a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkd.x b/sys/vops/lz/aselkd.x new file mode 100644 index 00000000..f0ad7dae --- /dev/null +++ b/sys/vops/lz/aselkd.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkd (a, b, c, sel, npix) + +double a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselki.x b/sys/vops/lz/aselki.x new file mode 100644 index 00000000..a56737ab --- /dev/null +++ b/sys/vops/lz/aselki.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselki (a, b, c, sel, npix) + +int a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkl.x b/sys/vops/lz/aselkl.x new file mode 100644 index 00000000..2fbf6b23 --- /dev/null +++ b/sys/vops/lz/aselkl.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkl (a, b, c, sel, npix) + +long a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkr.x b/sys/vops/lz/aselkr.x new file mode 100644 index 00000000..702000b3 --- /dev/null +++ b/sys/vops/lz/aselkr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkr (a, b, c, sel, npix) + +real a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselks.x b/sys/vops/lz/aselks.x new file mode 100644 index 00000000..59891f15 --- /dev/null +++ b/sys/vops/lz/aselks.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselks (a, b, c, sel, npix) + +short a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkx.x b/sys/vops/lz/aselkx.x new file mode 100644 index 00000000..4a4de962 --- /dev/null +++ b/sys/vops/lz/aselkx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkx (a, b, c, sel, npix) + +complex a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/asell.x b/sys/vops/lz/asell.x new file mode 100644 index 00000000..5b7e08a7 --- /dev/null +++ b/sys/vops/lz/asell.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure asell (a, b, c, sel, npix) + +long a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aselr.x b/sys/vops/lz/aselr.x new file mode 100644 index 00000000..3a5f7f1b --- /dev/null +++ b/sys/vops/lz/aselr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aselr (a, b, c, sel, npix) + +real a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/asels.x b/sys/vops/lz/asels.x new file mode 100644 index 00000000..b2118ba8 --- /dev/null +++ b/sys/vops/lz/asels.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure asels (a, b, c, sel, npix) + +short a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aselx.x b/sys/vops/lz/aselx.x new file mode 100644 index 00000000..1bd02e9a --- /dev/null +++ b/sys/vops/lz/aselx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aselx (a, b, c, sel, npix) + +complex a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/asokc.x b/sys/vops/lz/asokc.x new file mode 100644 index 00000000..794252f2 --- /dev/null +++ b/sys/vops/lz/asokc.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +char procedure asokc (a, npix, ksel) + +char a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +char temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokd.x b/sys/vops/lz/asokd.x new file mode 100644 index 00000000..54627469 --- /dev/null +++ b/sys/vops/lz/asokd.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +double procedure asokd (a, npix, ksel) + +double a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +double temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asoki.x b/sys/vops/lz/asoki.x new file mode 100644 index 00000000..dd579ac2 --- /dev/null +++ b/sys/vops/lz/asoki.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +int procedure asoki (a, npix, ksel) + +int a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +int temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokl.x b/sys/vops/lz/asokl.x new file mode 100644 index 00000000..37adff9c --- /dev/null +++ b/sys/vops/lz/asokl.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +long procedure asokl (a, npix, ksel) + +long a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +long temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokr.x b/sys/vops/lz/asokr.x new file mode 100644 index 00000000..420eaf65 --- /dev/null +++ b/sys/vops/lz/asokr.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +real procedure asokr (a, npix, ksel) + +real a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +real temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asoks.x b/sys/vops/lz/asoks.x new file mode 100644 index 00000000..a92f4015 --- /dev/null +++ b/sys/vops/lz/asoks.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +short procedure asoks (a, npix, ksel) + +short a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +short temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokx.x b/sys/vops/lz/asokx.x new file mode 100644 index 00000000..7528714a --- /dev/null +++ b/sys/vops/lz/asokx.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +complex procedure asokx (a, npix, ksel) + +complex a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +complex temp, wtemp +real abs_temp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + abs_temp = abs (temp) + + repeat { + while (abs (a[i]) < abs_temp) + i = i + 1 + while (abs_temp < abs (a[j])) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asqrd.x b/sys/vops/lz/asqrd.x new file mode 100644 index 00000000..e6cf3f70 --- /dev/null +++ b/sys/vops/lz/asqrd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrd (a, b, npix, errfcn) + +double a[ARB], b[ARB] +int npix, i +extern errfcn() +double errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (a[i]) + } + } +end diff --git a/sys/vops/lz/asqri.x b/sys/vops/lz/asqri.x new file mode 100644 index 00000000..c68c64f4 --- /dev/null +++ b/sys/vops/lz/asqri.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqri (a, b, npix, errfcn) + +int a[ARB], b[ARB] +int npix, i +extern errfcn() +int errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (real (a[i])) + } + } +end diff --git a/sys/vops/lz/asqrl.x b/sys/vops/lz/asqrl.x new file mode 100644 index 00000000..3b0d23f0 --- /dev/null +++ b/sys/vops/lz/asqrl.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrl (a, b, npix, errfcn) + +long a[ARB], b[ARB] +int npix, i +extern errfcn() +long errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (double (a[i])) + } + } +end diff --git a/sys/vops/lz/asqrr.x b/sys/vops/lz/asqrr.x new file mode 100644 index 00000000..a18b21d2 --- /dev/null +++ b/sys/vops/lz/asqrr.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrr (a, b, npix, errfcn) + +real a[ARB], b[ARB] +int npix, i +extern errfcn() +real errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (a[i]) + } + } +end diff --git a/sys/vops/lz/asqrs.x b/sys/vops/lz/asqrs.x new file mode 100644 index 00000000..5a1d6532 --- /dev/null +++ b/sys/vops/lz/asqrs.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrs (a, b, npix, errfcn) + +short a[ARB], b[ARB] +int npix, i +extern errfcn() +short errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (real (a[i])) + } + } +end diff --git a/sys/vops/lz/asqrx.x b/sys/vops/lz/asqrx.x new file mode 100644 index 00000000..a529811c --- /dev/null +++ b/sys/vops/lz/asqrx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrx (a, b, npix, errfcn) + +complex a[ARB], b[ARB] +int npix, i +extern errfcn() +complex errfcn() +errchk errfcn + +begin + do i = 1, npix { + { + b[i] = sqrt (a[i]) + } + } +end diff --git a/sys/vops/lz/asrtc.x b/sys/vops/lz/asrtc.x new file mode 100644 index 00000000..f4de2d71 --- /dev/null +++ b/sys/vops/lz/asrtc.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtc (a, b, npix) + +char a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +char pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovc (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtd.x b/sys/vops/lz/asrtd.x new file mode 100644 index 00000000..64d52880 --- /dev/null +++ b/sys/vops/lz/asrtd.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtd (a, b, npix) + +double a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +double pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovd (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrti.x b/sys/vops/lz/asrti.x new file mode 100644 index 00000000..e956a8bd --- /dev/null +++ b/sys/vops/lz/asrti.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrti (a, b, npix) + +int a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +int pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovi (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtl.x b/sys/vops/lz/asrtl.x new file mode 100644 index 00000000..ddc1c59b --- /dev/null +++ b/sys/vops/lz/asrtl.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtl (a, b, npix) + +long a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +long pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovl (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtr.x b/sys/vops/lz/asrtr.x new file mode 100644 index 00000000..a4be1ed2 --- /dev/null +++ b/sys/vops/lz/asrtr.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtr (a, b, npix) + +real a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +real pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovr (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrts.x b/sys/vops/lz/asrts.x new file mode 100644 index 00000000..b0bff6e6 --- /dev/null +++ b/sys/vops/lz/asrts.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrts (a, b, npix) + +short a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +short pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovs (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtx.x b/sys/vops/lz/asrtx.x new file mode 100644 index 00000000..7e0c421b --- /dev/null +++ b/sys/vops/lz/asrtx.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtx (a, b, npix) + +complex a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +complex pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovx (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (abs(b[j]) <= abs(pivot)) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/assqd.x b/sys/vops/lz/assqd.x new file mode 100644 index 00000000..ec8d4190 --- /dev/null +++ b/sys/vops/lz/assqd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +double procedure assqd (a, npix) +double sum + +double a[ARB] +int npix +int i + +begin + sum = 0.0D0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqi.x b/sys/vops/lz/assqi.x new file mode 100644 index 00000000..73091f16 --- /dev/null +++ b/sys/vops/lz/assqi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +real procedure assqi (a, npix) +real sum + +int a[ARB] +int npix +int i + +begin + sum = 0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assql.x b/sys/vops/lz/assql.x new file mode 100644 index 00000000..096f9a76 --- /dev/null +++ b/sys/vops/lz/assql.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +double procedure assql (a, npix) +double sum + +long a[ARB] +int npix +int i + +begin + sum = 0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqr.x b/sys/vops/lz/assqr.x new file mode 100644 index 00000000..ffb83e57 --- /dev/null +++ b/sys/vops/lz/assqr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +real procedure assqr (a, npix) +real sum + +real a[ARB] +int npix +int i + +begin + sum = 0.0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqs.x b/sys/vops/lz/assqs.x new file mode 100644 index 00000000..094f9285 --- /dev/null +++ b/sys/vops/lz/assqs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +real procedure assqs (a, npix) +real sum + +short a[ARB] +int npix +int i + +begin + sum = 0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqx.x b/sys/vops/lz/assqx.x new file mode 100644 index 00000000..adf4edb0 --- /dev/null +++ b/sys/vops/lz/assqx.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +complex procedure assqx (a, npix) +complex sum + +complex a[ARB] +int npix +int i + +begin + sum = (0.0,0.0) + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/asubd.x b/sys/vops/lz/asubd.x new file mode 100644 index 00000000..faa1943a --- /dev/null +++ b/sys/vops/lz/asubd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubi.x b/sys/vops/lz/asubi.x new file mode 100644 index 00000000..6cecbfe9 --- /dev/null +++ b/sys/vops/lz/asubi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubkd.x b/sys/vops/lz/asubkd.x new file mode 100644 index 00000000..9eed4999 --- /dev/null +++ b/sys/vops/lz/asubkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubki.x b/sys/vops/lz/asubki.x new file mode 100644 index 00000000..944e4af0 --- /dev/null +++ b/sys/vops/lz/asubki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubkl.x b/sys/vops/lz/asubkl.x new file mode 100644 index 00000000..7d6a7ce9 --- /dev/null +++ b/sys/vops/lz/asubkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubkr.x b/sys/vops/lz/asubkr.x new file mode 100644 index 00000000..c9a303ff --- /dev/null +++ b/sys/vops/lz/asubkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubks.x b/sys/vops/lz/asubks.x new file mode 100644 index 00000000..e0eb9d66 --- /dev/null +++ b/sys/vops/lz/asubks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubkx.x b/sys/vops/lz/asubkx.x new file mode 100644 index 00000000..4c9f5280 --- /dev/null +++ b/sys/vops/lz/asubkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubl.x b/sys/vops/lz/asubl.x new file mode 100644 index 00000000..851f988b --- /dev/null +++ b/sys/vops/lz/asubl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubr.x b/sys/vops/lz/asubr.x new file mode 100644 index 00000000..6ad54ba4 --- /dev/null +++ b/sys/vops/lz/asubr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubs.x b/sys/vops/lz/asubs.x new file mode 100644 index 00000000..6a2a5ddb --- /dev/null +++ b/sys/vops/lz/asubs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubs (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubx.x b/sys/vops/lz/asubx.x new file mode 100644 index 00000000..7694aa7c --- /dev/null +++ b/sys/vops/lz/asubx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asumd.x b/sys/vops/lz/asumd.x new file mode 100644 index 00000000..24e4e7a9 --- /dev/null +++ b/sys/vops/lz/asumd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +double procedure asumd (a, npix) + +double a[ARB] +int npix +int i + +double sum + +begin + sum = 0.0D0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asumi.x b/sys/vops/lz/asumi.x new file mode 100644 index 00000000..314b100f --- /dev/null +++ b/sys/vops/lz/asumi.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +real procedure asumi (a, npix) + +int a[ARB] +int npix +int i + +real sum + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asuml.x b/sys/vops/lz/asuml.x new file mode 100644 index 00000000..4a2f9ec1 --- /dev/null +++ b/sys/vops/lz/asuml.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +double procedure asuml (a, npix) + +long a[ARB] +int npix +int i + +double sum + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asumr.x b/sys/vops/lz/asumr.x new file mode 100644 index 00000000..962be9cc --- /dev/null +++ b/sys/vops/lz/asumr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +real procedure asumr (a, npix) + +real a[ARB] +int npix +int i + +real sum + +begin + sum = 0.0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asums.x b/sys/vops/lz/asums.x new file mode 100644 index 00000000..663dab08 --- /dev/null +++ b/sys/vops/lz/asums.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +real procedure asums (a, npix) + +short a[ARB] +int npix +int i + +real sum + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asumx.x b/sys/vops/lz/asumx.x new file mode 100644 index 00000000..936cdaf3 --- /dev/null +++ b/sys/vops/lz/asumx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +complex procedure asumx (a, npix) + +complex a[ARB] +int npix +int i + +complex sum + +begin + sum = (0.0,0.0) + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/aupxd.x b/sys/vops/lz/aupxd.x new file mode 100644 index 00000000..38e9fa53 --- /dev/null +++ b/sys/vops/lz/aupxd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxd (a, b, c, npix) + +complex a[ARB] # input vector +double b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxi.x b/sys/vops/lz/aupxi.x new file mode 100644 index 00000000..59e76ced --- /dev/null +++ b/sys/vops/lz/aupxi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxi (a, b, c, npix) + +complex a[ARB] # input vector +int b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxl.x b/sys/vops/lz/aupxl.x new file mode 100644 index 00000000..96147678 --- /dev/null +++ b/sys/vops/lz/aupxl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxl (a, b, c, npix) + +complex a[ARB] # input vector +long b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxr.x b/sys/vops/lz/aupxr.x new file mode 100644 index 00000000..135683fe --- /dev/null +++ b/sys/vops/lz/aupxr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxr (a, b, c, npix) + +complex a[ARB] # input vector +real b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxs.x b/sys/vops/lz/aupxs.x new file mode 100644 index 00000000..82996096 --- /dev/null +++ b/sys/vops/lz/aupxs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxs (a, b, c, npix) + +complex a[ARB] # input vector +short b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxx.x b/sys/vops/lz/aupxx.x new file mode 100644 index 00000000..109bdc01 --- /dev/null +++ b/sys/vops/lz/aupxx.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxx (a, b, c, npix) + +complex a[ARB] # input vector +complex b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = complex (real(a[i]), 0.0) + c[i] = complex (0.0, aimag(a[i])) + } +end diff --git a/sys/vops/lz/aveqc.x b/sys/vops/lz/aveqc.x new file mode 100644 index 00000000..e8d07db1 --- /dev/null +++ b/sys/vops/lz/aveqc.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqc (a, b, npix) + +char a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqd.x b/sys/vops/lz/aveqd.x new file mode 100644 index 00000000..d67daeb8 --- /dev/null +++ b/sys/vops/lz/aveqd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqd (a, b, npix) + +double a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqi.x b/sys/vops/lz/aveqi.x new file mode 100644 index 00000000..913224b4 --- /dev/null +++ b/sys/vops/lz/aveqi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqi (a, b, npix) + +int a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveql.x b/sys/vops/lz/aveql.x new file mode 100644 index 00000000..ce05898e --- /dev/null +++ b/sys/vops/lz/aveql.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveql (a, b, npix) + +long a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqr.x b/sys/vops/lz/aveqr.x new file mode 100644 index 00000000..01faffe2 --- /dev/null +++ b/sys/vops/lz/aveqr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqr (a, b, npix) + +real a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqs.x b/sys/vops/lz/aveqs.x new file mode 100644 index 00000000..92680633 --- /dev/null +++ b/sys/vops/lz/aveqs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqs (a, b, npix) + +short a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqx.x b/sys/vops/lz/aveqx.x new file mode 100644 index 00000000..2d616b1a --- /dev/null +++ b/sys/vops/lz/aveqx.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqx (a, b, npix) + +complex a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/awsud.x b/sys/vops/lz/awsud.x new file mode 100644 index 00000000..f2e5e02e --- /dev/null +++ b/sys/vops/lz/awsud.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsud (a, b, c, npix, k1, k2) + +double a[ARB], b[ARB], c[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsui.x b/sys/vops/lz/awsui.x new file mode 100644 index 00000000..0e75feed --- /dev/null +++ b/sys/vops/lz/awsui.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsui (a, b, c, npix, k1, k2) + +int a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsul.x b/sys/vops/lz/awsul.x new file mode 100644 index 00000000..1a8dd058 --- /dev/null +++ b/sys/vops/lz/awsul.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsul (a, b, c, npix, k1, k2) + +long a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsur.x b/sys/vops/lz/awsur.x new file mode 100644 index 00000000..4efd8909 --- /dev/null +++ b/sys/vops/lz/awsur.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsur (a, b, c, npix, k1, k2) + +real a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsus.x b/sys/vops/lz/awsus.x new file mode 100644 index 00000000..78ee5bbf --- /dev/null +++ b/sys/vops/lz/awsus.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsus (a, b, c, npix, k1, k2) + +short a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsux.x b/sys/vops/lz/awsux.x new file mode 100644 index 00000000..7516bd8b --- /dev/null +++ b/sys/vops/lz/awsux.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsux (a, b, c, npix, k1, k2) + +complex a[ARB], b[ARB], c[ARB] +complex k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awvgd.x b/sys/vops/lz/awvgd.x new file mode 100644 index 00000000..58b1d87b --- /dev/null +++ b/sys/vops/lz/awvgd.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgd (a, npix, mean, sigma, lcut, hcut) + +double a[ARB] +double mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFD + sigma = INDEFD + case 1: + mean = sum + sigma = INDEFD + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgi.x b/sys/vops/lz/awvgi.x new file mode 100644 index 00000000..b1e78ebe --- /dev/null +++ b/sys/vops/lz/awvgi.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgi (a, npix, mean, sigma, lcut, hcut) + +int a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgl.x b/sys/vops/lz/awvgl.x new file mode 100644 index 00000000..d56d0a8a --- /dev/null +++ b/sys/vops/lz/awvgl.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgl (a, npix, mean, sigma, lcut, hcut) + +long a[ARB] +double mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFD + sigma = INDEFD + case 1: + mean = sum + sigma = INDEFD + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgr.x b/sys/vops/lz/awvgr.x new file mode 100644 index 00000000..fab5efe7 --- /dev/null +++ b/sys/vops/lz/awvgr.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgr (a, npix, mean, sigma, lcut, hcut) + +real a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgs.x b/sys/vops/lz/awvgs.x new file mode 100644 index 00000000..8237be56 --- /dev/null +++ b/sys/vops/lz/awvgs.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgs (a, npix, mean, sigma, lcut, hcut) + +short a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgx.x b/sys/vops/lz/awvgx.x new file mode 100644 index 00000000..82fe4192 --- /dev/null +++ b/sys/vops/lz/awvgx.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgx (a, npix, mean, sigma, lcut, hcut) + +complex a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = abs (a[i]) + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = abs (a[i]) + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/axori.x b/sys/vops/lz/axori.x new file mode 100644 index 00000000..e6df0010 --- /dev/null +++ b/sys/vops/lz/axori.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axori (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i +int xor() + +begin + do i = 1, npix { + c[i] = xor (a[i], b[i]) + } +end diff --git a/sys/vops/lz/axorki.x b/sys/vops/lz/axorki.x new file mode 100644 index 00000000..5e08a769 --- /dev/null +++ b/sys/vops/lz/axorki.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axorki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i +int xor() + +begin + do i = 1, npix { + c[i] = xor (a[i], b) + } +end diff --git a/sys/vops/lz/axorkl.x b/sys/vops/lz/axorkl.x new file mode 100644 index 00000000..df4f074f --- /dev/null +++ b/sys/vops/lz/axorkl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axorkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i +long xorl() + +begin + do i = 1, npix { + c[i] = xorl (a[i], b) + } +end diff --git a/sys/vops/lz/axorks.x b/sys/vops/lz/axorks.x new file mode 100644 index 00000000..d85e283d --- /dev/null +++ b/sys/vops/lz/axorks.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axorks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i +short xors() + +begin + do i = 1, npix { + c[i] = xors (a[i], b) + } +end diff --git a/sys/vops/lz/axorl.x b/sys/vops/lz/axorl.x new file mode 100644 index 00000000..d4087fd3 --- /dev/null +++ b/sys/vops/lz/axorl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axorl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i +long xorl() + +begin + do i = 1, npix { + c[i] = xorl (a[i], b[i]) + } +end diff --git a/sys/vops/lz/axors.x b/sys/vops/lz/axors.x new file mode 100644 index 00000000..ab3c073d --- /dev/null +++ b/sys/vops/lz/axors.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axors (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i +short xors() + +begin + do i = 1, npix { + c[i] = xors (a[i], b[i]) + } +end diff --git a/sys/vops/lz/mkpkg b/sys/vops/lz/mkpkg new file mode 100644 index 00000000..046aa2b7 --- /dev/null +++ b/sys/vops/lz/mkpkg @@ -0,0 +1,330 @@ +# Make the VOPS vector operators library, procedures a[l-z]*.*. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +libvops.a: + alans.x + alani.x + alanl.x + alanks.x + alanki.x + alankl.x + alimc.x + alimd.x + alimi.x + aliml.x + alimr.x + alims.x + alimx.x + allnd.x + allni.x + allnl.x + allnr.x + allns.x + allnx.x + alogd.x + alogi.x + alogl.x + alogr.x + alogs.x + alogx.x + alors.x + alori.x + alorl.x + alorks.x + alorki.x + alorkl.x + alovc.x + alovd.x + alovi.x + alovl.x + alovr.x + alovs.x + alovx.x + altad.x + altai.x + altal.x + altar.x + altas.x + altax.x + altmd.x + altmi.x + altml.x + altmr.x + altms.x + altmx.x + altrd.x + altri.x + altrl.x + altrr.x + altrs.x + altrx.x + aluid.x <mach.h> + aluii.x <mach.h> + aluil.x <mach.h> + aluir.x <mach.h> + aluis.x <mach.h> + alutc.x + alutd.x + aluti.x + alutl.x + alutr.x + aluts.x + amagd.x + amagi.x + amagl.x + amagr.x + amags.x + amagx.x + amapd.x + amapi.x + amapl.x + amapr.x + amaps.x + amaxc.x + amaxd.x + amaxi.x + amaxkc.x + amaxkd.x + amaxki.x + amaxkl.x + amaxkr.x + amaxks.x + amaxkx.x + amaxl.x + amaxr.x + amaxs.x + amaxx.x + amed3c.x + amed3d.x + amed3i.x + amed3l.x + amed3r.x + amed3s.x + amed4c.x + amed4d.x + amed4i.x + amed4l.x + amed4r.x + amed4s.x + amed5c.x + amed5d.x + amed5i.x + amed5l.x + amed5r.x + amed5s.x + amedc.x + amedd.x + amedi.x + amedl.x + amedr.x + ameds.x + amedx.x + amgsd.x + amgsi.x + amgsl.x + amgsr.x + amgss.x + amgsx.x + aminc.x + amind.x + amini.x + aminkc.x + aminkd.x + aminki.x + aminkl.x + aminkr.x + aminks.x + aminkx.x + aminl.x + aminr.x + amins.x + aminx.x + amodd.x + amodi.x + amodkd.x + amodki.x + amodkl.x + amodkr.x + amodks.x + amodl.x + amodr.x + amods.x + amovc.x + amovd.x + amovi.x + amovkc.x + amovkd.x + amovki.x + amovkl.x + amovkr.x + amovks.x + amovkx.x + amovl.x + amovr.x + amovs.x + amovx.x + amuld.x + amuli.x + amulkd.x + amulki.x + amulkl.x + amulkr.x + amulks.x + amulkx.x + amull.x + amulr.x + amuls.x + amulx.x + anegd.x + anegi.x + anegl.x + anegr.x + anegs.x + anegx.x + anoti.x + anotl.x + anots.x + apkxd.x + apkxi.x + apkxl.x + apkxr.x + apkxs.x + apkxx.x + apold.x + apolr.x + apowd.x + apowi.x + apowkd.x + apowki.x + apowkl.x + apowkr.x + apowks.x + apowkx.x + apowl.x + apowr.x + apows.x + apowx.x + aravd.x <mach.h> + aravi.x <mach.h> + aravl.x <mach.h> + aravr.x <mach.h> + aravs.x <mach.h> + aravx.x <mach.h> + arcpd.x + arcpi.x + arcpl.x + arcpr.x + arcps.x + arcpx.x + arczd.x + arczi.x + arczl.x + arczr.x + arczs.x + arczx.x + argtd.x + argti.x + argtl.x + argtr.x + argts.x + argtx.x + arltd.x + arlti.x + arltl.x + arltr.x + arlts.x + arltx.x + aselc.x + aseld.x + aseli.x + asell.x + aselr.x + asels.x + aselx.x + aselkc.x + aselkd.x + aselki.x + aselkl.x + aselkr.x + aselks.x + aselkx.x + asokc.x <mach.h> + asokd.x <mach.h> + asoki.x <mach.h> + asokl.x <mach.h> + asokr.x <mach.h> + asoks.x <mach.h> + asokx.x <mach.h> + asqrd.x + asqri.x + asqrl.x + asqrr.x + asqrs.x + asqrx.x + asrtc.x + asrtd.x + asrti.x + asrtl.x + asrtr.x + asrts.x + asrtx.x + assqd.x + assqi.x + assql.x + assqr.x + assqs.x + assqx.x + asubd.x + asubi.x + asubkd.x + asubki.x + asubkl.x + asubkr.x + asubks.x + asubkx.x + asubl.x + asubr.x + asubs.x + asubx.x + asumd.x + asumi.x + asuml.x + asumr.x + asums.x + asumx.x + aupxd.x + aupxi.x + aupxl.x + aupxr.x + aupxs.x + aupxx.x + aveqc.x + aveqd.x + aveqi.x + aveql.x + aveqr.x + aveqs.x + aveqx.x + awsud.x + awsui.x + awsul.x + awsur.x + awsus.x + awsux.x + awvgd.x + awvgi.x + awvgl.x + awvgr.x + awvgs.x + awvgx.x + axori.x + axorki.x + axorkl.x + axorks.x + axorl.x + axors.x + ; diff --git a/sys/vops/mkpkg b/sys/vops/mkpkg new file mode 100644 index 00000000..f44f2b16 --- /dev/null +++ b/sys/vops/mkpkg @@ -0,0 +1,150 @@ +# Make the VOPS vector operators library. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +# Since all of the VOPS procedures in this directory are generic, no actual +# compilation occurs here (except for the two fft routines, which are type +# real only). The generic preprocessor is called to generate the type +# specific family of operators for each generic procedure, placing the output +# files in the subdirectories ak and lz. Since the preprocessed sources are +# permanently kept in the subdirectories, the generic preprocessor is only +# required on the UNIX development system, although it may be available on +# any other system as well. + +tfiles: + $set GA = "$$generic -k -p ak/" + $set GL = "$$generic -k -p lz/" + $set ACHT = "achtc.x achts.x achti.x achtl.x achtr.x achtd.x achtx.x" + + # The acht (change type) procedures are doubly generic and must be + # expanded twice, producing 7*7=49 files as output. + # + # We force this to be regenerated on each platform since there are + # differences in the generated code between 32 and 64-bit platforms. + + $generic -k -t csilrdx acht.gx + $generic -k -p ak/ -t csilrdx $(ACHT) + $delete $(ACHT) + + + # The following files are not generic hence are merely copied to the + # type specific directory. + + $ifolder (ak/acjgx.x, acjgx.x ) $copy acjgx.x ak/acjgx.x $endif + $ifolder (ak/afftrr.x, afftrr.x) $copy afftrr.x ak/afftrr.x $endif + $ifolder (ak/afftrx.x, afftrx.x) $copy afftrx.x ak/afftrx.x $endif + $ifolder (ak/afftxr.x, afftxr.x) $copy afftxr.x ak/afftxr.x $endif + $ifolder (ak/afftxx.x, afftxx.x) $copy afftxx.x ak/afftxx.x $endif + $ifolder (ak/aiftrr.x, aiftrr.x) $copy aiftrr.x ak/aiftrr.x $endif + $ifolder (ak/aiftrx.x, aiftrx.x) $copy aiftrx.x ak/aiftrx.x $endif + $ifolder (ak/aiftxr.x, aiftxr.x) $copy aiftxr.x ak/aiftxr.x $endif + $ifolder (ak/aiftxx.x, aiftxx.x) $copy aiftxx.x ak/aiftxx.x $endif + + # Each of the following generic files is expanded for each of the + # datatypes listed in the -t flag. + + $ifolder (ak/aabsi.x, aabs.gx ) $(GA) -t silrdx aabs.gx $endif + $ifolder (ak/aaddi.x, aadd.gx ) $(GA) -t silrdx aadd.gx $endif + $ifolder (ak/aaddki.x, aaddk.gx) $(GA) -t silrdx aaddk.gx $endif + $ifolder (ak/aandi.x, aand.gx ) $(GA) -t sil aand.gx $endif + $ifolder (ak/aandki.x, aandk.gx) $(GA) -t sil aandk.gx $endif + $ifolder (ak/aavgi.x, aavg.gx ) $(GA) -t silrdx aavg.gx $endif + $ifolder (ak/abavi.x, abav.gx ) $(GA) -t silrdx abav.gx $endif + $ifolder (ak/absui.x, absu.gx ) $(GA) -t silrd absu.gx $endif + $ifolder (ak/abeqi.x, abeq.gx ) $(GA) -t csilrdx abeq.gx $endif + $ifolder (ak/abeqki.x, abeqk.gx) $(GA) -t csilrdx abeqk.gx $endif + $ifolder (ak/abgei.x, abge.gx ) $(GA) -t csilrdx abge.gx $endif + $ifolder (ak/abgeki.x, abgek.gx) $(GA) -t csilrdx abgek.gx $endif + $ifolder (ak/abgti.x, abgt.gx ) $(GA) -t csilrdx abgt.gx $endif + $ifolder (ak/abgtki.x, abgtk.gx) $(GA) -t csilrdx abgtk.gx $endif + $ifolder (ak/ablei.x, able.gx ) $(GA) -t csilrdx able.gx $endif + $ifolder (ak/ableki.x, ablek.gx) $(GA) -t csilrdx ablek.gx $endif + $ifolder (ak/ablti.x, ablt.gx ) $(GA) -t csilrdx ablt.gx $endif + $ifolder (ak/abltki.x, abltk.gx) $(GA) -t csilrdx abltk.gx $endif + $ifolder (ak/abnei.x, abne.gx ) $(GA) -t csilrdx abne.gx $endif + $ifolder (ak/abneki.x, abnek.gx) $(GA) -t csilrdx abnek.gx $endif + $ifolder (ak/abori.x, abor.gx ) $(GA) -t sil abor.gx $endif + $ifolder (ak/aborki.x, abork.gx) $(GA) -t sil abork.gx $endif + $ifolder (ak/aclri.x, aclr.gx ) $(GA) -t csilrdx aclr.gx $endif + $ifolder (ak/acnvi.x, acnv.gx ) $(GA) -t silrd acnv.gx $endif + $ifolder (ak/acnvri.x, acnvr.gx) $(GA) -t silrd acnvr.gx $endif + $ifolder (ak/adivi.x, adiv.gx ) $(GA) -t silrdx adiv.gx $endif + $ifolder (ak/adivki.x, adivk.gx) $(GA) -t silrdx adivk.gx $endif + $ifolder (ak/adoti.x, adot.gx ) $(GA) -t silrdx adot.gx $endif + $ifolder (ak/advzi.x, advz.gx ) $(GA) -t silrdx advz.gx $endif + $ifolder (ak/aexpi.x, aexp.gx ) $(GA) -t silrdx aexp.gx $endif + $ifolder (ak/aexpki.x, aexpk.gx) $(GA) -t silrdx aexpk.gx $endif + $ifolder (ak/aglti.x, aglt.gx ) $(GA) -t csilrdx aglt.gx $endif + $ifolder (ak/ahgmi.x, ahgm.gx ) $(GA) -t csilrd ahgm.gx $endif + $ifolder (ak/ahivi.x, ahiv.gx ) $(GA) -t csilrdx ahiv.gx $endif + $ifolder (ak/aimgi.x, aimg.gx ) $(GA) -t silrd aimg.gx $endif + $ifolder (lz/alani.x, alan.gx ) $(GL) -t sil alan.gx $endif + $ifolder (lz/alanki.x, alank.gx) $(GL) -t sil alank.gx $endif + $ifolder (lz/alimi.x, alim.gx ) $(GL) -t csilrdx alim.gx $endif + $ifolder (lz/allni.x, alln.gx ) $(GL) -t silrdx alln.gx $endif + $ifolder (lz/alogi.x, alog.gx ) $(GL) -t silrdx alog.gx $endif + $ifolder (lz/alori.x, alor.gx ) $(GL) -t sil alor.gx $endif + $ifolder (lz/alorki.x, alork.gx) $(GL) -t sil alork.gx $endif + $ifolder (lz/alovi.x, alov.gx ) $(GL) -t csilrdx alov.gx $endif + $ifolder (lz/altai.x, alta.gx ) $(GL) -t silrdx alta.gx $endif + $ifolder (lz/altmi.x, altm.gx ) $(GL) -t silrdx altm.gx $endif + $ifolder (lz/altri.x, altr.gx ) $(GL) -t silrdx altr.gx $endif + $ifolder (lz/aluii.x, alui.gx ) $(GL) -t silrd alui.gx $endif + $ifolder (lz/aluti.x, alut.gx ) $(GL) -t csilrd alut.gx $endif + $ifolder (lz/amagi.x, amag.gx ) $(GL) -t silrdx amag.gx $endif + $ifolder (lz/amapi.x, amap.gx ) $(GL) -t silrd amap.gx $endif + $ifolder (lz/amaxi.x, amax.gx ) $(GL) -t csilrdx amax.gx $endif + $ifolder (lz/amaxki.x, amaxk.gx) $(GL) -t csilrdx amaxk.gx $endif + $ifolder (lz/amedi.x, amed.gx ) $(GL) -t csilrdx amed.gx $endif + $ifolder (lz/amed3i.x, amed3.gx) $(GL) -t csilrd amed3.gx $endif + $ifolder (lz/amed4i.x, amed4.gx) $(GL) -t csilrd amed4.gx $endif + $ifolder (lz/amed5i.x, amed5.gx) $(GL) -t csilrd amed5.gx $endif + $ifolder (lz/amgsi.x, amgs.gx ) $(GL) -t silrdx amgs.gx $endif + $ifolder (lz/amini.x, amin.gx ) $(GL) -t csilrdx amin.gx $endif + $ifolder (lz/aminki.x, amink.gx) $(GL) -t csilrdx amink.gx $endif + $ifolder (lz/amodi.x, amod.gx ) $(GL) -t silrd amod.gx $endif + $ifolder (lz/amodki.x, amodk.gx) $(GL) -t silrd amodk.gx $endif + $ifolder (lz/amovi.x, amov.gx ) $(GL) -t csilrdx amov.gx $endif + $ifolder (lz/amovki.x, amovk.gx) $(GL) -t csilrdx amovk.gx $endif + $ifolder (lz/amuli.x, amul.gx ) $(GL) -t silrdx amul.gx $endif + $ifolder (lz/amulki.x, amulk.gx) $(GL) -t silrdx amulk.gx $endif + $ifolder (lz/anegi.x, aneg.gx ) $(GL) -t silrdx aneg.gx $endif + $ifolder (lz/anoti.x, anot.gx ) $(GL) -t sil anot.gx $endif + $ifolder (lz/apkxi.x, apkx.gx ) $(GL) -t silrdx apkx.gx $endif + $ifolder (lz/apolr.x, apol.gx ) $(GL) -t rd apol.gx $endif + $ifolder (lz/apowi.x, apow.gx ) $(GL) -t silrdx apow.gx $endif + $ifolder (lz/apowki.x, apowk.gx) $(GL) -t silrdx apowk.gx $endif + $ifolder (lz/aravi.x, arav.gx ) $(GL) -t silrdx arav.gx $endif + $ifolder (lz/arcpi.x, arcp.gx ) $(GL) -t silrdx arcp.gx $endif + $ifolder (lz/arczi.x, arcz.gx ) $(GL) -t silrdx arcz.gx $endif + $ifolder (lz/argti.x, argt.gx ) $(GL) -t silrdx argt.gx $endif + $ifolder (lz/arlti.x, arlt.gx ) $(GL) -t silrdx arlt.gx $endif + $ifolder (lz/aseli.x, asel.gx ) $(GL) -t csilrdx asel.gx $endif + $ifolder (lz/aselki.x, aselk.gx) $(GL) -t csilrdx aselk.gx $endif + $ifolder (lz/asoki.x, asok.gx ) $(GL) -t csilrdx asok.gx $endif + $ifolder (lz/asqri.x, asqr.gx ) $(GL) -t silrdx asqr.gx $endif + $ifolder (lz/asrti.x, asrt.gx ) $(GL) -t csilrdx asrt.gx $endif + $ifolder (lz/assqi.x, assq.gx ) $(GL) -t silrdx assq.gx $endif + $ifolder (lz/asubi.x, asub.gx ) $(GL) -t silrdx asub.gx $endif + $ifolder (lz/asubki.x, asubk.gx) $(GL) -t silrdx asubk.gx $endif + $ifolder (lz/asumi.x, asum.gx ) $(GL) -t silrdx asum.gx $endif + $ifolder (lz/aupxi.x, aupx.gx ) $(GL) -t silrdx aupx.gx $endif + $ifolder (lz/aveqi.x, aveq.gx ) $(GL) -t csilrdx aveq.gx $endif + $ifolder (lz/awsui.x, awsu.gx ) $(GL) -t silrdx awsu.gx $endif + $ifolder (lz/awvgi.x, awvg.gx ) $(GL) -t silrdx awvg.gx $endif + $ifolder (lz/axori.x, axor.gx ) $(GL) -t sil axor.gx $endif + $ifolder (lz/axorki.x, axork.gx) $(GL) -t sil axork.gx $endif + ; + +libvops.a: + $ifeq (USE_GENERIC, yes) $call tfiles $endif + $set XFLAGS = "$(XVFLAGS)" + @ak + @lz + @achtgen # acht conversion matrix + fftr.f + fftx.f + ; diff --git a/sys/vops/vops.calls b/sys/vops/vops.calls new file mode 100644 index 00000000..9798b80b --- /dev/null +++ b/sys/vops/vops.calls @@ -0,0 +1,106 @@ +aabs 3 aabs.gx procedure aabs$t (a, b, npix) +aadd 3 aadd.gx procedure aadd$t (a, b, c, npix) +aaddk 3 aaddk.gx procedure aaddk$t (a, b, c, npix) +aand 3 aand.gx procedure aand$t (a, b, c, npix) +aandk 4 aandk.gx procedure aandk$t (a, b, c, npix) +aavg 4 aavg.gx procedure aavg$t (a, npix, mean, sigma) +abav 5 abav.gx procedure abav$t (a, b, nblocks, npix_per_block) +abeq 4 abeq.gx procedure abeq$t (a, b, c, npix) +abeqk 4 abeqk.gx procedure abeqk$t (a, b, c, npix) +abge 4 abge.gx procedure abge$t (a, b, c, npix) +abgek 4 abgek.gx procedure abgek$t (a, b, c, npix) +abgt 4 abgt.gx procedure abgt$t (a, b, c, npix) +abgtk 4 abgtk.gx procedure abgtk$t (a, b, c, npix) +able 4 able.gx procedure able$t (a, b, c, npix) +ablek 4 ablek.gx procedure ablek$t (a, b, c, npix) +ablt 4 ablt.gx procedure ablt$t (a, b, c, npix) +abltk 4 abltk.gx procedure abltk$t (a, b, c, npix) +abne 4 abne.gx procedure abne$t (a, b, c, npix) +abnek 4 abnek.gx procedure abnek$t (a, b, c, npix) +abor 3 abor.gx procedure abor$t (a, b, c, npix) +abork 4 abork.gx procedure abork$t (a, b, c, npix) +absu 5 absu.gx procedure absu$t (a, b, nblocks, npix_per_block) +acht 5 acht.gx procedure acht$t$$t (a, b, npix) +acjgx 3 acjgx.x procedure acjgx (a, b, npix) +aclr 3 aclr.gx procedure aclr$t (a, npix) +acnv 16 acnv.gx procedure acnv$t (in, out, npix, kernel, knpix) +acnvr 17 acnvr.gx procedure acnvr$t (in, out, npix, kernel, knpix) +adiv 4 adiv.gx procedure adiv$t (a, b, c, npix) +adivk 4 adivk.gx procedure adivk$t (a, b, c, npix) +adot 7 adot.gx real procedure adot$t (a, b, npix) +adot 5 adot.gx double procedure adot$t (a, b, npix) +advz 11 advz.gx procedure advz$t (a, b, c, npix, errfcn) +aexp 3 aexp.gx procedure aexp$t (a, b, c, npix) +aexpk 3 aexpk.gx procedure aexpk$t (a, b, c, npix) +afftrr 8 afftrr.x procedure afftrr (sr, si, fr, fi, npix) +afftrx 16 afftrx.x procedure afftrx (a, b, npix) +afftxr 7 afftxr.x procedure afftxr (sr, si, fr, fi, npix) +afftxx 7 afftxx.x procedure afftxx (a, b, npix) +aglt 6 aglt.gx procedure aglt$t (a,b,npix,low,high,kmul,kadd,nrange) +ahgm 6 ahgm.gx procedure ahgm$t (data, npix, hgm, nbins, z1, z2) +ahiv 3 ahiv.gx PIXEL procedure ahiv$t (a, npix) +aiftrr 8 aiftrr.x procedure aiftrr (fr, fi, sr, si, npix) +aiftrx 14 aiftrx.x procedure aiftrx (a, b, npix) +aiftxr 7 aiftxr.x procedure aiftxr (fr, fi, sr, si, npix) +aiftxx 14 aiftxx.x procedure aiftxx (a, b, npix) +aimg 3 aimg.gx procedure aimg$t (a, b, npix) +alan 3 alan.gx procedure alan$t (a, b, c, npix) +alank 3 alank.gx procedure alank$t (a, b, c, npix) +alor 3 alor.gx procedure alor$t (a, b, c, npix) +alork 3 alork.gx procedure alork$t (a, b, c, npix) +alim 3 alim.gx procedure alim$t (a, npix, minval, maxval) +alln 5 alln.gx procedure alln$t (a, b, npix, errfcn) +alog 5 alog.gx procedure alog$t (a, b, npix, errfcn) +alov 3 alov.gx PIXEL procedure alov$t (a, npix) +alta 4 alta.gx procedure alta$t (a, b, npix, k1, k2) +altm 4 altm.gx procedure altm$t (a, b, npix, k1, k2) +altr 5 altr.gx procedure altr$t (a, b, npix, k1, k2, k3) +alui 10 alui.gx procedure alui$t (a, b, x, npix) +alut 5 alut.gx procedure alut$t (a, b, npix, lut) +amag 3 amag.gx procedure amag$t (a, b, c, npix) +amap 5 amap.gx procedure amap$t (a, b, npix, a1, a2, b1, b2) +amax 3 amax.gx procedure amax$t (a, b, c, npix) +amaxk 3 amaxk.gx procedure amaxk$t (a, b, c, npix) +amed 6 amed.gx PIXEL procedure amed$t (a, npix) +amed3 4 amed3.gx procedure amed3$t (a, b, c, m, npix) +amed4 6 amed4.gx procedure amed4$t (a, b, c, d, m, npix) +amed5 5 amed5.gx procedure amed5$t (a, b, c, d, e, m, npix) +amgs 3 amgs.gx procedure amgs$t (a, b, c, npix) +amin 3 amin.gx procedure amin$t (a, b, c, npix) +amink 3 amink.gx procedure amink$t (a, b, c, npix) +amod 3 amod.gx procedure amod$t (a, b, c, npix) +amodk 3 amodk.gx procedure amodk$t (a, b, c, npix) +amov 5 amov.gx procedure amov$t (a, b, npix) +amovk 3 amovk.gx procedure amovk$t (a, b, npix) +amul 3 amul.gx procedure amul$t (a, b, c, npix) +amulk 3 amulk.gx procedure amulk$t (a, b, c, npix) +aneg 3 aneg.gx procedure aneg$t (a, b, npix) +anot 3 anot.gx procedure anot$t (a, b, npix) +apkx 4 apkx.gx procedure apkx$t (a, b, c, npix) +apol 4 apol.gx PIXEL procedure apol$t (x, coeff, ncoeff) +apow 3 apow.gx procedure apow$t (a, b, c, npix) +apowk 3 apowk.gx procedure apowk$t (a, b, c, npix) +arav 10 arav.gx int procedure arav$t (a, npix, mean, sigma, ksig) +arcp 4 arcp.gx procedure arcp$t (a, b, c, npix) +arcz 11 arcz.gx procedure arcz$t (a, b, c, npix, errfcn) +argt 4 argt.gx procedure argt$t (a, npix, ceil, newval) +arlt 3 arlt.gx procedure arlt$t (a, npix, floor, newval) +asel 6 asel.gx procedure asel$t (a, b, c, sel, npix) +aselk 6 aselk.gx procedure aselk$t (a, b, c, sel, npix) +asok 16 asok.gx PIXEL procedure asok$t (a, npix, ksel) +asqr 4 asqr.gx procedure asqr$t (a, b, npix, errfcn) +asrt 6 asrt.gx procedure asrt$t (a, b, npix) +assq 10 assq.gx PIXEL procedure assq$t (a, npix) +assq 4 assq.gx real procedure assq$t (a, npix) +assq 7 assq.gx double procedure assq$t (a, npix) +asub 3 asub.gx procedure asub$t (a, b, c, npix) +asubk 3 asubk.gx procedure asubk$t (a, b, c, npix) +asum 5 asum.gx real procedure asum$t (a, npix) +asum 7 asum.gx double procedure asum$t (a, npix) +asum 9 asum.gx PIXEL procedure asum$t (a, npix) +aupx 4 aupx.gx procedure aupx$t (a, b, c, npix) +aveq 3 aveq.gx bool procedure aveq$t (a, b, npix) +awsu 3 awsu.gx procedure awsu$t (a, b, c, npix, k1, k2) +awvg 7 awvg.gx int procedure awvg$t (a,npix,mean,sigma,lcut,hcut) +axor 3 axor.gx procedure axor$t (a, b, c, npix) +axork 3 axork.gx procedure axork$t (a, b, c, npix) diff --git a/sys/vops/vops.men b/sys/vops/vops.men new file mode 100644 index 00000000..2d75d60f --- /dev/null +++ b/sys/vops/vops.men @@ -0,0 +1,94 @@ + aabs - Absolute value of a vector + aadd - Add two vectors + aaddk - Add a vector and a scalar + aand - Bitwise boolean AND of two vectors + aandk - Bitwise boolean AND of a vector and a scalar + aavg - Compute the mean and standard deviation of a vector + abav - Block average a vector + abeq - Vector equals vector + abeqk - Vector equals scalar + abge - Vector greater than or equal to vector + abgek - Vector greater than or equal to scalar + abgt - Vector greater than vector + abgtk - Vector greater than scalar + able - Vector less than or equal to vector + ablek - Vector less than or equal to scalar + ablt - Vector less than vector + abltk - Vector less than scalar + abne - Vector not equal to vector + abnek - Vector not equal to scalar + abor - Bitwise boolean OR of two vectors + abork - Bitwise boolean OR of a vector and a scalar + absu - Block sum a vector + acht - Change datatype of a vector + acjgx - Complex conjugate of a complex vector + aclr - Clear (zero) a vector + acnv - Convolve two vectors + acnvr - Convolve a vector with a real kernel + adiv - Divide two vectors + adivk - Divide a vector by a scalar + adot - Dot product of two vectors + advz - Vector divide with divide by zero detection + aexp - Vector to a real vector exponent + aexpk - Vector to a real scalar exponent + afftr - Forward real discrete fourier transform + afftx - Forward complex discrete fourier transform + aglt - General piecewise linear transformation + ahgm - Accumulate the histogram of a series of vectors + ahiv - Compute the high (maximum) value of a vector + aiftr - Inverse real discrete fourier transform + aiftx - Inverse complex discrete fourier transform + aimg - Imaginary part of a complex vector + alan - Logical AND of two vectors + alank - Logical AND of a vector and a constant + alim - Compute the limits (minimum and maximum values) of a vector + alln - Natural logarithm of a vector + alog - Logarithm of a vector + alor - Logical OR of two vectors + alork - Logical OR of a vector and a constant + alov - Compute the low (minimum) value of a vector + altr - Linear transformation of a vector + alui - Vector lookup and interpolate (linear) + alut - Vector transform via lookup table + amag - Magnitude of two vectors (sqrt of sum of squares) + amap - Linear mapping of a vector with clipping + amax - Vector maximum of two vectors + amaxk - Vector maximum of a vector and a scalar + amed - Median value of a vector + amed3 - Vector median of three vectors + amed4 - Vector median of four vectors + amed5 - Vector median of five vectors + amgs - Magnitude squared of two vectors (sum of squares) + amin - Vector minimum of two vectors + amink - Vector minimum of a vector and a scalar + amod - Modulus of two vectors + amodk - Modulus of a vector and a scalar + amov - Move (copy or shift) a vector + amovk - Move a scalar into a vector + amul - Multiply two vectors + amulk - Multiply a vector and a scalar + aneg - Negate a vector (change the sign of each pixel) + anot - Bitwise boolean NOT of a vector + apkx - Pack a complex vector given the real and imaginary parts + apol - Polynomial evaluation + apow - Vector to an integer vector power + apowk - Vector to an integer scalar power + arav - Mean and standard deviation of a vector with pixel rejection + arcp - Reciprocal of a scalar and a vector + arcz - Reciprocal with detection of divide by zero + arlt - Vector replace pixel if less than scalar + argt - Vector replace pixel if greater than scalar + asel - Vector select from two vectors based on boolean flag vector + aselk - Vector select from vector/scalar based on boolean flag vector + asok - Selection of the Kth smallest element of a vector + asqr - Square root of a vector + asrt - Sort a vector in order of increasing pixel value + assq - Sum of squares of a vector + asub - Subtract two vectors + asubk - Subtract a scalar from a vector + asum - Sum of a vector + aupx - Unpack the real and imaginary parts of a complex vector + awsu - Weighted sum of two vectors + awvg - Mean and standard deviation of a windowed vector + axor - Bitwise boolean XOR (exclusive or) of two vectors + axork - Bitwise boolean XOR (exclusive or) of a vector and a scalar diff --git a/sys/vops/vops.syn b/sys/vops/vops.syn new file mode 100644 index 00000000..e54a3b5d --- /dev/null +++ b/sys/vops/vops.syn @@ -0,0 +1,96 @@ + aabs[_silrdx] (a, b, npix) + aadd[_silrdx] (a, b, c, npix) + aaddk[_silrdx] (a, b, c, npix) + aand[_sil___] (a, b, c, npix) + aandk[_sil___] (a, b, c, npix) + aavg[_silrdx] (a, npix, mean, sigma) + abav[_silrdx] (a, b, nblocks, npix_per_block) + abeq[csilrdx] (a, b, c, npix) + abeqk[csilrdx] (a, b, c, npix) + abge[csilrdx] (a, b, c, npix) + abgek[csilrdx] (a, b, c, npix) + abgt[csilrdx] (a, b, c, npix) + abgtk[csilrdx] (a, b, c, npix) + able[csilrdx] (a, b, c, npix) + ablek[csilrdx] (a, b, c, npix) + ablt[csilrdx] (a, b, c, npix) + abltk[csilrdx] (a, b, c, npix) + abne[csilrdx] (a, b, c, npix) + abnek[csilrdx] (a, b, c, npix) + abor[_sil___] (a, b, c, npix) + abork[_sil___] (a, b, c, npix) + absu[_silrd_] (a, b, nblocks, npix_per_block) + acht[UBcsilrdx][..] (a, b, npix) + acjg[______x] (a, b, npix) + aclr[Bcsilrdx] (a, npix) + acnv[_silrd_] (a, b, npix, kernel, kpix) + acnvr[_silrd_] (a, b, npix, kernel, kpix) + adiv[_silrdx] (a, b, c, npix) + adivk[_silrdx] (a, b, c, npix) + dot = adot[_silrdx] (a, b, npix) + advz[_silrdx] (a, b, c, npix, errfcn) + aexp[_silrdx] (a, b, c, npix) + aexpk[_silrdx] (a, b, c, npix) + afft[rx]x (s, f, npix) + afft[rx]r (sr, si, fr, fi, npix) + aglt[csilrdx] (a, b, npix, low, high, kmul, kadd, nrange) + ahgm[csilrd_] (a, npix, hgm, nbins, z1, z2) + hival = ahiv[csilrdx] (a, npix) + aift[rx]r (fr, fi, sr, si, npix) + aift[rx]x (f, s, npix) + aimg[_silrd_] (a, b, npix) + alan[_sil___] (a, b, c, npix) + alank[_sil___] (a, b, c, npix) + alim[csilrdx] (a, npix, minval, maxval) + alln[_silrdx] (a, b, npix, errfcn) + alog[_silrdx] (a, b, npix, errfcn) + alor[_sil___] (a, b, c, npix) + alork[_sil___] (a, b, c, npix) + loval = alov[csilrdx] (a, npix) + altr[_silrdx] (a, b, npix, k1, k2, k3) + alta[_silrdx] (a, b, npix, k1, k2) + altm[_silrdx] (a, b, npix, k1, k2) + alui[_silrd_] (a, b, x, npix) + alut[csil___] (a, b, nchar, lut) + amag[_silrdx] (a, b, c, npix) + amap[_silrd_] (a, b, npix, a1, a2, b1, b2) + amax[csilrdx] (a, b, c, npix) + amaxk[csilrdx] (a, b, c, npix) + med = amed[csilrdx] (a, npix) + amed3[csilrd_] (a, b, c, med, npix) + amed4[csilrd_] (a, b, c, d, med, npix) + amed5[csilrd_] (a, b, c, d, e, med, npix) + amgs[_silrdx] (a, b, c, npix) + amin[csilrdx] (a, b, c, npix) + amink[csilrdx] (a, b, c, npix) + amod[_silrd_] (a, b, c, npix) + amodk[_silrd_] (a, b, c, npix) + amov[csilrdx] (a, b, npix) + amovk[csilrdx] (a, b, npix) + amul[_silrdx] (a, b, c, npix) + amulk[_silrdx] (a, b, c, npix) + aneg[_silrdx] (a, b, npix) + anot[_sil___] (a, b, npix) + apkx[_silrdx] (a, b, c, npix) + y(x) = apol[____rd_] (x, coeff, ncoeff) + apow[_silrdx] (a, b, c, npix) + apowk[_silrdx] (a, b, c, npix) + ngpix = arav[_silrdx] (a, npix, mean, sigma, ksig) + arcp[_silrdx] (a, b, c, npix) + arcz[_silrdx] (a, b, c, npix, errfcn) + arlt[_silrdx] (a, npix, floor, newval) + argt[_silrdx] (a, npix, ceil, newval) + asel[csilrdx] (a, b, c, sel, npix) + aselk[csilrdx] (a, b, c, sel, npix) + asok[csilrdx] (a, npix, ksel) + asqr[_silrdx] (a, b, npix, errfcn) + asrt[csilrdx] (a, b, npix) + ssqrs = assq[_silrdx] (a, npix) + asub[_silrdx] (a, b, c, npix) + asubk[_silrdx] (a, b, c, npix) + sum = asum[_silrdx] (a, npix) + aupx[_silrdx] (a, b, c, npix) + awsu[_silrdx] (a, b, c, npix, k1, k2) + ngpix = awvg[_silrdx] (a, npix, mean, sigma, lcut, hcut) + axor[_sil___] (a, b, c, npix) + axork[_sil___] (a, b, c, npix) diff --git a/sys/vops/zzdebug.x b/sys/vops/zzdebug.x new file mode 100644 index 00000000..cdbc5757 --- /dev/null +++ b/sys/vops/zzdebug.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task xft + +define MAXPIX 4096 + +# XFT -- Test complex transform routines. + +procedure xft + +complex x[MAXPIX] +int npix, ntrip +long seed +int i, clgeti() +real urand() + +begin + npix = max(1, min(MAXPIX, clgeti ("npix"))) + ntrip = clgeti ("ntrip") + seed = 1 + + do i = 1, NPIX + x[i] = complex (urand(seed), urand(seed)) + + do i = 1, ntrip { + call afftx (x, x, NPIX) + call aiftx (x, x, NPIX) + } +end |