C===========================================================================
C Copyright (C) 1995-2007 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 AFI
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C IDENTIFICATION
C   	program afi			version 1.00		910320
C	G.M.Richter ZIAP Sternwarte Babelsberg
C
C PURPOSE
C	adaptive filtering of images:
C	reduction of the noise without damaging the resolution.
C	cleaning (smoothing, low pass filtering) as well as structur enhancing
C	and detecting (by two types of high pass filtering: gradient and 
C	Laplace filter) is possible.
C
C ALGORITHM
C	The local signal-to-noise ratio as a function of decreasing resolution
C	is evaluated via the H-transform: mean gradients and curvatures over 
C	different scale lengths (obtained from the H-coefficients of different
C	order) are compared to the corresponding exspectation values of the
C	noise. The order for which this signal-to-noise ratio exceedes a given
C	parameter K indicates the local resolution scale lenght of the signal
C	(dubbed: the point becomes significant at this order), and determines
C	the size of the impuls response of the filter at this point.
C
C KEYWORDS
C	IN_A	input frame
C	IN_B	input mask for noise statistics:
C		Only unmasked (mask value=0) pixels of the input frame are
C		used to estimate the noise statistics.
C		If 'NULL' is put in, no mask is used
C	OUT_A	output frame
C	INPUTC/C/1/1 type of adaptive filter:
C		'S'=smoothing
C		'G'=gradient filter
C		'L'=Laplace-filter
C	INPUTC/C/2/1 shape of impulse resonse:
C		'B'=box
C		'P'=pyramide
C	INPUTI/I/1/1 maximal size of impulse response
C		(in regions of high resolution the actual size is smaller)
C	INPUTR/R/1/1 threshold for significance
C	INPUTC/C/3/1 noise model:
C		'A'=additive noise is assumed
C		'P'=Poisson-noise is assumed
C
C NOTE
C	When the algorithm is finished some information on the noise 
C	statistics is put out on the terminal: the standard deviation and
C	the exspectation values of the gradients and the Laplace-terms at 
C	every order involved, and the number of pixels which became significant
C	on every order by the gradient and by the Laplace term respectively.
C	The rest pixels are set to the maximal size response.
C
C
C--------------------------------------------------------------------------
       IMPLICIT NONE

       INTEGER       MADRID(1),NRD,K1,K2,STAT,ORD,SIZ,
     >               NAXIS,NPIX(2),NAXISMT,NPIXMT(2),
     >               IMNIN,IMNOUT,IMNH0,IMNH1,IMNHG,IMNHL,IMNM,IMNMT
     
       INTEGER*8     PNTIN,PNTOUT,PNTH0,PNTH1,PNTHG,PNTHL,PNTM,PNTMT
       INTEGER	     NSG,NSL,REST
       CHARACTER*60  IN,OUT,MT
       CHARACTER     IDENT*72,UNIT*64,TYP*1,FORM*1,NOI*1,YMT*1

       DOUBLE PRECISION START(2),STEP(2)

       REAL          K,EG,EL,SG,SL,MOG,MOL,MUL,CUT(4)
C
C *** include MIDAS definition table
       INCLUDE       'MID_INCLUDE:ST_DEF.INC'
       COMMON        /VMR/MADRID
       COMMON        /TEST/EG(16),SG(16),EL(16),SL(16),NSG(16),NSL(16),
     >                     REST,MOG,MOL,MUL
       INCLUDE       'MID_INCLUDE:ST_DAT.INC'
C
C common block for statistics

C *** set up MIDAS environment
      CALL STSPRO('afi')

C get input frame and map it as an image with pixels in floating point format
      CALL STKRDC('IN_A',1,1,60,NRD,IN,K1,K2,STAT)
      CALL STIGET(IN,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,2,NAXIS,NPIX,
     >      	    START,STEP,IDENT,UNIT,PNTIN,IMNIN,STAT)
C
      IF (NAXIS.LT.2) CALL STETER(1,'*** FATAL: dimension less than 2')

C get name of output frame and create and map it
      CALL STKRDC('OUT_A',1,1,60,NRD,OUT,K1,K2,STAT)
      CALL STIPUT(OUT,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,NAXIS,NPIX,
     >           START,STEP,IDENT,UNIT,PNTOUT,IMNOUT,STAT)

C get name of mask image, if name=NULL -> no mask image
      YMT='Y'
      CALL STKRDC('IN_B',1,1,60,NRD,MT,K1,K2,STAT)
      IF ((MT(1:4).EQ.'NULL').OR.(MT(1:4).EQ.'null'))THEN
         YMT='N'
      ELSE
         CALL STIGET(MT,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,2,NAXISMT,
     >               NPIXMT,START,STEP,IDENT,UNIT,PNTMT,IMNMT,STAT)
         IF ((NPIXMT(1).NE.NPIX(1)).OR.(NPIXMT(2).NE.NPIX(2))) THEN
            CALL STETER(1,
     2           '*** FATAL: Image and mask have different dimensions')
         ENDIF
      ENDIF
