C @(#)intestar.for 17.1.1.1 (ESO-DMD) 01/25/02 17:11: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 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: INTESTAR C.PURPOSE: Compute the stellar magnitude C.LANGUAGE: F77+ESOext C.AUTHOR: Charlie Ounnas C.VERSION: 870928 RHW Change from old to new ST calls C.VERSION: 880708 RHW Converted to standrad fortran C.VERSION: 890214 RHW ST_interfaces C.VERSION: 901128 RHW changes due to change in command syntax; C. cursor selection now possible C.VERSION: 910115 RHW IMPLICIT NONE added C C 010201 last modif C C------------------------------------------------------------------- PROGRAM INTSTR C IMPLICIT NONE C INTEGER MADRID(1) INTEGER ISTAT INTEGER I,IAC INTEGER*8 IP INTEGER IMF,J,N,IR INTEGER ST1,ST2,COORDC,COOFF INTEGER KUN,KNUL, INCURS INTEGER TIDI,TIDO,ACOL,AROW INTEGER NAXIS,NCOL,NCOLO,NROW INTEGER ICOL(8) INTEGER MASK, OVCON INTEGER NPIX(3) INTEGER XY1(2),XY2(2) INTEGER MASKO(1000) REAL DMAX REAL FPIX1(6),FPIX2(6) REAL RVAL(11), RV REAL RINF(6) REAL CUTS(4) REAL STA(2), STE(2) REAL XYZI(2) REAL XYZ(8) REAL XYZO(8,1000) REAL PARAM(3) C DOUBLE PRECISION START(3),STEP(3) C CHARACTER FRAME*60,TBIN*60,TBOUT*60 CHARACTER*16 COLX,COLY CHARACTER FORM*5 CHARACTER INFO*40 CHARACTER*16 LABEL(2),UNIT(2) CHARACTER MODE*4 CHARACTER*80 TEXT CHARACTER*16 LABELO(8),UNITO(8) CHARACTER IDENT*72,CUNIT*64 LOGICAL NULL(2) C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' INCLUDE 'MID_INCLUDE:IDIDEV.INC/NOLIST' INCLUDE 'MID_INCLUDE:IDIMEM.INC/NOLIST' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C DATA LABEL /'X_COORD','Y_COORD'/ DATA LABELO/'X_COORD','Y_COORD','FLUX','MAGNITUDE', 2 'BACKGROUND','DIAMETER','LOG_DIAMETER', 3 'NO_REFERENCE'/ DATA UNIT /'WORLD COORD.', 'WORLD COORD.'/ DATA UNITO /'WORLD COORD.', 'WORLD COORD.', 2 ' ', ' ', ' ', 'WORLD COORD.',' ',' '/ DATA FORM/'E12.5'/ DATA INFO/'*** INFO: Switch the cursor on ...'/ C 901 FORMAT(' Id. World coord Flux Mag. ', 2 'Backgr Diameter') 902 FORMAT(I4,2X,6(G12.6)) 903 FORMAT('INFO: switch cursor on ...') C C *** start executable code CALL STSPRO('INTSTR') C C *** CALL STKRDC('IN_A',1,1,60,IAC,FRAME,KUN,KNUL,ISTAT) IF (FRAME.EQ.'*') THEN CALL CLNFRA(FRAME,FRAME,0) INCURS = 1 ELSE INCURS = 0 ENDIF CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE, 2 3,NAXIS,NPIX,START,STEP,IDENT,CUNIT,IP,IMF,ISTAT) C C *** get the subarea input options CALL STKRDC('IN_B',1,1,60,IAC,TBIN,KUN,KNUL,ISTAT) C C *** get the output table CALL STKRDC('OUT_A',1,1,60,IAC,TBOUT,KUN,KNUL,ISTAT) C C *** get the parameters CALL STKRDR('INPUTR',1,3,IAC,PARAM,KUN,KNUL,ISTAT) IF (PARAM(1).LE.0.) THEN PARAM(1) = 30. ENDIF IF (PARAM(1).LT.10.) THEN CALL STTPUT('*** WARNING: Radius is less than 10 pixel',ISTAT) CALL STTPUT(' You can expect unreliable results', 2 ISTAT) C PARAM(1) = 10. ENDIF IF (PARAM(1).GT.200.) THEN PARAM(1) = 200. ENDIF C C *** get the operation mode CALL STKRDC('INPUTC',1,1,4,IAC,MODE,KUN,KNUL,ISTAT) CALL UPCAS(MODE,MODE) C CALL STDRDR(IMF,'LHCUTS',1,4,IAC,CUTS,KUN,KNUL,ISTAT) IF (CUTS(1).LT.CUTS(2)) THEN DMAX = CUTS(2) ELSE DMAX = CUTS(4) END IF STA(1) = START(1) STA(2) = START(2) STE(1) = STEP(1) STE(2) = STEP(2) C C *** main contreol loop for cursor input IF (INCURS.EQ.1) THEN C C *** get main control block for DeAnza + attach device CALL DTOPEN(1,ISTAT) CALL STKRDI('DAZHOLD',14,1,IAC,OVCON,KUN,KNUL,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 = ' ' !that's needed for cursor interface NROW = 0 C C *** read cursor position(s) 10 CONTINUE CALL GETCUR('NNYY',FRAME,XY1,FPIX1,RVAL(1),RV,ST1, + XY2,FPIX2,RVAL(3),RV,ST2) IF ((ST1.EQ.0) .AND. (ST2.EQ.0)) THEN GO TO 20 ELSE GO TO 30 END IF C C *** write output heading 20 IF ((COORDC.EQ.0).AND.(COOFF.EQ.0)) THEN WRITE(TEXT,903) CALL STTPUT(TEXT,ISTAT) FRAME = ' ' COOFF = 1 GO TO 10 ELSE GO TO 50 END IF C 30 COORDC = COORDC + 1 ! update coordinate counter IF (COORDC.EQ.1) THEN WRITE(TEXT,901) CALL STTPUT(TEXT,ISTAT) ENDIF C C *** compute the radius of the aperture C *** world coordinates of the area center XYZI(1) = RVAL(1) XYZI(2) = RVAL(2) MASK = 0 C IF (MODE.EQ.'AUTO') THEN CALL SPFLXA(MADRID(IP),NPIX,STA,STE,PARAM(1), 2 PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ) ELSE CALL SPFLXI(MADRID(IP),NPIX,STA,STE,PARAM(1), 2 PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ) ENDIF C C *** output the result IF (MASK.EQ.-1) THEN ! on error next entry CALL STTPUT('*** ERROR: Excessive background', ISTAT) ELSE IF (MASK.EQ.-2) THEN CALL STTPUT('*** ERROR: Indefinite diameter', ISTAT) ELSE IF (MASK.EQ.-3) THEN CALL STTPUT('*** ERROR: Maximum is outside the object', 2 ISTAT) ELSE ! all systems ok NROW = NROW + 1 ! update table row counter DO 120 J = 1,8 XYZO(J,NROW) = XYZ(J) 120 CONTINUE MASKO(NROW) = MASK WRITE(TEXT,902) INT(XYZ(8)),XYZ(1),XYZ(2), 2 XYZ(3),XYZ(4),XYZ(5),XYZ(6) CALL STTPUT(TEXT,ISTAT) ENDIF GO TO 10 ELSE ! here for the input from table WRITE(TEXT,901) CALL STTPUT(TEXT,ISTAT) COLX = 'X_COORD' COLY = 'Y_COORD' CALL TBTOPN(TBIN,F_I_MODE,TIDI,ISTAT) CALL TBIGET(TIDI,NCOL,NROW,N,ACOL,AROW,ISTAT) C C search for colomn indices by name DO 210 I = 1,2 CALL TBLSER(TIDI,LABEL(I),ICOL(I),ISTAT) 210 CONTINUE DO 220 IR = 1,NROW CALL TBRRDR(TIDI,IR,2,ICOL,XYZI,NULL,ISTAT) MASK = 0 IF (MODE.EQ.'AUTO') THEN CALL SPFLXA(MADRID(IP),NPIX,STA,STE,PARAM(1), 2 PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ) ELSE CALL SPFLXI(MADRID(IP),NPIX,STA,STE,PARAM(1), 2 PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ) ENDIF C IF (MASK.EQ.-1) THEN ! on error next entry CALL STTPUT('*** ERROR: Excessive background', ISTAT) ELSE IF (MASK.EQ.-2) THEN CALL STTPUT('*** ERROR: Indefinite diameter', ISTAT) ELSE IF (MASK.EQ.-3) THEN CALL STTPUT('*** ERROR: Maximum is outside the object', 2 ISTAT) ELSE ! all systems ok DO 221 J = 1,8 XYZO(J,IR) = XYZ(J) 221 CONTINUE MASKO(IR) = MASK C WRITE(TEXT,902) INT(XYZ(8)),XYZ(1),XYZ(2), 2 XYZ(3),XYZ(4),XYZ(5),XYZ(6) CALL STTPUT(TEXT,ISTAT) ENDIF 220 CONTINUE CALL TBTCLO(TIDI,ISTAT) ENDIF C C *** open table if wanted 50 CONTINUE IF (TBOUT.NE.'?') THEN NCOLO = 8 CALL TBTINI(TBOUT,F_O_MODE,F_TRANS,NCOLO,NROW,TIDO,ISTAT) DO 60 I = 1,8 CALL TBCINI(TIDO,D_R4_FORMAT,1,FORM,UNITO(I), 2 LABELO(I),ICOL(I),ISTAT) 60 CONTINUE C C *** write to table J = 0 DO 130 I = 1,NROW IF (MASKO(I).GT.0) THEN J = J + 1 CALL TBRWRR(TIDO,J,8,ICOL,XYZO(1,I),ISTAT) ENDIF 130 CONTINUE CALL TBTCLO(TIDO,ISTAT) ENDIF C IF (INCURS.EQ.1) THEN CALL DTCLOS(QDSPNO) ENDIF CALL STSEPI END