C @(#)tdcopyima.for	13.1.1.1 (ES0-DMD) 06/02/98 18:19:02
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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  14:33 - 19 NOV 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  TCOPYIMA
C
C.PURPOSE
C
C  Execute the commands
C  COPY/IT  IMAGE TABLE
C  COPY/TI  TABLE IMAGE
C
C.KEYWORDS
C
C  copier, tables
C
C.ALGORITHM
C
C  Use MIDAS interface routines
C  900711 Add test on NULL values M.Peron
C  901012 Take care of the REAL number of rows
C  910306 Put reasonable labels in table MP
C  910318 Open the input table in F_MAP_FORCE|F_IMODE MPeron
C  910403 Take in account the number of allocated rows MP
C-----------------------------------------------------------
C
      SUBROUTINE TDCPIM
      IMPLICIT NONE
C
      INTEGER MADRID
      INTEGER*8   PNTR, TADD
      INTEGER NPIX(2), IAV, ISTAT, ICOL1, NAXIS, NCOL, NROW
      INTEGER ISIZE,   TID, I,     IC,    NSC,  NAC,  NAR
      INTEGER STATUS,  ID,  KUN,   KNUL,  TYPE, IMNO,NR
C
      DOUBLE PRECISION DSTART(2), DSTEP(2)
C
      REAL*4       RMIN,RMAX,CUTS(4)
      CHARACTER*16 MSG
      CHARACTER*60 TABLE, IMAGE, COLUMN
      CHARACTER*48 CUNIT
      CHARACTER*8  FORM
      CHARACTER*16 TUNIT, TLABEL
      CHARACTER*72 IDENT
      CHARACTER*1  ACTION
C
      INCLUDE 'MID_INCLUDE:TABLES.INC'
C
      COMMON /VMR/MADRID(1)
C
      INCLUDE 'MID_INCLUDE:TABLED.INC'
C
      DATA MSG/'ERR:TCOPYIMAxxxx'/
      DATA TUNIT/' '/, TLABEL/' '/
      DATA FORM/'G14.6 '/
C
      TYPE = D_R4_FORMAT
C
C ... get into MIDAS
C
      CALL STKRDC('ACTION',1,1,1,IAV,ACTION,KUN,KNUL,ISTAT)
      IF (ACTION.EQ.'I') THEN
          CALL STKRDC('IN_A',1,1,60,IAV,IMAGE,KUN,KNUL,ISTAT)
          CALL STKRDC('OUT_A',1,1,60,IAV,TABLE,KUN,KNUL,ISTAT)
          CALL STKRDC('P3',1,1,60,IAV,COLUMN,KUN,KNUL,ISTAT)
          IF (COLUMN(1:1).EQ.'?') THEN
              ICOL1  = 0
          ELSE
              ICOL1  = 1
          END IF
C
C ... copy image to table
          CALL STIGET(IMAGE,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,
     .    2,NAXIS,NPIX,DSTART,DSTEP,IDENT,CUNIT,PNTR,IMNO,ISTAT)
C
C ... create table
C
          IF (NPIX(2).LE.0) NPIX(2) = 1
          NCOL   = NPIX(2) + ICOL1
          NROW   = NPIX(1)
          ISIZE  = NPIX(1)*NPIX(2)
          CALL TBTINI(TABLE,F_TRANS,F_IO_MODE,NCOL,NROW,TID,ISTAT)
          IF (ICOL1.EQ.1) THEN
             TLABEL = COLUMN
          ELSE
             TLABEL = 'LAB001'
          ENDIF
          CALL TBCINI(TID,TYPE,1,FORM,TUNIT,TLABEL,IC,ISTAT)
          DO 10 I = 2,NCOL
              WRITE (TLABEL,9010) I
              CALL TBCINI(TID,TYPE,1,FORM,TUNIT,TLABEL,IC,ISTAT)
   10     CONTINUE
          IF (ICOL1.EQ.1) THEN
              CALL GENCOL(TID,1,NPIX(1),DSTART(1),DSTEP(1))
          END IF
          CALL TBCMAP(TID,ICOL1+1,TADD,ISTAT)
          CALL TBIGET(TID,NCOL,NR,NSC,NAC,NAR,ISTAT)
          CALL BICOPY(MADRID(PNTR),MADRID(TADD),ISIZE,NROW,NAR,NCOL)
          CALL TBIPUT(TID,NCOL,NROW,ISTAT)
          CALL TBSINI(TID,ISTAT)
          CALL TDHSTR(TID,ISTAT)
          CALL DSCUPT(TID,TID,' ',ISTAT)
          CALL TBTCLO(TID,ISTAT)
      ELSE
C
C ... copy table to image
C
          CALL STKRDC('IN_A',1,1,60,IAV,TABLE,KUN,KNUL,ISTAT)
          CALL STKRDC('OUT_A',1,1,60,IAV,IMAGE,KUN,KNUL,ISTAT)
          CALL TBTOPN(TABLE,16,TID,ISTAT)
          CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,ISTAT)
          CALL TBCMAP(TID,1,TADD,ISTAT)
