C @(#)maktab.for 17.1.1.1 (ES0-DMD) 01/25/02 17:56:13 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 program MAKTAB C------------------------------------------------------------------------------ C Makes input table in proper format for DBLEND when working with combined C input mode C C Possible inputs: C fit option W, input table BTAB with center positions in column :X, input C table ttemp with other info in normal form. C fit option S, FWHM value to use in BTAB, input table ttemp with other info C in normal form. C fit option A, centers in input table ttemp, FWHM's in keyword FWHM(6) C C Output: C table ttemp with all info in proper form for DBLEND C------------------------------------------------------------------------------ C C variable declarations C implicit none integer MADRID INTEGER ACOL,AROW INTEGER ACTVAL REAL BDATA(6,4) REAL CENT(6) INTEGER COL(4) INTEGER CPIX(6) character*16 CUNIT REAL DATA(50000) INTEGER DTID,BTID,TID character*1 FOPT REAL FWHM(6) character*72 IDENT character*60 IMAGE character*12 INTAB INTEGER KUN,KNUL REAL MAXVAL(6) INTEGER NAXIS INTEGER NCOLD,NROWD,NCOLB,NROWB,NROWT INTEGER NDATA INTEGER NN INTEGER NO INTEGER NPIX(2) INTEGER NSC logical NULL(4) REAL PAR(4) INTEGER*8 PNTR REAL SIDE(2) DOUBLE PRECISION START(2),STEP(2) INTEGER STAT character*72 STRING REAL TABLE(22,4) REAL TDATA(16,4) INTEGER XCOL REAL YVAL INTEGER II,JJ,KK,MM common /VMR/MADRID(1) data COL/1,2,3,4/ C connect to MIDAS environment call stspro('MAKTAB') C get inputs from keywords call stkrdc('BTAB',1,1,12,ACTVAL,INTAB,KUN,KNUL,STAT) call stkrdc('FITOPT',1,1,1,ACTVAL,FOPT,KUN,KNUL,STAT) call stkrdc('IN_A',1,1,60,ACTVAL,IMAGE,KUN,KNUL,STAT) call upcas(FOPT,FOPT) C rename ttemp to dummy name call stfrnm('ttemp.tbl','ttemp2.tbl',STAT) C read in values to be saved call tbtopn('ttemp2.tbl',2,DTID,STAT) call tbiget(DTID,NCOLD,NROWD,NSC,ACOL,AROW,STAT) do II = 1,NROWD call tbrrdr(DTID,II,4,COL,PAR,NULL,STAT) do JJ = 1,4 TDATA(II,JJ) = PAR(JJ) end do end do C close old table call tbtclo(DTID,STAT) C open image file call stiget(IMAGE,10,0,1,2,NAXIS,NPIX,START,STEP, & IDENT,CUNIT,PNTR,NO,STAT) C for option W, open table with center positions and read them in if (FOPT.EQ.'W') then call tbtopn(INTAB,0,BTID,STAT) call tbiget(BTID,NCOLB,NROWB,NSC,ACOL,AROW,STAT) call tblser(BTID,'X',XCOL,STAT) !could be ':X' instead do II = 1,NROWB call tberdr(BTID,II,XCOL,CENT(II),NULL,STAT) end do C read in the image if (NAXIS.eq.1) then NDATA = NPIX(1) call read1d(MADRID(PNTR),NPIX(1),DATA) else if (NAXIS.eq.2.and.(NPIX(1).eq.1.or.NPIX(2).eq.1)) then if (NPIX(1).eq.1) then NDATA = NPIX(2) START(1) = START(2) STEP(1) = STEP(2) else NDATA = NPIX(1) end if call read2d(MADRID(PNTR),NPIX,DATA,NDATA) else STRING = ' Input image is not a suitable type' call sttput(STRING,STAT) go to 9999 end if C determine pixel positions of centers do II = 1,NROWB CPIX(II)=nint((CENT(II)-real(START(1)))/real(STEP(1)))+1 end do C get data values at centers do II = 1,NROWB MAXVAL(II) = DATA(CPIX(II)) end do C construct new table rows do II = 1,NROWB BDATA(II,1) = CENT(II) BDATA(II,2) = MAXVAL(II) BDATA(II,3) = float(CPIX(II)) BDATA(II,4) = 1.0 end do C construct table NROWT = NROWD + NROWB do JJ = 1,4 do II = 1,4 TABLE(II,JJ) = TDATA(II,JJ) end do KK = 4 do II = 5,NROWT if (mod(II,3).eq.0) then TABLE(II,JJ) = BDATA((II/3)-1,JJ) else KK = KK+1 TABLE(II,JJ) = TDATA(KK,JJ) end if end do end do C for option S, interpret number in INTAB else if (FOPT.eq.'S') then read (INTAB,*) FWHM(1) !test this C construct new table rows NROWB = 0 do II = 5,NROWD SIDE(1) = TDATA(II,1) - (FWHM(1)/2) SIDE(2) = SIDE(1) + FWHM(1) YVAL = TDATA(II,2) / 2 do JJ = 1,2 NROWB = NROWB + 1 BDATA(NROWB,1) = SIDE(JJ) BDATA(NROWB,2) = YVAL BDATA(NROWB,3) = anint((SIDE(JJ)-real(START(1))) & /real(STEP(1)))+1. BDATA(NROWB,4) = 1.0 end do end do C construct new table NROWT = NROWD + NROWB do JJ = 1,4 do II = 1,4 TABLE(II,JJ) = TDATA(II,JJ) end do KK = 4 MM = 0 do II = 5,NROWT if (mod(II,3).eq.0) then KK = KK+1 TABLE(II,JJ) = TDATA(KK,JJ) else MM = MM+1 TABLE(II,JJ) = BDATA(MM,JJ) end if end do end do C for option A, get FWHM from keyword else if (FOPT.eq.'A') then call stkrdr('FWHM',1,6,ACTVAL,FWHM,KUN,KNUL,STAT) C construct new table rows NROWB = 0 do II = 5,NROWD SIDE(1) = TDATA(II,1) - (FWHM(II-4)/2) SIDE(2) = SIDE(1) + FWHM(II-4) YVAL = TDATA(II,2) / 2 do JJ = 1,2 NROWB = NROWB + 1 BDATA(NROWB,1) = SIDE(JJ) BDATA(NROWB,2) = YVAL BDATA(NROWB,3) = anint((SIDE(JJ)-real(START(1))) & /real(STEP(1)))+1. BDATA(NROWB,4) = 1.0 end do end do C construct new table NROWT = NROWD + NROWB do JJ = 1,4 do II = 1,4 TABLE(II,JJ) = TDATA(II,JJ) end do KK = 4 MM = 0 do II = 5,NROWT if (mod(II,3).eq.0) then KK = KK+1 TABLE(II,JJ) = TDATA(KK,JJ) else MM = MM+1 TABLE(II,JJ) = BDATA(MM,JJ) end if end do end do C invalid fit option used: else C write out error message STRING = 'fit option '// FOPT // + ' incompatible with B input option' call sttput(STRING,STAT) C deposit status parameter in keyword PAR(1) = 1 call stkwri('STATUS',PAR(1),1,1,KUN,STAT) !takes KNUL par also? C put ttemp back where it was and exit call stfrnm('ttemp2.tbl','ttemp.tbl',STAT) call stsepi end if C write the table out call tbtini('ttemp',1,1,4,NROWT,TID,STAT) call tbcini(TID,10,1,'G13.6',CUNIT,'X_AXIS',NN,STAT) call tbcini(TID,10,1,'G13.6','COUNTS','Y_AXIS',NN,STAT) call tbcini(TID,10,1,'I5','PIXEL','LINE_NO',NN,STAT) call tbcini(TID,10,1,'I5','PIXEL','PIXEL_NO',NN,STAT) do II = 1,NROWT do JJ = 1,4 PAR(JJ) = TABLE(II,JJ) end do call tbrwrr(TID,II,4,COL,PAR,STAT) end do call tbtclo(TID,STAT) C delete old table call STFDEL('ttemp2.tbl',STAT) C finished 9999 call stsepi end