C @(#)dblgc.for	19.1 (ES0-DMD) 02/25/03 14:29:41
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
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                    all rights reserved
C.IDENTIFICATION: Program DBLGC
C.PURPOSE:   Extract the coordinates and pixel values: the coordinates can be
C            included/appended in the descriptor, table or keyword.
C.AUTHOR:    Ch. Ounnas   ESO - Garching
C.LANGUAGE:  F77+ESOext
C.KEYWORDS:  Graphics, cursor, table descriptor
C.ALGORITHM: The outines uses the standard interface and AGL plotting routines.
C.VERSION:   850513 K. Banse     ???
C.VERSION:   850925 Ch. Ounnas   ???
C.VERSION:   851125 J.D. Ponz    ???
C.VERSION:   8602?? L.Fini       implementation of the AGL plotting routines
C.VERSION:   86???? R.H. Warmels Completely restructured
C.VERSION:   870211 R.H. Warmels corr. default for the maximum number of input
C.VERSION:   870629 R.H. Warmels include of facilitity to read contour plots
C.VERSION:   871113 R.H. Warmels ESO-FORTRAN Conversion
C.VERSION:   DBLGC from GCURSOR M.Bell adaptation for DBLEND routine
C -----------------------------------------------------------------
        program dblgc
C
        integer       MADRID

        REAL        CLIP(4)   !something for graphics display
        character*36  CUNIT     !image descriptor
        integer       DUM       !number of continuum points to be marked
        integer       FAC       !number of parameters per line to be marked
        character*1   FOPT      !fit option specified in DBLEND command
        integer       IC        !column number
        character*72  IDENT     !image descriptor
        real          IMAGE(4)  !image names
        real          WINDX(4),WINDY(4)
        integer       IMF       !file number of image frame
        character*60  INFO      !plotting keyword
        character*1   IOPT      !input option specified in DBLEND command
        integer*8       IP        !pointer to image frame
        integer       IROW      !table row to be written
        integer       ISI       !total number of pixels in image
        integer       ISTAT     !status indicator
        integer       LIM       !maximum number of useful cursor values in tabl
        integer       MSTAT     !internal error status indicator        

        integer       NAXIS     !dimensionality of input image
        integer       NCOLS     !number of columns output table is to have
        integer       NPIX(3)   !size of input image
        integer       NREAD     !number of cursor values actually read in
        integer       NRMAX     !maximum number of lines for output table
        character*20  PLNAME    !name of image frame that has been plotted
        integer       PLMODE    !output plot mode        
        integer       PLACC     !plot access mode

        character*1   RFLAG     !continuum option specified in DBLEND command
        DOUBLE PRECISION        START(3)  !zero points of world coordinates
        DOUBLE PRECISION        STEP(3)   !pixel size of world coordinates
        character*80  STRING*80 !output message holder
        REAL        SX,SY       !single precision versions of step(1,2)
        character*16  TABFOR(7) !table column formats
        character*16  TABLAB(7) !table column labels
        character*64  TABLE     !name of output table of cursor positions
        character*16  TABUNI(7) !table column units
        integer       TID       !table id number
        REAL          XS,YS     !single precision versions of start(1,2)
        INTEGER       NPL, IAC, KUN, L, IAV, NL, NTRY, KNUL
C
        integer       NNEW,NROLD  !dummy value holders
C
        INCLUDE         'MID_INCLUDE:ST_DEF.INC'
        common    /MYINFO/ SX,SY,XS,YS,NPL,ISI
        common    /VMR/    MADRID(1)
        INCLUDE         'MID_INCLUDE:ST_DAT.INC'
C
C
        DATA      TABUNI/' ',' ',' ',' ',' ',' ',' '/
        DATA      TABLAB/'X_AXIS','Y_AXIS','LINE_NO','PIXEL_NO',
     2                 'X_POSITION','Y_POSITION','PIXEL_VALUE'/
        DATA      TABFOR/'G13.6','G13.6','I5','I5',
     2                 'G13.6','G13.6','G13.6'/
        data      MSTAT /0/
        data      PLACC/-1/
        data      PLMODE/-1/
C
C *** start of executable code
        CALL STSPRO('DBLGC')
C
C *** get the needed keyword contents
        CALL PTKRDC('DNAME',60,IAC,INFO)
        L      = INDEX(INFO//' ',' ') - 1
        PLNAME = INFO(1:L)                                   ! type of the date
        call stkrdc('P5',1,1,1,IAC,RFLAG,KUN,KNUL,ISTAT)
        call upcas(RFLAG,RFLAG)
        if (RFLAG.eq.'R') then
          RFLAG = '4'
          DUM = 4
        else
          RFLAG = '2'
          DUM = 2
        end if
        call stkrdc('FITOPT',1,1,1,IAC,FOPT,KUN,KNUL,ISTAT)
        call upcas(FOPT,FOPT)
        call stkrdc('P6',1,1,1,IAC,IOPT,KUN,KNUL,ISTAT)
        call upcas(IOPT,IOPT)
C
C *** get table name for storage of data
        CALL STKRDC('IN_B',1,1,64,IAC,TABLE,KUN,KNUL,ISTAT)
C
        NRMAX = 24
        NCOLS  = 7                                                  ! 6 columns
C
        CALL TBTINI(TABLE,0,F_O_MODE,NCOLS,NRMAX,TID,ISTAT)      ! create table
        DO  IAV = 1,NCOLS                                      ! define columns
          CALL TBCINI(TID,D_R4_FORMAT,1,TABFOR(IAV),TABUNI(IAV),
     2                     TABLAB(IAV),IC,ISTAT)
        end do
        IROW   = 1
C
C *** restore the graphics display
        CALL PTOPEN(' ', ' ', PLACC, PLMODE)
        CALL PTKRDR('CLPL',4,IAC,CLIP)
C
C *** Image files
        CALL STIGET(PLNAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,3,
     2               NAXIS,NPIX,START,STEP,IDENT,CUNIT,IP,IMF,ISTAT)
        SX     = real(STEP(1))
        SY     = real(STEP(2))
        XS     = real(START(1))
        YS     = real(START(2))
        NPL    = NPIX(1)
        NL     = NPIX(2)
        ISI    = NPIX(1)*NPIX(2)
        CALL PTKRDR('XWNDL',4,IAC,WINDX)
        CALL PTKRDR('YWNDL',4,IAC,WINDY)
        IMAGE(1) = WINDX(1)
        IMAGE(2) = WINDX(2)
        IMAGE(3) = WINDY(1)
        IMAGE(4) = WINDY(2)
C
C *** get the cursor positions
C
        NTRY = 1
 30        STRING = 'Mark beginning and end of region to be fit'
        call sttput(STRING,ISTAT)
        CALL STTPUT('   X-axis       Y-axis     Line Pixel '//
     2               '  X-position   Y-position  Pixel_value',
     3                ISTAT)
        NREAD = 0
        call curpos(MADRID(IP),TID,2,IMAGE,IROW,NREAD)
        if (NREAD.ne.2) then
          STRING = 'ERROR: wrong number of positions read in'
          call sttput(STRING,ISTAT)
          NTRY = NTRY + 1
          if (NTRY.le.3) then
            go to 30
          else
            MSTAT = 4
            go to 100
          end if
        end if
C
        NTRY = 1
 40        STRING = 'Mark continuum on both sides: '//RFLAG//' points'
        call sttput(STRING,ISTAT)
        CALL STTPUT('   X-axis       Y-axis     Line Pixel '//
     2               '  X-position   Y-position  Pixel_value',
     3                ISTAT)
        LIM = NREAD + DUM
        call curpos(MADRID(IP),TID,DUM,IMAGE,IROW,NREAD)
        if (NREAD.ne.LIM) then
          STRING = 'ERROR: wrong number of positions read in'
          call sttput(STRING,ISTAT)
          NTRY = NTRY + 1
          if (NTRY.le.3) then
            NREAD = 2
            go to 40
          else
            MSTAT = 4
            go to 100
          end if
        end if

        NTRY = 1
        NROLD = NREAD
 50        if (FOPT.eq.'W'.and.IOPT.eq.'B') then
          STRING = 'Mark left and right half max points'
          call sttput(STRING,ISTAT)
          STRING = ' for each line indicated'
          call sttput(STRING,ISTAT)
          FAC = 2
        else if ((FOPT.eq.'S'.or.FOPT.eq.'A').and.IOPT.eq.'B') then
          STRING = 'Mark line centers'
          call sttput(STRING,ISTAT)
          FAC = 1
        else
          STRING = 'Mark left half max point, center, and right'
          call sttput(STRING,ISTAT)
          STRING = ' half max point for each line.'
          call sttput(STRING,ISTAT)
          FAC = 3
        end if
        STRING = 'Press space bar or middle mouse button when finished'
        call sttput(STRING,ISTAT)
        CALL STTPUT('   X-axis       Y-axis     Line Pixel '//
     2               '  X-position   Y-position  Pixel_value',
     3                ISTAT)
        call curpos(MADRID(IP),TID,18,IMAGE,IROW,NREAD)
        NNEW = NREAD - NROLD
        if (NNEW.gt.18) then
          MSTAT = 2
          go to 100
        end if
        if (NREAD.eq.0.or.mod(NNEW,FAC).ne.0) then
          STRING = 'ERROR: wrong number of values read in'
          call sttput(STRING,ISTAT)
          NTRY = NTRY + 1
          if (NTRY.le.3) then
            NREAD = LIM
            go to 50
          else
            MSTAT = 4
            go to 100
          end if
        end if
C
C  That's it folks...
C
 100        if (MSTAT.eq.1) then
          STRING = 'ERROR: wrong number of cursor positions read in'
          call sttput(STRING,ISTAT)
        else if (MSTAT.eq.2) then
          STRING = ' Too many lines marked; only first 6 will be used'
          call sttput(STRING,ISTAT)
        else if (MSTAT.eq.3) then
          STRING = 'ERROR: no cursor values read in'
          call sttput(STRING,ISTAT)
        else if (MSTAT.eq.4) then
          STRING = ' DBLGC exiting on input errors'
          call sttput(STRING,ISTAT)
        end if
        CALL TBSINI(TID,ISTAT)
        CALL TBTCLO(TID,ISTAT)
C
        CALL PTCLOS
        CALL STSEPI
        END

        subroutine curpos(DATA,TID,NITER,IMAGE,IROW,NREAD)

        INTEGER   NCR
        PARAMETER (NCR=1)

        integer NITER,KEY,NREAD,IPLX,IPLY,ISI,NPL,KUN
        INTEGER   ISTAT
        REAL      IMAGE(4)
        INTEGER   IC(7)
        REAL      X(NCR),Y(NCR),VALUE(7), DATA(1)
        real PXVL,XD,XP,YD,XS,YS,SX,SY,VAL,YP
        CHARACTER L1*13,L2*13,L3*6,L4*6,L5*13,L6*13,L7*15

        integer II, IROW, TID

        COMMON /MYINFO/ SX,SY,XS,YS,NPL,ISI
        DATA   IC /1,2,3,4,5,6,7/

 9000        FORMAT (I4)
 9010        FORMAT (G13.6)

        do  II = 1,NITER

   30     CONTINUE
          CALL AGVLOC(X(1),Y(1),KEY,PXVL)
          IF (KEY.EQ.13) THEN
            CALL STTPUT('*** WARNING: do not use return key',ISTAT)
            GO TO 30
          ELSE IF (KEY.EQ.32) THEN
            return
          ELSE
            XD     = X(1)
            IPLX   = NINT((XD-XS)/SX) + 1
            XP     = FLOAT(IPLX-1)*SX + XS
            YD     = Y(1)
            IF (IMAGE(3).NE.IMAGE(4)) THEN
              IPLY   = NINT((YD-YS)/SY) + 1
              YP     = FLOAT(IPLY-1)*SY + YS
            ELSE
              IPLY   = IMAGE(3)
              YP     = FLOAT(IPLY-1)*SY + YS
            END IF
C
            IF ((XD.LT.IMAGE(1)) .OR. (XD.GT.IMAGE(2)) .OR.
     2          (YD.LT.IMAGE(3)) .OR. (YD.GT.IMAGE(4))) THEN
              CALL STTPUT('*** WARNING: Graphic cursor outside '//
     2                     'plotted area',ISTAT)
              GO TO 30
            ELSE
              CALL PIXVAL(DATA,ISI,NPL,IPLX,IPLY,VAL)
            END IF
C
            NREAD = NREAD + 1
            CALL PTDATA(0,1,0,X,Y,0.0,NCR)
            VALUE(1) = XD
            VALUE(2) = YD
            VALUE(3) = float(IPLX)
            VALUE(4) = float(IPLY)
            VALUE(5) = XP
            VALUE(6) = YP
            VALUE(7) = VAL

            CALL STKWRR('OUTPUTR',VALUE,1,7,KUN,ISTAT)! fill keyword OUTPUTR
            CALL TBRWRR(TID,IROW,7,IC,VALUE,ISTAT)
            IROW = IROW + 1
C
C *** prepare the outputs
            WRITE (L1,9010) VALUE(1)
            WRITE (L2,9010) VALUE(2)
            WRITE (L3,9000) IPLX
            WRITE (L4,9000) IPLY
            WRITE (L5,9010) VALUE(5)
            WRITE (L6,9010) VALUE(6)
            WRITE (L7,9010) VALUE(7)

            CALL STTPUT(L1//L2//' '//L4//L3//'  '//L5//L6//L7,ISTAT)
          end if
C
        end do
        return
        end



