C @(#)piant5.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:57 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 PIANT5 (RNY,MX,MY,NP,NC,IA,FIFA,FONDO,ZE) C IMPLICIT NONE INTEGER MX INTEGER MY REAL RNY(MY,MX) INTEGER NP INTEGER NC INTEGER IA REAL FIFA REAL FONDO REAL ZE C INTEGER KMAX, NRPX INTEGER MAXPIX REAL AMI, AFACT INTEGER I, J, K, KKK, I1 INTEGER ILIN REAL A, AA REAL FFT REAL PNY, VAL INTEGER START(2), SIZE(2) INTEGER ERRCOD REAL RIV(40000) INTEGER LDATA(40001) REAL CUTS(2) REAL FAUX(3) INTEGER INAUX(5) INTEGER OUTAUX(2) C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C INCLUDE 'MID_INCLUDE:IDIDEV.INC' INCLUDE 'MID_INCLUDE:IDIMEM.INC' C INCLUDE 'MID_INCLUDE:ST_DAT.INC' C KMAX = QLUTSZ - 1 START(1) = IA+1 START(2) = 2 CUTS(1) = 0 CUTS(2) = KMAX SIZE(1) = NP*3 SIZE(2) = NC*3 NRPX = SIZE(1)*SIZE(2) MAXPIX = CUTS(2) AMI = 10.**35 A = -AMI C C *** auxilary info array INAUX(1) = D_R4_FORMAT !we have real data INAUX(2) = 1 INAUX(3) = SIZE(1) INAUX(4) = 1 INAUX(5) = 1 C C *** scale frame FAUX(1) = 1.0 FAUX(2) = CUTS(1) FAUX(3) = CUTS(2) C C *** OUTAUX(1) = KMAX OUTAUX(2) = 0 C C ** start the code IF (IDINUM.LT.11) THEN CALL IIMSTW(QDSPNO,QIMCH,0,SIZE(1),SIZE(2),QMDEP, * START(1),START(2),ERRCOD) ENDIF C DO 10 I = 1,NC DO 20 J = 1,NP A = AMAX1(A,RNY(I,J)) AMI = AMIN1(AMI,AMAX1(0.,RNY(I,J))) 20 CONTINUE 10 CONTINUE C A = 15000. FFT = FONDO IF (FFT.LE.0.) FFT=0.1 IF (AMI.LT.(FONDO+ZE*SQRT(FFT))) THEN AMI=FONDO+ZE*SQRT(FFT) ENDIF C A = AMAX1(AMI, (A / FIFA)) AA = A - AMI IF (AA .LT. 1) AA = 1. AFACT = FLOAT(MAXPIX) / AA ILIN = START(2)-1 DO 30 I = 1,NC K = 1 DO 40 J = 1,NP PNY=RNY(I,J) IF (PNY.LE.-1000.) PNY=AMI VAL= AMIN1(FLOAT(MAXPIX),(PNY-AMI)*AFACT) DO 50 KKK = 0 , 2 I1 = K+KKK RIV(I1) = VAL 50 CONTINUE K = K + 3 40 CONTINUE C C *** pack into bytes CALL K1PACK(RIV,RIV,RIV,RIV,RIV,INAUX,FAUX,LDATA(2),OUTAUX) DO 60 KKK = 1,3 ILIN = ILIN+1 CALL IIMWMY(QDSPNO,QIMCH,LDATA(2),SIZE(1),QMDEP,4, * START(1),ILIN,ERRCOD) 60 CONTINUE 30 CONTINUE C RETURN END