1 files changed, 108 insertions, 0 deletions
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