C @(#)dblgc.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 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