C          NROW   = NAR                  ! ON REQUEST 
          NPIX(2) = NCOL
          NPIX(1) = NROW
          ISIZE  = NCOL*NROW
          CUNIT  = ' '
          IDENT  = TABLE
          DSTART(1) = 0.D0
          DSTART(2) = 0.D0
          DSTEP(1) = 1.D0
          DSTEP(2) = 1.D0
          CALL STIPUT(IMAGE,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,2,NPIX,
     +            DSTART,DSTEP,IDENT,CUNIT,PNTR,ID,ISTAT)
          CALL BTCOPY(MADRID(TADD),MADRID(PNTR),NCOL,NROW,NAR,
     +            RMIN,RMAX)
          CUTS(1) = 0
          CUTS(2) = 0
          CUTS(3) = RMIN
          CUTS(4) = RMAX
          CALL STDWRR(ID,'LHCUTS',CUTS,1,4,KUN,ISTAT)
          CALL TDHSTR(ID,ISTAT)
          CALL DSCUPT(ID,ID,' ',ISTAT)
      END IF
C ... end
C
      CONTINUE
      IF (ISTAT.NE.0) THEN
          WRITE (MSG(13:16),9000) ISTAT
          CALL TDERRR(ISTAT,MSG,STATUS)
      END IF
 9000 FORMAT (I4)
 9010 FORMAT ('LAB',I3.3)
      END

      SUBROUTINE GENCOL(TID,ICOL,N,START,STEP)
C
C GENERATE FIRST COLUMN
C
      IMPLICIT NONE
      INTEGER  TID, ICOL
      INTEGER N, I, ISTAT
C
      DOUBLE PRECISION    START, STEP, T
C
      DO 10 I = 1,N
          T   = (I-1)*STEP + START
          CALL TBEWRD(TID,I,ICOL,T,ISTAT)
   10 CONTINUE
      RETURN
      END


      SUBROUTINE BICOPY(IN,OUT,N,NROW,NAR,NCOL)
C
C  COPY ARRAY
C
      IMPLICIT NONE
      INTEGER N, I,J,NROW,NCOL,NAR
C
      REAL    IN(N), OUT(NAR,NCOL)
C
      DO 20 J=1,NCOL
      DO 10 I = 1,NROW
          OUT(I,J) = IN(I+(J-1)*NROW)
   10 CONTINUE
   20 CONTINUE
      RETURN

      END

      SUBROUTINE BTCOPY(IN,OUT,NCOL,NROW,NAR,RMIN,RMAX)
  
      IMPLICIT NONE
      INTEGER I,J,TINULL,IAV,KUN,KNUL,ISTAT,NROW,NCOL,NAR
      REAL IN(NAR,NCOL),OUT(NROW,NCOL),TRNULL,NULL
      REAL RMIN,RMAX
      DOUBLE PRECISION TDNULL

      CALL STKRDR('NULL',2,1,IAV,NULL,KUN,KNUL,ISTAT)
      CALL TBMNUL(TINULL,TRNULL,TDNULL)
      RMIN = IN(1,1)
      RMAX = RMIN
      DO 20 J=1,NCOL
         DO 10 I=1,NROW
         IF (IN(I,J).EQ.TRNULL) THEN
             OUT(I,J) = NULL
         ELSE
             OUT(I,J) = IN(I,J)
             RMIN = MIN(RMIN,IN(I,J))
             RMAX = MAX(RMAX,IN(I,J))
         ENDIF
10       CONTINUE
20    CONTINUE
      RETURN
      END




