C @(#)magni.for 17.1.1.1 (ESO-IPG) 01/25/02 17:40:00 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 C.IDENTIFICATION: C program MAGNI version 1.00 881028 C K. Banse ESO - Garching C 980617 C C.KEYWORDS: C Gaussian profiles, intensity moments C C.PURPOSE: C find magnitude of objects C C.ALGORITHM: C simple integration over center part and subtraction of background C it is the JMAG command of IHAP (Author: P. Grosbol) C C.INPUT/OUTPUT: C C The following keywords are used: C IN_A/C/1/60 input frame C P1/C/1/80 input specs, C = CURSOR for cursor input C = image for image center or C = image,xpix,ypix for image pixel or C = image,table for table input C ACTION/C/1/3 magnitude method, C CEN for center method C CIR for method with circular aperture C REC for method with rect. aperture C P2/C/1/80 out specs (for data storage) C = :label for table or table,:label (a) C = descr,DESCR for descriptor (b) C = + for just display of data C P4/C/1/2 (a) identifier flag for table, C = I(D), append an identifier, else no. C (b) append flag for descriptor, C = A, append data to descriptor C = +, start again at position 1 in descr C AREA/C/1/80 nopix, (npiy) for magnitude, C nopix for no_mans_land, C nopix for sky - as char. string C P5/C/1/30 first char: '1' or '0' for center flag C then optional ",kappa" (default = 2.0) C COPTION/I/1/4 no. of cursors to use, C draw_flag for circles/rectangles, C draw_flag for labels (INPUTC(31)='I', C max. no. of cursor inputs C C DAZIN/I/1/5 zoom,aux_win_sizes (for cursor only) C OUTPUTR/R/1/12 last displayed results C OUTPUTI/I/1/1 no. of loops in program C C.VERSIONS C C 010625 last modif C C-------------------------------------------------------------------------- C PROGRAM MAGNI C IMPLICIT NONE C INTEGER BAKPIX,MAGPIX,MAGPIY,NOMPIX INTEGER COOS(5),CUROPT INTEGER CENTFL,IDFL,INFL,OUTFL,TBMAG INTEGER IDYES,FELEM INTEGER IAV,N,NN,NLIMIT,NMAL INTEGER LLABL,OVCON,COOFF INTEGER NCOOS,NROW INTEGER OUCOLS,CENTY,TBAPP INTEGER*8 PNTRA,PNTRC INTEGER STAT1,STAT2,STAT,INPUT(4),NOCURS,IMNO INTEGER NAXIS,NPIX(3),NPIXT(3),XYALP(3) INTEGER ALOW(3),BLOW(3),HIGH(3) INTEGER ICUR1(2),ICUR2(2),INBUF(5) INTEGER BOX(5),SPIX(4) INTEGER INCOLN(13),OUCOLN(13) INTEGER OPTION,LRVALS,NCOU,YESNO,LOOPI,DRAWY INTEGER TIDI,TIDO,TABNUL(13) INTEGER XFIGU(256),YFIGU(256),MAXPNT,NPNTS INTEGER CXSIZE,CYSIZE,KXSIZE,KYSIZE,ZMPIX,ZMPIY,ZNPIX,ZBPIX INTEGER RADIUS(4) INTEGER UNI(1),NULO,MADRID(1),EC,EL,ED,BUFSIZ C INTEGER GENNUM C LOGICAL SELFLG C CHARACTER FRAME*60 CHARACTER DESCR*15,APPFL*2 CHARACTER CUNIT*48,IDENT*72,CBUF*80,ACTION*3 CHARACTER IDF*8,OLDIDF*8,LABL*8,INFO*50 CHARACTER INTABL*60,OUTABL*60,CURACT*8 CHARACTER TUNITW*16,TUNIT*16,LABEL(13)*16 C DOUBLE PRECISION STEP(3),START(3) DOUBLE PRECISION DIN(4),DOUT(4) !MaxDim = 4 in wrldco.c DOUBLE PRECISION DVALS(10) C REAL RBUF(17),PCUR1(6),PCUR2(6) REAL RVALS(12),RR(2),R1,R2,R3,R4,FAC REAL AMAG,AMSIG,SKY,SSKY,APIX,XC,YC,XCC,YCC REAL TEMP(2),FLUX,RINF(8),XOFF,YOFF C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C INCLUDE 'MID_INCLUDE:IDIDEV.INC' INCLUDE 'MID_INCLUDE:IDIMEM.INC' C COMMON /VMR/ MADRID COMMON /FLAGS/ INFL,OUTFL,OPTION,TBMAG C DATA LABEL /'XSTART ','YSTART ','XEND ','YEND ', + 'MAGNITUDE ','MAG_SIGMA ','SKY ','SKY_SIGMA ', + 'IDENT ','XCEN ','YCEN ','MAGPIX ', + 'FLUX '/ DATA INCOLN /13*0/, OUCOLN /13*0/ DATA TUNITW /'WORLD COORD '/ DATA TUNIT /' '/ C DATA IDF /'ID '/, OLDIDF /' '/ DATA COOS /5*-1/, RADIUS /4*0/, TEMP/-1.0,-1.0/ DATA NPIXT /3*1/, ALOW /3*1/, BLOW /3*1/, HIGH /3*1/ DATA DESCR /' '/ DATA IDENT /' '/, CUNIT /' '/ DATA XYALP /0,0,0/, DVALS /10*0.0/ DATA INTABL /' '/, OUTABL /' '/ DATA MAXPNT /256/, BUFSIZ /300/ DATA INFO /'switch cursors on - next time we exit... '/ C INCLUDE 'MID_INCLUDE:ST_DAT.INC' C C set up MIDAS environment + enable automatic error abort CALL STSPRO('MAGNI') NCOOS = 0 !init no. of coords. read IDFL = 0 IDYES = 0 CUROPT = 0 CENTFL = 1 !if = 1, shift window CENTY = 1 !if = 1, we have already center vals in in_table NCOU = 0 !count used for various purposes TIDO = -1 !default to NO output table TBAPP = 0 !point to start of table TBMAG = 0 !use MAGPIX,MAGPIY... OUTFL = 0 XCC = -1 !init to invalid value YCC = -1 C C INFL = 1, cursor input OUTFL = 0, just display data C INFL = 2, table input = 1, results to descriptor C INFL = 3, image center OUTFL > 1, results to table: C INFL = 4, image pixel 2 = same input, output table C 3 = new output table C OPTION = 1, MAGNITUDE/CENTER C OPTION = 2, MAGNITUDE/RECTANGLE C OPTION = 3, MAGNITUDE/CIRCLE C C C get method C CALL STKRDC('ACTION',1,1,3,IAV,ACTION,UNI,NULO,STAT) CALL UPCAS(ACTION,ACTION) IF (ACTION.EQ.'CIR') THEN OPTION = 3 !MAGNI/CIRCLE ELSE IF (ACTION(1:1).EQ.'R') THEN OPTION = 2 !MAGNI/RECT ELSE OPTION = 1 !MAGNI/CENT ENDIF LRVALS = 12 C C get the input options C CALL STKRDC('P1',1,1,78,IAV,CBUF,UNI,NULO,STAT) NN = INDEX(CBUF,',') IF (NN.GT.1) THEN FRAME(1:) = CBUF(1:NN-1)//' ' INTABL(1:) = CBUF(NN+1:)//' ' IAV = GENNUM(INTABL) !check for image,xpix,ypix IF ((INTABL(1:1).EQ.'@') .OR. (IAV.EQ.1)) THEN INFL = 4 ELSE CALL CLNTAB(INTABL,INTABL,0) CALL TBTOPN(INTABL,F_IO_MODE,TIDI,STAT) INFL = 2 !INFL = 2 for table CENTY = 0 !default to No Center columns C CALL TBLSER(TIDI,LABEL(9),INCOLN(9),STAT) !look for :IDENT column IF (INCOLN(9).NE.-1) IDYES = 1 CALL TBLSER(TIDI,LABEL(10),INCOLN(10),STAT) !look for center cols CALL TBLSER(TIDI,LABEL(11),INCOLN(11),STAT) IF ( (INCOLN(10).GT.0) .AND. (INCOLN(11).GT.0)) THEN CENTY = 1 !indicate that we already have a center ENDIF ENDIF ELSE CALL UPCAS(CBUF(1:6),IDENT) IF (IDENT(1:6).EQ.'CURSOR') THEN CALL STKRDC('IN_A',1,1,60,IAV,FRAME,UNI,NULO,STAT) INFL = 1 !INFL = 1 for cursor COOFF = 0 ELSE FRAME(1:) = CBUF(1:60) INFL = 3 !INFL = 3 for image center CALL STTPUT + ('We work on crude center of input frame. ',STAT) ENDIF ENDIF C C get center flag + kappa for kappa-sigma clipping C CALL STKRDC('P5',1,1,30,IAV,CBUF,UNI,NULO,STAT) IF (CBUF(1:1).EQ.'0') THEN CENTFL = 0 ELSE IF (CBUF(1:1).NE.'1') THEN IF ((INFL.EQ.4) .OR. (CENTY.EQ.1)) CENTFL = 0 !force to NO ENDIF NN = INDEX(CBUF,',') IF (NN.GT.1) THEN CALL GENCNV(CBUF(NN+1:),2,1,N,FAC,STEP,IAV) IF (IAV.LE.0) THEN CALL STTPUT + ('Wrong syntax for center params, Kappa set to 2.0',STAT) FAC = 2.0 ENDIF ELSE FAC = 2.0 ENDIF C C open input frame CALL CLNFRA(FRAME,FRAME,0) CALL STFOPN(FRAME,D_R4_FORMAT,0,F_IMA_TYPE,IMNO,STAT) CALL STDRDI(IMNO,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT) IF (NAXIS.EQ.1) + CALL STETER(1,'input frame must be at least 2-dim frame...') CALL STDRDI(IMNO,'NPIX',1,2,IAV,NPIX,UNI,NULO,STAT) CALL STDRDD(IMNO,'START',1,2,IAV,START,UNI,NULO,STAT) CALL STDRDD(IMNO,'STEP',1,2,IAV,STEP,UNI,NULO,STAT) C C init frame pixls <-> world coords conversion CALL FPXWCO(0,IMNO,DIN,DOUT,STAT) IF (STAT .GT. 0) + CALL STETER(11,'problems with WCS of input frame...') C C map temporary work frames N = NPIX(1)*BUFSIZ CALL STFXMP(N,D_R4_FORMAT,PNTRA,STAT) N = BUFSIZ * BUFSIZ CALL STFXMP(N,D_R4_FORMAT,PNTRC,STAT) C C get integration sizes + check them C CALL STKRDC('AREA',1,1,78,IAV,CBUF,UNI,NULO,STAT) CALL PULLOU(CBUF,STEP,2,2,MAGPIX,MAGPIY,NOMPIX,BAKPIX) IF ((MAGPIX.LE.0).OR.(NOMPIX.LT.0).OR.(BAKPIX.LT.0)) + CALL STETER(2,'invalid pixel string ...') IF (MAGPIY.LE.0) MAGPIY = MAGPIX C NN = 2*(BAKPIX+NOMPIX) IF (OPTION.EQ.1) THEN MAGPIX = 3 !only take 9 center pixels CXSIZE = MAGPIX + NN CYSIZE = CXSIZE ELSE IF (OPTION.EQ.3) THEN NN = 2 * ((MAGPIX/2) + BAKPIX + NOMPIX) CXSIZE = 1 + NN !add center pixel for total no. of x/y-pixel CYSIZE = CXSIZE ELSE !for rectangle xpix, ypix may differ CXSIZE = MAGPIX + NN CYSIZE = MAGPIY + NN ENDIF KXSIZE = CXSIZE KYSIZE = CYSIZE C C get append_flag + output_specs C CALL STKRDC('P4',1,1,2,IAV,CBUF,UNI,NULO,STAT) CALL UPCAS(CBUF(1:2),APPFL) IF ((APPFL(1:1).EQ.'I').OR.(APPFL(2:2).EQ.'I')) IDFL = 1 C CALL STKRDC('P2',1,1,80,IAV,CBUF,UNI,NULO,STAT) IF (CBUF(1:1).EQ.'+') GOTO 500 !neither table nor descriptor C NN = INDEX(CBUF,',D') !test for ,D or ,d IF (NN .LE. 0) NN = INDEX(CBUF,',d') C C handle descriptor storage IF (NN.GT.1) THEN !it's a descriptor DESCR = CBUF(1:NN-1) IF (APPFL(1:1).EQ.'A') THEN !see, if data is to be appended FELEM = -1 ELSE FELEM = 1 ENDIF OUTFL = 1 !OUTFL = 1 for descriptor GOTO 500 !skip following table stuff ENDIF C C +++ C handle table storage C +++ C OUCOLS = 13 !no. of columns in out_table CALL CLNTAB(CBUF,OUTABL,0) C C either same table involved ... IF (OUTABL.EQ.INTABL) THEN !results go to same table TIDO = TIDI OUTFL = 2 !OUTFL = 2 for same table C DO 100,IAV=5,8 !test, if label(s) already there CALL TBLSER(TIDI,LABEL(IAV),OUCOLN(IAV),STAT) IF (OUCOLN(IAV).EQ.-1) !No. We have to define it... + CALL TBCINI(TIDI,D_R4_FORMAT,1,'E12.5', + TUNIT,LABEL(IAV),OUCOLN(IAV),STAT) 100 CONTINUE C IF (CENTY.EQ.1) THEN OUCOLN(10) = INCOLN(10) OUCOLN(11) = INCOLN(11) ELSE DO 120,IAV=10,11 !create :XCEN,:YCEN as double CALL TBCINI(TIDI,D_R8_FORMAT,1,'E24.15', + TUNITW,LABEL(IAV),OUCOLN(IAV),STAT) 120 CONTINUE ENDIF IF (IDFL.EQ.1) THEN IF (IDYES.EQ.1) THEN OUCOLN(9) = INCOLN(9) ELSE CALL TBCINI + (TIDI,D_C_FORMAT,8,'A8',TUNIT,LABEL(9),OUCOLN(9),STAT) ENDIF ENDIF C DO 140,IAV=12,13 CALL TBLSER(TIDI,LABEL(IAV),OUCOLN(IAV),STAT) IF (OUCOLN(IAV).EQ.-1) + CALL TBCINI(TIDI,D_R4_FORMAT,1,'E12.5', + TUNIT,LABEL(IAV),OUCOLN(IAV),STAT) 140 CONTINUE C C or just output table ... C ELSE !output to table - valid for any input option OUTFL = 3 C IF (APPFL(1:1).EQ.'A') THEN !append to existing table CALL STECNT('GET',EC,EL,ED) CALL STECNT('PUT',1,0,0) !disable errors ... CALL TBTOPN(OUTABL,F_IO_MODE,TIDO,STAT) CALL STECNT('PUT',EC,EL,ED) IF (STAT.NE.0) THEN !continue only, if TBTOPN o.k. APPFL(1:1) = '+' ELSE CALL TBIGET(TIDO,N,TBAPP,N,N,N,STAT) !get no. of rows DO 260,IAV=1,4 CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT) IF (OUCOLN(IAV).EQ.-1) + CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15', + TUNITW,LABEL(IAV),OUCOLN(IAV),STAT) 260 CONTINUE DO 270,IAV=5,8 CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT) IF (OUCOLN(IAV).EQ.-1) + CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5', + TUNIT,LABEL(IAV),OUCOLN(IAV),STAT) 270 CONTINUE C IF (IDFL.EQ.1) THEN CALL TBLSER(TIDO,LABEL(9),OUCOLN(9),STAT) IF (OUCOLN(9).EQ.-1) + CALL TBCINI(TIDO,D_C_FORMAT,8,'A8', + TUNIT,LABEL(9),OUCOLN(9),STAT) ENDIF DO 280,IAV=10,11 CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT) IF (OUCOLN(IAV).EQ.-1) + CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15', + TUNITW,LABEL(IAV),OUCOLN(IAV),STAT) 280 CONTINUE C DO 290,IAV=12,13 CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT) IF (OUCOLN(IAV).EQ.-1) + CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5', + TUNIT,LABEL(IAV),OUCOLN(IAV),STAT) 290 CONTINUE C GOTO 500 ENDIF ENDIF C C we create a new table (starting with 100 rows) C CALL TBTINI(OUTABL,0,F_O_MODE,OUCOLS+10,100,TIDO,STAT) DO 460,IAV=1,4 CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15', + TUNITW,LABEL(IAV),OUCOLN(IAV),STAT) 460 CONTINUE DO 470,IAV=5,8 CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5', + TUNIT,LABEL(IAV),OUCOLN(IAV),STAT) 470 CONTINUE C IF (IDFL.EQ.1) + CALL TBCINI(TIDO,D_C_FORMAT,8,'A8', + TUNIT,LABEL(9),OUCOLN(9),STAT) DO 480,IAV=10,11 CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15', + TUNITW,LABEL(IAV),OUCOLN(IAV),STAT) 480 CONTINUE C DO 490,IAV=12,13 CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5', + TUNIT,LABEL(IAV),OUCOLN(IAV),STAT) 490 CONTINUE ENDIF C C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C here all options join: C display header line + branch according to input option C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C 500 IF (INFL.NE.2) THEN IF (CENTFL.EQ.1) + CALL STTPUT + ('input windows will be adjusted around the center ', + STAT) ELSE IF (CENTFL.EQ.0) THEN IF (CENTY.EQ.1) THEN CBUF(1:) = 'x,ycenter will be taken from input table ' CALL STTPUT(CBUF,STAT) ENDIF ELSE IF (CENTY.EQ.1) THEN CBUF(1:) = + 'x,ycenter of input table will be overwritten ' CALL STTPUT(CBUF,STAT) ENDIF ENDIF ENDIF IF (INFL.NE.1) THEN CBUF(1:) = + 'xcenter ycenter magnitude mag-sigma sky '// + ' sky-sigma magpix flux ' CALL STTPUT(CBUF,STAT) IF (IDFL.EQ.1) CALL STTPUT(' ident ',STAT) ENDIF C C branch according to input option NMAL = 0 !init counter IF (INFL.EQ.1) THEN GOTO 900 ELSE IF (INFL.EQ.2) THEN GOTO 2000 ENDIF C C -------------------------------------------------------------------- C C a) input frame is used - use crude center or given x,ypixel C INFL = 3 or 4 (no looping) C C -------------------------------------------------------------------- C IF (INFL.EQ.3) THEN COOS(1) = NPIX(1)/2 COOS(2) = NPIX(2)/2 ELSE CALL EXTCO1(IMNO,INTABL,2,N,COOS,STAT) !get frame pixels IF (STAT.NE.0) THEN CALL STETER(3,'invalid pixel specification,...') CALL STSEPI ENDIF ENDIF XCC = COOS(1) YCC = COOS(2) C IF (OPTION.NE.3) THEN BOX(1) = COOS(1) - CXSIZE/2 BOX(2) = COOS(2) - CYSIZE/2 BOX(3) = BOX(1) + CXSIZE - 1 BOX(4) = BOX(2) + CYSIZE - 1 PCUR1(1) = FLOAT(BOX(1)) PCUR1(2) = FLOAT(BOX(2)) PCUR2(1) = FLOAT(BOX(3)) PCUR2(2) = FLOAT(BOX(4)) ELSE !circle option PCUR1(1) = FLOAT(COOS(1)) PCUR1(2) = FLOAT(COOS(2)) ENDIF NMAL = 1 !maybe we write a row to table WRITE(IDF(3:),10010) NMAL GOTO 3000 C C -------------------------------------------------------------------- C C b) cursor defined subimage(s) - get main control block for ImageDisplay C INFL = 1 (loop on cursor input) C C -------------------------------------------------------------------- C 900 CALL DTOPEN(1,STAT) CALL STKRDI('DAZHOLD',14,1,IAV,OVCON,UNI,NULO,STAT) CALL STKRDI('COPTION',1,4,IAV,INPUT,UNI,NULO,STAT) IF (OPTION.EQ.1) THEN NOCURS = 0 !for CENTER use 1 cursor ELSE IF (OPTION.EQ.2) THEN IF (INPUT(1).EQ.1) THEN NOCURS = 0 ELSE NOCURS = 2 ENDIF ELSE NOCURS = 2 !for CIRCLE use 2 cursors CUROPT = INPUT(1) !save 1 or 2 cursor mode IF (CUROPT.EQ.1) THEN WRITE(CBUF,20004) MAGPIX,NOMPIX,BAKPIX CALL STTDIS(CBUF,0,STAT) ENDIF ENDIF DRAWY = INPUT(2) YESNO = INPUT(3) NLIMIT = INPUT(4) C C adjust cursor shape CALL DTGICH(QDSPNO,QIMCH,CBUF,RINF,STAT) ZMPIX = MAGPIX ZMPIY = MAGPIY IAV = ZMPIX/2 ZNPIX = NOMPIX ZBPIX = BAKPIX IF ((SCALX.EQ.-1) .OR. (SCALX.EQ.0)) SCALX = 1 IF ((SCALY.EQ.-1) .OR. (SCALY.EQ.0)) SCALY = 1 IF (SCALX.NE.SCALY) CALL STETER + (6,'image not loaded with same x-, y-scale...') IF (SCALX.LT.-1) THEN NN = -SCALX ZMPIX = MAGPIX*NN ZMPIY = MAGPIY*NN IAV = (MAGPIX*NN)/2 ZNPIX = NOMPIX*NN ZBPIX = BAKPIX*NN ELSE IF (SCALX.GT.1) THEN ZMPIX = MAGPIX/SCALX + 1 !so we have at least 1 pixel ZMPIY = MAGPIY/SCALY + 1 IAV = MAGPIX/(2*SCALX) + 1 ZNPIX = NOMPIX/SCALX + 1 ZBPIX = BAKPIX/SCALX + 1 ENDIF COOS(1) = QDSZX/2 COOS(2) = QDSZY/2 LOOPI = 2 IF (OPTION.NE.3) THEN IF (NOCURS.EQ.0) THEN NN = 3 !use rectangle LOOPI = 2 ELSE NN = 1 !use rectangle N = ZMPIX + 2*(ZNPIX+ZBPIX) COOS(3) = COOS(1) + N - 1 N = ZMPIY + 2*(ZNPIX+ZBPIX) COOS(4) = COOS(2) + N - 1 ENDIF ELSE NN = 2 !use circle COOS(3) = IAV COOS(4) = COOS(3) + ZNPIX COOS(5) = COOS(4) + ZBPIX RADIUS(1) = COOS(3) !save original radius RADIUS(2) = COOS(4) RADIUS(3) = COOS(5) ENDIF CALL SETCUR(QDSPNO,NOCURS,NN,LOOPI,COOS,STAT) C CALL STKRDI('AUX_MODE',9,1,IAV,N,UNI,NULO,STAT) IF (N.NE.0) CALL CONCHA(QDSPNO,QOVCH,1,0) !clear overlay channel IF (OVCON.EQ.QIMCH) + CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT) C FRAME(1:) = ' ' CALL STKRDI('DAZIN',1,1,IAV,INBUF,UNI,NULO,STAT) CURACT = 'NNYY?C0 ' !set up for Cursor with ENTER button IF (INBUF(1).GT.0) THEN !we use the zoom window... IF (NOCURS.EQ.0) THEN CURACT(5:7) = 'ZC0' !prepare zoom_window stuff for GETCUR ELSE IF (OPTION.EQ.3) THEN !we want circles in zoom window CURACT(5:7) = 'ZC7' ELSE CURACT(5:7) = 'ZC2' ENDIF ENDIF INBUF(1) = (QDSZX * 3) / 4 !use 3/4 of main display size INBUF(2) = (QDSZY * 3) / 4 INBUF(3) = 0 !start at lower left of display INBUF(4) = 0 CALL STKWRI('DAZIN',INBUF,2,4,UNI,STAT) N = 0 CALL SETCUR(QDSPNO,N,3,2,COOS,STAT) !use cross C C if `novice', display initial help, show current zoomfactor CALL STKRDI('ERROR',2,1,IAV,N,UNI,NULO,STAT) IF (N.EQ.1) CALL AUXHLP(0) !for novice users display help ENDIF C CALL PIXXCV('INIT',IMNO,RBUF,NN) GOTO 1000 C 990 WRITE(CBUF,30000) MAGPIX,BAKPIX CALL STTDIS(CBUF,99,STAT) C C get cursor positions 1000 IF (NMAL.GE.NLIMIT) GOTO 9000 C CALL GETCUR(CURACT,FRAME, + ICUR1,PCUR1(1),RVALS(1),FLUX,STAT1, + ICUR2,PCUR2(1),RVALS(3),FLUX,STAT2) C C check cursor status for EXIT condition IF ((STAT1.EQ.0).AND.(STAT2.EQ.0)) THEN IF ((NMAL.EQ.0) .AND. (COOFF.EQ.0)) THEN CALL STTPUT(INFO,STAT) COOFF = 1 FRAME(1:) = ' ' GOTO 1000 ELSE GOTO 9000 ENDIF ELSE IF (NMAL.EQ.0) THEN CBUF(1:) = + 'xcenter ycenter magnitude mag-sigma' CALL STTPUT(CBUF,STAT) CBUF(1:) = + ' sky sky-sigma magpix flux ' CALL STTPUT(CBUF,STAT) IF (IDFL.EQ.1) CALL STTPUT(' ident ',STAT) ENDIF C C show graph used for magnitude determination C IF (OPTION.EQ.3) THEN !MAGNI/CIRCLE BOX(1) = ICUR1(1) BOX(2) = ICUR1(2) INBUF(1) = PCUR2(1) INBUF(2) = PCUR2(2) INBUF(3) = RVALS(3) C C check radii if in 1 cursor option for circle IF (CUROPT.EQ.1) THEN IF ((RADIUS(1).NE.INBUF(1)) .OR. + (RADIUS(2).NE.INBUF(2)) .OR. + (RADIUS(3).NE.INBUF(3))) THEN IF (RADIUS(4).GT.2) GOTO 1200 C RADIUS(4) = RADIUS(4) + 1 CALL STTDIS + ('The radii of the circles should not be modified!', + 0,STAT) CALL STTDIS + ('Original size of circles will be used anyway!', + 0,STAT) IF (SCALX.NE.SCALY) GOTO 1500 !skip the radius update part C 1200 INBUF(1) = RADIUS(1) !draw original radii again INBUF(2) = RADIUS(2) INBUF(3) = RADIUS(3) ENDIF C C update radii only in 2 cursor option for circle ELSE IF (SCALX.GT.1) THEN INBUF(1) = INBUF(1)*SCALX INBUF(2) = INBUF(2)*SCALX INBUF(3) = INBUF(3)*SCALX ELSE IF (SCALX.LT.-1) THEN NN = -SCALX INBUF(1) = INBUF(1)/NN INBUF(2) = INBUF(2)/NN INBUF(3) = INBUF(3)/NN ENDIF NOMPIX = INBUF(2) - INBUF(1) BAKPIX = INBUF(3) - INBUF(1) - NOMPIX CXSIZE = 1 + 2*INBUF(3) !in frame pixels INBUF(1) = PCUR2(1) !reset for following drawing INBUF(2) = PCUR2(2) INBUF(3) = RVALS(3) ENDIF C IF (DRAWY.EQ.1) THEN BOX(3) = INBUF(1) CALL BLDGRA('CIR',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS) CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT) BOX(3) = INBUF(2) CALL BLDGRA('CIR',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS) CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT) BOX(3) = INBUF(3) CALL BLDGRA('CIR',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS) ENDIF XCC = PCUR1(1) !xc,yc in frame pixels YCC = PCUR1(2) C ELSE !MAGNI/RECT + MAGNI/CENT IF (NOCURS.EQ.2) THEN !with two cursors IF ( (ICUR1(1).EQ.ICUR2(1)) .OR. + (ICUR1(2).EQ.ICUR2(2)) ) GOTO 990 CXSIZE = ICUR2(1) - ICUR1(1) + 1 CYSIZE = ICUR2(2) - ICUR1(2) + 1 ZMPIX = CXSIZE - 2*(ZNPIX+ZBPIX) ZMPIY = CYSIZE - 2*(ZNPIX+ZBPIX) IF ((ZMPIX.LT.1) .OR. (ZMPIY.LT.1)) GOTO 990 C IF (OPTION.EQ.2) THEN !only for RECT we modify IF (SCALX.GT.1) THEN MAGPIX = ZMPIX*SCALX CXSIZE = CXSIZE*SCALX ELSE IF (SCALX.LT.-1) THEN NN = -SCALX MAGPIX = ZMPIX/NN CXSIZE = CXSIZE/NN ELSE MAGPIX = ZMPIX ENDIF IF (SCALY.GT.1) THEN MAGPIY = ZMPIY*SCALY CYSIZE = CYSIZE*SCALY ELSE IF (SCALY.LT.-1) THEN NN = -SCALY MAGPIY = ZMPIY/NN CYSIZE = CYSIZE/NN ELSE MAGPIY = ZMPIY ENDIF ENDIF C SPIX(1) = (ICUR1(1)+ICUR2(1))/2 !xcenter SPIX(2) = (ICUR1(2)+ICUR2(2))/2 !ycenter XCC = (PCUR1(1)+PCUR2(1))/2 !xc,yc in frame pixels YCC = (PCUR1(2)+PCUR2(2))/2 C ELSE !single cursor SPIX(1) = ICUR1(1) !xcenter SPIX(2) = ICUR1(2) !ycenter XCC = PCUR1(1) !xc,yc in frame pixels YCC = PCUR1(2) PCUR1(1) = XCC - CXSIZE/2 PCUR1(2) = YCC - CYSIZE/2 PCUR2(1) = PCUR1(1) + CXSIZE - 1 PCUR2(2) = PCUR1(2) + CYSIZE - 1 ENDIF C BOX(1) = SPIX(1) - ZMPIX/2 BOX(2) = SPIX(2) - ZMPIY/2 BOX(3) = SPIX(1) + ZMPIX/2 - 1 BOX(4) = SPIX(2) + ZMPIY/2 - 1 IF (DRAWY.EQ.0) THEN BOX(1) = BOX(1) - ZNPIX - ZBPIX BOX(2) = BOX(2) - ZNPIX - ZBPIX BOX(3) = BOX(3) + ZNPIX + ZBPIX BOX(4) = BOX(4) + ZNPIX + ZBPIX ELSE CALL BLDGRA('REC',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS) CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT) BOX(1) = BOX(1) - ZNPIX BOX(2) = BOX(2) - ZNPIX BOX(3) = BOX(3) + ZNPIX BOX(4) = BOX(4) + ZNPIX CALL BLDGRA('REC',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS) CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT) BOX(1) = BOX(1) - ZBPIX BOX(2) = BOX(2) - ZBPIX BOX(3) = BOX(3) + ZBPIX BOX(4) = BOX(4) + ZBPIX CALL BLDGRA('REC',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS) ENDIF ENDIF IF (DRAWY.EQ.1) + CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT) C 1500 NMAL = NMAL + 1 IF (IDFL.EQ.1) THEN CALL STTDIS('enter identifier: ',1,STAT) READ(*,10003) IDF IF (IDF.EQ.' ') IDF = OLDIDF OLDIDF = IDF !save last identifier ELSE WRITE(IDF(3:),10010) NMAL ENDIF C KXSIZE = CXSIZE KYSIZE = CYSIZE GOTO 3000 C C -------------------------------------------------------------------- C C c) table defined subimage(s) C INFL = 2 (loop through table rows) C C -------------------------------------------------------------------- C 2000 CALL TBIGET(TIDI,N,NROW,N,N,N,STAT) !get total no. of rows C 2300 DO 2350,IAV=1,4 !search for columns CALL TBLSER(TIDI,LABEL(IAV),INCOLN(IAV),STAT) IF (INCOLN(IAV).LE.0) THEN CBUF(1:) = 'column labelled '//LABEL(IAV)// + ' is missing in input table... ' CALL STETER(4,CBUF) ENDIF 2350 CONTINUE C C here we loop 2800 NMAL = NMAL + 1 IF (NMAL.GT.NROW) THEN !test for end of table WRITE(CBUF,10001) NCOU,' table entries processed ' CALL STTPUT(CBUF,STAT) IF (OUTFL.NE.2) CALL TBTCLO(TIDI,STAT) GOTO 9000 ENDIF C C get next row of values C CALL TBSGET(TIDI,NMAL,SELFLG,STAT) IF (.NOT.SELFLG) GOTO 2800 C IF (IDYES.EQ.1) THEN CALL TBRRDC(TIDI,NMAL,1,INCOLN(9),IDF,TABNUL,STAT) ELSE WRITE(IDF(3:),10010) NMAL ENDIF C CALL TBRRDD(TIDI,NMAL,4,INCOLN,DVALS,TABNUL,STAT) DIN(1) = DVALS(1) !convert from wco's to fp's DIN(2) = DVALS(2) CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT) IF (STAT.NE.0) THEN WRITE(CBUF,10077) NMAL CALL STTPUT(CBUF,STAT) GOTO 2800 ENDIF C PCUR1(1) = REAL(DOUT(1)) PCUR1(2) = REAL(DOUT(2)) DIN(1) = DVALS(3) DIN(2) = DVALS(4) CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT) IF (STAT.NE.0) THEN WRITE(CBUF,10077) NMAL CALL STTPUT(CBUF,STAT) GOTO 2800 ENDIF PCUR1(3) = REAL(DOUT(1)) PCUR1(4) = REAL(DOUT(2)) C IF (TBMAG.NE.0) THEN !that implies OPTION = 2 (RECT) CXSIZE = PCUR1(3) - PCUR1(1) + 1 !get size of pixel interval CYSIZE = PCUR1(4) - PCUR1(2) + 1 NN = 2*(BAKPIX+NOMPIX) IF (TBMAG.EQ.1) THEN !pix_intv + BAKPIX + NOMPIX MAGPIX = CXSIZE MAGPIY = CYSIZE CXSIZE = CXSIZE + NN CYSIZE = CYSIZE + NN ELSE !pix_intv - BAKPIX - NOMPIX MAGPIX = CXSIZE - NN MAGPIY = CYSIZE - NN ENDIF KXSIZE = CXSIZE KYSIZE = CYSIZE ENDIF C IF (CENTY.EQ.1) THEN CALL TBRRDD(TIDI,NMAL,2,INCOLN(10),DVALS(5),TABNUL,STAT) DIN(1) = DVALS(5) DIN(2) = DVALS(6) CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT) IF (STAT.NE.0) THEN WRITE(CBUF,10077) NMAL CALL STTPUT(CBUF,STAT) GOTO 2800 ENDIF XCC = REAL(DOUT(1)) YCC = REAL(DOUT(2)) ENDIF C C if center_flag = 0 .and. centy = 1, use `final' sized rectangle already IF ((CENTY.EQ.1) .AND. (CENTFL.EQ.0)) THEN !use center from table IF (OPTION.EQ.3) THEN PCUR1(1) = XCC PCUR1(2) = YCC ELSE PCUR1(1) = XCC - CXSIZE/2 PCUR1(2) = YCC - CYSIZE/2 PCUR2(1) = PCUR1(1)+ CXSIZE - 1 PCUR2(2) = PCUR1(2)+ CYSIZE - 1 ENDIF ELSE IF (OPTION.EQ.3) THEN PCUR1(1) = (PCUR1(1)+PCUR1(3))/2 !get center PCUR1(2) = (PCUR1(2)+PCUR1(4))/2 PCUR1(3) = PCUR1(3)-PCUR1(1) !get diameter PCUR1(4) = PCUR1(4)-PCUR1(2) KXSIZE = NINT((PCUR1(3)+PCUR1(4)))/2 !from mean radius KXSIZE = 2*KXSIZE + 1 KYSIZE = KXSIZE ELSE DIN(1) = DVALS(3) DIN(2) = DVALS(4) CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT) IF (STAT.NE.0) THEN WRITE(CBUF,10077) NMAL CALL STTPUT(CBUF,STAT) GOTO 2800 ENDIF PCUR2(1) = REAL(DOUT(1)) PCUR2(2) = REAL(DOUT(2)) ENDIF ENDIF NCOU = NCOU + 1 C C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C common section for option a) and b) and c) C C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C pull out subwindow of frame C 3000 LOOPI = 0 STAT1 = 0 IF (OPTION.EQ.3) THEN !circle NN = KXSIZE/2 SPIX(1) = NINT(PCUR1(1)) - NN !xstart in frame pixels SPIX(2) = NINT(PCUR1(2)) - NN !ystart SPIX(3) = SPIX(1) + KXSIZE - 1 !xend SPIX(4) = SPIX(2) + KXSIZE - 1 !yend ELSE !rectangle SPIX(1) = NINT(PCUR1(1)) !xstart in frame pixels SPIX(2) = NINT(PCUR1(2)) !ystart SPIX(3) = NINT(PCUR2(1)) !xend SPIX(4) = NINT(PCUR2(2)) !yend ENDIF C C check for out-of-bounds XFIGU(1) = SPIX(3) - SPIX(1) YFIGU(1) = SPIX(4) - SPIX(2) IF (SPIX(1).LT.1) THEN WRITE(CBUF,10020) 'start x' CALL STTDIS(CBUF,0,STAT) SPIX(1) = 1 SPIX(3) = SPIX(1) + XFIGU(1) ENDIF IF (SPIX(3).GT.NPIX(1)) THEN WRITE(CBUF,10020) 'end x' CALL STTDIS(CBUF,0,STAT) SPIX(3) = NPIX(1) SPIX(1) = SPIX(3) - XFIGU(1) ENDIF IF (SPIX(2).LT.1) THEN WRITE(CBUF,10020) 'start y' CALL STTDIS(CBUF,0,STAT) SPIX(2) = 1 SPIX(4) = SPIX(2) + YFIGU(1) ENDIF IF (SPIX(4).GT.NPIX(2)) THEN WRITE(CBUF,10020) 'end y' CALL STTDIS(CBUF,0,STAT) SPIX(4) = NPIX(2) SPIX(2) = SPIX(4) - YFIGU(1) ENDIF C DIN(1) = SPIX(1) DIN(2) = SPIX(2) CALL FPXWCO(1,IMNO,DIN,DOUT,STAT) !move from fp's to wco's IF (STAT.NE.0) THEN WRITE(CBUF,10070) DIN(1),DIN(2) CALL STETER(13,CBUF) ENDIF C DVALS(1) = DOUT(1) DVALS(2) = DOUT(2) DIN(1) = SPIX(3) DIN(2) = SPIX(4) CALL FPXWCO(1,IMNO,DIN,DOUT,STAT) IF (STAT.NE.0) THEN WRITE(CBUF,10070) DIN(1),DIN(2) CALL STETER(13,CBUF) ENDIF C DVALS(3) = DOUT(1) DVALS(4) = DOUT(2) DO 3100,IAV=1,4 RVALS(IAV) = REAL(DVALS(IAV)) 3100 CONTINUE C 3130 XOFF = SPIX(1) - 1. !offset from pixel 1 on YOFF = SPIX(2) - 1. INBUF(1) = NPIX(1) INBUF(2) = SPIX(4) - SPIX(2) + 1 !ysize IF (INBUF(2).GT.BUFSIZ) THEN CALL STTPUT('subwindow y-dim > 300 ...',STAT) !sync with BUFSIZ... GOTO 7000 ENDIF INBUF(3) = 1 C C get a y-stripe from disk + copy subwindow out N = INBUF(1) * INBUF(2) !size of y-dim stripe in frame NN = ((SPIX(2)-1)*NPIX(1)) + 1 !1. pixel in there CALL STFGET(IMNO,NN,N,IAV,MADRID(PNTRA),STAT) C NPIXT(1) = SPIX(3) - SPIX(1) + 1 !xsize, ysize to copy NPIXT(2) = INBUF(2) ALOW(1) = SPIX(1) !first x,y pixel in source ALOW(2) = 1 !and destination frame HIGH(1) = SPIX(3) HIGH(2) = INBUF(2) CALL COPWND(MADRID(PNTRA),INBUF(1),MADRID(PNTRC),NPIXT, + ALOW,BLOW,HIGH) C C get center points - but only once and if CENTFL = 1 C IF (LOOPI.EQ.0) THEN IF ((CENTY.EQ.0).OR.(CENTFL.EQ.1)) THEN C C use STACEN to get center INPUT(1) = 1 !xstart INPUT(2) = NPIXT(1) !xend INPUT(3) = 1 !ystart INPUT(4) = NPIXT(2) !yend NN = INPUT(4) - INPUT(3) + INPUT(2) - INPUT(1) IF (NN.GT.300) !marginal points = NN*2 < 600 ! + CALL STETER + (7,'window too large for centering algorithm') C CALL STACEN(MADRID(PNTRC),NPIXT(1),NPIXT(2),'M',INPUT,XC,YC, + R1,R2,R3,R4,AMAG,STAT1) !get x,y-center in subframe IF (STAT1.NE.0) + CALL STTPUT('Cent. algorithm: center not in array...', + STAT) XCC = XC + XOFF !center in full frame YCC = YC + YOFF ELSE XC = XCC - XOFF !relate center to subwindow YC = YCC - YOFF ENDIF C DIN(1) = XCC DIN(2) = YCC CALL FPXWCO(1,IMNO,DIN,DVALS(5),STAT) !move from fp's to wco's RR(1) = REAL(DVALS(5)) RR(2) = REAL(DVALS(6)) C C check, if we use recentered window or CSIZE .NE. KSIZE C IF ((CENTFL.EQ.1) .OR. + (KXSIZE.NE.CXSIZE) .OR. (KYSIZE.NE.CYSIZE)) THEN NN = CXSIZE / 2 N = NINT(XCC) - NN !relate to complete frame IAV = N - SPIX(1) !difference to old start XC = XC - IAV !update xcent accordingly SPIX(1) = N NN = CYSIZE / 2 N = NINT(YCC) - NN IAV = N - SPIX(2) !difference to old start YC = YC - IAV !update ycent accordingly SPIX(2) = N SPIX(3) = SPIX(1) + CXSIZE - 1 SPIX(4) = SPIX(2) + CYSIZE - 1 LOOPI = 1 !avoid passing here again... GOTO 3130 !go + extract new subframe ENDIF ENDIF C C actual magnitude algorithm C CALL JMAGN(OPTION,MADRID(PNTRC),NPIXT(1),NPIXT(2),NOMPIX, + BAKPIX,FAC,XC,YC,AMAG,AMSIG,SKY,SSKY,APIX,FLUX,STAT) C IF (STAT1.EQ.0) THEN IF (STAT.LT.0) THEN IF (STAT.EQ.-2) + CALL STTPUT('Mag. algorithm: center not in array...', + STAT) IF (STAT.EQ.-3) + CALL STTPUT('Mag. algorithm: area too small...',STAT) AMAG = 0. AMSIG = 0. SKY = 0. SSKY = 0. FLUX = 0. ELSE IF (STAT.EQ.1) THEN CALL STTPUT( + 'Mag. algorithm: (Warning) source not in center ...', + STAT) ELSE IF (STAT.EQ.2) THEN AMAG = 0. AMSIG = 0. FLUX = 0. CALL STTPUT + ('Mag. algorithm: (Warning) flux not above sky background ...', + STAT) ENDIF ENDIF C NCOOS = NCOOS + 1 !increment coord. counter IF ((INFL.EQ.1).AND.(YESNO.EQ.1)) THEN !for cursor input draw numbers IF (IDFL.EQ.1) THEN LABL = IDF NN = 1 LLABL = INDEX(LABL,' ') - 1 ELSE WRITE(LABL(5:),10011) NCOOS NN = 5 DO 3900,N=5,7 IF (LABL(N:N).EQ.' ') NN = N + 1 3900 CONTINUE LLABL = 9 - NN ENDIF IF (OPTION.NE.3) THEN !place string right of center XYALP(1) = (BOX(1)+BOX(3))/2 + 5 XYALP(2) = (BOX(2)+BOX(4))/2 + 2 ELSE XYALP(1) = BOX(1) + 5 XYALP(2) = BOX(2) + 2 ENDIF CALL IIGTXT(QDSPNO,QOVCH,LABL(NN:),XYALP(1),XYALP(2), + 0,0,255,0,STAT) ENDIF C C prepare results RVALS(5) = RR(1) RVALS(6) = RR(2) RVALS(7) = AMAG RVALS(8) = AMSIG RVALS(9) = SKY RVALS(10) = SSKY RVALS(11) = APIX RVALS(12) = FLUX C WRITE(CBUF,20005) (RVALS(N),N=5,8) CALL STTPUT(CBUF,STAT) WRITE(CBUF,20006) (RVALS(N),N=9,12) CALL STTPUT(CBUF,STAT) IF (IDFL.EQ.1) CALL STTPUT(IDF,STAT) C C fill descriptor, table or nothing IF (OUTFL.EQ.1) THEN CALL STDWRR(IMNO,DESCR,RVALS,FELEM,LRVALS,UNI,STAT) !fill descr FELEM = -1 ELSE IF (OUTFL.GT.1) THEN !fill table N = NMAL + TBAPP IF (OUTFL.EQ.3) THEN CALL TBRWRD(TIDO,N,4,OUCOLN(1),DVALS(1),STAT) CALL TBRWRD(TIDO,N,2,OUCOLN(10),DVALS(5),STAT) IF (IDFL.EQ.1) CALL TBEWRC(TIDO,N,OUCOLN(9),IDF,STAT) ELSE IF (CENTY.NE.1) + CALL TBRWRD(TIDO,N,2,OUCOLN(10),DVALS(5),STAT) IF (IDFL.EQ.1) CALL TBEWRC(TIDO,N,OUCOLN(9),IDF,STAT) ENDIF CALL TBRWRR(TIDO,N,4,OUCOLN(5),RVALS(7),STAT) CALL TBRWRR(TIDO,N,2,OUCOLN(12),RVALS(11),STAT) ENDIF C C and loop again (only for INFL=1,2) C 7000 GOTO (1000,2800),INFL C C That's it folks... 9000 IF (OUTFL.EQ.3) CALL TBSINI(TIDO,STAT) IF (TIDO.GE.0) THEN CALL STKRDC('MID$LINE',1,1,80,IAV,CBUF,UNI,NULO,STAT) CALL STDWRC(TIDO,'HISTORY',1,CBUF,-1,80,UNI,STAT) ENDIF C C save last set of data + no. of coordinates obtained CALL STKWRR('OUTPUTR',RVALS,1,LRVALS,UNI,STAT) CALL STKWRD('OUTPUTD',DVALS,1,6,UNI,STAT) CALL STKWRI('OUTPUTI',NCOOS,1,1,UNI,STAT) C IF (INFL.EQ.1) THEN CALL DTCLOS(QDSPNO) CALL REFOVR(STAT) ENDIF CALL STSEPI C C format statements 10001 FORMAT(I4,A) 10003 FORMAT(A) 10010 FORMAT(I4.4) 10011 FORMAT(I4) 10020 FORMAT(A, + '-pixel out of frame - subwindow is adjusted accordingly...') 10070 FORMAT('bad coord(s) - X, Y: ',2F20.10) 10077 FORMAT('row no. ',I5,' contains bad coord(s) - we skip ...') 20004 FORMAT('size of circles is fixed according to Fsiz(', + I2,'),Nsiz(',I2,'),Bsiz(',I2,') pixels') 20005 FORMAT(G13.7,1X,G13.7,1X,G11.5,1X,G11.5) 20006 FORMAT(6X,G13.7,1X,G13.7,1X,G13.7,1X,G13.7) 30000 FORMAT('Square too small for Fsize =',I3,' Bsize = ',I3) END SUBROUTINE PULLOU(CBUF,STEP,NDF,BDF, + MAGPIX,MAGPIY,NOMPIX,BAKPIX) C IMPLICIT NONE C INTEGER BAKPIX,MAGPIX,MAGPIY,NOMPIX INTEGER BDF,NDF INTEGER LL,COUNT INTEGER OPTION,INFL,OUTFL,TBMAG C CHARACTER*(*) CBUF CHARACTER SAVBUF*80,STRING*30 C DOUBLE PRECISION STEP(2) C COMMON /FLAGS/ INFL,OUTFL,OPTION,TBMAG C MAGPIY = -1 C LL = INDEX(CBUF,',') !we expect "a,b,c" or "a,b" or "a" IF (LL.LE.0) THEN !only "a" given NOMPIX = NDF BAKPIX = BDF CALL SPULLO(CBUF,STEP(1),MAGPIX) RETURN ENDIF C IF (OPTION.EQ.2) THEN !for RECT we may have magpix,magpiy,.. IF (INFL.EQ.2) THEN !for table input only... IF (CBUF(1:2).EQ.'+,') THEN TBMAG = 1 !we use the table interval CBUF(1:) = CBUF(3:) MAGPIX = 1 GOTO 4000 ELSE IF (CBUF(1:2).EQ.'-,') THEN TBMAG = -1 !we use the table interval CBUF(1:) = CBUF(3:) MAGPIX = 1 GOTO 4000 ENDIF ENDIF C SAVBUF(1:) = CBUF(1:) DO 1000, COUNT=1,3 LL = INDEX(CBUF,',') IF (LL.LE.0) GOTO 2000 !NO - magpiy = magpix CBUF(LL:LL) = '^' 1000 CONTINUE C LL = INDEX(CBUF,'^') STRING(1:) = CBUF(1:LL-1)//' ' !copy out "ax" from "ax,ay,b,c" CALL SPULLO(STRING,STEP(1),MAGPIX) CBUF = CBUF(LL+1:)//' ' LL = INDEX(CBUF,'^') STRING(1:) = CBUF(1:LL-1)//' ' !copy out "ay" CALL SPULLO(STRING,STEP(2),MAGPIY) CBUF = CBUF(LL+1:)//' ' LL = INDEX(CBUF,'^') STRING(1:) = CBUF(1:LL-1)//' ' !copy out "b" from "a,b,c" CALL SPULLO(STRING,STEP(1),NOMPIX) CALL SPULLO(CBUF(LL+1:),STEP(1),BAKPIX) RETURN C 2000 CBUF(1:) = SAVBUF(1:) LL = INDEX(CBUF,',') !reset LL ENDIF C STRING(1:) = CBUF(1:LL-1)//' ' !copy out "a" from "a,b" or "a,b,c" CALL SPULLO(STRING,STEP(1),MAGPIX) CBUF = CBUF(LL+1:)//' ' C 4000 LL = INDEX(CBUF,',') IF (LL.LE.0) THEN !only "a,b" given BAKPIX = BDF CALL SPULLO(CBUF,STEP(1),NOMPIX) ELSE STRING(1:) = CBUF(1:LL-1)//' ' !copy out "b" from "a,b,c" CALL SPULLO(STRING,STEP(1),NOMPIX) CALL SPULLO(CBUF(LL+1:),STEP(1),BAKPIX) ENDIF C RETURN END SUBROUTINE SPULLO(CBUF,STEP,PIX) C IMPLICIT NONE C INTEGER PIX INTEGER SL C CHARACTER*(*) CBUF C REAL RR C DOUBLE PRECISION STEP,DD C IF (CBUF(1:1).EQ.'@') THEN CALL GENCNV(CBUF(2:),1,1,PIX,RR,DD,SL) IF (SL.LE.0) PIX = -1 !indicate wrong syntax... ELSE CALL GENCNV(CBUF(1:),4,1,PIX,RR,DD,SL) IF (SL.LE.0) THEN PIX = -1 !indicate wrong syntax... ELSE PIX = NINT(DD/STEP) ENDIF ENDIF C RETURN END