aboutsummaryrefslogtreecommitdiff
path: root/sys/imfort/tasks
diff options
context:
space:
mode:
Diffstat (limited to 'sys/imfort/tasks')
-rw-r--r--sys/imfort/tasks/README20
-rw-r--r--sys/imfort/tasks/args.f33
-rw-r--r--sys/imfort/tasks/hello.f6
-rw-r--r--sys/imfort/tasks/imcopy.f81
-rw-r--r--sys/imfort/tasks/imdel.f29
-rw-r--r--sys/imfort/tasks/imren.f36
-rw-r--r--sys/imfort/tasks/keyw.f116
-rw-r--r--sys/imfort/tasks/minmax.f56
-rw-r--r--sys/imfort/tasks/mkim.f75
-rw-r--r--sys/imfort/tasks/pcube.f108
-rw-r--r--sys/imfort/tasks/phead.f155
-rw-r--r--sys/imfort/tasks/planck.f59
-rw-r--r--sys/imfort/tasks/readim.f53
-rw-r--r--sys/imfort/tasks/tasks.unix18
-rw-r--r--sys/imfort/tasks/tasks.vms17
15 files changed, 862 insertions, 0 deletions
diff --git a/sys/imfort/tasks/README b/sys/imfort/tasks/README
new file mode 100644
index 00000000..9eb3e075
--- /dev/null
+++ b/sys/imfort/tasks/README
@@ -0,0 +1,20 @@
+IMIO$IMFORT/ZZDEBUG -
+
+ This directory contains a set of Fortran programs used to test the IMFORT
+software, and to provide real working examples illustrating the use of the
+IMFORT interface in host Fortran programs.
+
+ hello.f prints `hello, world!'
+ imcopy.f copy an image
+ imdel.f delete an image
+ imren.f rename an image
+ keyw.f test header keyword access
+ minmax.f update datamin, datamax
+ mkim.f make a test image, pix[i,j] = j * 100 + i
+ pcube.f print a subraster, e.g., of a MKIM test image
+ phead.f print an image header in FITS format
+ planck.f compute the planck function
+ readim.f test sequential read through an image
+
+To compile individual programs: cl> fc prog.f
+To define the tasks to the CL: cl> cl < tasks.cl (edit tasks.cl first)
diff --git a/sys/imfort/tasks/args.f b/sys/imfort/tasks/args.f
new file mode 100644
index 00000000..b484c4cd
--- /dev/null
+++ b/sys/imfort/tasks/args.f
@@ -0,0 +1,33 @@
+c ARGS -- Test the command line argument interface.
+c
+c usage: args [arg1 [arg2 ...]]
+c ------------------------------------------------------------------------
+
+ program args
+
+ character*80 argstr
+ integer nargs, ier, i
+
+c --- Test raw command line access.
+ call clrawc (argstr, ier)
+ if (ier .ne. 0) then
+ write (*, '('' clrawc returns status '', i3)') ier
+ else
+ write (*, '('' clrawc: '', a80)') argstr
+ endif
+
+c --- Test parsed command line access.
+ call clnarg (nargs)
+ write (*, '('' nargs = '', i3)') nargs
+
+ do 10 i = 1, nargs
+ call clargc (i, argstr, ier)
+ if (ier .ne. 0) then
+ write (*, '('' unexpected error '', i3)') ier
+ else
+ write (*, '(i4, 2x, a70)') i, argstr
+ endif
+ 10 continue
+
+ stop
+ end
diff --git a/sys/imfort/tasks/hello.f b/sys/imfort/tasks/hello.f
new file mode 100644
index 00000000..f1649f31
--- /dev/null
+++ b/sys/imfort/tasks/hello.f
@@ -0,0 +1,6 @@
+c HELLO -- Sample Fortran program to demonstate compile/link.
+
+ program hello
+ write (*,*) 'hello, world!'
+ stop
+ end
diff --git a/sys/imfort/tasks/imcopy.f b/sys/imfort/tasks/imcopy.f
new file mode 100644
index 00000000..c81f5f05
--- /dev/null
+++ b/sys/imfort/tasks/imcopy.f
@@ -0,0 +1,81 @@
+c IMCOPY -- Copy an image of up to 2048 pixels per line. Works for images of
+c up to three dimensions with a pixel type of either short or real.
+c
+c usage: imcopy oldimage newimage
+c ----------------------------------------------------------------------------
+
+ program imcopy
+
+ real rpix(2048)
+ integer*2 spix(4096)
+ equivalence (rpix, spix)
+ character*80 oimage, nimage, errmsg
+ integer ncols, nlines, nbands, j, k, oim, nim
+ integer ier, axlen(7), naxis, pixtype, nargs
+
+c --- Get command line arguments.
+ call clnarg (nargs)
+ if (nargs .eq. 2) then
+ call clargc (1, oimage, ier)
+ if (ier .ne. 0) goto 91
+ call clargc (2, nimage, ier)
+ if (ier .ne. 0) goto 91
+ else
+ write (*, '('' input image: '',$)')
+ read (*,*) oimage
+ write (*, '('' output image: '',$)')
+ read (*,*) nimage
+ endif
+
+c --- Open the input image.
+ call imopen (oimage, 1, oim, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Create a new output image with the same header and size as the
+c input image.
+
+ call imopnc (nimage, oim, nim, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Determine the size and pixel type of the image being copied.
+ call imgsiz (oim, axlen, naxis, pixtype, ier)
+ if (ier .ne. 0) goto 91
+ ncols = axlen(1)
+ nlines = axlen(2)
+ nbands = axlen(3)
+
+c --- Copy the image.
+ if (pixtype .eq. 3) then
+ do 15 k = 1, nbands
+ do 10 j = 1, nlines
+ call imgl3s (oim, spix, j, k, ier)
+ if (ier .ne. 0) goto 91
+ call impl3s (nim, spix, j, k, ier)
+ if (ier .ne. 0) goto 91
+ 10 continue
+ 15 continue
+ else
+ do 25 k = 1, nbands
+ do 20 j = 1, nlines
+ call imgl3r (oim, rpix, j, k, ier)
+ if (ier .ne. 0) goto 91
+ call impl3r (nim, rpix, j, k, ier)
+ if (ier .ne. 0) goto 91
+ 20 continue
+ 25 continue
+ endif
+
+c --- Clean up.
+ call imclos (oim, ier)
+ if (ier .ne. 0) goto 91
+ call imclos (nim, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+
+c -- Error actions.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+
+ stop
+ end
diff --git a/sys/imfort/tasks/imdel.f b/sys/imfort/tasks/imdel.f
new file mode 100644
index 00000000..d7b65ab9
--- /dev/null
+++ b/sys/imfort/tasks/imdel.f
@@ -0,0 +1,29 @@
+c IMDEL -- Delete an image.
+c
+c usage: imdel imagename
+c ----------------------------------------------------------------------
+
+ program imdel
+
+ integer ier
+ character*80 image, errmsg
+
+c --- Get the name of the image to be deleted.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Delete the image.
+ call imdele (image, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+
+ stop
+ end
diff --git a/sys/imfort/tasks/imren.f b/sys/imfort/tasks/imren.f
new file mode 100644
index 00000000..ea70a1e4
--- /dev/null
+++ b/sys/imfort/tasks/imren.f
@@ -0,0 +1,36 @@
+c IMREN -- Rename an image.
+c
+c usage: imren oldname newname
+c ----------------------------------------------------------------------
+
+ program imren
+
+ integer nargs, ier
+ character*80 oname, nname, errmsg
+
+c --- Get the old and new names of the image to be renamed.
+ call clnarg (nargs)
+ if (nargs .ge. 2) then
+ call clargc (1, oname, ier)
+ if (ier .ne. 0) goto 91
+ call clargc (2, nname, ier)
+ if (ier .ne. 0) goto 91
+ else
+ write (*, '('' enter old image name: '',$)')
+ read (*,*) oname
+ write (*, '('' enter new image name: '',$)')
+ read (*,*) nname
+ endif
+
+c --- Rename the image.
+ call imrnam (oname, nname, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+
+ stop
+ end
diff --git a/sys/imfort/tasks/keyw.f b/sys/imfort/tasks/keyw.f
new file mode 100644
index 00000000..ee235f51
--- /dev/null
+++ b/sys/imfort/tasks/keyw.f
@@ -0,0 +1,116 @@
+c KEYW -- Test the image header get/put interface routines.
+c
+c usage: keyw imagename
+c ----------------------------------------------------------------------------
+
+ program keyw
+
+ character*80 image, errmsg
+ character*8 keywrd, option
+ character*80 valstr, commnt
+ integer ncols, nlines, dtype
+ integer im, ier, axlen(7), naxis
+
+c --- Get image name.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Open the image.
+ call imopen (image, 3, im, ier)
+ if (ier .ne. 0) goto 91
+ call imgsiz (im, axlen, naxis, dtype, ier)
+ if (ier .ne. 0) goto 91
+
+ ncols = axlen(1)
+ nlines = axlen(2)
+
+c --- Interpreter loop.
+ 10 continue
+ write (*, '('' enter command (quit,gkw[cir],pkw[cir],addk,delk): '',$)')
+ read (*,*) option
+
+ if (option .eq. 'pkwc') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ write (*, '('' value: '',$)')
+ read (*,*) valstr
+ call impkwc (im, keywrd, valstr, ier)
+ if (ier .ne. 0) goto 91
+ goto 10
+
+ else if (option .eq. 'pkwi') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ write (*, '('' value: '',$)')
+ read (*,*) ival
+ call impkwi (im, keywrd, ival, ier)
+ if (ier .ne. 0) goto 91
+ goto 10
+
+ else if (option .eq. 'pkwr') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ write (*, '('' value: '',$)')
+ read (*,*) rval
+ call impkwr (im, keywrd, rval, ier)
+ if (ier .ne. 0) goto 91
+ goto 10
+
+ else if (option .eq. 'gkwc') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ call imgkwc (im, keywrd, valstr, ier)
+ if (ier .ne. 0) goto 91
+ write (*,*) 'value ', valstr
+ goto 10
+
+ else if (option .eq. 'gkwi') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ call imgkwi (im, keywrd, ival, ier)
+ if (ier .ne. 0) goto 91
+ write (*,*) 'value ', ival
+ goto 10
+
+ else if (option .eq. 'gkwr') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ call imgkwr (im, keywrd, rval, ier)
+ if (ier .ne. 0) goto 91
+ write (*,*) 'value ', rval
+ goto 10
+
+ else if (option .eq. 'addk') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ write (*, '('' keyword datatype: '',$)')
+ read (*,*) dtype
+ write (*, '('' comment field: '',$)')
+ read (*,*) commnt
+ call imaddk (im, keywrd, dtype, commnt, ier)
+ if (ier .ne. 0) goto 91
+ write (*,*) 'value ', rval
+ goto 10
+
+ else if (option .eq. 'delk') then
+ write (*, '('' keyword name: '',$)')
+ read (*,*) keywrd
+ call imdelk (im, keywrd, ier)
+ if (ier .ne. 0) goto 91
+ goto 10
+
+ endif
+
+c --- Clean up.
+ call imclos (im, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+
+ stop
+ end
diff --git a/sys/imfort/tasks/minmax.f b/sys/imfort/tasks/minmax.f
new file mode 100644
index 00000000..34edaea5
--- /dev/null
+++ b/sys/imfort/tasks/minmax.f
@@ -0,0 +1,56 @@
+c MINMAX -- Compute the minimum and maximum pixel values in an image.
+c The new values are printed as well as updated in the image header.
+c
+c usage: minmax image
+c ----------------------------------------------------------------------
+
+ program minmax
+
+ character*80 image, errmsg
+ real pix(8192), dmin, dmax, vmin, vmax
+ integer im, axlen(7), naxis, dtype, ier, j
+
+c --- Get image name.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Open the image for readwrite access (we need to update the header).
+ call imopen (image, 3, im, ier)
+ if (ier .ne. 0) goto 91
+ call imgsiz (im, axlen, naxis, dtype, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Read through the image and compute the limiting pixel values.
+ do 10 j = 1, axlen(2)
+ call imgl2r (im, pix, j, ier)
+ if (ier .ne. 0) goto 91
+ call alimr (pix, axlen(1), vmin, vmax)
+ if (j .eq. 1) then
+ dmin = vmin
+ dmax = vmax
+ else
+ dmin = min (dmin, vmin)
+ dmax = max (dmax, vmax)
+ endif
+ 10 continue
+
+c --- Update the image header.
+ call impkwr (im, 'datamin', dmin, ier)
+ if (ier .ne. 0) goto 91
+ call impkwr (im, 'datamax', dmax, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Clean up.
+ call imclos (im, ier)
+ if (ier .ne. 0) goto 91
+ write (*, '(1x, a20, 2 g12.5)') image, dmin, dmax
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+ stop
+ end
diff --git a/sys/imfort/tasks/mkim.f b/sys/imfort/tasks/mkim.f
new file mode 100644
index 00000000..7aec2b24
--- /dev/null
+++ b/sys/imfort/tasks/mkim.f
@@ -0,0 +1,75 @@
+c MKIM -- Make a two dimensional test image of type short or real. The pixel
+c values go 1, 2, 3, etc. in storage order.
+c
+c usage: mkim image ncols nlines [dtype] [pixdir]
+c
+c The data type defaults to type short if not specified on the command line.
+c ----------------------------------------------------------------------------
+
+ program mkim
+
+ character*80 image, errmsg, pixdir
+ integer im, ier, axlen(7), naxis, dtype
+ integer nlines, ncols, i, j
+ real pix(8192)
+
+c --- Get image name.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Get image size.
+ call clargi (2, ncols, ier)
+ if (ier .ne. 0) then
+ write (*, '('' ncols: '',$)')
+ read (*,*) ncols
+ endif
+ call clargi (3, nlines, ier)
+ if (ier .ne. 0) then
+ write (*, '('' nlines: '',$)')
+ read (*,*) nlines
+ endif
+
+c --- Get pixel datatype (optional).
+ call clargi (4, dtype, ier)
+ if (ier .ne. 0) dtype = 3
+
+c --- Get pixel directory (optional).
+ call clargc (5, pixdir, ier)
+ if (ier .eq. 0) then
+ call imsdir (pixdir)
+ endif
+
+ axlen(1) = ncols
+ axlen(2) = nlines
+ naxis = 2
+
+c --- Create the image.
+ call imcrea (image, axlen, naxis, dtype, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Open the image for writing, and write the data.
+ call imopen (image, 3, im, ier)
+ if (ier .ne. 0) goto 91
+
+ do 20 j = 1, nlines
+ do 10 i = 1, ncols
+ pix(i) = (j-1) * ncols + i
+ 10 continue
+ call impl2r (im, pix, j, ier)
+ if (ier .ne. 0) goto 91
+ 20 continue
+
+c --- Close the image and quit.
+ call imclos (im, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+ stop
+ end
diff --git a/sys/imfort/tasks/pcube.f b/sys/imfort/tasks/pcube.f
new file mode 100644
index 00000000..89dd3651
--- /dev/null
+++ b/sys/imfort/tasks/pcube.f
@@ -0,0 +1,108 @@
+c PCUBE -- Extract a subraster (image cube) from an image and print
+c the values on the standard output. This is used with a standard
+c test image to verify that the IMFORT interface is working correctly.
+c
+c usage: pcube image i1 i2 [j1 j2 [k1 k2]]
+c ---------------------------------------------------------------------
+
+ program pcube
+
+ character*80 image, errmsg
+ integer i1, i2, j1, j2, k1, k2
+ integer im, ier, axlen(7), naxis, dtype, nargs
+ real pix(8192)
+
+c --- Get image name.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Open the image.
+ call imopen (image, 1, im, ier)
+ if (ier .ne. 0) goto 91
+ call imgsiz (im, axlen, naxis, dtype, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Get subraster coordinates.
+ call clnarg (nargs)
+ if (nargs .lt. 3) then
+ write (*, '('' enter subraster coordinates (i1 i2 j1 j2): '',$)')
+ read (*,*) i1, i2, j1, j2
+ k1 = 1
+ k2 = 1
+ else
+ call clargi (2, i1, ier)
+ if (ier .ne. 0) goto 91
+ call clargi (3, i2, ier)
+ if (ier .ne. 0) goto 91
+
+ if (nargs .ge. 5) then
+ call clargi (4, j1, ier)
+ if (ier .ne. 0) goto 91
+ call clargi (5, j2, ier)
+ if (ier .ne. 0) goto 91
+ else
+ j1 = 1
+ j2 = 1
+ endif
+
+ if (nargs .ge. 7) then
+ call clargi (6, k1, ier)
+ if (ier .ne. 0) goto 91
+ call clargi (7, k2, ier)
+ if (ier .ne. 0) goto 91
+ else
+ k1 = 1
+ k2 = 1
+ endif
+ endif
+
+c --- Extract the subraster.
+ call imgs3r (im, pix, i1, i2, j1, j2, k1, k2, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Print the pixel values.
+ call pcuber (pix, i2-i1+1, j2-j1+1, k2-k1+1, i1,i2, j1,j2, k1,k2)
+
+c --- Close the input image and quit.
+ call imclos (im, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+
+c --- Error handler.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+ stop
+ end
+
+
+c PCUBER -- Print pixel values, 3d subraster, type real.
+c ----------------------------------------------------------------
+
+ subroutine pcuber (pix, nx,ny,nz, i1,i2, j1,j2, k1,k2)
+
+ integer nx, ny, nz
+ real pix(nx,ny,nz)
+ integer i1, i2, j1, j2, k1, k2
+ integer i, j, k
+
+ nx = i2 - i1 + 1
+ ny = j2 - j1 + 1
+ nz = k2 - k1 + 1
+
+ do 20 k = k1, k2
+ write (*, '('' band '', i3)') k
+
+ print 81, i1, i2, j1, j2
+ do 10 j = 1, ny
+ print 82, j-1+j1, (pix(i,j,k), i = 1, nx)
+ 10 continue
+ 20 continue
+
+ 81 format (' subraster at ', 4 i4)
+ 82 format (' line ', i4, 8 (1x, f7.0))
+
+ end
diff --git a/sys/imfort/tasks/phead.f b/sys/imfort/tasks/phead.f
new file mode 100644
index 00000000..4a54b584
--- /dev/null
+++ b/sys/imfort/tasks/phead.f
@@ -0,0 +1,155 @@
+c PHEAD -- Print the header of the named image in FITS format, one keyword
+c per line. A pattern may optionally be specified to list some subset of the
+c header keywords.
+c
+c usage: phead image [pattern]
+c ----------------------------------------------------------------------------
+
+ program phead
+
+ character*20 kwname
+ character*80 image, patstr, errmsg
+ integer im, kwl, ier
+ logical sortit
+
+c --- Get image name.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Get pattern string (list everything if no pattern given).
+ call clargc (2, patstr, ier)
+ if (ier .ne. 0) then
+ patstr = '*'
+ endif
+
+c --- Open the image.
+ call imopen (image, 1, im, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Open the keyword list and print each keyword in FITS format on the
+c standard output device.
+
+ sortit = .false.
+ call imokwl (im, patstr, sortit, kwl, ier)
+
+ 10 continue
+ call imgnkw (kwl, kwname, ier)
+ if (ier .ne. 0) goto 20
+ call putkey (im, kwname, ier)
+ if (ier .ne. 0) goto 91
+ goto 10
+ 20 continue
+
+ call imckwl (kwl, ier)
+ if (ier .ne. 0) goto 91
+
+c --- Clean up.
+ call imclos (im, ier)
+ if (ier .ne. 0) goto 91
+
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '(1x, '' Error: '', a80)') errmsg
+
+ stop
+ end
+
+
+c PUTKEY -- Read the value and comment fields of the named image header
+c keyword, and print the value of the keyword in FITS format on the
+c standard output device.
+c
+c 000000000111111111122222222223333333333444444444455555555556
+c 123456789012345678901234567890123456789012345678901234567890
+c keyword = xxx / comment
+c keyword = 'sval ' / comment
+c
+c Datatype codes: 1=bool, 2=char, 3,4,5=int, 6,7=real/double, 8=complex
+c Only codes 1, 2, 4, and 6 (bool,char,int,real) are returned by IMTYPK.
+c ------------------------------------------------------------------------
+
+ subroutine putkey (im, kwname, ier)
+
+ integer im
+ character*(*) kwname
+
+ logical bval
+ character*68 sval
+ integer ival
+ doubleprecision dval
+
+ character*18 valstr
+ character*47 comstr
+ character*70 lngstr
+ integer nchars, dtype, ier, i
+
+c --- Get the keyword data type and comment information.
+ call imtypk (im, kwname, dtype, comstr, ier)
+ if (ier .ne. 0) return
+
+c --- Print the value of the keyword in FITS format. The format depends
+c upon the datatype of the parameter.
+
+ if (dtype .eq. 1) then
+ call imgkwb (im, kwname, bval, ier)
+ if (ier .ne. 0) return
+ write (*, 10) kwname, bval, comstr
+ 10 format (1x, a8, '= ', l20, ' / ', a47)
+
+ else if (dtype .ge. 3 .and. dtype .le. 5) then
+ call imgkwi (im, kwname, ival, ier)
+ if (ier .ne. 0) return
+ write (*, 20) kwname, ival, comstr
+ 20 format (1x, a8, '= ', i20, ' / ', a47)
+
+ else if (dtype .eq. 6 .or. dtype .eq. 7) then
+ call imgkwd (im, kwname, dval, ier)
+ if (ier .ne. 0) return
+ if (abs(dval) .lt. 1.0E6 .and. abs(dval) .ge. 1.0E-1) then
+ write (*, 30) kwname, dval, comstr
+ 30 format (1x, a8, '= ', f20.2, ' / ', a47)
+ else
+ write (*, 31) kwname, dval, comstr
+ 31 format (1x, a8, '= ', e20.12, ' / ', a47)
+ endif
+
+ else
+ call imgkwc (im, kwname, sval, ier)
+ if (ier .ne. 0) return
+
+ nchars = len(sval) - 1
+ do 40 i = nchars, 9, -1
+ if (sval(i:i) .ne. ' ') goto 41
+ nchars = i - 1
+ 40 continue
+ 41 continue
+
+ if (nchars .le. 8) then
+ write (*, 45) kwname, sval, comstr
+ 45 format (1x, a8, '= ''', a8, '''', 10x, ' / ', a47)
+ else if (nchars .le. 18) then
+ valstr = sval
+ write (*, 46) kwname, valstr, comstr
+ 46 format (1x, a8, '= ''', a18, '''', ' / ', a47)
+ else
+ nchars = min (nchars, len(lngstr) - 2)
+ lngstr(1:1) = ''''
+ do 47 i = 1, nchars
+ lngstr(i+1:i+1) = sval(i:i)
+ 47 continue
+ lngstr(nchars+2:nchars+2) = ''''
+ do 48 i = nchars + 3, len(lngstr)
+ lngstr(i:i) = ' '
+ 48 continue
+ write (*, 49) kwname, lngstr
+ 49 format (1x, a8, '= ', a69)
+ endif
+ endif
+
+ ier = 0
+ end
diff --git a/sys/imfort/tasks/planck.f b/sys/imfort/tasks/planck.f
new file mode 100644
index 00000000..520183c0
--- /dev/null
+++ b/sys/imfort/tasks/planck.f
@@ -0,0 +1,59 @@
+c PLANCK -- Compute the Planck blackbody radiation distribution for a
+c given temperature and wavelength region.
+c
+c usage: planck temperature lambda1 lambda2
+c
+c The temperature is specified in degrees Kelvin and the wavelength
+c region in microns (1u=10000A). 100 [x,y] data points defining the
+c curve are output.
+c ----------------------------------------------------------------------
+
+ program planck
+
+ character*80 errmsg
+ integer nargs, ier, i
+ real w1, w2, dw, cm, t
+ real xv(100), yv(100)
+
+c --- Get the temperature in degrees kelvin.
+ call clargr (1, t, ier)
+ if (ier .ne. 0) then
+ write (*, '('' temperature (degrees kelvin): '',$)')
+ read (*,*) t
+ endif
+
+c --- Get the wavelength region to be computed.
+ call clnarg (nargs)
+ if (nargs .ge. 3) then
+ call clargr (2, w1, ier)
+ if (ier .ne. 0) goto 91
+ call clargr (3, w2, ier)
+ if (ier .ne. 0) goto 91
+ else
+ write (*, '('' start wavelength (microns): '',$)')
+ read (*,*) w1
+ write (*, '('' end wavelength (microns): '',$)')
+ read (*,*) w2
+ endif
+
+c --- Compute the blackbody curve.
+ dw = (w2 - w1) / 99.0
+ do 10 i = 1, 100
+ xv(i) = ((i-1) * dw) + w1
+ cm = xv(i) * 1.0E-4
+ yv(i) = (3.74185E-5 * (cm ** -5)) /
+ * (2.71828 ** (1.43883 / (cm * t)) - 1.0)
+ 10 continue
+
+c --- Print the curve as a table.
+ do 20 i = 1, 100
+ write (*, '(1x, f7.4, g12.4)') xv(i), yv(i)
+ 20 continue
+
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+ stop
+ end
diff --git a/sys/imfort/tasks/readim.f b/sys/imfort/tasks/readim.f
new file mode 100644
index 00000000..466da0e0
--- /dev/null
+++ b/sys/imfort/tasks/readim.f
@@ -0,0 +1,53 @@
+c READIM -- Read through an image and count the lines (used for timing tests).
+c Tests line sequential i/o.
+c
+c usage: readim image
+c ----------------------------------------------------------------------------
+
+ program readim
+
+ character*80 image, errmsg
+ integer ncols, nlines, nbands, j, k
+ integer im, ier, axlen(7), naxis, dtype
+ integer*2 pix(8192)
+
+c --- Get image name.
+ call clargc (1, image, ier)
+ if (ier .ne. 0) then
+ write (*, '('' enter image name: '',$)')
+ read (*,*) image
+ endif
+
+c --- Open the image.
+ call imopen (image, 1, im, ier)
+ if (ier .ne. 0) goto 91
+ call imgsiz (im, axlen, naxis, dtype, ier)
+ if (ier .ne. 0) goto 91
+
+ ncols = axlen(1)
+ nlines = axlen(2)
+ nbands = axlen(3)
+
+c --- Read through the image.
+ do 20 k = 1, nbands
+ do 10 j = 1, nlines
+ call imgl3s (im, pix, j, k, ier)
+ if (ier .ne. 0) goto 91
+ 10 continue
+ 20 continue
+
+c --- Clean up.
+ call imclos (im, ier)
+ if (ier .ne. 0) goto 91
+
+ print 81, nlines, image
+ 81 format (' read ', i4, ' lines from image ', a64)
+
+ stop
+
+c --- Error exit.
+ 91 call imemsg (ier, errmsg)
+ write (*, '('' Error: '', a80)') errmsg
+
+ stop
+ end
diff --git a/sys/imfort/tasks/tasks.unix b/sys/imfort/tasks/tasks.unix
new file mode 100644
index 00000000..13aa52fb
--- /dev/null
+++ b/sys/imfort/tasks/tasks.unix
@@ -0,0 +1,18 @@
+# Declare the IMFORT test/demo tasks as CL foreign tasks [MACHDEP].
+# Usage: uncomment the appropriate declarations, and type `cl < tasks.cl'.
+# NOTE - requires that "iraf" be defined in the host environment.
+
+task $args = "$${iraf}sys/imfort/tasks/args.e $1 $2 $3 $4 $5"
+task $hello = "$${iraf}sys/imfort/tasks/hello.e"
+task $imcopy = "$${iraf}sys/imfort/tasks/imcopy.e $(*)"
+task $imdel = "$${iraf}sys/imfort/tasks/imdel.e $(*)"
+task $imren = "$${iraf}sys/imfort/tasks/imren.e $(*)"
+task $keyw = "$${iraf}sys/imfort/tasks/keyw.e"
+task $minmax = "$${iraf}sys/imfort/tasks/minmax.e $(*)"
+task $mkim = "$${iraf}sys/imfort/tasks/mkim.e $(1) $2 $3 $4 $(5)"
+task $pcube = "$${iraf}sys/imfort/tasks/pcube.e $(1) $2 $3 $4 $5 $6 $7"
+task $phead = "$${iraf}sys/imfort/tasks/phead.e $(1) $2"
+task $planck = "$${iraf}sys/imfort/tasks/planck.e"
+task $readim = "$${iraf}sys/imfort/tasks/readim.e $(*)"
+
+keep
diff --git a/sys/imfort/tasks/tasks.vms b/sys/imfort/tasks/tasks.vms
new file mode 100644
index 00000000..2be943f4
--- /dev/null
+++ b/sys/imfort/tasks/tasks.vms
@@ -0,0 +1,17 @@
+# Declare the IMFORT test/demo tasks as CL foreign tasks [MACHDEP].
+# Usage: uncomment the appropriate declarations, and type `cl < tasks.cl'.
+
+task $args = "$args:==\$irafdisk:[iraf.sys.imfort.tasks]args.exe!args $1 $2 $3 $4 $5"
+task $hello = "$hello:==\$irafdisk:[iraf.sys.imfort.tasks]hello.exe!hello"
+task $imcopy = "$imcopy:==\$irafdisk:[iraf.sys.imfort.tasks]imcopy.exe!imcopy $(*)"
+task $imdel = "$imdel:==\$irafdisk:[iraf.sys.imfort.tasks]imdel.exe!imdel $(*)"
+task $imren = "$imren:==\$irafdisk:[iraf.sys.imfort.tasks]imren.exe!imren $(*)"
+task $keyw = "$keyw:==\$irafdisk:[iraf.sys.imfort.tasks]keyw.exe!keyw"
+task $minmax = "$minmax:==\$irafdisk:[iraf.sys.imfort.tasks]minmax.exe!minmax $(*)"
+task $mkim = "$mkim:==\$irafdisk:[iraf.sys.imfort.tasks]mkim.exe!mkim $(*) $2 $3 $4"
+task $pcube = "$pcube:==\$irafdisk:[iraf.sys.imfort.tasks]pcube.exe!pcube $(*) $2 $3 $4 $5 $6 $7"
+task $phead = "$phead:==\$irafdisk:[iraf.sys.imfort.tasks]phead.exe!phead $(1) $2"
+task $planck = "$planck:==\$irafdisk:[iraf.sys.imfort.tasks]planck.exe!planck"
+task $readim = "$readim:==\$irafdisk:[iraf.sys.imfort.tasks]readim.exe!readim $(*)"
+
+keep
generated by cgit (git 2.34.1) at 2025-09-20 14:28:38 -0400