C @(#)midsubs.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
      SUBROUTINE ATTACH (IMAGE, OPEN)
C
C Open an image.
C
      IMPLICIT NONE
      CHARACTER OBJECT*72, CASE*4
      CHARACTER*30 IMAGE, COOFIL, MAGFIL, PSFFIL, PROFIL,
     .     GRPFIL, SWITCH
      INTEGER AXLEN(7)
C
      REAL DNUL, DUN
      INTEGER IER, NAXIS, IDTYPE
      INTEGER MADRID, IMDATA, IMCOPY, NCOL, NROW
      LOGICAL OPEN
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /FILNAM/ COOFIL, MAGFIL, PSFFIL, PROFIL, GRPFIL
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
      COMMON /SIZE/ NCOL, NROW
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      IF (OPEN) THEN
         CALL CLPIC ('DATA')
      END IF
C
      CALL STFOPN (IMAGE, D_R4_FORMAT, 1, F_IMA_TYPE, IMDATA, IER)
      IF (IER .EQ. 0) THEN
         OPEN = .TRUE.
         CALL STFINF (IMAGE, 2, AXLEN, IER)
         IDTYPE = AXLEN(2)
         IF ((IDTYPE .NE. D_R4_FORMAT) .AND. (IDTYPE .NE. D_I4_FORMAT)
     .        .AND. (IDTYPE .NE. D_I2_FORMAT)) THEN
              CALL STUPID ('Invalid data type.')
              OPEN = .FALSE.
              RETURN
         END IF
C
         CALL STDRDC (IMDATA, 'IDENT', 1, 1, 72, NAXIS, OBJECT,
     .        DUN, DNUL, IER)
         IF (IER .EQ. 0) THEN
            WRITE (6,601) OBJECT
  601       FORMAT (/10X, A/)
         END IF
         CALL STDRDI (IMDATA, 'NPIX', 1, 2, NAXIS, AXLEN, DUN,
     .        DNUL, IER)
         IF (IER .NE. 0) THEN
            CALL STUPID ('Unable to read image dimensions.')
            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, CASE('.coo'))
         MAGFIL = SWITCH(IMAGE, CASE('.ap'))
         PSFFIL = SWITCH(IMAGE, CASE('.psf'))
         PROFIL = SWITCH(IMAGE, CASE('.nst'))
         GRPFIL = SWITCH(IMAGE, CASE('.grp'))
      ELSE
         OPEN = .FALSE.
         CALL STUPID ('          Unable to open image.')
      END IF
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE CREPIC (PICTUR, TYPE, NCOL, NROW, IER)
      IMPLICIT NONE
      INTEGER LEN(7)
C
      CHARACTER*30 PICTUR
      CHARACTER*6 TYPE
      INTEGER NCOL, NROW, IDTYPE, IER, MADRID, IMDATA, IMCOPY
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      CALL STFINF (PICTUR, 99, LEN, IER)
      IF (IER .EQ. 0) THEN
         CALL STFDEL (PICTUR, IER)
      END IF
C
      LEN(1) = NCOL
      LEN(2) = NROW
      IF ((TYPE(1:1) .EQ. 'S') .OR. (TYPE(1:1) .EQ. 's')) THEN
         IDTYPE = D_I2_FORMAT
      ELSE
         IDTYPE = D_R4_FORMAT
      END IF
      CALL STFCRE (PICTUR, IDTYPE, F_IO_MODE, F_IMA_TYPE, 
     .     NCOL*NROW, IMCOPY, IER)
C     IF (IER .NE. 0) CALL STUPID (MESSAGE(IER))
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE RDARAY (TEXT, LX, LY, MX, MY, NX, FUNC, IER)
      IMPLICIT NONE
      INTEGER NX, MIN0, MAX0
      REAL FUNC(NX,*)
C
      CHARACTER*4 TEXT
      INTEGER LX, LY, MX, MY, IER, MADRID, IMDATA, IMCOPY, IDTYPE
      INTEGER JY, KX, ID, NCOL, NROW, J
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /SIZE/ NCOL, NROW
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      IF (TEXT .EQ. 'DATA') THEN
         ID = IMDATA
      ELSE
         ID = IMCOPY
      END IF
C
C Reset LX, LY, MX, and MY, if necessary, to keep them within
C the bounds of the image.
C
      MX = LX+MX-1
      MY = LY+MY-1
      LX = MAX0(1,LX)
      LY = MAX0(1,LY)
      MX = MIN0(NCOL,MX)
      MY = MIN0(NROW,MY)
      MX = MX-LX+1
      MY = MY-LY+1
      DO J=1,MY
         JY = LY+J-1
         CALL STFGET (ID, (JY-1)*NCOL+LX, MX, KX, FUNC(1,J), IER)
         IF (IER .NE. 0) THEN 
            CALL STUPID ('STFGET:  Error reading image data.')
         END IF
      END DO
      RETURN
      END!
C
C#######################################################################
C
      FUNCTION OBJECT (TEXT)
      IMPLICIT NONE
      CHARACTER*(*) OBJECT
      CHARACTER*(*) TEXT
      REAL DUN, DNUL
      INTEGER MADRID, IMDATA, IMCOPY, IDTYPE, I, NAXIS, IER
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      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
C
      CALL STDRDC (IMDATA, 'IDENT', 1, 1, 72, NAXIS, OBJECT,
     .     DUN, DNUL, IER)
