C @(#)specenter.for	19.1 (ESO-DMD) 02/25/03 14:29:43
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 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence 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 SPECEN
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  19:10 - 3 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C   PROGRAM SPECENTER
C
C.KEYWORDS
C
C   LINE CENTER
C
C.PURPOSE
C
C   LINE CENTERING. INPUT/OUTPUT IN TABLE
C
C   COMMAND
C   CENTER/method  image table EMISSION/ABSORPTION
C
C.ALGORITHM
C
C   LINE CENTER IS FOUND BY
C   MAXI/MINI       - POSITION OF THE MAXIMUM/MINIMUM VALUE  ! Not anymore
C   MOMENT          - POSITION OF THE FIRST MOMENT (Modif. P.Ballester 901127)
C   GAUSSIAN        - CENTER OF THE FITTED GAUSSIAN
C   GRAVITY         - GRAVITY CENTER OF THE 2 HIGHEST PIXELS
C                     WITH RESPECT TO THE THIRD ONE
C
C.INPUT/OUTPUT
C
C   TABLE COLUMNS :
C   :XSTART - FIRST COORD   INPUT
C   :XEND   - SECOND COORD  INPUT
C   :XCEN   - COMPUTED CENTER
C   :YSTART - IMAGE VALUE FIRST COORD   INPUT
C   :YEND   - IMAGE VALUE SECOND COORD  INPUT
C   :PEAK   - MAXIMUM VALUE
C   :YFIT   - FITTED MAXIMUM IN GAUSSIAN METHOD ONLY
C   :FWHM   - FWHM IN GAUSSIAN METHOD ONLY
C
C
C.MODIFICATIONS
C  [2.1]      INCLUDE FWHM AND FORMAT FOR NON EXISTING COLUMNS
C  [2.1]      INCLUDE :YSTART, :YEND AND :YFIT
C
C-----------------------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER   MADRID
      INTEGER   I,I1,I2,IACT,IAV,ICY,IFAIL,II1,IMETH
      INTEGER   IMODE
      INTEGER*8 IP
      INTEGER   ISI,IYCOOR,NAXIS,NCOL,NCOLS,NL
      INTEGER   NOUT,NPL,NROW,NSC
      INTEGER   NPIX(2),KUN,KNUL,IMNO,TID,NAC,NAR
      INTEGER   STATUS,IC(8)
C
      REAL VY
      REAL ACOE(4),START(2),STEP(2),VALUE(8),W1(400),W2(400)
      DOUBLE PRECISION DSTART(2), DSTEP(2)
C
      CHARACTER FRAME1*80,METH*2
      CHARACTER TABLE*80,TABUNT(8)*16,TABLAB(8)*16,IEA*1
      CHARACTER FORM(8)*6,LINE*72
      CHARACTER IDENT*72,CUNIT*48,LABEL2*16,COMLIN*80
C
      LOGICAL NULL(2),NULLY,FLAG
C
      INCLUDE  'MID_INCLUDE:TABLES.INC'
      COMMON /VMR/MADRID(1)
      INCLUDE  'MID_INCLUDE:TABLED.INC'
C
      DATA NULLY/.FALSE./
      DATA NCOLS/6/
      DATA NOUT/4/
      DATA TABUNT/' ',' ',' ',' ',' ',' ',' ',' '/
      DATA TABLAB/'XSTART','XEND','XCEN','YSTART','YEND','PEAK',
     +     'YFIT','FWHM'/
      DATA FORM/'E13.5','E13.5','E13.5','G15.5','G15.5','G15.5','G15.5',
     +     'E13.5'/
      DATA LABEL2/'Y'/
      DATA LINE/' Column ...... not present in table '/
C
C  initialize
C
      CALL STSPRO('SPECENTER')
      CALL STKRDC('P3',1,1,1,IACT,IEA,KUN,KNUL,STATUS)
      IF (IEA.EQ.'E') THEN
          IMODE  = 1
      ELSE
          IMODE  = 0
      END IF
      CALL STKRDC('MID$CMND',1,1,80,IACT,COMLIN,KUN,KNUL,STATUS)
      METH   = COMLIN(11:12)
      IF (METH.EQ.'GA') THEN
          IMETH  = -1
          NCOLS  = 8
          NOUT   = 6
      ELSE
          IF (METH.EQ.'GR') THEN
              IMETH  = 0
          ELSE
              IMETH  = 1
          END IF
      END IF
C
C  read image
C
      CALL STKRDC('P1',1,1,80,IACT,FRAME1,KUN,KNUL,STATUS)
      CALL STIGET(FRAME1,10,0,1,2,NAXIS,NPIX,DSTART,DSTEP,IDENT,
     +            CUNIT,IP,IMNO,STATUS)
      START(1) = DSTART(1)
      START(2) = DSTART(2)
      STEP(1)  = DSTEP(1)
      STEP(2)  = DSTEP(2)
      IF (NAXIS.GT.1 .AND. NPIX(2).GT.1) THEN
          IYCOOR = 1
      ELSE
          IYCOOR = 0
          NL     = 1
          NPIX(2) = 1
      END IF
      NPL    = NPIX(1)
      ISI    = NPIX(1)*NPIX(2)
      II1    = 16*NAXIS
      TABUNT(1) = CUNIT(II1+1:II1+16)
      TABUNT(2) = TABUNT(1)
      TABUNT(3) = TABUNT(1)
      TABUNT(4) = CUNIT(1:16)
      TABUNT(5) = TABUNT(4)
      TABUNT(6) = TABUNT(4)
      TABUNT(7) = TABUNT(4)
      TABUNT(8) = TABUNT(1)
C
C  get table name for storage of data
C
      CALL STKRDC('P2',1,1,80,IACT,TABLE,KUN,KNUL,STATUS)
      CALL TBTOPN(TABLE,2,TID,STATUS)
      CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,STATUS)
      DO 10 IAV = 1,NCOLS
          CALL TBLSER(TID,TABLAB(IAV),IC(IAV),STATUS)
          IF (IAV.LE.2) THEN
              IF (IC(IAV).EQ.-1) THEN
                  WRITE (LINE,9000) TABLAB(IAV) (1:6)
                  CALL STTPUT(LINE,STATUS)
                  GO TO 30
              END IF
          ELSE
              IF (IC(IAV).EQ.-1) THEN
                  CALL TBCINI(TID,D_R4_FORMAT,1,FORM(IAV),TABUNT(IAV),
     +                        TABLAB(IAV),IC(IAV),STATUS)
              END IF
          END IF
   10 CONTINUE
      IF (IYCOOR.EQ.1) THEN
          CALL TBLSER(TID,LABEL2,ICY,STATUS)
          IF (ICY.EQ.-1) THEN
              WRITE (LINE,9000) ':Y     '
              CALL STTPUT(LINE,STATUS)
              GO TO 30
          END IF
      END IF
