C @(#)inttab.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:56 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 INTINI(INTNAM,TIDINT) C++ C.Purpose: Create the intermediate table with the following columns C. col 1 : group identification format = I C. col 2: : component identification (star or hole) I C. col 3 to 18 : general window paremeters R C. col 19 : flag parameter C*2 C. col 20 to 25: fit parameters R C.Author: Rein Warmels, ESO Garching C.Version: 890812 RHW Type column taken out C-- IMPLICIT NONE CHARACTER*60 INTNAM INTEGER TIDINT C INTEGER NGRP INTEGER NIDN INTEGER NGEN INTEGER NFLG INTEGER NPAR INTEGER NRINT PARAMETER (NGRP=1) PARAMETER (NIDN=1) PARAMETER (NGEN=16) PARAMETER (NFLG=1) PARAMETER (NPAR=6) PARAMETER (NRINT=10000) INTEGER NROW INTEGER NCINT INTEGER ISTAT INTEGER I CHARACTER*80 STRING CHARACTER*16 FORMI2 CHARACTER*16 FORMI6 CHARACTER*16 FORMR4 CHARACTER*16 UNIT C CHARACTER*16 LABGRP CHARACTER*16 LABIDN CHARACTER*16 LABGEN(16) CHARACTER*16 LABFLG CHARACTER*16 LABPAR(6) C INTEGER INTTYP INTEGER INTCOL CHARACTER*16 INTFOR CHARACTER*16 INTUNI CHARACTER*16 INTLAB INCLUDE 'MID_INCLUDE:ST_DEF.INC' INCLUDE 'MID_INCLUDE:ST_DAT.INC' C DATA NROW/1000/ DATA FORMI2/'I2'/ DATA FORMI6/'I6'/ DATA FORMR4/'E12.4'/ DATA UNIT/' '/ DATA LABGRP/'GROUP '/ DATA LABIDN/'IDENT'/ DATA LABGEN/'WND_XSTA', 'WND_YSTA', 'MAG1 ', 2 'MAG2 ', 'MAG3 ', 'WND_XDIM', 3 'WND_YDIM', 'BG_XCOEF', 'BG_YCOEF', 4 'BG ', 'BETA ', 'VARIANCE', 4 'FIT_ITER', 'WND_FL ', 'N_CMP ', 5 'N_HOL '/ DATA LABFLG/'CMP_FL '/ DATA LABPAR/'INT_FIT ', 'X_FIT ', 'Y_FIT ', 2 'SIGMA ', 'CHI_SQ ', 'SIQ '/ C C *** create a new intermediate table NCINT = NGRP + NIDN + NGEN + NFLG + NPAR CALL TBTINI(INTNAM,0,F_O_MODE,NCINT,NRINT,TIDINT,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** INFO: Problems with opening a new intermediate'// 2 ' table' CALL STTPUT(STRING,ISTAT) CALL STSEPI ELSE C C *** intialize the column for the group number INTTYP = D_I4_FORMAT INTFOR = FORMI6 INTUNI = UNIT INTLAB = LABGRP CALL TBCINI(TIDINT,INTTYP,NGRP,INTFOR,INTUNI, 2 INTLAB,INTCOL,ISTAT) C C *** intialize the column for the name of the component INTTYP = D_I4_FORMAT INTFOR = FORMI6 INTUNI = UNIT INTLAB = LABIDN CALL TBCINI(TIDINT,INTTYP,NIDN,INTFOR,INTUNI, 2 INTLAB,INTCOL,ISTAT) C C *** initialize the column for the standard data DO 10 I = 1,NGEN INTTYP = D_R4_FORMAT INTFOR = FORMR4 INTUNI = UNIT INTLAB = LABGEN(I) CALL TBCINI(TIDINT,INTTYP,1,INTFOR,INTUNI, 2 INTLAB,INTCOL,ISTAT) 10 CONTINUE C C *** initialize the column for the component flag INTTYP = D_I4_FORMAT INTFOR = FORMI2 INTUNI = UNIT INTLAB = LABFLG CALL TBCINI(TIDINT,INTTYP,NFLG,INTFOR,INTUNI, 2 INTLAB,INTCOL,ISTAT) C C *** initialize the column for the object parameters DO 20 I = 1,NPAR INTTYP = D_R4_FORMAT INTFOR = FORMR4 INTUNI = UNIT INTLAB = LABPAR(I) CALL TBCINI(TIDINT,INTTYP,1,INTFOR,INTUNI, 2 INTLAB,INTCOL,ISTAT) 20 CONTINUE ENDIF C RETURN END SUBROUTINE INTDRD(IDEN,INTG1,INTG2,INTG3, 2 REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7) C+++ C.PURPOSE: Write the table info into the descriptor C--- IMPLICIT NONE INTEGER IDEN INTEGER INTG1,INTG2,INTG3 REAL REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7 C INTEGER ISTAT, IACT, KUN, KNUL C INTEGER IOUT(3) REAL ROUT(7) C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C CALL STDRDR(IDEN,'INTPAR_R',1,7,IACT,ROUT,KUN,KNUL,ISTAT) REAL1 = ROUT(1) ! REAL2 = ROUT(2) ! REAL3 = ROUT(3) ! REAL4 = ROUT(4) ! REAL5 = ROUT(5) ! REAL6 = ROUT(6) ! REAL7 = ROUT(7) ! C CALL STDRDI(IDEN,'INTPAR_I',1,3,IACT,IOUT,KUN,KNUL,ISTAT) INTG1 = IOUT(1) ! number of groups INTG2 = IOUT(2) ! number of components INTG3 = IOUT(3) ! number of iterations C RETURN END SUBROUTINE INTDWR(IDEN,INTG1,INTG2,INTG3, 2 REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7) C+++ C--- IMPLICIT NONE INTEGER IDEN INTEGER INTG1,INTG2,INTG3 REAL REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7 C INTEGER KUN, ISTAT C INTEGER IOUT(3) REAL ROUT(7) C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C ROUT(1) = REAL1 ! ROUT(2) = REAL2 ! ROUT(3) = REAL3 ! ROUT(4) = REAL4 ! ROUT(5) = REAL5 ! ROUT(6) = REAL6 ! ROUT(7) = REAL7 ! CALL STDWRR(IDEN,'INTPAR_R',ROUT,1,7,KUN,ISTAT) C IOUT(1) = INTG1 ! number of groups IOUT(2) = INTG2 ! number of components IOUT(3) = INTG3 ! number of iterations CALL STDWRI(IDEN,'INTPAR_I',IOUT,1,3,KUN,ISTAT) C RETURN END SUBROUTINE INTWRD(TID,IROW,NCOMPS,NHOLES) C+++ C.Purpose: Reads the intermediate table starting from row = IROW. C. The data will be stores in a THREE common blocks to be read by C. calling program. C--- IMPLICIT NONE INTEGER TID ! table identification INTEGER IROW ! row indication where to start INTEGER NCOMPS ! number of components in window INTEGER NHOLES ! number of holes in window C INCLUDE 'MID_REL_INCL:RFOTDECL.INC/NOLIST' C INTEGER ISTAT INTEGER IR, IS, IH INTEGER ICGRP INTEGER ICIDN INTEGER ICGEN(NINTP) INTEGER ICFLG INTEGER ICPAR(NINTC) INTEGER TINULL C DOUBLE PRECISION TDNULL,TDTRUE,TDFALS C REAL RNST, RNHL REAL ROUT(NINTC) REAL TRNULL,TBLSEL C LOGICAL NULL(NINTP) C C DATA ICGRP/1/ DATA ICIDN/2/ DATA ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/ DATA ICFLG/19/ DATA ICPAR/20,21,22,23,24,25/ C C *** start the code; first define the columns CALL TBMNUL(TINULL,TRNULL,TDNULL) CALL TBMCON(TBLSEL,TDTRUE,TDFALS) C C *** read general parameters CALL TBERDI(TID,IROW,ICGRP,IDNGRP,NULL,ISTAT) ! group number CALL TBRRDR(TID,IROW,NINTP,ICGEN,PARINT,NULL,ISTAT) ! gen. parameters C C *** read the star parameters CALL TBERDR(TID,IROW,ICGEN(15),RNST,NULL,ISTAT) ! # stars CALL TBERDR(TID,IROW,ICGEN(16),RNHL,NULL,ISTAT) ! # holes NCOMPS = INT(RNST) NHOLES = INT(RNHL) C C *** get the identification and fit parameters for the stars IF (NCOMPS.GT.0) THEN DO 100 IS = 1, NCOMPS IR = IROW + IS - 1 CALL TBERDI(TID,IR,ICIDN,IDNCMP(IS),NULL,ISTAT) ! ident comp. CALL TBERDI(TID,IR,ICFLG,FLGCMP(IS),NULL,ISTAT) ! flag CALL TBRRDR(TID,IR,NINTC,ICPAR,ROUT,NULL,ISTAT) ! comp. par. FITCMP((IS-1)*6+1) = ROUT(1) FITCMP((IS-1)*6+2) = ROUT(2) FITCMP((IS-1)*6+3) = ROUT(3) FITCMP((IS-1)*6+4) = ROUT(4) FITCMP((IS-1)*6+5) = ROUT(5) FITCMP((IS-1)*6+6) = ROUT(6) 100 CONTINUE ENDIF C C*** get the hole parameters IF (NHOLES.GT.0) THEN DO 200 IH = 1, NHOLES IR = IROW + NCOMPS + IH - 1 CALL TBERDI(TID,IR,ICIDN,IDNHOL(IH),NULL,ISTAT) ! ident CALL TBERDI(TID,IR,ICFLG,FLGHOL(IH),NULL,ISTAT) ! flag CALL TBRRDR(TID,IR,NINTH,ICPAR,ROUT,NULL,ISTAT) ! hole par. FITHOL((IH-1)*3+1) = ROUT(1) FITHOL((IH-1)*3+2) = ROUT(2) FITHOL((IH-1)*3+3) = ROUT(3) 200 CONTINUE ENDIF C RETURN END SUBROUTINE INTWWR(TID,IROW,NCOMP,NHOLES) C+++ C.Purpose: Writes the intermediate table starting from row = IROW. C. The data will be stores in a THREE common blocks to be read by C. calling program. C--- IMPLICIT NONE INTEGER TID ! table identification INTEGER IROW ! row indication where to start INTEGER NCOMP ! number of components INTEGER NHOLES ! number of holes C INCLUDE 'MID_REL_INCL:RFOTDECL.INC/NOLIST' ! array dimensions C INTEGER IR, IS, IH INTEGER ISTAT INTEGER ICGRP INTEGER ICIDN INTEGER ICGEN(NINTP) INTEGER ICFLG INTEGER ICPAR(NINTC) REAL ROUT(NINTC) C DATA ICGRP/1/ DATA ICIDN/2/ DATA ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/ DATA ICFLG/19/ DATA ICPAR/20,21,22,23,24,25/ C C *** write the star parameters DO 100 IS = 1,NCOMP IR = IROW + IS - 1 CALL TBEWRI(TID,IR,ICGRP,IDNGRP,ISTAT) ! write group number CALL TBEWRI(TID,IR,ICIDN,IDNCMP(IS),ISTAT) ! write sort object CALL TBRWRR(TID,IR,NINTP,ICGEN,PARINT,ISTAT) ! write gen. pars. CALL TBEWRI(TID,IR,ICFLG,FLGCMP(IS),ISTAT) ! write the flag C ROUT(1) = FITCMP((IS-1)*6+1) ROUT(2) = FITCMP((IS-1)*6+2) ROUT(3) = FITCMP((IS-1)*6+3) ROUT(4) = FITCMP((IS-1)*6+4) ROUT(5) = FITCMP((IS-1)*6+5) ROUT(6) = FITCMP((IS-1)*6+6) CALL TBRWRR(TID,IR,NINTC,ICPAR,ROUT,ISTAT) ! write object par. 100 CONTINUE C C*** write the hole parameters IF (NHOLES.GT.0) THEN DO 200 IH = 1, NHOLES IR = IROW + NCOMP + IH - 1 CALL TBEWRI(TID,IR,ICGRP,IDNGRP,ISTAT) ! write group number CALL TBEWRI(TID,IR,ICIDN,IDNHOL(IH),ISTAT) ! write the sort object CALL TBRWRR(TID,IR,NINTP,ICGEN,PARINT,ISTAT) ! write gen. pars. CALL TBEWRI(TID,IR,ICFLG,FLGHOL(IH),ISTAT) ! write the flag C ROUT(1) = FITHOL((IH-1)*3+1) ROUT(2) = FITHOL((IH-1)*3+2) ROUT(3) = FITHOL((IH-1)*3+3) CALL TBRWRR(TID,IR,NINTH,ICPAR,ROUT,ISTAT) 200 CONTINUE ENDIF C RETURN END SUBROUTINE INTCWR(TID,IROW,INDEX) C+++ C.Purpose: Writes a ro in the intermediate table at row = IROW. C. The data will be stores in a THREE common blocks to be read by C. calling program. C--- IMPLICIT NONE INTEGER TID ! table identification INTEGER IROW ! row indication where to start INTEGER INDEX ! start index of component in table C INCLUDE 'MID_REL_INCL:RFOTDECL.INC/NOLIST' ! declarations C INTEGER ISTAT INTEGER ICGRP INTEGER ICIDN INTEGER ICGEN(NINTP) INTEGER ICFLG INTEGER ICPAR(NINTC) REAL ROUT(NINTC) C DATA ICGRP/1/ DATA ICIDN/2/ DATA ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/ DATA ICFLG/19/ DATA ICPAR/20,21,22,23,24,25/ C C *** write the component parameters CALL TBEWRI(TID,IROW,ICGRP,IDNGRP,ISTAT) ! write group number CALL TBEWRI(TID,IROW,ICIDN,IDNCMP(INDEX),ISTAT) ! write the sort object CALL TBRWRR(TID,IROW,NINTP,ICGEN,PARINT,ISTAT) ! write gen. parameters CALL TBEWRI(TID,IROW,ICFLG,FLGCMP(INDEX),ISTAT) ! write the flag C ROUT(1) = FITCMP((INDEX-1)*6+1) ! copy comp. parameters ROUT(2) = FITCMP((INDEX-1)*6+2) ROUT(3) = FITCMP((INDEX-1)*6+3) ROUT(4) = FITCMP((INDEX-1)*6+4) ROUT(5) = FITCMP((INDEX-1)*6+5) ROUT(6) = FITCMP((INDEX-1)*6+6) CALL TBRWRR(TID,IROW,NINTC,ICPAR,ROUT,ISTAT) ! write component par. C RETURN END SUBROUTINE INTHWR(TID,IROW,INDEX) C+++ C.Purpose: Writes a ro in the intermediate table at row = IROW. C. The data will be stores in a THREE common blocks to be read by C. calling program. C--- IMPLICIT NONE INTEGER TID ! table identification INTEGER IROW ! row indication where to start INTEGER INDEX ! start index of component in table C INCLUDE 'MID_REL_INCL:RFOTDECL.INC/NOLIST' C INTEGER ISTAT INTEGER ICGRP INTEGER ICIDN INTEGER ICGEN(NINTP) INTEGER ICFLG INTEGER ICPAR(NINTH) REAL ROUT(NINTH) C DATA ICGRP/1/ DATA ICIDN/2/ DATA ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/ DATA ICFLG/19/ DATA ICPAR/20,21,22/ C C *** write the component parameters CALL TBEWRI(TID,IROW,ICGRP,IDNGRP,ISTAT) ! write group number CALL TBEWRI(TID,IROW,ICIDN,IDNHOL(INDEX),ISTAT) ! write the sort object CALL TBRWRR(TID,IROW,NINTP,ICGEN,PARINT,ISTAT) ! write gen. parameters CALL TBEWRI(TID,IROW,ICFLG,FLGHOL(INDEX),ISTAT) ! write the flag C ROUT(1) = FITHOL((INDEX-1)*3+1) ! copy comp. parameters ROUT(2) = FITHOL((INDEX-1)*3+2) ROUT(3) = FITHOL((INDEX-1)*3+3) CALL TBRWRR(TID,IROW,NINTH,ICPAR,ROUT,ISTAT) ! write component par. C RETURN END