C @(#)specenter.for 17.1.1.1 (ESO-DMD) 01/25/02 17:56:14 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 PROGRAM SPECEN C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C C.VERSION: 1.0 ESO-FORTRAN Conversion, AA 19:10 - 3 DEC 1987 C C.LANGUAGE: F77+ESOext C C.AUTHOR: J.D.PONZ C C.IDENTIFICATION C C PROGRAM SPECENTER C C.KEYWORDS C C LINE CENTER C C.PURPOSE C C LINE CENTERING. INPUT/OUTPUT IN TABLE C C COMMAND C CENTER/method image table EMISSION/ABSORPTION C C.ALGORITHM C C LINE CENTER IS FOUND BY C MAXI/MINI - POSITION OF THE MAXIMUM/MINIMUM VALUE ! Not anymore C MOMENT - POSITION OF THE FIRST MOMENT (Modif. P.Ballester 901127) C GAUSSIAN - CENTER OF THE FITTED GAUSSIAN C GRAVITY - GRAVITY CENTER OF THE 2 HIGHEST PIXELS C WITH RESPECT TO THE THIRD ONE C C.INPUT/OUTPUT C C TABLE COLUMNS : C :XSTART - FIRST COORD INPUT C :XEND - SECOND COORD INPUT C :XCEN - COMPUTED CENTER C :YSTART - IMAGE VALUE FIRST COORD INPUT C :YEND - IMAGE VALUE SECOND COORD INPUT C :PEAK - MAXIMUM VALUE C :YFIT - FITTED MAXIMUM IN GAUSSIAN METHOD ONLY C :FWHM - FWHM IN GAUSSIAN METHOD ONLY C C C.MODIFICATIONS C [2.1] INCLUDE FWHM AND FORMAT FOR NON EXISTING COLUMNS C [2.1] INCLUDE :YSTART, :YEND AND :YFIT C C----------------------------------------------------------------- C IMPLICIT NONE C INTEGER MADRID INTEGER I,I1,I2,IACT,IAV,ICY,IFAIL,II1,IMETH INTEGER IMODE INTEGER*8 IP INTEGER ISI,IYCOOR,NAXIS,NCOL,NCOLS,NL INTEGER NOUT,NPL,NROW,NSC INTEGER NPIX(2),KUN,KNUL,IMNO,TID,NAC,NAR INTEGER STATUS,IC(8) C REAL VY REAL ACOE(4),START(2),STEP(2),VALUE(8),W1(400),W2(400) DOUBLE PRECISION DSTART(2), DSTEP(2) C CHARACTER FRAME1*80,METH*2 CHARACTER TABLE*80,TABUNT(8)*16,TABLAB(8)*16,IEA*1 CHARACTER FORM(8)*6,LINE*72 CHARACTER IDENT*72,CUNIT*48,LABEL2*16,COMLIN*80 C LOGICAL NULL(2),NULLY,FLAG C INCLUDE 'MID_INCLUDE:TABLES.INC' COMMON /VMR/MADRID(1) INCLUDE 'MID_INCLUDE:TABLED.INC' C DATA NULLY/.FALSE./ DATA NCOLS/6/ DATA NOUT/4/ DATA TABUNT/' ',' ',' ',' ',' ',' ',' ',' '/ DATA TABLAB/'XSTART','XEND','XCEN','YSTART','YEND','PEAK', + 'YFIT','FWHM'/ DATA FORM/'E13.5','E13.5','E13.5','G15.5','G15.5','G15.5','G15.5', + 'E13.5'/ DATA LABEL2/'Y'/ DATA LINE/' Column ...... not present in table '/ C C initialize C CALL STSPRO('SPECENTER') CALL STKRDC('P3',1,1,1,IACT,IEA,KUN,KNUL,STATUS) IF (IEA.EQ.'E') THEN IMODE = 1 ELSE IMODE = 0 END IF CALL STKRDC('MID$CMND',1,1,80,IACT,COMLIN,KUN,KNUL,STATUS) METH = COMLIN(11:12) IF (METH.EQ.'GA') THEN IMETH = -1 NCOLS = 8 NOUT = 6 ELSE IF (METH.EQ.'GR') THEN IMETH = 0 ELSE IMETH = 1 END IF END IF C C read image C CALL STKRDC('P1',1,1,80,IACT,FRAME1,KUN,KNUL,STATUS) CALL STIGET(FRAME1,10,0,1,2,NAXIS,NPIX,DSTART,DSTEP,IDENT, + CUNIT,IP,IMNO,STATUS) START(1) = DSTART(1) START(2) = DSTART(2) STEP(1) = DSTEP(1) STEP(2) = DSTEP(2) IF (NAXIS.GT.1 .AND. NPIX(2).GT.1) THEN IYCOOR = 1 ELSE IYCOOR = 0 NL = 1 NPIX(2) = 1 END IF NPL = NPIX(1) ISI = NPIX(1)*NPIX(2) II1 = 16*NAXIS TABUNT(1) = CUNIT(II1+1:II1+16) TABUNT(2) = TABUNT(1) TABUNT(3) = TABUNT(1) TABUNT(4) = CUNIT(1:16) TABUNT(5) = TABUNT(4) TABUNT(6) = TABUNT(4) TABUNT(7) = TABUNT(4) TABUNT(8) = TABUNT(1) C C get table name for storage of data C CALL STKRDC('P2',1,1,80,IACT,TABLE,KUN,KNUL,STATUS) CALL TBTOPN(TABLE,2,TID,STATUS) CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,STATUS) DO 10 IAV = 1,NCOLS CALL TBLSER(TID,TABLAB(IAV),IC(IAV),STATUS) IF (IAV.LE.2) THEN IF (IC(IAV).EQ.-1) THEN WRITE (LINE,9000) TABLAB(IAV) (1:6) CALL STTPUT(LINE,STATUS) GO TO 30 END IF ELSE IF (IC(IAV).EQ.-1) THEN CALL TBCINI(TID,D_R4_FORMAT,1,FORM(IAV),TABUNT(IAV), + TABLAB(IAV),IC(IAV),STATUS) END IF END IF 10 CONTINUE IF (IYCOOR.EQ.1) THEN CALL TBLSER(TID,LABEL2,ICY,STATUS) IF (ICY.EQ.-1) THEN WRITE (LINE,9000) ':Y ' CALL STTPUT(LINE,STATUS) GO TO 30 END IF END IF C C loop on input - pairs of points C DO 20 I = 1,NROW CALL TBSGET(TID,I,FLAG,STATUS) IF (FLAG) THEN CALL TBRRDR(TID,I,2,IC,VALUE,NULL,STATUS) IF (IYCOOR.EQ.1) THEN CALL TBERDR(TID,I,ICY,VY,NULLY,STATUS) NL = (VY-START(2))/STEP(2) + 1 END IF IF ((.NOT.NULL(1)) .AND. (.NOT.NULL(2)) .AND. + (.NOT.NULLY)) THEN I1 = (VALUE(1)-START(1))/STEP(1) + 1 I2 = (VALUE(2)-START(1))/STEP(1) + 1 CALL FIND(MADRID(IP),NPIX(1),NPIX(2), + START,STEP,NL,I1, + I2,IMODE,IMETH,VALUE(3),VALUE(6), + IFAIL,W1, + W2,ACOE,VALUE(4),VALUE(5)) VALUE(7) = ACOE(1) VALUE(8) = ACOE(3) IF (IFAIL.EQ.0) THEN CALL TBRWRR(TID,I,NOUT,IC(3),VALUE(3), + STATUS) ELSE CALL TBEDEL(TID,I,IC(3),STATUS) CALL TBEDEL(TID,I,IC(4),STATUS) CALL TBEDEL(TID,I,IC(5),STATUS) CALL TBEDEL(TID,I,IC(6),STATUS) IF (IMETH.EQ.-1) THEN CALL TBEDEL(TID,I,IC(7),STATUS) CALL TBEDEL(TID,I,IC(8),STATUS) END IF END IF ELSE CALL TBEDEL(TID,I,IC(3),STATUS) CALL TBEDEL(TID,I,IC(4),STATUS) CALL TBEDEL(TID,I,IC(5),STATUS) CALL TBEDEL(TID,I,IC(6),STATUS) IF (IMETH.EQ.-1) THEN CALL TBEDEL(TID,I,IC(7),STATUS) CALL TBEDEL(TID,I,IC(8),STATUS) END IF END IF END IF 20 CONTINUE C C exit C 30 CALL TBTCLO(TID,STATUS) CALL STSEPI STOP 9000 FORMAT (A) END