C
C  loop on input - pairs of points
C
      DO 20 I = 1,NROW
          CALL TBSGET(TID,I,FLAG,STATUS)
          IF (FLAG) THEN
              CALL TBRRDR(TID,I,2,IC,VALUE,NULL,STATUS)
              IF (IYCOOR.EQ.1) THEN
                  CALL TBERDR(TID,I,ICY,VY,NULLY,STATUS)
                  NL     = (VY-START(2))/STEP(2) + 1
              END IF
              IF ((.NOT.NULL(1)) .AND. (.NOT.NULL(2)) .AND.
     +            (.NOT.NULLY)) THEN
                  I1     = (VALUE(1)-START(1))/STEP(1) + 1
                  I2     = (VALUE(2)-START(1))/STEP(1) + 1
                  CALL FIND(MADRID(IP),NPIX(1),NPIX(2),
     +                      START,STEP,NL,I1,
     +                      I2,IMODE,IMETH,VALUE(3),VALUE(6),
     +                      IFAIL,W1,
     +                      W2,ACOE,VALUE(4),VALUE(5))
                  VALUE(7) = ACOE(1)
                  VALUE(8) = ACOE(3)
                  IF (IFAIL.EQ.0) THEN
                      CALL TBRWRR(TID,I,NOUT,IC(3),VALUE(3),
     +                            STATUS)
                  ELSE
                      CALL TBEDEL(TID,I,IC(3),STATUS)
                      CALL TBEDEL(TID,I,IC(4),STATUS)
                      CALL TBEDEL(TID,I,IC(5),STATUS)
                      CALL TBEDEL(TID,I,IC(6),STATUS)
                      IF (IMETH.EQ.-1) THEN
                          CALL TBEDEL(TID,I,IC(7),STATUS)
                          CALL TBEDEL(TID,I,IC(8),STATUS)
                      END IF
                  END IF
              ELSE
                  CALL TBEDEL(TID,I,IC(3),STATUS)
                  CALL TBEDEL(TID,I,IC(4),STATUS)
                  CALL TBEDEL(TID,I,IC(5),STATUS)
                  CALL TBEDEL(TID,I,IC(6),STATUS)
                  IF (IMETH.EQ.-1) THEN
                      CALL TBEDEL(TID,I,IC(7),STATUS)
                      CALL TBEDEL(TID,I,IC(8),STATUS)
                  END IF
              END IF
          END IF
   20 CONTINUE
C
C  exit
C
   30 CALL TBTCLO(TID,STATUS)
      CALL STSEPI
      STOP 
 9000 FORMAT (A)
      END

