C @(#)irasubs.for	17.1.1.1 (ES0-DMD) 01/25/02 17:14:09
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
      character*(*) function object (text)
      character*132 line
      character*(*) text
      common /imid/ imdata, imcopy, dtype
      if ((text(1:1) .eq. 'd') .or. (text(1:1) .eq. 'D')) then
         i = imdata
      else if ((text(1:1) .eq. 'c') .or. (text(1:1) .eq. 'C')) then
         i = imcopy
      else
         object = ' '
         return
      end if
      call imgkwc (i, 'title', line, ier)
      if (ier .ne. 0) then
         call imgkwc (imdata, 'OBJECT', line, ier)
      end if
      if (ier .ne. 0) then
         call imgkwc (i, 'COMMENT', line, ier)
      end if
      if (ier .ne. 0) then
         object = ' '
         return
      end if
      do i=1,132
         if (line(i:i) .ne. ' ') then
            object = line(i:132)
            return
         end if
      end do
      object = ' '
      return
      end
c
c
c
      subroutine attach (image, open)
      character expand*100, message*64, object*64
      character*30 image, coofil, magfil, psffil, profil,
     .     grpfil, switch, extend
      integer axlen(7), dtype
      logical*1 open
      common /filnam/ coofil, magfil, psffil, profil, grpfil
      common /imid/ imdata, imcopy, dtype
      common /size/ ncol, nrow
      call imopen (expand(extend(image,'imh')), 1, imdata, ier)
      if (ier .eq. 0) then
         open = .true.
         call imgkwc (imdata, 'title', object, ier)
         if (ier .ne. 0) then
            call imgkwc (imdata, 'OBJECT', object, ier)
         end if
         if (ier .ne. 0) then
            call imgkwc (imdata, 'COMMENT', object, ier)
         end if
         if (ier .eq. 0) then
            write (6,601) object
  601       format (/10x, a/)
         end if
         call imgsiz (imdata, axlen, naxis, dtype, ier)
         if (ier .ne. 0) then
            call stupid (message(ier))
            open = .false.
            return
         else if (naxis .eq. 1) then
            ncol = axlen(1)
            nrow = 1
         else
            ncol = axlen(1)
            nrow = axlen(2)
         end if
         write (6,611) ncol, nrow
  611    format (38x, 'Picture size: ', 2i5)
         coofil = switch(image, '.coo')
         magfil = switch(image, '.ap')
         psffil = switch(image, '.psf')
         profil = switch(image, '.nst')
         grpfil = switch(image, '.grp')
      else
         open = .false.
         call stupid (message(ier))
      end if
      return
      end
c
c
c
      character*80 function message (ier)
      character*80 error
      call imemsg (ier,error)
      message = error
      return
      end
c
c
c
      subroutine crepic (picture, type, ncol, nrow, ier)
      character*100 expand
      character*80 message
      character*30 picture, extend
d     character*30 new
      character*6 type
      integer*4 len(7)
      common /imid/ imdata, imcopy, idtype
      call imopen (expand(extend(picture, 'imh')), 1, imcopy, ier)
      if (ier .eq. 0) then
d        call stupid ('Output image already exists')
d        new = 'OVERWRITE'
d        call getname ('New output file name:', new)
d        if (new .eq. 'OVERWRITE') then
            call imdele (picture, ier)
d        else
d           picture = new
d        end if
d        call tblank
      end if
c
      len(1) = ncol
      len(2) = nrow
      if ((type(1:1) .eq. 'R') .or. (type(1:1) .eq. 'r')) 
     .     idtype = 6
      call imcrea (picture, len, 2, idtype, ier)
      if (ier .ne. 0) call stupid (message(ier))
      call imopen (picture, 3, imcopy, ier)
      if (ier .ne. 0) call stupid (message(ier))
      call imhcpy (imdata, imcopy, ier)
      if (ier .ne. 0) call stupid (message(ier))
      return
      end
c
c
c
      subroutine coppic (picture, pix, ncol, nrow, ier)
      character*80 message
      character*30 picture
d     character*30 new
      real*4 pix(ncol)
      common /imid/ imdata, imcopy, idtype
c
      call imopen (picture, 3, j, ier)
      if (ier .eq. 0) then
d        call stupid ('Output image already exists')
d        new = 'OVERWRITE'
d        call getname ('New output file name:', new)
d        if (new .eq. 'OVERWRITE') then
            call imdele (picture, ier)
d        else
d           picture = new
d        end if
d        call tblank
      end if
c
      call imopnc (picture, imdata, imcopy, ier)
      if (ier .ne. 0) call stupid(message(ier))
      do j = 1,nrow
         call imgl2r (imdata, pix, j, ier)
         if (ier .ne. 0) call stupid(message(ier))
         call impl2r (imcopy, pix, j, ier)
         if (ier .ne. 0) call stupid(message(ier))
      end do
      return
      end
c
c
c
      subroutine rdaray (text, lx, ly, mx, my, nx, func, ier)
      character*80 message
      character*4 text
      real*4 func(nx,*)
      common /size/ ncol, nrow
      common /imid/ imdata, imcopy, idtype
      if (text .eq. 'DATA') then
         id = imdata
      else
         id = imcopy
      end if
      mx = lx+mx-1
      my = ly+my-1
      lx = max(1,lx)
      ly = max(1,ly)
      mx = min(ncol,mx)
      my = min(nrow,my)
      my = my-ly+1
      do j=1,my
         jy = ly+j-1
         call imgs2r (id, func(1,j), lx, mx, jy, jy, ier)
         if (ier .ne. 0) then 
            call stupid(message(ier))
            write (6,*) 'rdaray:  x =', lx, ' to', mx, 
     .           '  y =', jy
         end if
      end do
      mx = mx-lx+1
      return
      end
c
c
c
      subroutine wraray (text, lx, ly, mx, my, maxx, func, ier)
      character*80 message
      character*4 text
      real*4 func(maxx,*), row(4096)
      common /size/ ncol, nrow
      common /imid/ imdata, imcopy, idtype
      if (text .eq. 'DATA') then
         id = imdata
      else
         id = imcopy
      end if
      mx = lx+mx-1
      my = ly+my-1
      lx = max(1,lx)
      ly = max(1,ly)
      mx = min(ncol, mx)
      my = min(nrow, my)
      nx = mx-lx+1
      ny = my-ly+1
      do j=1,ny
         jy = ly+j-1
         do i=1,nx
            if (idtype .le. 3) then
               row(i) = max(-32768., min(32767., func(i,j)))
            else
               row(i) = func(i,j)
            end if
            if (idtype .le. 5) then
               row(i) = anint(row(i))
            end if
         end do
         call imps2r (id, row, lx, mx, jy, jy, ier)
         if (ier .ne. 0) then
            call stupid(message(ier))
            write (6,*) 'wraray:  x =', lx, ' to', mx, 
     .           ' y =', jy
         end if
      end do
      mx = nx
      my = ny
      return
      end
c
c
c
      subroutine clpic (text)
      character*4 text
      common /imid/ imdata, imcopy, idtype
      if (text .eq. 'DATA') then
         id = imdata
      else
         id = imcopy
      end if
      call imclos (id, ier)
      return
      end
c
c
c
      subroutine delpic (image, ier)
      character*30 image
      call imdele (image, ier)
      return
      end
c
c
c
      subroutine  writem  (picture, label, type, string)
      real*8 double
c     real*4 single
c     integer*4 long
c     integer*2 short
      integer*4 dtype
      character expand*100, picture*30, extend*30, 
     .     label*8, type*1, string*(*)
      common /imid/ imdata, imcopy, dtype
      call imopen (expand(extend(picture,'imh')), 3, imdata, istat)
      if (istat .ne. 0) then
         call stupid ('Error opening image.')
         write (6,*) istat
         call oops
      end if
c
      if ((type .eq. 'D') .or. (type .eq. 'd')) then
         read (string,*,iostat=istat) double
         if (istat .ne. 0) then
            call stupid ('Error reading datum from string:')
            write (6,*) string
            call oops
         end if
         call imakwd (imdata, label, double, ' ', istat)
         if (istat .ne. 0) then
            call stupid ('Error writing header item:')
            write (6,*) label, '= ', double
         end if
      end if
      call imclos (imdata, istat)
      return
      end
C
C
C
      SUBROUTINE LIST (FILE)
      CHARACTER*30 FILE
      CALL TBLANK
      WRITE (6,*) 'Image file = ', FILE
      CALL TBLANK
      RETURN
      END