C
C *** read char.key 'FILTER TYPE [S/G/L]'
      CALL STKRDC('INPUTC',1,1,1,NRD,TYP,K1,K2,STAT)
C
C *** read char.key 'IMPULSE-RESPONSE SHAPE [P/B]'
      CALL STKRDC('INPUTC',1,2,1,NRD,FORM,K1,K2,STAT)
C
C *** read integer key 'FILTER-SIZE'
      CALL STKRDI('INPUTI',1,1,NRD,SIZ,K1,K2,STAT)
C
C *** read real key 'THRESHOLD K'
      CALL STKRDR('INPUTR',1,1,NRD,K,K1,K2,STAT)
C
C read char.key 'NOISE TYPE [A/P]'
      CALL STKRDC('INPUTC',1,3,1,NRD,NOI,K1,K2,STAT)
C
C *** check input parameter
      CALL UPCAS(NOI,NOI)
      IF (NOI.NE.'A' .AND. NOI.NE.'P') THEN
         CALL STETER(1,'FATAL: *** INVALID NOISE-TYPE')
      ENDIF
      CALL UPCAS(TYP,TYP)
      IF (TYP.NE.'S' .AND. TYP.NE.'G' .AND. TYP.NE.'L') THEN
         CALL STETER(1,'*** FATAL: INVALID FILTER-TYPE')
      ENDIF
      CALL UPCAS(FORM,FORM)
      IF (FORM.NE.'B' .AND. FORM.NE.'P') THEN
         CALL STETER(1,'*** FATAL: INVALID IMPULSE-RESPONSE SHAPE')
      ENDIF
C
C *** get transform-order ORD from window-size SIZ
      IF (FORM.EQ.'P') THEN
         ORD=2                                    ! size = 3
         IF(SIZ.GT.3)   ORD=3
         IF(SIZ.GT.5)   ORD=4
         IF(SIZ.GT.7)   ORD=5
         IF(SIZ.GT.11)  ORD=6
         IF(SIZ.GT.15)  ORD=7
         IF(SIZ.GT.23)  ORD=8
         IF(SIZ.GT.31)  ORD=9
         IF(SIZ.GT.47)  ORD=10
         IF(SIZ.GT.63)  ORD=11
         IF(SIZ.GT.95)  ORD=12
         IF(SIZ.GT.127) ORD=13
         IF(SIZ.GT.191) ORD=14	!255
      ELSE
         ORD=2                                    ! size = 3
         IF(SIZ.GT.3)   ORD=3
         IF(SIZ.GT.5)   ORD=4
         IF(SIZ.GT.9)   ORD=5
         IF(SIZ.GT.17)  ORD=6
         IF(SIZ.GT.33)  ORD=7
         IF(SIZ.GT.65)  ORD=8
         IF(SIZ.GT.129) ORD=9
         IF(SIZ.GT.257) ORD=10	!513
      ENDIF
C
C *** create and map images to work
      CALL STIPUT('mid_h0',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,NAXIS,NPIX,
     >           START,STEP,IDENT,UNIT,PNTH0,IMNH0,STAT)
      CALL STIPUT('mid_h1',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,NAXIS,NPIX,
     >        START,STEP,IDENT,UNIT,PNTH1,IMNH1,STAT)
      CALL STIPUT('mid_hg',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,NAXIS,NPIX,
     >        START,STEP,IDENT,UNIT,PNTHG,IMNHG,STAT)
      CALL STIPUT('mid_hl',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,NAXIS,NPIX,
     >        START,STEP,IDENT,UNIT,PNTHL,IMNHL,STAT)
      CALL STIPUT('mid_m',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,NAXIS,NPIX,
     >        START,STEP,IDENT,UNIT,PNTM,IMNM,STAT)
C
C *** start algorithm
      CALL AFIDO(NPIX(1),NPIX(2),MADRID(PNTMT),MADRID(PNTIN),
     >           MADRID(PNTH0),MADRID(PNTH1),MADRID(PNTHG),
     >           MADRID(PNTHL),MADRID(PNTOUT),MADRID(PNTM),
     >           ORD,TYP,FORM,NOI,K,YMT)

C *** information on image statistics and number of significant points
      CALL AINFO(ORD)
c
C *** copy all descriptors from input frame to output frame
C
C  copy descriptors and update LHCUTS + HISTORY
      CALL DSCUPT(IMNIN,IMNOUT,' ',STAT)
C
C *** write cuts for gradient and laplace
      IF (TYP.NE.'S') THEN
         IF (TYP.EQ.'G') THEN
            CUT(2)=3.*MOG
            CUT(1)=0.
         ELSE
            CUT(2)=3.*MOL
            CUT(1)=3.*MUL
         ENDIF
         CALL STDWRR(IMNOUT,'LHCUTS',CUT,1,2,K1,STAT)
      ENDIF
C
C *** release files, update keywords and exit
      CALL STSEPI
      END
