C @(#)lsfun1t.for 17.1.1.1 (ES0-DMD) 01/25/02 17:10:49 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 LSFU1T(NRRES,NRPRM,PRM,FCTVEC) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C.MODULE C FIT C C.NAME C LSFUN1_T C C.PURPOSE C Function to compute the approximating function at each point, C for FIT/TABLE C C.KEYWORDS C Approximating Function. C C.DESCRIPTION C Read the TABLE row by row, and compute the fitting function by C calling MIDAS functions C C.LANGUAGE C FORTRAN C C.CALLING SEQUENCE C CALL LSFUN1_T(NRRES,NRPRM,PRM,FCTVEC) C C.INPUT PARAMETERS C NRRES INTEGER Number of residuals C NRPRM INTEGER Number of parameters C PRM (NRPRM) DOUBLE Parameters C C.MODIFIED PARAMETERS C none C C.OUTPUT PARAMETERS C FCTVEC (NRRES) DOUBLE Approximating values C C.FILES C FIT_NAG.INC/NOLIST C C.MODULES CALLED C FTFUNC C C.AUTHOR C Ph. DEFERT, Feb 1986 C M. Peron apr 92 fit on tables for Apollo and VAX C.MODIFICATIONS C C C----------------------------------------------------------------------- C C IMPLICIT NONE C .. Scalar Arguments .. INTEGER NRPRM,NRRES C .. C .. Array Arguments .. DOUBLE PRECISION FCTVEC(NRRES),PRM(NRPRM) C .. C .. Scalars in Common .. INTEGER NRCOL,ISTAR CHARACTER WGTTYP*1 C .. C .. Arrays in Common .. INTEGER ICOL(10),ACOL,AROW C .. C .. Local Scalars .. DOUBLE PRECISION W,Y,Y1,YOUT,YY INTEGER IDAT,IFUN,IPNT,ISTAT,K,NC,NROW,NS,BEGFCT,IP LOGICAL ISEL,VALID C .. C .. Local Arrays .. DOUBLE PRECISION DUMMY(10) REAL XVAL(10),X(10) LOGICAL NULL(10) C .. C .. Common blocks .. C .. C .. External Files .. INCLUDE 'MID_INCLUDE:FITNAGI.INC/NOLIST' INCLUDE 'MID_INCLUDE:FITNAGC.INC/NOLIST' COMMON /LSQFUN/ICOL,NRCOL,ISTAR,WGTTYP C .. C .. Executable Statements .. C C deal with linear simple constraints C DO 10 K = 1,NRPRM IP = FIXPAR(K) IF (IP.EQ.0) PRM(K) = PARINI(K) IF (IP.GT.0) THEN PRM(K) = PRM(IP)*PRPFAC(K) PARAM(K) = PRM(K) END IF 10 CONTINUE C C Go through the table C CALL TBIGET(FZIDEN,NC,NROW,NS,ACOL,AROW,ISTAT) IPNT = 0 DO 50 IDAT = 1,NROW CALL TBSGET(FZIDEN,IDAT,ISEL,ISTAT) IF ( .NOT. ISEL) GO TO 50 CALL TBRRDR(FZIDEN,IDAT,NRCOL,ICOL(ISTAR),XVAL(ISTAR), + NULL(ISTAR),ISTAT) VALID = ISEL DO 20 K = 1,NRCOL VALID = VALID .AND. ( .NOT. NULL(K+ISTAR-1)) 20 CONTINUE IF ( .NOT. VALID) GO TO 50 Y = XVAL(2) W = XVAL(1) DO 30 K = 1,NRCOL X(K) = XVAL(K+2) 30 CONTINUE C C Compute the weighting factors C IF (WGTTYP(1:1).NE.'W') THEN IF (WGTTYP(1:1).EQ.'C') THEN W = 1. ELSE IF (WGTTYP(1:1).EQ.'S') THEN YY = ABS(Y) IF (YY.LT.1.E-12) THEN W = 1. ELSE W = 1./YY END IF ELSE IF (WGTTYP(1:1).EQ.'I') THEN W = 1./W**2 END IF END IF C C Compute the fitting values C Y1 = 0.D0 BEGFCT = 1 DO 40 IFUN = 1,NRFUN CALL FTFUNC(FCTCOD(IFUN),NRIND,X,ACTPAR(IFUN),PRM(BEGFCT), + YOUT,DUMMY) Y1 = Y1 + YOUT BEGFCT = BEGFCT + ACTPAR(IFUN) 40 CONTINUE IPNT = IPNT + 1 FCTVEC(IPNT) = SQRT(W)* (Y1-Y) 50 CONTINUE RETURN END