diff options
Diffstat (limited to 'pkg/images/imutil/src')
59 files changed, 21528 insertions, 0 deletions
diff --git a/pkg/images/imutil/src/generic/imaadd.x b/pkg/images/imutil/src/generic/imaadd.x new file mode 100644 index 00000000..cd492467 --- /dev/null +++ b/pkg/images/imutil/src/generic/imaadd.x @@ -0,0 +1,255 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_adds (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) { + if (a == 0) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call aaddks (Mems[buf[2]], a, Mems[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 0) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call aaddks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call aadds (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addi (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) { + if (a == 0) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call aaddki (Memi[buf[2]], a, Memi[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 0) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call aaddki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call aaddi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) { + if (a == 0) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call aaddkl (Meml[buf[2]], a, Meml[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 0) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call aaddkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call aaddl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) { + if (a == 0.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call aaddkr (Memr[buf[2]], a, Memr[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 0.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call aaddkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call aaddr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addd (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) { + if (a == 0.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call aaddkd (Memd[buf[2]], a, Memd[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 0.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call aaddkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call aaddd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imadiv.x b/pkg/images/imutil/src/generic/imadiv.x new file mode 100644 index 00000000..1de8b194 --- /dev/null +++ b/pkg/images/imutil/src/generic/imadiv.x @@ -0,0 +1,347 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_DIV -- Image arithmetic division. + + +procedure ima_divs (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +short a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() +short ima_efncs() +extern ima_efncs + +short divzero +common /imadcoms/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) + call arczs (a, Mems[buf[2]], Mems[buf[1]], len, + ima_efncs) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 0) + call amovks (divzero, Mems[buf[1]], len) + else if (b == 1) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call adivks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call advzs (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], + len, ima_efncs) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +short procedure ima_efncs (a) + +short a +short divzero +common /imadcoms/ divzero + +begin + return (divzero) +end + +procedure ima_divi (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +int a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() +int ima_efnci() +extern ima_efnci + +int divzero +common /imadcomi/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) + call arczi (a, Memi[buf[2]], Memi[buf[1]], len, + ima_efnci) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 0) + call amovki (divzero, Memi[buf[1]], len) + else if (b == 1) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call adivki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call advzi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], + len, ima_efnci) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +int procedure ima_efnci (a) + +int a +int divzero +common /imadcomi/ divzero + +begin + return (divzero) +end + +procedure ima_divl (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +long a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() +long ima_efncl() +extern ima_efncl + +long divzero +common /imadcoml/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) + call arczl (a, Meml[buf[2]], Meml[buf[1]], len, + ima_efncl) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 0) + call amovkl (divzero, Meml[buf[1]], len) + else if (b == 1) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call adivkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call advzl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], + len, ima_efncl) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +long procedure ima_efncl (a) + +long a +long divzero +common /imadcoml/ divzero + +begin + return (divzero) +end + +procedure ima_divr (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +real a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() +real ima_efncr() +extern ima_efncr + +real divzero +common /imadcomr/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) + call arczr (a, Memr[buf[2]], Memr[buf[1]], len, + ima_efncr) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 0.0) + call amovkr (divzero, Memr[buf[1]], len) + else if (b == 1.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call adivkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call advzr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], + len, ima_efncr) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +real procedure ima_efncr (a) + +real a +real divzero +common /imadcomr/ divzero + +begin + return (divzero) +end + +procedure ima_divd (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +double a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() +double ima_efncd() +extern ima_efncd + +double divzero +common /imadcomd/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) + call arczd (a, Memd[buf[2]], Memd[buf[1]], len, + ima_efncd) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 0.0D0) + call amovkd (divzero, Memd[buf[1]], len) + else if (b == 1.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call adivkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call advzd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], + len, ima_efncd) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +double procedure ima_efncd (a) + +double a +double divzero +common /imadcomd/ divzero + +begin + return (divzero) +end + diff --git a/pkg/images/imutil/src/generic/imamax.x b/pkg/images/imutil/src/generic/imamax.x new file mode 100644 index 00000000..36fec944 --- /dev/null +++ b/pkg/images/imutil/src/generic/imamax.x @@ -0,0 +1,212 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_MAX -- Image arithmetic maximum value. + + +procedure ima_maxs (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) + call amaxks (Mems[buf[2]], a, Mems[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) + call amaxks (Mems[buf[2]], b, Mems[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call amaxs (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_maxi (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) + call amaxki (Memi[buf[2]], a, Memi[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) + call amaxki (Memi[buf[2]], b, Memi[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call amaxi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_maxl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) + call amaxkl (Meml[buf[2]], a, Meml[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) + call amaxkl (Meml[buf[2]], b, Meml[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call amaxl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_maxr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) + call amaxkr (Memr[buf[2]], a, Memr[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) + call amaxkr (Memr[buf[2]], b, Memr[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call amaxr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_maxd (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) + call amaxkd (Memd[buf[2]], a, Memd[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) + call amaxkd (Memd[buf[2]], b, Memd[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call amaxd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imamin.x b/pkg/images/imutil/src/generic/imamin.x new file mode 100644 index 00000000..5124db41 --- /dev/null +++ b/pkg/images/imutil/src/generic/imamin.x @@ -0,0 +1,212 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_MIN -- Image arithmetic minimum value. + + +procedure ima_mins (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) + call aminks (Mems[buf[2]], a, Mems[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) + call aminks (Mems[buf[2]], b, Mems[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call amins (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_mini (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) + call aminki (Memi[buf[2]], a, Memi[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) + call aminki (Memi[buf[2]], b, Memi[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call amini (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_minl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) + call aminkl (Meml[buf[2]], a, Meml[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) + call aminkl (Meml[buf[2]], b, Meml[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call aminl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_minr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) + call aminkr (Memr[buf[2]], a, Memr[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) + call aminkr (Memr[buf[2]], b, Memr[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call aminr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_mind (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) + call aminkd (Memd[buf[2]], a, Memd[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) + call aminkd (Memd[buf[2]], b, Memd[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call amind (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imamul.x b/pkg/images/imutil/src/generic/imamul.x new file mode 100644 index 00000000..05fdf8a4 --- /dev/null +++ b/pkg/images/imutil/src/generic/imamul.x @@ -0,0 +1,257 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_MUL -- Image arithmetic multiplication. + + +procedure ima_muls (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) { + if (a == 1) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call amulks (Mems[buf[2]], a, Mems[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 1) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call amulks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call amuls (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_muli (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) { + if (a == 1) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call amulki (Memi[buf[2]], a, Memi[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 1) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call amulki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call amuli (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_mull (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) { + if (a == 1) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call amulkl (Meml[buf[2]], a, Meml[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 1) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call amulkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call amull (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_mulr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) { + if (a == 1.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call amulkr (Memr[buf[2]], a, Memr[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 1.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call amulkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call amulr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_muld (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) { + if (a == 1.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call amulkd (Memd[buf[2]], a, Memd[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 1.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call amulkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call amuld (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imanl.x b/pkg/images/imutil/src/generic/imanl.x new file mode 100644 index 00000000..8ec958c4 --- /dev/null +++ b/pkg/images/imutil/src/generic/imanl.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_NL -- For each line in the output image lines from the input images +# are returned. The input images are repeated as necessary. EOF is returned +# when the last line of the output image has been reached. One dimensional +# images are read only once and the data pointers are assumed to be unchanged +# from previous calls. The image line vectors must be initialized externally +# and then left untouched. +# +# This procedure is typically used when operations upon lines or pixels +# make sense in mixed dimensioned images. For example to add a one dimensional +# image to all lines of a higher dimensional image or to subtract a +# two dimensional image from all bands of three dimensional image. +# The lengths of the common dimensions should generally be checked +# for equality with xt_imleneq. + + +int procedure ima_nls (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnls(), imgnls() + +begin + if (impnls (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnls (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnls (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nli (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnli(), imgnli() + +begin + if (impnli (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnli (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnli (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nll (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnll(), imgnll() + +begin + if (impnll (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnll (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnll (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nlr (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnlr(), imgnlr() + +begin + if (impnlr (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnlr (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnlr (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nld (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnld(), imgnld() + +begin + if (impnld (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnld (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnld (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + diff --git a/pkg/images/imutil/src/generic/imasub.x b/pkg/images/imutil/src/generic/imasub.x new file mode 100644 index 00000000..1a0fcb2c --- /dev/null +++ b/pkg/images/imutil/src/generic/imasub.x @@ -0,0 +1,252 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_SUB -- Image arithmetic subtraction. + + +procedure ima_subs (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) { + if (a != 0) { + call asubks (Mems[buf[2]], a, Mems[buf[1]], len) + call anegs (Mems[buf[1]], Mems[buf[1]], len) + } else + call anegs (Mems[buf[2]], Mems[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 0) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call asubks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call asubs (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_subi (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) { + if (a != 0) { + call asubki (Memi[buf[2]], a, Memi[buf[1]], len) + call anegi (Memi[buf[1]], Memi[buf[1]], len) + } else + call anegi (Memi[buf[2]], Memi[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 0) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call asubki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call asubi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_subl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) { + if (a != 0) { + call asubkl (Meml[buf[2]], a, Meml[buf[1]], len) + call anegl (Meml[buf[1]], Meml[buf[1]], len) + } else + call anegl (Meml[buf[2]], Meml[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 0) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call asubkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call asubl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_subr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) { + if (a != 0.0) { + call asubkr (Memr[buf[2]], a, Memr[buf[1]], len) + call anegr (Memr[buf[1]], Memr[buf[1]], len) + } else + call anegr (Memr[buf[2]], Memr[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 0.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call asubkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call asubr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_subd (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) { + if (a != 0.0D0) { + call asubkd (Memd[buf[2]], a, Memd[buf[1]], len) + call anegd (Memd[buf[1]], Memd[buf[1]], len) + } else + call anegd (Memd[buf[2]], Memd[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 0.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call asubkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call asubd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imfuncs.x b/pkg/images/imutil/src/generic/imfuncs.x new file mode 100644 index 00000000..67bc4ed5 --- /dev/null +++ b/pkg/images/imutil/src/generic/imfuncs.x @@ -0,0 +1,1613 @@ +include <imhdr.h> +include <mach.h> +include <math.h> + + + +# IF_LOG10 -- Compute the base 10 logarithm of image1 and write the results to +# image2. + +procedure if_log10r (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +real if_elogr() +extern if_elogr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call alogr (Memr[buf1], Memr[buf2], npix, if_elogr) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +real procedure if_elogr (x) + +real x # the input pixel value + +begin + return (real(-MAX_EXPONENT)) +end + + +# IF_ALOG10 -- Take the power of 10 of image1 and write the results to image2. + +procedure if_alog10r (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_va10r (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VA10 -- Take the antilog (base 10) of a vector. + +procedure if_va10r (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of points + +int i +real maxexp, maxval + +begin + maxexp = MAX_EXPONENT + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= (-maxexp)) + b[i] = 0.0 + else + b[i] = 10.0 ** a[i] + } +end + + +# IF_LN -- Take the natural log of the pixels in image1 and write the results +# to image2. + +procedure if_lnr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 + +real if_elnr() +extern if_elnr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call allnr (Memr[buf1], Memr[buf2], npix, if_elnr) +end + + +# IF_ELN -- The error function for the natural logarithm. + +real procedure if_elnr (x) + +real x # input value + +begin + return (real (LN_10) * real(-MAX_EXPONENT)) +end + + +# IF_ALN -- Take the natural antilog of the pixels in image1 and write the +# results to image2. + +procedure if_alnr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_valnr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VALN -- Take the natural antilog of a vector. + +procedure if_valnr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real maxexp, maxval, eval + +begin + maxexp = log (10.0 ** real (MAX_EXPONENT)) + maxval = MAX_REAL + eval = real (BASE_E) + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = 0.0 + else + b[i] = eval ** a[i] + } +end + + +# IF_SQR -- Take the square root of pixels in image1 and write the results +# to image2. + +procedure if_sqrr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +real if_esqrr() +extern if_esqrr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call asqrr (Memr[buf1], Memr[buf2], npix, if_esqrr) +end + + +# IF_ESQR -- Error function for the square root. + +real procedure if_esqrr (x) + +real x # input value + +begin + return (0.0) +end + + +# IF_SQUARE -- Take the square of the pixels in image1 and write to image2. +procedure if_squarer (im1, im2) + +pointer im1 # the input image pointer +pointer im2 # the output image pointer + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call apowkr (Memr[buf1], 2, Memr[buf2], npix) +end + + +# IF_CBRT -- Take the cube root of the pixels in image1 and write the results +# to image2. + +procedure if_cbrtr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vcbrtr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VCBRT -- Compute the cube root of a vector. + +procedure if_vcbrtr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real onethird + +begin + onethird = 1.0 / 3.0 + do i = 1, n { + if (a[i] >= 0.0) { + b[i] = a[i] ** onethird + } else { + b[i] = -a[i] + b[i] = - (b[i] ** onethird) + } + } +end + + +# IF_CUBE -- Take the cube of the pixels in image1 and write the results to +# image2. + +procedure if_cuber (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call apowkr (Memr[buf1], 3, Memr[buf2], npix) +end + + +# IF_COS -- Take cosine of pixels in image1 and write the results to image2. + +procedure if_cosr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vcosr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VCOS - Compute the cosine of a vector. + +procedure if_vcosr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = cos(a[i]) +end + + +# IF_SIN -- Take sine of the pixels in image1 and write the results to image2. + +procedure if_sinr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vsinr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VSIN - Take the sine of a vector. + +procedure if_vsinr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = sin(a[i]) +end + + +# IF_TAN -- Take tangent of pixels in image1 and write the results to image2. + +procedure if_tanr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vtanr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VTAN - Take the tangent of a vector. + +procedure if_vtanr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tan(a[i]) +end + + +# IF_ACOS -- Take arccosine of pixels in image1 and write the results to image2. + +procedure if_acosr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vacosr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VACOS - Take the arccosine of a vector. + +procedure if_vacosr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n { + if (a[i] > 1.0) + b[i] = acos (1.0) + else if (a[i] < -1.0) + b[i] = acos (-1.0) + else + b[i] = acos(a[i]) + } +end + + +# IF_ASIN -- Take arcsine of pixels in image1 and write the results to image2. + +procedure if_asinr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vasinr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VASIN - Take arcsine of vector + +procedure if_vasinr (a, b, n) + +real a[n] +real b[n] +int n + +int i + +begin + do i = 1, n { + if (a[i] > 1.0) + b[i] = asin (1.0) + else if (a[i] < -1.0) + b[i] = asin (-1.0) + else + b[i] = asin(a[i]) + } +end + + +# IF_ATAN -- Take arctangent of pixels in image1 and write the results to +# image2. + +procedure if_atanr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vatanr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VATAN - Take the arctangent of a vector. + +procedure if_vatanr (a, b, n) + +real a[n] +real b[n] +int n + +int i + +begin + do i = 1, n + b[i] = atan(a[i]) +end + + +# IF_HCOS -- Take the hyperbolic cosine of pixels in image1 and write the +# results to image2. + +procedure if_hcosr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vhcosr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VHCOS - Take the hyperbolic cosine of a vector. + +procedure if_vhcosr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real maxexp, maxval + +begin + maxexp = log (10.0 ** real(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (abs (a[i]) >= maxexp) + b[i] = maxval + else + b[i] = cosh (a[i]) + } +end + + +# IF_HSIN -- Take the hyperbolic sine of pixels in image1 and write the +# results to image2. + +procedure if_hsinr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vhsinr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VHSIN - Take the hyperbolic sine of a vector. + +procedure if_vhsinr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real maxexp, maxval + +begin + maxexp = log (10.0 ** real(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = -maxval + else + b[i] = sinh(a[i]) + } +end + + +# IF_HTAN -- Take the hyperbolic tangent of pixels in image1 and write the +# results to image2. + +procedure if_htanr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vhtanr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VHTAN - Take the hyperbolic tangent of a vector. + +procedure if_vhtanr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tanh(a[i]) +end + + +# IF_RECIP -- Take the reciprocal of the pixels in image1 and write the +# results to image2. + +procedure if_recipr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +real if_erecipr() +extern if_erecipr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call arczr (1.0, Memr[buf1], Memr[buf2], npix, if_erecipr) +end + + +# IF_ERECIP -- Error function for the reciprocal computation. + +real procedure if_erecipr (x) + +real x + +begin + return (0.0) +end + + + +# IF_LOG10 -- Compute the base 10 logarithm of image1 and write the results to +# image2. + +procedure if_log10d (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +double if_elogd() +extern if_elogd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call alogd (Memd[buf1], Memd[buf2], npix, if_elogd) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +double procedure if_elogd (x) + +double x # the input pixel value + +begin + return (double(-MAX_EXPONENT)) +end + + +# IF_ALOG10 -- Take the power of 10 of image1 and write the results to image2. + +procedure if_alog10d (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_va10d (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VA10 -- Take the antilog (base 10) of a vector. + +procedure if_va10d (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of points + +int i +double maxexp, maxval + +begin + maxexp = MAX_EXPONENT + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= (-maxexp)) + b[i] = 0.0D0 + else + b[i] = 10.0D0 ** a[i] + } +end + + +# IF_LN -- Take the natural log of the pixels in image1 and write the results +# to image2. + +procedure if_lnd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 + +double if_elnd() +extern if_elnd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call allnd (Memd[buf1], Memd[buf2], npix, if_elnd) +end + + +# IF_ELN -- The error function for the natural logarithm. + +double procedure if_elnd (x) + +double x # input value + +begin + return (double (LN_10) * double(-MAX_EXPONENT)) +end + + +# IF_ALN -- Take the natural antilog of the pixels in image1 and write the +# results to image2. + +procedure if_alnd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_valnd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VALN -- Take the natural antilog of a vector. + +procedure if_valnd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double maxexp, maxval, eval + +begin + maxexp = log (10.0D0 ** double (MAX_EXPONENT)) + maxval = MAX_REAL + eval = double (BASE_E) + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = 0.0D0 + else + b[i] = eval ** a[i] + } +end + + +# IF_SQR -- Take the square root of pixels in image1 and write the results +# to image2. + +procedure if_sqrd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +double if_esqrd() +extern if_esqrd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call asqrd (Memd[buf1], Memd[buf2], npix, if_esqrd) +end + + +# IF_ESQR -- Error function for the square root. + +double procedure if_esqrd (x) + +double x # input value + +begin + return (0.0D0) +end + + +# IF_SQUARE -- Take the square of the pixels in image1 and write to image2. +procedure if_squared (im1, im2) + +pointer im1 # the input image pointer +pointer im2 # the output image pointer + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call apowkd (Memd[buf1], 2, Memd[buf2], npix) +end + + +# IF_CBRT -- Take the cube root of the pixels in image1 and write the results +# to image2. + +procedure if_cbrtd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vcbrtd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VCBRT -- Compute the cube root of a vector. + +procedure if_vcbrtd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double onethird + +begin + onethird = 1.0D0 / 3.0D0 + do i = 1, n { + if (a[i] >= 0.0D0) { + b[i] = a[i] ** onethird + } else { + b[i] = -a[i] + b[i] = - (b[i] ** onethird) + } + } +end + + +# IF_CUBE -- Take the cube of the pixels in image1 and write the results to +# image2. + +procedure if_cubed (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call apowkd (Memd[buf1], 3, Memd[buf2], npix) +end + + +# IF_COS -- Take cosine of pixels in image1 and write the results to image2. + +procedure if_cosd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vcosd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VCOS - Compute the cosine of a vector. + +procedure if_vcosd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = cos(a[i]) +end + + +# IF_SIN -- Take sine of the pixels in image1 and write the results to image2. + +procedure if_sind (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vsind (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VSIN - Take the sine of a vector. + +procedure if_vsind (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = sin(a[i]) +end + + +# IF_TAN -- Take tangent of pixels in image1 and write the results to image2. + +procedure if_tand (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vtand (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VTAN - Take the tangent of a vector. + +procedure if_vtand (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tan(a[i]) +end + + +# IF_ACOS -- Take arccosine of pixels in image1 and write the results to image2. + +procedure if_acosd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vacosd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VACOS - Take the arccosine of a vector. + +procedure if_vacosd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n { + if (a[i] > 1.0D0) + b[i] = acos (1.0D0) + else if (a[i] < -1.0D0) + b[i] = acos (-1.0D0) + else + b[i] = acos(a[i]) + } +end + + +# IF_ASIN -- Take arcsine of pixels in image1 and write the results to image2. + +procedure if_asind (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vasind (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VASIN - Take arcsine of vector + +procedure if_vasind (a, b, n) + +double a[n] +double b[n] +int n + +int i + +begin + do i = 1, n { + if (a[i] > 1.0D0) + b[i] = asin (1.0D0) + else if (a[i] < -1.0D0) + b[i] = asin (-1.0D0) + else + b[i] = asin(a[i]) + } +end + + +# IF_ATAN -- Take arctangent of pixels in image1 and write the results to +# image2. + +procedure if_atand (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vatand (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VATAN - Take the arctangent of a vector. + +procedure if_vatand (a, b, n) + +double a[n] +double b[n] +int n + +int i + +begin + do i = 1, n + b[i] = atan(a[i]) +end + + +# IF_HCOS -- Take the hyperbolic cosine of pixels in image1 and write the +# results to image2. + +procedure if_hcosd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vhcosd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VHCOS - Take the hyperbolic cosine of a vector. + +procedure if_vhcosd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double maxexp, maxval + +begin + maxexp = log (10.0D0 ** double(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (abs (a[i]) >= maxexp) + b[i] = maxval + else + b[i] = cosh (a[i]) + } +end + + +# IF_HSIN -- Take the hyperbolic sine of pixels in image1 and write the +# results to image2. + +procedure if_hsind (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vhsind (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VHSIN - Take the hyperbolic sine of a vector. + +procedure if_vhsind (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double maxexp, maxval + +begin + maxexp = log (10.0D0 ** double(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = -maxval + else + b[i] = sinh(a[i]) + } +end + + +# IF_HTAN -- Take the hyperbolic tangent of pixels in image1 and write the +# results to image2. + +procedure if_htand (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vhtand (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VHTAN - Take the hyperbolic tangent of a vector. + +procedure if_vhtand (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tanh(a[i]) +end + + +# IF_RECIP -- Take the reciprocal of the pixels in image1 and write the +# results to image2. + +procedure if_recipd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +double if_erecipd() +extern if_erecipd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call arczd (1.0, Memd[buf1], Memd[buf2], npix, if_erecipd) +end + + +# IF_ERECIP -- Error function for the reciprocal computation. + +double procedure if_erecipd (x) + +double x + +begin + return (0.0D0) +end + + + + + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_absl (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnll(), impnll() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnll (im1, buf1, v1) != EOF) && + (impnll (im2, buf2, v2) != EOF)) + call aabsl (Meml[buf1], Meml[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_negl (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnll(), impnll() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnll (im1, buf1, v1) != EOF) && + (impnll (im2, buf2, v2) != EOF)) + call anegl (Meml[buf1], Meml[buf2], npix) +end + + + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_absr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call aabsr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_negr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call anegr (Memr[buf1], Memr[buf2], npix) +end + + + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_absd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call aabsd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_negd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call anegd (Memd[buf1], Memd[buf2], npix) +end + + diff --git a/pkg/images/imutil/src/generic/imjoin.x b/pkg/images/imutil/src/generic/imjoin.x new file mode 100644 index 00000000..83b02541 --- /dev/null +++ b/pkg/images/imutil/src/generic/imjoin.x @@ -0,0 +1,527 @@ +include <imhdr.h> + +define VPTR Memi[$1+$2-1] # Array of axis vector pointers + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoins (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnls() +pointer impnls() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnls (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnls (in, inbuf, Meml[VPTR(vin,image)]) + call amovs (Mems[inbuf], Mems[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnls (out, outbuf, Meml[vout]) + stat = imgnls (in, inbuf, Meml[VPTR(vin,image)]) + call amovs (Mems[inbuf], Mems[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnls (out, outbuf, Meml[vout]) + stat = imgnls (in, inbuf, Meml[VPTR(vin,image)]) + call amovs (Mems[inbuf], Mems[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoini (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnli() +pointer impnli() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnli (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnli (in, inbuf, Meml[VPTR(vin,image)]) + call amovi (Memi[inbuf], Memi[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnli (out, outbuf, Meml[vout]) + stat = imgnli (in, inbuf, Meml[VPTR(vin,image)]) + call amovi (Memi[inbuf], Memi[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnli (out, outbuf, Meml[vout]) + stat = imgnli (in, inbuf, Meml[VPTR(vin,image)]) + call amovi (Memi[inbuf], Memi[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoinl (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnll() +pointer impnll() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnll (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnll (in, inbuf, Meml[VPTR(vin,image)]) + call amovl (Meml[inbuf], Meml[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnll (out, outbuf, Meml[vout]) + stat = imgnll (in, inbuf, Meml[VPTR(vin,image)]) + call amovl (Meml[inbuf], Meml[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnll (out, outbuf, Meml[vout]) + stat = imgnll (in, inbuf, Meml[VPTR(vin,image)]) + call amovl (Meml[inbuf], Meml[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoinr (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnlr() +pointer impnlr() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnlr (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnlr (in, inbuf, Meml[VPTR(vin,image)]) + call amovr (Memr[inbuf], Memr[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnlr (out, outbuf, Meml[vout]) + stat = imgnlr (in, inbuf, Meml[VPTR(vin,image)]) + call amovr (Memr[inbuf], Memr[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnlr (out, outbuf, Meml[vout]) + stat = imgnlr (in, inbuf, Meml[VPTR(vin,image)]) + call amovr (Memr[inbuf], Memr[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoind (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnld() +pointer impnld() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnld (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnld (in, inbuf, Meml[VPTR(vin,image)]) + call amovd (Memd[inbuf], Memd[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnld (out, outbuf, Meml[vout]) + stat = imgnld (in, inbuf, Meml[VPTR(vin,image)]) + call amovd (Memd[inbuf], Memd[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnld (out, outbuf, Meml[vout]) + stat = imgnld (in, inbuf, Meml[VPTR(vin,image)]) + call amovd (Memd[inbuf], Memd[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoinx (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnlx() +pointer impnlx() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnlx (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnlx (in, inbuf, Meml[VPTR(vin,image)]) + call amovx (Memx[inbuf], Memx[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnlx (out, outbuf, Meml[vout]) + stat = imgnlx (in, inbuf, Meml[VPTR(vin,image)]) + call amovx (Memx[inbuf], Memx[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnlx (out, outbuf, Meml[vout]) + stat = imgnlx (in, inbuf, Meml[VPTR(vin,image)]) + call amovx (Memx[inbuf], Memx[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + diff --git a/pkg/images/imutil/src/generic/imrep.x b/pkg/images/imutil/src/generic/imrep.x new file mode 100644 index 00000000..bcc29d0a --- /dev/null +++ b/pkg/images/imutil/src/generic/imrep.x @@ -0,0 +1,1423 @@ +include <imhdr.h> +include <mach.h> + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imreps (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real ilower +short floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnls(), impnls() + +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnls (im, buf2, v2) != EOF) + call amovks (newval, Mems[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = int (upper) + while (imgnls (im, buf1, v1) != EOF) { + junk = impnls (im, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + call arles (Mems[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + while (imgnls (im, buf1, v1) != EOF) { + junk = impnls (im, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + call arges (Mems[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + while (imgnls (im, buf1, v1) != EOF) { + junk = impnls (im, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + call areps (Mems[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrreps (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real ilower +short floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnls(), impnls() +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnls (im, buf2, v2) != EOF) + call amovks (newval, Mems[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_SHORT + ceil = int (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_SHORT + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_SHORT) + + while (imgnls (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Mems[buf1] + val2 = Mems[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Mems[ptr+l] = INDEFS + } + } + } else { + if (!IS_INDEFS(val2)) + Mems[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnls (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Mems[buf1] + if (IS_INDEFS(Mems[buf1])) + Mems[buf2] = newval + else + Mems[buf2] = val1 + Mems[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_SHORT) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure areps (a, npts, floor, ceil, newval) + +short a[npts] # Input arrays +int npts # Number of points +short floor, ceil # Replacement limits +short newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arles (a, npts, floor, newval) + +short a[npts] +int npts +short floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arges (a, npts, ceil, newval) + +short a[npts] +int npts +short ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepi (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real ilower +int floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnli(), impnli() + +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnli (im, buf2, v2) != EOF) + call amovki (newval, Memi[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = int (upper) + while (imgnli (im, buf1, v1) != EOF) { + junk = impnli (im, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + call arlei (Memi[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + while (imgnli (im, buf1, v1) != EOF) { + junk = impnli (im, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + call argei (Memi[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + while (imgnli (im, buf1, v1) != EOF) { + junk = impnli (im, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + call arepi (Memi[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepi (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real ilower +int floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnli(), impnli() +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnli (im, buf2, v2) != EOF) + call amovki (newval, Memi[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_INT + ceil = int (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_INT + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_INT) + + while (imgnli (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memi[buf1] + val2 = Memi[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memi[ptr+l] = INDEFI + } + } + } else { + if (!IS_INDEFI(val2)) + Memi[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnli (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memi[buf1] + if (IS_INDEFI(Memi[buf1])) + Memi[buf2] = newval + else + Memi[buf2] = val1 + Memi[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_INT) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepi (a, npts, floor, ceil, newval) + +int a[npts] # Input arrays +int npts # Number of points +int floor, ceil # Replacement limits +int newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arlei (a, npts, floor, newval) + +int a[npts] +int npts +int floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure argei (a, npts, ceil, newval) + +int a[npts] +int npts +int ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepl (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real ilower +long floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnll(), impnll() + +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnll (im, buf2, v2) != EOF) + call amovkl (newval, Meml[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = int (upper) + while (imgnll (im, buf1, v1) != EOF) { + junk = impnll (im, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + call arlel (Meml[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + while (imgnll (im, buf1, v1) != EOF) { + junk = impnll (im, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + call argel (Meml[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + while (imgnll (im, buf1, v1) != EOF) { + junk = impnll (im, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + call arepl (Meml[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepl (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real ilower +long floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnll(), impnll() +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnll (im, buf2, v2) != EOF) + call amovkl (newval, Meml[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_LONG + ceil = int (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_LONG + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_LONG) + + while (imgnll (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Meml[buf1] + val2 = Meml[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Meml[ptr+l] = INDEFL + } + } + } else { + if (!IS_INDEFL(val2)) + Meml[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnll (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Meml[buf1] + if (IS_INDEFL(Meml[buf1])) + Meml[buf2] = newval + else + Meml[buf2] = val1 + Meml[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_LONG) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepl (a, npts, floor, ceil, newval) + +long a[npts] # Input arrays +int npts # Number of points +long floor, ceil # Replacement limits +long newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arlel (a, npts, floor, newval) + +long a[npts] +int npts +long floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure argel (a, npts, ceil, newval) + +long a[npts] +int npts +long ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepr (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlr (im, buf2, v2) != EOF) + call amovkr (newval, Memr[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = double (upper) + while (imgnlr (im, buf1, v1) != EOF) { + junk = impnlr (im, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + call arler (Memr[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + while (imgnlr (im, buf1, v1) != EOF) { + junk = impnlr (im, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + call arger (Memr[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + while (imgnlr (im, buf1, v1) != EOF) { + junk = impnlr (im, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + call arepr (Memr[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepr (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnlr(), impnlr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlr (im, buf2, v2) != EOF) + call amovkr (newval, Memr[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_REAL + ceil = double (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + ceil = MAX_REAL + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_REAL) + + while (imgnlr (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memr[buf1] + val2 = Memr[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memr[ptr+l] = INDEFR + } + } + } else { + if (!IS_INDEFR(val2)) + Memr[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnlr (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memr[buf1] + if (IS_INDEFR(Memr[buf1])) + Memr[buf2] = newval + else + Memr[buf2] = val1 + Memr[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_REAL) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepr (a, npts, floor, ceil, newval) + +real a[npts] # Input arrays +int npts # Number of points +real floor, ceil # Replacement limits +real newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arler (a, npts, floor, newval) + +real a[npts] +int npts +real floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arger (a, npts, ceil, newval) + +real a[npts] +int npts +real ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepd (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +double floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnld (im, buf2, v2) != EOF) + call amovkd (newval, Memd[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = double (upper) + while (imgnld (im, buf1, v1) != EOF) { + junk = impnld (im, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + call arled (Memd[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + while (imgnld (im, buf1, v1) != EOF) { + junk = impnld (im, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + call arged (Memd[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + while (imgnld (im, buf1, v1) != EOF) { + junk = impnld (im, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + call arepd (Memd[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepd (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +double floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnld(), impnld() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnld (im, buf2, v2) != EOF) + call amovkd (newval, Memd[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_DOUBLE + ceil = double (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + ceil = MAX_DOUBLE + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_DOUBLE) + + while (imgnld (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memd[buf1] + val2 = Memd[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memd[ptr+l] = INDEFD + } + } + } else { + if (!IS_INDEFD(val2)) + Memd[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnld (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memd[buf1] + if (IS_INDEFD(Memd[buf1])) + Memd[buf2] = newval + else + Memd[buf2] = val1 + Memd[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_DOUBLE) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepd (a, npts, floor, ceil, newval) + +double a[npts] # Input arrays +int npts # Number of points +double floor, ceil # Replacement limits +double newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arled (a, npts, floor, newval) + +double a[npts] +int npts +double floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arged (a, npts, ceil, newval) + +double a[npts] +int npts +double ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepx (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +complex floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlx(), impnlx() + + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = complex (value, img) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlx (im, buf2, v2) != EOF) + call amovkx (newval, Memx[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = double (upper) + while (imgnlx (im, buf1, v1) != EOF) { + junk = impnlx (im, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + call arlex (Memx[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + while (imgnlx (im, buf1, v1) != EOF) { + junk = impnlx (im, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + call argex (Memx[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + while (imgnlx (im, buf1, v1) != EOF) { + junk = impnlx (im, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + call arepx (Memx[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepx (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +complex floor, ceil, newval, val1, val2 +real abs_floor, abs_ceil +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnlx(), impnlx() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = complex (value, img) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlx (im, buf2, v2) != EOF) + call amovkx (newval, Memx[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = 0 + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = real (lower) + ceil = MAX_REAL + abs_floor = abs (floor) + abs_ceil = abs (ceil) + + # Replace pixels between lower and upper by value. + } else { + floor = real (lower) + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_COMPLEX) + + while (imgnlx (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memx[buf1] + val2 = Memx[buf2] + if ((abs (val1) >= abs_floor) && (abs (val1) <= abs_ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memx[ptr+l] = INDEFX + } + } + } else { + if (!IS_INDEFX(val2)) + Memx[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnlx (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memx[buf1] + if (IS_INDEFX(Memx[buf1])) + Memx[buf2] = newval + else + Memx[buf2] = val1 + Memx[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_COMPLEX) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepx (a, npts, floor, ceil, newval) + +complex a[npts] # Input arrays +int npts # Number of points +complex floor, ceil # Replacement limits +complex newval # Replacement value + +int i +real abs_floor +real abs_ceil + +begin + abs_floor = abs (floor) + abs_ceil = abs (ceil) + + do i = 1, npts { + if ((abs (a[i]) >= abs_floor) && (abs (a[i]) <= abs_ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arlex (a, npts, floor, newval) + +complex a[npts] +int npts +complex floor, newval + +int i +real abs_floor + +begin + abs_floor = abs (floor) + + do i = 1, npts + if (abs (a[i]) <= abs_floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure argex (a, npts, ceil, newval) + +complex a[npts] +int npts +complex ceil, newval + +int i +real abs_ceil + +begin + abs_ceil = abs (ceil) + + do i = 1, npts + if (abs (a[i]) >= abs_ceil) + a[i] = newval +end + + diff --git a/pkg/images/imutil/src/generic/imsum.x b/pkg/images/imutil/src/generic/imsum.x new file mode 100644 index 00000000..fcb43716 --- /dev/null +++ b/pkg/images/imutil/src/generic/imsum.x @@ -0,0 +1,1902 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../imsum.h" + +define TMINSW 1.00 # Relative timings for nvecs = 5 +define TMXMNSW 1.46 +define TMED3 0.18 +define TMED5 0.55 + +# IMSUM -- Sum or average images with optional high and low pixel rejection. +# +# This procedure has to be clever in not exceeding the maximum number of images +# which can be mapped at one time. If no pixels are being rejected then the +# images can be summed (or averaged) in blocks using the output image to hold +# intermediate results. If pixels are being rejected then lines from all +# images must be obtained. If the number of images exceeds the maximum +# then only a subset of the images are kept mapped and the remainder are +# mapped and unmapped for each line. This, of course, is inefficient but +# there is no other way. + + +procedure imsums (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +short const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnls(), impnls() +errchk immap, imunmap, imgnls, impnls + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnls (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrs (Mems[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovs (Mems[buf_in], Mems[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aadds (Mems[buf_in], Mems[buf_out], + Mems[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivks (Mems[buf_out], const, Mems[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_SHORT) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnls (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovs (Mems[buf_in], Mems[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejs (Memi[buf], nimages, Mems[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivks (Mems[buf_out], const, Mems[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejs (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +short b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovs (Mems[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minsws (a, i, npts) + i = i - 1 + } + call amovs (Mems[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxsws (a, i, npts) + i = i - 1 + } + call amovs (Mems[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnsws (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minsws (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxsws (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovs (Mems[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3s (Mems[a[1]], Mems[a[2]], Mems[a[3]], b, npts) + } else { + call amed5s (Mems[a[1]], Mems[a[2]], Mems[a[3]], + Mems[a[4]], Mems[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minsws (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +short temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mems[k] < Mems[kmin]) + kmin = k + } + if (k != kmin) { + temp = Mems[k] + Mems[k] = Mems[kmin] + Mems[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxsws (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +short temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mems[k] > Mems[kmax]) + kmax = k + } + if (k != kmax) { + temp = Mems[k] + Mems[k] = Mems[kmax] + Mems[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnsws (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +short temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Mems[k] > Mems[kmax]) + kmax = k + else if (Mems[k] < Mems[kmin]) + kmin = k + } + temp = Mems[k] + Mems[k] = Mems[kmax] + Mems[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Mems[j] + Mems[j] = Mems[kmax] + Mems[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Mems[j] + Mems[j] = Mems[kmin] + Mems[kmin] = temp + } + } +end + +procedure imsumi (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +int const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnli(), impnli() +errchk immap, imunmap, imgnli, impnli + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnli (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclri (Memi[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddi (Memi[buf_in], Memi[buf_out], + Memi[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivki (Memi[buf_out], const, Memi[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_INT) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnli (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovi (Memi[buf_in], Memi[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imreji (Memi[buf], nimages, Memi[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivki (Memi[buf_out], const, Memi[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imreji (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +int b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovi (Memi[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswi (a, i, npts) + i = i - 1 + } + call amovi (Memi[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswi (a, i, npts) + i = i - 1 + } + call amovi (Memi[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswi (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswi (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswi (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovi (Memi[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3i (Memi[a[1]], Memi[a[2]], Memi[a[3]], b, npts) + } else { + call amed5i (Memi[a[1]], Memi[a[2]], Memi[a[3]], + Memi[a[4]], Memi[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswi (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +int temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memi[k] < Memi[kmin]) + kmin = k + } + if (k != kmin) { + temp = Memi[k] + Memi[k] = Memi[kmin] + Memi[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswi (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +int temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memi[k] > Memi[kmax]) + kmax = k + } + if (k != kmax) { + temp = Memi[k] + Memi[k] = Memi[kmax] + Memi[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswi (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +int temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Memi[k] > Memi[kmax]) + kmax = k + else if (Memi[k] < Memi[kmin]) + kmin = k + } + temp = Memi[k] + Memi[k] = Memi[kmax] + Memi[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Memi[j] + Memi[j] = Memi[kmax] + Memi[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Memi[j] + Memi[j] = Memi[kmin] + Memi[kmin] = temp + } + } +end + +procedure imsuml (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +long const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnll(), impnll() +errchk immap, imunmap, imgnll, impnll + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnll (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrl (Meml[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovl (Meml[buf_in], Meml[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddl (Meml[buf_in], Meml[buf_out], + Meml[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivkl (Meml[buf_out], const, Meml[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_LONG) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnll (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovl (Meml[buf_in], Meml[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejl (Memi[buf], nimages, Meml[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivkl (Meml[buf_out], const, Meml[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejl (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +long b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovl (Meml[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswl (a, i, npts) + i = i - 1 + } + call amovl (Meml[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswl (a, i, npts) + i = i - 1 + } + call amovl (Meml[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswl (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswl (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswl (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovl (Meml[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3l (Meml[a[1]], Meml[a[2]], Meml[a[3]], b, npts) + } else { + call amed5l (Meml[a[1]], Meml[a[2]], Meml[a[3]], + Meml[a[4]], Meml[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswl (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +long temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Meml[k] < Meml[kmin]) + kmin = k + } + if (k != kmin) { + temp = Meml[k] + Meml[k] = Meml[kmin] + Meml[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswl (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +long temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Meml[k] > Meml[kmax]) + kmax = k + } + if (k != kmax) { + temp = Meml[k] + Meml[k] = Meml[kmax] + Meml[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswl (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +long temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Meml[k] > Meml[kmax]) + kmax = k + else if (Meml[k] < Meml[kmin]) + kmin = k + } + temp = Meml[k] + Meml[k] = Meml[kmax] + Meml[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Meml[j] + Meml[j] = Meml[kmax] + Meml[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Meml[j] + Meml[j] = Meml[kmin] + Meml[kmin] = temp + } + } +end + +procedure imsumr (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +real const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnlr(), impnlr() +errchk immap, imunmap, imgnlr, impnlr + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnlr (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrr (Memr[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddr (Memr[buf_in], Memr[buf_out], + Memr[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivkr (Memr[buf_out], const, Memr[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_REAL) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnlr (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovr (Memr[buf_in], Memr[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejr (Memi[buf], nimages, Memr[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivkr (Memr[buf_out], const, Memr[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejr (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +real b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovr (Memr[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswr (a, i, npts) + i = i - 1 + } + call amovr (Memr[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswr (a, i, npts) + i = i - 1 + } + call amovr (Memr[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswr (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswr (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswr (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovr (Memr[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3r (Memr[a[1]], Memr[a[2]], Memr[a[3]], b, npts) + } else { + call amed5r (Memr[a[1]], Memr[a[2]], Memr[a[3]], + Memr[a[4]], Memr[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswr (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +real temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memr[k] < Memr[kmin]) + kmin = k + } + if (k != kmin) { + temp = Memr[k] + Memr[k] = Memr[kmin] + Memr[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswr (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +real temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memr[k] > Memr[kmax]) + kmax = k + } + if (k != kmax) { + temp = Memr[k] + Memr[k] = Memr[kmax] + Memr[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswr (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +real temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Memr[k] > Memr[kmax]) + kmax = k + else if (Memr[k] < Memr[kmin]) + kmin = k + } + temp = Memr[k] + Memr[k] = Memr[kmax] + Memr[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Memr[j] + Memr[j] = Memr[kmax] + Memr[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Memr[j] + Memr[j] = Memr[kmin] + Memr[kmin] = temp + } + } +end + +procedure imsumd (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +double const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnld(), impnld() +errchk immap, imunmap, imgnld, impnld + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnld (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrd (Memd[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovd (Memd[buf_in], Memd[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddd (Memd[buf_in], Memd[buf_out], + Memd[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivkd (Memd[buf_out], const, Memd[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_DOUBLE) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnld (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovd (Memd[buf_in], Memd[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejd (Memi[buf], nimages, Memd[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivkd (Memd[buf_out], const, Memd[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejd (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +double b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovd (Memd[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswd (a, i, npts) + i = i - 1 + } + call amovd (Memd[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswd (a, i, npts) + i = i - 1 + } + call amovd (Memd[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswd (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswd (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswd (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovd (Memd[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3d (Memd[a[1]], Memd[a[2]], Memd[a[3]], b, npts) + } else { + call amed5d (Memd[a[1]], Memd[a[2]], Memd[a[3]], + Memd[a[4]], Memd[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswd (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +double temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memd[k] < Memd[kmin]) + kmin = k + } + if (k != kmin) { + temp = Memd[k] + Memd[k] = Memd[kmin] + Memd[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswd (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +double temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memd[k] > Memd[kmax]) + kmax = k + } + if (k != kmax) { + temp = Memd[k] + Memd[k] = Memd[kmax] + Memd[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswd (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +double temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Memd[k] > Memd[kmax]) + kmax = k + else if (Memd[k] < Memd[kmin]) + kmin = k + } + temp = Memd[k] + Memd[k] = Memd[kmax] + Memd[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Memd[j] + Memd[j] = Memd[kmax] + Memd[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Memd[j] + Memd[j] = Memd[kmin] + Memd[kmin] = temp + } + } +end + diff --git a/pkg/images/imutil/src/generic/mkpkg b/pkg/images/imutil/src/generic/mkpkg new file mode 100644 index 00000000..9878bc7b --- /dev/null +++ b/pkg/images/imutil/src/generic/mkpkg @@ -0,0 +1,21 @@ +# Make IMUTIL. + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + imaadd.x <imhdr.h> + imadiv.x <imhdr.h> + imamax.x <imhdr.h> + imamin.x <imhdr.h> + imamul.x <imhdr.h> + imanl.x <imhdr.h> + imasub.x <imhdr.h> + imfuncs.x <imhdr.h> <mach.h> <math.h> + imjoin.x <imhdr.h> + imrep.x <imhdr.h> <mach.h> + imsum.x ../imsum.h <imhdr.h> + ; + diff --git a/pkg/images/imutil/src/getcmd.x b/pkg/images/imutil/src/getcmd.x new file mode 100644 index 00000000..2ed08314 --- /dev/null +++ b/pkg/images/imutil/src/getcmd.x @@ -0,0 +1,406 @@ +include <syserr.h> +include <error.h> +include <ctotok.h> +include <lexnum.h> + +# parameter names and values. + +define HS_ADD 1 +define HS_ADDONLY 2 +define HS_UPDATE 3 +define HS_VERIFY 4 +define HS_SHOW 5 +define HS_DELETE 6 +define HS_RENAME 7 +define HS_FIELD 8 +define HS_VALUE 9 +define HS_COMMENT 10 +define HS_BEFORE 11 +define HS_AFTER 12 +define ERROR -2 + +define HADD Memi[$1] +define HADDONLY Memi[$1+1] +define HUPDATE Memi[$1+2] +define HVERIFY Memi[$1+3] +define HSHOW Memi[$1+4] +define HDELETE Memi[$1+5] +define HRENAME Memi[$1+6] +define HBAF Memi[$1+7] +define HFIELD Memc[P2C($1+10)] +define HVALUE Memc[P2C($1+46)] +define HCOMMENT Memc[P2C($1+86)] +define HBAFVALUE Memc[P2C($1+126)] + +define HSZ 200 + +define OP_EDIT 1 # hedit opcodes +define OP_INIT 2 +define OP_ADD 3 +define OP_DELETE 4 +define OP_DEFPAR 5 +define OP_RENAME 6 +define BEFORE 1 +define AFTER 2 + +define LEN_CARD 80 + +# HE_CMDPARS -- Procedure to parse and analyze a string of the form: +# + +procedure he_getcmdf (cmd, operation, fields, valexpr, comment, pkey, baf, + update, verify, show) + + +char cmd[ARB] #I String with kernel section +int operation +char fields[ARB] +char valexpr[ARB] +char comment[ARB] +char pkey[ARB] +int baf +int update +int verify +int show + +pointer hc +char outstr[LEN_CARD] +char identif[LEN_CARD], dot +int ip, nexpr, token, add, addonly, delete, rename, nch +bool streq() +int lex_type, ctotok(), he_ks_lex(), ctowrd() +errchk syserr, syserrs + +begin + # The default values should have been already initialized + # with a call fxf_ksinit(). + + call calloc(hc, HSZ, TY_STRUCT) + call he_ksinit (hc) + + ip = 1 + nexpr = 0 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + if (ip == 1) { + nch= ctowrd(cmd, ip, outstr, LEN_CARD) + token = TOK_IDENTIFIER + } else { + token = ctotok (cmd, ip, outstr, LEN_CARD) + } + + if (token == TOK_CHARCON) { + ip = ip - 2 + nch= ctowrd(cmd, ip, outstr, LEN_CARD) + if (nexpr >= 1) + token = TOK_STRING + if (nch <=3) { + #ctowrd will not parse one letter string, doit in here. + outstr[1]=cmd[ip-2] + outstr[2]=EOS + } + } + + if (token == TOK_STRING && nexpr == 0) + token = TOK_IDENTIFIER + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + + case TOK_NUMBER: + if (nexpr != 1) { + call eprintf ("%s\n") + call pargstr (cmd) + call error (13,"Numeric value not allow in this field") + } + call strcpy (outstr, HVALUE(hc), LEN_CARD) + nexpr = nexpr + 1 + case TOK_CHARCON: + ip = ip - 1 + case TOK_STRING: + if (nexpr != 1 && nexpr != 2) { + call eprintf ("%s\n") + call pargstr (cmd) + call error(13, "Value or comment error") + } + if (nexpr == 1) + call strcpy (outstr, HVALUE(hc), LEN_CARD) + if (nexpr == 2) + call strcpy (outstr, HCOMMENT(hc), LEN_CARD) + nexpr = nexpr + 1 + + case TOK_IDENTIFIER: + call strcpy (outstr, identif, LEN_CARD) + call strlwr (outstr) + lex_type = he_ks_lex (outstr) + + if (streq(identif, "comment") && nexpr == 0) + lex_type = 0 + # look for =<value>, + or - + if (lex_type > 0) { + call he_ks_gvalue (lex_type, cmd, ip, hc) + } else { + #if (nexpr == 0 || nexpr == 1) + if (nexpr == 0) + call strcpy (identif, HFIELD(hc), LEN_CARD) + else if (nexpr == 1) + call strcpy (outstr, HVALUE(hc), LEN_CARD) + else { + call eprintf ("%s\n") + call pargstr (cmd) + call error(13, "Field or value error") + } + } + nexpr = nexpr + 1 + + case TOK_OPERATOR: + dot = outstr[1] + if (nexpr == 1 && dot == '.') + call strcpy (outstr, HVALUE(hc), LEN_CARD) + else if (nexpr == 2 && dot == '.') + call strcpy (outstr, HCOMMENT(hc), LEN_CARD) + else { + call eprintf ("%s\n") + call pargstr (cmd) + call error(13,"error in tok_operator value") + } + nexpr = nexpr + 1 + + default: + #call error(13,"error in command line") + } + } + + call strcpy (HFIELD(hc), fields, LEN_CARD) + call strcpy (HVALUE(hc), valexpr, LEN_CARD) + call strcpy (HCOMMENT(hc), comment, LEN_CARD) + call strcpy (HBAFVALUE(hc), pkey, LEN_CARD) + baf = HBAF(hc) + add = HADD(hc) + addonly = HADDONLY(hc) + update = HUPDATE(hc) + verify = HVERIFY(hc) + show = HSHOW(hc) + delete = HDELETE(hc) + rename = HRENAME(hc) + + operation = OP_EDIT + if (add == -1 && addonly == -1 && delete == -1 && rename == -1) + operation = OP_DEFPAR + else if (add == YES) + operation = OP_ADD + else if (addonly == YES) + operation = OP_INIT + else if (delete == YES) + operation = OP_DELETE + else if (rename == YES) + operation = OP_RENAME + + if (streq (fields, "default_pars")) + operation = -operation + + call mfree(hc, TY_STRUCT) +end + + +# HE_KS_LEX -- Map an identifier into a header parameter code. + +int procedure he_ks_lex (outstr) + +char outstr[ARB] + +int len, strlen(), strncmp() +errchk syserr, syserrs + +begin + len = strlen (outstr) + + # Allow for small string to be taken as keyword names + # and not hedit parameters, like 'up' instead of 'up(date)'. + if (len < 3) + return(0) + + # Other kernel keywords. + if (strncmp (outstr, "field", len) == 0) + return (HS_FIELD) + if (strncmp (outstr, "value", len) == 0) + return (HS_VALUE) + if (strncmp (outstr, "comment", len) == 0) + return (HS_COMMENT) + if (strncmp (outstr, "after", len) == 0) + return (HS_AFTER) + if (strncmp (outstr, "before", len) == 0) + return (HS_BEFORE) + if (strncmp (outstr, "add", len) == 0) + return (HS_ADD) + if (strncmp (outstr, "addonly", len) == 0) + return (HS_ADDONLY) + if (strncmp (outstr, "delete", len) == 0) + return (HS_DELETE) + if (strncmp (outstr, "rename", len) == 0) + return (HS_RENAME) + if (strncmp (outstr, "verify", len) == 0) + return (HS_VERIFY) + if (strncmp (outstr, "show", len) == 0) { + return (HS_SHOW) + } + if (strncmp (outstr, "update", len) == 0) + return (HS_UPDATE) + + return (0) # not recognized; probably a value +end + + +# FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character +# position in the 'ksection' string. Put the values in the FKS structure. + +procedure he_ks_gvalue (param, cmd, ip, hc) + +int param #I parameter code +char cmd[ARB] #I Ksection +int ip #I Current parsing pointer in ksection +pointer hc #U Update the values in the FKS structure + +pointer sp, ln +int jp, token +int ctotok() +errchk syserr, syserrs + +begin + jp = ip + + call smark (sp) + call salloc (ln, LEN_CARD, TY_CHAR) + + # See if the parameter value is given as par=<value> or '+/-' + if (ctotok (cmd, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) { + if (Memc[ln] == '=' ) { + token = ctotok (cmd, jp, Memc[ln], LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && token != TOK_NUMBER) { + call syserr (SYS_FXFKSSYN) + } else { + call he_ks_val (Memc[ln], param, hc) + ip = jp + } + } else if (Memc[ln] == '+' || Memc[ln] == '-') { + call he_ks_pm (Memc[ln], param, hc) + ip = jp + } + } + + call sfree (sp) +end + + +# FXF_KS_VALUE -- Returns the value of a parameter in the kernel section. + +procedure he_ks_val (outstr, param, hc) + +char outstr[ARB] #I Input string with value +int param #I Parameter code +pointer hc #U Fits kernel descriptor + +int ival +int strcmp() +errchk syserr, syserrs + +begin + call strlwr (outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (param) { + case HS_FIELD: + call strcpy (outstr, HFIELD(hc), LEN_CARD) + case HS_VALUE: + call strcpy (outstr, HVALUE(hc), LEN_CARD) + case HS_COMMENT: + call strcpy (outstr, HCOMMENT(hc), LEN_CARD) + case HS_BEFORE: + HBAF(hc) = BEFORE + call strcpy (outstr, HBAFVALUE(hc), LEN_CARD) + case HS_AFTER: + HBAF(hc) = AFTER + call strcpy (outstr, HBAFVALUE(hc), LEN_CARD) + case HS_ADD: + HADD(hc) = ival + case HS_ADDONLY: + HADDONLY(hc) = ival + case HS_UPDATE: + HUPDATE(hc) = ival + case HS_VERIFY: + HVERIFY(hc) = ival + case HS_SHOW: + HSHOW(hc) = ival + case HS_DELETE: + HDELETE(hc) = ival + case HS_RENAME: + HRENAME(hc) = ival + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# HE_KS_PM -- Return the character YES or NO based on the value '+' or '-' + +procedure he_ks_pm (pm, param, hc) + +char pm[1] #I contains "+" or "-" +int param #I Parameter code +pointer hc #U Fits kernel descriptor + +int ival +errchk syserr, syserrs + +begin + if (pm[1] == '+') + ival = YES + else + ival = NO + + switch (param) { + case HS_ADD: + HADD(hc) = ival + case HS_ADDONLY: + HADDONLY(hc) = ival + case HS_UPDATE: + HUPDATE(hc) = ival + case HS_VERIFY: + HVERIFY(hc) = ival + case HS_SHOW: + HSHOW(hc) = ival + case HS_DELETE: + HDELETE(hc) = ival + case HS_RENAME: + HRENAME(hc) = ival + default: + call error(13, "ks_pm: invalid value") + } +end + + +# FXF_KSINIT -- Initialize default values for ks parameters. + +procedure he_ksinit (hc) + +pointer hc #I + +begin + HADD(hc) = -1 + HADDONLY(hc) = -1 + HDELETE(hc) = -1 + HRENAME(hc) = -1 + HUPDATE(hc) = -1 + HVERIFY(hc) = -1 + HSHOW(hc) = -1 +end diff --git a/pkg/images/imutil/src/gettok.h b/pkg/images/imutil/src/gettok.h new file mode 100644 index 00000000..d0cfd1ca --- /dev/null +++ b/pkg/images/imutil/src/gettok.h @@ -0,0 +1,22 @@ +# GETTOK.H -- External definitions for gettok.h + +define GT_IDENT (-99) +define GT_NUMBER (-98) +define GT_STRING (-97) +define GT_COMMAND (-96) +define GT_PLUSEQ (-95) +define GT_COLONEQ (-94) +define GT_EXPON (-93) +define GT_CONCAT (-92) +define GT_SE (-91) +define GT_LE (-90) +define GT_GE (-89) +define GT_EQ (-88) +define GT_NE (-87) +define GT_LAND (-86) +define GT_LOR (-85) + +# Optionl flags. +define GT_NOSPECIAL 0003 +define GT_NOFILE 0001 +define GT_NOCOMMAND 0002 diff --git a/pkg/images/imutil/src/gettok.x b/pkg/images/imutil/src/gettok.x new file mode 100644 index 00000000..a0975300 --- /dev/null +++ b/pkg/images/imutil/src/gettok.x @@ -0,0 +1,922 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <ctype.h> +include <fset.h> +include "gettok.h" + +.help gettok +.nf -------------------------------------------------------------------------- +GETTOK -- Lexical input routines. Used to return tokens from input text, +performing macro expansion and file expansion. The input text may be either +an open file descriptor or a text string. + + nchars = gt_expandtext (text, obuf, len_obuf, gsym, gsym_data) + + gt = gt_open (fd, gsym, gsym_data, pbblen, flags) + gt = gt_opentext (text, gsym, gsym_data, pbblen, flags) + gt_close (gt) + + nchars = gt_expand (gt, obuf, len_obuf) + token = gt_gettok (gt, tokbuf, maxch) + gt_ungettok (gt, tokbuf) + token = gt_rawtok (gt, tokbuf, maxch) + token = gt_nexttok (gt) + +The client get-symbol routine has the following calling sequence, where +"nargs" is an output argument which should be set to the number of macro +arguments, if any. Normally this routine will call SYMTAB to do the +symbol lookup, but this is not required. GSYM may be set to NULL if no +macro replacement is desired. + + textp = gsym (gsym_data, symbol, &nargs) + +PBBLEN is the size of the pushback buffer used for macro expansion, and +determines the size of the largest macro replacement string that can be +pushed back. FLAGS may be used to disable certain types of pushback. +Both PBBLEN and FLAGS may be given as zero if the client is happy with the +builtin defaults. + +Access to the package is gained by opening a text string with GT_OPENTEXT. +This returns a descriptor which is passed to GT_GETTOK to read successive +tokens, which may come from the input text string or from any macros, +include files, etc., referenced in the text or in any substituted text. +GT_UNGETTOK pushes a token back into the GT_GETTOK input stream, to be +returned in the next GT_GETTOK call (following macro expansion). GT_EXPAND +will process the entire input text string, expanding any macro references +therein, returning the fully resolved text in the output buffer. A more +macroscopic version of this is GT_EXPANDTEXT, which does the opentext, +expand, and close operations internally, using the builtin defaults. + +GT_RAWTOK returns the next physical token from an input stream (without +macro expansion), and GT_NEXTTOK returns the type of the next *physical* +token (no macro expansion) without actually fetching it (for look ahead +decision making). + +The tokens that can be returned are as follows: + + GT_IDENT [a-zA-Z][a-zA-Z0-9_]* + GT_NUMBER [0-9][0-9a-zA-Z.]*(e|E)?(+|-)?[0-9]* + GT_STRING if "abc" or 'abc', the abc + 'c' other characters, e.g., =+-*/,;:()[] etc + EOF at end of input + +Macro replacement syntax: + + macro push macro with null arglist + macro(arg,arg,...) push macro with argument substitution + @file push contents of file + @file(arg,arg,...) push file with argument substitution + `cmd` substitute output of CL command "cmd" + +where + macro is an identifier, the name of a global macro + or a datafile local macro (parameter) + +In all cases, occurences of $N in the replacement text are replaced by the +macro arguments if any, and macros are recursively expanded. Whitespace, +including newline, equates to a single space, as does EOF (hence always +delimits tokens). Comments (# to end of line) are ignored. All identifiers +in scanned text are checked to see if they are references to predefined +macros, using the client supplied symbol lookup routine. +.endhelp --------------------------------------------------------------------- + +# General definitions. +define MAX_LEVELS 20 # max include file nesting +define MAX_ARGS 9 # max arguments to a macro +define SZ_CMD 80 # `cmd` +define SZ_IBUF 8192 # buffer for macro replacement +define SZ_OBUF 8192 # buffer for macro replacement +define SZ_ARGBUF 256 # argument list to a macro +define SZ_TOKBUF 1024 # token buffer +define DEF_MAXPUSHBACK 16384 # max pushback, macro replacement +define INC_TOKBUF 4096 # increment if expanded text fills + +# The gettok descriptor. +define LEN_GTDES 50 +define GT_FD Memi[$1] # current input stream +define GT_UFD Memi[$1+1] # user (client) input file +define GT_FLAGS Memi[$1+2] # option flags +define GT_PBBLEN Memi[$1+3] # pushback buffer length +define GT_DEBUG Memi[$1+4] # for debug messages +define GT_GSYM Memi[$1+5] # get symbol routine +define GT_GSYMDATA Memi[$1+6] # client data for above +define GT_NEXTCH Memi[$1+7] # lookahead character +define GT_FTEMP Memi[$1+8] # file on stream is a temp file +define GT_LEVEL Memi[$1+9] # current nesting level +define GT_SVFD Memi[$1+10+$2-1]# stacked file descriptors +define GT_SVFTEMP Memi[$1+30+$2-1]# stacked ftemp flags + +# Set to YES to enable debug messages. +define DEBUG NO + + +# GT_EXPANDTEXT -- Perform macro expansion on a text string returning the +# fully resolved text in the client's output buffer. The number of chars +# in the output string is returned as the function value. + +int procedure gt_expandtext (text, obuf, len_obuf, gsym, gsym_data) + +char text[ARB] #I input text to be expanded +pointer obuf #U output buffer +int len_obuf #U size of output buffer +int gsym #I epa of client get-symbol routine +int gsym_data #I client data for above + +pointer gt +int nchars +int gt_expand() +pointer gt_opentext() +errchk gt_opentext + +begin + gt = gt_opentext (text, gsym, gsym_data, 0, 0) + nchars = gt_expand (gt, obuf, len_obuf) + call gt_close (gt) + + return (nchars) +end + + +# GT_EXPAND -- Perform macro expansion on a GT text stream returning the +# fully resolved text in the client's output buffer. The number of chars +# in the output string is returned as the function value. + +int procedure gt_expand (gt, obuf, len_obuf) + +pointer gt #I gettok descriptor +pointer obuf #U output buffer +int len_obuf #U size of output buffer + +int token, nchars +pointer sp, tokbuf, op, otop +int gt_gettok(), strlen(), gstrcpy() +errchk realloc + +begin + call smark (sp) + call salloc (tokbuf, SZ_TOKBUF, TY_CHAR) + + # Open input text for macro expanded token input. + otop = obuf + len_obuf + op = obuf + + # Copy tokens to the output, inserting a space after every token. + repeat { + token = gt_gettok (gt, Memc[tokbuf], SZ_TOKBUF) + if (token != EOF) { + if (op + strlen(Memc[tokbuf]) + 3 > otop) { + nchars = op - obuf + len_obuf = len_obuf + INC_TOKBUF + call realloc (obuf, len_obuf, TY_CHAR) + otop = obuf + len_obuf + op = obuf + nchars + } + + if (token == GT_STRING) { + Memc[op] = '"' + op = op + 1 + } + op = op + gstrcpy (Memc[tokbuf], Memc[op], otop-op) + if (token == GT_STRING) { + Memc[op] = '"' + op = op + 1 + } + Memc[op] = ' ' + op = op + 1 + } + } until (token == EOF) + + # Cancel the trailing blank and add the EOS. + if (op > 1 && op < otop) + op = op - 1 + Memc[op] = EOS + + call sfree (sp) + return (op - 1) +end + + +# GT_OPEN -- Open the GETTOK descriptor on a file descriptor. + +pointer procedure gt_open (fd, gsym, gsym_data, pbblen, flags) + +int fd #I input file +int gsym #I epa of client get-symbol routine +int gsym_data #I client data for above +int pbblen #I pushback buffer length +int flags #I option flags + +pointer gt +int sz_pbbuf +errchk calloc + +begin + call calloc (gt, LEN_GTDES, TY_STRUCT) + + GT_GSYM(gt) = gsym + GT_GSYMDATA(gt) = gsym_data + GT_FLAGS(gt) = flags + GT_DEBUG(gt) = DEBUG + + GT_FD(gt) = fd + GT_UFD(gt) = fd + + if (pbblen <= 0) + sz_pbbuf = DEF_MAXPUSHBACK + else + sz_pbbuf = pbblen + call fseti (GT_FD(gt), F_PBBSIZE, sz_pbbuf) + GT_PBBLEN(gt) = sz_pbbuf + + return (gt) +end + + +# GT_OPENTEXT -- Open the GT_GETTOK descriptor. The descriptor is initially +# opened on the user supplied string buffer (which is opened as a file and +# which must remain intact while token input is in progress), but include file +# processing etc. may cause arbitrary nesting of file descriptors. + +pointer procedure gt_opentext (text, gsym, gsym_data, pbblen, flags) + +char text[ARB] #I input text to be scanned +int gsym #I epa of client get-symbol routine +int gsym_data #I client data for above +int pbblen #I pushback buffer length +int flags #I option flags + +pointer gt +int sz_pbbuf +int stropen(), strlen() +errchk stropen, calloc + +begin + call calloc (gt, LEN_GTDES, TY_STRUCT) + + GT_GSYM(gt) = gsym + GT_GSYMDATA(gt) = gsym_data + GT_FLAGS(gt) = flags + GT_DEBUG(gt) = DEBUG + + GT_FD(gt) = stropen (text, strlen(text), READ_ONLY) + GT_UFD(gt) = 0 + + if (pbblen <= 0) + sz_pbbuf = DEF_MAXPUSHBACK + else + sz_pbbuf = pbblen + call fseti (GT_FD(gt), F_PBBSIZE, sz_pbbuf) + GT_PBBLEN(gt) = sz_pbbuf + + return (gt) +end + + +# GT_GETTOK -- Return the next token from the input stream. The token ID +# (a predefined integer code or the character value) is returned as the +# function value. The text of the token is returned as an output argument. +# Any macro references, file includes, etc., are performed in the process +# of scanning the input stream, hence only fully resolved tokens are output. + +int procedure gt_gettok (gt, tokbuf, maxch) + +pointer gt #I gettok descriptor +char tokbuf[maxch] #O receives the text of the token +int maxch #I max chars out + +pointer sp, bp, cmd, ibuf, obuf, argbuf, fname, textp +int fd, token, level, margs, nargs, nchars, i_fd, o_fd, ftemp + +int strmac(), open(), stropen() +int gt_rawtok(), gt_nexttok(), gt_arglist(), zfunc3() +errchk gt_rawtok, close, ungetci, ungetline, gt_arglist, +errchk clcmdw, stropen, syserr, zfunc3 +define pushfile_ 91 + + +begin + call smark (sp) + + # Allocate some buffer space. + nchars = SZ_CMD + SZ_IBUF + SZ_OBUF + SZ_ARGBUF + SZ_FNAME + 5 + call salloc (bp, nchars, TY_CHAR) + + cmd = bp + ibuf = cmd + SZ_CMD + 1 + obuf = ibuf + SZ_IBUF + 1 + argbuf = obuf + SZ_OBUF + 1 + fname = argbuf + SZ_ARGBUF + 1 + + # Read raw tokens and push back macro or include file text until we + # get a fully resolved token. + + repeat { + fd = GT_FD(gt) + + # Get a raw token. + token = gt_rawtok (gt, tokbuf, maxch) + + # Process special tokens. + switch (token) { + case EOF: + # EOF has been reached on the current stream. + level = GT_LEVEL(gt) + if (GT_FTEMP(gt) == YES) { + call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME) + if (level > 0) + call close (fd) + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else if (level > 0) + call close (fd) + + if (level > 0) { + # Restore previous stream. + GT_FD(gt) = GT_SVFD(gt,level) + GT_FTEMP(gt) = GT_SVFTEMP(gt,level) + GT_LEVEL(gt) = level - 1 + GT_NEXTCH(gt) = NULL + } else { + # Return EOF token to caller. + call strcpy ("EOF", tokbuf, maxch) + break + } + + case GT_IDENT: + # Lookup the identifier in the symbol table. + textp = NULL + if (GT_GSYM(gt) != NULL) + textp = zfunc3 (GT_GSYM(gt), GT_GSYMDATA(gt), tokbuf, margs) + + # Process a defined macro. + if (textp != NULL) { + # If macro does not have any arguments, merely push back + # the replacement text. + + if (margs == 0) { + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + call ungetline (fd, Memc[textp]) + next + } + + # Extract argument list, if any, perform argument + # substitution on the macro, and push back the edited + # text to be rescanned. + + if (gt_nexttok(gt) == '(') { + nargs = gt_arglist (gt, Memc[argbuf], SZ_ARGBUF) + if (nargs != margs) { + call eprintf ("macro `%s' called with ") + call pargstr (tokbuf) + call eprintf ("wrong number of arguments\n") + } + + # Pushback the text of a macro with arg substitution. + nchars = strmac (Memc[textp], Memc[argbuf], + Memc[obuf], SZ_OBUF) + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + call ungetline (fd, Memc[obuf]) + next + + } else { + call eprintf ("macro `%s' called with no arguments\n") + call pargstr (tokbuf) + } + } + + # Return a regular identifier. + break + + case GT_COMMAND: + # Send a command to the CL and push back the output. + if (and (GT_FLAGS(gt), GT_NOCOMMAND) != 0) + break + + # Execute the command, spooling the output in a temp file. + call mktemp ("tmp$co", Memc[fname], SZ_FNAME) + call sprintf (Memc[cmd], SZ_LINE, "%s > %s") + call pargstr (tokbuf) + call pargstr (Memc[fname]) + call clcmdw (Memc[cmd]) + + # Open the output file as input text. + call strcpy (Memc[fname], tokbuf, maxch) + nargs = 0 + ftemp = YES + goto pushfile_ + + case '@': + # Pushback the contents of a file. + if (and (GT_FLAGS(gt), GT_NOFILE) != 0) + break + + token = gt_rawtok (gt, tokbuf, maxch) + if (token != GT_IDENT && token != GT_STRING) { + call eprintf ("expected a filename after the `@'\n") + next + } else { + nargs = 0 + if (gt_nexttok(gt) == '(') # ) + nargs = gt_arglist (gt, Memc[argbuf], SZ_ARGBUF) + ftemp = NO + } +pushfile_ + # Attempt to open the file. + iferr (i_fd = open (tokbuf, READ_ONLY, TEXT_FILE)) { + call eprintf ("cannot open `%s'\n") + call pargstr (tokbuf) + next + } + + call fseti (i_fd, F_PBBSIZE, GT_PBBLEN(gt)) + + # Cancel lookahead. + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + + # If the macro was called with a nonnull argument list, + # attempt to perform argument substitution on the file + # contents. Otherwise merely push the fd. + + if (nargs > 0) { + # Pushback file contents with argument substitution. + o_fd = stropen (Memc[ibuf], SZ_IBUF, NEW_FILE) + + call fcopyo (i_fd, o_fd) + nchars = strmac (Memc[ibuf],Memc[argbuf],Memc[obuf],SZ_OBUF) + call ungetline (fd, Memc[obuf]) + + call close (o_fd) + call close (i_fd) + + } else { + # Push a new input stream. + level = GT_LEVEL(gt) + 1 + if (level > MAX_LEVELS) + call syserr (SYS_FPBOVFL) + + GT_SVFD(gt,level) = GT_FD(gt) + GT_SVFTEMP(gt,level) = GT_FTEMP(gt) + GT_LEVEL(gt) = level + + fd = i_fd + GT_FD(gt) = fd + GT_FTEMP(gt) = ftemp + } + + default: + break + } + } + + if (GT_DEBUG(gt) > 0) { + call eprintf ("token=%d(%o), `%s'\n") + call pargi (token) + call pargi (max(0,token)) + if (IS_PRINT(tokbuf[1])) + call pargstr (tokbuf) + else + call pargstr ("") + } + + call sfree (sp) + return (token) +end + + +# GT_UNGETTOK -- Push a token back into the GT_GETTOK input stream, to be +# returned as the next token by GT_GETTOK. + +procedure gt_ungettok (gt, tokbuf) + +pointer gt #I gettok descriptor +char tokbuf[ARB] #I text of token + +int fd +errchk ungetci + +begin + fd = GT_FD(gt) + + if (GT_DEBUG(gt) > 0) { + call eprintf ("unget token `%s'\n") + call pargstr (tokbuf) + } + + # Cancel lookahead. + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + + # First push back a space to ensure that the token is recognized + # when the input is rescanned. + + call ungetci (fd, ' ') + + # Now push the token text. + call ungetline (fd, tokbuf) +end + + +# GT_RAWTOK -- Get a raw token from the input stream, without performing any +# macro expansion or file inclusion. The text of the token in returned in +# tokbuf, and the token type is returened as the function value. + +int procedure gt_rawtok (gt, outstr, maxch) + +pointer gt #I gettok descriptor +char outstr[maxch] #O receives text of token. +int maxch #I max chars out + +int token, delim, fd, ch, last_ch, op +define again_ 91 +int getci() + +begin + fd = GT_FD(gt) +again_ + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + GT_NEXTCH(gt) = NULL + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') { + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + } + + # Output the first character. + op = 1 + if (ch != EOF && ch != '"' && ch != '\'' && ch != '`') { + outstr[op] = ch + op = op + 1 + } + + # Accumulate token. Some of the token recognition logic used here + # (especially for numbers) is crude, but it is not clear that rigour + # is justified for this application. + + if (ch == EOF) { + call strcpy ("EOF", outstr, maxch) + token = EOF + + } else if (ch == '#') { + # Ignore a comment. + while (getci (fd, ch) != '\n') + if (ch == EOF) + break + goto again_ + + } else if (IS_ALPHA(ch) || ch == '_' || ch == '$' || ch == '.') { + # Identifier. + token = GT_IDENT + while (getci (fd, ch) != EOF) + if (IS_ALNUM(ch) || ch == '_' || ch == '$' || ch == '.') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + + } else if (IS_DIGIT(ch)) { + # Number. + token = GT_NUMBER + + # Get number. + while (getci (fd, ch) != EOF) + if (IS_ALNUM(ch) || ch == '.') { + outstr[op] = ch + last_ch = ch + op = min (maxch, op+1) + } else + break + + # Get exponent if any. + if (last_ch == 'E' || last_ch == 'e') { + outstr[op] = ch + op = min (maxch, op+1) + while (getci (fd, ch) != EOF) + if (IS_DIGIT(ch) || ch == '+' || ch == '-') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + } + + } else if (ch == '"' || ch == '\'' || ch == '`') { + # Quoted string or command. + + if (ch == '`') + token = GT_COMMAND + else + token = GT_STRING + + delim = ch + while (getci (fd, ch) != EOF) + if (ch==delim && (op>1 && outstr[op-1] != '\\') || ch == '\n') + break + else { + outstr[op] = ch + op = min (maxch, op+1) + } + ch = getci (fd, ch) + + } else if (ch == '+') { + # May be the += operator. + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_PLUSEQ + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '+' + + } else if (ch == ':') { + # May be the := operator. + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_COLONEQ + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = ':' + + } else if (ch == '*') { + if (getci (fd, ch) != EOF) + if (ch == '*') { + token = GT_EXPON + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '*' + + } else if (ch == '/') { + if (getci (fd, ch) != EOF) + if (ch == '/') { + token = GT_CONCAT + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '/' + + } else if (ch == '?') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_SE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '?' + + } else if (ch == '<') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_LE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '<' + + } else if (ch == '>') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_GE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '>' + + } else if (ch == '=') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_EQ + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '=' + + } else if (ch == '!') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_NE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '!' + + } else if (ch == '&') { + if (getci (fd, ch) != EOF) + if (ch == '&') { + token = GT_LAND + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '&' + + } else if (ch == '|') { + if (getci (fd, ch) != EOF) + if (ch == '|') { + token = GT_LOR + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '|' + + } else { + # Other characters. + token = ch + ch = getci (fd, ch) + } + + # Process the lookahead character. + if (IS_WHITE(ch) || ch == '\n') { + repeat { + ch = getci (fd, ch) + } until (!(IS_WHITE(ch) || ch == '\n')) + } + + if (ch != EOF) + GT_NEXTCH(gt) = ch + + outstr[op] = EOS + return (token) +end + + +# GT_NEXTTOK -- Determine the type of the next raw token in the input stream, +# without actually fetching the token. Operators such as GT_EQ etc. are not +# recognized at this level. Note that this is at the same level as +# GT_RAWTOK, i.e., no macro expansion is performed, and the lookahead token +# is that which would be returned by the next gt_rawtok, which is not +# necessarily what gt_gettok would return after macro replacement. + +int procedure gt_nexttok (gt) + +pointer gt #I gettok descriptor + +int token, fd, ch +int getci() + +begin + fd = GT_FD(gt) + + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + + if (ch == EOF) + token = EOF + else if (IS_ALPHA(ch) || ch == '_' || ch == '$' || ch == '.') + token = GT_IDENT + else if (IS_DIGIT(ch)) + token = GT_NUMBER + else if (ch == '"' || ch == '\'') + token = GT_STRING + else if (ch == '`') + token = GT_COMMAND + else + token = ch + + if (GT_DEBUG(gt) > 0) { + call eprintf ("nexttok=%d(%o) `%c'\n") + call pargi (token) + call pargi (max(0,token)) + if (IS_PRINT(ch)) + call pargi (ch) + else + call pargi (0) + } + + return (token) +end + + +# GT_CLOSE -- Close the gettok descriptor and any files opened thereon. + +procedure gt_close (gt) + +pointer gt #I gettok descriptor + +int level, fd +pointer sp, fname + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + for (level=GT_LEVEL(gt); level >= 0; level=level-1) { + fd = GT_FD(gt) + if (GT_FTEMP(gt) == YES) { + call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME) + call close (fd) + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else if (fd != GT_UFD(gt)) + call close (fd) + + if (level > 0) { + GT_FD(gt) = GT_SVFD(gt,level) + GT_FTEMP(gt) = GT_SVFTEMP(gt,level) + } + } + + call mfree (gt, TY_STRUCT) + call sfree (sp) +end + + +# GT_ARGLIST -- Extract a paren and comma delimited argument list to be used +# for substitution into a macro replacement string. Since the result will be +# pushed back and rescanned, we do not have to perform macro substitution on +# the argument list at this level. + +int procedure gt_arglist (gt, argbuf, maxch) + +pointer gt #I gettok descriptor +char argbuf[maxch] #O receives parsed arguments +int maxch #I max chars out + +int level, quote, nargs, op, ch, fd +int getci() + +begin + fd = GT_FD(gt) + + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + + quote = 0 + level = 1 + nargs = 0 + op = 1 + + if (ch == '(') { + while (getci (fd, ch) != EOF) { + if (ch == '"' || ch == '\'') { + if (quote == 0) + quote = ch + else if (quote == ch) + quote = 0 + + } else if (ch == '(' && quote == 0) { + level = level + 1 + } else if (ch == ')' && quote == 0) { + level = level - 1 + if (level <= 0) { + if (op > 1 && argbuf[op-1] != EOS) + nargs = nargs + 1 + break + } + + } else if (ch == ',' && level == 1 && quote == 0) { + ch = EOS + nargs = nargs + 1 + } else if (ch == '\n') { + ch = ' ' + } else if (ch == '\\' && quote == 0) { + ch = getci (fd, ch) + next + } else if (ch == '#' && quote == 0) { + while (getci (fd, ch) != EOF) + if (ch == '\n') + break + next + } + + argbuf[op] = ch + op = min (maxch, op + 1) + } + + GT_NEXTCH(gt) = NULL + } + + argbuf[op] = EOS + return (nargs) +end diff --git a/pkg/images/imutil/src/hedit.x b/pkg/images/imutil/src/hedit.x new file mode 100644 index 00000000..4dd553bb --- /dev/null +++ b/pkg/images/imutil/src/hedit.x @@ -0,0 +1,806 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <evexpr.h> +include <imset.h> +include <ctype.h> +include <lexnum.h> + +define LEN_USERAREA 28800 # allow for the largest possible header +define SZ_IMAGENAME 63 # max size of an image name +define SZ_FIELDNAME 31 # max size of a field name + +define OP_EDIT 1 # hedit opcodes +define OP_INIT 2 +define OP_ADD 3 +define OP_DELETE 4 + + +# HEDIT -- Edit or view selected fields of an image header or headers. This +# editor performs a single edit operation upon a relation, e.g., upon a set +# of fields of a set of images. Templates and expressions may be used to +# automatically select the images and fields to be edited, and to compute +# the new value of each field. + +procedure t_hedit() + +pointer fields # template listing fields to be processed +pointer valexpr # the value expression (if op=edit|add) + +bool noupdate, quit +int imlist, flist, nfields, up, min_lenuserarea +pointer sp, field, sections, s_fields, s_valexpr, im, ip, image, buf +int operation, verify, show, update + +pointer immap() +bool clgetb(), streq() +int btoi(), imtopenp(), imtgetim(), imofnlu(), imgnfn(), getline() +int envfind(), ctoi() + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (s_fields, SZ_LINE, TY_CHAR) + call salloc (s_valexpr, SZ_LINE, TY_CHAR) + call salloc (sections, SZ_FNAME, TY_CHAR) + + # Get the primary operands. + imlist = imtopenp ("images") + + # Determine type of operation to be performed. The default operation + # is edit. + + operation = OP_EDIT + if (clgetb ("add")) + operation = OP_ADD + else if (clgetb ("addonly")) + operation = OP_INIT + else if (clgetb ("delete")) + operation = OP_DELETE + + # Get list of fields to be edited, added, or deleted. + call clgstr ("fields", Memc[s_fields], SZ_LINE) + for (ip=s_fields; IS_WHITE (Memc[ip]); ip=ip+1) + ; + fields = ip + + # The value expression parameter is not used for the delete operation. + if (operation != OP_DELETE) { + call clgstr ("value", Memc[s_valexpr], SZ_LINE) + for (ip=s_valexpr; IS_WHITE (Memc[ip]); ip=ip+1) + ; + valexpr = ip + while (Memc[ip] != EOS) + ip = ip + 1 + while (ip > valexpr && IS_WHITE (Memc[ip-1])) + ip = ip - 1 + Memc[ip] = EOS + } else { + Memc[s_valexpr] = EOS + valexpr = s_valexpr + } + + # Get switches. If the expression value is ".", meaning print value + # rather than edit, then we do not use the switches. + + if (operation == OP_EDIT && streq (Memc[valexpr], ".")) { + update = NO + verify = NO + show = NO + } else { + update = btoi (clgetb ("update")) + verify = btoi (clgetb ("verify")) + show = btoi (clgetb ("show")) + } + + # Main processing loop. An image is processed in each pass through + # the loop. + + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # set the length of the user area + if (envfind ("min_lenuserarea", Memc[sections], SZ_FNAME) > 0) { + up = 1 + if (ctoi (Memc[sections], up, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Open the image. + iferr { + if (update == YES) + im = immap (Memc[image], READ_WRITE, min_lenuserarea) + else + im = immap (Memc[image], READ_ONLY, min_lenuserarea) + } then { + call erract (EA_WARN) + next + } + + if (operation == OP_INIT || operation == OP_ADD) { + # Add a field to the image header. This cannot be done within + # the IMGNFN loop because template expansion on the existing + # fields of the image header would discard the new field name + # since it does not yet exist. + + nfields = 1 + call he_getopsetimage (im, Memc[image], Memc[field]) + switch (operation) { + case OP_INIT: + call he_initfield (im, Memc[image], Memc[fields], + Memc[valexpr], verify, show, update) + case OP_ADD: + call he_addfield (im, Memc[image], Memc[fields], + Memc[valexpr], verify, show, update) + } + + } else { + # Open list of fields to be processed. + flist = imofnlu (im, Memc[fields]) + + nfields = 0 + while (imgnfn (flist, Memc[field], SZ_FNAME) != EOF) { + call he_getopsetimage (im, Memc[image], Memc[field]) + + switch (operation) { + case OP_EDIT: + call he_editfield (im, Memc[image], Memc[field], + Memc[valexpr], verify, show, update) + case OP_DELETE: + call he_deletefield (im, Memc[image], Memc[field], + Memc[valexpr], verify, show, update) + } + nfields = nfields + 1 + } + + call imcfnl (flist) + } + + # Update the image header and unmap the image. + + noupdate = false + quit = false + + if (update == YES) { + if (nfields == 0) + noupdate = true + else if (verify == YES) { + call eprintf ("update %s ? (yes): ") + call pargstr (Memc[image]) + call flush (STDERR) + + if (getline (STDIN, Memc[buf]) == EOF) + noupdate = true + else { + # Strip leading whitespace and trailing newline. + for (ip=buf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == 'q') { + quit = true + noupdate = true + } else if (! (Memc[ip] == '\n' || Memc[ip] == 'y')) + noupdate = true + } + } + + if (noupdate) { + call imseti (im, IM_WHEADER, NO) + call imunmap (im) + } else { + call imunmap (im) + if (show == YES) { + call printf ("%s updated\n") + call pargstr (Memc[image]) + } + } + } else + call imunmap (im) + + call flush (STDOUT) + if (quit) + break + } + + call imtclose (imlist) + call sfree (sp) +end + + +# HE_EDITFIELD -- Edit the value of the named field of the indicated image. +# The value expression is evaluated, interactively inspected if desired, +# and the resulting value put to the image. + +procedure he_editfield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +int goahead, nl +pointer sp, ip, oldval, newval, defval, o + +bool streq() +pointer evexpr() +extern he_getop() +int getline(), imaccf(), strldxs(), locpr() +errchk evexpr, getline, imaccf, he_gval + +begin + call smark (sp) + call salloc (oldval, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + call salloc (defval, SZ_LINE, TY_CHAR) + + # Verify that the named field exists before going any further. + if (field[1] != '$') + if (imaccf (im, field) == NO) { + call eprintf ("parameter %s,%s not found\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # Get the old value. + call he_gval (im, image, field, Memc[oldval], SZ_LINE) + + # Evaluate the expression. Encode the result operand as a string. + # If the expression is not parenthesized, assume that is is already + # a string literal. + + if (valexpr[1] == '(') { + o = evexpr (valexpr, locpr (he_getop), 0) + call he_encodeop (o, Memc[newval], SZ_LINE) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } else + call strcpy (valexpr, Memc[newval], SZ_LINE) + + if (streq (Memc[newval], ".")) { + # Merely print the value of the field. + + call printf ("%s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + + } else if (verify == YES) { + # Query for new value and edit the field. If the response is a + # blank line, use the default new value. If the response is "$" + # or EOF, do not change the value of the parameter. + + call strcpy (Memc[newval], Memc[defval], SZ_LINE) + call eprintf ("%s,%s (%s -> %s): ") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + call he_pargstr (Memc[defval]) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Do not skip leading whitespace; may be significant in a + # string literal. + + ip = newval + + # Do strip trailing newline since it is an artifact of getline. + nl = strldxs ("\n", Memc[ip]) + if (nl > 0) + Memc[ip+nl-1] = EOS + + # Decode user response. + if (Memc[ip] == '\\') { + ip = ip + 1 + goahead = YES + } else if (streq(Memc[ip],"n") || streq(Memc[ip],"no")) { + goahead = NO + } else if (streq(Memc[ip],"y") || streq(Memc[ip],"yes") || + Memc[ip] == EOS) { + call strcpy (Memc[defval], Memc[newval], SZ_LINE) + goahead = YES + } else { + if (ip > newval) + call strcpy (Memc[ip], Memc[newval], SZ_LINE) + goahead = YES + } + + # Edit field if so indicated. + if (goahead == YES) + call he_updatefield (im, image, field, Memc[oldval], + Memc[newval], show) + + call flush (STDOUT) + } + + } else { + call he_updatefield (im, image, field, Memc[oldval], Memc[newval], + show) + } + + call sfree (sp) +end + + +# HE_INITFIELD -- Add a new field to the indicated image. If the field already +# exists do not set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure he_initfield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imaddb, imastr, imaddi, imaddr + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + + if (imaccf (im, field) == YES) { + call eprintf ("parameter %s,%s already exists\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, max(1,strlen(valexpr)), TY_CHAR) + call strcpy (valexpr, O_VALC(o), ARB) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + + switch (O_TYPE(o)) { + case TY_BOOL: + call imaddb (im, field, O_VALB(o)) + case TY_CHAR: + call imastr (im, field, O_VALC(o)) + case TY_INT: + call imaddi (im, field, O_VALI(o)) + case TY_REAL: + call imaddr (im, field, O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# HE_ADDFIELD -- Add a new field to the indicated image. If the field already +# exists, merely set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure he_addfield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imaddb, imastr, imaddi, imaddr + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + + if (imaccf (im, field) == YES) { + call he_editfield (im, image, field, valexpr, verify, show, update) + call sfree (sp) + return + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, max(1,strlen(valexpr)), TY_CHAR) + call strcpy (valexpr, O_VALC(o), ARB) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + + switch (O_TYPE(o)) { + case TY_BOOL: + call imaddb (im, field, O_VALB(o)) + case TY_CHAR: + call imastr (im, field, O_VALC(o)) + case TY_INT: + call imaddi (im, field, O_VALI(o)) + case TY_REAL: + call imaddr (im, field, O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# HE_DELETEFIELD -- Delete a field from the indicated image. If the field does +# not exist, print a warning message. + +procedure he_deletefield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # not used +int verify # verify deletion interactively +int show # print record of edit +int update # enable updating of the image + +pointer sp, ip, newval +int getline(), imaccf() + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + if (imaccf (im, field) == NO) { + call eprintf ("nonexistent field %s,%s\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + if (verify == YES) { + # Delete pending verification. + + call eprintf ("delete %s,%s ? (yes): ") + call pargstr (image) + call pargstr (field) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Strip leading whitespace and trailing newline. + for (ip=newval; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == 'y') { + call imdelf (im, field) + if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } + } + } + + } else { + # Delete without verification. + + iferr (call imdelf (im, field)) + call erract (EA_WARN) + else if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } + } + + call sfree (sp) +end + + +# HE_UPDATEFIELD -- Update the value of an image header field. + +procedure he_updatefield (im, image, field, oldval, newval, show) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field name +char oldval[ARB] # old value, encoded as a string +char newval[ARB] # old value, encoded as a string +int show # print record of update + +begin + iferr (call impstr (im, field, newval)) { + call eprintf ("cannot update %s,%s\n") + call pargstr (image) + call pargstr (field) + return + } + + if (show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (oldval) + call he_pargstr (newval) + } +end + + +# HE_GVAL -- Get the value of an image header field and return it as a string. +# The ficticious special field "$I" (the image name) is recognized in this +# context in addition to the actual header fields. + +procedure he_gval (im, image, field, strval, maxch) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field whose value is to be returned +char strval[ARB] # string value of field (output) +int maxch # max chars out + +begin + if (field[1] == '$' && field[2] == 'I') + call strcpy (image, strval, maxch) + else if (field[1] == '$') + call imgstr (im, field[2], strval, maxch) + else + call imgstr (im, field, strval, maxch) +end + + +# HE_GETOP -- Satisfy an operand request from EVEXPR. In this context, +# operand names refer to the fields of the image header. The following +# special operand names are recognized: +# +# . a string literal, returned as the string "." +# $ the value of the current field +# $F the name of the current field +# $I the name of the current image +# $T the current time, expressed as an integer +# +# The companion procedure HE_GETOPSETIMAGE is used to pass the image pointer +# and image and field names. + +procedure he_getop (operand, o) + +char operand[ARB] # operand name +pointer o # operand (output) + +pointer h_im # getop common +char h_image[SZ_IMAGENAME] +char h_field[SZ_FIELDNAME] +common /hegopm/ h_im, h_image, h_field +bool streq() +long clktime() +errchk he_getfield + +begin + if (streq (operand, ".")) { + call xev_initop (o, 1, TY_CHAR) + call strcpy (".", O_VALC(o), 1) + + } else if (streq (operand, "$")) { + call he_getfield (h_im, h_field, o) + + } else if (streq (operand, "$F")) { + call xev_initop (o, SZ_FIELDNAME, TY_CHAR) + call strcpy (h_field, O_VALC(o), SZ_FIELDNAME) + + } else if (streq (operand, "$I")) { + call xev_initop (o, SZ_IMAGENAME, TY_CHAR) + call strcpy (h_image, O_VALC(o), SZ_IMAGENAME) + + } else if (streq (operand, "$T")) { + # Assignment of long into int may fail on some systems. Maybe + # should use type string and let database convert to long... + + call xev_initop (o, 0, TY_INT) + O_VALI(o) = clktime (long(0)) + + } else + call he_getfield (h_im, operand, o) +end + + +# HE_GETFIELD -- Return the value of the named field of the image header as +# an EVEXPR type operand structure. + +procedure he_getfield (im, field, o) + +pointer im # image descriptor +char field[ARB] # name of field to be returned +pointer o # pointer to output operand + +bool imgetb() +int imgeti(), imgftype() +real imgetr() + +begin + switch (imgftype (im, field)) { + case TY_BOOL: + call xev_initop (o, 0, TY_BOOL) + O_VALB(o) = imgetb (im, field) + + case TY_SHORT, TY_INT, TY_LONG: + call xev_initop (o, 0, TY_INT) + O_VALI(o) = imgeti (im, field) + + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + call xev_initop (o, 0, TY_REAL) + O_VALR(o) = imgetr (im, field) + + default: + call xev_initop (o, SZ_LINE, TY_CHAR) + call imgstr (im, field, O_VALC(o), SZ_LINE) + } +end + + +# HE_GETOPSETIMAGE -- Set the image pointer, image name, and field name (context +# of getop) in preparation for a getop call by EVEXPR. + +procedure he_getopsetimage (im, image, field) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited + +pointer h_im # getop common +char h_image[SZ_IMAGENAME] +char h_field[SZ_FIELDNAME] +common /hegopm/ h_im, h_image, h_field + +begin + h_im = im + call strcpy (image, h_image, SZ_IMAGENAME) + call strcpy (field, h_field, SZ_FIELDNAME) +end + + +# HE_ENCODEOP -- Encode an operand as returned by EVEXPR as a string. EVEXPR +# operands are restricted to the datatypes bool, int, real, and string. + +procedure he_encodeop (o, outstr, maxch) + +pointer o # operand to be encoded +char outstr[ARB] # output string +int maxch # max chars in outstr + +begin + switch (O_TYPE(o)) { + case TY_BOOL: + call sprintf (outstr, maxch, "%b") + call pargb (O_VALB(o)) + case TY_CHAR: + call sprintf (outstr, maxch, "%s") + call pargstr (O_VALC(o)) + case TY_INT: + call sprintf (outstr, maxch, "%d") + call pargi (O_VALI(o)) + case TY_REAL: + call sprintf (outstr, maxch, "%g") + call pargr (O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } +end + + +# HE_PARGSTR -- Pass a string to a printf statement, enclosing the string +# in quotes if it contains any whitespace. + +procedure he_pargstr (str) + +char str[ARB] # string to be printed +int ip +bool quoteit +pointer sp, op, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + op = buf + Memc[op] = '"' + op = op + 1 + + # Copy string to scratch buffer, enclosed in quotes. Check for + # embedded whitespace. + + quoteit = false + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_WHITE(str[ip])) { # detect whitespace + quoteit = true + Memc[op] = str[ip] + } else if (str[ip] == '\n') { # prettyprint newlines + Memc[op] = '\\' + op = op + 1 + Memc[op] = 'n' + } else # normal characters + Memc[op] = str[ip] + + if (ip < SZ_LINE) + op = op + 1 + } + + # If whitespace was seen pass the quoted string, otherwise pass the + # original input string. + + if (quoteit) { + Memc[op] = '"' + op = op + 1 + Memc[op] = EOS + call pargstr (Memc[buf]) + } else + call pargstr (str) + + call sfree (sp) +end diff --git a/pkg/images/imutil/src/hselect.x b/pkg/images/imutil/src/hselect.x new file mode 100644 index 00000000..5be85627 --- /dev/null +++ b/pkg/images/imutil/src/hselect.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <evexpr.h> +include <ctype.h> + +define LEN_USERAREA 28800 # allow for the largest possible header + + +# HSELECT -- Perform a relational select operation upon a set of images. +# Our function is to select all images from the input set matching some +# criteria, printing the listed fields of each selected image on the standard +# output in list form. +# +# N.B.: this task shares code with the HEDIT task. + +procedure t_hselect() + +pointer sp, im, image, fields, expr, missing, section +int imlist, ip, min_lenuserarea +int imtopenp(), imtgetim(), envfind(), ctoi() +pointer immap() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (fields, SZ_LINE, TY_CHAR) + call salloc (expr, SZ_LINE, TY_CHAR) + call salloc (missing, SZ_LINE, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + # Get the primary operands. + imlist = imtopenp ("images") + call clgstr ("fields", Memc[fields], SZ_LINE) + call clgstr ("expr", Memc[expr], SZ_LINE) + call clgstr ("missing", Memc[missing], SZ_LINE) + + # Main processing loop. An image is processed in each pass through + # the loop. + + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Check size of user area + if (envfind ("min_lenuserarea", Memc[section], SZ_FNAME) > 0) { + ip = 1 + if (ctoi (Memc[section], ip, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Open the image. + iferr (im = immap (Memc[image], READ_ONLY, min_lenuserarea)) { + call erract (EA_WARN) + next + } + + call he_getopsetimage (im, Memc[image], Memc[image]) + call hs_select (im, Memc[image], Memc[fields], Memc[expr], + Memc[missing]) + + call imunmap (im) + call flush (STDOUT) + } + + call imtclose (imlist) + call sfree (sp) +end + + +# HS_SELECT -- Evaluate the user supplied boolean expression using the +# header parameter values for an image, and print the values of the listed +# parameters on the standard output if the expression is true. + +procedure hs_select (im, image, fields, expr, missing) + +pointer im # image descriptor +char image[ARB] # name of image being evaluated +char fields[ARB] # fields to be passed if record is selected +char expr[ARB] # exression to be evaluated +char missing[ARB] # missing output value + +int fieldno +pointer o, sp, field, value, flist +pointer evexpr(), imofnlu() +int locpr(), imgnfn() +extern he_getop() +errchk evexpr, imofnlu, imgnfn + +begin + call smark (sp) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + + # Evaluate selection criteria. + o = evexpr (expr, locpr(he_getop), 0) + if (O_TYPE(o) != TY_BOOL) + call error (1, "expression must be boolean") + + # Print the values of the listed fields if the record was selected. + if (O_VALB(o)) { + flist = imofnlu (im, fields) + + fieldno = 1 + while (imgnfn (flist, Memc[field], SZ_FNAME) != EOF) { + iferr { + call he_gval (im, image, Memc[field], Memc[value], SZ_LINE) + } then { + call printf ("\t%s") + call pargstr (missing) + } else { + if (fieldno == 1) { + call printf ("%s") + call he_pargstr (Memc[value]) + } else { + call printf ("\t%s") + call he_pargstr (Memc[value]) + } + } + fieldno = fieldno + 1 + } + call printf ("\n") + + call imcfnl (flist) + call flush (STDOUT) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/iegsym.x b/pkg/images/imutil/src/iegsym.x new file mode 100644 index 00000000..6b7fbabf --- /dev/null +++ b/pkg/images/imutil/src/iegsym.x @@ -0,0 +1,37 @@ +include <ctotok.h> +include <imhdr.h> +include <ctype.h> +include <mach.h> +include <imset.h> +include <fset.h> +include <lexnum.h> +include <evvexpr.h> +include "gettok.h" + + +# Expression database symbol. +define LEN_SYM 2 +define SYM_TEXT Memi[$1] +define SYM_NARGS Memi[$1+1] + + + +# IE_GSYM -- Get symbol routine for the gettok package. + +pointer procedure ie_gsym (st, symname, nargs) + +pointer st #I symbol table +char symname[ARB] #I symbol to be looked up +int nargs #O number of macro arguments + +pointer sym +pointer strefsbuf(), stfind() + +begin + sym = stfind (st, symname) + if (sym == NULL) + return (NULL) + + nargs = SYM_NARGS(sym) + return (strefsbuf (st, SYM_TEXT(sym))) +end diff --git a/pkg/images/imutil/src/imaadd.gx b/pkg/images/imutil/src/imaadd.gx new file mode 100644 index 00000000..a31b47fc --- /dev/null +++ b/pkg/images/imutil/src/imaadd.gx @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +$for (silrd) +# IMA_ADD -- Image arithmetic addition. + +procedure ima_add$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (a == 0$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call aaddk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 0$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call aaddk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call aadd$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imadiv.gx b/pkg/images/imutil/src/imadiv.gx new file mode 100644 index 00000000..0aaac952 --- /dev/null +++ b/pkg/images/imutil/src/imadiv.gx @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_DIV -- Image arithmetic division. + +$for (silrd) +procedure ima_div$t (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +PIXEL a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() +PIXEL ima_efnc$t() +extern ima_efnc$t + +PIXEL divzero +common /imadcom$t/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) + call arcz$t (a, Mem$t[buf[2]], Mem$t[buf[1]], len, + ima_efnc$t) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 0$f) + call amovk$t (divzero, Mem$t[buf[1]], len) + else if (b == 1$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call adivk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call advz$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], + len, ima_efnc$t) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +PIXEL procedure ima_efnc$t (a) + +PIXEL a +PIXEL divzero +common /imadcom$t/ divzero + +begin + return (divzero) +end +$endfor diff --git a/pkg/images/imutil/src/imamax.gx b/pkg/images/imutil/src/imamax.gx new file mode 100644 index 00000000..5804825f --- /dev/null +++ b/pkg/images/imutil/src/imamax.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_MAX -- Image arithmetic maximum value. + +$for (silrd) +procedure ima_max$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) + call amaxk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) + call amaxk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call amax$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imamin.gx b/pkg/images/imutil/src/imamin.gx new file mode 100644 index 00000000..b0360510 --- /dev/null +++ b/pkg/images/imutil/src/imamin.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_MIN -- Image arithmetic minimum value. + +$for (silrd) +procedure ima_min$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) + call amink$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) + call amink$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call amin$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imamul.gx b/pkg/images/imutil/src/imamul.gx new file mode 100644 index 00000000..a2c2a4d9 --- /dev/null +++ b/pkg/images/imutil/src/imamul.gx @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_MUL -- Image arithmetic multiplication. + +$for (silrd) +procedure ima_mul$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (a == 1$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call amulk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 1$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call amulk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call amul$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imanl.gx b/pkg/images/imutil/src/imanl.gx new file mode 100644 index 00000000..c91631f7 --- /dev/null +++ b/pkg/images/imutil/src/imanl.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_NL -- For each line in the output image lines from the input images +# are returned. The input images are repeated as necessary. EOF is returned +# when the last line of the output image has been reached. One dimensional +# images are read only once and the data pointers are assumed to be unchanged +# from previous calls. The image line vectors must be initialized externally +# and then left untouched. +# +# This procedure is typically used when operations upon lines or pixels +# make sense in mixed dimensioned images. For example to add a one dimensional +# image to all lines of a higher dimensional image or to subtract a +# two dimensional image from all bands of three dimensional image. +# The lengths of the common dimensions should generally be checked +# for equality with xt_imleneq. + +$for (silrd) +int procedure ima_nl$t (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnl$t(), imgnl$t() + +begin + if (impnl$t (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnl$t (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnl$t (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end +$endfor diff --git a/pkg/images/imutil/src/imasub.gx b/pkg/images/imutil/src/imasub.gx new file mode 100644 index 00000000..4eb2a2c2 --- /dev/null +++ b/pkg/images/imutil/src/imasub.gx @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMA_SUB -- Image arithmetic subtraction. + +$for (silrd) +procedure ima_sub$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (a != 0$f) { + call asubk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + call aneg$t (Mem$t[buf[1]], Mem$t[buf[1]], len) + } else + call aneg$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 0$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call asubk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call asub$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imdelete.x b/pkg/images/imutil/src/imdelete.x new file mode 100644 index 00000000..204ff7fa --- /dev/null +++ b/pkg/images/imutil/src/imdelete.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <error.h> + +# IMDELETE -- Delete a list of images. If image cannot be deleted, warn but do +# not abort. Verify before deleting each image if user wishes. + +procedure t_imdelete() + +bool verify +int list, nchars +pointer sp, tty, imname, im + +pointer ttyodes(), immap() +int imtopenp(), imtgetim(), imaccess(), strlen(), strncmp() +bool clgetb() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + list = imtopenp ("images") + verify = clgetb ("verify") + if (verify) + tty = ttyodes ("terminal") + + while (imtgetim (list, Memc[imname], SZ_FNAME) != EOF) { + + if (verify) { + # If image does not exist, warn user (since verify mode is + # in effect). + + if (imaccess (Memc[imname], 0) == NO) { + call eprintf ("Warning: %s `%s'\n") + call pargstr ("Cannot delete nonexistent image") + call pargstr (Memc[imname]) + next + } + + # Set default action of verify prompt (override learning of + # most recent response). + + call clputb ("go_ahead", clgetb ("default_action")) + + # Output prompt, with image name. + call printf ("delete image ") + call ttyso (STDOUT, tty, YES) + call printf ("`%s'") + call pargstr (Memc[imname]) + call ttyso (STDOUT, tty, NO) + + # Include portion of image title in prompt. + ifnoerr (im = immap (Memc[imname], READ_ONLY, 0)) { + nchars = strlen (IM_TITLE(im)) + if (nchars > 0) { + call printf (" - %0.28s") + call pargstr (IM_TITLE(im)) + if (nchars > 28) + call printf ("...") + } + iferr (call imunmap (im)) + ; + } + + # Do the query. + if (! clgetb ("go_ahead")) + next + } + + iferr (call imdelete (Memc[imname])) + call erract (EA_WARN) + } + + # Reset the go_ahead parameter, overiding learn mode, in case delete + # is subsequently called from the background. Close tty descriptor. + + if (verify) { + call clputb ("go_ahead", true) + call ttycdes (tty) + } + + call imtclose (list) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imexpr.gx b/pkg/images/imutil/src/imexpr.gx new file mode 100644 index 00000000..139761fc --- /dev/null +++ b/pkg/images/imutil/src/imexpr.gx @@ -0,0 +1,1183 @@ +include <ctotok.h> +include <imhdr.h> +include <ctype.h> +include <mach.h> +include <imset.h> +include <fset.h> +include <lexnum.h> +include <evvexpr.h> +include "gettok.h" + + +# IMEXPR.X -- Image expression evaluator. + +define MAX_OPERANDS 26 +define MAX_ALIASES 10 +define DEF_LENINDEX 97 +define DEF_LENSTAB 1024 +define DEF_LENSBUF 8192 +define DEF_LINELEN 32768 + +# Input image operands. +define LEN_IMOPERAND 18 +define IO_OPNAME Memi[$1] # symbolic operand name +define IO_TYPE Memi[$1+1] # operand type +define IO_IM Memi[$1+2] # image pointer if image +define IO_V Memi[$1+3+($2)-1] # image i/o pointer +define IO_DATA Memi[$1+10] # current image line + # align +define IO_OP ($1+12) # pointer to evvexpr operand + +# Image operand types (IO_TYPE). +define IMAGE 1 # image (vector) operand +define NUMERIC 2 # numeric constant +define PARAMETER 3 # image parameter reference + +# Main imexpr descriptor. +define LEN_IMEXPR (24+LEN_IMOPERAND*MAX_OPERANDS) +define IE_ST Memi[$1] # symbol table +define IE_IM Memi[$1+1] # output image +define IE_NDIM Memi[$1+2] # dimension of output image +define IE_AXLEN Memi[$1+3+($2)-1] # dimensions of output image +define IE_INTYPE Memi[$1+10] # minimum input operand type +define IE_OUTTYPE Memi[$1+11] # datatype of output image +define IE_BWIDTH Memi[$1+12] # npixels boundary extension +define IE_BTYPE Memi[$1+13] # type of boundary extension +define IE_BPIXVAL Memr[P2R($1+14)] # boundary pixel value +define IE_V Memi[$1+15+($2)-1] # position in output image +define IE_NOPERANDS Memi[$1+22] # number of input operands + # align +define IE_IMOP ($1+24+(($2)-1)*LEN_IMOPERAND) # image operand array + +# Expression database symbol. +define LEN_SYM 2 +define SYM_TEXT Memi[$1] +define SYM_NARGS Memi[$1+1] + +# Argument list symbol +define LEN_ARGSYM 1 +define ARGNO Memi[$1] + + +# IMEXPR -- Task procedure for the image expression evaluator. This task +# generates an image by evaluating an arbitrary vector expression, which may +# reference other images as input operands. +# +# The input expression may be any legal EVVEXPR expression. Input operands +# must be specified using the reserved names "a" through "z", hence there are +# a maximum of 26 input operands. An input operand may be an image name or +# image section, an image header parameter, a numeric constant, or the name +# of a builtin keyword. Image header parameters are specified as, e.g., +# "a.naxis1" where the operand "a" must be assigned to an input image. The +# special image name "." refers to the output image generated in the last +# call to imexpr, making it easier to perform a sequence of operations. + +procedure t_imexpr() + +double dval +bool verbose, rangecheck +pointer out, st, sp, ie, dims, intype, outtype, ref_im +pointer outim, fname, expr, xexpr, output, section, data, imname +pointer oplist, opnam, opval, param, io, ip, op, o, im, ia, emsg +int len_exprbuf, fd, nchars, noperands, dtype, status, i, j +int ndim, npix, ch, percent, nlines, totlines, flags, mapflag + +real clgetr() +double imgetd() +int imgftype(), clgwrd(), ctod() +bool clgetb(), imgetb(), streq(), strne() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld() +int impnls(), impnli(), impnll(), impnlr(), impnld() +int open(), getci(), ie_getops(), lexnum(), stridxs() +int imgeti(), ctoi(), btoi(), locpr(), clgeti(), strncmp() +pointer ie_getexprdb(), ie_expandtext(), immap() +extern ie_getop(), ie_fcn() +pointer evvexpr() +long fstatl() + +string s_nodata "bad image: no data" +string s_badtype "unknown image type" +define numeric_ 91 +define image_ 92 + +begin + # call memlog ("--------- START IMEXPR -----------") + + call smark (sp) + call salloc (ie, LEN_IMEXPR, TY_STRUCT) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (output, SZ_PATHNAME, TY_CHAR) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (intype, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_FNAME, TY_CHAR) + call salloc (oplist, SZ_LINE, TY_CHAR) + call salloc (opval, SZ_LINE, TY_CHAR) + call salloc (dims, SZ_LINE, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + + # Initialize the main imexpr descriptor. + call aclri (Memi[ie], LEN_IMEXPR) + + verbose = clgetb ("verbose") + rangecheck = clgetb ("rangecheck") + + # Load the expression database, if any. + st = NULL + call clgstr ("exprdb", Memc[fname], SZ_PATHNAME) + if (strne (Memc[fname], "none")) + st = ie_getexprdb (Memc[fname]) + IE_ST(ie) = st + + # Get the expression to be evaluated and expand any file inclusions + # or macro references. + + len_exprbuf = SZ_COMMAND + call malloc (expr, len_exprbuf, TY_CHAR) + call clgstr ("expr", Memc[expr], len_exprbuf) + + if (Memc[expr] == '@') { + fd = open (Memc[expr+1], READ_ONLY, TEXT_FILE) + nchars = fstatl (fd, F_FILESIZE) + if (nchars > len_exprbuf) { + len_exprbuf = nchars + call realloc (expr, len_exprbuf, TY_CHAR) + } + for (op=expr; getci(fd,ch) != EOF; op = op + 1) { + if (ch == '\n') + Memc[op] = ' ' + else + Memc[op] = ch + } + Memc[op] = EOS + call close (fd) + } + + if (st != NULL) { + xexpr = ie_expandtext (st, Memc[expr]) + call mfree (expr, TY_CHAR) + expr = xexpr + if (verbose) { + call printf ("%s\n") + call pargstr (Memc[expr]) + call flush (STDOUT) + } + } + + # Get output image name. + call clgstr ("output", Memc[output], SZ_PATHNAME) + call imgimage (Memc[output], Memc[imname], SZ_PATHNAME) + + IE_BWIDTH(ie) = clgeti ("bwidth") + IE_BTYPE(ie) = clgwrd ("btype", Memc[oplist], SZ_LINE, + "|constant|nearest|reflect|wrap|project|") + IE_BPIXVAL(ie) = clgetr ("bpixval") + + # Determine the minimum input operand type. + call clgstr ("intype", Memc[intype], SZ_FNAME) + + if (strncmp (Memc[intype], "auto", 4) == 0) + IE_INTYPE(ie) = 0 + else { + switch (Memc[intype]) { + case 'i', 'l': + IE_INTYPE(ie) = TY_INT + case 'r': + IE_INTYPE(ie) = TY_REAL + case 'd': + IE_INTYPE(ie) = TY_DOUBLE + default: + IE_INTYPE(ie) = 0 + } + } + + # Parse the expression and generate a list of input operands. + noperands = ie_getops (st, Memc[expr], Memc[oplist], SZ_LINE) + IE_NOPERANDS(ie) = noperands + + # Process the list of input operands and initialize each operand. + # This means fetch the value of the operand from the CL, determine + # the operand type, and initialize the image operand descriptor. + # The operand list is returned as a sequence of EOS delimited strings. + + opnam = oplist + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (Memc[opnam] == EOS) + call error (1, "malformed operand list") + + call clgstr (Memc[opnam], Memc[opval], SZ_LINE) + IO_OPNAME(io) = Memc[opnam] + ip = opval + + # Initialize the input operand; these values are overwritten below. + o = IO_OP(io) + call aclri (Memi[o], LEN_OPERAND) + + if (Memc[ip] == '.' && (Memc[ip+1] == EOS || Memc[ip+1] == '[')) { + # A "." is shorthand for the last output image. + call strcpy (Memc[ip+1], Memc[section], SZ_FNAME) + call clgstr ("lastout", Memc[opval], SZ_LINE) + call strcat (Memc[section], Memc[opval], SZ_LINE) + goto image_ + + } else if (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.') { + # "a.foo" refers to parameter foo of image A. Mark this as + # a parameter operand for now, and patch it up later. + + IO_TYPE(io) = PARAMETER + IO_DATA(io) = ip + call salloc (IO_DATA(io), SZ_LINE, TY_CHAR) + call strcpy (Memc[ip], Memc[IO_DATA(io)], SZ_LINE) + + } else if (ctod (Memc, ip, dval) > 0) { + if (Memc[ip] != EOS) + goto image_ + + # A numeric constant. +numeric_ IO_TYPE(io) = NUMERIC + + ip = opval + switch (lexnum (Memc, ip, nchars)) { + case LEX_REAL: + dtype = TY_REAL + if (stridxs("dD",Memc[opval]) > 0 || nchars > NDIGITS_RP+3) + dtype = TY_DOUBLE + O_TYPE(o) = dtype + if (dtype == TY_REAL) + O_VALR(o) = dval + else + O_VALD(o) = dval + default: + O_TYPE(o) = TY_INT + O_LEN(o) = 0 + O_VALI(o) = int(dval) + } + + } else { + # Anything else is assumed to be an image name. +image_ + ip = opval + call imgimage (Memc[ip], Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], Memc[imname])) + call error (2, "input and output images cannot be the same") + + im = immap (Memc[ip], READ_ONLY, 0) + + # Set any image options. + if (IE_BWIDTH(ie) > 0) { + call imseti (im, IM_NBNDRYPIX, IE_BWIDTH(ie)) + call imseti (im, IM_TYBNDRY, IE_BTYPE(ie)) + call imsetr (im, IM_BNDRYPIXVAL, IE_BPIXVAL(ie)) + } + + IO_TYPE(io) = IMAGE + call amovkl (1, IO_V(io,1), IM_MAXDIM) + IO_IM(io) = im + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + O_TYPE(o) = IM_PIXTYPE(im) + case TY_COMPLEX: + O_TYPE(o) = TY_REAL + default: # TY_USHORT + O_TYPE(o) = TY_INT + } + + O_TYPE(o) = max (IE_INTYPE(ie), O_TYPE(o)) + O_LEN(o) = IM_LEN(im,1) + O_FLAGS(o) = 0 + + # If one dimensional image read in data and be done with it. + if (IM_NDIM(im) == 1) { + switch (O_TYPE(o)) { + $for (silrd) + case TY_PIXEL: + if (imgnl$t (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + $endfor + default: + call error (4, s_badtype) + } + } + } + + + # Get next operand name. + while (Memc[opnam] != EOS) + opnam = opnam + 1 + opnam = opnam + 1 + } + + # Go back and patch up any "a.foo" type parameter references. The + # reference input operand (e.g. "a") must be of type IMAGE and must + # point to a valid open image. + + do i = 1, noperands { + mapflag = NO + io = IE_IMOP(ie,i) + ip = IO_DATA(io) + if (IO_TYPE(io) != PARAMETER) + next + + # Locate referenced symbolic image operand (e.g. "a"). + ia = NULL + do j = 1, noperands { + ia = IE_IMOP(ie,j) + if (IO_OPNAME(ia) == Memc[ip] && IO_TYPE(ia) == IMAGE) + break + ia = NULL + } + if (ia == NULL && (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.')) { + # The parameter operand is something like 'a.foo' however + # the image operand 'a' is not in the list derived from the + # expression, perhaps because we just want to use a parameter + # from a reference image and not the image itself. In this + # case map the image so we can get the parameter. + + call strcpy (Memc[ip], Memc[opval], 1) + call clgstr (Memc[opval], Memc[opnam], SZ_LINE) + call imgimage (Memc[opnam], Memc[fname], SZ_PATHNAME) + + iferr (im = immap (Memc[fname], READ_ONLY, 0)) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + } else + mapflag = YES + + } else if (ia == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + + } else + im = IO_IM(ia) + + # Get the parameter value and set up operand struct. + param = ip + 2 + IO_TYPE(io) = NUMERIC + o = IO_OP(io) + O_LEN(o) = 0 + + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[ip]) + call error (6, Memc[emsg]) + } + + if (mapflag == YES) + call imunmap (im) + } + + # Determine the reference image from which we will inherit image + # attributes such as the WCS. If the user specifies this we use + # the indicated image, otherwise we use the input image operand with + # the highest dimension. + + call clgstr ("refim", Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], "auto")) { + # Locate best reference image (highest dimension). + ndim = 0 + ref_im = NULL + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + if (IM_NDIM(im) > ndim) { + ref_im = im + ndim = IM_NDIM(im) + } + } + } else { + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == Memc[fname] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad wcsimage reference image %s") + call pargstr (Memc[fname]) + call error (7, Memc[emsg]) + } + ref_im = IO_IM(io) + } + + # Determine the dimension and size of the output image. If the "dims" + # parameter is set this determines the image dimension, otherwise we + # determine the best output image dimension and size from the input + # images. The exception is the line length, which is determined by + # the image line operand returned when the first line of the image + # is evaluated. + + call clgstr ("dims", Memc[dims], SZ_LINE) + if (streq (Memc[dims], "auto")) { + # Determine the output image dimensions from the input images. + call amovki (1, IE_AXLEN(ie,2), IM_MAXDIM-1) + IE_AXLEN(ie,1) = 0 + ndim = 1 + + do i = 1, noperands { + io = IE_IMOP(ie,i) + im = IO_IM(io) + if (IO_TYPE(io) != IMAGE || im == NULL) + next + + ndim = max (ndim, IM_NDIM(im)) + do j = 2, IM_NDIM(im) { + npix = IM_LEN(im,j) + if (npix > 1) { + if (IE_AXLEN(ie,j) <= 1) + IE_AXLEN(ie,j) = npix + else + IE_AXLEN(ie,j) = min (IE_AXLEN(ie,j), npix) + } + } + } + IE_NDIM(ie) = ndim + + } else { + # Use user specified output image dimensions. + ndim = 0 + for (ip=dims; ctoi(Memc,ip,npix) > 0; ) { + ndim = ndim + 1 + IE_AXLEN(ie,ndim) = npix + for (ch=Memc[ip]; IS_WHITE(ch) || ch == ','; ch=Memc[ip]) + ip = ip + 1 + } + IE_NDIM(ie) = ndim + } + + # Determine the pixel type of the output image. + call clgstr ("outtype", Memc[outtype], SZ_FNAME) + + if (strncmp (Memc[outtype], "auto", 4) == 0) { + IE_OUTTYPE(ie) = 0 + } else if (strncmp (Memc[outtype], "ref", 3) == 0) { + if (ref_im != NULL) + IE_OUTTYPE(ie) = IM_PIXTYPE(ref_im) + else + IE_OUTTYPE(ie) = 0 + } else { + switch (Memc[outtype]) { + case 'u': + IE_OUTTYPE(ie) = TY_USHORT + case 's': + IE_OUTTYPE(ie) = TY_SHORT + case 'i': + IE_OUTTYPE(ie) = TY_INT + case 'l': + IE_OUTTYPE(ie) = TY_LONG + case 'r': + IE_OUTTYPE(ie) = TY_REAL + case 'd': + IE_OUTTYPE(ie) = TY_DOUBLE + default: + call error (8, "bad outtype") + } + } + + # Open the output image. If the output image name has a section we + # are writing to a section of an existing image. + + call imgsection (Memc[output], Memc[section], SZ_FNAME) + if (Memc[section] != EOS && Memc[section] != NULL) { + outim = immap (Memc[output], READ_WRITE, 0) + IE_AXLEN(ie,1) = IM_LEN(outim,1) + } else { + if (ref_im != NULL) + outim = immap (Memc[output], NEW_COPY, ref_im) + else + outim = immap (Memc[output], NEW_IMAGE, 0) + IM_LEN(outim,1) = 0 + call amovl (IE_AXLEN(ie,2), IM_LEN(outim,2), IM_MAXDIM-1) + IM_NDIM(outim) = IE_NDIM(ie) + IM_PIXTYPE(outim) = 0 + } + + # Initialize output image line pointer. + call amovkl (1, IE_V(ie,1), IM_MAXDIM) + + percent = 0 + nlines = 0 + totlines = 1 + do i = 2, IM_NDIM(outim) + totlines = totlines * IM_LEN(outim,i) + + # Generate the pixel data for the output image line by line, + # evaluating the user supplied expression to produce each image + # line. Images may be any dimension, datatype, or size. + + # call memlog ("--------- PROCESS IMAGE -----------") + + out = NULL + repeat { + # call memlog1 ("--------- line %d ----------", nlines + 1) + + # Output image line generated by last iteration. + if (out != NULL) { + op = data + if (O_LEN(out) == 0) { + # Output image line is a scalar. + + switch (O_TYPE(out)) { + case TY_BOOL: + Memi[op] = O_VALI(out) + call amovki (O_VALI(out), Memi[op], IM_LEN(outim,1)) + $for (silrd) + case TY_PIXEL: + call amovk$t (O_VAL$T(out), Mem$t[op], IM_LEN(outim,1)) + $endfor + } + + } else { + # Output image line is a vector. + + npix = min (O_LEN(out), IM_LEN(outim,1)) + ip = O_VALP(out) + switch (O_TYPE(out)) { + case TY_BOOL: + call amovi (Memi[ip], Memi[op], npix) + $for (silrd) + case TY_PIXEL: + call amov$t (Mem$t[ip], Mem$t[op], npix) + $endfor + } + } + + call evvfree (out) + out = NULL + } + + # Get the next line in all input images. If EOF is seen on the + # image we merely rewind and keep going. This allows a vector, + # plane, etc. to be applied to each line, band, etc. of a higher + # dimensioned image. + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + o = IO_OP(io) + + # Data for a 1D image was read in above. + if (IM_NDIM(im) == 1) + next + + switch (O_TYPE(o)) { + $for (silrd) + case TY_PIXEL: + if (imgnl$t (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnl$t (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + $endfor + default: + call error (10, s_badtype) + } + } + + # call memlog (".......... enter evvexpr ..........") + + # This is it! Evaluate the vector expression. + flags = 0 + if (rangecheck) + flags = or (flags, EV_RNGCHK) + + out = evvexpr (Memc[expr], + locpr(ie_getop), ie, locpr(ie_fcn), ie, flags) + + # call memlog (".......... exit evvexpr ..........") + + # If the pixel type and line length of the output image are + # still undetermined set them to match the output operand. + + if (IM_PIXTYPE(outim) == 0) { + if (IE_OUTTYPE(ie) == 0) { + if (O_TYPE(out) == TY_BOOL) + IE_OUTTYPE(ie) = TY_INT + else + IE_OUTTYPE(ie) = O_TYPE(out) + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } else + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } + if (IM_LEN(outim,1) == 0) { + if (IE_AXLEN(ie,1) == 0) { + if (O_LEN(out) == 0) { + IE_AXLEN(ie,1) = 1 + IM_LEN(outim,1) = 1 + } else { + IE_AXLEN(ie,1) = O_LEN(out) + IM_LEN(outim,1) = O_LEN(out) + } + } else + IM_LEN(outim,1) = IE_AXLEN(ie,1) + } + + # Print percent done. + if (verbose) { + nlines = nlines + 1 + if (nlines * 100 / totlines >= percent + 10) { + percent = percent + 10 + call printf ("%2d%% ") + call pargi (percent) + call flush (STDOUT) + } + } + + switch (O_TYPE(out)) { + case TY_BOOL: + status = impnli (outim, data, IE_V(ie,1)) + $for (silrd) + case TY_PIXEL: + status = impnl$t (outim, data, IE_V(ie,1)) + $endfor + default: + call error (11, "expression type incompatible with image") + } + } until (status == EOF) + + # call memlog ("--------- DONE PROCESSING IMAGE -----------") + + if (verbose) { + call printf ("- done\n") + call flush (STDOUT) + } + + # All done. Unmap images. + call imunmap (outim) + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) == IMAGE && IO_IM(io) != NULL) + call imunmap (IO_IM(io)) + } + + # Clean up. + do i = 1, noperands { + io = IE_IMOP(ie,i) + o = IO_OP(io) + if (O_TYPE(o) == TY_CHAR) + call mfree (O_VALP(o), TY_CHAR) + } + + call evvfree (out) + call mfree (expr, TY_CHAR) + if (st != NULL) + call stclose (st) + + call clpstr ("lastout", Memc[output]) + call sfree (sp) +end + + +# IE_GETOP -- Called by evvexpr to fetch an input image operand. + +procedure ie_getop (ie, opname, o) + +pointer ie #I imexpr descriptor +char opname[ARB] #I operand name +pointer o #I output operand to be filled in + +int axis, i +pointer param, data +pointer sp, im, io, v + +bool imgetb() +int imgeti() +double imgetd() +int imgftype(), btoi() +errchk malloc +define err_ 91 + +begin + call smark (sp) + + if (IS_LOWER(opname[1]) && opname[2] == EOS) { + # Image operand. + + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1]) + break + io = NULL + } + + if (io == NULL) + goto err_ + else + v = IO_OP(io) + + call amovi (Memi[v], Memi[o], LEN_OPERAND) + if (IO_TYPE(io) == IMAGE) { + O_VALP(o) = IO_DATA(io) + O_FLAGS(o) = 0 + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[2] == '.') { + # Image parameter reference, e.g., "a.foo". + call salloc (param, SZ_FNAME, TY_CHAR) + + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) + goto err_ + + # Get the parameter value and set up operand struct. + call strcpy (opname[3], Memc[param], SZ_FNAME) + im = IO_IM(io) + + iferr (O_TYPE(o) = imgftype (im, Memc[param])) + goto err_ + + switch (O_TYPE(o)) { + case TY_BOOL: + iferr (O_VALI(o) = btoi (imgetb (im, Memc[param]))) + goto err_ + + case TY_CHAR: + O_LEN(o) = SZ_LINE + O_FLAGS(o) = O_FREEVAL + iferr { + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + } then + goto err_ + + case TY_INT: + iferr (O_VALI(o) = imgeti (im, Memc[param])) + goto err_ + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + iferr (O_VALD(o) = imgetd (im, Memc[param])) + goto err_ + + default: + goto err_ + } + + call sfree (sp) + return + + } else if (IS_UPPER(opname[1]) && opname[2] == EOS) { + # The current pixel coordinate [I,J,K,...]. The line coordinate + # is a special case since the image is computed a line at a time. + # If "I" is requested return a vector where v[i] = i. For J, K, + # etc. just return the scalar index value. + + axis = opname[1] - 'I' + 1 + if (axis == 1) { + O_TYPE(o) = TY_INT + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else { + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + } + call malloc (data, O_LEN(o), TY_INT) + do i = 1, O_LEN(o) + Memi[data+i-1] = i + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } else { + O_TYPE(o) = TY_INT + #O_LEN(o) = 0 + #if (axis < 1 || axis > IM_MAXDIM) + #O_VALI(o) = 1 + #else + #O_VALI(o) = IE_V(ie,axis) + #O_FLAGS(o) = 0 + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + call malloc (data, O_LEN(o), TY_INT) + if (axis < 1 || axis > IM_MAXDIM) + call amovki (1, Memi[data], O_LEN(o)) + else + call amovki (IE_V(ie,axis), Memi[data], O_LEN(o)) + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } + + call sfree (sp) + return + } + +err_ + O_TYPE(o) = ERR + call sfree (sp) +end + + +# IE_FCN -- Called by evvexpr to execute an imexpr special function. + +procedure ie_fcn (ie, fcn, args, nargs, o) + +pointer ie #I imexpr descriptor +char fcn[ARB] #I function name +pointer args[ARB] #I input arguments +int nargs #I number of input arguments +pointer o #I output operand to be filled in + +begin + # No functions yet. + O_TYPE(o) = ERR +end + + +# IE_GETEXPRDB -- Read the expression database into a symbol table. The +# input file has the following structure: +# +# <symbol>['(' arg-list ')'][':'|'='] replacement-text +# +# Symbols must be at the beginning of a line. The expression text is +# terminated by a nonempty, noncomment line with no leading whitespace. + +pointer procedure ie_getexprdb (fname) + +char fname[ARB] #I file to be read + +pointer sym, sp, lbuf, st, a_st, ip, symname, tokbuf, text +int tok, fd, line, nargs, op, token, buflen, offset, stpos, n +errchk open, getlline, stopen, stenter, ie_puttok +int open(), getlline(), ctotok(), stpstr() +pointer stopen(), stenter() +define skip_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + call salloc (text, SZ_COMMAND, TY_CHAR) + call salloc (tokbuf, SZ_COMMAND, TY_CHAR) + call salloc (symname, SZ_FNAME, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + st = stopen ("imexpr", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + a_st = stopen ("args", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + line = 0 + + while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + + # Replace single quotes by double quotes because things + # should behave like the command line but this routine + # uses ctotok which treats single quotes as character + # constants. + + for (ip=lbuf; Memc[ip]!=EOS; ip=ip+1) { + if (Memc[ip] == '\'') + Memc[ip] = '"' + } + + # Skip comments and blank lines. + ip = lbuf + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == '\n' || Memc[ip] == '#') + next + + # Get symbol name. + if (ctotok (Memc,ip,Memc[symname],SZ_FNAME) != TOK_IDENTIFIER) { + call eprintf ("exprdb: expected identifier at line %d\n") + call pargi (line) +skip_ while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + if (Memc[lbuf] == '\n') + break + } + } + + call stmark (a_st, stpos) + + # Check for the optional argument-symbol list. Allow only a + # single space between the symbol name and its argument list, + # otherwise we can't tell the difference between an argument + # list and the parenthesized expression which follows. + + if (Memc[ip] == ' ') + ip = ip + 1 + + if (Memc[ip] == '(') { + ip = ip + 1 + n = 0 + repeat { + tok = ctotok (Memc, ip, Memc[tokbuf], SZ_FNAME) + if (tok == TOK_IDENTIFIER) { + sym = stenter (a_st, Memc[tokbuf], LEN_ARGSYM) + n = n + 1 + ARGNO(sym) = n + } else if (Memc[tokbuf] == ',') { + ; + } else if (Memc[tokbuf] != ')') { + call eprintf ("exprdb: bad arglist at line %d\n") + call pargi (line) + call stfree (a_st, stpos) + goto skip_ + } + } until (Memc[tokbuf] == ')') + } + + # Check for the optional ":" or "=". + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == ':' || Memc[ip] == '=') + ip = ip + 1 + + # Accumulate the expression text. + buflen = SZ_COMMAND + op = 1 + + repeat { + repeat { + token = ctotok (Memc, ip, Memc[tokbuf+1], SZ_COMMAND) + if (Memc[tokbuf] == '#') + break + else if (token != TOK_EOS && token != TOK_NEWLINE) { + if (token == TOK_STRING) { + Memc[tokbuf] = '"' + call strcat ("""", Memc[tokbuf], SZ_COMMAND) + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf]) + } else + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf+1]) + } + } until (token == TOK_EOS) + + if (getlline (fd, Memc[lbuf], SZ_COMMAND) == EOF) + break + else + line = line + 1 + + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (ip == lbuf) { + call ungetline (fd, Memc[lbuf]) + line = line - 1 + break + } + } + + # Free any argument list symbols. + call stfree (a_st, stpos) + + # Scan the expression text and count the number of $N arguments. + nargs = 0 + for (ip=text; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && IS_DIGIT(Memc[ip+1])) { + nargs = max (nargs, TO_INTEG(Memc[ip+1])) + ip = ip + 1 + } + + # Enter symbol in table. + sym = stenter (st, Memc[symname], LEN_SYM) + offset = stpstr (st, Memc[text], 0) + SYM_TEXT(sym) = offset + SYM_NARGS(sym) = nargs + } + + call stclose (a_st) + call sfree (sp) + + return (st) +end + + +# IE_PUTTOK -- Append a token string to a text buffer. + +procedure ie_puttok (a_st, text, op, buflen, token) + +pointer a_st #I argument-symbol table +pointer text #U text buffer +int op #U output pointer +int buflen #U buffer length, chars +char token[ARB] #I token string + +pointer sym +int ip, ch1, ch2 +pointer stfind() +errchk realloc + +begin + # Replace any symbolic arguments by "$N". + if (a_st != NULL && IS_ALPHA(token[1])) { + sym = stfind (a_st, token) + if (sym != NULL) { + token[1] = '$' + token[2] = TO_DIGIT(ARGNO(sym)) + token[3] = EOS + } + } + + # Append the token string to the text buffer. + for (ip=1; token[ip] != EOS; ip=ip+1) { + if (op + 1 > buflen) { + buflen = buflen + SZ_COMMAND + call realloc (text, buflen, TY_CHAR) + } + + # The following is necessary because ctotok parses tokens such as + # "$N", "==", "!=", etc. as two tokens. We need to rejoin these + # characters to make one token. + + if (op > 1 && token[ip+1] == EOS) { + ch1 = Memc[text+op-3] + ch2 = token[ip] + + if (ch1 == '$' && IS_DIGIT(ch2)) + op = op - 1 + else if (ch1 == '*' && ch2 == '*') + op = op - 1 + else if (ch1 == '/' && ch2 == '/') + op = op - 1 + else if (ch1 == '<' && ch2 == '=') + op = op - 1 + else if (ch1 == '>' && ch2 == '=') + op = op - 1 + else if (ch1 == '=' && ch2 == '=') + op = op - 1 + else if (ch1 == '!' && ch2 == '=') + op = op - 1 + else if (ch1 == '?' && ch2 == '=') + op = op - 1 + else if (ch1 == '&' && ch2 == '&') + op = op - 1 + else if (ch1 == '|' && ch2 == '|') + op = op - 1 + } + + Memc[text+op-1] = token[ip] + op = op + 1 + } + + # Append a space to ensure that tokens are delimited. + Memc[text+op-1] = ' ' + op = op + 1 + + Memc[text+op-1] = EOS +end + + +# IE_EXPANDTEXT -- Scan an expression, performing macro substitution on the +# contents and returning a fully expanded string. + +pointer procedure ie_expandtext (st, expr) + +pointer st #I symbol table (macros) +char expr[ARB] #I input expression + +pointer buf, gt +int buflen, nchars +int locpr(), gt_expand() +pointer gt_opentext() +extern ie_gsym() + +begin + buflen = SZ_COMMAND + call malloc (buf, buflen, TY_CHAR) + + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE) + nchars = gt_expand (gt, buf, buflen) + call gt_close (gt) + + return (buf) +end + + +# IE_GETOPS -- Parse the expression and generate a list of input operands. +# The output operand list is returned as a sequence of EOS delimited strings. + +int procedure ie_getops (st, expr, oplist, maxch) + +pointer st #I symbol table +char expr[ARB] #I input expression +char oplist[ARB] #O operand list +int maxch #I max chars out + +int noperands, ch, i +int ops[MAX_OPERANDS] +pointer gt, sp, tokbuf, op + +extern ie_gsym() +pointer gt_opentext() +int locpr(), gt_rawtok(), gt_nexttok() +errchk gt_opentext, gt_rawtok + +begin + call smark (sp) + call salloc (tokbuf, SZ_LINE, TY_CHAR) + + call aclri (ops, MAX_OPERANDS) + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE+GT_NOCOMMAND) + + # This assumes that operand names are the letters "a" to "z". + while (gt_rawtok (gt, Memc[tokbuf], SZ_LINE) != EOF) { + ch = Memc[tokbuf] + if (IS_LOWER(ch) && Memc[tokbuf+1] == EOS) + if (gt_nexttok (gt) != '(') + ops[ch-'a'+1] = 1 + } + + call gt_close (gt) + + op = 1 + noperands = 0 + do i = 1, MAX_OPERANDS + if (ops[i] != 0 && op < maxch) { + oplist[op] = 'a' + i - 1 + op = op + 1 + oplist[op] = EOS + op = op + 1 + noperands = noperands + 1 + } + + oplist[op] = EOS + op = op + 1 + + call sfree (sp) + return (noperands) +end diff --git a/pkg/images/imutil/src/imexpr.x b/pkg/images/imutil/src/imexpr.x new file mode 100644 index 00000000..f23c04d6 --- /dev/null +++ b/pkg/images/imutil/src/imexpr.x @@ -0,0 +1,1263 @@ +include <ctotok.h> +include <imhdr.h> +include <ctype.h> +include <mach.h> +include <imset.h> +include <fset.h> +include <lexnum.h> +include <evvexpr.h> +include "gettok.h" + + +# IMEXPR.X -- Image expression evaluator. + +define MAX_OPERANDS 26 +define MAX_ALIASES 10 +define DEF_LENINDEX 97 +define DEF_LENSTAB 1024 +define DEF_LENSBUF 8192 +define DEF_LINELEN 32768 + +# Input image operands. +define LEN_IMOPERAND 18 +define IO_OPNAME Memi[$1] # symbolic operand name +define IO_TYPE Memi[$1+1] # operand type +define IO_IM Memi[$1+2] # image pointer if image +define IO_V Memi[$1+3+($2)-1] # image i/o pointer +define IO_DATA Memi[$1+10] # current image line + # align +define IO_OP ($1+12) # pointer to evvexpr operand + +# Image operand types (IO_TYPE). +define IMAGE 1 # image (vector) operand +define NUMERIC 2 # numeric constant +define PARAMETER 3 # image parameter reference + +# Main imexpr descriptor. +define LEN_IMEXPR (24+LEN_IMOPERAND*MAX_OPERANDS) +define IE_ST Memi[$1] # symbol table +define IE_IM Memi[$1+1] # output image +define IE_NDIM Memi[$1+2] # dimension of output image +define IE_AXLEN Memi[$1+3+($2)-1] # dimensions of output image +define IE_INTYPE Memi[$1+10] # minimum input operand type +define IE_OUTTYPE Memi[$1+11] # datatype of output image +define IE_BWIDTH Memi[$1+12] # npixels boundary extension +define IE_BTYPE Memi[$1+13] # type of boundary extension +define IE_BPIXVAL Memr[P2R($1+14)] # boundary pixel value +define IE_V Memi[$1+15+($2)-1] # position in output image +define IE_NOPERANDS Memi[$1+22] # number of input operands + # align +define IE_IMOP ($1+24+(($2)-1)*LEN_IMOPERAND) # image operand array + +# Expression database symbol. +define LEN_SYM 2 +define SYM_TEXT Memi[$1] +define SYM_NARGS Memi[$1+1] + +# Argument list symbol +define LEN_ARGSYM 1 +define ARGNO Memi[$1] + + +# IMEXPR -- Task procedure for the image expression evaluator. This task +# generates an image by evaluating an arbitrary vector expression, which may +# reference other images as input operands. +# +# The input expression may be any legal EVVEXPR expression. Input operands +# must be specified using the reserved names "a" through "z", hence there are +# a maximum of 26 input operands. An input operand may be an image name or +# image section, an image header parameter, a numeric constant, or the name +# of a builtin keyword. Image header parameters are specified as, e.g., +# "a.naxis1" where the operand "a" must be assigned to an input image. The +# special image name "." refers to the output image generated in the last +# call to imexpr, making it easier to perform a sequence of operations. + +procedure t_imexpr() + +double dval +bool verbose, rangecheck +pointer out, st, sp, ie, dims, intype, outtype, ref_im +pointer outim, fname, expr, xexpr, output, section, data, imname +pointer oplist, opnam, opval, param, io, ip, op, o, im, ia, emsg +int len_exprbuf, fd, nchars, noperands, dtype, status, i, j +int ndim, npix, ch, percent, nlines, totlines, flags, mapflag + +real clgetr() +double imgetd() +int imgftype(), clgwrd(), ctod() +bool clgetb(), imgetb(), streq(), strne() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld() +int impnls(), impnli(), impnll(), impnlr(), impnld() +int open(), getci(), ie_getops(), lexnum(), stridxs() +int imgeti(), ctoi(), btoi(), locpr(), clgeti(), strncmp() +pointer ie_getexprdb(), ie_expandtext(), immap() +extern ie_getop(), ie_fcn() +pointer evvexpr() +long fstatl() + +string s_nodata "bad image: no data" +string s_badtype "unknown image type" +define numeric_ 91 +define image_ 92 + +begin + # call memlog ("--------- START IMEXPR -----------") + + call smark (sp) + call salloc (ie, LEN_IMEXPR, TY_STRUCT) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (output, SZ_PATHNAME, TY_CHAR) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (intype, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_FNAME, TY_CHAR) + call salloc (oplist, SZ_LINE, TY_CHAR) + call salloc (opval, SZ_LINE, TY_CHAR) + call salloc (dims, SZ_LINE, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + + # Initialize the main imexpr descriptor. + call aclri (Memi[ie], LEN_IMEXPR) + + verbose = clgetb ("verbose") + rangecheck = clgetb ("rangecheck") + + # Load the expression database, if any. + st = NULL + call clgstr ("exprdb", Memc[fname], SZ_PATHNAME) + if (strne (Memc[fname], "none")) + st = ie_getexprdb (Memc[fname]) + IE_ST(ie) = st + + # Get the expression to be evaluated and expand any file inclusions + # or macro references. + + len_exprbuf = SZ_COMMAND + call malloc (expr, len_exprbuf, TY_CHAR) + call clgstr ("expr", Memc[expr], len_exprbuf) + + if (Memc[expr] == '@') { + fd = open (Memc[expr+1], READ_ONLY, TEXT_FILE) + nchars = fstatl (fd, F_FILESIZE) + if (nchars > len_exprbuf) { + len_exprbuf = nchars + call realloc (expr, len_exprbuf, TY_CHAR) + } + for (op=expr; getci(fd,ch) != EOF; op = op + 1) { + if (ch == '\n') + Memc[op] = ' ' + else + Memc[op] = ch + } + Memc[op] = EOS + call close (fd) + } + + if (st != NULL) { + xexpr = ie_expandtext (st, Memc[expr]) + call mfree (expr, TY_CHAR) + expr = xexpr + if (verbose) { + call printf ("%s\n") + call pargstr (Memc[expr]) + call flush (STDOUT) + } + } + + # Get output image name. + call clgstr ("output", Memc[output], SZ_PATHNAME) + call imgimage (Memc[output], Memc[imname], SZ_PATHNAME) + + IE_BWIDTH(ie) = clgeti ("bwidth") + IE_BTYPE(ie) = clgwrd ("btype", Memc[oplist], SZ_LINE, + "|constant|nearest|reflect|wrap|project|") + IE_BPIXVAL(ie) = clgetr ("bpixval") + + # Determine the minimum input operand type. + call clgstr ("intype", Memc[intype], SZ_FNAME) + + if (strncmp (Memc[intype], "auto", 4) == 0) + IE_INTYPE(ie) = 0 + else { + switch (Memc[intype]) { + case 'i', 'l': + IE_INTYPE(ie) = TY_INT + case 'r': + IE_INTYPE(ie) = TY_REAL + case 'd': + IE_INTYPE(ie) = TY_DOUBLE + default: + IE_INTYPE(ie) = 0 + } + } + + # Parse the expression and generate a list of input operands. + noperands = ie_getops (st, Memc[expr], Memc[oplist], SZ_LINE) + IE_NOPERANDS(ie) = noperands + + # Process the list of input operands and initialize each operand. + # This means fetch the value of the operand from the CL, determine + # the operand type, and initialize the image operand descriptor. + # The operand list is returned as a sequence of EOS delimited strings. + + opnam = oplist + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (Memc[opnam] == EOS) + call error (1, "malformed operand list") + + call clgstr (Memc[opnam], Memc[opval], SZ_LINE) + IO_OPNAME(io) = Memc[opnam] + ip = opval + + # Initialize the input operand; these values are overwritten below. + o = IO_OP(io) + call aclri (Memi[o], LEN_OPERAND) + + if (Memc[ip] == '.' && (Memc[ip+1] == EOS || Memc[ip+1] == '[')) { + # A "." is shorthand for the last output image. + call strcpy (Memc[ip+1], Memc[section], SZ_FNAME) + call clgstr ("lastout", Memc[opval], SZ_LINE) + call strcat (Memc[section], Memc[opval], SZ_LINE) + goto image_ + + } else if (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.') { + # "a.foo" refers to parameter foo of image A. Mark this as + # a parameter operand for now, and patch it up later. + + IO_TYPE(io) = PARAMETER + IO_DATA(io) = ip + call salloc (IO_DATA(io), SZ_LINE, TY_CHAR) + call strcpy (Memc[ip], Memc[IO_DATA(io)], SZ_LINE) + + } else if (ctod (Memc, ip, dval) > 0) { + if (Memc[ip] != EOS) + goto image_ + + # A numeric constant. +numeric_ IO_TYPE(io) = NUMERIC + + ip = opval + switch (lexnum (Memc, ip, nchars)) { + case LEX_REAL: + dtype = TY_REAL + if (stridxs("dD",Memc[opval]) > 0 || nchars > NDIGITS_RP+3) + dtype = TY_DOUBLE + O_TYPE(o) = dtype + if (dtype == TY_REAL) + O_VALR(o) = dval + else + O_VALD(o) = dval + default: + O_TYPE(o) = TY_INT + O_LEN(o) = 0 + O_VALI(o) = int(dval) + } + + } else { + # Anything else is assumed to be an image name. +image_ + ip = opval + call imgimage (Memc[ip], Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], Memc[imname])) + call error (2, "input and output images cannot be the same") + + im = immap (Memc[ip], READ_ONLY, 0) + + # Set any image options. + if (IE_BWIDTH(ie) > 0) { + call imseti (im, IM_NBNDRYPIX, IE_BWIDTH(ie)) + call imseti (im, IM_TYBNDRY, IE_BTYPE(ie)) + call imsetr (im, IM_BNDRYPIXVAL, IE_BPIXVAL(ie)) + } + + IO_TYPE(io) = IMAGE + call amovkl (1, IO_V(io,1), IM_MAXDIM) + IO_IM(io) = im + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + O_TYPE(o) = IM_PIXTYPE(im) + case TY_COMPLEX: + O_TYPE(o) = TY_REAL + default: # TY_USHORT + O_TYPE(o) = TY_INT + } + + O_TYPE(o) = max (IE_INTYPE(ie), O_TYPE(o)) + O_LEN(o) = IM_LEN(im,1) + O_FLAGS(o) = 0 + + # If one dimensional image read in data and be done with it. + if (IM_NDIM(im) == 1) { + switch (O_TYPE(o)) { + + case TY_SHORT: + if (imgnls (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_INT: + if (imgnli (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_LONG: + if (imgnll (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_REAL: + if (imgnlr (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_DOUBLE: + if (imgnld (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + default: + call error (4, s_badtype) + } + } + } + + + # Get next operand name. + while (Memc[opnam] != EOS) + opnam = opnam + 1 + opnam = opnam + 1 + } + + # Go back and patch up any "a.foo" type parameter references. The + # reference input operand (e.g. "a") must be of type IMAGE and must + # point to a valid open image. + + do i = 1, noperands { + mapflag = NO + io = IE_IMOP(ie,i) + ip = IO_DATA(io) + if (IO_TYPE(io) != PARAMETER) + next + + # Locate referenced symbolic image operand (e.g. "a"). + ia = NULL + do j = 1, noperands { + ia = IE_IMOP(ie,j) + if (IO_OPNAME(ia) == Memc[ip] && IO_TYPE(ia) == IMAGE) + break + ia = NULL + } + if (ia == NULL && (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.')) { + # The parameter operand is something like 'a.foo' however + # the image operand 'a' is not in the list derived from the + # expression, perhaps because we just want to use a parameter + # from a reference image and not the image itself. In this + # case map the image so we can get the parameter. + + call strcpy (Memc[ip], Memc[opval], 1) + call clgstr (Memc[opval], Memc[opnam], SZ_LINE) + call imgimage (Memc[opnam], Memc[fname], SZ_PATHNAME) + + iferr (im = immap (Memc[fname], READ_ONLY, 0)) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + } else + mapflag = YES + + } else if (ia == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + + } else + im = IO_IM(ia) + + # Get the parameter value and set up operand struct. + param = ip + 2 + IO_TYPE(io) = NUMERIC + o = IO_OP(io) + O_LEN(o) = 0 + + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[ip]) + call error (6, Memc[emsg]) + } + + if (mapflag == YES) + call imunmap (im) + } + + # Determine the reference image from which we will inherit image + # attributes such as the WCS. If the user specifies this we use + # the indicated image, otherwise we use the input image operand with + # the highest dimension. + + call clgstr ("refim", Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], "auto")) { + # Locate best reference image (highest dimension). + ndim = 0 + ref_im = NULL + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + if (IM_NDIM(im) > ndim) { + ref_im = im + ndim = IM_NDIM(im) + } + } + } else { + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == Memc[fname] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad wcsimage reference image %s") + call pargstr (Memc[fname]) + call error (7, Memc[emsg]) + } + ref_im = IO_IM(io) + } + + # Determine the dimension and size of the output image. If the "dims" + # parameter is set this determines the image dimension, otherwise we + # determine the best output image dimension and size from the input + # images. The exception is the line length, which is determined by + # the image line operand returned when the first line of the image + # is evaluated. + + call clgstr ("dims", Memc[dims], SZ_LINE) + if (streq (Memc[dims], "auto")) { + # Determine the output image dimensions from the input images. + call amovki (1, IE_AXLEN(ie,2), IM_MAXDIM-1) + IE_AXLEN(ie,1) = 0 + ndim = 1 + + do i = 1, noperands { + io = IE_IMOP(ie,i) + im = IO_IM(io) + if (IO_TYPE(io) != IMAGE || im == NULL) + next + + ndim = max (ndim, IM_NDIM(im)) + do j = 2, IM_NDIM(im) { + npix = IM_LEN(im,j) + if (npix > 1) { + if (IE_AXLEN(ie,j) <= 1) + IE_AXLEN(ie,j) = npix + else + IE_AXLEN(ie,j) = min (IE_AXLEN(ie,j), npix) + } + } + } + IE_NDIM(ie) = ndim + + } else { + # Use user specified output image dimensions. + ndim = 0 + for (ip=dims; ctoi(Memc,ip,npix) > 0; ) { + ndim = ndim + 1 + IE_AXLEN(ie,ndim) = npix + for (ch=Memc[ip]; IS_WHITE(ch) || ch == ','; ch=Memc[ip]) + ip = ip + 1 + } + IE_NDIM(ie) = ndim + } + + # Determine the pixel type of the output image. + call clgstr ("outtype", Memc[outtype], SZ_FNAME) + + if (strncmp (Memc[outtype], "auto", 4) == 0) { + IE_OUTTYPE(ie) = 0 + } else if (strncmp (Memc[outtype], "ref", 3) == 0) { + if (ref_im != NULL) + IE_OUTTYPE(ie) = IM_PIXTYPE(ref_im) + else + IE_OUTTYPE(ie) = 0 + } else { + switch (Memc[outtype]) { + case 'u': + IE_OUTTYPE(ie) = TY_USHORT + case 's': + IE_OUTTYPE(ie) = TY_SHORT + case 'i': + IE_OUTTYPE(ie) = TY_INT + case 'l': + IE_OUTTYPE(ie) = TY_LONG + case 'r': + IE_OUTTYPE(ie) = TY_REAL + case 'd': + IE_OUTTYPE(ie) = TY_DOUBLE + default: + call error (8, "bad outtype") + } + } + + # Open the output image. If the output image name has a section we + # are writing to a section of an existing image. + + call imgsection (Memc[output], Memc[section], SZ_FNAME) + if (Memc[section] != EOS && Memc[section] != NULL) { + outim = immap (Memc[output], READ_WRITE, 0) + IE_AXLEN(ie,1) = IM_LEN(outim,1) + } else { + if (ref_im != NULL) + outim = immap (Memc[output], NEW_COPY, ref_im) + else + outim = immap (Memc[output], NEW_IMAGE, 0) + IM_LEN(outim,1) = 0 + call amovl (IE_AXLEN(ie,2), IM_LEN(outim,2), IM_MAXDIM-1) + IM_NDIM(outim) = IE_NDIM(ie) + IM_PIXTYPE(outim) = 0 + } + + # Initialize output image line pointer. + call amovkl (1, IE_V(ie,1), IM_MAXDIM) + + percent = 0 + nlines = 0 + totlines = 1 + do i = 2, IM_NDIM(outim) + totlines = totlines * IM_LEN(outim,i) + + # Generate the pixel data for the output image line by line, + # evaluating the user supplied expression to produce each image + # line. Images may be any dimension, datatype, or size. + + # call memlog ("--------- PROCESS IMAGE -----------") + + out = NULL + repeat { + # call memlog1 ("--------- line %d ----------", nlines + 1) + + # Output image line generated by last iteration. + if (out != NULL) { + op = data + if (O_LEN(out) == 0) { + # Output image line is a scalar. + + switch (O_TYPE(out)) { + case TY_BOOL: + Memi[op] = O_VALI(out) + call amovki (O_VALI(out), Memi[op], IM_LEN(outim,1)) + + case TY_SHORT: + call amovks (O_VALS(out), Mems[op], IM_LEN(outim,1)) + + case TY_INT: + call amovki (O_VALI(out), Memi[op], IM_LEN(outim,1)) + + case TY_LONG: + call amovkl (O_VALL(out), Meml[op], IM_LEN(outim,1)) + + case TY_REAL: + call amovkr (O_VALR(out), Memr[op], IM_LEN(outim,1)) + + case TY_DOUBLE: + call amovkd (O_VALD(out), Memd[op], IM_LEN(outim,1)) + + } + + } else { + # Output image line is a vector. + + npix = min (O_LEN(out), IM_LEN(outim,1)) + ip = O_VALP(out) + switch (O_TYPE(out)) { + case TY_BOOL: + call amovi (Memi[ip], Memi[op], npix) + + case TY_SHORT: + call amovs (Mems[ip], Mems[op], npix) + + case TY_INT: + call amovi (Memi[ip], Memi[op], npix) + + case TY_LONG: + call amovl (Meml[ip], Meml[op], npix) + + case TY_REAL: + call amovr (Memr[ip], Memr[op], npix) + + case TY_DOUBLE: + call amovd (Memd[ip], Memd[op], npix) + + } + } + + call evvfree (out) + out = NULL + } + + # Get the next line in all input images. If EOF is seen on the + # image we merely rewind and keep going. This allows a vector, + # plane, etc. to be applied to each line, band, etc. of a higher + # dimensioned image. + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + o = IO_OP(io) + + # Data for a 1D image was read in above. + if (IM_NDIM(im) == 1) + next + + switch (O_TYPE(o)) { + + case TY_SHORT: + if (imgnls (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnls (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_INT: + if (imgnli (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnli (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_LONG: + if (imgnll (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnll (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_REAL: + if (imgnlr (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnlr (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_DOUBLE: + if (imgnld (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnld (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + default: + call error (10, s_badtype) + } + } + + # call memlog (".......... enter evvexpr ..........") + + # This is it! Evaluate the vector expression. + flags = 0 + if (rangecheck) + flags = or (flags, EV_RNGCHK) + + out = evvexpr (Memc[expr], + locpr(ie_getop), ie, locpr(ie_fcn), ie, flags) + + # call memlog (".......... exit evvexpr ..........") + + # If the pixel type and line length of the output image are + # still undetermined set them to match the output operand. + + if (IM_PIXTYPE(outim) == 0) { + if (IE_OUTTYPE(ie) == 0) { + if (O_TYPE(out) == TY_BOOL) + IE_OUTTYPE(ie) = TY_INT + else + IE_OUTTYPE(ie) = O_TYPE(out) + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } else + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } + if (IM_LEN(outim,1) == 0) { + if (IE_AXLEN(ie,1) == 0) { + if (O_LEN(out) == 0) { + IE_AXLEN(ie,1) = 1 + IM_LEN(outim,1) = 1 + } else { + IE_AXLEN(ie,1) = O_LEN(out) + IM_LEN(outim,1) = O_LEN(out) + } + } else + IM_LEN(outim,1) = IE_AXLEN(ie,1) + } + + # Print percent done. + if (verbose) { + nlines = nlines + 1 + if (nlines * 100 / totlines >= percent + 10) { + percent = percent + 10 + call printf ("%2d%% ") + call pargi (percent) + call flush (STDOUT) + } + } + + switch (O_TYPE(out)) { + case TY_BOOL: + status = impnli (outim, data, IE_V(ie,1)) + + case TY_SHORT: + status = impnls (outim, data, IE_V(ie,1)) + + case TY_INT: + status = impnli (outim, data, IE_V(ie,1)) + + case TY_LONG: + status = impnll (outim, data, IE_V(ie,1)) + + case TY_REAL: + status = impnlr (outim, data, IE_V(ie,1)) + + case TY_DOUBLE: + status = impnld (outim, data, IE_V(ie,1)) + + default: + call error (11, "expression type incompatible with image") + } + } until (status == EOF) + + # call memlog ("--------- DONE PROCESSING IMAGE -----------") + + if (verbose) { + call printf ("- done\n") + call flush (STDOUT) + } + + # All done. Unmap images. + call imunmap (outim) + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) == IMAGE && IO_IM(io) != NULL) + call imunmap (IO_IM(io)) + } + + # Clean up. + do i = 1, noperands { + io = IE_IMOP(ie,i) + o = IO_OP(io) + if (O_TYPE(o) == TY_CHAR) + call mfree (O_VALP(o), TY_CHAR) + } + + call evvfree (out) + call mfree (expr, TY_CHAR) + if (st != NULL) + call stclose (st) + + call clpstr ("lastout", Memc[output]) + call sfree (sp) +end + + +# IE_GETOP -- Called by evvexpr to fetch an input image operand. + +procedure ie_getop (ie, opname, o) + +pointer ie #I imexpr descriptor +char opname[ARB] #I operand name +pointer o #I output operand to be filled in + +int axis, i +pointer param, data +pointer sp, im, io, v + +bool imgetb() +int imgeti() +double imgetd() +int imgftype(), btoi() +errchk malloc +define err_ 91 + +begin + call smark (sp) + + if (IS_LOWER(opname[1]) && opname[2] == EOS) { + # Image operand. + + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1]) + break + io = NULL + } + + if (io == NULL) + goto err_ + else + v = IO_OP(io) + + call amovi (Memi[v], Memi[o], LEN_OPERAND) + if (IO_TYPE(io) == IMAGE) { + O_VALP(o) = IO_DATA(io) + O_FLAGS(o) = 0 + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[2] == '.') { + # Image parameter reference, e.g., "a.foo". + call salloc (param, SZ_FNAME, TY_CHAR) + + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) + goto err_ + + # Get the parameter value and set up operand struct. + call strcpy (opname[3], Memc[param], SZ_FNAME) + im = IO_IM(io) + + iferr (O_TYPE(o) = imgftype (im, Memc[param])) + goto err_ + + switch (O_TYPE(o)) { + case TY_BOOL: + iferr (O_VALI(o) = btoi (imgetb (im, Memc[param]))) + goto err_ + + case TY_CHAR: + O_LEN(o) = SZ_LINE + O_FLAGS(o) = O_FREEVAL + iferr { + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + } then + goto err_ + + case TY_INT: + iferr (O_VALI(o) = imgeti (im, Memc[param])) + goto err_ + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + iferr (O_VALD(o) = imgetd (im, Memc[param])) + goto err_ + + default: + goto err_ + } + + call sfree (sp) + return + + } else if (IS_UPPER(opname[1]) && opname[2] == EOS) { + # The current pixel coordinate [I,J,K,...]. The line coordinate + # is a special case since the image is computed a line at a time. + # If "I" is requested return a vector where v[i] = i. For J, K, + # etc. just return the scalar index value. + + axis = opname[1] - 'I' + 1 + if (axis == 1) { + O_TYPE(o) = TY_INT + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else { + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + } + call malloc (data, O_LEN(o), TY_INT) + do i = 1, O_LEN(o) + Memi[data+i-1] = i + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } else { + O_TYPE(o) = TY_INT + #O_LEN(o) = 0 + #if (axis < 1 || axis > IM_MAXDIM) + #O_VALI(o) = 1 + #else + #O_VALI(o) = IE_V(ie,axis) + #O_FLAGS(o) = 0 + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + call malloc (data, O_LEN(o), TY_INT) + if (axis < 1 || axis > IM_MAXDIM) + call amovki (1, Memi[data], O_LEN(o)) + else + call amovki (IE_V(ie,axis), Memi[data], O_LEN(o)) + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } + + call sfree (sp) + return + } + +err_ + O_TYPE(o) = ERR + call sfree (sp) +end + + +# IE_FCN -- Called by evvexpr to execute an imexpr special function. + +procedure ie_fcn (ie, fcn, args, nargs, o) + +pointer ie #I imexpr descriptor +char fcn[ARB] #I function name +pointer args[ARB] #I input arguments +int nargs #I number of input arguments +pointer o #I output operand to be filled in + +begin + # No functions yet. + O_TYPE(o) = ERR +end + + +# IE_GETEXPRDB -- Read the expression database into a symbol table. The +# input file has the following structure: +# +# <symbol>['(' arg-list ')'][':'|'='] replacement-text +# +# Symbols must be at the beginning of a line. The expression text is +# terminated by a nonempty, noncomment line with no leading whitespace. + +pointer procedure ie_getexprdb (fname) + +char fname[ARB] #I file to be read + +pointer sym, sp, lbuf, st, a_st, ip, symname, tokbuf, text +int tok, fd, line, nargs, op, token, buflen, offset, stpos, n +errchk open, getlline, stopen, stenter, ie_puttok +int open(), getlline(), ctotok(), stpstr() +pointer stopen(), stenter() +define skip_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + call salloc (text, SZ_COMMAND, TY_CHAR) + call salloc (tokbuf, SZ_COMMAND, TY_CHAR) + call salloc (symname, SZ_FNAME, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + st = stopen ("imexpr", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + a_st = stopen ("args", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + line = 0 + + while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + + # Replace single quotes by double quotes because things + # should behave like the command line but this routine + # uses ctotok which treats single quotes as character + # constants. + + for (ip=lbuf; Memc[ip]!=EOS; ip=ip+1) { + if (Memc[ip] == '\'') + Memc[ip] = '"' + } + + # Skip comments and blank lines. + ip = lbuf + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == '\n' || Memc[ip] == '#') + next + + # Get symbol name. + if (ctotok (Memc,ip,Memc[symname],SZ_FNAME) != TOK_IDENTIFIER) { + call eprintf ("exprdb: expected identifier at line %d\n") + call pargi (line) +skip_ while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + if (Memc[lbuf] == '\n') + break + } + } + + call stmark (a_st, stpos) + + # Check for the optional argument-symbol list. Allow only a + # single space between the symbol name and its argument list, + # otherwise we can't tell the difference between an argument + # list and the parenthesized expression which follows. + + if (Memc[ip] == ' ') + ip = ip + 1 + + if (Memc[ip] == '(') { + ip = ip + 1 + n = 0 + repeat { + tok = ctotok (Memc, ip, Memc[tokbuf], SZ_FNAME) + if (tok == TOK_IDENTIFIER) { + sym = stenter (a_st, Memc[tokbuf], LEN_ARGSYM) + n = n + 1 + ARGNO(sym) = n + } else if (Memc[tokbuf] == ',') { + ; + } else if (Memc[tokbuf] != ')') { + call eprintf ("exprdb: bad arglist at line %d\n") + call pargi (line) + call stfree (a_st, stpos) + goto skip_ + } + } until (Memc[tokbuf] == ')') + } + + # Check for the optional ":" or "=". + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == ':' || Memc[ip] == '=') + ip = ip + 1 + + # Accumulate the expression text. + buflen = SZ_COMMAND + op = 1 + + repeat { + repeat { + token = ctotok (Memc, ip, Memc[tokbuf+1], SZ_COMMAND) + if (Memc[tokbuf] == '#') + break + else if (token != TOK_EOS && token != TOK_NEWLINE) { + if (token == TOK_STRING) { + Memc[tokbuf] = '"' + call strcat ("""", Memc[tokbuf], SZ_COMMAND) + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf]) + } else + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf+1]) + } + } until (token == TOK_EOS) + + if (getlline (fd, Memc[lbuf], SZ_COMMAND) == EOF) + break + else + line = line + 1 + + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (ip == lbuf) { + call ungetline (fd, Memc[lbuf]) + line = line - 1 + break + } + } + + # Free any argument list symbols. + call stfree (a_st, stpos) + + # Scan the expression text and count the number of $N arguments. + nargs = 0 + for (ip=text; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && IS_DIGIT(Memc[ip+1])) { + nargs = max (nargs, TO_INTEG(Memc[ip+1])) + ip = ip + 1 + } + + # Enter symbol in table. + sym = stenter (st, Memc[symname], LEN_SYM) + offset = stpstr (st, Memc[text], 0) + SYM_TEXT(sym) = offset + SYM_NARGS(sym) = nargs + } + + call stclose (a_st) + call sfree (sp) + + return (st) +end + + +# IE_PUTTOK -- Append a token string to a text buffer. + +procedure ie_puttok (a_st, text, op, buflen, token) + +pointer a_st #I argument-symbol table +pointer text #U text buffer +int op #U output pointer +int buflen #U buffer length, chars +char token[ARB] #I token string + +pointer sym +int ip, ch1, ch2 +pointer stfind() +errchk realloc + +begin + # Replace any symbolic arguments by "$N". + if (a_st != NULL && IS_ALPHA(token[1])) { + sym = stfind (a_st, token) + if (sym != NULL) { + token[1] = '$' + token[2] = TO_DIGIT(ARGNO(sym)) + token[3] = EOS + } + } + + # Append the token string to the text buffer. + for (ip=1; token[ip] != EOS; ip=ip+1) { + if (op + 1 > buflen) { + buflen = buflen + SZ_COMMAND + call realloc (text, buflen, TY_CHAR) + } + + # The following is necessary because ctotok parses tokens such as + # "$N", "==", "!=", etc. as two tokens. We need to rejoin these + # characters to make one token. + + if (op > 1 && token[ip+1] == EOS) { + ch1 = Memc[text+op-3] + ch2 = token[ip] + + if (ch1 == '$' && IS_DIGIT(ch2)) + op = op - 1 + else if (ch1 == '*' && ch2 == '*') + op = op - 1 + else if (ch1 == '/' && ch2 == '/') + op = op - 1 + else if (ch1 == '<' && ch2 == '=') + op = op - 1 + else if (ch1 == '>' && ch2 == '=') + op = op - 1 + else if (ch1 == '=' && ch2 == '=') + op = op - 1 + else if (ch1 == '!' && ch2 == '=') + op = op - 1 + else if (ch1 == '?' && ch2 == '=') + op = op - 1 + else if (ch1 == '&' && ch2 == '&') + op = op - 1 + else if (ch1 == '|' && ch2 == '|') + op = op - 1 + } + + Memc[text+op-1] = token[ip] + op = op + 1 + } + + # Append a space to ensure that tokens are delimited. + Memc[text+op-1] = ' ' + op = op + 1 + + Memc[text+op-1] = EOS +end + + +# IE_EXPANDTEXT -- Scan an expression, performing macro substitution on the +# contents and returning a fully expanded string. + +pointer procedure ie_expandtext (st, expr) + +pointer st #I symbol table (macros) +char expr[ARB] #I input expression + +pointer buf, gt +int buflen, nchars +int locpr(), gt_expand() +pointer gt_opentext() +extern ie_gsym() + +begin + buflen = SZ_COMMAND + call malloc (buf, buflen, TY_CHAR) + + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE) + nchars = gt_expand (gt, buf, buflen) + call gt_close (gt) + + return (buf) +end + + +# IE_GETOPS -- Parse the expression and generate a list of input operands. +# The output operand list is returned as a sequence of EOS delimited strings. + +int procedure ie_getops (st, expr, oplist, maxch) + +pointer st #I symbol table +char expr[ARB] #I input expression +char oplist[ARB] #O operand list +int maxch #I max chars out + +int noperands, ch, i +int ops[MAX_OPERANDS] +pointer gt, sp, tokbuf, op + +extern ie_gsym() +pointer gt_opentext() +int locpr(), gt_rawtok(), gt_nexttok() +errchk gt_opentext, gt_rawtok + +begin + call smark (sp) + call salloc (tokbuf, SZ_LINE, TY_CHAR) + + call aclri (ops, MAX_OPERANDS) + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE+GT_NOCOMMAND) + + # This assumes that operand names are the letters "a" to "z". + while (gt_rawtok (gt, Memc[tokbuf], SZ_LINE) != EOF) { + ch = Memc[tokbuf] + if (IS_LOWER(ch) && Memc[tokbuf+1] == EOS) + if (gt_nexttok (gt) != '(') + ops[ch-'a'+1] = 1 + } + + call gt_close (gt) + + op = 1 + noperands = 0 + do i = 1, MAX_OPERANDS + if (ops[i] != 0 && op < maxch) { + oplist[op] = 'a' + i - 1 + op = op + 1 + oplist[op] = EOS + op = op + 1 + noperands = noperands + 1 + } + + oplist[op] = EOS + op = op + 1 + + call sfree (sp) + return (noperands) +end diff --git a/pkg/images/imutil/src/imfuncs.gx b/pkg/images/imutil/src/imfuncs.gx new file mode 100644 index 00000000..b63bea59 --- /dev/null +++ b/pkg/images/imutil/src/imfuncs.gx @@ -0,0 +1,786 @@ +include <imhdr.h> +include <mach.h> +include <math.h> + +$for (rd) + +# IF_LOG10 -- Compute the base 10 logarithm of image1 and write the results to +# image2. + +procedure if_log10$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +PIXEL if_elog$t() +extern if_elog$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call alog$t (Mem$t[buf1], Mem$t[buf2], npix, if_elog$t) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +PIXEL procedure if_elog$t (x) + +PIXEL x # the input pixel value + +begin + return (PIXEL(-MAX_EXPONENT)) +end + + +# IF_ALOG10 -- Take the power of 10 of image1 and write the results to image2. + +procedure if_alog10$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_va10$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VA10 -- Take the antilog (base 10) of a vector. + +procedure if_va10$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of points + +int i +PIXEL maxexp, maxval + +begin + maxexp = MAX_EXPONENT + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= (-maxexp)) + b[i] = 0$f + else + b[i] = 10$f ** a[i] + } +end + + +# IF_LN -- Take the natural log of the pixels in image1 and write the results +# to image2. + +procedure if_ln$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 + +PIXEL if_eln$t() +extern if_eln$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call alln$t (Mem$t[buf1], Mem$t[buf2], npix, if_eln$t) +end + + +# IF_ELN -- The error function for the natural logarithm. + +PIXEL procedure if_eln$t (x) + +PIXEL x # input value + +begin + return (PIXEL (LN_10) * PIXEL(-MAX_EXPONENT)) +end + + +# IF_ALN -- Take the natural antilog of the pixels in image1 and write the +# results to image2. + +procedure if_aln$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_valn$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VALN -- Take the natural antilog of a vector. + +procedure if_valn$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL maxexp, maxval, eval + +begin + maxexp = log (10$f ** PIXEL (MAX_EXPONENT)) + maxval = MAX_REAL + eval = PIXEL (BASE_E) + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = 0$f + else + b[i] = eval ** a[i] + } +end + + +# IF_SQR -- Take the square root of pixels in image1 and write the results +# to image2. + +procedure if_sqr$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +PIXEL if_esqr$t() +extern if_esqr$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call asqr$t (Mem$t[buf1], Mem$t[buf2], npix, if_esqr$t) +end + + +# IF_ESQR -- Error function for the square root. + +PIXEL procedure if_esqr$t (x) + +PIXEL x # input value + +begin + return (0$f) +end + + +# IF_SQUARE -- Take the square of the pixels in image1 and write to image2. +procedure if_square$t (im1, im2) + +pointer im1 # the input image pointer +pointer im2 # the output image pointer + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call apowk$t (Mem$t[buf1], 2, Mem$t[buf2], npix) +end + + +# IF_CBRT -- Take the cube root of the pixels in image1 and write the results +# to image2. + +procedure if_cbrt$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vcbrt$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VCBRT -- Compute the cube root of a vector. + +procedure if_vcbrt$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL onethird + +begin + onethird = 1$f / 3$f + do i = 1, n { + if (a[i] >= 0$f) { + b[i] = a[i] ** onethird + } else { + b[i] = -a[i] + b[i] = - (b[i] ** onethird) + } + } +end + + +# IF_CUBE -- Take the cube of the pixels in image1 and write the results to +# image2. + +procedure if_cube$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call apowk$t (Mem$t[buf1], 3, Mem$t[buf2], npix) +end + + +# IF_COS -- Take cosine of pixels in image1 and write the results to image2. + +procedure if_cos$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vcos$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VCOS - Compute the cosine of a vector. + +procedure if_vcos$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = cos(a[i]) +end + + +# IF_SIN -- Take sine of the pixels in image1 and write the results to image2. + +procedure if_sin$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vsin$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VSIN - Take the sine of a vector. + +procedure if_vsin$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = sin(a[i]) +end + + +# IF_TAN -- Take tangent of pixels in image1 and write the results to image2. + +procedure if_tan$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vtan$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VTAN - Take the tangent of a vector. + +procedure if_vtan$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tan(a[i]) +end + + +# IF_ACOS -- Take arccosine of pixels in image1 and write the results to image2. + +procedure if_acos$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vacos$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VACOS - Take the arccosine of a vector. + +procedure if_vacos$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n { + if (a[i] > 1$f) + b[i] = acos (1$f) + else if (a[i] < -1$f) + b[i] = acos (-1$f) + else + b[i] = acos(a[i]) + } +end + + +# IF_ASIN -- Take arcsine of pixels in image1 and write the results to image2. + +procedure if_asin$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vasin$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VASIN - Take arcsine of vector + +procedure if_vasin$t (a, b, n) + +PIXEL a[n] +PIXEL b[n] +int n + +int i + +begin + do i = 1, n { + if (a[i] > 1$f) + b[i] = asin (1$f) + else if (a[i] < -1$f) + b[i] = asin (-1$f) + else + b[i] = asin(a[i]) + } +end + + +# IF_ATAN -- Take arctangent of pixels in image1 and write the results to +# image2. + +procedure if_atan$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vatan$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VATAN - Take the arctangent of a vector. + +procedure if_vatan$t (a, b, n) + +PIXEL a[n] +PIXEL b[n] +int n + +int i + +begin + do i = 1, n + b[i] = atan(a[i]) +end + + +# IF_HCOS -- Take the hyperbolic cosine of pixels in image1 and write the +# results to image2. + +procedure if_hcos$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vhcos$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VHCOS - Take the hyperbolic cosine of a vector. + +procedure if_vhcos$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL maxexp, maxval + +begin + maxexp = log (10$f ** PIXEL(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (abs (a[i]) >= maxexp) + b[i] = maxval + else + b[i] = cosh (a[i]) + } +end + + +# IF_HSIN -- Take the hyperbolic sine of pixels in image1 and write the +# results to image2. + +procedure if_hsin$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vhsin$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VHSIN - Take the hyperbolic sine of a vector. + +procedure if_vhsin$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL maxexp, maxval + +begin + maxexp = log (10$f ** PIXEL(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = -maxval + else + b[i] = sinh(a[i]) + } +end + + +# IF_HTAN -- Take the hyperbolic tangent of pixels in image1 and write the +# results to image2. + +procedure if_htan$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vhtan$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VHTAN - Take the hyperbolic tangent of a vector. + +procedure if_vhtan$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tanh(a[i]) +end + + +# IF_RECIP -- Take the reciprocal of the pixels in image1 and write the +# results to image2. + +procedure if_recip$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +PIXEL if_erecip$t() +extern if_erecip$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call arcz$t (1.0, Mem$t[buf1], Mem$t[buf2], npix, if_erecip$t) +end + + +# IF_ERECIP -- Error function for the reciprocal computation. + +PIXEL procedure if_erecip$t (x) + +PIXEL x + +begin + return (0$f) +end + +$endfor + +$for (lrd) + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_abs$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call aabs$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_neg$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call aneg$t (Mem$t[buf1], Mem$t[buf2], npix) +end + +$endfor diff --git a/pkg/images/imutil/src/imfunction.x b/pkg/images/imutil/src/imfunction.x new file mode 100644 index 00000000..08c4813a --- /dev/null +++ b/pkg/images/imutil/src/imfunction.x @@ -0,0 +1,306 @@ +include <imhdr.h> + +define IF_LOG10 1 +define IF_ALOG10 2 +define IF_LN 3 +define IF_ALN 4 +define IF_SQRT 5 +define IF_SQUARE 6 +define IF_CBRT 7 +define IF_CUBE 8 +define IF_ABS 9 +define IF_NEG 10 +define IF_COS 11 +define IF_SIN 12 +define IF_TAN 13 +define IF_ACOS 14 +define IF_ASIN 15 +define IF_ATAN 16 +define IF_COSH 17 +define IF_SINH 18 +define IF_TANH 19 +define IF_RECIPROCAL 20 + +define FUNCS "|log10|alog10|ln|aln|sqrt|square|cbrt|cube|abs|neg|\ +cos|sin|tan|acos|asin|atan|hcos|hsin|htan|reciprocal|" + +# T_FUNCTION -- Apply a function to a list of images. + +procedure t_imfunction () + +pointer input # input images +pointer output # output images +int func # function +int verbose # verbose mode + +int list1, list2 +pointer sp, image1, image2, image3, function, im1, im2 +bool clgetb() +int clgwrd(), imtopen(), imtgetim(), imtlen(), btoi() +pointer immap() + +begin + # Allocate working space. + + call smark (sp) + call salloc (input, SZ_LINE, TY_CHAR) + call salloc (output, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (image3, SZ_FNAME, TY_CHAR) + call salloc (function, SZ_FNAME, TY_CHAR) + + # Get image template list. + + call clgstr ("input", Memc[input], SZ_LINE) + call clgstr ("output", Memc[output], SZ_LINE) + func = clgwrd ("function", Memc[function], SZ_FNAME, FUNCS) + verbose = btoi (clgetb ("verbose")) + + list1 = imtopen (Memc[input]) + list2 = imtopen (Memc[output]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Input and output image lists don't match") + } + + # Apply function to each input image. Optimize IMIO. + + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[image3], + SZ_FNAME) + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_PIXTYPE(im1) == TY_COMPLEX) { + call printf ("%s is datatype complex: skipping\n") + call imunmap (im1) + next + } + im2 = immap (Memc[image2], NEW_COPY, im1) + + switch (func) { + case IF_LOG10: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_log10d (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_log10r (im1, im2) + } + + case IF_ALOG10: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_alog10d (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_alog10r (im1, im2) + } + + case IF_LN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_lnd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_lnr (im1, im2) + } + + case IF_ALN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_alnd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_alnr (im1, im2) + } + + case IF_SQRT: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_sqrd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_sqrr (im1, im2) + } + + case IF_SQUARE: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_squared (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_squarer (im1, im2) + } + + case IF_CBRT: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_cbrtd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_cbrtr (im1, im2) + } + + case IF_CUBE: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_cubed (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_cuber (im1, im2) + } + + case IF_ABS: + switch (IM_PIXTYPE(im1)) { + case TY_SHORT, TY_INT, TY_LONG: + call if_absl (im1, im2) + case TY_DOUBLE: + call if_absd (im1, im2) + default: + call if_absr (im1, im2) + } + + case IF_NEG: + # Preserve the original image type. + switch (IM_PIXTYPE(im1)) { + case TY_SHORT, TY_INT, TY_LONG: + call if_negl (im1, im2) + case TY_DOUBLE: + call if_negd (im1, im2) + default: + call if_negr (im1, im2) + } + + case IF_COS: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_cosd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_cosr (im1, im2) + } + + case IF_SIN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_sind (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_sinr (im1, im2) + } + + case IF_TAN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_tand (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_tanr (im1, im2) + } + + case IF_ACOS: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_acosd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_acosr (im1, im2) + } + + case IF_ASIN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_asind (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_asinr (im1, im2) + } + + case IF_ATAN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_atand (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_atanr (im1, im2) + } + + case IF_COSH: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_hcosd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_hcosr (im1, im2) + } + + case IF_SINH: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_hsind (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_hsinr (im1, im2) + } + + case IF_TANH: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_htand (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_htanr (im1, im2) + } + + case IF_RECIPROCAL: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_recipd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_recipr (im1, im2) + } + + default: + call error (0, "Undefined function\n") + + } + + if (verbose == YES) { + call printf ("%s -> %s function: %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image3]) + call pargstr (Memc[function]) + } + + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[image3]) + + } + + call imtclose (list1) + call imtclose (list2) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imgets.x b/pkg/images/imutil/src/imgets.x new file mode 100644 index 00000000..c05c14ca --- /dev/null +++ b/pkg/images/imutil/src/imgets.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <ctype.h> + +# IMGETS -- Get the value of an image header parameter as a character string. +# The value is returned as a CL parameter of type string; the type coercion +# facilities of the CL may be used to convert to a different datatype if +# desired. + +procedure t_imgets() + +pointer sp, im +pointer image, param, value +pointer immap() +int ip, op, stridxs() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + + call clgstr ("image", Memc[image], SZ_FNAME) + call clgstr ("param", Memc[param], SZ_LINE) + + im = immap (Memc[image], READ_ONLY, 0) + + iferr (call imgstr (im, Memc[param], Memc[value], SZ_LINE)) { + call erract (EA_WARN) + call clpstr ("value", "0") + } else { + # Check for special case of string with double quotes. + if (stridxs ("\"", Memc[value]) != 0) { + op = param + for (ip=value; Memc[ip]!=EOS; ip=ip+1) { + if (Memc[ip] == '"') { + Memc[op] = '\\' + op = op + 1 + } + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call clpstr ("value", Memc[param]) + } else + call clpstr ("value", Memc[value]) + } + + call imunmap (im) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imheader.x b/pkg/images/imutil/src/imheader.x new file mode 100644 index 00000000..57c496fe --- /dev/null +++ b/pkg/images/imutil/src/imheader.x @@ -0,0 +1,303 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <ctype.h> +include <imhdr.h> +include <imset.h> +include <imio.h> +include <time.h> + +define SZ_DIMSTR (IM_MAXDIM*4) +define SZ_MMSTR 40 +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] +define LMARGIN 0 + + +# IMHEADER -- Read contents of an image header and print on STDOUT. + +procedure t_imheader() + +int list, nimages, errcode +bool long_format, user_fields +pointer sp, template, image, errmsg +int imtopen(), imtgetim(), imtlen(), clgeti(), errget() +bool clgetb() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call salloc (template, SZ_LINE, TY_CHAR) + + if (clgeti ("$nargs") == 0) + call clgstr ("imlist", Memc[template], SZ_LINE) + else + call clgstr ("images", Memc[template], SZ_LINE) + + list = imtopen (Memc[template]) + long_format = clgetb ("longheader") + user_fields = clgetb ("userfields") + nimages = 0 + + if (imtlen (list) <= 0) + call printf ("no images found\n") + else { + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + nimages = nimages + 1 + if (long_format && nimages > 1) + call putci (STDOUT, '\n') + iferr { + call imphdr (STDOUT,Memc[image],long_format,user_fields) + } then { + errcode = errget (Memc[errmsg], SZ_LINE) + call eprintf ("%s: %s\n") + call pargstr (Memc[image]) + call pargstr (Memc[errmsg]) + } + call flush (STDOUT) + } + } + + call imtclose (list) + call sfree (sp) +end + + +# IMPHDR -- Print the contents of an image header. + +procedure imphdr (fd, image, long_format, user_fields) + +int fd +char image[ARB] +bool long_format +bool user_fields + +int hi, i +bool pixfile_ok +pointer im, sp, ctime, mtime, ldim, pdim, title, lbuf, ip +int gstrcpy(), stropen(), getline(), strlen(), stridxs(), imstati() +errchk im_fmt_dimensions, immap, access, stropen, getline +define done_ 91 +pointer immap() + +begin + # Allocate automatic buffers. + call smark (sp) + call salloc (ctime, SZ_TIME, TY_CHAR) + call salloc (mtime, SZ_TIME, TY_CHAR) + call salloc (ldim, SZ_DIMSTR, TY_CHAR) + call salloc (pdim, SZ_DIMSTR, TY_CHAR) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + im = immap (image, READ_ONLY, 0) + + # Format subscript strings, date strings, mininum and maximum + # pixel values. + + call im_fmt_dimensions (im, Memc[ldim], SZ_DIMSTR, IM_LEN(im,1)) + call im_fmt_dimensions (im, Memc[pdim], SZ_DIMSTR, IM_PHYSLEN(im,1)) + call cnvtime (IM_CTIME(im), Memc[ctime], SZ_TIME) + call cnvtime (IM_MTIME(im), Memc[mtime], SZ_TIME) + + # Strip any trailing whitespace from the title string. + ip = title + gstrcpy (IM_TITLE(im), Memc[title], SZ_LINE) - 1 + while (ip >= title && IS_WHITE(Memc[ip]) || Memc[ip] == '\n') + ip = ip - 1 + Memc[ip+1] = EOS + + # Begin printing image header. + call fprintf (fd, "%s%s[%s]: %s\n") + call pargstr (IM_NAME(im)) + call pargstr (Memc[ldim]) + call pargtype (IM_PIXTYPE(im)) + call pargstr (Memc[title]) + + # All done if not long format. + if (! long_format) + goto done_ + + call fprintf (fd, "%*w%s bad pixels, min=%s, max=%s%s\n") + call pargi (LMARGIN) + if (IM_NBPIX(im) == 0) # num bad pixels + call pargstr ("No") + else + call pargl (IM_NBPIX(im)) + + if (IM_LIMTIME(im) == 0) { # min,max pixel values + do i = 1, 2 + call pargstr ("unknown") + call pargstr ("") + } else { + call pargr (IM_MIN(im)) + call pargr (IM_MAX(im)) + if (IM_LIMTIME(im) < IM_MTIME(im)) + call pargstr (" (old)") + else + call pargstr ("") + } + + call fprintf (fd, + "%*w%s storage mode, physdim %s, length of user area %d s.u.\n") + call pargi (LMARGIN) + call pargstr ("Line") + call pargstr (Memc[pdim]) + call pargi (IM_HDRLEN(im) - LEN_IMHDR) + + call fprintf (fd, "%*wCreated %s, Last modified %s\n") + call pargi (LMARGIN) + call pargstr (Memc[ctime]) # times + call pargstr (Memc[mtime]) + + pixfile_ok = (imstati (im, IM_PIXFD) > 0) + if (!pixfile_ok) { + ifnoerr (call imopsf (im)) + pixfile_ok = (imstati (im, IM_PIXFD) > 0) + if (pixfile_ok) + call close (imstati (im, IM_PIXFD)) + } + if (pixfile_ok) + call strcpy ("[ok]", Memc[lbuf], SZ_LINE) + else + call strcpy ("[NO PIXEL FILE]", Memc[lbuf], SZ_LINE) + + call fprintf (fd, "%*wPixel file \"%s\" %s\n") + call pargi (LMARGIN) + call pargstr (IM_PIXFILE(im)) + call pargstr (Memc[lbuf]) + + # Print the history records. + if (strlen (IM_HISTORY(im)) > 1) { + hi = stropen (IM_HISTORY(im), ARB, READ_ONLY) + while (getline (hi, Memc[lbuf]) != EOF) { + for (i=1; i <= LMARGIN; i=i+1) + call putci (fd, ' ') + call putline (fd, Memc[lbuf]) + if (stridxs ("\n", Memc[lbuf]) == 0) + call putline (fd, "\n") + } + call close (hi) + } + + if (user_fields) + call imh_print_user_area (fd, im) + +done_ + call imunmap (im) + call sfree (sp) +end + + +# IM_FMT_DIMENSIONS -- Format the image dimensions in the form of a subscript, +# i.e., "[nx,ny,nz,...]". + +procedure im_fmt_dimensions (im, outstr, maxch, len_axes) + +pointer im +char outstr[ARB] +int maxch, i, fd, stropen() +long len_axes[ARB] +errchk stropen, fprintf, pargl + +begin + fd = stropen (outstr, maxch, NEW_FILE) + + if (IM_NDIM(im) == 0) { + call fprintf (fd, "[0") + } else { + call fprintf (fd, "[%d") + call pargl (len_axes[1]) + } + + do i = 2, IM_NDIM(im) { + call fprintf (fd, ",%d") + call pargl (len_axes[i]) + } + + call fprintf (fd, "]") + call close (fd) +end + + +# PARGTYPE -- Convert an integer type code into a string, and output the +# string with PARGSTR to FMTIO. + +procedure pargtype (dtype) + +int dtype + +begin + switch (dtype) { + case TY_UBYTE: + call pargstr ("ubyte") + case TY_BOOL: + call pargstr ("bool") + case TY_CHAR: + call pargstr ("char") + case TY_SHORT: + call pargstr ("short") + case TY_USHORT: + call pargstr ("ushort") + case TY_INT: + call pargstr ("int") + case TY_LONG: + call pargstr ("long") + case TY_REAL: + call pargstr ("real") + case TY_DOUBLE: + call pargstr ("double") + case TY_COMPLEX: + call pargstr ("complex") + case TY_POINTER: + call pargstr ("pointer") + case TY_STRUCT: + call pargstr ("struct") + default: + call pargstr ("unknown datatype") + } +end + + +# IMH_PRINT_USER_AREA -- Print the user area of the image, if nonzero length +# and it contains only ascii values. + +procedure imh_print_user_area (out, im) + +int out # output file +pointer im # image descriptor + +pointer sp, lbuf, ip +int in, ncols, min_lenuserarea, i +int stropen(), getline(), envgeti() +errchk stropen, envgeti, getline, putci, putline + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Open user area in header. + min_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + in = stropen (USER_AREA(im), min_lenuserarea, READ_ONLY) + ncols = envgeti ("ttyncols") - LMARGIN + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. + + while (getline (in, Memc[lbuf]) != EOF) { + for (ip=lbuf; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + while (ip > lbuf && Memc[ip-1] == ' ') + ip = ip - 1 + if (ip - lbuf > ncols) + ip = lbuf + ncols + Memc[ip] = '\n' + Memc[ip+1] = EOS + + for (i=1; i <= LMARGIN; i=i+1) + call putci (out, ' ') + call putline (out, Memc[lbuf]) + } + + call close (in) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imhistogram.x b/pkg/images/imutil/src/imhistogram.x new file mode 100644 index 00000000..b62233b7 --- /dev/null +++ b/pkg/images/imutil/src/imhistogram.x @@ -0,0 +1,332 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <gset.h> + +define SZ_CHOICE 18 + +define HIST_TYPES "|normal|cumulative|difference|second_difference|" +define NORMAL 1 +define CUMULATIVE 2 +define DIFFERENCE 3 +define SECOND_DIFF 4 + +define PLOT_TYPES "|line|box|" +define LINE 1 +define BOX 2 + +define SZ_TITLE 512 # plot title buffer + +# IMHISTOGRAM -- Compute and plot the histogram of an image. + +procedure t_imhistogram() + +long v[IM_MAXDIM] +real z1, z2, dz, z1temp, z2temp, zstart +int npix, nbins, nbins1, nlevels, nwide, z1i, z2i, i, maxch, histtype +pointer gp, im, sp, hgm, hgmr, buf, image, device, str, title, op + +real clgetr() +pointer immap(), gopen() +int clgeti(), clgwrd() +int imgnlr(), imgnli() +bool clgetb(), fp_equalr() + +begin + call smark (sp) + call salloc (image, SZ_LINE, TY_CHAR) + call salloc (str, SZ_CHOICE, TY_CHAR) + + # Get the image name. + call clgstr ("image", Memc[image], SZ_LINE) + im = immap (Memc[image], READ_ONLY, 0) + npix = IM_LEN(im,1) + + # Get histogram range. + z1 = clgetr ("z1") + z2 = clgetr ("z2") + + if (IS_INDEFR(z1) || IS_INDEFR(z2)) { + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + z1temp = IM_MIN(im) + z2temp = IM_MAX(im) + } else + call im_minmax (im, z1temp, z2temp) + + if (IS_INDEFR(z1)) + z1 = z1temp + + if (IS_INDEFR(z2)) + z2 = z2temp + } + + if (z1 > z2) { + dz = z1; z1 = z2; z2 = dz + } + + # Get default histogram resolution. + dz = clgetr ("binwidth") + if (IS_INDEFR(dz)) + nbins = clgeti ("nbins") + else { + nbins = nint ((z2 - z1) / dz) + z2 = z1 + nbins * dz + } + + # Set the limits for integer images. + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + z1i = nint (z1) + z2i = nint (z2) + z1 = real (z1i) + z2 = real (z2i) + } + + # Adjust the resolution of the histogram and/or the data range + # so that an integral number of data values map into each + # histogram bin (to avoid aliasing effects). + + if (clgetb ("autoscale")) + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + nlevels = z2i - z1i + nwide = max (1, nint (real (nlevels) / real (nbins))) + nbins = max (1, nint (real (nlevels) / real (nwide))) + z2i = z1i + nbins * nwide + z2 = real (z2i) + } + + # The extra bin counts the pixels that equal z2 and shifts the + # remaining bins to evenly cover the interval [z1,z2]. + # Real numbers could be handled better - perhaps adjust z2 + # upward by ~ EPSILONR (in ahgm itself). + + nbins1 = nbins + 1 + + # Initialize the histogram buffer and image line vector. + call salloc (hgm, nbins1, TY_INT) + call aclri (Memi[hgm], nbins1) + call amovkl (long(1), v, IM_MAXDIM) + + # Read successive lines of the image and accumulate the histogram. + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + # Test for constant valued image, which causes zero divide in ahgm. + if (z1i == z2i) { + call eprintf ("Warning: Image `%s' has no data range.\n") + call pargstr (Memc[image]) + call imunmap (im) + call sfree (sp) + return + } + + while (imgnli (im, buf, v) != EOF) + call ahgmi (Memi[buf], npix, Memi[hgm], nbins1, z1i, z2i) + + default: + # Test for constant valued image, which causes zero divide in ahgm. + if (fp_equalr (z1, z2)) { + call eprintf ("Warning: Image `%s' has no data range.\n") + call pargstr (Memc[image]) + call imunmap (im) + call sfree (sp) + return + } + + while (imgnlr (im, buf, v) != EOF) + call ahgmr (Memr[buf], npix, Memi[hgm], nbins1, z1, z2) + } + + # "Correct" the topmost bin for pixels that equal z2. Each + # histogram bin really wants to be half open. + + if (clgetb ("top_closed")) + Memi[hgm+nbins-1] = Memi[hgm+nbins-1] + Memi[hgm+nbins1-1] + + dz = (z2 - z1) / real (nbins) + + histtype = clgwrd ("hist_type", Memc[str], SZ_CHOICE, HIST_TYPES) + + switch (histtype) { + case NORMAL: + # do nothing + case CUMULATIVE: + call ih_acumi (Memi[hgm], Memi[hgm], nbins) + case DIFFERENCE: + call ih_amrgi (Memi[hgm], Memi[hgm], nbins) + z1 = z1 + dz / 2. + z2 = z2 - dz / 2. + nbins = nbins - 1 + case SECOND_DIFF: + call ih_amrgi (Memi[hgm], Memi[hgm], nbins) + call ih_amrgi (Memi[hgm], Memi[hgm], nbins-1) + z1 = z1 + dz + z2 = z2 - dz + nbins = nbins - 2 + default: + call error (1, "bad switch 1") + } + + # List or plot the histogram. In list format, the bin value is the + # z value of the left side (start) of the bin. + + if (clgetb ("listout")) { + zstart = z1 + dz / 2.0 + do i = 1, nbins { + call printf ("%g %d\n") + call pargr (zstart) + call pargi (Memi[hgm+i-1]) + zstart = zstart + dz + } + } else { + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_TITLE, TY_CHAR) + call salloc (hgmr, nbins, TY_REAL) + call achtir (Memi[hgm], Memr[hgmr], nbins) + + call clgstr ("device", Memc[device], SZ_FNAME) + gp = gopen (Memc[device], NEW_FILE, STDGRAPH) + if (clgetb ("logy")) + call gseti (gp, G_YTRAN, GW_LOG) + call gswind (gp, z1, z2, INDEF, INDEF) + call gascale (gp, Memr[hgmr], nbins, 2) + + # Format the plot title, starting with the system banner. + call sysid (Memc[title], SZ_TITLE) + for (op=title; Memc[op] != '\n' && Memc[op] != EOS; op=op+1) + ; + Memc[op] = '\n'; op = op + 1 + maxch = SZ_TITLE - (op - title) + + # Format the remainder of the plot title. + call sprintf (Memc[op], maxch, + "%s of %s = %s\nFrom z1=%g to z2=%g, nbins=%d, width=%g") + switch (histtype) { + case NORMAL: + call pargstr ("Histogram") + case CUMULATIVE: + call pargstr ("Cumulative histogram") + case DIFFERENCE: + call pargstr ("Difference histogram") + case SECOND_DIFF: + call pargstr ("Second difference histogram") + default: + call error (1, "bad switch 3") + } + + call pargstr (Memc[image]) + call pargstr (IM_TITLE(im)) + call pargr (z1) + call pargr (z2) + call pargi (nbins) + call pargr (dz) + + # Draw the plot. Center the bins for plot_type=line. + call glabax (gp, Memc[title], "", "") + + switch (clgwrd ("plot_type", Memc[str], SZ_LINE, PLOT_TYPES)) { + case LINE: + call gvline (gp, Memr[hgmr], nbins, z1 + dz/2., z2 - dz/2.) + case BOX: + call hgline (gp, Memr[hgmr], nbins, z1, z2) + default: + call error (1, "bad switch 2") + } + + call gclose (gp) + } + + call imunmap (im) + call sfree (sp) +end + + +# HGLINE -- Draw a stepped curve of the histogram data. + +procedure hgline (gp, ydata, npts, x1, x2) + +pointer gp # Graphics descriptor +real ydata[ARB] # Y coordinates of the line endpoints +int npts # Number of line endpoints +real x1, x2 + +int pixel +real x, y, dx + +begin + dx = (x2 - x1) / npts + + # Do the first horizontal line + x = x1 + y = ydata[1] + call gamove (gp, x, y) + x = x + dx + call gadraw (gp, x, y) + + do pixel = 2, npts { + x = x1 + dx * (pixel - 1) + y = ydata[pixel] + # vertical connection + call gadraw (gp, x, y) + # horizontal line + call gadraw (gp, x + dx, y) + } +end + + +# These two routines are intended to be generic vops routines. Only +# the integer versions are included since that's all that's used here. + +# <NOT IMPLEMENTED!> The operation is carried out in such a way that +# the result is the same whether or not the output vector overlaps +# (partially) the input vector. The routines WILL work in place! + +# ACUM -- Compute a cumulative vector (generic). Should b[1] be zero? + +procedure ih_acumi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +# int npix, i, a_first, b_first + +begin +# call zlocva (a, a_first) +# call zlocva (b, b_first) +# +# if (b_first <= a_first) { + # Shouldn't use output arguments internally, + # but no reason to use this routine unsafely. + b[1] = a[1] + do i = 2, npix + b[i] = b[i-1] + a[i] +# } else { + # overlapping solution not implemented yet! +# } +end + + +# AMRG -- Compute a marginal (forward difference) vector (generic). + +procedure ih_amrgi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +# int npix, i, a_first, b_first + +begin +# call zlocva (a, a_first) +# call zlocva (b, b_first) +# +# if (b_first <= a_first) { + do i = 1, npix-1 + b[i] = a[i+1] - a[i] + b[npix] = 0 +# } else { + # overlapping solution not implemented yet! +# } +end diff --git a/pkg/images/imutil/src/imjoin.gx b/pkg/images/imutil/src/imjoin.gx new file mode 100644 index 00000000..3a6dbde7 --- /dev/null +++ b/pkg/images/imutil/src/imjoin.gx @@ -0,0 +1,92 @@ +include <imhdr.h> + +define VPTR Memi[$1+$2-1] # Array of axis vector pointers + +$for (silrdx) + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoin$t (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnl$t() +pointer impnl$t() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnl$t (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnl$t (in, inbuf, Meml[VPTR(vin,image)]) + call amov$t (Mem$t[inbuf], Mem$t[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnl$t (out, outbuf, Meml[vout]) + stat = imgnl$t (in, inbuf, Meml[VPTR(vin,image)]) + call amov$t (Mem$t[inbuf], Mem$t[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnl$t (out, outbuf, Meml[vout]) + stat = imgnl$t (in, inbuf, Meml[VPTR(vin,image)]) + call amov$t (Mem$t[inbuf], Mem$t[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/imutil/src/imminmax.x b/pkg/images/imutil/src/imminmax.x new file mode 100644 index 00000000..78daff61 --- /dev/null +++ b/pkg/images/imutil/src/imminmax.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IM_MINMAX -- Compute the minimum and maximum pixel values of an image. +# Works for images of any dimensionality, size, or datatype, although +# the min and max values can currently only be stored in the image header +# as real values. + +procedure im_minmax (im, min_value, max_value) + +pointer im # image descriptor +real min_value # minimum pixel value in image (out) +real max_value # maximum pixel value in image (out) + +pointer buf +bool first_line +long v[IM_MAXDIM] +short minval_s, maxval_s +long minval_l, maxval_l +real minval_r, maxval_r +int imgnls(), imgnll(), imgnlr() + +begin + call amovkl (long(1), v, IM_MAXDIM) # start vector + first_line = true + min_value = INDEF + max_value = INDEF + + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + while (imgnls (im, buf, v) != EOF) { + call alims (Mems[buf], IM_LEN(im,1), minval_s, maxval_s) + if (first_line) { + min_value = minval_s + max_value = maxval_s + first_line = false + } else { + if (minval_s < min_value) + min_value = minval_s + if (maxval_s > max_value) + max_value = maxval_s + } + } + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (im, buf, v) != EOF) { + call aliml (Meml[buf], IM_LEN(im,1), minval_l, maxval_l) + if (first_line) { + min_value = minval_l + max_value = maxval_l + first_line = false + } else { + if (minval_l < min_value) + min_value = minval_l + if (maxval_l > max_value) + max_value = maxval_l + } + } + default: + while (imgnlr (im, buf, v) != EOF) { + call alimr (Memr[buf], IM_LEN(im,1), minval_r, maxval_r) + if (first_line) { + min_value = minval_r + max_value = maxval_r + first_line = false + } else { + if (minval_r < min_value) + min_value = minval_r + if (maxval_r > max_value) + max_value = maxval_r + } + } + } +end diff --git a/pkg/images/imutil/src/imrep.gx b/pkg/images/imutil/src/imrep.gx new file mode 100644 index 00000000..89ce581b --- /dev/null +++ b/pkg/images/imutil/src/imrep.gx @@ -0,0 +1,346 @@ +include <imhdr.h> +include <mach.h> + +$for (silrdx) + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrep$t (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +$if (datatype == sil) +real ilower +$endif +PIXEL floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +$if (datatype == sil) +bool fp_equalr() +$endif + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + $if (datatype == x) + newval = complex (value, img) + $else + newval = double (value) + $endif + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnl$t (im, buf2, v2) != EOF) + call amovk$t (newval, Mem$t[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + $if (datatype == sil) + ceil = int (upper) + $else + ceil = double (upper) + $endif + while (imgnl$t (im, buf1, v1) != EOF) { + junk = impnl$t (im, buf2, v2) + call amov$t (Mem$t[buf1], Mem$t[buf2], npix) + call arle$t (Mem$t[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + $else + floor = double (lower) + $endif + while (imgnl$t (im, buf1, v1) != EOF) { + junk = impnl$t (im, buf2, v2) + call amov$t (Mem$t[buf1], Mem$t[buf2], npix) + call arge$t (Mem$t[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + $else + floor = double (lower) + ceil = double (upper) + $endif + while (imgnl$t (im, buf1, v1) != EOF) { + junk = impnl$t (im, buf2, v2) + call amov$t (Mem$t[buf1], Mem$t[buf2], npix) + call arep$t (Mem$t[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrep$t (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +$if (datatype == sil) +real ilower +$endif +PIXEL floor, ceil, newval, val1, val2 +$if (datatype == x) +real abs_floor, abs_ceil +$endif +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnl$t(), impnl$t() +$if (datatype == sil) +bool fp_equalr() +$endif + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + $if (datatype == x) + newval = complex (value, img) + $else + newval = double (value) + $endif + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnl$t (im, buf2, v2) != EOF) + call amovk$t (newval, Mem$t[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + $if (datatype == sil) + floor = -MAX_PIXEL + ceil = int (upper) + $else $if (datatype == x) + floor = 0 + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $else + floor = -MAX_PIXEL + ceil = double (upper) + $endif $endif + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_PIXEL + $else $if (datatype == x) + floor = real (lower) + ceil = MAX_REAL + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $else + floor = double (lower) + ceil = MAX_PIXEL + $endif $endif + + # Replace pixels between lower and upper by value. + } else { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + $else $if (datatype == x) + floor = real (lower) + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $else + floor = double (lower) + ceil = double (upper) + $endif $endif + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_PIXEL) + + while (imgnl$t (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Mem$t[buf1] + val2 = Mem$t[buf2] + $if (datatype == x) + if ((abs (val1) >= abs_floor) && (abs (val1) <= abs_ceil)) { + $else + if ((val1 >= floor) && (val1 <= ceil)) { + $endif + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Mem$t[ptr+l] = INDEF + } + } + } else { + if (!IS_INDEF(val2)) + Mem$t[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnl$t (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Mem$t[buf1] + if (IS_INDEF(Mem$t[buf1])) + Mem$t[buf2] = newval + else + Mem$t[buf2] = val1 + Mem$t[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_PIXEL) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arep$t (a, npts, floor, ceil, newval) + +PIXEL a[npts] # Input arrays +int npts # Number of points +PIXEL floor, ceil # Replacement limits +PIXEL newval # Replacement value + +int i +$if (datatype == x) +real abs_floor +real abs_ceil +$endif + +begin + $if (datatype == x) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $endif + + do i = 1, npts { + $if (datatype == x) + if ((abs (a[i]) >= abs_floor) && (abs (a[i]) <= abs_ceil)) + $else + if ((a[i] >= floor) && (a[i] <= ceil)) + $endif + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arle$t (a, npts, floor, newval) + +PIXEL a[npts] +int npts +PIXEL floor, newval + +int i +$if (datatype == x) +real abs_floor +$endif + +begin + $if (datatype == x) + abs_floor = abs (floor) + $endif + + do i = 1, npts + $if (datatype == x) + if (abs (a[i]) <= abs_floor) + $else + if (a[i] <= floor) + $endif + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arge$t (a, npts, ceil, newval) + +PIXEL a[npts] +int npts +PIXEL ceil, newval + +int i +$if (datatype == x) +real abs_ceil +$endif + +begin + $if (datatype == x) + abs_ceil = abs (ceil) + $endif + + do i = 1, npts + $if (datatype == x) + if (abs (a[i]) >= abs_ceil) + $else + if (a[i] >= ceil) + $endif + a[i] = newval +end + +$endfor diff --git a/pkg/images/imutil/src/imstat.h b/pkg/images/imutil/src/imstat.h new file mode 100644 index 00000000..b059bc31 --- /dev/null +++ b/pkg/images/imutil/src/imstat.h @@ -0,0 +1,62 @@ +# Header file for the IMSTATISTTICS task. + +define LEN_IMSTAT 20 + +define IST_SUMX Memd[P2D($1)] +define IST_SUMX2 Memd[P2D($1+2)] +define IST_SUMX3 Memd[P2D($1+4)] +define IST_SUMX4 Memd[P2D($1+6)] +define IST_LO Memr[P2R($1+8)] +define IST_HI Memr[P2R($1+9)] +define IST_MIN Memr[P2R($1+10)] +define IST_MAX Memr[P2R($1+11)] +define IST_MEAN Memr[P2R($1+12)] +define IST_MEDIAN Memr[P2R($1+13)] +define IST_MODE Memr[P2R($1+14)] +define IST_STDDEV Memr[P2R($1+15)] +define IST_SKEW Memr[P2R($1+16)] +define IST_KURTOSIS Memr[P2R($1+17)] +define IST_NPIX Memi[$1+18] +define IST_SW Memi[$1+19] + +define LEN_NSWITCHES 8 + +define IST_SKURTOSIS Memi[$1] +define IST_SSKEW Memi[$1+1] +define IST_SSTDDEV Memi[$1+2] +define IST_SMODE Memi[$1+3] +define IST_SMEDIAN Memi[$1+4] +define IST_SMEAN Memi[$1+5] +define IST_SMINMAX Memi[$1+6] +define IST_SNPIX Memi[$1+7] + +define IST_FIELDS "|image|npix|min|max|mean|midpt|mode|stddev|skew|kurtosis|" + +define IST_NFIELDS 10 + +define IST_KIMAGE "IMAGE" +define IST_KNPIX "NPIX" +define IST_KMIN "MIN" +define IST_KMAX "MAX" +define IST_KMEAN "MEAN" +define IST_KMEDIAN "MIDPT" +define IST_KMODE "MODE" +define IST_KSTDDEV "STDDEV" +define IST_KSKEW "SKEW" +define IST_KKURTOSIS "KURTOSIS" + +define IST_FIMAGE 1 +define IST_FNPIX 2 +define IST_FMIN 3 +define IST_FMAX 4 +define IST_FMEAN 5 +define IST_FMEDIAN 6 +define IST_FMODE 7 +define IST_FSTDDEV 8 +define IST_FSKEW 9 +define IST_FKURTOSIS 10 + +define IST_FCOLUMN "%10d" +define IST_FINTEGER "%10d" +define IST_FREAL "%10.4g" +define IST_FSTRING "%20s" diff --git a/pkg/images/imutil/src/imsum.gx b/pkg/images/imutil/src/imsum.gx new file mode 100644 index 00000000..31afc420 --- /dev/null +++ b/pkg/images/imutil/src/imsum.gx @@ -0,0 +1,398 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../imsum.h" + +define TMINSW 1.00 # Relative timings for nvecs = 5 +define TMXMNSW 1.46 +define TMED3 0.18 +define TMED5 0.55 + +# IMSUM -- Sum or average images with optional high and low pixel rejection. +# +# This procedure has to be clever in not exceeding the maximum number of images +# which can be mapped at one time. If no pixels are being rejected then the +# images can be summed (or averaged) in blocks using the output image to hold +# intermediate results. If pixels are being rejected then lines from all +# images must be obtained. If the number of images exceeds the maximum +# then only a subset of the images are kept mapped and the remainder are +# mapped and unmapped for each line. This, of course, is inefficient but +# there is no other way. + +$for(silrd) +procedure imsum$t (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +PIXEL const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnl$t(), impnl$t() +errchk immap, imunmap, imgnl$t, impnl$t + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnl$t (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclr$t (Mem$t[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amov$t (Mem$t[buf_in], Mem$t[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aadd$t (Mem$t[buf_in], Mem$t[buf_out], + Mem$t[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivk$t (Mem$t[buf_out], const, Mem$t[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_PIXEL) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnl$t (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amov$t (Mem$t[buf_in], Mem$t[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrej$t (Memi[buf], nimages, Mem$t[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivk$t (Mem$t[buf_out], const, Mem$t[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrej$t (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +PIXEL b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amov$t (Mem$t[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minsw$t (a, i, npts) + i = i - 1 + } + call amov$t (Mem$t[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxsw$t (a, i, npts) + i = i - 1 + } + call amov$t (Mem$t[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnsw$t (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minsw$t (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxsw$t (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amov$t (Mem$t[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3$t (Mem$t[a[1]], Mem$t[a[2]], Mem$t[a[3]], b, npts) + } else { + call amed5$t (Mem$t[a[1]], Mem$t[a[2]], Mem$t[a[3]], + Mem$t[a[4]], Mem$t[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minsw$t (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +PIXEL temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mem$t[k] < Mem$t[kmin]) + kmin = k + } + if (k != kmin) { + temp = Mem$t[k] + Mem$t[k] = Mem$t[kmin] + Mem$t[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxsw$t (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +PIXEL temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mem$t[k] > Mem$t[kmax]) + kmax = k + } + if (k != kmax) { + temp = Mem$t[k] + Mem$t[k] = Mem$t[kmax] + Mem$t[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnsw$t (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +PIXEL temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Mem$t[k] > Mem$t[kmax]) + kmax = k + else if (Mem$t[k] < Mem$t[kmin]) + kmin = k + } + temp = Mem$t[k] + Mem$t[k] = Mem$t[kmax] + Mem$t[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Mem$t[j] + Mem$t[j] = Mem$t[kmax] + Mem$t[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Mem$t[j] + Mem$t[j] = Mem$t[kmin] + Mem$t[kmin] = temp + } + } +end +$endfor diff --git a/pkg/images/imutil/src/imsum.h b/pkg/images/imutil/src/imsum.h new file mode 100644 index 00000000..190d277c --- /dev/null +++ b/pkg/images/imutil/src/imsum.h @@ -0,0 +1,4 @@ +# Definitions for IMSUM + +define IMS_MAX 15 # Maximum number of images which are mapped + # at the same time. diff --git a/pkg/images/imutil/src/imtile.h b/pkg/images/imutil/src/imtile.h new file mode 100644 index 00000000..a2610860 --- /dev/null +++ b/pkg/images/imutil/src/imtile.h @@ -0,0 +1,55 @@ +# Header file for the IMTILE task. + +# Define the structure + +define LEN_IRSTRUCT 35 + +define IT_NCOLS Memi[$1] # x length of single subraster +define IT_NROWS Memi[$1+1] # y length of a single subrasters +define IT_NXOVERLAP Memi[$1+2] # x overlap between subrasters +define IT_NYOVERLAP Memi[$1+3] # y overlap between subrasters +define IT_NXSUB Memi[$1+4] # number of subrasters in x dimension +define IT_NYSUB Memi[$1+5] # number of subrasters in y dimension +define IT_NXRSUB Memi[$1+6] # x index of reference subraster +define IT_NYRSUB Memi[$1+7] # y index of reference subraster +define IT_XREF Memi[$1+8] # x offset of reference subraster +define IT_YREF Memi[$1+9] # y offset of reference subraster +define IT_CORNER Memi[$1+10] # starting corner for insertion +define IT_ORDER Memi[$1+11] # row or column insertion +define IT_RASTER Memi[$1+12] # raster order +define IT_OVAL Memr[P2R($1+13)] # undefined value + +define IT_IC1 Memi[$1+14] # input image lower column limit +define IT_IC2 Memi[$1+15] # input image upper column limit +define IT_IL1 Memi[$1+16] # input image lower line limit +define IT_IL2 Memi[$1+17] # input image upper line limit +define IT_OC1 Memi[$1+18] # output image lower column limit +define IT_OC2 Memi[$1+19] # output image upper column limit +define IT_OL1 Memi[$1+20] # output image lower line limit +define IT_OL2 Memi[$1+21] # output image upper line limit +define IT_DELTAX Memi[$1+22] # x shifts +define IT_DELTAY Memi[$1+23] # y shifts +define IT_DELTAI Memi[$1+24] # intensity shifts + +define IT_XRSHIFTS Memi[$1+25] # x row links +define IT_YRSHIFTS Memi[$1+26] # y row links +define IT_NRSHIFTS Memi[$1+27] # number of row links +define IT_XCSHIFTS Memi[$1+28] # x column links +define IT_YCSHIFTS Memi[$1+29] # y column links +define IT_NCSHIFTS Memi[$1+30] # number of column links + +# Define some useful constants + +define IT_LL 1 +define IT_LR 2 +define IT_UL 3 +define IT_UR 4 + +define IT_ROW 1 +define IT_COLUMN 2 + +define IT_COORDS 1 +define IT_SHIFTS 2 +define IT_FILE 3 + +define MAX_NRANGES 100 diff --git a/pkg/images/imutil/src/listpixels.x b/pkg/images/imutil/src/listpixels.x new file mode 100644 index 00000000..e4435c95 --- /dev/null +++ b/pkg/images/imutil/src/listpixels.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <mwset.h> + +# LISTPIXELS -- Convert image pixels into a text stream, i.e., into a list. +# Each pixel is printed on a separate line, preceded by its coordinates. +# The images or image sections may be of any dimension. + +procedure t_listpixels() + +bool verbose +char image[SZ_FNAME], wcs[SZ_FNAME] +double incoords[IM_MAXDIM], outcoords[IM_MAXDIM] +int i, j, npix, ndim, wcsndim, laxis1, fmtstat +int paxno[IM_MAXDIM], laxno[IM_MAXDIM] +long v[IM_MAXDIM], vcoords[IM_MAXDIM] +pointer im, line, imlist, mw, ct, fmtptrs[IM_MAXDIM] + +bool clgetb() +int imgnlr(), imgnld(), imgnlx(), imtgetim(), mw_stati(), clscan(), nscan() +pointer imtopenp(), immap(), mw_openim(), mw_sctran() + +begin + # Get the image list and the wcs. + imlist = imtopenp ("images") + call clgstr ("wcs", wcs, SZ_FNAME) + if (wcs[1] == EOS) + call strcpy ("logical", wcs, SZ_FNAME) + verbose = clgetb ("verbose") + + while (imtgetim (imlist, image, SZ_FNAME) != EOF) { + # Print optional banner string. + if (verbose) { + call printf ("\n#Image: %s Wcs: %s\n\n") + call pargstr (image) + call pargstr (wcs) + } + + # Open the input image. + im = immap (image, READ_ONLY, 0) + ndim = IM_NDIM(im) + npix = IM_LEN(im,1) + + # Get the wcs. + ifnoerr (mw = mw_openim (im)) { + # Set up the transformation. + call mw_seti (mw, MW_USEAXMAP, NO) + ct = mw_sctran (mw, "logical", wcs, 0) + wcsndim = mw_stati (mw, MW_NPHYSDIM) + + # Get the physical to logical axis map. + call mw_gaxmap (mw, paxno, laxno, wcsndim) + + # Set the default wcs. + call mw_ssytem (mw, wcs) + + } else { + # Print the error message from the above loop. + call erract (EA_WARN) + + # Set the transform to the identity transform. + mw = NULL + ct = NULL + wcsndim = ndim + + # Set the default physical to logical axis map. + do i = 1, wcsndim + paxno[i] = i + } + + # Initialize the v vectors. + call amovkl (long (1), v, IM_MAXDIM) + call amovkl (long (1), vcoords, IM_MAXDIM) + + # Initialize the coordinates. + laxis1 = 0 + do i = 1, wcsndim { + if (paxno[i] == 0) { + incoords[i] = 1 + } else if (paxno[i] == 1) { + laxis1 = i + incoords[i] = v[1] + } else { + incoords[i] = v[paxno[i]] + } + } + + # Check and correct for the no axis mapping case. + if (laxis1 == 0) { + laxis1 = 1 + do i = 1, wcsndim + paxno[i] = i + } + + # Get the logical to physical axis map for the format strings. + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + + # Set the format strings for the logical axes. + fmtstat = clscan ("formats") + do i = 1, ndim { + call malloc (fmtptrs[i], SZ_FNAME, TY_CHAR) + if (fmtstat != EOF) + call gargwrd (Memc[fmtptrs[i]], SZ_FNAME) + else + Memc[fmtptrs[i]] = EOS + if ((nscan() == i) && (Memc[fmtptrs[i]] != EOS)) + call strcat (" ", Memc[fmtptrs[i]], SZ_FNAME) + else if (laxno[i] == 0) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else if (mw == NULL || ct == NULL) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else iferr (call mw_gwattrs (mw, laxno[i], "format", + Memc[fmtptrs[i]], SZ_FNAME)) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else + call strcat (" ", Memc[fmtptrs[i]], SZ_FNAME) + } + + # Print the pixels. + switch (IM_PIXTYPE(im)) { + case TY_COMPLEX: + while (imgnlx (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %z\n") # pixel value + call pargx (Memx[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + case TY_DOUBLE: + while (imgnld (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %g\n") # pixel value + call pargd (Memd[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + default: + while (imgnlr (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %g\n") # pixel value + call pargr (Memr[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + } + + do i = 1, ndim + call mfree (fmtptrs[i], TY_CHAR) + if (mw != NULL) + call mw_close (mw) + call imunmap (im) + } + + call imtclose (imlist) +end diff --git a/pkg/images/imutil/src/minmax.x b/pkg/images/imutil/src/minmax.x new file mode 100644 index 00000000..c3dcbfff --- /dev/null +++ b/pkg/images/imutil/src/minmax.x @@ -0,0 +1,313 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IM_VMINMAX -- Compute the minimum and maximum pixel values of an image. +# Works for images of any dimensionality, size, or datatype, although +# the min and max values can currently only be stored in the image header +# as real values. + +procedure im_vminmax (im, min_value, max_value, imin_value, imax_value, + vmin, vmax) + +pointer im # image descriptor +double min_value # minimum pixel value in image (real, out) +double max_value # maximum pixel value in image (real, out) +double imin_value # minimum pixel value in image (imag, out) +double imax_value # maximum pixel value in image (imag, out) +long vmin[ARB], vmax[ARB] # v vectors + +bool first_line +int colmin, colmax +complex xmin_value, xmax_value, minval_x, maxval_x +long v[IM_MAXDIM], ovmin[IM_MAXDIM], ovmax[IM_MAXDIM] +short minval_s, maxval_s +long minval_l, maxval_l +pointer buf +real minval_r, maxval_r +double minval_d, maxval_d +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() + +begin + call amovkl (long(1), v, IM_MAXDIM) # start vector + call amovkl (long(1), ovmin, IM_MAXDIM) + call amovkl (long(1), ovmax, IM_MAXDIM) + call amovkl (long(1), vmin, IM_MAXDIM) + call amovkl (long(1), vmax, IM_MAXDIM) + + first_line = true + min_value = INDEFD + max_value = INDEFD + imin_value = INDEFD + imax_value = INDEFD + + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + while (imgnls (im, buf, v) != EOF) { + call valims (Mems[buf], IM_LEN(im,1), minval_s, maxval_s, + colmin, colmax) + if (first_line) { + min_value = minval_s + max_value = maxval_s + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_s < min_value) { + min_value = minval_s + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_s > max_value) { + max_value = maxval_s + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (im, buf, v) != EOF) { + call valiml (Meml[buf], IM_LEN(im,1), minval_l, maxval_l, + colmin, colmax) + if (first_line) { + min_value = minval_l + max_value = maxval_l + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_l < min_value) { + min_value = minval_l + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_l > max_value) { + max_value = maxval_l + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_REAL: + while (imgnlr (im, buf, v) != EOF) { + call valimr (Memr[buf], IM_LEN(im,1), minval_r, maxval_r, + colmin, colmax) + if (first_line) { + min_value = minval_r + max_value = maxval_r + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_r < min_value) { + min_value = minval_r + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_r > max_value) { + max_value = maxval_r + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_DOUBLE: + while (imgnld (im, buf, v) != EOF) { + call valimd (Memd[buf], IM_LEN(im,1), minval_d, maxval_d, + colmin, colmax) + if (first_line) { + min_value = minval_d + max_value = maxval_d + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_d < min_value) { + min_value = minval_d + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_d > max_value) { + max_value = maxval_d + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_COMPLEX: + while (imgnlx (im, buf, v) != EOF) { + call valimx (Memx[buf], IM_LEN(im,1), minval_x, maxval_x, + colmin, colmax) + if (first_line) { + xmin_value = minval_x + xmax_value = maxval_x + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (abs (minval_x) < abs (xmin_value)) { + xmin_value = minval_x + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (abs (maxval_x) > abs (xmax_value)) { + xmax_value = maxval_x + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + min_value = real (xmin_value) + max_value = real (xmax_value) + imin_value = aimag (xmin_value) + imax_value = aimag (xmax_value) + + default: + call error (0, "Unknown pixel data type") + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valims (a, npix, minval_s, maxval_s, colmin, colmax) + +short a[ARB], minval_s, maxval_s, value +int colmin, colmax, npix, i + +begin + minval_s = a[1] + maxval_s = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_s) { + minval_s = value + colmin = i + } else if (value > maxval_s) { + maxval_s = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valiml (a, npix, minval_l, maxval_l, colmin, colmax) + +long a[ARB], minval_l, maxval_l, value +int colmin, colmax, npix, i + +begin + minval_l = a[1] + maxval_l = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_l) { + minval_l = value + colmin = i + } else if (value > maxval_l) { + maxval_l = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valimr (a, npix, minval_r, maxval_r, colmin, colmax) + +real a[ARB], minval_r, maxval_r, value +int colmin, colmax, npix, i + +begin + minval_r = a[1] + maxval_r = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_r) { + minval_r = value + colmin = i + } else if (value > maxval_r) { + maxval_r = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valimd (a, npix, minval_d, maxval_d, colmin, colmax) + +double a[ARB], minval_d, maxval_d, value +int colmin, colmax, npix, i + +begin + minval_d = a[1] + maxval_d = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_d) { + minval_d = value + colmin = i + } else if (value > maxval_d) { + maxval_d = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valimx (a, npix, minval_x, maxval_x, colmin, colmax) + +complex a[ARB], minval_x, maxval_x, value +int colmin, colmax, npix, i + +begin + minval_x = a[1] + maxval_x = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (abs (value) < abs (minval_x)) { + minval_x = value + colmin = i + } else if (abs (value) > abs (maxval_x)) { + maxval_x = value + colmax = i + } + } +end diff --git a/pkg/images/imutil/src/mkpkg b/pkg/images/imutil/src/mkpkg new file mode 100644 index 00000000..7fdbfbb3 --- /dev/null +++ b/pkg/images/imutil/src/mkpkg @@ -0,0 +1,81 @@ +# Library for making the IMUTIL tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (imexpr.x, imexpr.gx) + $(GEN) imexpr.gx -o imexpr.x $endif + + $ifolder (generic/imfuncs.x, imfuncs.gx) + $(GEN) imfuncs.gx -o generic/imfuncs.x $endif + + $ifolder (generic/imjoin.x, imjoin.gx) + $(GEN) imjoin.gx -o generic/imjoin.x $endif + + $ifolder (generic/imrep.x, imrep.gx) + $(GEN) imrep.gx -o generic/imrep.x $endif + + $ifolder (generic/imsum.x, imsum.gx) + $(GEN) imsum.gx -o generic/imsum.x $endif + + $ifolder (generic/imaadd.x, imaadd.gx) + $(GEN) imaadd.gx -o generic/imaadd.x $endif + $ifolder (generic/imadiv.x, imadiv.gx) + $(GEN) imadiv.gx -o generic/imadiv.x $endif + $ifolder (generic/imamax.x, imamax.gx) + $(GEN) imamax.gx -o generic/imamax.x $endif + $ifolder (generic/imamin.x, imamin.gx) + $(GEN) imamin.gx -o generic/imamin.x $endif + $ifolder (generic/imamul.x, imamul.gx) + $(GEN) imamul.gx -o generic/imamul.x $endif + $ifolder (generic/imasub.x, imasub.gx) + $(GEN) imasub.gx -o generic/imasub.x $endif + $ifolder (generic/imanl.x, imanl.gx) + $(GEN) imanl.gx -o generic/imanl.x $endif + + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic + + getcmd.x <error.h> <ctotok.h> <lexnum.h> + gettok.x <error.h> <ctype.h> <fset.h> gettok.h <syserr.h> + hedit.x <error.h> <evexpr.h> <imset.h> <ctype.h> <lexnum.h> + imdelete.x <imhdr.h> <error.h> + imexpr.x <ctotok.h> <imhdr.h> <ctype.h> <mach.h> <imset.h>\ + <fset.h> <lexnum.h> <evvexpr.h> gettok.h + iegsym.x <ctotok.h> <imhdr.h> <ctype.h> <mach.h> <imset.h>\ + <fset.h> <lexnum.h> <evvexpr.h> gettok.h + imfunction.x <imhdr.h> + imgets.x <imhdr.h> <error.h> <ctype.h> + imheader.x <imhdr.h> <imio.h> <time.h> <ctype.h> <error.h>\ + <imset.h> + imhistogram.x <mach.h> <imhdr.h> <gset.h> + imminmax.x <imhdr.h> + listpixels.x <error.h> <imhdr.h> <mwset.h> + minmax.x <imhdr.h> + nhedit.x <ctype.h> <error.h> <evexpr.h> <imset.h> <lexnum.h> + t_imstat.x <mach.h> <imhdr.h> <imset.h> "imstat.h" + t_sections.x + hselect.x <error.h> <evexpr.h> <ctype.h> + t_imarith.x <imhdr.h> <error.h> <lexnum.h> + t_imaxes.x <imhdr.h> + t_chpix.x <error.h> <imhdr.h> <fset.h> + t_imcopy.x <imhdr.h> + t_imdivide.x <imhdr.h> + t_imjoin.x <syserr.h> <error.h> <imhdr.h> + t_imrename.x <imhdr.h> + t_imreplace.x <imhdr.h> + t_imslice.x <error.h> <imhdr.h> <ctype.h> <mwset.h> + t_imsum.x <imhdr.h> + t_imstack.x <imhdr.h> <mwset.h> + t_imtile.x <imhdr.h> <fset.h> "imtile.h" + t_minmax.x <error.h> <imhdr.h> <imset.h> + ; diff --git a/pkg/images/imutil/src/nhedit.x b/pkg/images/imutil/src/nhedit.x new file mode 100644 index 00000000..1e9300c1 --- /dev/null +++ b/pkg/images/imutil/src/nhedit.x @@ -0,0 +1,1101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <evexpr.h> +include <imset.h> +include <ctype.h> +include <lexnum.h> + +define LEN_USERAREA 28800 # allow for the largest possible header +define SZ_IMAGENAME 63 # max size of an image name +define SZ_FIELDNAME 31 # max size of a field name +define HRECLEN 80 + +define OP_EDIT 1 # hedit opcodes +define OP_INIT 2 +define OP_ADD 3 +define OP_DELETE 4 +define OP_DEFPAR 5 +define OP_RENAME 6 +define BEFORE 1 +define AFTER 2 + + +# NHEDIT -- Edit or view selected fields of an image header or headers. This +# editor performs a single edit operation upon a relation, e.g., upon a set +# of fields of a set of images. Templates and expressions may be used to +# automatically select the images and fields to be edited, and to compute +# the new value of each field. + +procedure t_nhedit() + +pointer fields # template listing fields to be processed +pointer valexpr # the value expression (if op=edit|add) + +bool noupdate, quit +int imlist, nfields, up, min_lenuserarea +pointer sp, field, comment, sections, im, ip, image, buf +pointer cmd, pkey +int operation, verify, show, update, fd, baf +int dp_oper, dp_update, dp_verify, dp_show + +pointer immap() +bool streq() +int imtopenp(), imtgetim(), getline(), nowhite() +int envfind(), ctoi(), open() + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (fields, SZ_FNAME, TY_CHAR) + call salloc (pkey, SZ_FNAME, TY_CHAR) + call salloc (valexpr, SZ_LINE, TY_CHAR) + call salloc (comment, SZ_LINE, TY_CHAR) + call salloc (sections, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Get the primary operands. + imlist = imtopenp ("images") + + # Determine type of operation to be performed (default is edit). + + # Do we have a command file instead of a command line? Allow either + # a null string or the string "NULL" to indicate we don't. + + call clgstr ("comfile", Memc[fields], SZ_LINE) + if (nowhite (Memc[fields], Memc[fields], SZ_LINE) == 0 || + streq (Memc[fields], "NULL")) { + call he_getpars (operation, fields, valexpr, Memc[comment], + Memc[pkey], baf, update, verify, show) + fd = 0 + } else { + call he_getpars (dp_oper, NULL, valexpr, Memc[comment], + Memc[pkey], baf, dp_update, dp_verify, dp_show) + fd = open(Memc[fields], READ_ONLY, TEXT_FILE) + } + + # Main processing loop. An image is processed in each pass through + # the loop. + + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # set the length of the user area + if (envfind ("min_lenuserarea", Memc[sections], SZ_FNAME) > 0) { + up = 1 + if (ctoi (Memc[sections], up, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Open the image. + iferr { + if (update == YES || fd != 0) + im = immap (Memc[image], READ_WRITE, min_lenuserarea) + else + im = immap (Memc[image], READ_ONLY, min_lenuserarea) + } then { + call erract (EA_WARN) + next + } + + if (fd != 0) { + # Open the command file and start processing each line. + # rewind file before proceeding + + call seek(fd, BOF) + while (getline(fd, Memc[cmd]) != EOF) { + for (ip=cmd; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[cmd] == '#' || Memc[ip] == '\n') + next + + call he_getcmdf (Memc[cmd], operation, Memc[fields], + Memc[valexpr], Memc[comment], Memc[pkey], baf, + update, verify, show) + + # Set the default parameters for the command file. + if (operation < 0) { + dp_oper = -operation + if (update != -1) + dp_update = update + if (verify != -1) + dp_verify = verify + if (show != -1) + dp_show = show + next + } + + # Set the parameters for the current command, the + # command parameters take precedence over the defaults. + call nh_setpar (operation, dp_oper, dp_update, + dp_verify, dp_show, update, verify, show) + + iferr (call nh_edit (im, Memc[image], operation, + Memc[fields], Memc[valexpr], Memc[comment], + Memc[pkey], baf, update, verify, show, nfields)) + call erract (EA_WARN) + + } + + } else + iferr (call nh_edit (im, Memc[image], operation, Memc[fields], + Memc[valexpr], Memc[comment], Memc[pkey], baf, update, + verify, show, nfields)) + call erract (EA_WARN) + + # Update the image header and unmap the image. + + noupdate = false + quit = false + + if (update == YES) { + if (nfields == 0 && fd == 0) + noupdate = true + else if (verify == YES) { + call eprintf ("update %s ? (yes): ") + call pargstr (Memc[image]) + call flush (STDERR) + + if (getline (STDIN, Memc[buf]) == EOF) + noupdate = true + else { + # Strip leading whitespace and trailing newline. + for (ip=buf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == 'q') { + quit = true + noupdate = true + } else if (! (Memc[ip] == '\n' || Memc[ip] == 'y')) + noupdate = true + } + } + + if (noupdate) { + call imseti (im, IM_WHEADER, NO) + call imunmap (im) + } else { + call imunmap (im) + if (show == YES) { + call printf ("%s updated\n") + call pargstr (Memc[image]) + } + } + } else { + call imunmap (im) + } + + call flush (STDOUT) + if (quit) + break + } #end of while + + # Close command file + if (fd != 0) + call close(fd) + call imtclose (imlist) + call sfree (sp) +end + + +# NH_EDIT -- Edit the field in the image header. + +procedure nh_edit (im, image, operation, keyws, exprs, comment, pkey, baf, + update, verify, show, nfields) + +pointer im #I image descriptor +char image[ARB] # +int operation #I operation code +char keyws[ARB] # Memc[fields] +char exprs[ARB] # Memc[valexpr] +char comment[ARB] # Memc[comment] +char pkey[ARB] # +int baf +int update +int verify +int show +int nfields + +pointer sp, field +int imgnfn(), imofnlu() +int flist + +begin + + call smark(sp) + call salloc (field, SZ_FNAME, TY_CHAR) + + if (operation == OP_INIT || operation == OP_ADD) { + # Add a field to the image header. This cannot be done within + # the IMGNFN loop because template expansion on the existing + # fields of the image header would discard the new field name + # since it does not yet exist. + + nfields = 1 + call he_getopsetimage (im, image, keyws) + switch (operation) { + case OP_INIT: + call nh_initfield (im, image, keyws, exprs, comment, + pkey, baf, verify, show, update) + case OP_ADD: + call nh_addfield (im, image, keyws, exprs, comment, + pkey, baf, verify, show, update) + } + } else { + # Open list of fields to be processed. + flist = imofnlu (im, keyws) + nfields = 0 + while (imgnfn (flist, Memc[field], SZ_FNAME) != EOF) { + call he_getopsetimage (im, image, Memc[field]) + + switch (operation) { + case OP_EDIT: + call nh_editfield (im, image, Memc[field], + exprs, comment, verify, show, update) + case OP_RENAME: + call nh_renamefield (im, image, Memc[field], + exprs, verify, show, update) + case OP_DELETE: + call nh_deletefield (im, image, Memc[field], + exprs, verify, show, update) + } + nfields = nfields + 1 + } + + call imcfnl (flist) + } + call sfree(sp) +end + + +# NH_EDITFIELD -- Edit the value of the named field of the indicated image. +# The value expression is evaluated, interactively inspected if desired, +# and the resulting value put to the image. + +procedure nh_editfield (im, image, field, valexpr, comment, verify, + show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +char comment[ARB] # keyword comment +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +int goahead, nl +pointer sp, ip, oldval, newval, defval, o, fcomm, ncomm + +bool streq() +pointer evexpr() +extern he_getop() +int getline(), imaccf(), strldxs(), locpr() +errchk evexpr, getline, imaccf, he_gval + +begin + call smark (sp) + call salloc (oldval, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + call salloc (defval, SZ_LINE, TY_CHAR) + call salloc (fcomm, HRECLEN, TY_CHAR) + call salloc (ncomm, HRECLEN, TY_CHAR) + + call strcpy (comment, Memc[ncomm], HRECLEN) + + # Verify that the named field exists before going any further. + if (field[1] != '$') + if (imaccf (im, field) == NO) { + call eprintf ("parameter %s,%s not found\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # Get the old value. + call he_gval (im, image, field, Memc[oldval], SZ_LINE) + + # Evaluate the expression. Encode the result operand as a string. + # If the expression is not parenthesized, assume that is is already + # a string literal. + + if (valexpr[1] == '(') { + o = evexpr (valexpr, locpr (he_getop), 0) + call he_encodeop (o, Memc[newval], SZ_LINE) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } else + call strcpy (valexpr, Memc[newval], SZ_LINE) + + call imgcom (im, field, Memc[fcomm]) + if (streq (Memc[newval], ".") && streq (comment, ".")) { + # Merely print the value of the field. + + if (Memc[fcomm] == EOS) { + call printf ("%s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + } else { + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + call printf ("%s,%s = %s / %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + call pargstr(Memc[fcomm]) + } + + } else if (verify == YES) { + # Query for new value and edit the field. If the response is a + # blank line, use the default new value. If the response is "$" + # or EOF, do not change the value of the parameter. + + if (streq (Memc[newval], ".")) { + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + } + if (streq (comment, ".")) + call strcpy (Memc[fcomm], Memc[ncomm], SZ_LINE) + call strcpy (Memc[newval], Memc[defval], SZ_LINE) + call eprintf ("%s,%s (%s -> %s): ") + call pargstr (image) + call pargstr (field) + call nh_pargstrc (Memc[oldval], Memc[fcomm]) + call nh_pargstrc (Memc[defval], Memc[ncomm]) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Do not skip leading whitespace; may be significant in a + # string literal. + + ip = newval + + # Do strip trailing newline since it is an artifact of getline. + nl = strldxs ("\n", Memc[ip]) + if (nl > 0) + Memc[ip+nl-1] = EOS + + # Decode user response. + if (Memc[ip] == '\\') { + ip = ip + 1 + goahead = YES + } else if (streq(Memc[ip],"n") || streq(Memc[ip],"no")) { + goahead = NO + } else if (streq(Memc[ip],"y") || streq(Memc[ip],"yes") || + Memc[ip] == EOS) { + call strcpy (Memc[defval], Memc[newval], SZ_LINE) + goahead = YES + } else { + if (ip > newval) + call strcpy (Memc[ip], Memc[newval], SZ_LINE) + goahead = YES + } + + # Edit field if so indicated. + if (goahead == YES && update == YES) + call nh_updatefield (im, image, field, Memc[oldval], + Memc[newval], Memc[fcomm], Memc[ncomm], show) + + call flush (STDOUT) + } + + } else { + if (streq (Memc[newval], ".")) { + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + } + if (streq (comment, ".")) + call strcpy (Memc[fcomm], Memc[ncomm], SZ_LINE) + if (update == YES) { + call nh_updatefield (im, image, field, Memc[oldval], + Memc[newval], Memc[fcomm], Memc[ncomm], show) + } + } + if (update == NO && show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call nh_pargstrc (Memc[oldval], Memc[fcomm]) + call nh_pargstrc (Memc[newval], Memc[ncomm]) + } + + call sfree (sp) +end + + +# NH_RENAMEFIELD -- Rename the named field of the indicated image. +# The value expression is evaluated, interactively inspected if desired, +# and the resulting value put to the image. + +procedure nh_renamefield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +int goahead, nl +pointer sp, ip, oldval, newval, defval, o + +bool streq() +pointer evexpr() +extern he_getop() +int getline(), imaccf(), strldxs(), locpr() +errchk evexpr, getline, imaccf, he_gval + +begin + call smark (sp) + call salloc (oldval, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + call salloc (defval, SZ_LINE, TY_CHAR) + + # Verify that the named field exists before going any further. + if (field[1] != '$') + if (imaccf (im, field) == NO) { + call eprintf ("parameter %s,%s not found\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # Get the old value. + call he_gval (im, image, field, Memc[oldval], SZ_LINE) + + # Evaluate the expression. Encode the result operand as a string. + # If the expression is not parenthesized, assume that is is already + # a string literal. + + if (valexpr[1] == '(') { + o = evexpr (valexpr, locpr (he_getop), 0) + call he_encodeop (o, Memc[newval], SZ_LINE) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } else + call strcpy (valexpr, Memc[newval], SZ_LINE) + call strupr (Memc[newval]) + + if (verify == YES) { + # Query for new value and edit the field. If the response is a + # blank line, use the default new value. If the response is "$" + # or EOF, do not change the value of the parameter. + + call strcpy (field, Memc[oldval], SZ_LINE) + if (streq (Memc[newval], ".")) + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + call strcpy (Memc[newval], Memc[defval], SZ_LINE) + call eprintf ("%s,%s (%s -> %s): ") + call pargstr (image) + call pargstr (field) + call pargstr (field) + call pargstr (Memc[newval]) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Do not skip leading whitespace; may be significant in a + # string literal. + + ip = newval + + # Do strip trailing newline since it is an artifact of getline. + nl = strldxs ("\n", Memc[ip]) + if (nl > 0) + Memc[ip+nl-1] = EOS + + # Decode user response. + if (Memc[ip] == '\\') { + ip = ip + 1 + goahead = YES + } else if (streq(Memc[ip],"n") || streq(Memc[ip],"no")) { + goahead = NO + } else if (streq(Memc[ip],"y") || streq(Memc[ip],"yes") || + Memc[ip] == EOS) { + call strcpy (Memc[defval], Memc[newval], SZ_LINE) + goahead = YES + } else { + if (ip > newval) + call strcpy (Memc[ip], Memc[newval], SZ_LINE) + goahead = YES + } + + # Edit field if so indicated. + if (goahead == YES && update == YES) + call nh_updatekey (im, image, field, Memc[newval], show) + + call flush (STDOUT) + } + + } else { + call strcpy (field, Memc[oldval], SZ_LINE) + if (update == YES) + call nh_updatekey (im, image, field, Memc[newval], show) + } + if (update == NO && show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call pargstr (field) + call pargstr (Memc[newval]) + } + + call sfree (sp) +end + + +# NH_INITFIELD -- Add a new field to the indicated image. If the field already +# existsdo not set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure nh_initfield (im, image, field, valexpr, comment, pkey, baf, + verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +char comment[ARB] # keyword comment +char pkey[ARB] # +int baf +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imakbc, imastrc, imakic, imakrc + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + + if (imaccf (im, field) == YES) { + call eprintf ("parameter %s,%s already exists\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, strlen(valexpr), TY_CHAR) + call strcpy (valexpr, O_VALC(o), ARB) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + + if (update == YES) { + switch (O_TYPE(o)) { + case TY_BOOL: + if (pkey[1] != EOS && baf != 0) + call imakbci (im, field, O_VALB(o), comment, pkey, baf) + else + call imakbc (im, field, O_VALB(o), comment) + case TY_CHAR: + if (pkey[1] != EOS && baf != 0) + call imastrci (im, field, O_VALC(o), comment, pkey, baf) + else + call imastrc (im, field, O_VALC(o), comment) + case TY_INT: + if (pkey[1] != EOS && baf != 0) + call imakici (im, field, O_VALI(o), comment, pkey, baf) + else + call imakic (im, field, O_VALI(o), comment) + case TY_REAL: + if (pkey[1] != EOS && baf != 0) + call imakrci (im, field, O_VALR(o), comment, pkey, baf) + else + call imakrc (im, field, O_VALR(o), comment) + default: + call error (1, "unknown expression datatype") + } + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s / %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + call pargstr(comment) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# NH_ADDFIELD -- Add a new field to the indicated image. If the field already +# exists, merely set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure nh_addfield (im, image, field, valexpr, comment, pkey, baf, + verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +char comment[ARB] # keyword comment +char pkey[ARB] # pivot keyword name +int baf # either BEFORE or AFTER value +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +bool streq() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imakbc, imastrc, imakic, imakrc + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + if (!streq(field, "comment") && !streq(field, "history")) { + if (imaccf (im, field) == YES) { + call nh_editfield (im, image, field, valexpr, comment, + verify, show, update) + call sfree (sp) + return + } + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, max(1,strlen(valexpr)), TY_CHAR) + call strcpy (valexpr, O_VALC(o), SZ_LINE) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + if (update == YES) { + switch (O_TYPE(o)) { + case TY_BOOL: + if (pkey[1] != EOS && baf != 0) + call imakbci (im, field, O_VALB(o), comment, pkey, baf) + else + call imakbc (im, field, O_VALB(o), comment) + case TY_CHAR: + if (streq(field, "comment") || + streq(field, "history") || + streq(field, "add_textf") || + streq(field, "add_blank")) { + if (streq(field, "add_textf")) { + call imputextf (im, O_VALC(o), pkey, baf) + } else { + call imphis (im, field, O_VALC(o), pkey, baf) + } + } else if (pkey[1] != EOS && baf != 0) { + call imastrci (im, field, O_VALC(o), comment, pkey, baf) + } else { + call imastrc (im, field, O_VALC(o), comment) + } + case TY_INT: + if (pkey[1] != EOS && baf != 0) + call imakici (im, field, O_VALI(o), comment, pkey, baf) + else + call imakic (im, field, O_VALI(o), comment) + case TY_REAL: + if (pkey[1] != EOS && baf != 0) + call imakrci (im, field, O_VALR(o), comment, pkey, baf) + else + call imakrc (im, field, O_VALR(o), comment) + default: + call error (1, "unknown expression datatype") + } + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s / %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + call pargstr(comment) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# NH_DELETEFIELD -- Delete a field from the indicated image. If the field does +# not exist, print a warning message. + +procedure nh_deletefield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # not used +int verify # verify deletion interactively +int show # print record of edit +int update # enable updating of the image + +pointer sp, ip, newval +int getline(), imaccf() + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + if (imaccf (im, field) == NO) { + call eprintf ("nonexistent field %s,%s\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + if (verify == YES) { + # Delete pending verification. + + call eprintf ("delete %s,%s ? (yes): ") + call pargstr (image) + call pargstr (field) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Strip leading whitespace and trailing newline. + for (ip=newval; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == 'y') { + call imdelf (im, field) + if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } + } + } + + } else { + # Delete without verification. + + if (update == YES) { + iferr (call imdelf (im, field)) + call erract (EA_WARN) + else if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } else if (show == YES) + call printf ("%s,%s deleted, no update\n") + call pargstr (image) + call pargstr (field) + } + } + + call sfree (sp) +end + + +# NH_UPDATEFIELD -- Update the value of an image header field. + +procedure nh_updatefield (im, image, field, oldval, newval, oldcomm, + newcomm, show) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field name +char oldval[ARB] # old value, encoded as a string +char newval[ARB] # new value, encoded as a string +char oldcomm[ARB] # old keyword comment +char newcomm[ARB] # new keyword comment +int show # print record of update + +begin + iferr (call impstrc (im, field, newval, newcomm)) { + call eprintf ("cannot update %s,%s\n") + call pargstr (image) + call pargstr (field) + return + } + if (show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call nh_pargstrc (oldval, oldcomm) + call nh_pargstrc (newval, newcomm) + + } +end + + +# NH_UPDATEKEY -- Update the image header field. + +procedure nh_updatekey (im, image, field, newkey, show) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field name +char newkey[ARB] # new key +int show # print record of update + +begin + iferr (call imrenf (im, field, newkey)) { + call eprintf ("cannot update %s,%s\n") + call pargstr (image) + call pargstr (field) + return + } + if (show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call pargstr (field) + call pargstr (newkey) + + } +end + + +# NH_CPSTR -- Copy a string to a header record with optional comment. + +procedure nh_cpstr (str, outbuf) + +char str[ARB] # string to be printed +char outbuf[ARB] # comment string to be printed + +int ip +bool quoteit +pointer sp, op, buf + +begin + + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + op = buf + Memc[op] = '"' + op = op + 1 + + # Copy string to scratch buffer, enclosed in quotes. Check for + # embedded whitespace. + + quoteit = false + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_WHITE(str[ip])) { # detect whitespace + quoteit = true + Memc[op] = str[ip] + } else if (str[ip] == '\n') { # prettyprint newlines + Memc[op] = '\\' + op = op + 1 + Memc[op] = 'n' + } else # normal characters + Memc[op] = str[ip] + + if (ip < SZ_LINE) + op = op + 1 + } + + # If whitespace was seen pass the quoted string, otherwise pass the + # original input string. + + if (quoteit) { + Memc[op] = '"' + op = op + 1 + Memc[op] = EOS + call strcpy (Memc[buf], outbuf, SZ_LINE) + } else + call strcpy (str, outbuf, SZ_LINE) + + call sfree (sp) +end + + +# NH_PARGSTRC -- Pass a string to a printf statement plus the comment string. + procedure nh_pargstrc (str, comment) + +char str[ARB] # string to be printed +char comment[ARB] # comment string to be printed + +pointer sp, buf + +begin + + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call nh_cpstr (str, Memc[buf]) + + if (comment[1] != EOS) { + call strcat (" / ", Memc[buf], SZ_LINE) + call strcat (comment, Memc[buf], SZ_LINE) + } + + call pargstr (Memc[buf]) + + call sfree (sp) +end + + +# HE_GETPARS -- get the cl parameters for this task + +procedure he_getpars (operation, fields, valexpr, comment, + pivot, baf, update, verify, show) + +int operation +pointer fields # template listing fields to be processed +pointer valexpr # the value expression (if op=edit|add) +char comment[ARB] +char pivot[ARB] +int baf +int update +int verify +int show +bool clgetb(), streq() + +pointer ip +int btoi() + +begin + # Set switches. + operation = OP_EDIT + if (clgetb ("add")) + operation = OP_ADD + else if (clgetb ("addonly")) + operation = OP_INIT + else if (clgetb ("delete")) + operation = OP_DELETE + else if (clgetb ("rename")) + operation = OP_RENAME + + # If fields is NULL then this will be done in a command file. + if (fields != NULL) { + + # Get list of fields to be edited, added, or deleted. + call clgstr ("fields", Memc[fields], SZ_LINE) + for (ip=fields; IS_WHITE (Memc[ip]); ip=ip+1) + ; + call strcpy (Memc[ip], Memc[fields], SZ_LINE) + + # Set value expression. + Memc[valexpr] = EOS + if (operation != OP_DELETE) { + call clgstr ("value", Memc[valexpr], SZ_LINE) + if (operation != OP_RENAME) + call clgstr ("comment", comment, SZ_LINE) + + # Justify value + for (ip=valexpr; IS_WHITE (Memc[ip]); ip=ip+1) + ; + call strcpy (Memc[ip], Memc[valexpr], SZ_LINE) + ip = valexpr + while (Memc[ip] != EOS) + ip = ip + 1 + while (ip > valexpr && IS_WHITE (Memc[ip-1])) + ip = ip - 1 + Memc[ip] = EOS + } + + # If only printing results ignore the RENAME flag. + if (operation == OP_RENAME && streq (Memc[valexpr], ".")) { + operation = OP_EDIT + call strcpy (".", comment, SZ_LINE) + } + + } else { + Memc[valexpr] = EOS + comment[1] = EOS + } + + + # Get switches. If the expression value is ".", meaning print value + # rather than edit, then we do not use the switches. + + if (operation == OP_EDIT && streq (Memc[valexpr], ".") && + streq (comment, ".")) { + update = NO + verify = NO + show = NO + } else { + update = btoi (clgetb ("update")) + verify = btoi (clgetb ("verify")) + show = btoi (clgetb ("show")) + call clgstr ("after", pivot, SZ_LINE) + if (pivot[1] != EOS) + baf = AFTER + if (pivot[1] == EOS) { + call clgstr ("before", pivot, SZ_LINE) + if (pivot[1] != EOS) + baf = BEFORE + } + } +end + + +# NH_SETPAR -- Set a parameter. + +procedure nh_setpar (operation, dp_oper, dp_update, dp_verify, dp_show, + update, verify, show) +int operation +int dp_oper +int dp_update +int dp_verify +int dp_show +int update +int verify +int show + +begin + # If the value is positive then the parameter has been set + # in the command line. + + if (operation == OP_DEFPAR) + operation = dp_oper + if (update == -1) + update = dp_update + if (verify == -1) + verify = dp_verify + if (show == -1) + show = dp_show +end diff --git a/pkg/images/imutil/src/t_chpix.x b/pkg/images/imutil/src/t_chpix.x new file mode 100644 index 00000000..13c35cc3 --- /dev/null +++ b/pkg/images/imutil/src/t_chpix.x @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <fset.h> + +# T_CHPIXTYPE -- Change the pixel type of a list of images from the specified +# old pixel type to the new pixel type. The input images to be converted can +# be slected by pixel type. Conversion from one pixel type to another is +# direct and may involve loss of precision and dynamic range. Mapping of +# floating point numbers to integer numbers is done by truncation. + + +define CHP_ALL 1 # All types +define CHP_USHORT 2 # Unsigned short integer +define CHP_SHORT 3 # Short integers +define CHP_INT 4 # Integers +define CHP_LONG 5 # Long integers +define CHP_REAL 6 # Reals +define CHP_DOUBLE 7 # Doubles +define CHP_COMPLEX 8 # Complex + +define CHP_TYSTR "|all|ushort|short|int|long|real|double|complex|" + +procedure t_chpixtype() + +pointer imtlist1 # Input image list +pointer imtlist2 # Output image list + +pointer image1 # Input image +pointer image2 # Output image +pointer imtemp # Temporary file + +int list1, list2, intype, outtype, verbose +pointer im1, im2, sp, instr, outstr, imstr +bool clgetb() +int imtopen(), imtgetim(), imtlen(), clgwrd(), chp_gettype(), btoi() +pointer immap() + +errchk xt_mkimtemp, immap, imunmap, xt_delimtemp, chp_pixtype + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary space. + call smark (sp) + call salloc (imtlist1, SZ_FNAME, TY_CHAR) + call salloc (imtlist2, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (instr, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call salloc (imstr, SZ_LINE, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the input and output pixel types. + intype = clgwrd ("oldpixtype", Memc[instr], SZ_LINE, CHP_TYSTR) + outtype = clgwrd ("newpixtype", Memc[outstr], SZ_LINE, CHP_TYSTR) + verbose = btoi (clgetb ("verbose")) + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Loop over the set of input and output images + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + iferr { + + # Open the input and output images. + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im1 = immap (Memc[image1], READ_ONLY, 0) + if (intype == CHP_ALL || IM_PIXTYPE(im1) == chp_gettype(intype)) + im2 = immap (Memc[image2], NEW_COPY, im1) + else + im2 = NULL + + # Change the pixel type. + call chp_enctype (IM_PIXTYPE(im1), Memc[imstr], SZ_LINE) + if (im2 == NULL) { + if (verbose == YES) { + call printf ("Cannot change Image: %s (%s) -> ") + call pargstr (Memc[image1]) + call pargstr (Memc[imstr]) + call printf ("Image: %s (%s)\n") + call pargstr (Memc[imtemp]) + call pargstr (Memc[outstr]) + } + } else { + if (verbose == YES) { + call printf ("Image: %s (%s) -> Image: %s (%s)\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imstr]) + call pargstr (Memc[imtemp]) + call pargstr (Memc[outstr]) + } + call chp_pixtype (im1, im2, chp_gettype (outtype)) + } + + # Close up the input and output images. + call imunmap (im1) + if (im2 != NULL) { + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + } then { + call eprintf ("Error converting %s (%s) -> (%s)\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imstr]) + call pargstr (Memc[outstr]) + call erract (EA_WARN) + } + } + + call imtclose (list1) + call imtclose (list2) + + call sfree (sp) +end + + +# CHP_PIXTYPE -- Change pixel types using line sequential image i/o. + +procedure chp_pixtype (im1, im2, outtype) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +int outtype # output pixel type + +int ncols +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() + +errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx +errchk impnls, impnli, impnll, impnlr, impnld, impnlx + +begin + ncols = IM_LEN(im1, 1) + + IM_PIXTYPE(im2) = outtype + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + switch (outtype) { + case TY_USHORT: + while (impnll(im2,buf2,v2) != EOF && imgnll(im1,buf1,v1) != EOF) + call amovl (Meml[buf1], Meml[buf2], ncols) + case TY_SHORT: + while (impnls(im2,buf2,v2) != EOF && imgnls(im1,buf1,v1) != EOF) + call amovs (Mems[buf1], Mems[buf2], ncols) + case TY_INT: + while (impnli(im2,buf2,v2) != EOF && imgnli(im1,buf1,v1) != EOF) + call amovi (Memi[buf1], Memi[buf2], ncols) + case TY_LONG: + while (impnll(im2,buf2,v2) != EOF && imgnll(im1,buf1,v1) != EOF) + call amovl (Meml[buf1], Meml[buf2], ncols) + case TY_REAL: + while (impnlr(im2,buf2,v2) != EOF && imgnlr(im1,buf1,v1) != EOF) + call amovr (Memr[buf1], Memr[buf2], ncols) + case TY_DOUBLE: + while (impnld(im2,buf2,v2) != EOF && imgnld(im1,buf1,v1) != EOF) + call amovd (Memd[buf1], Memd[buf2], ncols) + case TY_COMPLEX: + while (impnlx(im2,buf2,v2) != EOF && imgnlx(im1,buf1,v1) != EOF) + call amovx (Memx[buf1], Memx[buf2], ncols) + } + + call imflush (im2) +end + + +# CHP_GETTYPE -- Get the the image pixel type. + +int procedure chp_gettype (intype) + +int intype # input pixel type + +begin + switch (intype) { + case CHP_USHORT: + return (TY_USHORT) + case CHP_SHORT: + return (TY_SHORT) + case CHP_INT: + return (TY_INT) + case CHP_LONG: + return (TY_LONG) + case CHP_REAL: + return (TY_REAL) + case CHP_DOUBLE: + return (TY_DOUBLE) + case CHP_COMPLEX: + return (TY_COMPLEX) + default: + return (ERR) + } +end + + +# CHP_ENCTYPE -- Encode the pixel type string. + +procedure chp_enctype (pixtype, str, maxch) + +int pixtype # pixel type +char str[ARB] # string for encoding pixel type +int maxch # maximum characters + +begin + switch (pixtype) { + case TY_USHORT: + call strcpy ("ushort", str, maxch) + case TY_SHORT: + call strcpy ("short", str, maxch) + case TY_INT: + call strcpy ("int", str, maxch) + case TY_LONG: + call strcpy ("long", str, maxch) + case TY_REAL: + call strcpy ("real", str, maxch) + case TY_DOUBLE: + call strcpy ("double", str, maxch) + case TY_COMPLEX: + call strcpy ("complex", str, maxch) + } +end diff --git a/pkg/images/imutil/src/t_imarith.x b/pkg/images/imutil/src/t_imarith.x new file mode 100644 index 00000000..6d5f6105 --- /dev/null +++ b/pkg/images/imutil/src/t_imarith.x @@ -0,0 +1,489 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <error.h> +include <lexnum.h> + +define ADD 1 # Opcodes. +define SUB 2 +define MUL 3 +define DIV 4 +define MIN 5 +define MAX 6 + +# T_IMARITH -- Simple image arithmetic. +# +# For each pixel in each image compute: +# +# operand1 op operand2 = result +# +# Do the operations as efficiently as possible. Allow operand1 or operand2 +# to be a constant. Allow resultant image to have the same name as an +# operand image. Allow lists for the operands and the results. +# Allow one of the operands to have extra dimensions but require that the +# common dimensions are of the same length. + +procedure t_imarith () + +int list1 # Operand1 list +int list2 # Operand2 list +int list3 # Result list +int op # Operator +bool verbose # Verbose option +bool noact # Noact option +double c1 # Constant for operand1 +double c2 # Constant for operand2 +double divzero # Zero divide replacement +int pixtype # Output pixel datatype +int calctype # Datatype for calculations + +int i, j, pixtype1, pixtype2 +short sc1, sc2, sdz +int hlist +double dval1, dval2 +pointer im1, im2, im3 +pointer sp, operand1, operand2, result, imtemp +pointer opstr, dtstr, field, title, hparams + +int imtopenp(), imtgetim(), imtlen(), imofnlu(), imgnfn() +double clgetd(), imgetd() +bool clgetb(), streq() +int clgwrd() +int gctod(), lexnum() +pointer immap() +errchk immap, imgetd, imputd + +begin + # Allocate memory for strings. + call smark (sp) + call salloc (operand1, SZ_FNAME, TY_CHAR) + call salloc (operand2, SZ_FNAME, TY_CHAR) + call salloc (result, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (opstr, SZ_FNAME, TY_CHAR) + call salloc (dtstr, SZ_FNAME, TY_CHAR) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_IMTITLE, TY_CHAR) + call salloc (hparams, SZ_LINE, TY_CHAR) + + # Get the operands and the operator. + list1 = imtopenp ("operand1") + op = clgwrd ("op", Memc[opstr], SZ_FNAME, ",+,-,*,/,min,max,") + list2 = imtopenp ("operand2") + list3 = imtopenp ("result") + + # Get the rest of the options. + call clgstr ("hparams", Memc[hparams], SZ_LINE) + verbose = clgetb ("verbose") + noact = clgetb ("noact") + if (op == DIV) + divzero = clgetd ("divzero") + + # Check the number of elements. + if (((imtlen (list1) != 1) && (imtlen (list1) != imtlen (list3))) || + ((imtlen (list2) != 1) && (imtlen (list2) != imtlen (list3)))) { + call imtclose (list1) + call imtclose (list2) + call imtclose (list3) + call error (1, "Wrong number of elements in the operand lists") + } + + # Do each operation. + while (imtgetim (list3, Memc[result], SZ_FNAME) != EOF) { + if (imtgetim (list1, Memc[imtemp], SZ_FNAME) != EOF) + call strcpy (Memc[imtemp], Memc[operand1], SZ_FNAME) + if (imtgetim (list2, Memc[imtemp], SZ_FNAME) != EOF) + call strcpy (Memc[imtemp], Memc[operand2], SZ_FNAME) + + # Image sections in the output are not allowed. + call imgsection (Memc[result], Memc[field], SZ_FNAME) + if (Memc[field] != EOS) { + call eprintf ( + "imarith: image sections in the output are not allowed (%s)\n") + call pargstr (Memc[result]) + next + } + + # To allow purely numeric file names first test if the operand + # is a file. If it is not then attempt to interpret the operand + # as a numerical constant. Otherwise it is an error. + iferr { + im1 = immap (Memc[operand1], READ_ONLY, 0) + pixtype1 = IM_PIXTYPE(im1) + } then { + i = 1 + j = gctod (Memc[operand1], i, c1) + if ((Memc[operand1+i-1]!=EOS) && (Memc[operand1+i-1]!=' ')) { + call eprintf ("%s is not an image or a number\n") + call pargstr (Memc[operand1]) + next + } + + i = 1 + pixtype1 = lexnum (Memc[operand1], i, j) + switch (pixtype1) { + case LEX_REAL: + pixtype1 = TY_REAL + default: + pixtype1 = TY_SHORT + } + im1 = NULL + } + + iferr { + im2 = immap (Memc[operand2], READ_ONLY, 0) + pixtype2 = IM_PIXTYPE(im2) + } then { + i = 1 + j = gctod (Memc[operand2], i, c2) + if ((Memc[operand2+i-1]!=EOS) && (Memc[operand2+i-1]!=' ')) { + call eprintf ("%s is not an image or a number\n") + call pargstr (Memc[operand2]) + if (im1 != NULL) + call imunmap (im1) + next + } + + i = 1 + pixtype2 = lexnum (Memc[operand2], i, j) + switch (pixtype2) { + case LEX_REAL: + pixtype2 = TY_REAL + default: + pixtype2 = TY_SHORT + } + im2 = NULL + } + + # Determine the output pixel datatype and calculation datatype. + call ima_set (pixtype1, pixtype2, op, pixtype, calctype) + + # If verbose or noact print the operation. + if (verbose || noact) { + call printf ("IMARITH:\n Operation = %s\n") + call pargstr (Memc[opstr]) + call printf (" Operand1 = %s\n Operand2 = %s\n") + call pargstr (Memc[operand1]) + call pargstr (Memc[operand2]) + call printf (" Result = %s\n Result pixel type = %s\n") + call pargstr (Memc[result]) + call dtstring (pixtype, Memc[dtstr], SZ_FNAME) + call pargstr (Memc[dtstr]) + call printf (" Calculation type = %s\n") + call dtstring (calctype, Memc[dtstr], SZ_FNAME) + call pargstr (Memc[dtstr]) + if (op == DIV) { + call printf ( + " Replacement value for division by zero = %g\n") + call pargd (divzero) + } + } + + # Do the operation if the no act switch is not set. + if (!noact) { + # Check the two operands have the same dimension lengths + # over the same dimensions. + if ((im1 != NULL) && (im2 != NULL)) { + j = OK + do i = 1, min (IM_NDIM (im1), IM_NDIM (im2)) + if (IM_LEN (im1, i) != IM_LEN (im2, i)) + j = ERR + if (j == ERR) { + call imunmap (im1) + call imunmap (im2) + call eprintf ( + "Input images have different dimensions\n") + next + } + } + + # Create a temporary output image as a copy of one of the + # operand images (the one with the highest dimension). + # This allows the resultant image to have + # the same name as one of the operand images. + if ((im1 != NULL) && (im2 != NULL)) { + call xt_mkimtemp (Memc[operand1], Memc[result], + Memc[imtemp], SZ_FNAME) + if (streq (Memc[result], Memc[imtemp])) + call xt_mkimtemp (Memc[operand2], Memc[result], + Memc[imtemp], SZ_FNAME) + if (IM_NDIM(im1) >= IM_NDIM(im2)) + im3 = immap (Memc[result], NEW_COPY, im1) + else + im3 = immap (Memc[result], NEW_COPY, im2) + } else if (im1 != NULL) { + call xt_mkimtemp (Memc[operand1], Memc[result], + Memc[imtemp], SZ_FNAME) + im3 = immap (Memc[result], NEW_COPY, im1) + } else if (im2 != NULL) { + call xt_mkimtemp (Memc[operand2], Memc[result], + Memc[imtemp], SZ_FNAME) + im3 = immap (Memc[result], NEW_COPY, im2) + } else + call error (0, "No operand images") + + # Set the result image title and pixel datatype. + call clgstr ("title", Memc[title], SZ_IMTITLE) + if (Memc[title] != EOS) + call strcpy (Memc[title], IM_TITLE (im3), SZ_IMTITLE) + IM_PIXTYPE (im3) = pixtype + + # Call the appropriate procedure to do the arithmetic + # efficiently. + switch (calctype) { + case TY_SHORT: + sc1 = c1 + sc2 = c2 + switch (op) { + case ADD: + call ima_adds (im1, im2, im3, sc1, sc2) + case SUB: + call ima_subs (im1, im2, im3, sc1, sc2) + case MUL: + call ima_muls (im1, im2, im3, sc1, sc2) + case DIV: + sdz = divzero + call ima_divs (im1, im2, im3, sc1, sc2, sdz) + case MIN: + call ima_mins (im1, im2, im3, sc1, sc2) + case MAX: + call ima_maxs (im1, im2, im3, sc1, sc2) + } + case TY_INT: + switch (op) { + case ADD: + call ima_addi (im1, im2, im3, int (c1), int (c2)) + case SUB: + call ima_subi (im1, im2, im3, int (c1), int (c2)) + case MUL: + call ima_muli (im1, im2, im3, int (c1), int (c2)) + case DIV: + call ima_divi (im1, im2, im3, int (c1), int (c2), + int (divzero)) + case MIN: + call ima_mini (im1, im2, im3, int (c1), int (c2)) + case MAX: + call ima_maxi (im1, im2, im3, int (c1), int (c2)) + } + case TY_LONG: + switch (op) { + case ADD: + call ima_addl (im1, im2, im3, long (c1), long (c2)) + case SUB: + call ima_subl (im1, im2, im3, long (c1), long (c2)) + case MUL: + call ima_mull (im1, im2, im3, long (c1), long (c2)) + case DIV: + call ima_divl (im1, im2, im3, long (c1), long (c2), + long (divzero)) + case MIN: + call ima_minl (im1, im2, im3, long (c1), long (c2)) + case MAX: + call ima_maxl (im1, im2, im3, long (c1), long (c2)) + } + case TY_REAL: + switch (op) { + case ADD: + call ima_addr (im1, im2, im3, real (c1), real (c2)) + case SUB: + call ima_subr (im1, im2, im3, real (c1), real (c2)) + case MUL: + call ima_mulr (im1, im2, im3, real (c1), real (c2)) + case DIV: + call ima_divr (im1, im2, im3, real (c1), real (c2), + real (divzero)) + case MIN: + call ima_minr (im1, im2, im3, real (c1), real (c2)) + case MAX: + call ima_maxr (im1, im2, im3, real (c1), real (c2)) + } + case TY_DOUBLE: + switch (op) { + case ADD: + call ima_addd (im1, im2, im3, double(c1), double(c2)) + case SUB: + call ima_subd (im1, im2, im3, double(c1), double(c2)) + case MUL: + call ima_muld (im1, im2, im3, double(c1), double(c2)) + case DIV: + call ima_divd (im1, im2, im3, double(c1), double(c2), + double(divzero)) + case MIN: + call ima_mind (im1, im2, im3, double(c1), double(c2)) + case MAX: + call ima_maxd (im1, im2, im3, double(c1), double(c2)) + } + } + + # Do the header parameters. + iferr { + ifnoerr (dval1 = imgetd (im3, "CCDMEAN")) + call imdelf (im3, "CCDMEAN") + + hlist = imofnlu (im3, Memc[hparams]) + while (imgnfn (hlist, Memc[field], SZ_FNAME) != EOF) { + if (im1 != NULL) + dval1 = imgetd (im1, Memc[field]) + else + dval1 = c1 + if (im2 != NULL) + dval2 = imgetd (im2, Memc[field]) + else + dval2 = c2 + + switch (op) { + case ADD: + call imputd (im3, Memc[field], dval1 + dval2) + case SUB: + call imputd (im3, Memc[field], dval1 - dval2) + case MUL: + call imputd (im3, Memc[field], dval1 * dval2) + case DIV: + if (dval2 == 0.) { + call eprintf ( + "WARNING: Division by zero in header keyword (%s)\n") + call pargstr (Memc[field]) + } else + call imputd (im3, Memc[field], dval1 / dval2) + case MIN: + call imputd (im3, Memc[field], min (dval1, dval2)) + case MAX: + call imputd (im3, Memc[field], max (dval1, dval2)) + } + } + call imcfnl (hlist) + } then + call erract (EA_WARN) + } + + # Unmap images and release the temporary output image. + if (im1 != NULL) + call imunmap (im1) + if (im2 != NULL) + call imunmap (im2) + if (!noact) { + call imunmap (im3) + call xt_delimtemp (Memc[result], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + call imtclose (list3) + call sfree (sp) +end + + +# IMA_SET -- Determine the output image pixel type and the calculation +# datatype. The default pixel types are based on the highest arithmetic +# precendence of the input images or constants. Division requires +# a minimum of real. + +procedure ima_set (pixtype1, pixtype2, op, pixtype, calctype) + +int pixtype1 # Pixel datatype of operand 1 +int pixtype2 # Pixel datatype of operand 2 +int pixtype # Pixel datatype of resultant image +int op # Operation +int calctype # Pixel datatype for calculations + +char line[1] +int max_type + +begin + # Determine maximum precedence datatype. + switch (pixtype1) { + case TY_SHORT: + if (op == DIV) + max_type = TY_REAL + else if (pixtype2 == TY_USHORT) + max_type = TY_LONG + else + max_type = pixtype2 + case TY_USHORT: + if (op == DIV) + max_type = TY_REAL + else if ((pixtype2 == TY_SHORT) || (pixtype2 == TY_USHORT)) + max_type = TY_LONG + else + max_type = pixtype2 + case TY_INT: + if (op == DIV) + max_type = TY_REAL + else if ((pixtype2 == TY_SHORT) || (pixtype2 == TY_USHORT)) + max_type = pixtype1 + else + max_type = pixtype2 + case TY_LONG: + if (op == DIV) + max_type = TY_REAL + else if ((pixtype2 == TY_SHORT) || (pixtype2 == TY_USHORT) || + (pixtype2 == TY_INT)) + max_type = pixtype1 + else + max_type = pixtype2 + case TY_REAL: + if (pixtype2 == TY_DOUBLE) + max_type = pixtype2 + else + max_type = pixtype1 + case TY_DOUBLE: + max_type = pixtype1 + } + + # Set calculation datatype. + call clgstr ("calctype", line, 1) + switch (line[1]) { + case '1': + if (pixtype1 == TY_USHORT) + calctype = TY_LONG + else + calctype = pixtype1 + case '2': + if (pixtype2 == TY_USHORT) + calctype = TY_LONG + else + calctype = pixtype2 + case EOS: + calctype = max_type + case 's': + calctype = TY_SHORT + case 'u': + calctype = TY_LONG + case 'i': + calctype = TY_INT + case 'l': + calctype = TY_LONG + case 'r': + calctype = TY_REAL + case 'd': + calctype = TY_DOUBLE + default: + call error (6, "Unrecognized datatype") + } + + # Set output pixel datatype. + call clgstr ("pixtype", line, 1) + switch (line[1]) { + case '1': + pixtype = pixtype1 + case '2': + pixtype = pixtype2 + case EOS: + pixtype = calctype + case 's': + pixtype = TY_SHORT + case 'u': + pixtype = TY_USHORT + case 'i': + pixtype = TY_INT + case 'l': + pixtype = TY_LONG + case 'r': + pixtype = TY_REAL + case 'd': + pixtype = TY_DOUBLE + default: + call error (6, "Unrecognized dataype") + } +end diff --git a/pkg/images/imutil/src/t_imaxes.x b/pkg/images/imutil/src/t_imaxes.x new file mode 100644 index 00000000..86d32fbd --- /dev/null +++ b/pkg/images/imutil/src/t_imaxes.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +define SZ_PARAM 5 + + +# IMAXES -- Determine the number and lengths of the axes of an image. +# Called from CL scripts. This routine will go away when we get DBIO +# access from the CL. + +procedure t_imaxes() + +char imname[SZ_FNAME] +char param[SZ_PARAM] +int i +pointer im +pointer immap() + +begin + call clgstr ("image", imname, SZ_FNAME) + im = immap (imname, READ_ONLY, 0) + + call clputi ("ndim", IM_NDIM(im)) + + do i = 1, IM_MAXDIM { + call sprintf (param, SZ_PARAM, "len%d") + call pargi (i) + call clputl (param, IM_LEN(im,i)) + } + + call imunmap (im) +end diff --git a/pkg/images/imutil/src/t_imcopy.x b/pkg/images/imutil/src/t_imcopy.x new file mode 100644 index 00000000..b79f0d9d --- /dev/null +++ b/pkg/images/imutil/src/t_imcopy.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMCOPY -- Copy image(s) +# +# The input images are given by an image template list. The output +# is either a matching list of images or a directory. +# The number of input images may be either one or match the number of output +# images. Image sections are allowed in the input images and are ignored +# in the output images. If the input and output image names are the same +# then the copy is performed to a temporary file which then replaces the +# input image. + +procedure t_imcopy() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +bool verbose # Print operations? + +char image1[SZ_PATHNAME] # Input image name +char image2[SZ_PATHNAME] # Output image name +char dirname1[SZ_PATHNAME] # Directory name +char dirname2[SZ_PATHNAME] # Directory name + +int list1, list2, root_len + +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb() + +begin + # Get input and output image template lists. + + call clgstr ("input", imtlist1, SZ_LINE) + call clgstr ("output", imtlist2, SZ_LINE) + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (imtlist2, dirname2, SZ_PATHNAME) > 0) { + list1 = imtopen (imtlist1) + while (imtgetim (list1, image1, SZ_PATHNAME) != EOF) { + + # Strip the image section first because fnldir recognizes it + # as part of a directory. Place the input image name + # without a directory or image section in string dirname1. + + call get_root (image1, image2, SZ_PATHNAME) + root_len = fnldir (image2, dirname1, SZ_PATHNAME) + call strcpy (image2[root_len + 1], dirname1, SZ_PATHNAME) + + call strcpy (dirname2, image2, SZ_PATHNAME) + call strcat (dirname1, image2, SZ_PATHNAME) + call img_imcopy (image1, image2, verbose) + } + call imtclose (list1) + + } else { + # Expand the input and output image lists. + + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same") + } + + # Do each set of input/output images. + + while ((imtgetim (list1, image1, SZ_PATHNAME) != EOF) && + (imtgetim (list2, image2, SZ_PATHNAME) != EOF)) { + + call img_imcopy (image1, image2, verbose) + } + + call imtclose (list1) + call imtclose (list2) + } +end diff --git a/pkg/images/imutil/src/t_imdivide.x b/pkg/images/imutil/src/t_imdivide.x new file mode 100644 index 00000000..510e49e5 --- /dev/null +++ b/pkg/images/imutil/src/t_imdivide.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# T_IMDIVIDE -- Image division with rescaling. + +# Options for rescaling. +define NORESC 1 # Do not scale resultant image +define MEAN 2 # Scale resultant mean to given value +define NUMER 3 # Scale resultant mean to mean of numerator + +procedure t_imdivide () + +char image1[SZ_FNAME] # Numerator image +char image2[SZ_FNAME] # Denominator image +char image3[SZ_FNAME] # Resultant image +char title[SZ_IMTITLE] # Resultant image title +int rescale # Option for rescaling +real constant # Replacement for zero divide +bool verbose # Verbose output? + +char str[SZ_LINE] +int i, npix, ntotal +real sum1, sum2, sum3, scale +long line1[IM_MAXDIM], line2[IM_MAXDIM], line3[IM_MAXDIM] +pointer im1, im2, im3, data1, data2, data3 + +int clgwrd(), imgnlr(), impnlr() +bool clgetb(), strne() +real clgetr(), asumr(), ima_efncr() +pointer immap() +extern ima_efncr + +common /imadcomr/ constant + +begin + # Access images and set parameters. + call clgstr ("numerator", image1, SZ_FNAME) + im1 = immap (image1, READ_ONLY, 0) + call clgstr ("denominator", image2, SZ_FNAME) + im2 = immap (image2, READ_ONLY, 0) + call clgstr ("resultant", image3, SZ_FNAME) + im3 = immap (image3, NEW_COPY, im1) + + if (IM_NDIM (im1) != IM_NDIM (im2)) + call error (0, "Input images have different dimensions") + do i = 1, IM_NDIM (im1) + if (IM_LEN (im1, i) != IM_LEN (im2, i)) + call error (0, "Input images have different sizes") + + call clgstr ("title", title, SZ_IMTITLE) + if (strne (title, "*")) + call strcpy (title, IM_TITLE(im3), SZ_IMTITLE) + IM_PIXTYPE(im3) = TY_REAL + + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Initialize. + npix = IM_LEN(im1, 1) + ntotal = 0 + sum1 = 0. + sum2 = 0. + sum3 = 0. + call amovkl (long(1), line1, IM_MAXDIM) + call amovkl (long(1), line2, IM_MAXDIM) + call amovkl (long(1), line3, IM_MAXDIM) + + # Loop through the images doing the division. + # Accumulate the sums for mean values. + while (impnlr (im3, data3, line3) != EOF) { + i = imgnlr (im1, data1, line1) + i = imgnlr (im2, data2, line2) + call advzr (Memr[data1], Memr[data2], Memr[data3], npix, ima_efncr) + sum1 = sum1 + asumr (Memr[data1], npix) + sum2 = sum2 + asumr (Memr[data2], npix) + sum3 = sum3 + asumr (Memr[data3], npix) + ntotal = ntotal + npix + } + sum1 = sum1 / ntotal + sum2 = sum2 / ntotal + sum3 = sum3 / ntotal + + # Close the images. + call imunmap (im1) + call imunmap (im2) + call imunmap (im3) + + # Print image means if verbose. + if (verbose) { + call printf ("Task imdivide:\n") + call printf (" %s: Mean = %g\n") + call pargstr (image1) + call pargr (sum1) + call printf (" %s: Mean = %g\n") + call pargstr (image2) + call pargr (sum2) + call printf (" %s: Mean = %g\n") + call pargstr (image3) + call pargr (sum3) + } + + # Determine resultant image rescaling. + rescale = clgwrd ("rescale", str, SZ_LINE, ",norescale,mean,numerator,") + switch (rescale) { + case NORESC: + return + case MEAN: + scale = clgetr ("mean") / sum3 + case NUMER: + scale = sum1 / sum3 + } + + if(verbose) { + call printf (" %s: Scale = %g\n") + call pargstr (image3) + call pargr (scale) + } + + # Open image read_write and initialize line counters. + im1 = immap (image3, READ_WRITE, 0) + call amovkl (long(1), line1, IM_MAXDIM) + call amovkl (long(1), line2, IM_MAXDIM) + + # Loop through the image rescaling the image lines. + while (imgnlr (im1, data1, line1) != EOF) { + i = impnlr (im1, data2, line2) + call amulkr (Memr[data1], scale, Memr[data2], npix) + } + + call imunmap (im1) +end diff --git a/pkg/images/imutil/src/t_imjoin.x b/pkg/images/imutil/src/t_imjoin.x new file mode 100644 index 00000000..810c0a2d --- /dev/null +++ b/pkg/images/imutil/src/t_imjoin.x @@ -0,0 +1,272 @@ +include <imhdr.h> +include <error.h> +include <syserr.h> + +define DEFBUFSIZE 65536 # default IMIO buffer size +define FUDGE 0.8 # fudge factor + + +# T_IMJOIN -- Produce a single output image from a list of input images +# by joining the images in the input image list along a single dimension. +# The set of input images need have the same number of dimensions and +# elements per dimension ONLY along the axes not being joined. +# The output pixel type will be converted to the highest precedence pixel +# type if not all the images do not have the same pixel type. + +procedure t_imjoin() + +int i, j, joindim, list, nimages, inpixtype, ndim, nelems[IM_MAXDIM] +int bufsize, maxsize, memory, oldsize, outpixtype, verbose +pointer sp, in, out, im, im1, input, output + +bool clgetb() +#char clgetc() +int imtopenp(), imtlen(), imtgetim(), clgeti(), btoi() +int getdatatype(), ij_tymax(), sizeof(), begmem(), errcode() +pointer immap() +errchk immap + +define retry_ 99 + +begin + # Allocate working space. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + + # Get the parameters. Note that clgetc no longer accepts a blank + # string as input so clgstr is used to fetch the pixtype parameter + # and input is used as the temporary holding variable. + list = imtopenp ("input") + call clgstr ("output", Memc[output], SZ_FNAME) + joindim = clgeti ("join_dimension") + #outpixtype = getdatatype (clgetc ("pixtype")) + call clgstr ("pixtype", Memc[input], SZ_FNAME) + outpixtype = getdatatype (Memc[input]) + verbose = btoi (clgetb ("verbose")) + + # Check to make sure that the input image list is not empty. + nimages = imtlen (list) + if (nimages == 0) { + call imtclose (list) + call sfree (sp) + call error (0, "The input image list is empty") + } else + call salloc (in, nimages, TY_POINTER) + + # Check the the join dimension is not too large. + if (joindim > IM_MAXDIM) + call error (0, + "The join dimension cannot be greater then the current IM_MAXDIM") + + bufsize = 0 + +retry_ + + # Map the input images. + nimages = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + nimages = nimages + 1 + Memi[in+nimages-1] = immap (Memc[input], READ_ONLY, 0) + } + + # Determine the dimensionality, size, and pixel type of the output + # image. Force the output image to have the same number of dimensions + # as the input images, with the following check even though the + # remainder of the code permits stacking the images into a higher + # dimension. + + im = Memi[in] + inpixtype = IM_PIXTYPE(im) + if (joindim > IM_NDIM(im)) { + call eprintf ( + "ERROR: For image %s ndim is %d max join dimension is %d\n") + call pargstr (IM_HDRFILE(im)) + call pargi (IM_NDIM(im)) + call pargi (IM_NDIM(im)) + call error (0, "The user-specified join dimension is too large") + } + ndim = max (IM_NDIM(im), joindim) + do j = 1, ndim { + if (j <= IM_NDIM(im)) + nelems[j] = IM_LEN(im,j) + else + nelems[j] = 1 + } + + # Make sure that all the input images have the same dimensionality, + # and that the length of each dimension is the same for all dimensions + # but the one being joined. + + do i = 2, nimages { + im1 = Memi[in+i-1] + if (IM_NDIM(im1) != IM_NDIM(im)) + call error (0, "The input images have different dimensions") + ndim = max (ndim, IM_NDIM(im1)) + do j = 1, ndim { + if (j > IM_NDIM(im1)) + nelems[j] = nelems[j] + 1 + else if (j == joindim) + nelems[j] = nelems[j] + IM_LEN(im1,j) + else if (IM_LEN(im1,j) != nelems[j]) + call error (0, + "The input images have unequal sizes in the non-join dimension") + } + inpixtype = ij_tymax (inpixtype, IM_PIXTYPE(im1)) + } + + # Open the output image and set its pixel data type, number of + # dimensions, and length of each of the dimensions. + + out = immap (Memc[output], NEW_COPY, Memi[in]) + if (outpixtype == ERR || outpixtype == TY_BOOL) + IM_PIXTYPE(out) = inpixtype + else + IM_PIXTYPE(out) = outpixtype + IM_NDIM(out) = ndim + do j = 1, ndim + IM_LEN(out,j) = nelems[j] + + if (bufsize == 0) { + + # Set initial IMIO buffer size based on the number of images + # and maximum amount of working memory available. The buffer + # size may be adjusted later if the task runs out of memory. + # The FUDGE factor is used to allow for the size of the + # program, memory allocator inefficiencies, and any other + # memory requirements besides IMIO. + + bufsize = 1 + do i = 1, IM_NDIM(out) + bufsize = bufsize * IM_LEN(out,i) + bufsize = bufsize * sizeof (inpixtype) + bufsize = min (bufsize, DEFBUFSIZE) + memory = begmem ((nimages + 1) * bufsize, oldsize, maxsize) + memory = min (memory, int (FUDGE * maxsize)) + bufsize = memory / (nimages + 1) + } + + # Join the images along the join dimension. If an out of memory error + # occurs close all images and files, divide the IMIO buffer size in + # half and try again. + + iferr { + switch (inpixtype) { + case TY_SHORT: + call imjoins (Memi[in], nimages, out, joindim, outpixtype) + case TY_INT: + call imjoini (Memi[in], nimages, out, joindim, outpixtype) + case TY_USHORT, TY_LONG: + call imjoinl (Memi[in], nimages, out, joindim, outpixtype) + case TY_REAL: + call imjoinr (Memi[in], nimages, out, joindim, outpixtype) + case TY_DOUBLE: + call imjoind (Memi[in], nimages, out, joindim, outpixtype) + case TY_COMPLEX: + call imjoinx (Memi[in], nimages, out, joindim, outpixtype) + } + } then { + switch (errcode()) { + case SYS_MFULL: + do j = 1, nimages + call imunmap (Memi[in+j-1]) + call imunmap (out) + call imdelete (Memc[output]) + call imtrew (list) + bufsize = bufsize / 2 + goto retry_ + default: + call erract (EA_ERROR) + } + } + + if (verbose == YES) + call ij_verbose (Memi[in], nimages, out, joindim) + + # Unmap all the images. + call imunmap (out) + do i = 1, nimages + call imunmap (Memi[in+i-1]) + + # Restore memory. + call sfree (sp) + call fixmem (oldsize) +end + + +define MAX_NTYPES 8 +define MAX_NPIXTYPES 7 + +# IJ_TYMAX -- Return the data type of highest precedence. + +int procedure ij_tymax (type1, type2) + +int type1, type2 # Input data types + +int i, j, order[MAX_NTYPES] +data order/TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE,TY_COMPLEX, + TY_REAL/ +begin + for (i=1; (i<=MAX_NPIXTYPES) && (type1!=order[i]); i=i+1) + ; + for (j=1; (j<=MAX_NPIXTYPES) && (type2!=order[j]); j=j+1) + ; + return (order[max(i,j)]) +end + + +# IJ_VERBOSE -- Print messages about the actions taken by IMJOIN. + +procedure ij_verbose (imptrs, nimages, outptr, joindim) + +pointer imptrs[ARB] # array of input image pointers +int nimages # the number of input images +pointer outptr # the output image pointer +int joindim # the join dimension + +int i, j, nindim, noutdim +long offset + +begin + noutdim = IM_NDIM(outptr) + offset = 1 + + do i = 1, nimages { + + nindim = IM_NDIM(imptrs[i]) + call printf ("Join: %s size: ") + call pargstr (IM_HDRFILE(imptrs[i])) + do j = 1, nindim { + if (j == nindim) + call printf ("%d -> ") + else + call printf ("%d X ") + call pargl (IM_LEN(imptrs[i],j)) + } + + call printf ("%s[") + call pargstr (IM_HDRFILE(outptr)) + do j = 1, noutdim { + if (j > nindim) { + call printf ("%d:%d") + call pargi (i) + call pargi (i) + } else if (j == joindim) { + call printf ("%d:%d") + call pargl (offset) + call pargl (offset + IM_LEN(imptrs[i],j)-1) + offset = offset + IM_LEN(imptrs[i],j) + } else { + call printf ("1:%d") + call pargl (IM_LEN(outptr,j)) + } + if (j != noutdim) + call printf (",") + else + call printf ("]") + } + + call printf ("\n") + + } +end diff --git a/pkg/images/imutil/src/t_imrename.x b/pkg/images/imutil/src/t_imrename.x new file mode 100644 index 00000000..25562044 --- /dev/null +++ b/pkg/images/imutil/src/t_imrename.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMRENAME -- Rename an image or list of images, or move a image or images +# to a new directory. Pixel files are moved to the current IMDIR. Moving +# an image to the same directory will move the pixel file if IMDIR has been +# changed since the image was created. + +procedure t_imrename() + +pointer sp, old_list, new_list +pointer old_name, new_name, old_dir, new_dir +bool verbose + +int list1, list2, root_len +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb() + +begin + call smark (sp) + call salloc (old_list, SZ_LINE, TY_CHAR) + call salloc (new_list, SZ_LINE, TY_CHAR) + call salloc (old_name, SZ_PATHNAME, TY_CHAR) + call salloc (new_name, SZ_PATHNAME, TY_CHAR) + call salloc (new_dir, SZ_PATHNAME, TY_CHAR) + call salloc (old_dir, SZ_PATHNAME, TY_CHAR) + + # Get input and output image template lists. + call clgstr ("oldnames", Memc[old_list], SZ_LINE) + call clgstr ("newnames", Memc[new_list], SZ_LINE) + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (Memc[new_list], Memc[new_dir], SZ_PATHNAME) > 0) { + list1 = imtopen (Memc[old_list]) + while (imtgetim (list1, Memc[old_name], SZ_PATHNAME) != EOF) { + + # Strip the image section first because fnldir recognizes it + # as part of a directory. Place the input image name + # without a directory or image section in string Memc[old_dir]. + + call get_root (Memc[old_name], Memc[new_name], SZ_PATHNAME) + root_len = fnldir (Memc[new_name], Memc[old_dir], SZ_PATHNAME) + call strcpy (Memc[new_name+root_len], Memc[old_dir],SZ_PATHNAME) + + call strcpy (Memc[new_dir], Memc[new_name], SZ_PATHNAME) + call strcat (Memc[old_dir], Memc[new_name], SZ_PATHNAME) + call img_rename (Memc[old_name], Memc[new_name], verbose) + } + call imtclose (list1) + + } else { + # Expand the input and output image lists. + list1 = imtopen (Memc[old_list]) + list2 = imtopen (Memc[new_list]) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Different number of old and new image names") + } + + # Do each set of input/output images. + while ((imtgetim (list1, Memc[old_name], SZ_PATHNAME) != EOF) && + (imtgetim (list2, Memc[new_name], SZ_PATHNAME) != EOF)) { + + call img_rename (Memc[old_name], Memc[new_name], verbose) + } + + call imtclose (list1) + call imtclose (list2) + } + + call sfree (sp) +end + + +# IMG_RENAME -- Rename an image, optionally printing a message to the STDOUT. + +procedure img_rename (old_name, new_name, verbose) + +char old_name[ARB] #I old image name +char new_name[ARB] #I new image name +bool verbose #I print message? + +begin + iferr (call imrename (old_name, new_name)) { + call eprintf ("Warning: cannot rename `%s' -> `%s'\n") + call pargstr (old_name) + call pargstr (new_name) + } else if (verbose) { + call printf ("`%s' -> `%s'\n") + call pargstr (old_name) + call pargstr (new_name) + call flush (STDOUT) + } +end diff --git a/pkg/images/imutil/src/t_imreplace.x b/pkg/images/imutil/src/t_imreplace.x new file mode 100644 index 00000000..2b8750ac --- /dev/null +++ b/pkg/images/imutil/src/t_imreplace.x @@ -0,0 +1,83 @@ +include <imhdr.h> + +# T_IMREP -- Replace pixels in a window with a constant. + +procedure t_imrep () + +char imtlist[SZ_LINE] # Images to be editted +real lower # Lower limit of window +real upper # Upper limit of window +real value # Replacement value +real radius # Radius +real img # Imaginary part for complex + +int list +char image[SZ_FNAME] +pointer im + +int imtopen(), imtgetim() +real clgetr() +pointer immap() + +begin + # Get image template list. + + call clgstr ("images", imtlist, SZ_LINE) + list = imtopen (imtlist) + + # Get the parameters. + + value = clgetr ("value") + img = clgetr ("imaginary") + lower = clgetr ("lower") + upper = clgetr ("upper") + radius = max (0., clgetr ("radius")) + + # Replace the pixels in each image. Optimize IMIO. + + while (imtgetim (list, image, SZ_FNAME) != EOF) { + + im = immap (image, READ_WRITE, 0) + + if (radius < 1.) { + switch (IM_PIXTYPE (im)) { + case TY_SHORT: + call imreps (im, lower, upper, value, img) + case TY_INT: + call imrepi (im, lower, upper, value, img) + case TY_USHORT, TY_LONG: + call imrepl (im, lower, upper, value, img) + case TY_REAL: + call imrepr (im, lower, upper, value, img) + case TY_DOUBLE: + call imrepd (im, lower, upper, value, img) + case TY_COMPLEX: + call imrepx (im, lower, upper, value, img) + default: + call error (0, "Unsupported image pixel datatype") + } + + } else { + switch (IM_PIXTYPE (im)) { + case TY_SHORT: + call imrreps (im, lower, upper, radius, value, img) + case TY_INT: + call imrrepi (im, lower, upper, radius, value, img) + case TY_USHORT, TY_LONG: + call imrrepl (im, lower, upper, radius, value, img) + case TY_REAL: + call imrrepr (im, lower, upper, radius, value, img) + case TY_DOUBLE: + call imrrepd (im, lower, upper, radius, value, img) + case TY_COMPLEX: + call imrrepx (im, lower, upper, radius, value, img) + default: + call error (0, "Unsupported image pixel datatype") + } + } + + call imunmap (im) + } + + call imtclose (list) +end diff --git a/pkg/images/imutil/src/t_imslice.x b/pkg/images/imutil/src/t_imslice.x new file mode 100644 index 00000000..6942ec05 --- /dev/null +++ b/pkg/images/imutil/src/t_imslice.x @@ -0,0 +1,472 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <ctype.h> +include <mwset.h> + +# T_IMSLICE -- Slice an input image into a list of output images equal in +# length to the length of the dimension to be sliced. The remaining +# dimensions are unchanged. For a 1 dimensionsal image this task is a null +# operation. + +procedure t_imslice() + +pointer imtlist1 # Input image list +pointer imtlist2 # Output image list +pointer image1 # Input image +pointer image2 # Output image +int sdim # Dimension to be sliced +int verbose # Verbose mode + +pointer sp +int list1, list2 + +bool clgetb() +int imtopen(), imtgetim(), imtlen(), btoi(), clgeti() +errchk sl_slice + +begin + call smark (sp) + call salloc (imtlist1, SZ_FNAME, TY_CHAR) + call salloc (imtlist2, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + sdim = clgeti ("slice_dimension") + verbose = btoi (clgetb ("verbose")) + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Loop over the set of input and output images + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) + call sl_imslice (Memc[image1], Memc[image2], sdim, verbose) + + call imtclose (list1) + call imtclose (list2) + + call sfree (sp) +end + + +# SL_IMSLICE -- Procedure to slice an n-dimensional image into a set +# of images with one fewer dimensions. A number is appendend to the +# output image name indicating which element of the n-th dimension the +# new image originated from. + +procedure sl_imslice (image1, image2, sdim, verbose) + +char image1[ARB] # input image +char image2[ARB] # output image +int sdim # slice dimension +int verbose # verbose mode + +int i, j, ndim, fdim, ncols, nlout, nimout, pdim +int axno[IM_MAXDIM], axval[IM_MAXDIM] +pointer sp, inname, outname, outsect, im1, im2, buf1, buf2, vim1, vim2 +pointer mw, vs, ve +real shifts[IM_MAXDIM] + +pointer immap(), mw_openim() +int mw_stati() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int imggss(), imggsi(), imggsl(), imggsr(), imggsd(), imggsx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +bool envgetb() + +errchk imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +errchk imggss(), imggsi(), imggsl(), imggsr(), imggsd(), imggsx() +errchk impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() + +begin + iferr (im1 = immap (image1, READ_ONLY, 0)) { + call erract (EA_WARN) + return + } + + ndim = IM_NDIM(im1) + + # Check that sdim is in range. + if (sdim > ndim) { + call printf ("Image %s has fewer than %d dimensions.\n") + call pargstr (image1) + call pargi (sdim) + call imunmap (im1) + return + } + + # Cannot slice 1D images. + if (ndim == 1) { + call printf ("Image %s is 1 dimensional.\n") + call pargstr (image1) + call imunmap (im1) + return + } + + # Cannot slice an image which is degnerate in slice dimension. + #if (IM_LEN(im1,sdim) == 1) { + #call printf ("Image %s is degenerate in the %d dimension.\n") + #call pargstr (image1) + #call pargi (sdim) + #call imunmap (im1) + #return + #} + + call smark (sp) + call salloc (inname, SZ_LINE, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (outsect, SZ_LINE, TY_CHAR) + + call salloc (vs, IM_MAXDIM, TY_LONG) + call salloc (ve, IM_MAXDIM, TY_LONG) + call salloc (vim1, IM_MAXDIM, TY_LONG) + call salloc (vim2, IM_MAXDIM, TY_LONG) + + # Compute the number of output images. and the number of columns + nimout = IM_LEN(im1, sdim) + + # Compute the number of lines and columns in the output image. + if (sdim == 1) { + fdim = 2 + ncols = IM_LEN(im1,2) + } else { + fdim = 1 + ncols = IM_LEN(im1,1) + } + nlout = 1 + do i = 1, sdim - 1 + nlout = nlout * IM_LEN(im1,i) + do i = sdim + 1, ndim + nlout = nlout * IM_LEN(im1,i) + nlout = nlout / ncols + + call amovkl (long(1), Meml[vim1], IM_MAXDIM) + do i = 1, nimout { + + # Construct the output image name. + call sprintf (Memc[outname], SZ_FNAME, "%s%03d") + call pargstr (image2) + call pargi (i) + + # Open the output image. + iferr (im2 = immap (Memc[outname], NEW_COPY, im1)) { + call erract (EA_WARN) + call imunmap (im1) + call sfree (sp) + return + } else { + IM_NDIM(im2) = ndim - 1 + do j = 1, sdim - 1 + IM_LEN(im2,j) = IM_LEN(im1,j) + do j = sdim + 1, IM_NDIM(im1) + IM_LEN(im2,j-1) = IM_LEN(im1,j) + } + + # Print messages on the screen. + if (verbose == YES) { + call sl_einsection (im1, i, sdim, Memc[inname], SZ_LINE) + call sl_esection (im2, Memc[outsect], SZ_LINE) + call printf ("Copied image %s %s -> %s %s\n") + call pargstr (image1) + call pargstr (Memc[inname]) + call pargstr (Memc[outname]) + call pargstr (Memc[outsect]) + call flush (STDOUT) + } + + # Initialize the v vectors for each new image. + if (sdim != ndim) { + do j = 1, ndim { + if (j == sdim) { + Meml[vs+j-1] = i + Meml[ve+j-1] = i + } else if (j == fdim) { + Meml[vs+j-1] = 1 + Meml[ve+j-1] = IM_LEN(im1,j) + } else { + Meml[vs+j-1] = 1 + Meml[ve+j-1] = 1 + } + } + } + + # Loop over the appropriate range of lines. + call amovkl (long(1), Meml[vim2], IM_MAXDIM) + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + if (sdim == ndim) { + do j = 1, nlout { + if (impnls (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnls (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovs (Mems[buf1], Mems[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnls (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggss (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovs (Mems[buf1], Mems[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_USHORT, TY_INT: + if (sdim == ndim) { + do j = 1, nlout { + if (impnli (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnli (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovi (Memi[buf1], Memi[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnli (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1= imggsi (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovi (Memi[buf1], Memi[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_LONG: + if (sdim == ndim) { + do j = 1, nlout { + if (impnll (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnll (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovl (Meml[buf1], Meml[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnll (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsl (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovl (Meml[buf1], Meml[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_REAL: + if (sdim == ndim) { + do j = 1, nlout { + if (impnlr (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnlr (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnlr (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsr (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovr (Memr[buf1], Memr[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), + fdim, sdim, ndim) + } + } + case TY_DOUBLE: + if (sdim == ndim) { + do j = 1, nlout { + if (impnld (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnld (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovd (Memd[buf1], Memd[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnld (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsd (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovd (Memd[buf1], Memd[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_COMPLEX: + if (sdim == ndim) { + do j = 1, nlout { + if (impnlx (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnlx (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovx (Memx[buf1], Memx[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnlx (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsx (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovx (Memx[buf1], Memx[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + } + + # Update the wcs. + if (! envgetb ("nowcs")) { + + # Open and shift the wcs. + mw = mw_openim (im1) + call aclrr (shifts, ndim) + shifts[sdim] = -(i - 1) + call mw_shift (mw, shifts, (2 ** ndim - 1)) + + # Get and reset the axis map. + pdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gaxmap (mw, axno, axval, pdim) + do j = 1, pdim { + if (axno[j] < sdim) { + next + } else if (axno[j] > sdim) { + axno[j] = axno[j] - 1 + } else { + axno[j] = 0 + axval[j] = i - 1 + } + } + call mw_saxmap (mw, axno, axval, pdim) + + call mw_savim (mw, im2) + call mw_close (mw) + } + + call imunmap (im2) + } + + + call imunmap (im1) + call sfree (sp) +end + + +# SL_LOOP -- Increment the vector V from VS to VE (nested do loops cannot +# be used because of the variable number of dimensions). + +procedure sl_loop (vs, ve, ldim, fdim, sdim, ndim) + +long vs[ndim] # vector of starting points +long ve[ndim] # vector of ending points +long ldim[ndim] # vector of dimension lengths +int fdim # first dimension +int sdim # slice dimension +int ndim # number of dimensions + +int dim + +begin + for (dim = fdim+1; dim <= ndim; dim = dim + 1) { + if (dim == sdim) + next + vs[dim] = vs[dim] + 1 + ve[dim] = vs[dim] + if (vs[dim] - ldim[dim] == 1) { + if (dim < ndim) { + vs[dim] = 1 + ve[dim] = 1 + } else + break + } else + break + } +end + + +# SL_EINSECTION -- Encode the dimensions of an image where the element of +# the slice dimension is fixed in section notation. + +procedure sl_einsection (im, el, sdim, section, maxch) + +pointer im # pointer to the image +int el # element of last dimension +int sdim # slice dimension +char section[ARB] # output section +int maxch # maximum number of characters in output section + +int i, op +int ltoc(), gstrcat() + +begin + op = 1 + section[1] = '[' + op = op + 1 + + # Encode dimensions up to the slice dimension. + for (i = 1; i <= sdim - 1 && op <= maxch; i = i + 1) { + op = op + ltoc (long(1), section[op], maxch) + op = op + gstrcat (":", section[op], maxch) + op = op + ltoc (IM_LEN(im,i), section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + } + + # Encode the slice dimension. + op = op + ltoc (el, section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + + # Encode dimensions above the slice dimension. + for (i = sdim + 1; i <= IM_NDIM(im); i = i + 1) { + op = op + ltoc (long(1), section[op], maxch) + op = op + gstrcat (":", section[op], maxch) + op = op + ltoc (IM_LEN(im,i), section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + } + + section[op-1] = ']' + section[op] = EOS +end + + +# SL_ESECTION -- Encode the dimensions of an image in section notation. + +procedure sl_esection (im, section, maxch) + +pointer im # pointer to the image +char section[ARB] # output section +int maxch # maximum number of characters in output section + +int i, op +int ltoc(), gstrcat() + +begin + op = 1 + section[1] = '[' + op = op + 1 + + for (i = 1; i <= IM_NDIM(im); i = i + 1) { + op = op + ltoc (long(1), section[op], maxch) + op = op + gstrcat (":", section[op], maxch) + op = op + ltoc (IM_LEN(im,i), section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + } + + section[op-1] = ']' + section[op] = EOS +end diff --git a/pkg/images/imutil/src/t_imstack.x b/pkg/images/imutil/src/t_imstack.x new file mode 100644 index 00000000..20fc1ac7 --- /dev/null +++ b/pkg/images/imutil/src/t_imstack.x @@ -0,0 +1,300 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mwset.h> + +define NTYPES 7 + + +# T_IMSTACK -- Stack images into a single image of higher dimension. + +procedure t_imstack () + +int i, j, npix, list, pdim, lmax, lindex +int axno[IM_MAXDIM], axval[IM_MAXDIM] +long line_in[IM_MAXDIM], line_out[IM_MAXDIM] +pointer sp, input, output, in, out, buf_in, buf_out, mwin, mwout + +bool envgetb() +int imtopenp(), imtgetim(), imtlen() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +int mw_stati() +pointer immap(), mw_open(), mw_openim() + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + + # Get the input images and the output image. + list = imtopenp ("images") + call clgstr ("output", Memc[output], SZ_FNAME) + + # Add each input image to the output image. + + i = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + + i = i + 1 + in = immap (Memc[input], READ_ONLY, 0) + + # For the first input image map the output image as a copy + # and increment the dimension. Set the output line counter. + + if (i == 1) { + out = immap (Memc[output], NEW_COPY, in) + call isk_new_image (out) + IM_NDIM(out) = IM_NDIM(out) + 1 + IM_LEN(out, IM_NDIM(out)) = imtlen (list) + npix = IM_LEN(out, 1) + call amovkl (long(1), line_out, IM_MAXDIM) + } + + # Check next input image for consistency with the output image. + if (IM_NDIM(in) != IM_NDIM(out) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(in) { + if (IM_LEN(in, j) != IM_LEN(out, j)) + call error (0, "Input images not consistent") + } + + # Copy the input lines from the image to the next lines of + # the output image. Switch on the output data type to optimize + # IMIO. + + call amovkl (long(1), line_in, IM_MAXDIM) + switch (IM_PIXTYPE (out)) { + case TY_SHORT: + while (imgnls (in, buf_in, line_in) != EOF) { + if (impnls (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovs (Mems[buf_in], Mems[buf_out], npix) + } + case TY_INT: + while (imgnli (in, buf_in, line_in) != EOF) { + if (impnli (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + case TY_USHORT, TY_LONG: + while (imgnll (in, buf_in, line_in) != EOF) { + if (impnll (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovl (Meml[buf_in], Meml[buf_out], npix) + } + case TY_REAL: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + case TY_DOUBLE: + while (imgnld (in, buf_in, line_in) != EOF) { + if (impnld (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovd (Memd[buf_in], Memd[buf_out], npix) + } + case TY_COMPLEX: + while (imgnlx (in, buf_in, line_in) != EOF) { + if (impnlx (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovx (Memx[buf_in], Memx[buf_out], npix) + } + default: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + } + + # Update the wcs. The output image will inherit the wcs of + # the first input image. The new axis will be assigned the + # identity transformation if wcsdim of the original image is + # less than the number of dimensions in the stacked image. + + if ((i == 1) && (! envgetb ("nowcs"))) { + mwin = mw_openim (in) + pdim = mw_stati (mwin, MW_NPHYSDIM) + call mw_gaxmap (mwin, axno, axval, pdim) + lmax = 0 + lindex = 0 + do j = 1, pdim { + if (axno[j] <= lmax) + next + lmax = axno[j] + lindex = j + } + if (lindex < pdim) { + axno[pdim] = lmax + 1 + axval[pdim] = 0 + call mw_saxmap (mwin, axno, axval, pdim) + call mw_saveim (mwin, out) + } else { + mwout = mw_open (NULL, pdim + 1) + call isk_wcs (mwin, mwout, IM_NDIM(out)) + call mw_saveim (mwout, out) + call mw_close (mwout) + } + call mw_close (mwin) + } + + call imunmap (in) + } + + # Finish up. + call imunmap (out) + call imtclose (list) + call sfree (sp) +end + + +# ISK_NEW_IMAGE -- Get a new image title and pixel type. +# +# The strings 'default' or '*' are recognized as defaulting to the original +# title or pixel datatype. + +procedure isk_new_image (im) + +pointer im # image descriptor + +pointer sp, lbuf +int i, type_codes[NTYPES] +bool strne() +int stridx() + +string types "suilrdx" +data type_codes /TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE, + TY_COMPLEX/ + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call clgstr ("title", Memc[lbuf], SZ_LINE) + if (strne (Memc[lbuf], "default") && strne (Memc[lbuf], "*")) + call strcpy (Memc[lbuf], IM_TITLE(im), SZ_IMTITLE) + + call clgstr ("pixtype", Memc[lbuf], SZ_LINE) + if (strne (Memc[lbuf], "default") && strne (Memc[lbuf], "*")) { + i = stridx (Memc[lbuf], types) + if (i != 0) + IM_PIXTYPE(im) = type_codes[i] + } + + call sfree (sp) +end + + +# ISK_WCS -- Update the wcs of the stacked image. + +procedure isk_wcs (mwin, mwout, ndim) + +pointer mwin # input wcs descriptor +pointer mwout # output wcs descriptor +int ndim # the dimension of the output image + +int i, j, nin, nout, szatstr, axno[IM_MAXDIM], axval[IM_MAXDIM] +pointer sp, wcs, attribute, matin, matout, rin, rout, win, wout, atstr +int mw_stati(), itoc(), strlen() +errchk mw_newsystem() + +begin + # Get the sizes of the two wcs. + nin = mw_stati (mwin, MW_NPHYSDIM) + nout = mw_stati (mwout, MW_NPHYSDIM) + szatstr = SZ_LINE + + # Allocate space for the matrices and vectors. + call smark (sp) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (matin, nin * nin, TY_DOUBLE) + call salloc (matout, nout * nout, TY_DOUBLE) + call salloc (rin, nin, TY_DOUBLE) + call salloc (rout, nout, TY_DOUBLE) + call salloc (win, nin, TY_DOUBLE) + call salloc (wout, nout, TY_DOUBLE) + call salloc (attribute, SZ_FNAME, TY_CHAR) + call malloc (atstr, szatstr, TY_CHAR) + + # Set the system name. + call mw_gsystem (mwin, Memc[wcs], SZ_FNAME) + iferr (call mw_newsystem (mwout, Memc[wcs], nout)) + call mw_ssystem (mwout, Memc[wcs]) + + # Set the lterm. + call mw_gltermd (mwin, Memd[matin], Memd[rin], nin) + call aclrd (Memd[rout], nout) + call amovd (Memd[rin], Memd[rout], nin) + call mw_mkidmd [Memd[matout], nout) + call isk_mcopy (Memd[matin], nin, Memd[matout], nout) + call mw_sltermd (mwout, Memd[matout], Memd[rout], nout) + + # Set the wterm. + call mw_gwtermd (mwin, Memd[rin], Memd[win], Memd[matin], nin) + call aclrd (Memd[rout], nout) + call amovd (Memd[rin], Memd[rout], nin) + call aclrd (Memd[wout], nout) + call amovd (Memd[win], Memd[wout], nin) + call mw_mkidmd [Memd[matout], nout) + call isk_mcopy (Memd[matin], nin, Memd[matout], nout) + call mw_swtermd (mwout, Memd[rout], Memd[wout], Memd[matout], nout) + + # Set the axis map. + call mw_gaxmap (mwin, axno, axval, nin) + do i = nin + 1, nout { + axno[i] = ndim + axval[i] = 0 + } + call mw_saxmap (mwout, axno, axval, nout) + + # Get the axis list and copy the old attribute list for each axis. + do i = 1, nin { + iferr (call mw_gwattrs (mwin, i, "wtype", Memc[atstr], szatstr)) + call strcpy ("linear", Memc[atstr], szatstr) + call mw_swtype (mwout, i, 1, Memc[atstr], "") + for (j = 1; ; j = j + 1) { + if (itoc (j, Memc[attribute], SZ_FNAME) <= 0) + Memc[attribute] = EOS + repeat { + iferr (call mw_gwattrs (mwin, i, Memc[attribute], + Memc[atstr], szatstr)) + Memc[atstr] = EOS + if (strlen (Memc[atstr]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + if (Memc[atstr] == EOS) + break + call mw_swattrs (mwout, i, Memc[attribute], Memc[atstr]) + } + } + + # Set the default attributes for the new axes. + do i = nin + 1, nout + call mw_swtype (mwout, i, 1, "linear", "") + + call mfree (atstr, TY_CHAR) + call sfree (sp) +end + + +# ISK_MCOPY -- Copy a smaller 2d matrix into a larger one. + +procedure isk_mcopy (matin, nin, matout, nout) + +double matin[nin,nin] # the input matrix +int nin # size of the input matrix +double matout[nout,nout] # the input matrix +int nout # size of the output matrix + +int i,j + +begin + do i = 1, nin { + do j = 1, nin + matout[j,i] = matin[j,i] + } +end diff --git a/pkg/images/imutil/src/t_imstat.x b/pkg/images/imutil/src/t_imstat.x new file mode 100644 index 00000000..9641a83e --- /dev/null +++ b/pkg/images/imutil/src/t_imstat.x @@ -0,0 +1,1213 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <imset.h> +include "imstat.h" + + +# T_IMSTATISTICS -- Compute and print the statistics of images. + +procedure t_imstatistics () + +real lower, upper, binwidth, lsigma, usigma, low, up, hwidth, hmin, hmax +pointer sp, fieldstr, fields, image, ist, v +pointer im, buf, hgm +int i, list, nclip, format, nfields, nbins, npix, cache, old_size + +real clgetr() +pointer immap() +int imtopenp(), btoi(), ist_fields(), imtgetim(), imgnlr(), ist_ihist() +int clgeti() +bool clgetb() +errchk immap() + +begin + call smark (sp) + call salloc (fieldstr, SZ_LINE, TY_CHAR) + call salloc (fields, IST_NFIELDS, TY_INT) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (v, IM_MAXDIM, TY_LONG) + + # Open the list of input images, the fields and the data value limits. + list = imtopenp ("images") + call clgstr ("fields", Memc[fieldstr], SZ_LINE) + lower = clgetr ("lower") + upper = clgetr ("upper") + nclip = clgeti ("nclip") + lsigma = clgetr ("lsigma") + usigma = clgetr ("usigma") + binwidth = clgetr ("binwidth") + format = btoi (clgetb ("format")) + cache = btoi (clgetb ("cache")) + + # Allocate space for statistics structure + call ist_allocate (ist) + + # Get the selected fields. + nfields = ist_fields (Memc[fieldstr], Memi[fields], IST_NFIELDS) + if (nfields <= 0) { + call imtclose (list) + call sfree (sp) + return + } + + # Set the processing switches + call ist_switches (ist, Memi[fields], nfields, nclip) + + # Print header banner. + if (format == YES) + call ist_pheader (Memi[fields], nfields) + + # Loop through the input images. + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + + # Open the image. + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + call printf ("Error reading image %s ...\n") + call pargstr (Memc[image]) + next + } + + if (cache == YES) + call ist_cache1 (cache, im, old_size) + + # Accumulate the central moment statistics. + low = lower + up = upper + do i = 0, nclip { + + call ist_initialize (ist, low, up) + call amovkl (long(1), Meml[v], IM_MAXDIM) + + if (IST_SKURTOSIS(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate4 (ist, Memr[buf], + int (IM_LEN(im, 1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SSKEW(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate3 (ist, Memr[buf], + int (IM_LEN (im, 1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SSTDDEV(IST_SW(ist)) == YES || + IST_SMEDIAN(IST_SW(ist)) == YES || + IST_SMODE(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate2 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SMEAN(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate1 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SNPIX(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate0 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SMINMAX(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate0 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, YES) + } + + + # Compute the central moment statistics. + call ist_stats (ist) + + # Compute new limits and iterate. + if (i < nclip) { + if (IS_INDEFR(lsigma) || IS_INDEFR(IST_MEAN(ist)) || + IS_INDEFR(IST_STDDEV(ist))) + low = -MAX_REAL + else if (lsigma > 0.0) + low = IST_MEAN(ist) - lsigma * IST_STDDEV(ist) + else + low = -MAX_REAL + if (IS_INDEFR(usigma) || IS_INDEFR(IST_MEAN(ist)) || + IS_INDEFR(IST_STDDEV(ist))) + up = MAX_REAL + else if (usigma > 0.0) + up = IST_MEAN(ist) + usigma * IST_STDDEV(ist) + else + up = MAX_REAL + if (!IS_INDEFR(lower)) + low = max (low, lower) + if (!IS_INDEFR(upper)) + up = min (up, upper) + if (i > 0) { + if (IST_NPIX(ist) == npix) + break + } + npix = IST_NPIX(ist) + } + + } + + # Accumulate the histogram. + hgm = NULL + if ((IST_SMEDIAN(IST_SW(ist)) == YES || IST_SMODE(IST_SW(ist)) == + YES) && ist_ihist (ist, binwidth, hgm, nbins, hwidth, hmin, + hmax) == YES) { + call aclri (Memi[hgm], nbins) + call amovkl (long(1), Meml[v], IM_MAXDIM) + while (imgnlr (im, buf, Meml[v]) != EOF) + call ahgmr (Memr[buf], int(IM_LEN(im,1)), Memi[hgm], nbins, + hmin, hmax) + if (IST_SMEDIAN(IST_SW(ist)) == YES) + call ist_hmedian (ist, Memi[hgm], nbins, hwidth, hmin, + hmax) + if (IST_SMODE(IST_SW(ist)) == YES) + call ist_hmode (ist, Memi[hgm], nbins, hwidth, hmin, hmax) + } + if (hgm != NULL) + call mfree (hgm, TY_INT) + + # Print the statistics. + if (format == YES) + call ist_print (Memc[image], "", ist, Memi[fields], nfields) + else + call ist_fprint (Memc[image], "", ist, Memi[fields], nfields) + + call imunmap (im) + if (cache == YES) + call fixmem (old_size) + } + + call ist_free (ist) + call imtclose (list) + call sfree (sp) +end + + +# IST_ALLOCATE -- Allocate space for the statistics structure. + +procedure ist_allocate (ist) + +pointer ist #O the statistics descriptor + +begin + call calloc (ist, LEN_IMSTAT, TY_STRUCT) + call malloc (IST_SW(ist), LEN_NSWITCHES, TY_INT) +end + + +# IST_FREE -- Free the statistics structure. + +procedure ist_free (ist) + +pointer ist #O the statistics descriptor + +begin + call mfree (IST_SW(ist), TY_INT) + call mfree (ist, TY_STRUCT) +end + + +# IST_FIELDS -- Procedure to decode the fields string into a list of the +# fields to be computed and printed. + +int procedure ist_fields (fieldstr, fields, max_nfields) + +char fieldstr[ARB] #I string containing the list of fields +int fields[ARB] #O fields array +int max_nfields #I maximum number of fields + +int nfields, flist, field +pointer sp, fname +int fntopnb(), fntgfnb(), strdic() + +begin + nfields = 0 + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + flist = fntopnb (fieldstr, NO) + while (fntgfnb (flist, Memc[fname], SZ_FNAME) != EOF && + (nfields < max_nfields)) { + field = strdic (Memc[fname], Memc[fname], SZ_FNAME, IST_FIELDS) + if (field == 0) + next + nfields = nfields + 1 + fields[nfields] = field + } + call fntclsb (flist) + + call sfree (sp) + + return (nfields) +end + + +# IST_SWITCHES -- Set the processing switches. + +procedure ist_switches (ist, fields, nfields, nclip) + +pointer ist #I the statistics pointer +int fields[ARB] #I fields array +int nfields #I maximum number of fields +int nclip #I the number of clipping iterations + +pointer sw +int ist_isfield() + +begin + # Initialize. + sw = IST_SW(ist) + call amovki (NO, Memi[sw], LEN_NSWITCHES) + + # Set the computation switches. + IST_SNPIX(sw) = ist_isfield (IST_FNPIX, fields, nfields) + IST_SMEAN(sw) = ist_isfield (IST_FMEAN, fields, nfields) + IST_SMEDIAN(sw) = ist_isfield (IST_FMEDIAN, fields, nfields) + IST_SMODE(sw) = ist_isfield (IST_FMODE, fields, nfields) + if (nclip > 0) + IST_SSTDDEV(sw) = YES + else + IST_SSTDDEV(sw) = ist_isfield (IST_FSTDDEV, fields, nfields) + IST_SSKEW(sw) = ist_isfield (IST_FSKEW, fields, nfields) + IST_SKURTOSIS(sw) = ist_isfield (IST_FKURTOSIS, fields, nfields) + + # Adjust the computation switches. + if (ist_isfield (IST_FMIN, fields, nfields) == YES) + IST_SMINMAX(sw) = YES + else if (ist_isfield (IST_FMAX, fields, nfields) == YES) + IST_SMINMAX(sw) = YES + else if (IST_SMEDIAN(sw) == YES || IST_SMODE(sw) == YES) + IST_SMINMAX(sw) = YES + else + IST_SMINMAX(sw) = NO +end + + +# IST_PHEADER -- Print the banner fields. + +procedure ist_pheader (fields, nfields) + +int fields[ARB] # fields to be printed +int nfields # number of fields + +int i + +begin + call printf ("#") + do i = 1, nfields { + switch (fields[i]) { + case IST_FIMAGE: + call printf (IST_FSTRING) + call pargstr (IST_KIMAGE) + case IST_FNPIX: + call printf (IST_FCOLUMN) + call pargstr (IST_KNPIX) + case IST_FMIN: + call printf (IST_FCOLUMN) + call pargstr (IST_KMIN) + case IST_FMAX: + call printf (IST_FCOLUMN) + call pargstr (IST_KMAX) + case IST_FMEAN: + call printf (IST_FCOLUMN) + call pargstr (IST_KMEAN) + case IST_FMEDIAN: + call printf (IST_FCOLUMN) + call pargstr (IST_KMEDIAN) + case IST_FMODE: + call printf (IST_FCOLUMN) + call pargstr (IST_KMODE) + case IST_FSTDDEV: + call printf (IST_FCOLUMN) + call pargstr (IST_KSTDDEV) + case IST_FSKEW: + call printf (IST_FCOLUMN) + call pargstr (IST_KSKEW) + case IST_FKURTOSIS: + call printf (IST_FCOLUMN) + call pargstr (IST_KKURTOSIS) + } + } + + call printf ("\n") + call flush (STDOUT) +end + + +# IST_ISFIELD -- Procedure to determine whether a specified field is one +# of the selected fields or not. + +int procedure ist_isfield (field, fields, nfields) + +int field #I field to be tested +int fields[ARB] #I array of selected fields +int nfields #I number of fields + +int i, isfield + +begin + isfield = NO + do i = 1, nfields { + if (field != fields[i]) + next + isfield = YES + break + } + + return (isfield) +end + + +# IST_INITIALIZE -- Initialize the statistics computation. + +procedure ist_initialize (ist, lower, upper) + +pointer ist #I pointer to the statistics structure +real lower #I lower good data limit +real upper #I upper good data limit + +begin + if (IS_INDEFR(lower)) + IST_LO(ist) = -MAX_REAL + else + IST_LO(ist) = lower + if (IS_INDEFR(upper)) + IST_HI(ist) = MAX_REAL + else + IST_HI(ist) = upper + + IST_NPIX(ist) = 0 + IST_SUMX(ist) = 0.0d0 + IST_SUMX2(ist) = 0.0d0 + IST_SUMX3(ist) = 0.0d0 + IST_SUMX4(ist) = 0.0d0 + + IST_MIN(ist) = MAX_REAL + IST_MAX(ist) = -MAX_REAL + IST_MEAN(ist) = INDEFR + IST_MEDIAN(ist) = INDEFR + IST_MODE(ist) = INDEFR + IST_STDDEV(ist) = INDEFR + IST_SKEW(ist) = INDEFR + IST_KURTOSIS(ist) = INDEFR +end + + +# IST_ACCUMULATE4 -- Accumulate sums up to the fourth power of the data for +# data values between lower and upper. + +procedure ist_accumulate4 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double xx, xx2, sumx, sumx2, sumx3, sumx4 +real lo, hi, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + sumx2 = 0.0 + sumx3 = 0.0 + sumx4 = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } else { + do i = 1, npts { + xx = x[i] + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_SUMX2(ist) = IST_SUMX2(ist) + sumx2 + IST_SUMX3(ist) = IST_SUMX3(ist) + sumx3 + IST_SUMX4(ist) = IST_SUMX4(ist) + sumx4 + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE3 -- Accumulate sums up to the third power of the data for +# data values between lower and upper. + +procedure ist_accumulate3 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double xx, xx2, sumx, sumx2, sumx3 +real lo, hi, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + sumx2 = 0.0 + sumx3 = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } else { + do i = 1, npts { + xx = x[i] + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_SUMX2(ist) = IST_SUMX2(ist) + sumx2 + IST_SUMX3(ist) = IST_SUMX3(ist) + sumx3 + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE2 -- Accumulate sums up to the second power of the data for +# data values between lower and upper. + +procedure ist_accumulate2 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double xx, sumx, sumx2 +real lo, hi, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + sumx2 = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } else { + do i = 1, npts { + xx = x[i] + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + npix = npix + 1 + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_SUMX2(ist) = IST_SUMX2(ist) + sumx2 + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE1 -- Accumulate sums up to the first power of the data for +# data values between lower and upper. + +procedure ist_accumulate1 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double sumx +real lo, hi, xx, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + sumx = sumx + xx + } + } else { + do i = 1, npts + sumx = sumx + x[i] + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + sumx = sumx + xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + sumx = sumx + xx + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE0 -- Accumulate sums up to the 0th power of the data for +# data values between lower and upper. + +procedure ist_accumulate0 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +int i, npix +real lo, hi, xx, xmin, xmax + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + } + } + } + + IST_NPIX(ist) = npix + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_STATS -- Procedure to compute the first four central moments of the +# distribution. + +procedure ist_stats (ist) + +pointer ist #I statistics structure + +double mean, var, stdev +pointer sw +bool fp_equalr() + +begin + sw = IST_SW(ist) + + # Compute the basic statistics regardless of the switches. + if (fp_equalr (IST_MIN(ist), MAX_REAL)) + IST_MIN(ist) = INDEFR + if (fp_equalr (IST_MAX(ist), -MAX_REAL)) + IST_MAX(ist) = INDEFR + if (IST_NPIX(ist) <= 0) + return + + mean = IST_SUMX(ist) / IST_NPIX(ist) + IST_MEAN(ist) = mean + if (IST_NPIX(ist) < 2) + return + + var = (IST_SUMX2(ist) - IST_SUMX(ist) * mean) / + (IST_NPIX(ist) - 1) + if (var <= 0.0) { + IST_STDDEV(ist) = 0.0 + return + } else { + stdev = sqrt (var) + IST_STDDEV(ist) = stdev + } + + # Compute higher order moments if the switches are set. + if (IST_SSKEW(sw)== YES) + IST_SKEW(ist) = (IST_SUMX3(ist) - 3.0d0 * IST_MEAN(ist) * + IST_SUMX2(ist) + 3.0d0 * mean * mean * + IST_SUMX(ist) - IST_NPIX(ist) * mean ** 3) / + IST_NPIX(ist) / stdev / stdev / stdev + + if (IST_SKURTOSIS(sw) == YES) + IST_KURTOSIS(ist) = (IST_SUMX4(ist) - 4.0d0 * mean * + IST_SUMX3(ist) + 6.0d0 * mean * mean * + IST_SUMX2(ist) - 4.0 * mean ** 3 * IST_SUMX(ist) + + IST_NPIX(ist) * mean ** 4) / IST_NPIX(ist) / + stdev / stdev / stdev / stdev - 3.0d0 +end + + + +# IST_IHIST -- Initilaize the histogram of the image pixels. + +int procedure ist_ihist (ist, binwidth, hgm, nbins, hwidth, hmin, hmax) + +pointer ist #I pointer to the statistics structure +real binwidth #I histogram bin width in sigma +pointer hgm #O pointer to the histogram +int nbins #O number of bins +real hwidth #O histogram resolution +real hmin #O minimum histogram value +real hmax #O maximum histogram value + +begin + nbins = 0 + if (binwidth <= 0.0) + return (NO) + + hwidth = binwidth * IST_STDDEV(ist) + if (hwidth <= 0.0) + return (NO) + + nbins = (IST_MAX(ist) - IST_MIN(ist)) / hwidth + 1 + if (nbins < 3) + return (NO) + + hmin = IST_MIN(ist) + hmax = IST_MAX(ist) + + call malloc (hgm, nbins, TY_INT) + + return (YES) +end + + +# IST_HMEDIAN -- Estimate the median from the histogram. + +procedure ist_hmedian (ist, hgm, nbins, hwidth, hmin, hmax) + +pointer ist #I pointer to the statistics structure +int hgm[ARB] #I histogram of the pixels +int nbins #I number of bins in the histogram +real hwidth #I resolution of the histogram +real hmin #I minimum histogram value +real hmax #I maximum histogram value + +real h1, hdiff, hnorm +pointer sp, ihgm +int i, lo, hi + +bool fp_equalr() + +begin + call smark (sp) + call salloc (ihgm, nbins, TY_REAL) + + # Integrate the histogram and normalize. + Memr[ihgm] = hgm[1] + do i = 2, nbins + Memr[ihgm+i-1] = hgm[i] + Memr[ihgm+i-2] + hnorm = Memr[ihgm+nbins-1] + call adivkr (Memr[ihgm], hnorm, Memr[ihgm], nbins) + + # Initialize the low and high bin numbers. + lo = 0 + hi = 1 + + # Search for the point which divides the integral in half. + do i = 1, nbins { + if (Memr[ihgm+i-1] > 0.5) + break + lo = i + } + hi = lo + 1 + + # Approximate the median. + h1 = hmin + lo * hwidth + if (lo == 0) + hdiff = Memr[ihgm+hi-1] + else + hdiff = Memr[ihgm+hi-1] - Memr[ihgm+lo-1] + if (fp_equalr (hdiff, 0.0)) + IST_MEDIAN(ist) = h1 + else if (lo == 0) + IST_MEDIAN(ist) = h1 + 0.5 / hdiff * hwidth + else + IST_MEDIAN(ist) = h1 + (0.5 - Memr[ihgm+lo-1]) / hdiff * hwidth + + call sfree (sp) +end + + +# IST_HMODE -- Procedure to compute the mode. + +procedure ist_hmode (ist, hgm, nbins, hwidth, hmin, hmax) + +pointer ist #I pointer to the statistics strucuture +int hgm[ARB] #I histogram of the pixels +int nbins #I number of bins in the histogram +real hwidth #I resolution of the histogram +real hmin #I minimum histogram value +real hmax #I maximum histogram value + +int i, bpeak +real hpeak, dh1, dh2, denom +bool fp_equalr() + +begin + # If there is a single bin return the midpoint of that bin. + if (nbins == 1) { + IST_MODE(ist) = hmin + 0.5 * hwidth + return + } + + # If there are two bins return the midpoint of the greater bin. + if (nbins == 2) { + if (hgm[1] > hgm[2]) + IST_MODE(ist) = hmin + 0.5 * hwidth + else if (hgm[2] > hgm[1]) + IST_MODE(ist) = hmin + 1.5 * hwidth + else + IST_MODE(ist) = hmin + hwidth + return + } + + # Find the bin containing the histogram maximum. + hpeak = hgm[1] + bpeak = 1 + do i = 2, nbins { + if (hgm[i] > hpeak) { + hpeak = hgm[i] + bpeak = i + } + } + + # If the maximum is in the first bin return the midpoint of the bin. + if (bpeak == 1) { + IST_MODE(ist) = hmin + 0.5 * hwidth + return + } + + # If the maximum is in the last bin return the midpoint of the bin. + if (bpeak == nbins) { + IST_MODE(ist) = hmin + (nbins - 0.5) * hwidth + return + } + + # Compute the lower limit of bpeak. + bpeak = bpeak - 1 + + # Do a parabolic interpolation to find the peak. + dh1 = hgm[bpeak+1] - hgm[bpeak] + dh2 = hgm[bpeak+1] - hgm[bpeak+2] + denom = dh1 + dh2 + if (fp_equalr (denom, 0.0)) { + IST_MODE(ist) = hmin + (bpeak + 0.5) * hwidth + } else { + IST_MODE(ist) = bpeak + 1 + 0.5 * (dh1 - dh2) / denom + IST_MODE(ist) = hmin + (IST_MODE(ist) - 0.5) * hwidth + } + + #dh1 = hgm[bpeak] * (hmin + (bpeak - 0.5) * hwidth) + + #hgm[bpeak+1] * (hmin + (bpeak + 0.5) * hwidth) + + #hgm[bpeak+2] * (hmin + (bpeak + 1.5) * hwidth) + #dh2 = hgm[bpeak] + hgm[bpeak+1] + hgm[bpeak+2] +end + + +# IST_PRINT -- Print the fields using builtin format strings. + +procedure ist_print (image, mask, ist, fields, nfields) + +char image[ARB] #I image name +char mask[ARB] #I mask name +pointer ist #I pointer to the statistics structure +int fields[ARB] #I fields to be printed +int nfields #I number of fields + +int i + +begin + call printf (" ") + do i = 1, nfields { + switch (fields[i]) { + case IST_FIMAGE: + call printf (IST_FSTRING) + call pargstr (image) + case IST_FNPIX: + call printf (IST_FINTEGER) + call pargi (IST_NPIX(ist)) + case IST_FMIN: + call printf (IST_FREAL) + call pargr (IST_MIN(ist)) + case IST_FMAX: + call printf (IST_FREAL) + call pargr (IST_MAX(ist)) + case IST_FMEAN: + call printf (IST_FREAL) + call pargr (IST_MEAN(ist)) + case IST_FMEDIAN: + call printf (IST_FREAL) + call pargr (IST_MEDIAN(ist)) + case IST_FMODE: + call printf (IST_FREAL) + call pargr (IST_MODE(ist)) + case IST_FSTDDEV: + call printf (IST_FREAL) + call pargr (IST_STDDEV(ist)) + case IST_FSKEW: + call printf (IST_FREAL) + call pargr (IST_SKEW(ist)) + case IST_FKURTOSIS: + call printf (IST_FREAL) + call pargr (IST_KURTOSIS(ist)) + } + } + + call printf ("\n") + call flush (STDOUT) +end + + +# IST_FPRINT -- Print the fields using a free format. + +procedure ist_fprint (image, mask, ist, fields, nfields) + +char image[ARB] #I image name +char mask[ARB] #I mask name +pointer ist #I pointer to the statistics structure +int fields[ARB] #I fields to be printed +int nfields #I number of fields + +int i + +begin + do i = 1, nfields { + switch (fields[i]) { + case IST_FIMAGE: + call printf ("%s") + call pargstr (image) + case IST_FNPIX: + call printf ("%d") + call pargi (IST_NPIX(ist)) + case IST_FMIN: + call printf ("%g") + call pargr (IST_MIN(ist)) + case IST_FMAX: + call printf ("%g") + call pargr (IST_MAX(ist)) + case IST_FMEAN: + call printf ("%g") + call pargr (IST_MEAN(ist)) + case IST_FMEDIAN: + call printf ("%g") + call pargr (IST_MEDIAN(ist)) + case IST_FMODE: + call printf ("%g") + call pargr (IST_MODE(ist)) + case IST_FSTDDEV: + call printf ("%g") + call pargr (IST_STDDEV(ist)) + case IST_FSKEW: + call printf ("%g") + call pargr (IST_SKEW(ist)) + case IST_FKURTOSIS: + call printf ("%g") + call pargr (IST_KURTOSIS(ist)) + } + if (i < nfields) + call printf (" ") + } + + call printf ("\n") + call flush (STDOUT) +end + + +define MEMFUDGE 1.05 + +# IST_CACHE1 -- Cache 1 image in memory using the image i/o buffer sizes. + +procedure ist_cache1 (cache, im, old_size) + +int cache #I cache the image pixels in the imio buffer +pointer im #I the image descriptor +int old_size #O the old working set size + +int i, req_size, buf_size +int sizeof(), ist_memstat() + +begin + req_size = MEMFUDGE * IM_LEN(im,1) * sizeof (IM_PIXTYPE(im)) + do i = 2, IM_NDIM(im) + req_size = req_size * IM_LEN(im,i) + if (ist_memstat (cache, req_size, old_size) == YES) + call ist_pcache (im, INDEFI, buf_size) +end + + +# IST_MEMSTAT -- Figure out if there is enough memory to cache the image +# pixels. If it is necessary to request more memory and the memory is +# avalilable return YES otherwise return NO. + +int procedure ist_memstat (cache, req_size, old_size) + +int cache #I cache memory ? +int req_size #I the requested working set size in chars +int old_size #O the original working set size in chars + +int cur_size, max_size +int begmem() + +begin + # Find the default working set size. + cur_size = begmem (0, old_size, max_size) + + # If cacheing is disabled return NO regardless of the working set size. + if (cache == NO) + return (NO) + + # If the requested working set size is less than the current working + # set size return YES. + if (req_size <= cur_size) + return (YES) + + # Reset the current working set size. + cur_size = begmem (req_size, old_size, max_size) + if (req_size <= cur_size) { + return (YES) + } else { + return (NO) + } +end + + +# IST_PCACHE -- Cache the image pixels im memory by resetting the default image +# buffer size. If req_size is INDEF the size of the image is used to determine +# the size of the image i/o buffers. + +procedure ist_pcache (im, req_size, buf_size) + +pointer im #I the input image point +int req_size #I the requested working set size in chars +int buf_size #O the new image buffer size + +int i, def_size, new_imbufsize +int sizeof(), imstati() + +begin + # Find the default buffer size. + def_size = imstati (im, IM_BUFSIZE) + + # Compute the new required image i/o buffer size in chars. + if (IS_INDEFI(req_size)) { + new_imbufsize = IM_LEN(im,1) * sizeof (IM_PIXTYPE(im)) + do i = 2, IM_NDIM(im) + new_imbufsize = new_imbufsize * IM_LEN(im,i) + } else { + new_imbufsize = req_size + } + + # If the default image i/o buffer size is already bigger than + # the requested size do nothing. + if (def_size >= new_imbufsize) { + buf_size = def_size + return + } + + # Reset the image i/o buffer. + call imseti (im, IM_BUFSIZE, new_imbufsize) + call imseti (im, IM_BUFFRAC, 0) + buf_size = new_imbufsize +end + diff --git a/pkg/images/imutil/src/t_imsum.x b/pkg/images/imutil/src/t_imsum.x new file mode 100644 index 00000000..6e4d0c61 --- /dev/null +++ b/pkg/images/imutil/src/t_imsum.x @@ -0,0 +1,320 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMSUM -- Sum or average images with optional high and low pixel rejection. + +procedure t_imsum () + +int list # Input image list +pointer image # Output image +pointer hparams # Header parameter list +pointer option # Output option +int pixtype # Output pixel datatype +int calctype # Internal calculation type +real low_reject # Number or frac of low pix to reject +real high_reject # Number or frac of high pix to reject + +int i, nimages, nlow, nhigh +pointer sp, str, im_in, im_out + +bool clgetb(), streq() +real clgetr() +int imtopenp(), imtlen(), imtgetim(), clgwrd() +pointer immap() + +errchk imsum_set, immap, imunmap + +begin + # Get the input image list. Check that there is at least 1 image. + list = imtopenp ("input") + nimages = imtlen (list) + if (nimages < 1) { + call imtclose (list) + call error (0, "No input images in list") + } + + # Allocate strings and get the parameters. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (hparams, SZ_LINE, TY_CHAR) + call salloc (option, SZ_LINE, TY_CHAR) + + i = clgwrd ("option", Memc[option], SZ_LINE, "|sum|average|median|") + if (streq (Memc[option], "median")) { + nlow = nimages / 2 + nhigh = nimages - nlow - 1 + } else { + # If the rejection value is less than 1 then it is a fraction of the + # input images otherwise it is the number of pixels to be rejected. + low_reject = clgetr ("low_reject") + high_reject = clgetr ("high_reject") + + if (low_reject < 1.) + nlow = low_reject * nimages + else + nlow = low_reject + + if (high_reject < 1.) + nhigh = high_reject * nimages + else + nhigh = high_reject + + if (nlow + nhigh >= nimages) { + call sfree (sp) + call imtclose (list) + call error (0, "Number of pixels rejected >= number of images") + } + } + call clgstr ("hparams", Memc[hparams], SZ_LINE) + + # Map the output image and set the title and pixel type. + # Check all images have the same number and length of dimensions. + + call imsum_set (list, pixtype, calctype) + + i = imtgetim (list, Memc[image], SZ_FNAME) + im_in = immap (Memc[image], READ_ONLY, 0) + call clgstr ("output", Memc[image], SZ_FNAME) + im_out = immap (Memc[image], NEW_COPY, im_in) + call new_title ("title", im_out) + IM_PIXTYPE (im_out) = pixtype + + call imtrew (list) + + # Print verbose info. + if (clgetb ("verbose")) { + call salloc (str, SZ_LINE, TY_CHAR) + call printf ("IMSUM:\n") + call printf (" Input images:\n") + while (imtgetim (list, Memc[str], SZ_LINE) != EOF) { + call printf (" %s\n") + call pargstr (Memc[str]) + } + call imtrew (list) + call printf (" Output image: %s\n") + call pargstr (Memc[image]) + call printf (" Header parameters: %s\n") + call pargstr (Memc[hparams]) + call printf (" Output pixel datatype: %s\n") + call dtstring (pixtype, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Calculation type: %s\n") + call dtstring (calctype, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Option: %s\n") + call pargstr (Memc[option]) + call printf (" Low rejection: %d\n High rejection: %d\n") + call pargi (nlow) + call pargi (nhigh) + call flush (STDOUT) + } + + # Do the image average. Switch on the calculation type. + switch (calctype) { + case TY_SHORT: + call imsums (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_INT: + call imsumi (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_LONG: + call imsuml (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_REAL: + call imsumr (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_DOUBLE: + call imsumd (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + default: + call imsumr (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + } + call imunmap (im_out) + call imunmap (im_in) + + # Set the header parameters. + call imtrew (list) + call imsum_hparam (list, Memc[image], Memc[hparams], Memc[option]) + + call imtclose (list) + call sfree (sp) +end + +# IMSUM_SET -- Determine the output image pixel type and the calculation +# datatype. The default pixel types are based on the highest arithmetic +# precendence of the input images. + +define NTYPES 5 + +procedure imsum_set (list, pixtype, calctype) + +int list # List of input images +int pixtype # Pixel datatype of output image +int calctype # Pixel datatype for calculations + +int i, j, nimages, max_type +pointer sp, str, im1, im2 + +int imtgetim(), imtlen() +bool xt_imleneq() +pointer immap() +errchk immap, imunmap + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Determine maximum precedence datatype. + # Also check that the images are the same dimension and size. + + nimages = imtlen (list) + j = imtgetim (list, Memc[str], SZ_LINE) + im1 = immap (Memc[str], READ_ONLY, 0) + max_type = IM_PIXTYPE (im1) + + do i = 2, nimages { + j = imtgetim (list, Memc[str], SZ_LINE) + im2 = immap (Memc[str], READ_ONLY, 0) + + if ((IM_NDIM(im1) != IM_NDIM(im2)) || !xt_imleneq (im1, im2)) { + call imunmap (im1) + call imunmap (im2) + call error (0, "Images have different dimensions or sizes") + } + + switch (IM_PIXTYPE (im2)) { + case TY_SHORT: + if (max_type == TY_USHORT) + max_type = TY_INT + case TY_USHORT: + if (max_type == TY_SHORT) + max_type = TY_INT + case TY_INT: + if (max_type == TY_USHORT || max_type == TY_SHORT) + max_type = IM_PIXTYPE (im2) + case TY_LONG: + if (max_type == TY_USHORT || max_type == TY_SHORT || + max_type == TY_INT) + max_type = IM_PIXTYPE (im2) + case TY_REAL: + if (max_type != TY_DOUBLE) + max_type = IM_PIXTYPE (im2) + case TY_DOUBLE: + max_type = IM_PIXTYPE (im2) + default: + } + call imunmap (im2) + } + + call imunmap (im1) + call imtrew (list) + + # Set calculation datatype. + call clgstr ("calctype", Memc[str], SZ_LINE) + switch (Memc[str]) { + case EOS: + calctype = max_type + case 's': + calctype = TY_SHORT + case 'i': + calctype = TY_INT + case 'l': + calctype = TY_LONG + case 'r': + calctype = TY_REAL + case 'd': + calctype = TY_DOUBLE + default: + call error (0, "Unrecognized datatype") + } + + # Set output pixel datatype. + call clgstr ("pixtype", Memc[str], SZ_LINE) + switch (Memc[str]) { + case EOS: + pixtype = calctype + case 'u': + pixtype = TY_USHORT + case 's': + pixtype = TY_SHORT + case 'i': + pixtype = TY_INT + case 'l': + pixtype = TY_LONG + case 'r': + pixtype = TY_REAL + case 'd': + pixtype = TY_DOUBLE + default: + call error (0, "Unrecognized datatype") + } + + call sfree (sp) +end + +# IMSUM_HPARM -- Arithmetic on image header parameters. +# +# This program is limited by a lack of a rewind procedure for the image +# header fields list. Thus, a static array of field names is used +# to require only one pass through the list and the images. + +define NFIELDS 10 # Maximum number of fields allowed. + +procedure imsum_hparam (list, output, hparams, option) + +int list # List of input images. +char output[ARB] # Output image +char hparams[ARB] # List of header parameters +char option[ARB] # Sum option + +int i, nfields, flist +pointer sp, field, dvals, image, in, out + +int imofnlu(), imgnfn(), imtgetim(), imtlen() +bool strne(), streq() +double imgetd() +pointer immap() + +errchk immap, imofnlu, imgetd, imputd, imunmap + +begin + # Return if median. + if (strne (option, "average") && strne (option, "sum")) + return + + # Allocate memory. + call smark (sp) + call salloc (field, NFIELDS*SZ_FNAME, TY_CHAR) + call salloc (dvals, NFIELDS, TY_DOUBLE) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Map the fields. + out = immap (output, READ_WRITE, 0) + flist = imofnlu (out, hparams) + i = 0 + while ((i < NFIELDS) && + (imgnfn (flist, Memc[field+i*SZ_FNAME], SZ_FNAME) != EOF)) + i = i + 1 + call imcfnl (flist) + + # Accumulate values from each image. + + nfields = i + call aclrd (Memd[dvals], nfields) + + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + in = immap (Memc[image], READ_ONLY, 0) + do i = 1, nfields + Memd[dvals+i-1] = Memd[dvals+i-1] + + imgetd (in, Memc[field+(i-1)*SZ_FNAME]) + call imunmap (in) + } + + # Output the sums or average. + if (streq (option, "average")) { + i = imtlen (list) + call adivkd (Memd[dvals], double (i), Memd[dvals], nfields) + } + + do i = 1, nfields + call imputd (out, Memc[field+(i-1)*SZ_FNAME], Memd[dvals+i-1]) + + call imunmap (out) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/t_imtile.x b/pkg/images/imutil/src/t_imtile.x new file mode 100644 index 00000000..92f5cce0 --- /dev/null +++ b/pkg/images/imutil/src/t_imtile.x @@ -0,0 +1,619 @@ +include <imhdr.h> +include <fset.h> +include "imtile.h" + + +# T_IMTILE -- Combine a list of same-size subrasters into a single large +# mosaiced image. + +procedure t_imtile () + +int nimages, nmissing, subtract, verbose +pointer it, sp, outimage, trimsection, medsection, nullinput, ranges +pointer str, index, c1, c2, l1, l2, isnull, median, imlist, outim + +bool clgetb() +char clgetc() +int btoi(), clgwrd(), imtlen(), clgeti(), decode_ranges(), it_get_imtype() +pointer imtopenp(), it_setim() +real clgetr() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + call malloc (it, LEN_IRSTRUCT, TY_STRUCT) + + # Allocate temporary working space. + call smark (sp) + call salloc (outimage, SZ_FNAME, TY_CHAR) + call salloc (trimsection, SZ_FNAME, TY_CHAR) + call salloc (medsection, SZ_FNAME, TY_CHAR) + call salloc (nullinput, SZ_FNAME, TY_CHAR) + call salloc (ranges, 3 * MAX_NRANGES + 1, TY_INT) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input image list and the output image name. + imlist = imtopenp ("input") + call clgstr ("output", Memc[outimage], SZ_FNAME) + call clgstr ("trim_section", Memc[trimsection], SZ_FNAME) + call clgstr ("missing_input", Memc[nullinput], SZ_FNAME) + call clgstr ("median_section", Memc[medsection], SZ_FNAME) + if (Memc[medsection] == EOS) + subtract = NO + else + subtract = btoi (clgetb ("subtract")) + verbose = btoi (clgetb ("verbose")) + + # Get the mosaicing parameters. + IT_NXSUB(it) = clgeti ("nctile") + IT_NYSUB(it) = clgeti ("nltile") + IT_CORNER(it) = clgwrd ("start_tile", Memc[str], SZ_FNAME, + ",ll,lr,ul,ur,") + if (clgetb ("row_order")) + IT_ORDER(it) = IT_ROW + else + IT_ORDER(it) = IT_COLUMN + IT_RASTER(it) = btoi (clgetb ("raster_order")) + IT_NXOVERLAP(it) = clgeti ("ncoverlap") + IT_NYOVERLAP(it) = clgeti ("nloverlap") + IT_OVAL(it) = clgetr ("ovalue") + + # Check that the number of observed and missing images matches + # the number of specified subrasters. + if (Memc[nullinput] == EOS) { + nmissing = 0 + Memi[ranges] = 0 + Memi[ranges+1] = 0 + Memi[ranges+2] = 1 + Memi[ranges+3] = NULL + } else { + if (decode_ranges (Memc[nullinput], Memi[ranges], MAX_NRANGES, + nmissing) == ERR) + call error (0, "Error decoding list of unobserved rasters.") + } + nimages = imtlen (imlist) + nmissing + if (nimages != (IT_NXSUB(it) * IT_NYSUB(it))) + call error (0, + "The number of input images is not equal to nxsub * nysub.") + + # Compute the output image characteristics and open the output image. + outim = it_setim (it, imlist, Memc[trimsection], Memc[outimage], + clgeti ("ncols"), clgeti ("nlines"), it_get_imtype (clgetc ( + "opixtype"))) + + # Allocate space for and setup the section descriptors. + call salloc (index, nimages, TY_INT) + call salloc (c1, nimages, TY_INT) + call salloc (c2, nimages, TY_INT) + call salloc (l1, nimages, TY_INT) + call salloc (l2, nimages, TY_INT) + call salloc (isnull, nimages, TY_INT) + call salloc (median, nimages, TY_REAL) + + call it_setup (it, imlist, Memi[ranges], Memc[trimsection], + Memc[medsection], outim, Memi[index], Memi[c1], Memi[c2], + Memi[l1], Memi[l2], Memi[isnull], Memr[median]) + + # Make the output image. + call it_mkmosaic (imlist, Memc[trimsection], outim, Memi[index], + Memi[c1], Memi[c2], Memi[l1], Memi[l2], Memi[isnull], + Memr[median], IT_NXSUB(it), IT_NYSUB(it), IT_OVAL(it), subtract) + + # Printe the results. + if (verbose == YES) { + call it_show (imlist, Memc[trimsection], Memc[outimage], + Memi[index], Memi[c1], Memi[c2], Memi[l1], Memi[l2], + Memi[isnull], Memr[median], IT_NXSUB(it)*IT_NYSUB(it), subtract) + } + + # Close up files and free space. + call imunmap (outim) + call clpcls (imlist) + call sfree (sp) + call mfree (it, TY_STRUCT) +end + + +define NTYPES 7 + +# IT_GET_IMTYPE -- Procedure to get the image type. + +int procedure it_get_imtype (c) + +char c # character denoting the image type + +int i, typecodes[NTYPES] +int stridx() +string types "usilrdx" +data typecodes /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE, + TY_COMPLEX/ + +begin + i = stridx (c, types) + if (i == 0) + return (ERR) + else + return (typecodes[i]) +end + + +# IT_SETUP -- Setup the data base parameters for the images. + +procedure it_setup (it, imlist, ranges, trimsection, medsection, outim, + index, c1, c2, l1, l2, isnull, median) + +pointer it # pointer to the imtil structure +pointer imlist # pointer to the list of input images +int ranges[ARB] # list of missing subrasters +char trimsection[ARB] # input image section for output +char medsection[ARB] # input image section for median computation +pointer outim # pointer to the output image +int index[ARB] # index array +int c1[ARB] # array of beginning column limits +int c2[ARB] # array of ending column limits +int l1[ARB] # array of beginning line limits +int l2[ARB] # array of ending line limits +int isnull[ARB] # output input image order number +real median[ARB] # output median of input image + +int i, j, k, nimrows, nimcols, imcount, next_null +pointer sp, imname, im, buf +int get_next_number(), imtgetim() +pointer immap(), imgs2r() +real amedr() + +begin + nimcols = IM_LEN(outim,1) + nimrows = IM_LEN(outim,2) + + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + imcount = 1 + next_null = 0 + if (get_next_number (ranges, next_null) == EOF) + next_null = IT_NXSUB(it) * IT_NYSUB(it) + 1 + + # Loop over the input images. + do i = 1, IT_NXSUB(it) * IT_NYSUB(it) { + + # Set the indices array. + call it_indices (i, j, k, IT_NXSUB(it), IT_NYSUB(it), + IT_CORNER(it), IT_RASTER(it), IT_ORDER(it)) + index[i] = i + c1[i] = max (1, min (1 + (j - 1) * (IT_NCOLS(it) - + IT_NXOVERLAP(it)), nimcols)) + c2[i] = min (nimcols, max (1, c1[i] + IT_NCOLS(it) - 1)) + l1[i] = max (1, min (1 + (k - 1) * (IT_NROWS(it) - + IT_NYOVERLAP(it)), nimrows)) + l2[i] = min (nimrows, max (1, l1[i] + IT_NROWS(it) - 1)) + + # Set the index of each image in the image template + # and compute the median of the subraster. + if (i < next_null) { + isnull[i] = imcount + if (medsection[1] != EOS) { + if (imtgetim (imlist, Memc[imname], SZ_FNAME) == EOF) + call error (0, "Error reading input image list.") + call strcat (medsection, Memc[imname], SZ_FNAME) + im = immap (Memc[imname], READ_ONLY, TY_CHAR) + buf = imgs2r (im, 1, int (IM_LEN(im,1)), 1, int (IM_LEN(im, + 2))) + median[i] = amedr (Memr[buf], int (IM_LEN(im,1)) * + int (IM_LEN(im,2))) + call imunmap (im) + } else + median[i] = INDEFR + imcount = imcount + 1 + } else { + isnull[i] = 0 + if (medsection[1] == EOS) + median[i] = INDEFR + else + median[i] = IT_OVAL(it) + if (get_next_number (ranges, next_null) == EOF) + next_null = IT_NXSUB(it) * IT_NYSUB(it) + 1 + } + + } + + call imtrew (imlist) + call sfree (sp) +end + + +# IT_SETIM -- Procedure to set up the output image characteristics. + +pointer procedure it_setim (it, list, trimsection, outimage, nimcols, nimrows, + opixtype) + +pointer it # pointer to the imtile structure +pointer list # pointer to list of input images +char trimsection[ARB]# input image section +char outimage[ARB] # name of the output image +int nimcols # number of output image columns +int nimrows # number of output image rows +int opixtype # output image pixel type + +int ijunk, nc, nr +pointer sp, imname, im, outim +int imtgetim() +pointer immap() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + # Get the size of the first subraster. + if (imtgetim (list, Memc[imname], SZ_FNAME) != EOF) { + call strcat (trimsection, Memc[imname], SZ_FNAME) + im = immap (Memc[imname], READ_ONLY, 0) + IT_NCOLS(it) = IM_LEN(im,1) + IT_NROWS(it) = IM_LEN(im,2) + call imunmap (im) + call imtrew (list) + } else + call error (0, "Error reading first input image.\n") + + # Compute the size of the output image. + ijunk = IT_NXSUB(it) * IT_NCOLS(it) - (IT_NXSUB(it) - 1) * + IT_NXOVERLAP(it) + if (IS_INDEFI(nimcols)) + nc = ijunk + else + nc = max (nimcols, ijunk) + ijunk = IT_NYSUB(it) * IT_NROWS(it) - (IT_NYSUB(it) - 1) * + IT_NYOVERLAP(it) + if (IS_INDEFI(ijunk)) + nr = ijunk + else + nr = max (nimrows, ijunk) + + # Set the output pixel type. + if (opixtype == ERR) + opixtype = TY_REAL + + # Open output image and set the parameters. + outim = immap (outimage, NEW_IMAGE, 0) + IM_NDIM(outim) = 2 + IM_LEN(outim,1) = nc + IM_LEN(outim,2) = nr + IM_PIXTYPE(outim) = opixtype + + call sfree (sp) + + return (outim) +end + + +# IT_MKMOSAIC -- Procedure to make the mosaiced image. + +procedure it_mkmosaic (imlist, trimsection, outim, index, c1, c2, l1, l2, + isnull, median, nxsub, nysub, oval, subtract) + +pointer imlist # pointer to input image list +char trimsection[ARB]# input image section +pointer outim # pointer to the output image +int index[ARB] # index array for sorting the images +int c1[ARB] # array of column beginnings +int c2[ARB] # array of column endings +int l1[ARB] # array of line beginnings +int l2[ARB] # array of line endings +int isnull[ARB] # index of input image in the template +real median[ARB] # array of input image median values +int nxsub # number of subrasters per output image column +int nysub # number of subrasters per output image row +real oval # pixel value of undefined output image regions +int subtract # subtract the median off each subraster + +int i, j, noutcols, noutlines, olineptr, ll1, ll2 +pointer sp, inimage, imptrs, buf +int imtrgetim() +pointer immap(), impl2r() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (imptrs, nxsub, TY_POINTER) + call salloc (inimage, SZ_FNAME, TY_CHAR) + + # Sort the subrasters on the yindex. + do i = 1, nxsub * nysub + index[i] = i + call rg_qsorti (l1, index, index, nxsub * nysub) + + noutcols = IM_LEN(outim,1) + noutlines = IM_LEN(outim,2) + + # Loop over the input images. + olineptr = 1 + do i = 1, nxsub * nysub, nxsub { + + # Compute the line and column limits. + ll1 = l1[index[i]] + ll2 = l2[index[i]] + + # Open the nxsub input images. + do j = i, i + nxsub - 1 { + if (isnull[index[j]] <= 0) { + Memc[inimage] = EOS + Memi[imptrs+j-i] = NULL + } else { + if (imtrgetim (imlist, isnull[index[j]], Memc[inimage], + SZ_FNAME) == EOF) + Memi[imptrs+j-i] = NULL + else { + call strcat (trimsection, Memc[inimage], SZ_FNAME) + Memi[imptrs+j-i] = immap (Memc[inimage], READ_ONLY, 0) + } + } + } + + # Write out the undefined lines. + while (olineptr < ll1) { + buf = impl2r (outim, olineptr) + call amovkr (oval, Memr[buf], noutcols) + olineptr = olineptr + 1 + } + + # Write the output lines. + call it_mklines (Memi[imptrs], outim, index, c1, c2, ll1, ll2, + median, i, nxsub, oval, subtract) + olineptr = ll2 + 1 + + # Close up the images. + # Open the nxsub input images. + do j = i, i + nxsub - 1 { + if (Memi[imptrs+j-i] != NULL) + call imunmap (Memi[imptrs+j-i]) + } + + } + + # Write out the remaining undefined lines. + while (olineptr < noutlines) { + buf = impl2r (outim, olineptr) + call amovkr (oval, Memr[buf], noutcols) + olineptr = olineptr + 1 + } + + call sfree (sp) +end + + +# IT_MKLINES -- Construct and output image lines. + +procedure it_mklines (imptrs, outim, index, c1, c2, l1, l2, meds, init, nsub, + oval, subtract) + +pointer imptrs[ARB] # array of input image pointers +pointer outim # output imnage pointer +int index[ARB] # array of indices +int c1[ARB] # array of beginning columns +int c2[ARB] # array of ending columns +int l1 # beginning line +int l2 # ending line +real meds[ARB] # array of median values +int init # first index +int nsub # number of subrasters +real oval # output value +int subtract # subtract the median value + +int i, j, jj, noutcols +pointer obuf, ibuf +pointer impl2r(), imgl2r() + +begin + noutcols = IM_LEN(outim, 1) + do i = l1, l2 { + obuf = impl2r (outim, i) + call amovkr (oval, Memr[obuf], noutcols) + do j = 1, nsub { + jj = index[j+init-1] + if (imptrs[j] != NULL) { + ibuf = imgl2r (imptrs[j], i - l1 + 1) + if (subtract == YES) + call asubkr (Memr[ibuf], meds[jj], Memr[obuf+c1[jj]-1], + c2[jj] - c1[jj] + 1) + else + call amovr (Memr[ibuf], Memr[obuf+c1[jj]-1], c2[jj] - + c1[jj] + 1) + } + } + } +end + + +# IT_INDICES -- Given the number in the list for a missing subraster and +# information about how the subrasters were written return the i and j +# indices of the specified subrasters. + +procedure it_indices (num, i, j, nxsub, nysub, corner, raster, order) + +int num # number of the subraster +int i,j # indices of the subraster +int nxsub,nysub # number of subrasters in x and y +int corner # starting corner +int raster # raster order +int order # column or row order + +begin + switch (corner) { + case IT_LL: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = num / nxsub + if (raster == YES && mod (j,2) == 0) + i = 1 + else + i = nxsub + } else { + j = num / nxsub + 1 + if (raster == YES && mod (j,2) == 0) + i = nxsub - mod (num, nxsub) + 1 + else + i = mod (num, nxsub) + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = num / nysub + if (raster == YES && mod (i,2) == 0) + j = 1 + else + j = nysub + } else { + i = num / nysub + 1 + if (raster == YES && mod (i,2) == 0) + j = nysub - mod (num, nysub) + 1 + else + j = mod (num, nysub) + } + } + case IT_LR: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = num / nxsub + if (raster == YES && mod (j,2) == 0) + i = nxsub + else + i = 1 + } else { + j = num / nxsub + 1 + if (raster == YES && mod (j,2) == 0) + i = mod (num, nxsub) + else + i = nxsub - mod (num, nxsub) + 1 + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = nxsub - num / nysub + 1 + if (raster == YES && mod (i,2) != 0) + j = 1 + else + j = nysub + } else { + i = nxsub - num / nysub + if (raster == YES && mod (i,2) != 0) + j = nysub - mod (num, nysub) + 1 + else + j = mod (num, nysub) + } + } + case IT_UL: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = nysub - num / nxsub + 1 + if (raster == YES && mod (j,2) != 0) + i = 1 + else + i = nxsub + } else { + j = nysub - num / nxsub + if (raster == YES && mod (j,2) != 0) + i = nxsub - mod (num, nxsub) + 1 + else + i = mod (num, nxsub) + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = num / nysub + if (raster == YES && mod (i,2) == 0) + j = nysub + else + j = 1 + } else { + i = num / nysub + 1 + if (raster == YES && mod (i,2) == 0) + j = mod (num, nysub) + else + j = nysub - mod (num, nysub) + 1 + } + } + case IT_UR: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = nysub - num / nxsub + 1 + if (raster == YES && mod (j,2) != 0) + i = nxsub + else + i = 1 + } else { + j = nysub - num / nxsub + if (raster == YES && mod (j,2) != 0) + i = mod (num, nxsub) + else + i = nxsub - mod (num, nxsub) + 1 + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = nxsub - num / nysub + 1 + if (raster == YES && mod (i,2) != 0) + j = nysub + else + j = 1 + } else { + i = nxsub - num / nysub + if (raster == YES && mod (i,2) != 0) + j = mod (num, nysub) + else + j = nysub - mod (num, nysub) + 1 + } + } + } +end + + +# IT_SHOW -- List the results. + +procedure it_show (imlist, trimsection, outimage, index, c1, c2, l1, + l2, isnull, median, nsub, subtract) + +int imlist # input image list +char trimsection[ARB]# trim section of input image +char outimage[ARB] # output image +int index[ARB] # array of sorted indices (not used at present) +int c1[ARB] # array of beginning column limits +int c2[ARB] # array of ending column limits +int l1[ARB] # array of beginning line limits +int l2[ARB] # array of ending line limits +int isnull[ARB] # image name index +real median[ARB] # array of medians +int nsub # number of subrasters +int subtract # subtract the median from the subraster + +int i +pointer sp, imname +int imtrgetim() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + do i = 1, nsub { + + if (isnull[i] <= 0) + call strcpy ("nullimage", Memc[imname], SZ_FNAME) + else if (imtrgetim (imlist, isnull[i], Memc[imname], + SZ_FNAME) != EOF) + call strcat (trimsection, Memc[imname], SZ_FNAME) + else + Memc[imname] = EOS + + call printf ("imcopy %s %s[%d:%d,%d:%d] %g %g\n") + call pargstr (Memc[imname]) + call pargstr (outimage) + call pargi (c1[i]) + call pargi (c2[i]) + call pargi (l1[i]) + call pargi (l2[i]) + call pargr (median[i]) + if (subtract == YES) + call pargr (-median[i]) + else + call pargr (0.0) + } + + call sfree (sp) +end + + + diff --git a/pkg/images/imutil/src/t_minmax.x b/pkg/images/imutil/src/t_minmax.x new file mode 100644 index 00000000..03dff18c --- /dev/null +++ b/pkg/images/imutil/src/t_minmax.x @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imset.h> + +# MINMAX -- Update the minimum and maximum pixel values of an image. This is +# done only if the values are absent or invalid, unless the force flag is set. +# The header values are not updated when computing the min/max of an image +# section unless the force flag is set. The values are printed on the standard +# output as they are computed, if the verbose option is selected. + +procedure t_minmax() + +pointer images # image name template +bool force # force recomputation of values +bool update # update values in image header +bool verbose # print values as they are computed + +bool section +int list, pixtype +long vmin[IM_MAXDIM], vmax[IM_MAXDIM] +pointer im, sp, pixmin, pixmax, imname, imsect +double minval, maxval, iminval, imaxval + +bool clgetb() +long clktime() +int imtopen(), imtgetim() +pointer immap() +define tryagain_ 91 + +begin + call smark (sp) + call salloc (images, SZ_LINE, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (imsect, SZ_FNAME, TY_CHAR) + call salloc (pixmin, SZ_FNAME, TY_CHAR) + call salloc (pixmax, SZ_FNAME, TY_CHAR) + + # Get list of input images. + + call clgstr ("images", Memc[images], SZ_LINE) + list = imtopen (Memc[images]) + + # Get switches. + + force = clgetb ("force") + update = clgetb ("update") + verbose = clgetb ("verbose") + + # Process each image in the list. + + while (imtgetim (list, Memc[imname], SZ_FNAME) != EOF) { + call imgsection (Memc[imname], Memc[imsect], SZ_FNAME) + section = (Memc[imsect] != EOS) + + call strcpy ("", Memc[pixmin], SZ_FNAME) + call strcpy ("", Memc[pixmax], SZ_FNAME) + + if (update) { + + iferr (im = immap (Memc[imname], READ_WRITE, 0)) + goto tryagain_ + + pixtype = IM_PIXTYPE(im) + if (force || (IM_LIMTIME(im) < IM_MTIME(im))) { + if (IM_NDIM(im) > 0) { + call im_vminmax (im, minval, maxval, iminval, imaxval, + vmin, vmax) + call mkoutstr (vmin, IM_NDIM(im), Memc[pixmin], + SZ_FNAME) + call mkoutstr (vmax, IM_NDIM(im), Memc[pixmax], + SZ_FNAME) + } else { + minval = INDEFD + maxval = INDEFD + Memc[pixmin] = EOS + Memc[pixmax] = EOS + } + if (! section) { + if (IS_INDEFD(minval)) + IM_MIN(im) = INDEFR + else + IM_MIN(im) = minval + if (IS_INDEFD(maxval)) + IM_MAX(im) = INDEFR + else + IM_MAX(im) = maxval + IM_LIMTIME(im) = clktime (long(0)) + call imseti (im, IM_WHEADER, YES) + } + } else { + minval = IM_MIN(im) + maxval = IM_MAX(im) + } + + call imunmap (im) + + } else { +tryagain_ iferr (im = immap (Memc[imname], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } else { + pixtype = IM_PIXTYPE(im) + if (force || IM_LIMTIME(im) < IM_MTIME(im)) { + if (IM_NDIM(im) > 0) { + call im_vminmax (im, minval, maxval, iminval, + imaxval, vmin, vmax) + call mkoutstr (vmin, IM_NDIM(im), Memc[pixmin], + SZ_FNAME) + call mkoutstr (vmax, IM_NDIM(im), Memc[pixmax], + SZ_FNAME) + } else { + minval = INDEFD + maxval = INDEFD + Memc[pixmin] = EOS + Memc[pixmax] = EOS + } + } else { + minval = IM_MIN(im) + maxval = IM_MAX(im) + } + call imunmap (im) + } + } + + # Make the section strings. + + if (verbose) { + if (pixtype == TY_COMPLEX) { + call printf (" %s %s %z %s %z\n") + call pargstr (Memc[imname]) + call pargstr (Memc[pixmin]) + call pargx (complex (minval, iminval)) + call pargstr (Memc[pixmax]) + call pargx (complex (maxval, imaxval)) + call flush (STDOUT) + } else { + call printf (" %s %s %g %s %g\n") + call pargstr (Memc[imname]) + call pargstr (Memc[pixmin]) + call pargd (minval) + call pargstr (Memc[pixmax]) + call pargd (maxval) + call flush (STDOUT) + } + } + } + + # Return the computed values of the last image examined as CL + # parameters. + + call clputd ("minval", minval) + call clputd ("maxval", maxval) + call clputd ("iminval", iminval) + call clputd ("imaxval", imaxval) + call clpstr ("minpix", Memc[pixmin]) + call clpstr ("maxpix", Memc[pixmax]) + + call sfree (sp) +end + + +# MKOUTSTR -- Encode the output string. + +procedure mkoutstr (v, ndim, outstr, maxch) + +long v[ARB] # imio v vector +int ndim # number of dimensions +char outstr[ARB] # output string +int maxch # maximum length of string + +int i, ip, nchars +int ltoc() + +begin + # Encode opening brackett. + outstr[1] = '[' + + # Encode v vector values. + ip = 2 + do i = 1, ndim { + nchars = ltoc (v[i], outstr[ip], maxch) + ip = ip + nchars + outstr[ip] = ',' + ip = ip + 1 + } + + # Encode closing bracketts and EOS. + outstr[ip-1] = ']' + outstr[ip] = EOS +end diff --git a/pkg/images/imutil/src/t_sections.x b/pkg/images/imutil/src/t_sections.x new file mode 100644 index 00000000..560e2a2f --- /dev/null +++ b/pkg/images/imutil/src/t_sections.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SECTIONS -- Expand a image template into a list of images on the +# standard output and record the number of sections in a parameter. + +procedure t_sections() + +char images[SZ_LINE] # Image template +char image[SZ_FNAME] +char str[SZ_LINE] +int option, list +int clgwrd(), imtopen(), imtgetim(), imtlen() + +begin + call clgstr ("images", images, SZ_LINE) + option = clgwrd ("option", str, SZ_LINE, + ",nolist,fullname,root,section,") + list = imtopen (images) + + call clputi ("nimages", imtlen (list)) + + while (imtgetim (list, image, SZ_FNAME) != EOF) { + switch (option) { + case 2: + call printf ("%s\n") + call pargstr (image) + case 3: + call get_root (image, str, SZ_LINE) + call printf ("%s\n") + call pargstr (str) + case 4: + call get_section (image, str, SZ_LINE) + call printf ("%s\n") + call pargstr (str) + } + } + + call imtclose (list) +end |