C @(#)lsqmon.for 17.1.1.1 (ES0-DMD) 01/25/02 17:10:50 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 LSQMON(NRPNT,NRPRM,PRM,FCTVEC,FCTJAC,LJAC,SV,DIMGRA, + ITER,NFEVAL,IW,LIW,W,LW) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C.MODULE C FIT C C.NAME C LSQMON C C.PURPOSE C Monitoring the least squares algorithms. C C.KEYWORDS C Monitoring. C C.DESCRIPTION C trivial C C.LANGUAGE C FORTRAN C C.CALLING SEQUENCE C CALL LSQMON(NRRES,NRPRM,PRM,FCTVEC,FCTJAC,LJAC,SV,DIMGRA, C + ITER,NFEVAL,IW,LIW,W,LW) C C.INPUT PARAMETERS C NRRES INTEGER Number of residuals C NRPRM INTEGER Number of parameters C PRM (NRPRM) DOUBLE Parameters C LJAC INTEGER 1st dimension of jacobian C FCTVEC (NRRES) DOUBLE Approximating values C FCTJAC (LJAC,NRRES) DOUBLE values of the jacobian C SV (NRPRM) DOUBLE singular values C DIMGRA INTEGER Dimension of gradient space C ITER INTEGER Iteration number C NFEVAL INTEGER Present number of fct eval. C IW (LIW) INTEGER unused C LIW INTEGER C W (LW) DOUBLE C LW INTEGER C C.MODIFIED PARAMETERS C none C C.OUTPUT PARAMETERS C none C C.FILES C none C C.MODULES CALLED C STTPUT C C.AUTHOR C Ph. DEFERT, Feb 1986 C C.MODIFICATIONS C M. Peron Nov 1990 replace F01DEF by F06EAF C C----------------------------------------------------------------------- C IMPLICIT NONE C .. C .. Scalar Arguments .. INTEGER DIMGRA,LIW,LJAC,LW,NFEVAL,ITER,NRPRM,NRPNT INTEGER MADRID(1) C .. C .. Array Arguments .. DOUBLE PRECISION FCTJAC(LJAC,NRPRM),FCTVEC(NRPNT),IW(LIW), + PRM(NRPRM),SV(NRPRM),W(LW) C .. C .. Local Scalars .. DOUBLE PRECISION FSUMSQ,GRDNRM,REDCHI,RCHOLD,CHIPERC INTEGER I,STATUS C .. C .. Local Arrays .. DOUBLE PRECISION GRD(100) CHARACTER LINE*78 C DOUBLE PRECISION F06EAF C .. C .. External Files .. INCLUDE 'MID_INCLUDE:FITNAGI.INC/NOLIST' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:FITNAGC.INC/NOLIST' SAVE REDCHI DATA REDCHI/0.0/ C .. C .. Executable Statements .. RCHOLD = REDCHI FSUMSQ = F06EAF(NRPNT,FCTVEC,1,FCTVEC,1) REDCHI = DMAX1(FSUMSQ/DBLE(NRPNT-NRPRM+NRPFIX),0.D0) IF (ITER.GT.1 .AND. RCHOLD.GT.1.D-15) THEN CHIPERC = 100.* (RCHOLD-REDCHI)/RCHOLD ELSE CHIPERC = 0. END IF CALL LSQGRD(NRPNT,NRPRM,FCTVEC,FCTJAC,LJAC,GRD) GRDNRM = DSQRT(F06EAF(NRPRM,GRD,1,GRD,1)) CALL STTPUT(' ',STATUS) CALL STTPUT( + ' Iter F. Eval. Sum of Squares Red. Chisq. % Decr.' + //' Grad. Norm. Grad. Dim.',STATUS) WRITE (LINE,9000) ITER,NFEVAL,FSUMSQ,REDCHI,CHIPERC,GRDNRM,DIMGRA CALL STTPUT(LINE,STATUS) CALL STTPUT(' ',STATUS) CALL STTPUT(' Parameters Gradient '// + 'Singular Values',STATUS) DO 10 I = 1,NRPRM WRITE (LINE,9010) PRM(I),GRD(I),SV(I) CALL STTPUT(LINE,STATUS) 10 CONTINUE CALL STTPUT(' ',STATUS) RETURN 9000 FORMAT (I5,2X,I5,3X,1PE12.4,4X,1PE12.4,2X,0PF6.2,3X,1PE9.1,7X,I3) 9010 FORMAT (2X,1PD15.7,6X,1PD9.1,6X,1PD9.1) END