C @(#)tddspfit.for 17.1.1.1 (ESO-DMD) 01/25/02 17:47:14 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 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 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C C.VERSION: 1.0 ESO-FORTRAN Conversion, AA 11:40 - 15 DEC 1987 C C.LANGUAGE: F77+ESOext C C.AUTHOR: J.D.PONZ C 900219 KB, throw out SX calls C C C.IDENTIFICATION TDDSPFIT.FOR C.KEYWORDS TABLE, APPLICATIONS C.ENVIRONMENT MIDAS C C------------------------------------------------------------------ SUBROUTINE TDRDIS(CPAR,IPAR,RPAR,DPAR,ISTAT) C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C.PURPOSE C IMPLICIT NONE C C DISPLAY STANDARD FIT RESULTS C C------------------------------------------------------------------ CHARACTER*20 CPAR ! IN : METHOD INTEGER IPAR(*) ! IN : INTEGER INFO REAL RPAR(*) ! IN : SINGLE PRECISION INFO DOUBLE PRECISION DPAR(*) ! IN : DOUBLE PRECISION INFO INTEGER ISTAT ! OUT: STATUS CHARACTER*4 METHOD C C BRANCH TO THE CORRESPONDING ROUTINE C METHOD = CPAR(17:20) IF (METHOD(1:4).EQ.'LINE') . CALL TDRDS1(CPAR,IPAR,RPAR,DPAR,ISTAT) IF (METHOD(1:4).EQ.'MULT') . CALL TDRDS2(CPAR,IPAR,RPAR,DPAR,ISTAT) RETURN END SUBROUTINE TDRDS1(CPAR,IPAR,RPAR,DPAR,ISTAT) C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C.PURPOSE C C DISPLAY STANDARD RESULTS OF THE DISPERSION ANALYSIS C C------------------------------------------------------------------ C IMPLICIT NONE CHARACTER*20 CPAR ! IN : METHOD INTEGER IPAR(*) ! IN : INTEGER INFO REAL RPAR(*) ! IN : SINGLE PRECISION INFO DOUBLE PRECISION DPAR(*) ! IN : DOUBLE PRECISION INFO INTEGER ISTAT ! OUT : STATUS C INTEGER I CHARACTER*80 FREG01 CHARACTER*80 FREG02 CHARACTER*80 FREG03 CHARACTER*80 FREG04 CHARACTER*80 FREG05 CHARACTER*80 FREG06 CHARACTER*80 FREG07 DATA FREG01/ + ' REGRESSION Input Table : Type : ' + / DATA FREG02/ + ' N.Cases : ; N.Ind.Vars : ' + / DATA FREG03/ + ' Dependent variable : column # ' + / DATA FREG04/ + ' Conf.level: Std.Error : ' + / DATA FREG05/ + ' Var. Column Coefficient Std.Err ' + / DATA FREG06/ + ' # ' + / DATA FREG07/ + ' Constant Term ' + / C FREG01(15:18) = CPAR(1:4) FREG01(37:44) = CPAR(9:16) FREG01(54:62) = ' ' IF (CPAR(17:20).EQ.'LINE') FREG01(54:59) = 'LINEAR' IF (CPAR(17:20).EQ.'POWE') FREG01(54:58) = 'POWER' IF (CPAR(17:20).EQ.'NONL') FREG01(54:62) = 'NONLINEAR' CALL STTPUT(FREG01,ISTAT) CALL STTPUT(' ',ISTAT) WRITE (FREG02(15:21),9000) IPAR(1) WRITE (FREG02(40:42),9020) IPAR(2) CALL STTPUT(FREG02,ISTAT) WRITE (FREG03(35:37),9020) IPAR(3) CALL STTPUT(FREG03,ISTAT) WRITE (FREG04(15:27),9010) RPAR(1) WRITE (FREG04(50:62),9010) RPAR(2) C CALL STTPUT(FREG04,ISTAT) CALL STTPUT(' ',ISTAT) CALL STTPUT(FREG05,ISTAT) DO 10 I = 1,IPAR(2) WRITE (FREG06(4:6),9020) I WRITE (FREG06(12:14),9020) IPAR(I+3) WRITE (FREG06(21:41),9030) DPAR(I+1) WRITE (FREG06(45:57),9010) RPAR(I+3) CALL STTPUT(FREG06,ISTAT) 10 CONTINUE WRITE (FREG07(21:41),9030) DPAR(1) WRITE (FREG07(45:57),9010) RPAR(3) CALL STTPUT(' ',ISTAT) CALL STTPUT(FREG07,ISTAT) RETURN 9000 FORMAT (I7) 9010 FORMAT (G13.7) 9020 FORMAT (I3) 9030 FORMAT (G20.12) END SUBROUTINE TDRDS2(CPAR,IPAR,RPAR,DPAR,ISTAT) C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C.PURPOSE C C DISPLAY STANDARD RESULTS OF THE POLYNOMIAL FIT C C------------------------------------------------------------------ C IMPLICIT NONE CHARACTER*20 CPAR ! IN : METHOD INTEGER IPAR(*) ! IN : INTEGER INFO REAL RPAR(*) ! IN : SINGLE PRECISION INFO DOUBLE PRECISION DPAR(*) ! IN : DOUBLE PRECISION INFO INTEGER ISTAT ! OUT : STATUS C INTEGER I,I1,J REAL XX CHARACTER*132 FREG01 CHARACTER*132 FREG02 CHARACTER*132 FREG03 CHARACTER*132 FREG04 CHARACTER*132 FREG05 CHARACTER*132 FREG06 CHARACTER*132 FREG07 C DATA FREG01/ + ' POLYNOMIALS Input Table : Type : ' + / DATA FREG02/ + ' N.Cases : ; N.Ind.Vars : ' + / DATA FREG03/ + ' Dependent variable : column # ' + / DATA FREG04/ + ' Independent variable: column # degree : ' + / DATA FREG05/ + ' degree ' + / DATA FREG06/ + ' ' + / DATA FREG07/ + ' R.M.S error : ' + / C FREG01(15:18) = CPAR(1:4) FREG01(37:44) = CPAR(9:16) FREG01(54:62) = 'MUL L-S' CALL STTPUT(FREG01,ISTAT) CALL STTPUT(' ',ISTAT) WRITE (FREG02(15:21),9000) IPAR(1) WRITE (FREG02(40:42),9020) IPAR(2) CALL STTPUT(FREG02,ISTAT) WRITE (FREG03(35:37),9020) IPAR(3) CALL STTPUT(FREG03,ISTAT) WRITE (FREG04(35:37),9020) IPAR(4) WRITE (FREG04(54:56),9020) IPAR(6) CALL STTPUT(FREG04,ISTAT) WRITE (FREG04(35:37),9020) IPAR(5) WRITE (FREG04(54:56),9020) IPAR(7) IF (IPAR(2).GT.1) CALL STTPUT(FREG04,ISTAT) CALL STTPUT(' ',ISTAT) CALL STTPUT(FREG05,ISTAT) DO 10 I = 1,IPAR(6) + 1 I1 = (I-1)* (IPAR(7)+1) + 1 WRITE (FREG06(4:),9030) I - 1, (DPAR(J),J=I1,I1+IPAR(7)) CALL STTPUT(FREG06,ISTAT) 10 CONTINUE XX = RPAR(5) XX = SQRT((XX*XX)/IPAR(1)) WRITE (FREG07(31:43),9010) XX CALL STTPUT(' ',ISTAT) CALL STTPUT(FREG07,ISTAT) RETURN 9000 FORMAT (I7) 9010 FORMAT (G13.7) 9020 FORMAT (I3) 9030 FORMAT (I3,1P10E12.4) END