C @(#)rfotadapt.for	19.1 (ES0-DMD) 02/25/03 13:30:13
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
       PROGRAM ADAPT
C+++
C.IDENT:   RFOTADAPT
C.PURPOSE: Use fit on template frame to derive trial values for fitting new 
C          frame
C.AUTHOR:  R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola
C          Osservatorio Astronomico di Roma
C.VERSION: 880930 RHW Installation in MIDAS
C          890915 RHW MIDAS tables included; partially rewritten 
C.VERSION: 900121 RHW All variables declared; implicit none included 
C.VERSION: 900122 RHW IMPLICIT NONE added; all variables defined
C----
      IMPLICIT     NONE
      INCLUDE      'MID_REL_INCL:RFOTDECL.INC'
C
      INTEGER      EC, ED, EL
      INTEGER      IAV,IAC
      INTEGER      ICP, IHL
      INTEGER      IROW
      INTEGER      ISTAT
      INTEGER      JC, JH
      INTEGER      KF
      INTEGER      KSX,KSY
      INTEGER      KUN,KNUL
      INTEGER      KVI(2)
      INTEGER      MADRID(1)
      INTEGER      NCP, NHL
      INTEGER      NCINT,NRINT,NSINT
      INTEGER      NACINT,NARINT
      INTEGER      TIDINT
C
      REAL         DX, DY
      REAL         CDS
      REAL         FMA
      REAL         HF
      REAL         TSH
C
      CHARACTER    INTFIL*60
      CHARACTER    RSN
      CHARACTER    STRING*80
C
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
      COMMON       /VMR/MADRID
      INCLUDE      'MID_INCLUDE:ST_DAT.INC'
C
C *** Is MIDAS out there
      CALL STSPRO('ADAPT')
C
C *** read the intermediate file
      CALL STKRDC('IN_A',1,1,60,IAC,INTFIL,KUN,KNUL,ISTAT)  ! intermediate file
      CALL STECNT('GET',EC,ED,EL)
      CALL STECNT('PUT',1,0,0)
      CALL TBTOPN(INTFIL,F_IO_MODE,TIDINT,ISTAT)
      IF (ISTAT.NE.0) THEN
         STRING = '*** FATAL: Problems with opening intermediate'//
     2            ' table ... '
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ENDIF
C
C *** get table info
      CALL TBIGET(TIDINT,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT)
      IF (ISTAT.NE.0) THEN
         STRING = '*** FATAL: Problems with getting info for '//
     2            ' intermediate table; Try again ... '
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ENDIF
      IF (NRINT.EQ.0) THEN
         STRING = '*** FATAL: No data points in intermediate table'
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ENDIF
      CALL STECNT('PUT',EC,ED,EL)
C
C *** get the multiplier intensity, background, and holes
      CALL STKRDR('INPUTR',1,1,IAV,TSH,KUN,KNUL,ISTAT)            ! threshold
      CALL STKRDR('INPUTR',2,1,IAV,FMA,KUN,KNUL,ISTAT)            ! intensity
      CALL STKRDR('INPUTR',3,1,IAV,CDS,KUN,KNUL,ISTAT)            ! background
      CALL STKRDR('INPUTR',4,1,IAV,HF,KUN,KNUL,ISTAT)             ! holes factor
      CALL STKRDI('INPUTI',1,2,IAV,KVI,KUN,KNUL,ISTAT)            ! area
      KSX = KVI(1)
      KSY = KVI(2)
C
C *** do the work
      RSN  = 'Y'
      IROW = 1
C
C *** loop through all groups
  101 CONTINUE               
         CALL INTWRD(TIDINT,IROW,NCP,NHL)
         DX  = 0
         DY  = 0
         KF  = 0
C
         IF (PARINT(1).LT.1) THEN
            KF = 2
            IF (PARINT(1)+PARINT(6) .GT. 3) THEN
               PARINT(6) = PARINT(6) + PARINT(1) - 1
               DX        = PARINT(1)-1
               PARINT(1) = 1
            ELSE
               KF=1
            END IF
         END IF
C
         IF (KF.NE.1) THEN
            IF (PARINT(2).LT.1) THEN
               KF = 2
               IF (PARINT(2)+PARINT(7) .GT. 3) THEN
                  PARINT(7) = PARINT(7)+PARINT(2)-1
                  DY        = PARINT(2)-1
                  PARINT(2) = 1
               ELSE
                  KF = 1
               END IF
            ENDIF
         END IF
C
         IF (KSX.NE.0) THEN
            IF (KF.NE.1) THEN
               IF (PARINT(1)+PARINT(6)-1 .GT. KSX) THEN
                  KF = 2
                  IF (KSX-PARINT(1)+1 .GT. 3) THEN
                     PARINT(6) = KSX-PARINT(1)+1
                  ELSE
                     KF = 1
                  END IF
               ENDIF
            END IF
         END IF
C
         IF (KSY.NE.0) THEN
            IF (KF.NE.1) THEN
               IF (PARINT(2)+PARINT(7)-1 .GT. KSY) THEN
                  KF = 2
                  IF (KSY-PARINT(2)+1.GT.3) THEN
                     PARINT(7) = KSY-PARINT(2)+1
                  ELSE
                     KF = 1
                  END IF
              END IF
            ENDIF
         END IF
C
C*** chnage the background with a factor CDS
         PARINT(10) = PARINT(10)*CDS
C
         DO 200 JC = 1,NCP
            ICP = (JC-1)*6
            FITCMP(ICP+2) = FITCMP(ICP+2)+DX
            FITCMP(ICP+3) = FITCMP(ICP+3)+DY
            IF (FITCMP(ICP+1).LT.TSH) THEN
               FLGCMP(JC) = 0
            ELSE
               IF (FLGCMP(JC).NE.1 .AND. RSN.EQ.'Y') THEN
                  FLGCMP(JC) = 1
               ENDIF
            END IF
C
            FITCMP(ICP+1) = FITCMP(ICP+1)*FMA
            IF (KF.EQ.1) THEN
               FLGCMP(JC) = 0

            ELSE IF (KF.EQ.2) THEN
               IF (FITCMP(ICP+2).LT.2) THEN
                  FLGCMP(JC) = 0
               ENDIF
               IF (FITCMP(ICP+3).LT.2) THEN
                  FLGCMP(JC) = 0
               ENDIF
               IF (FITCMP(ICP+2) .GE. PARINT(6)-1) THEN
                  FLGCMP(JC) = 0
               ENDIF
               IF (FITCMP(ICP+3).GE.PARINT(7)-1) THEN
                  FLGCMP(JC) = 0
               ENDIF
            END IF
  200    CONTINUE
C
         DO 400 JH = 1,NHL
               IHL = (JH-1)*3
               FITHOL(IHL+1) = FITHOL(IHL+1)*HF
               FITHOL(IHL+2) = FITHOL(IHL+2)+DX
               FITHOL(IHL+3) = FITHOL(IHL+3)+DY
  400    CONTINUE
C
C *** rewrite the window
         CALL INTWWR(TIDINT,IROW,NCP,NHL)
         IROW = IROW + NCP + NHL
         IF (IROW.LE.NRINT) THEN
            GO TO 101
         ENDIF
C
      CALL TBTCLO(TIDINT,ISTAT)
      CALL STSEPI
      END
