C @(#)ctable.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:40 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.IDENTIFICATION C subroutine CTABLE version 1.1 830916 C A. Kruszewski ESO Garching C modified version 1.2 870304 C A. Kruszewski Obs. de Geneve C.PURPOSE C creates a table and writes parameters of detected objects into it C.INPUT/OUTPUT C input parameters C NCOL integer*4 number of table columns C NROW integer*4 number of table rows C START real*8 array physical coordinates of (1,1) pixel C STEP real*8 array physical size of one pixel C NCAT integer*4 array integer parameters C PMTR real*4 array array holding classifiers C PRCT real*4 array catalog of objects profiles C NP integer*4 dimension of catalog buffer C output parameters C IOF integer*4 output table C----------------------------------------------------------------------- SUBROUTINE CTABLE(IOF,NCOL,NROW,START,STEP, NCAT, & PMTR, PRCT, NP) C IMPLICIT NONE INCLUDE 'MID_REL_INCL:INVENT.INC/NOLIST' C INTEGER IOF INTEGER NCOL INTEGER NROW DOUBLE PRECISION START(2) DOUBLE PRECISION STEP(2) INTEGER NP INTEGER NCAT(NIPAR,NP) REAL PMTR(NRPAR,NP) REAL PRCT(0:MAXSUB,NP) C REAL PVAL(27+MAXSUB) INTEGER ICOL(MAXSUB+27) INTEGER IPRF, ISTAT INTEGER K INTEGER L INTEGER MADRID(1) CHARACTER*16 LABEL(26), UNIT(26), LABELP, UNITP C INCLUDE 'MID_INCLUDE:TABLES.INC' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:TABLED.INC' C DATA LABEL/'IDENT','X','Y','MAG_CNV','MAG_AP_1','MAG_AP_2', & 'REL_GRAD','SIGMA_GR','BG','INT','RADIUS_1','RADIUS_2', & 'ELONG','POS_ANG','RAD_ISO','MAG_PET','RAD_PET','RAD_KRON', & 'ALPHA','MAG_ISO','CLASS','NR_OTH_OBJ','AR','SIGMA_X', & 'SIGMA_Y','SIGMA_MAG'/ DATA UNIT/'NO_DIM','MICRON','MICRON','MAGNITUDE','MAGNITUDE', & 'MAGNITUDE','NO_DIM','NO_DIM','INSTR_UNITS','INSTR_UNITS', & 'PIXEL','PIXEL','NO_DIM','DEGREES','PIXEL','MAGNITUDE', & 'PIXEL','PIXEL','NO_DIM','MAGNITUDE','NO_DIM','PIXEL', & 'PIXEL','PIXEL','PIXEL','NO_DIM'/ C UNITP = 'INSTR_UNITS' LABELP = 'PROFILE' DO 10 L = 1 , NCOL ICOL(L) = L 10 CONTINUE C DO 20 L = 1 , 26 CALL TBCINI(IOF, D_R4_FORMAT, 1, 'E12.4', UNIT(L), & LABEL(L), ICOL(L), ISTAT) 20 CONTINUE IPRF = NCOL - 26 IF (IPRF.GT.0) THEN DO 30 L = 27 , NCOL CALL TBCINI(IOF, D_R4_FORMAT, 1, 'E12.4', UNITP, & LABELP, ICOL(L), ISTAT) 30 CONTINUE ENDIF C C ****** Write data into output table. C DO 60 K = 1 , NROW DO 40 L = 1 , 26 IF ( L .EQ. 1 ) THEN PVAL(L) = FLOAT(K) ELSE IF ( L .EQ. 2 ) THEN PVAL(L) = SNGL( START(1) + & STEP(1) * DBLE(PMTR(10,K)-1.0) ) ELSE IF ( L .EQ. 3 ) THEN PVAL(L) = SNGL( START(2) + & STEP(2) * DBLE(PMTR(11,K)-1.0) ) ELSE IF ( L .EQ. 4 ) THEN PVAL(L) = PMTR(12,K) ELSE IF ( L .EQ. 5 ) THEN PVAL(L) = PMTR(13,K) ELSE IF ( L .EQ. 6 ) THEN PVAL(L) = PMTR(20,K) ELSE IF ( L .EQ. 7 ) THEN PVAL(L) = PMTR(3,K) ELSE IF ( L .EQ. 8 ) THEN PVAL(L) = PMTR(4,K) ELSE IF ( L .EQ. 9 ) THEN PVAL(L) = PMTR(1,K) ELSE IF ( L .EQ. 10 ) THEN PVAL(L) = PMTR(2,K) ELSE IF ( L .EQ. 11 ) THEN PVAL(L) = PMTR(6,K) ELSE IF ( L .EQ. 12 ) THEN PVAL(L) = PMTR(7,K) ELSE IF ( L .EQ. 13 ) THEN PVAL(L) = PMTR(8,K) ELSE IF ( L .EQ. 14 ) THEN PVAL(L) = PMTR(9,K) ELSE IF ( L .EQ. 23 ) THEN PVAL(L) = FLOAT( NCAT(5,K) ) ELSE IF ( L .EQ. 20 ) THEN PVAL(L) = PMTR(5,K) ELSE IF ( L .EQ. 22 ) THEN PVAL(L) = FLOAT( NCAT(3,K) ) ELSE IF ( L .EQ. 24 ) THEN PVAL(L) = PMTR(22,K) ELSE IF ( L .EQ. 25 ) THEN PVAL(L) = PMTR(23,K) ELSE IF ( L .EQ. 26 ) THEN PVAL(L) = PMTR(24,K) ELSE PVAL(L) = PMTR(L,K) ENDIF 40 CONTINUE DO 50 L = 27 , NCOL PVAL(L) = PRCT(L-27,K) 50 CONTINUE CALL TBRWRR( IOF , K , NCOL , ICOL , PVAL , ISTAT ) 60 CONTINUE CALL TBSINI( IOF , ISTAT ) C RETURN C END C