C===========================================================================
C Copyright (C) 1995-2011 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
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: CENTERROW
C.PURPOSE:        Interactive line centering. output stored in a table
C.LANGUAGE:       F77+ESOext
C.AUTHOR:         J.D.Ponz
C.KEYWORDS:       Line, centre
C.ALGORITHM:      Line center is found by:
C                 maximum/minimum - position of the maximum/minimum value
C                 gaussian        - center of the fitted gaussian
C                 gravity         - gravity center of the 2 highest pixels
C                                   with respect to the third one
C.INPUT/OUTPUT:   Interactive input via the graphics cursor
C                 table columns :
C                 :XSTART - first cursor input
C                 :XEND   - second cursor input
C                 :XCEN   - computed center
C                 :YSTART - image value for first cursor input
C                 :YEND   - image value for second cursor input
C                 :PEAK   - maximum value
C                 :YFIT   - fitted maximum in gaussian method only
C                 :FWHM   - fwhm in gaussian method only
C 
C.OJO:	to increase the size of the interval, increment all the
C arrays which currently have dimension = 2048 (031112)
C SW1, SW2, W1, W2, WEIGHT
C 
C.VERSION: 840328  JDP  Creation   
C.VERSION: 880703  RHW  ESO-FORTRAN Conversion 
C.VERSION: 900430  RHW  Change to standard graphic interfaces 
C 
C 110629	last modif
C-----------------------------------------------------------------
C 
      PROGRAM   SPCNTR

      IMPLICIT  NONE

      INTEGER   MADRID
      INTEGER   I1,I2,IAC,IACT,IAV,IFAIL,II,II1,IMETH,NPTS
      INTEGER   IMODE,IPL1,IPL2,ISEQ,ISORT,ISTAT
      INTEGER   L,NAXIS,NCOLS,NCOUNT,NNCOL,NPL,NL
      INTEGER   NVAL, NSIZE(2)
      INTEGER   IMNOI, IMNOT, IMNOW
      INTEGER   IMAGE(4)
      INTEGER   NPIX(3),NN, INP
      INTEGER   KEY
      INTEGER   APPFLG
      INTEGER   STATUS,IC(8)
      INTEGER   KUN, KNUL, TID,ACOL, AROW
      INTEGER   ACCESS, PLMODE
      INTEGER   LTYPE, STYPE, BIN

      INTEGER*8 PNTRI, PNTRW, PNTRT

      REAL      SXY,X1,X2,XYS,YOFF
      REAL      XCUR,YCUR,RRBUF(5)
      REAL      RMAGE(4), SVALUE(8), SW1(2048), SW2(2048)

      DOUBLE PRECISION VALUE(8),W1(2048),W2(2048),ACOE(4)
      DOUBLE PRECISION START(3),STEP(3)
      DOUBLE PRECISION DXYS, DSXY

      CHARACTER NAME*60,INFO*60,METH*2
      CHARACTER TABLE*64,TABU(8)*16,TABL(8)*16,IEA*1
      CHARACTER CLINE*72,HEAD1*72,HEAD2*72,FORM(8)*6,PROMPT*72,IAPP*1
      CHARACTER IDENT*72,CUNIT*48,COML*80

      INCLUDE   'MID_INCLUDE:ST_DEF.INC/NOLIST' 
      COMMON    /VMR/MADRID(1)
      INCLUDE   'MID_INCLUDE:ST_DAT.INC/NOLIST' 
C
      DATA      NCOLS/6/
      DATA      STYPE/5/
      DATA      BIN/0/
      DATA      YOFF/0.0/
      DATA      ACCESS/1/
      DATA      PLMODE/-1/
      DATA      NPIX/1,1,1/, STEP/1.0,1.0,1.0/, START/0.0,0.0,0.0/

      DATA      TABU/' ',' ',' ',' ',' ',' ',' ',' '/
      DATA      TABL/'START','END','CENTER','INT_START','INT_END',
     +               'INT_PEAK','INT_FIT','FWHM'/
      DATA      FORM/'F10.3','F10.3','F10.3','G15.5','G15.5','G15.5',
     +               'G15.5','F10.3'/
      DATA      HEAD1/
     +  '     start         end        center     pixel_value    FWHM'/
      DATA      HEAD2/
     +  '     start         end        center     pixel_value'/
      DATA      PROMPT/' Ready for cursor input ...'/
