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