C @(#)inteaper.for 17.1.1.1 (ESO-DMD) 01/25/02 17:11:40 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 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C.IDENTIFICATION: INTEAPER.FOR C.AUTHOR: Ch. Ounnas ESO - Garching C.LANGUAGE: F77+ESOext C.KEYWORDS: Image display, cursor, flux-magnitude C.PURPOSE: read the position of the two cursors on the DeAnza display C and get integrated density of relevant pixels inside an C aperture C.ALGORITHM: Use enabled cursor(s) and read screen pixels, real pixels and C world coordinatE when the ENTER button is pressed on the C cursor board. Exit by pressing ENTER with enabled cursor(s) C off (see COORD.FOR from K. Banse). C.INPUT/OUTPUT: the following keywords are used: C DEANZA/I/1/6 main DeAnza info C DAZHOLD/I/1/3 cursor(s) enabled, cursor form(s) + split C screen mode C INPUTR/R/1/1 radius of the aperture C INPUTC/C/1/12 name of output table C.VERSION: 830610 ?? ? C.VERSION: 840706 ?? ? C.VERSION: 840803 ?? ? C.VERSION: 850320 KB bug fix for neg. logar C.VERSION: 860710 KB conv. to ST, IDI interfaces + IIMPLICIT NONE C.VERSION: 870304 KB store results also in keyword OUTPUTR(1-7) C.VERSION: 871123 KB adapt to mod. DeAnza software (1K memory + C. 512 display...) C.VERSION: 880919 RW ESO-FORTRAN Conversion C.VERSION: 900319 KB adapt GETCUR's first parameter to 4 chars. C.VERSION: 900801 RHW ST and TB interfaces C.VERSION: 911202 KB handle EXIT from GETCUR correctly C.VERSION: 930517 KB add 3rd par. for CLNFRA C C 010201 lats modif C C------------------------------------------------------------------- PROGRAM INTAPR C IMPLICIT NONE C DOUBLE PRECISION START(3),STEP(3) C INTEGER MADRID INTEGER*8 IP INTEGER IMF INTEGER ST1,ST2,ISTAT,COORDC,COOFF INTEGER INCURS,INFLAG,IAV INTEGER NAXIS,I INTEGER TIDI,TIDO,NROW,NCOL,NOP,N1,N2,ND1,ND2,NACOL,NAROW INTEGER XY1(2),XY2(2) INTEGER NPIX(3),ICOL(2),OCOL(7) INTEGER XFIG(2048),YFIG(2048) INTEGER COORD(3),NX,NY INTEGER KUN,KNUL C CHARACTER IDENT*72,CUNIT*64 CHARACTER DSCTYP*1,DSCNAM*20 CHARACTER*60 FRAME,INTAB,OUTAB CHARACTER CERCLE*2 CHARACTER*16 COLX,COLY CHARACTER*16 UNITO(7),LABELO(7) CHARACTER*16 TABFOR(7) CHARACTER TEXT*80 C REAL RBUF(17), RINF(6), TEMP(2) REAL PXLS1(6), PXLS2(6) REAL XE,YE,RAYON,BEAM,BGSB,XEYE(2),ACAT(7) REAL RX,RY REAL XSTA,YSTA,XSTE,YSTE C LOGICAL NULL(2) C INCLUDE 'MID_INCLUDE:ST_DEF.INC' INCLUDE 'MID_INCLUDE:IDIDEV.INC' INCLUDE 'MID_INCLUDE:IDIMEM.INC' COMMON /VMR/MADRID(1) INCLUDE 'MID_INCLUDE:ST_DAT.INC' C DATA UNITO /'WORLD COORD','WORLD COORD','USER UNIT',' ', 2 ' ',' ',' '/ DATA LABELO/'X_COORD','Y_COORD','RADIUS ','NPIX ', 2 'FLUX ','BGSB ','MAG '/ DATA TABFOR/'G13.6','G13.6','G13.6','F6.0', 2 'G13.6','G13.6','G13.6'/ DATA DSCNAM/'BACKGROUND'/ DATA CERCLE/'CI'/ C 902 FORMAT(1X,G10.4,1X,G10.4,2X,G10.4,2X,I6,2X,G10.4,2X, 2 G12.4,2X,G10.4) C C *** initialize MIDAS CALL STSPRO('INTAPR') C C *** get input frame + map it CALL STKRDC('IN_A',1,1,60,IAV,FRAME,KUN,KNUL,ISTAT) IF (FRAME(1:1).EQ.'*') THEN ! File loaded on Deanza CALL CLNFRA(FRAME,FRAME,0) INCURS = 1 ELSE INCURS = 0 ! File non loaded on Deanza END IF CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,3,NAXIS,NPIX, 2 START,STEP,IDENT,CUNIT,IP,IMF,ISTAT) XSTA = START(1) YSTA = START(2) XSTE = STEP(1) YSTE = STEP(2) C C *** get the subarea input options CALL STKRDC('IN_B',1,1,60,IAV,INTAB,KUN,KNUL,ISTAT) IF (INTAB(1:1).EQ.'*') THEN INFLAG = 1 ! INFLAG = 1 for cursor ELSE ! INFLAG = 2 for table INFLAG = 2 END IF C C *** read INPUTC to fill OUTAB if output table CALL STKRDC('INPUTC',1,1,60,IAV,OUTAB,KUN,KNUL,ISTAT) IF (OUTAB(1:1).NE.'?') THEN CALL TBTINI(OUTAB,0,F_O_MODE,7,COORDC,TIDO,ISTAT) DO 60 IAV = 1,7 CALL TBCINI(TIDO,D_R4_FORMAT,1,TABFOR(IAV),UNITO(IAV), 2 LABELO(IAV),OCOL(IAV),ISTAT) 60 CONTINUE END IF C C *** does the descriptor BACKGROUND exist in FRAME ?? CALL STDFND(IMF,DSCNAM,DSCTYP,ND1,ND2,ISTAT) IF (DSCTYP.EQ.' ') THEN BGSB = 0. ELSE CALL STDRDR(IMF,DSCNAM,1,1,IAV,BGSB,KUN,KNUL,ISTAT) END IF C C *** get the radius of the aperture in user unit CALL STKRDR('INPUTR',1,1,IAV,BEAM,KUN,KNUL,ISTAT) ! Image on display C IF (INCURS.EQ.1) THEN C *** get main control block for DeAnza + attach device CALL DTOPEN(1,ISTAT) C C *** get scroll values of displayed channel + scroll overlay accordingly CALL DTGICH(QDSPNO,QIMCH,FRAME,RINF,ISTAT) CALL DAZSCR(QDSPNO,QIMCH,SCROLX,SCROLY,ISTAT) COORDC = 0 COOFF = 0 FRAME = ' ' C C *** read cursor position(s) 10 CALL GETCUR('NNYY',FRAME,XY1,PXLS1(3),PXLS1(5),RBUF(1),ST1, + XY2,PXLS2(3),PXLS2(5),RBUF(1),ST2) IF ((ST1.EQ.0) .AND. (ST2.EQ.0)) THEN GO TO 20 ELSE GO TO 30 END IF C 20 IF ((COORDC.EQ.0).AND.(COOFF.EQ.0)) THEN CALL STTPUT + ('switch cursor(s) on - next time we exit...',ISTAT) FRAME(1:) = ' ' COOFF = 1 GO TO 10 ELSE CALL DTCLOS(QDSPNO) GO TO 50 END IF C 30 COORDC = COORDC + 1 ! update coordinate counter C C *** compute the radius of the aperture C *** world coordinates of the area center XE = (PXLS1(5)+PXLS2(5))/2. YE = (PXLS1(6)+PXLS2(6))/2. RX = ABS(PXLS2(5)-PXLS1(5))/2.0 RY = ABS(PXLS2(6)-PXLS1(6))/2.0 RAYON = MIN(RX,RY) C C *** draw the aperture in the Deanza overlay channel COORD(1) = (XY1(1)+XY2(1))/2 COORD(2) = (XY1(2)+XY2(2))/2 NX = (XY2(1)-XY1(1))/2 NY = (XY2(2)-XY1(2))/2 COORD(3) = MIN(NX,NY) CALL BLDGRA(CERCLE,COORD,TEMP,XFIG,YFIG,2048,NOP) CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,255,1,ISTAT) C IF (BEAM.NE.-1.) THEN RAYON = BEAM ENDIF C CALL SFLUX(MADRID(IP),NPIX,START,STEP,XE,YE, 2 RAYON,BGSB,ACAT) IF (COORDC.EQ.1) THEN CALL STTPUT(' Centre (w.c.) Radius #Pixels'// 2 ' Flux Background Magnitude',ISTAT) ENDIF C IF (ACAT(7).LE.-1000) THEN ACAT(1) = XE ACAT(2) = YE ACAT(3) = 0.0 ACAT(4) = 0.0 ACAT(5) = 0.0 ACAT(6) = 0.0 ACAT(7) = 0.0 ENDIF WRITE(TEXT,902) ACAT(1),ACAT(2),ACAT(3),INT(ACAT(4)),ACAT(5), 2 ACAT(6),ACAT(7) CALL STTPUT(TEXT,ISTAT) IF (OUTAB(1:1).NE.'?') THEN CALL TBRWRR(TIDO,COORDC,7,OCOL,ACAT,ISTAT) ENDIF GOTO 10 ELSE ! No display used, but in table C *** read coordinates XE,YE in the input table C *** Initialisation of the labels of the columns RAYON = BEAM COLX = 'X_COORD' COLY = 'Y_COORD' CALL TBTOPN(INTAB,F_I_MODE,TIDI,ISTAT) C C *** Find columns X_COORD and Y_COORD CALL TBLSER(TIDI,COLX,ICOL(1),ISTAT) IF (ICOL(1).LE.0) THEN CALL STTPUT('The column label X_COORD is not present', 2 ISTAT) CALL TBTCLO(TIDI,ISTAT) GO TO 50 END IF CALL TBLSER(TIDI,COLY,ICOL(2),ISTAT) IF (ICOL(2).LE.0) THEN CALL STTPUT('The column label Y_COORD is not present', + ISTAT) CALL TBTCLO(TIDI,ISTAT) GO TO 50 END IF NCOL = 2 C C *** Find number of rows CALL TBIGET(TIDI,N1,NROW,N2,NACOL,NAROW,ISTAT) C C *** Read each row for XE,YE I = 0 40 I = I + 1 IF (I.GT.NROW) THEN CALL TBTCLO(TIDI,ISTAT) GO TO 50 ENDIF C CALL TBRRDR(TIDI,I,2,ICOL,XEYE,NULL,ISTAT) XE = XEYE(1) YE = XEYE(2) COORDC = COORDC + 1 C CALL SFLUX(MADRID(IP),NPIX,START,STEP,XE,YE, 2 RAYON,BGSB,ACAT) IF (COORDC.EQ.1) THEN CALL STTPUT(' Centre (w.c.) Radius #Pixels'// 2 ' Flux Background Magnitude',ISTAT) ENDIF C IF (ACAT(7).LE.-1000) THEN ACAT(1) = XE ACAT(2) = YE ACAT(3) = 0.0 ACAT(4) = 0.0 ACAT(5) = 0.0 ACAT(6) = 0.0 ACAT(7) = 0.0 ENDIF WRITE(TEXT,902) ACAT(1),ACAT(2),ACAT(3),INT(ACAT(4)),ACAT(5), 2 ACAT(6),ACAT(7) CALL STTPUT(TEXT,ISTAT) IF (OUTAB(1:1).NE.'?') THEN CALL TBRWRR(TIDO,COORDC,7,OCOL,ACAT,ISTAT) ENDIF GOTO 40 END IF C C *** That's it folks... 50 CONTINUE C C *** put the last entry in the keyword OUTPUTR CALL STKWRR('OUTPUTR',ACAT,1,7,KUN,ISTAT) IF (OUTAB(1:1).NE.'?') THEN CALL TBTCLO(TIDO,ISTAT) ENDIF C CALL STSEPI END C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C.IDENTIFICATION: SFLUX C.AUTHOR: Ch. Ounnas ESO - Garching C.LANGUAGE: F77+ESOext C.KEYWORDS: flux-magnitude C.PURPOSE: compute flux inside an aperture C.VERSION: 880919 RHW ESO-FORTRAN Conversion C.VERSION: 910115 RHW IMPLICIT NONE added C ---------------------------------------------------------------------- SUBROUTINE SFLUX(FMES,NPIX,START,STEP,XE,YE,RAYON, 2 BGSB,TAB) IMPLICIT NONE C REAL FMES(1) INTEGER NPIX(2) DOUBLE PRECISION START(2) DOUBLE PRECISION STEP(2) REAL XE REAL YE REAL RAYON REAL BGSB REAL TAB(7) C INTEGER MADRID(1) INTEGER IMIN, IMAX INTEGER IST INTEGER LMIN, LMAX INTEGER LM, IL, IM INTEGER NPL INTEGER IPL C REAL ANL, ANPL REAL DIF, DELTAS REAL DX, DY REAL PIX REAL PS2, POIDS REAL RA, RI, R2 REAL RES REAL RMES(1024) REAL RMIN, RMAX REAL XP, YP REAL XC, YC REAL XSTA, YSTA REAL XMIN, XMAX REAL YMIN, YMAX REAL ZERO REAL VMAG C COMMON /VMR/MADRID C DX = STEP(1) DY = STEP(2) ANL = FLOAT(NPIX(2)) ANPL = FLOAT(NPIX(1)) XSTA = START(1) YSTA = START(2) C ALPHA = DX/RAYON C WRITE(TEXT,*) ' ALPHA = ',ALPHA C ALR = ALPHA*RAYON C RMAX = RAYON*(1.+ALPHA) C RMIN = RAYON*(1.-ALPHA) C RMAX = RAYON RMIN = RAYON RA = RMAX**2 RI = RMIN**2 DELTAS = ABS(DY*DX) C ZERO = 0. XMIN = XE - RMAX XMAX = XE + RMAX YMIN = YE - RMAX YMAX = YE + RMAX IPL = INT((XMIN-XSTA)/DX) + 1 C IF (IPL.GE.1. .AND. IPL.LE.ANPL) THEN IMIN = IPL IPL = INT((XMAX-XSTA)/DX) + 1 ELSE CALL STTPUT('*** INFO: Aperture area outside frame '// 2 'boundaries',IST) TAB(7) = -9999.99 GO TO 30 END IF C IF (IPL.GE.1. .AND. IPL.LE.ANPL) THEN IMAX = IPL IPL = INT((YMAX-YSTA)/DY) + 1 ELSE CALL STTPUT('*** INFO: Aperture area outside frame '// 2 'boundaries',IST) TAB(7) = -9999.99 GO TO 30 END IF C IF (IPL.GE.1. .AND. IPL.LE.ANL) THEN LMAX = IPL IPL = INT((YMIN-YSTA)/DY) + 1 ELSE CALL STTPUT('*** INFO: Aperture area outside frame '// 2 'boundaries',IST) TAB(7) = -9999.99 GO TO 30 END IF C IF (IPL.GE.1. .AND. IPL.LE.ANL) THEN LMIN = IPL ELSE CALL STTPUT('*** INFO: Aperture area outside frame '// 2 'boundaries',IST) TAB(7) = -9999.99 GO TO 30 END IF C IF (DX.LE.0.) THEN IM = IMIN IMIN = IMAX IMAX = IM END IF C IF (DY.LE.0.) THEN IM = LMIN LMIN = LMAX LMAX = IM END IF C LM = LMAX - LMIN + 1 IM = IMAX - IMIN + 1 PIX = 0. RES = 0. PS2 = DX/2. C DO 20 IL = 1,LM CALL LIRE(IL+LMIN-1,NPIX(1),IMIN,IMAX,1,FMES,RMES) YP = YSTA + FLOAT(LMIN+IL-2)*DY IF (DY.LE.0.) THEN CALL LIRE(LMAX-IL+1,NPIX(1),IMIN,IMAX,1,FMES,RMES) YP = YSTA + FLOAT(LMAX-IL)*DY END IF C YC = (YE-YP)**2 DO 10 NPL = 1,IM XP = XSTA + FLOAT(IMIN+NPL-2)*DX IF (DX.LE.0.) THEN XP = XSTA + FLOAT(IMAX-NPL)*DX END IF C XC = (XE-XP)**2 R2 = SQRT(YC+XC) DIF = RAYON - R2 C IF (DIF.GE.0.) THEN IF (DIF.GT.PS2) THEN POIDS = 1. ELSE POIDS = 0.5* (1.+DIF/PS2) END IF ELSE IF (ABS(DIF).GT.PS2) THEN POIDS = 0. ELSE POIDS = 0.5* (1+DIF/PS2) END IF END IF C C IF (R2 .LT. RA ) THEN C IF (R2 .LE. RI ) THEN C POIDS = 1. C ELSE C R2=SQRT(R2) C POIDS=(RMAX-R2)/(2.*ALR)-((R2-RAYON)**2-ALR**2) C 2 /(8.*ALR*RAYON) C ENDIF RES = RES + POIDS*RMES(NPL) PIX = PIX + POIDS C ENDIF 10 CONTINUE 20 CONTINUE C C RES = RES/200. C RES = RES*DELTAS C PI = 3.1415927 C SPIX = PIX*DX*DY C SCERCLE = PI*RAYON**2 VMAG = RES - PIX*BGSB IF (VMAG.GT.0) THEN VMAG = -2.5*ALOG10(VMAG) ELSE VMAG = -9999.99 END IF C TAB(1) = XE TAB(2) = YE TAB(3) = RAYON TAB(4) = AINT(PIX) TAB(5) = RES TAB(6) = BGSB TAB(7) = VMAG C 30 RETURN END SUBROUTINE LIRE(NL,NPL,NPL1,NPL2,NPL3,FMES,RMES) C+++ C.PURPOSE: Write part of a frame into an array C.AUTHOR: ??? C.VERSION: ?????? ??? created C.VERSION: 890117 RHW documented C.COMMENTS: none C--- IMPLICIT NONE INTEGER NL INTEGER NPL INTEGER NPL1 INTEGER NPL2 INTEGER NPL3 REAL FMES(1) REAL RMES(1) INTEGER MADRID(1) INTEGER NPD, NPF, K, I C COMMON /VMR/MADRID C *** NPD = NPL* (NL-1) + NPL1 NPF = NPD + NPL2 - NPL1 K = 0 C DO 10 I = NPD,NPF,NPL3 K = K + 1 RMES(K) = FMES(I) 10 CONTINUE C RETURN END