C
      IF (IER .EQ. 0) THEN
         CALL STDRDC (IMDATA, 'OBJECT', 1, 1, 72, NAXIS, 
     .        OBJECT, DUN, DNUL, IER)
      END IF
C
      IF (IER .NE. 0) THEN
         CALL STDRDC (IMDATA, 'COMMENT', 1, 1, 72, NAXIS, 
     .        OBJECT, DUN, DNUL, IER)
      END IF
C
      IF (IER .EQ. 0) THEN
         WRITE (6,601) OBJECT
  601    FORMAT (/10X, A/)
      END IF
C
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE COPPIC (PICTUR, PIX, NCOL, NROW, IER)
      IMPLICIT NONE
      INTEGER NCOL, NROW
      REAL PIX(NCOL)
C
      CHARACTER*80 DUMMY
      CHARACTER*30 PICTUR
      CHARACTER*6 TYPE
      INTEGER LX, LY, J, NX, NY, LEN
      INTEGER IER, MADRID, IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      CALL STFINF (PICTUR, 99, LEN, IER)
      IF (IER .EQ. 0) THEN
         CALL STFDEL (PICTUR, IER)
      END IF
C
      IF (IDTYPE .EQ. D_R4_FORMAT) THEN
         TYPE = 'REAL'
      ELSE IF (IDTYPE .EQ. D_I4_FORMAT) THEN
         TYPE = 'INT'
      ELSE
         TYPE = 'SHORT'
      END IF
      NX = NCOL
      NY = NROW
      CALL CREPIC (PICTUR, TYPE, NX, NY, IER)
      IF (IER .NE. 0) THEN
         CALL STUPID ('CREPIC: Error creating output image.')
         CALL OOPS
      END IF
C
      CALL STDCOP (IMDATA, IMCOPY, 1, DUMMY, IER)
      IF (IER .NE. 0) THEN
         CALL STUPID ('STDCOP: Error copying image.')
         CALL OOPS
      END IF
C
      NY = 1
      DO J = 1,NROW
         LX = 1
         LY = J
         CALL RDARAY ('DATA', LX, LY, NX, NY, NCOL, PIX, IER)
         IF (IER .NE. 0) THEN
            CALL STUPID ('RDARAY:  Error copying image data.')
            CALL OOPS
         END IF
C
         CALL WRARAY ('COPY', LX, LY, NX, NY, NCOL, PIX, IER)
         IF (IER .NE. 0) THEN
            CALL STUPID ('WRARAY:  Error copying image data.')
            CALL OOPS
         END IF
C
      END DO
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE WRARAY (TEXT, LX, LY, MX, MY, MAXX, FUNC, IER)
      IMPLICIT NONE
      INTEGER MAXX
      REAL FUNC(MAXX,*), ROW(4096)
C
      CHARACTER*4 TEXT
      INTEGER MADRID, NCOL, NROW, IMDATA, IMCOPY, IDTYPE, ID
      INTEGER I, J, JY, LX, LY, MX, MY, NX, NY, IER
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /SIZE/ NCOL, NROW
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      IF ((TEXT(1:1) .EQ. 'd') .OR. (TEXT(1:1) .EQ. 'D')) THEN
         ID = IMDATA
      ELSE
         ID = IMCOPY
      END IF
      MX = LX+MX-1
      MY = LY+MY-1
      LX = MAX0(1,LX)
      LY = MAX0(1,LY)
      MX = MIN0(NCOL, MX)
      MY = MIN0(NROW, MY)
      NX = MX-LX+1
      NY = MY-LY+1
      DO J=1,NY
         JY = LY+J-1
         DO I=1,NX
            IF (IDTYPE .EQ. D_I2_FORMAT) THEN
               ROW(I) = AMAX1(-32768., AMIN1(32767., FUNC(I,J)))
               ROW(I) = ANINT(ROW(I))
            ELSE IF (IDTYPE .EQ. D_I4_FORMAT) THEN
               ROW(I) = AMAX1(-2147483000., AMIN1(2147483000.,
     .              FUNC(I,J)))
               ROW(I) = ANINT(ROW(I))
            ELSE
               ROW(I) = FUNC(I,J)
            END IF
         END DO
         CALL STFPUT (ID, (JY-1)*NCOL+LX, NX, ROW, IER)
         IF (IER .NE. 0) THEN
            CALL STUPID ('STFPUT error.')
            CALL OOPS
         END IF
      END DO
      MX = NX
      MY = NY
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE CLPIC (TEXT)
      IMPLICIT NONE
      CHARACTER*4 TEXT
      INTEGER IDTYPE, MADRID, IER, ID, IMDATA, IMCOPY
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
      COMMON /IMID/ IMDATA, IMCOPY, IDTYPE
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      IF ((TEXT(1:1) .EQ. 'D') .OR. (TEXT(1:1) .EQ. 'd')) THEN
         ID = IMDATA
      ELSE
         ID = IMCOPY
      END IF
      CALL STFCLO (ID, IER)
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE DELPIC (IMAGE, IER)
      IMPLICIT NONE
      CHARACTER*30 IMAGE
      INTEGER MADRID, IER
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/ MADRID
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      CALL STFDEL (IMAGE, IER)
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE LIST (FILE)
      IMPLICIT NONE
      CHARACTER*30 FILE
      CALL TBLANK
      WRITE (6,*) 'Image file = ', FILE
      CALL TBLANK
      RETURN
      END!