Next: A Table Application in
Up: Examples Using Table Data
Previous: Examples Using Table Data
The following example is a copy of
a program in the ROMAFOT stellar photometry package. It reads the
intermediate table, obtained after various fitted and verification command
in the ROMAFOT package, and creates the final registration table,
containing the final results. The program is tied into the MIDAS environment
via the following procedure regist.prg:
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++
!.IDENTIFICATION: REGIST.PRG
!.PURPOSE: Privat register command for the ROMAFOT package
!.USE: @@ regist int_tab reg_tab [wnd_opt] [obj_opt]
!.AUTHOR: Rein H. Warmels, ESO Garching
!.VERSION: 890614 RHW Creation
!.VERSION: 890803 RHW Implementation of table file system
!.VERSION: 900515 RHW Copied to own directory as an example
! ----------------------------
DEFINE/PARAM P1 ? TBL "Enter input intermediate table: "
DEFINE/PARAM P2 ? TBL "Enter output registration table: "
DEFINE/PARAM P3 A C "Enter window option: "
DEFINE/PARAM P4 N C "Enter object option: "
!
WRITE/KEYWORD IN_A {P1}
WRITE/KEYWORD OUT_A {P2}
WRITE/KEYWORD INPUTC/C/1/1 {P3}
WRITE/KEYWORD INPUTC/C/2/1 {P4}
!
RUN REGIST
To run the application execute the procedure via
Midas 001> @@ regist int_tab reg_tab [wnd_opt] [obj_opt]
The program is written in standard Fortran 77 code with the exceptions
which are taken care of by the ESO provided preprocessor. This preprocessor
is not needed on a VAX/VMS machine! In the code you will find a reference
to common block MID_INCLUDE:RFOTDECL.INC which contains all relevant
variables. In order to keep this example within reasonable limits this
common block is not listed.
PROGRAM REGIST
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: RFOTREGIST
C.PURPOSE: Compute the absolute quantities and store the results
C in the final MIDAS table
C.AUTHOR: R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola
C Osservatorio Astronomico di Roma
C.VERSION: 16.09.87 RB First running version at ESO (outside MIDAS)
C 17.12.87 RHW Installation in MIDAS
C 24.10.88 RB New version
C 14.06.89 RHW Rewritten for the portable MIDAS version
C Inclusion of MIDAS tables
C----------------------------------------------------------------------
IMPLICIT NONE
INTEGER NMAX
INTEGER NCPAR
INTEGER NRREG
PARAMETER (NMAX=256)
PARAMETER (NCPAR=12)
PARAMETER (NRREG=10000)
C ***
INTEGER ICPAR(NCPAR)
INTEGER IDENT(NRREG)
INTEGER IROW, ICIDN, IREGI, IGRP
INTEGER ISTAT, IAC, IAV
INTEGER I, IS, IH, IC, IK, IVN
INTEGER KUN, KNUL, KONT
INTEGER IPX, IPY
INTEGER K7
INTEGER LF9
INTEGER MADRID(1)
INTEGER NRINT,NCINT
INTEGER NACINT,NARINT,NSINT
INTEGER NOBJ, NGRP, NSR
INTEGER NCP, NHL, NCOM
INTEGER NMAX
INTEGER NCPAR, NRREG, NCREG
INTEGER REGTYP, REGCOL
INTEGER TIDINT
INTEGER TIDREG
C ***
REAL ALTMIN
REAL B, BETA
REAL BU(NMAX)
REAL DATR(NCPAR,NRREG)
REAL D1, D2, D3, D4, D6, D7
REAL FOG, FAT, FOND, FL
REAL GRE
REAL P(NMAX)
REAL SIGMA, SOFOT, SAT
REAL PP1, PP2
REAL SQM(NMAX), SIQ(NMAX)
REAL U
REAL V
REAL VOL
C ***
CHARACTER*80 STRING
CHARACTER*60 INTFIL
CHARACTER*60 REGFIL
CHARACTER*16 LABEL(NCPAR),REGLAB
CHARACTER*16 UNIT(NCPAR),REGUNI
CHARACTER*16 REGFOR
CHARACTER*16 FORMR4,FORMI4
CHARACTER*1 SST, CAR
C ***
INCLUDE 'MID_INCLUDE:RFOTDECL.INC' ! romafot common block
INCLUDE 'MID_INCLUDE:ST_DEF.INC' ! ST definitions
COMMON /VMR/MADRID(1) ! DON'T FORGET !!!
INCLUDE 'MID_INCLUDE:ST_DAT.INC' ! ST assignments
C ***
DATA ICIDN/1/
DATA FORMI4/'I6'/
DATA FORMR4/'E12.4'/
DATA LABEL /'X ', 'Y ', 'INT ', 'BG ',
2 'MAG1 ', 'MAG2 ', 'MAG3 ', 'MAG_CNV ',
3 'SIGMA ', 'BETA ', 'SIQ ', 'CHI_SQ '/
DATA UNIT /'PIXEL ', 'PIXEL ', ' ', ' ',
2 'MAG. ', 'MAG. ', 'MAG. ', 'MAG. ',
3 ' ', ' ', ' ', ' '/
C ***
9001 FORMAT('*** INFO: Window ',I5,' not fitted')
9002 FORMAT('*** INFO: Window ',I5,' not registered (no conv. ',
* 'or already regist.)')
C
C *** start the code
CALL STSPRO('REGISTER')
C
C *** get the input intermediate table and output registration table
CALL STKRDC('IN_A',1,1,60,IAC,INTFIL,KUN,KNUL,ISTAT)
CALL STKRDC('OUT_A',1,1,60,IAC,REGFIL,KUN,KNUL,ISTAT)
C
C ***
CALL TBTOPN(INTFIL,F_I_MODE,TIDINT,ISTAT) ! open interm. table
CALL TBIGET(TIDINT,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT) ! info
IF (NRINT.EQ.0) THEN ! no rows in table
STRING = '*** FATAL: There are no data in the intermediate '//
2 'table'
CALL STETER(9,STRING)
ENDIF
C
C *** create the registration table
NCREG = NCPAR + 1
CALL TBTINI(REGFIL,0,F_O_MODE,NCREG,NRREG,TIDREG,ISTAT)
C
REGTYP = D_I4_FORMAT
REGFOR = FORMI4
REGUNI = ' '
REGLAB = 'IDENT'
CALL TBCINI(TIDREG,REGTYP,1,REGFOR,REGUNI,
2 REGLAB,REGCOL,ISTAT) ! create ident column
C
DO 101 I = 1,NCPAR ! loop through columns
ICPAR(I) = I + 1
REGTYP = D_R4_FORMAT
REGFOR = FORMR4
REGUNI = UNIT(I)
REGLAB = LABEL(I)
CALL TBCINI(TIDREG,REGTYP,1,REGFOR,REGUNI,
2 REGLAB,REGCOL,ISTAT) ! create the columns
101 CONTINUE
C
C *** read the window and object option
CALL STKRDC('INPUTC',1,1,1,IAV,CAR,KUN,KNUL,ISTAT)
CALL STKRDC('INPUTC',1,2,1,IAV,SST,KUN,KNUL,ISTAT)
C
C *** read the table descriptor of the intermedaite table
CALL INTDRD(TIDINT,NGRP,NOBJ,NSR,SAT,FAT,SIGMA,BETA,SOFOT,
2 ALTMIN,FOG)
C
C *** do the work
KONT = 0
IROW = 1
IGRP = 1
C
1001 CONTINUE ! loop through the rows
CALL INTWRD(TIDINT,IROW,NCP,NHL) ! read the groups
D1 = PARINT(1)
D2 = PARINT(2)
V = PARINT(3)
B = PARINT(4)
U = PARINT(5)
D3 = PARINT(6)
D4 = PARINT(7)
P(1) = PARINT(8)
P(2) = PARINT(9)
P(3) = PARINT(10)
BETA = PARINT(11)
D7 = PARINT(12)
D6 = PARINT(13)
FL = PARINT(14)
C
DO 1011 IS = 1,NCP ! copy the components
P((IS-1)*4+4) = FITCMP((IS-1)*6+1)
P((IS-1)*4+5) = FITCMP((IS-1)*6+2)
P((IS-1)*4+6) = FITCMP((IS-1)*6+3)
P((IS-1)*4+7) = FITCMP((IS-1)*6+4)
SQM(IS) = FITCMP((IS-1)*6+5)
SIQ(IS) = FITCMP((IS-1)*6+6)
1011 CONTINUE
C
DO 1012 IH = 1,NHL ! copy the holes
BU((IH-1)*3+1) = FITHOL((IH-1)*3+1)
BU((IH-1)*3+2) = FITHOL((IH-1)*3+2)
BU((IH-1)*3+3) = FITHOL((IH-1)*3+3)
1012 CONTINUE
C
IREGI = 0
IF (CAR.EQ.'A') THEN
IREGI = 1
ENDIF
IF (IREGI.EQ.1) THEN
IPX = INT(D1)
IPY = INT(D2)
NCOM = 0
LF9 = 0
C
DO 1013 IC = 1,NCP
K7 = (IC-1)*4 +4
IVN = FLGCMP(IC)
IF (IVN.EQ.1 .OR. CAR.EQ.'A' .OR. IVN.EQ.2) THEN
IF (IVN.EQ.1 .OR. (IVN.EQ.2 .AND. SST.EQ.''Y')) THEN
C ***
CALL STTPUT('HERE WE WILL COMPUTE THE FINAL'//
2 ' RESULTS,ISTAT)
C
C *** copy back to register array
IDENT(KONT) = IDNGRP*100+(IDNCMP(IC)-100)
DATR(1,KONT) = PP1
DATR(2,KONT) = PP2
DATR(3,KONT) = P(K7)
DATR(4,KONT) = FOND
DATR(5,KONT) = V
DATR(6,KONT) = B
DATR(7,KONT) = U
DATR(8,KONT) = VOL
DATR(9,KONT) = P(K7+3)
DATR(10,KONT) = BETA
DATR(11,KONT) = SIQ(IC)
DATR(12,KONT) = SQM(IC)
END IF
1013 CONTINUE
C
ELSE
IF (GRE.EQ.0) THEN
WRITE (STRING,9001) IC
ELSE
WRITE(STRING,9002) IC
END IF
CALL STTPUT(STRING,ISTAT)
END IF
C
IROW = IROW + NCP + NHL ! row index for next group
IF (IROW.LE.NRINT) THEN ! did we have all rows (= groups)
GO TO 1001 ! NO
ENDIF
C
C *** fill the registration table
DO 102 IK = 1,KONT
CALL TBERWRI(TIDREG,IK,ICIDN,IDENT(IK),ISTAT)
CALL TBRWRR(TIDREG,IK,NCPAR,ICPAR,DATR(1,IK),ISTAT)
102 CONTINUE
CALL TBSINI(TIDREG,ISTAT) ! initialize the selecion
CALL TBTCLO(TIDREG,ISTAT) ! close the table
CALL STSEPI ! over and out
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,STAT)
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 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
C. by 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_INCLUDE:RFOTDECL.INC/NOLIST'
C
INTEGER ISTAT
INTEGER IS, 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
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 nr.
CALL TBRRDR(TID,IROW,NINTP,ICGEN,PARINT,NULL,ISTAT) ! gen. par.
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 cp.
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
Next: A Table Application in
Up: Examples Using Table Data
Previous: Examples Using Table Data