C===========================================================================
C Copyright (C) 1995-2005 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 050803	last modif
C 
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,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
