C @(#)inteline.for 17.1.1.1 (ES0-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 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: INTEGR C.PURPOSE: Integrate a line or a portion of a line interactively C using cursor control, or in batch mode C.LANGUAGE: F77+ESOext C.ALGORITHM: Uses the AGL plotting package C.KEYWORDS: Graphics, bulk data frame, integration, line profile C.INPUT/OUTPUT: IN_A/C/1/60 = input frame C INPUTI/I/1/1 = line number (defaulted to 1) C.AUTHOR: Ch. Ounnas C.VERSION: ?????? Ch. Ounnas Creation C.VERSION: 850513 K. Banse ??? C.VERSION: 870625 RHW rewritten and restructured C.VERSION: 871203 RHW ESO-FORTRAN Conversion C.VERSION: 890131 RHW ST interfaces C.VERSION: 900430 RHW Mapping of frame with STFMAP and STFGET C.VERSION: 910115 RHW IMPLICIT NONE added C.VERSION: 9312?? RHW change to new graphics interfaces C.VERSION: 990316 K. Banse NPMAX => 300 000 C ----------------------------------------------------------------- PROGRAM INTEGR IMPLICIT NONE C INTEGER NPMAX PARAMETER (NPMAX=300000) INTEGER MADRID(1) INTEGER I, IAC,II,III,IMF INTEGER IST,ISTAT,NAXIS,NL,NPL INTEGER NVAL,NPIX(3) INTEGER NPL1, NPL2, NPS INTEGER NCH1,NCH2,NCHA(2),KUN(1),KNUL INTEGER*8 WPNTR1,WPNTR2 INTEGER WIMNO INTEGER NCUR,NDEG, INDX(2) INTEGER ACCESS INTEGER BNMOD,LTYPE REAL SX,SY,XS,YS REAL X0,XPS(NPMAX) REAL FRAME(8),SCALES(3) REAL OFFSET(2),AREA(4) REAL IMAGE(4) REAL DELTAX REAL XC(12),CURS(12) REAL YOFF REAL PLTEPS C DOUBLE PRECISION START(2),STEP(2) C CHARACTER MODE*1,INPUT*72,TEXT*80 CHARACTER LABEL1*80,LABEL2*80 CHARACTER LAB1U*16,LAB2U*16 CHARACTER NAME*60,IDENT*72,CUNIT*64 CHARACTER BINMOD*4 CHARACTER XFRAME*4, YFRAME*4 C INTEGER PLMODE C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' DATA LABEL1(1:10)/'Position ('/ DATA LABEL2(1:13)/'Pixel value ('/ DATA YOFF/0.0/ DATA PLMODE/1/ DATA ACCESS/0/ DATA SCALES/0.0,0.0,0.0/ DATA OFFSET/-999.,-999./ DATA PLTEPS/1.0E-20/ DATA XFRAME/'MANU'/ DATA YFRAME/'MANU'/ C 9001 FORMAT('Row: ', I6) 9002 FORMAT('*** WARNING: zero dynamics range in data: value = ', 2 G13.6) C C *** start of executable code *************************************** CALL STSPRO('INTEGR') ! contact with the MIDAS monitor C C *** find file name and read the data CALL STKRDC('IN_A',1,1,60,IAC,NAME,KUN,KNUL,IST) CALL STFOPN(NAME,D_R4_FORMAT,0,F_IMA_TYPE,IMF,IST) CALL STDRDI(IMF,'NAXIS',1,1,IAC,NAXIS,KUN,KNUL,IST) CALL STDRDI(IMF,'NPIX',1,NAXIS,IAC,NPIX,KUN,KNUL,IST) CALL STDRDD(IMF,'START',1,NAXIS,IAC,START,KUN,KNUL,IST) CALL STDRDD(IMF,'STEP',1,NAXIS,IAC,STEP,KUN,KNUL,IST) CALL STDRDC(IMF,'IDENT',1,1,72,IAC,IDENT,KUN,KNUL,IST) CALL STDRDC(IMF,'CUNIT',1,1,64,IAC,CUNIT,KUN,KNUL,IST) C C *** read the manual setting CALL PTKRDR('XAXIS',4,IAC,FRAME) CALL PTKRDR('YAXIS',4,IAC,FRAME(5)) C C allocate virtual memory for a single line of the frame NVAL = NPIX(1) IF (NVAL.EQ.1) THEN CALL STTPUT('*** FATAL: Image row contains only one point!', 2 ISTAT) ENDIF IF (NVAL.LT.512) NVAL = 512 CALL STFCRE('PLOTWORK',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE, + NVAL,WIMNO,IST) CALL STFMAP(WIMNO,F_X_MODE,1,NVAL,IAC,WPNTR1,IST) C C *** determine the various pameters for the plotting NPL = NPIX(1) NL = NPIX(2) SX = STEP(1) SY = STEP(2) XS = START(1) YS = START(2) C C *** line number IF (NAXIS.GT.1) THEN CALL STKRDC('P2',1,1,72,IAC,INPUT,KUN,KNUL,IST) II = INDEX(INPUT,' ') CALL GETSIN(INPUT(1:II-1),NL,YS,SY,IMAGE(3)) IMAGE(4) = IMAGE(3) CALL BOXPTW(IMAGE(3),NL,YS,SY,AREA(3)) C ELSE IMAGE(3) = 1. IMAGE(4) = 1. ENDIF C C *** first and last pixel CALL STKRDC('INPUTC',1,1,72,IAC,INPUT,KUN,KNUL,IST) CALL UPCAS(INPUT,INPUT) IF (INPUT(1:1).EQ.'M') THEN ! manu input CALL BOXWTP(FRAME(1),NPL,XS,SX,IMAGE(1)) CALL BOXPTW(IMAGE(1),NPL,XS,SX,AREA(1)) C ELSE II = INDEX(INPUT,',') CALL GETSIN(INPUT(1:II-1),NPL,XS,SX,IMAGE(1)) III = INDEX(INPUT,' ') CALL GETSIN(INPUT(II+1:III-1),NPL,XS,SX,IMAGE(2)) CALL BOXPTW(IMAGE(1),NPL,XS,SX,AREA(1)) ENDIF C C *** pixels to be plotted CALL PTKWRR('PIXEL',4,IMAGE) NPL1 = INT(MIN(IMAGE(1),IMAGE(2))) NPL2 = INT(MAX(IMAGE(1),IMAGE(2))) NPS = ABS(NPL1-NPL2) + 1 WPNTR2 = WPNTR1 + NPL1 - 1 C C *** set the array indexes II = (INT(IMAGE(3))-1)*NPL + 1 ! offset in frame CALL STFGET(IMF,II,NPL,IAC,MADRID(WPNTR1),IST) C C *** get the number of cursor and the interpolation CALL STKRDI('INPUTI',1,2,IAC,NCHA,KUN,KNUL,IST) NCUR = NCHA(1) NDEG = NCHA(2) C C *** batch mode or in forground CALL STKRDC('P5',1,1,1,IAC,MODE,KUN,KNUL,IST) CALL UPCAS(MODE,MODE) C C *** interactive or batch mode IF (MODE.EQ.'B') THEN CALL STKRDR('CURS',1,12,IAC,CURS,KUN,KNUL,IST) !get positions DO 10 II = 1,NCUR XC(II) = CURS(II) 10 CONTINUE DELTAX = CURS(NCUR+1) IMAGE(1) = 1. IMAGE(2) = FLOAT(NPL) CALL INTFRB(MADRID(WPNTR1),NPL,IMAGE,SX,XS,NCUR,NDEG, 2 DELTAX,XC) ELSE C C *** calculate the frame of the x axis IF ((ABS(FRAME(1)).LT.PLTEPS) .AND. 2 (ABS(FRAME(2)).LT.PLTEPS)) THEN XFRAME = 'AUTO' FRAME(1) = AREA(1) FRAME(2) = AREA(2) FRAME(3) = 0.0 FRAME(4) = 0.0 ELSE XFRAME = 'MANU' ENDIF C C *** set min and max pixel values IF ((ABS(FRAME(5)).LT.PLTEPS) .AND. 2 (ABS(FRAME(6)).LT.PLTEPS)) THEN YFRAME = 'AUTO' CALL MNMX(MADRID(WPNTR2),NPS,FRAME(5),INDX) IF (FRAME(5).EQ.FRAME(6)) THEN WRITE (TEXT,9002) FRAME(5) CALL STTPUT(TEXT,ISTAT) ENDIF FRAME(7) = 0.0 FRAME(8) = 0.0 ELSE YFRAME = 'MANU' ENDIF C CALL GETAXS(XFRAME,FRAME) CALL GETAXS(YFRAME,FRAME(5)) CALL PTKWRR('XWNDL',4,FRAME) CALL PTKWRR('YWNDL',4,FRAME(5)) C C *** statistics determined; get the setups CALL PTKRDC('BINMOD',4,IAC,BINMOD) IF (BINMOD(1:2).EQ.'ON') THEN BNMOD = 1 ELSE BNMOD = 0 ENDIF C CALL PTKRDI('LTYPE',1,IAC,LTYPE) CALL PTOPEN(' ',' ',ACCESS,PLMODE) C C *** do the work X0 = FLOAT(NPL1-1)*SX + XS DO 20 I = 1,NPS XPS(I) = X0 + (I-1)*SX 20 CONTINUE CALL PTDATA(0,LTYPE,BNMOD,XPS,MADRID(WPNTR2),YOFF,NPS) C C *** draw the axis and the label LAB1U = CUNIT(17:32) NCH1 = INDEX(LAB1U,' ')-1 IF (NCH1 .LT. 0) THEN LABEL1(10:) = ' ' ELSE LABEL1(11:) = LAB1U(1:NCH1)//')' ENDIF LAB2U = CUNIT(33:48) NCH2 = INDEX(LAB2U,' ')-1 IF (NCH2 .LT. 0) THEN LABEL2(13:) = ' ' ELSE LABEL2(14:) = LAB2U(1:NCH2)//')' ENDIF CALL PTFRAM(FRAME(1),FRAME(5),LABEL1,LABEL2) C C *** do the integration CALL INTFRI(MADRID(WPNTR1),NPS,IMAGE,SX,XS,NCUR,NDEG) CALL PTCLOS() END IF C C *** finish this bastard and exit CALL STSEPI END SUBROUTINE GETSIN(STRING,NOPIX,START,STEP,PIXEL) C+++ C.PURPOSE: Convert the user coordinate input string into pixel value C.AUTHOR: Klaus Banse, ESO-Garching C.COMMENTS: If coord outside valid interval PIXEL .LE. 0 will be returned... C.VERSION: 87???? RHW small adjustments of the plotting package C.VERSION: 910115 RHW IMPLICIT NONE added C--- IMPLICIT NONE CHARACTER*(*) STRING ! IN: coordinate string INTEGER NOPIX ! IN: number pixels in frame REAL START ! IN: start value of frame REAL STEP ! IN: step between pixel REAL PIXEL ! OUT: pixel number C INTEGER IVAL, ISTAT INTEGER MADRID(1) REAL RVAL CHARACTER*1 TEST DOUBLE PRECISION DVAL C COMMON /VMR/MADRID C C *** TEST = STRING(1:1) ! check 1. character of input string IF (TEST.EQ.'<') THEN ! handle "<" format PIXEL = 1 RETURN C ELSE IF (TEST.EQ.'>') THEN ! handle ">" format PIXEL = NOPIX RETURN C ELSE IF (TEST.EQ.'@') THEN ! handle "@" format CALL GENCNV(STRING(2:),1,1,IVAL,RVAL,DVAL,ISTAT) IF (ISTAT.GT.0) THEN C PIXEL = IVAL-1 PIXEL = IVAL ENDIF C ELSE ! here we have world coordinates CALL GENCNV(STRING,2,1,IVAL,RVAL,DVAL,ISTAT) IF (ISTAT.GT.0) THEN PIXEL = NINT((RVAL-START)/STEP) + 1 ENDIF END IF C C test, if pixel too large... IF (PIXEL.GT.NOPIX) THEN PIXEL = 0 ELSE IF (PIXEL.LT.1) THEN PIXEL = -1 END IF C RETURN END