C @(#)getpix.for 17.1.1.1 (ES0-DMD) 01/25/02 17:11:36 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 SUBROUTINE EXTRA2(A,NPIX,IMAGE,DATA,MXPIX,ISM,IFLAG,ISI) C+++ C.AUTHOR: Rein H. Warmels, ESO-Garching, based on existing code by C Ch.Ounnas C.PURPOSE: extract a subimage from a MIDAS frame , smoothes it (option) C Finally fills a transmitted array (1 dimension) C.ALGORITHM: extracts a subimage from a MIDAS frame and fills an array C if required smoothes the subframe before with a running C 2-d average. C.COMMENTS: none C.VERSION: 890117 RHW Adjusted for portable version C.VERSION: 910115 RHW IMPLICIT NONE added C--- IMPLICIT NONE C REAL A(1) ! IN: entry to the frame INTEGER NPIX(3) ! IN: standard descriptor of frame INTEGER IMAGE(4) ! IN: contains in pixels units INTEGER MXPIX ! IN: max size REAL DATA(MXPIX,MXPIX) ! OUT: data array INTEGER ISM ! IN: smooth. parameter (if .le. 1 np) INTEGER IFLAG ! IN: 0: no rot.; 1: 90 deg. rotation INTEGER ISI ! IN: total size of the data array C INTEGER MADRID(1) INTEGER NX1, NX2, NY1, NY2 INTEGER NX, NY INTEGER ILIS, IOFF INTEGER IX, IY, KX, KY, ISX, ISY, IXG, IYG INTEGER II INTEGER NAV REAL AVER C COMMON /VMR/MADRID C C *** check correct input NX1 = MIN(IMAGE(1),IMAGE(2)) NX2 = MAX(IMAGE(1),IMAGE(2)) IMAGE(1) = NX1 IMAGE(2) = NX2 NY1 = MIN(IMAGE(3),IMAGE(4)) NY2 = MAX(IMAGE(3),IMAGE(4)) IMAGE(3) = NY1 IMAGE(4) = NY2 C C *** NX = IMAGE(2) - IMAGE(1) + 1 IF (NX.EQ.1) THEN ! 1-dim image rotate over 90 deg. IFLAG = 1 END IF NY = IMAGE(4) - IMAGE(3) + 1 C C *** check image input IF (NX.LE.1) THEN RETURN END IF C IF (NY.LE.1) THEN RETURN END IF C C *** set and correct smoothing parameter IF (ISM.EQ.0) THEN ISM = 1 END IF ILIS = 2 * (ISM/2) + 1 IOFF = ILIS/2 C C *** smoothes and read frame IF (ISM.GE.2) THEN DO 40 IX = IMAGE(1),IMAGE(2) DO 30 IY = IMAGE(3),IMAGE(4) AVER = 0. NAV = 0 DO 20 ISX = 1,ILIS DO 10 ISY = 1,ILIS IXG = IX + ISX - IOFF - 1 IYG = IY + ISY - IOFF - 1 C C *** check if no reading out of the frame is done IF (IXG.LE.0 .OR. IXG.GT.NPIX(1)) THEN GO TO 20 END IF IF (IYG.LE.0 .OR. IYG.GT.NPIX(2)) THEN GO TO 10 END IF NAV = NAV + 1 II = (IYG-1)*NPIX(1) + IXG AVER = AVER + A(II) 10 CONTINUE 20 CONTINUE AVER = AVER/FLOAT(NAV) KX = IX - IMAGE(1) + 1 KY = IY - IMAGE(3) + 1 C C *** rotate over 90 deg. in equired IF (IFLAG.EQ.0) THEN DATA(KX,KY) = AVER ELSE DATA(KY,NX-KX+1) = AVER END IF 30 CONTINUE 40 CONTINUE C ELSE DO 60 IY = IMAGE(3),IMAGE(4) KY = IY - IMAGE(3) + 1 DO 50 IX = IMAGE(1),IMAGE(2) KX = IX - IMAGE(1) + 1 II = IX + (IY-1)*NPIX(1) C C *** rotate over 90 deg. in equired IF (IFLAG.EQ.0) THEN DATA(KX,KY) = A(II) ELSE DATA(KY,NX-KX+1) = A(II) END IF 50 CONTINUE 60 CONTINUE END IF RETURN END SUBROUTINE PIXVAL(FMES,ISI,NPL,IPL,IL,VAL) C+++ C.PURPOSE: Read a pixel in a frame into an real variable C.AUTHOR: Rein H. Warmels, ESO-Garching C.VERSION: ?????? RHW Creation C.VERSION: 890117 RHW documented C.COMMENTS: none C--- IMPLICIT NONE REAL FMES(1) INTEGER ISI INTEGER NPL INTEGER IPL INTEGER IL REAL VAL C INTEGER MADRID(1) INTEGER INDEX COMMON /VMR/MADRID C *** IF (IPL.GT.NPL) THEN VAL = 0. ELSE INDEX = (IL-1)*NPL + IPL VAL = FMES(INDEX) END IF C RETURN END SUBROUTINE LIBA(NL,NPL,NPL1,NPL2,NPL3,FMES,RMES) C+++ C.PURPOSE: Write an array into a frame 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 INTEGER K, I C COMMON /VMR/MADRID C C *** NPD = NPL* (NL-1) + NPL1 NPF = NPD + NPL2 - NPL1 K = 0 C DO 10 I = NPD,NPF,NPL3 K = K + 1 FMES(I) = RMES(K) 10 CONTINUE C 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 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