C @(#)fitcopy.for	17.1.1.1 (ES0-DMD) 01/25/02 17:11:04
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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  15:22 - 20 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  program FITCOPY.FOR
C
C.PURPOSE
C
C  Execute the command
C  MODIFY/FIT  table seq_no [fitname]
C  SAVE/FIT  table seq_no [fitname]
C
C.KEYWORDS
C
C  fit, parameter initializaton
C
C.INPUT/OUTPUT
C
C  P1 - P2     contain input parameters
C
C.ALGORITHM
C
C  Use fit interface routines
C  The program defines the parameter guesses from table columns
C  or saves fitted values (and errors) in a table
C
C  In the form INIT/FIT the table contains the
C  initial guesses as :par_GUES for each parameter 'par' in the fit
C  In the form SAVE/FIT fitted parameter values and error are
C  stored as :par and :par_ERROR for each parameter 'par'
C
C-----------------------------------------------------------
C
C ... define data
      IMPLICIT  NONE
C
      INTEGER      PL,TID,SEQ,STATUS,KUN,KNUL
      INTEGER      IAV, ISTAT, I, NCOL, I2, NC1
      INTEGER      ICOL(100), NAMLEN
      INTEGER      MADRID(1),EC,EL,ED
C
      REAL VAL(100)
C
      LOGICAL ISEL,NULL(100)
C
      CHARACTER*16  MSG,UNIT
      CHARACTER*80  TABLE,NAME
      CHARACTER*8   FORM
      CHARACTER*80  COM
      CHARACTER*16  LABEL(100)
C
       INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'
       INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST'
       INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'
       COMMON/VMR/MADRID
       INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST'
C
      DATA MSG/'ERR:FITCOPYxxxx'/,UNIT/' '/
      DATA FORM/'G14.6'/
      DATA NAMLEN/80/
C
C ... get parameters
C
      CALL STSPRO('FITCOPY')
      CALL FITBL 
      CALL STKRDC('P1',1,1,NAMLEN,IAV,TABLE,KUN,KNUL,ISTAT)
      CALL STKRDC('P3',1,1,NAMLEN,IAV,NAME,KUN,KNUL,ISTAT)
      CALL STKRDI('INPUTI',1,1,IAV,SEQ,KUN,KNUL,ISTAT)
      CALL STKRDC('MID$CMND',1,1,4,IAV,COM,KUN,KNUL,ISTAT)
C
C ... get fitname and handle default
C
      IF (NAME(1:1).EQ.'?') THEN
          CALL STKRDC('FITNAME',1,1,NAMLEN,IAV,NAME,KUN,KNUL,ISTAT)
      ELSE
          CALL STKWRC('FITNAME',1,NAME,1,NAMLEN,KUN,ISTAT)
      END IF
C
C ... init fit structure
C
      CALL FTINIT(NAME,ISTAT)
      IF (COM(1:1).EQ.'M') THEN
          DO 10 I = 1,FZNPTOT
              PL     = FZPLEN(I)
              LABEL(I) = FZPTOKEN(I) (1:PL)//'_GUESS'
   10     CONTINUE
          NCOL   = FZNPTOT
      ELSE
          DO 20 I = 1,FZNPTOT
              I2     = 2*I
              PL     = FZPLEN(I)
              LABEL(I2-1) = FZPTOKEN(I)
              LABEL(I2) = FZPTOKEN(I) (1:PL)//'_ERROR'
   20     CONTINUE
          NCOL   = 2*FZNPTOT
      END IF
C
C ... init table
C
      CALL STECNT('GET',EC,EL,ED)
      CALL STECNT('PUT',1,0,0)
      CALL TBTOPN(TABLE,F_IO_MODE,TID,ISTAT)
      CALL STECNT('PUT',EC,EL,ED)
      IF (ISTAT.NE.0) 
     +    CALL TBTINI(TABLE,F_TRANS,F_O_MODE,NCOL,10,TID,ISTAT)
      DO 30 I = 1,NCOL
          CALL TBLSER(TID,LABEL(I),ICOL(I),ISTAT)
          IF (ICOL(I).LE.0) THEN
              ICOL(I) = 0
              IF (COM(1:1).EQ.'S') THEN
                  CALL TBCINI(TID,D_R4_FORMAT,1,FORM,
     .                        UNIT,LABEL(I),ICOL(I),
     +                        ISTAT)
              END IF
          END IF
   30 CONTINUE
C
C ... copy to/from table
C
      IF (COM(1:1).EQ.'M') THEN
          CALL TBSGET(TID,SEQ,ISEL,ISTAT)
          IF ( .NOT. ISEL) THEN
              CALL STTPUT(' Non selected row ',ISTAT)
              GO TO 70
          END IF
          DO 40 I = 1,NCOL
              IF (ICOL(I).NE.0 .AND. FZFIXED(I).LT.0) THEN
                CALL TBERDR(TID,SEQ,ICOL(I),VAL(I),NULL(I),ISTAT)
                FZVALUE(I) = VAL(I)
              ENDIF
   40     CONTINUE
      ELSE
          NC1    = NCOL/2
          DO 50 I = 1,NC1
              I2     = 2*I
              VAL(I2-1) = FZVALUE(I)
              VAL(I2) = FZERROR(I)
   50     CONTINUE
          CALL TBRWRR(TID,SEQ,NCOL,ICOL,VAL,ISTAT)
      END IF
      CALL TBTCLO(TID,ISTAT)
C
C ... end
C
      CALL FTEXIT(NAME,ISTAT)
   70 IF (ISTAT.NE.0) THEN
          WRITE (MSG(13:16),9000) ISTAT
          CALL TDERRR(ISTAT,MSG,STATUS)
      END IF
      CALL STSEPI
 9000 FORMAT (I4)
      END