C
C
      CALL STSPRO('CLINE')                                       !  initialize
      CALL STKRDC('PLCDATA',1,1,60,IACT,INFO,KUN,KNUL,STATUS)
      L      = INDEX(INFO//' ',' ') - 1
      NAME  = INFO(1:L)
C
      CALL STKRDC('P3',1,1,1,IACT,IEA,KUN,KNUL,STATUS)
      CALL UPCAS(IEA,IEA)
      IF (IEA.EQ.'E') THEN
         IMODE  = 1
      ELSE
         IMODE  = 0
      END IF
C
      CALL STKRDC('MID$CMND',1,1,80,IACT,COML,KUN,KNUL,STATUS)
      METH   = COML(11:12)
      IF (METH.EQ.'GA') THEN
         IMETH  = -1
         NCOLS  = 8
      ELSE
         IF (METH.EQ.'GR') THEN
            IMETH  = 0
         ELSE
            IMETH  = 1
         END IF
      END IF
C
      CALL STKRDC('P4',1,1,1,IACT,IAPP,KUN,KNUL,STATUS)
      CALL UPCAS(IAPP,IAPP)
      IF (IAPP.EQ.'A') THEN
         APPFLG = 1
      ELSE
         APPFLG = 0
      END IF
      ISEQ   = 0
C
C *** read image
      CALL STFOPN(NAME,D_R4_FORMAT,0,F_IMA_TYPE,IMNOI,ISTAT)
      CALL STDRDI(IMNOI,'NAXIS',1,1,IAC,NAXIS,KUN,KNUL,ISTAT)
      CALL STDRDI(IMNOI,'NPIX',1,NAXIS,IAC,NPIX,KUN,KNUL,ISTAT)
      CALL STDRDD(IMNOI,'START',1,NAXIS,IAC,START,KUN,KNUL,ISTAT)
      CALL STDRDD(IMNOI,'STEP',1,NAXIS,IAC,STEP,KUN,KNUL,ISTAT)
      CALL STDRDC(IMNOI,'IDENT',1,1,72,IAC,IDENT,KUN,KNUL,ISTAT)
      CALL STDRDC(IMNOI,'CUNIT',1,1,64,IAC,CUNIT,KUN,KNUL,ISTAT)
C
      NPL     = NPIX(1)
      NL      = NPIX(2)
      II1     = 16*NAXIS
      NVAL    = NPIX(2)
C
C *** allocate virtual memory for a single line of the frame
      CALL PTKRDR('PIXEL',4,IAC,RMAGE)
CC above call = CALL STKRDR('PLRGRAP',25,4,IAV,RMAGE,KUN,KNUL,ISTAT)
      IMAGE(1) = RMAGE(1)
      IMAGE(2) = RMAGE(2)
      IMAGE(3) = RMAGE(3)
      IMAGE(4) = RMAGE(4)
      IF (IMAGE(3).EQ.IMAGE(4)) THEN
         II = (IMAGE(3)-1)*NPL + 1
         CALL STFMAP(IMNOI,F_I_MODE,II,NPL,IAC,PNTRW,ISTAT)
         SXY  = STEP(1)
         XYS  = START(1)
         DSXY = STEP(1)
         DXYS = START(1)
      ELSE
C                                                        ! here for the columns
         NN = NPIX(1)*NPIX(2)   
         CALL STFMAP(IMNOI,F_I_MODE,1,NN,IAC,PNTRI,ISTAT)
         CALL STFCRE('MIDTRAN',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,
     +               NN,IMNOT,ISTAT)
         CALL STFMAP(IMNOT,F_X_MODE,1,NN,IAV,PNTRT,ISTAT)
         NSIZE(1) = 128
         NSIZE(2) = 256
         CALL LINCOL(MADRID(PNTRI),NPIX,NSIZE,MADRID(PNTRT))  ! transpose frame
         CALL STFUNM(IMNOI,ISTAT)
C
         IF (NVAL.LT.512) NVAL = 512
         CALL STFCRE('PLOTWORK', D_R4_FORMAT,F_X_MODE, F_IMA_TYPE,
     +               NVAL,IMNOW,ISTAT)                   ! create scratch frame	
         CALL STFMAP(IMNOW,F_X_MODE,1,NVAL,IAC,PNTRW,ISTAT)
         II = (IMAGE(1)-1)*NL
         PNTRT = PNTRT + II
         CALL COPYF(MADRID(PNTRT),MADRID(PNTRW),NVAL)       ! copy right column
         CALL STFUNM(IMNOT,ISTAT)
         SXY  = STEP(2)
         XYS  = START(2)
         DSXY = STEP(2)
         DXYS = START(2)
      ENDIF
C
      TABU(1) = CUNIT(II1+1:II1+16)
      TABU(2) = TABU(1)
      TABU(3) = TABU(1)
      TABU(4) = CUNIT(1:16)
      TABU(5) = TABU(4)
      TABU(6) = TABU(4)
      TABU(7) = TABU(4)
      TABU(8) = TABU(1)
C
C *** get table name for storage of data
      CALL STKRDC('P2',1,1,64,IACT,TABLE,KUN,KNUL,STATUS)
      IF (APPFLG.EQ.0) THEN
         CALL TBTINI(TABLE,F_TRANS,F_O_MODE,10,200,TID,STATUS)
         DO 10 IAV = 1,NCOLS
            CALL TBCINI(TID,D_R4_FORMAT,1,FORM(IAV),TABU(IAV),
     +                  TABL(IAV),IC(IAV),STATUS)
   10    CONTINUE
      ELSE
         CALL TBTOPN(TABLE,F_U_MODE,TID,STATUS)
         CALL TBIGET(TID,NNCOL,ISEQ,ISORT,ACOL,AROW,STATUS)
         DO 20 IAV = 1,NCOLS
            CALL TBLSER(TID,TABL(IAV),IC(IAV),STATUS)
            IF (IC(IAV).EQ.-1) THEN
               CALL STTPUT('*** FATAL: Wrong input table ',STATUS)
               CALL TBTCLO(TID,STATUS)
               CALL STSEPI
            END IF
   20    CONTINUE
      END IF
C
C *** restore the graphics display
      CALL PTOPEN(' ',' ',ACCESS,PLMODE)
C
C *** loop on input - pairs of points
      IF (IMETH.EQ.-1) THEN
         CALL STTPUT(HEAD1,STATUS)
      ELSE
         CALL STTPUT(HEAD2,STATUS)
      END IF
      CALL STTPUT(' ',STATUS)
      NCOUNT = 0
C
   30 CONTINUE
      CALL PTGCUR(XCUR,YCUR,KEY,STATUS)
      IF (STATUS.EQ.1) THEN
         GOTO 30
      ELSE IF (KEY.EQ.32) THEN
         CALL TBTCLO(TID,STATUS)
         CALL PTCLOS()
         CALL STSEPI
      ELSE
         LTYPE = 0
         BIN   = 0
         CALL PTDATA(STYPE,LTYPE,BIN,XCUR,YCUR,YOFF,1)
         X1       = XCUR
         VALUE(1) = DBLE(XCUR)
         IPL1     = NINT((X1-XYS)/SXY) + 1
      END IF
C
   40 CONTINUE
      CALL PTGCUR(XCUR,YCUR,KEY,STATUS)
      IF (STATUS.EQ.1) THEN
         GOTO 40
      ELSE IF (KEY.EQ.32) THEN
         CALL TBTCLO(TID,STATUS)
         CALL PTCLOS()
         CALL STSEPI
      ELSE
         LTYPE = 0
         CALL PTDATA(STYPE,LTYPE,BIN,XCUR,YCUR,YOFF,1)
         X2       = XCUR
         VALUE(2) = DBLE(XCUR)
         IPL2     = NINT((X2-XYS)/SXY) + 1
      ENDIF
C
C *** find center
      I1     = MIN(IPL1,IPL2)
      I2     = MAX(IPL1,IPL2)
      CALL PLFIND(MADRID(PNTRW),DXYS,DSXY,I1,I2,IMODE,IMETH,
     +          VALUE(3),VALUE(6),IFAIL,W1,W2,ACOE,VALUE(4),VALUE(5))
      VALUE(7) = ACOE(1)
      VALUE(8) = ACOE(3)
C
      IF (IFAIL.EQ.0) THEN
         ISEQ   = ISEQ + 1
         SVALUE(1) = VALUE(1)
         SVALUE(2) = VALUE(2)
         SVALUE(3) = VALUE(3)
         SVALUE(4) = VALUE(4)
         SVALUE(5) = VALUE(5)
         SVALUE(6) = VALUE(6)
         SVALUE(7) = VALUE(7)
         SVALUE(8) = VALUE(8)
C
         RRBUF(1)  = SVALUE(1)
         RRBUF(2)  = SVALUE(2)
         RRBUF(3)  = SVALUE(3)
         RRBUF(4)  = SVALUE(6)
         RRBUF(5)  = SVALUE(8)
         CALL TBRWRR(TID,ISEQ,NCOLS,IC,SVALUE,STATUS)
         IF (IMETH.EQ.-1) THEN
            WRITE (CLINE,9000) SVALUE(1), SVALUE(2),
     +                         SVALUE(3), SVALUE(6), SVALUE(8)
            CALL STKWRR('OUTPUTR',RRBUF,1,5,KUN,STATUS)
         ELSE
            WRITE (CLINE,9000) SVALUE(1), SVALUE(2), 
     +                         SVALUE(3), SVALUE(6)
            CALL STKWRR('OUTPUTR',RRBUF,1,4,KUN,STATUS)
         ENDIF
C
         CALL STTPUT(CLINE,STATUS)
         NCOUNT = NCOUNT + 1
         IF (IMETH.EQ.-1) THEN
            NPTS = I2 - I1 + 1
            LTYPE = 1
            DO INP = 1, NPTS
               SW1(INP) = SNGL(W1(INP))
               SW2(INP) = SNGL(W2(INP))
            ENDDO
            CALL PTDATA(STYPE,LTYPE,BIN,SW1,SW2,YOFF,NPTS)
         END IF
      END IF
C
      GO TO 30
C 
9000  FORMAT(3F13.3,G13.5,G13.5)
      END
