C @(#)maktab.for	19.1 (ES0-DMD) 02/25/03 14:29:42
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
