* * $Id: hparam.F,v 1.1.1.1 1996/01/16 17:07:45 mclareni Exp $ * * $Log: hparam.F,v $ * Revision 1.1.1.1 1996/01/16 17:07:45 mclareni * First import * * #include "hbook/pilot.h" *CMZ : 4.22/08 04/07/94 08.57.13 by Rene Brun *-- Author : SUBROUTINE HPARAM (IDH,ICONTR,R2MINI,MAXPOW,COEFFI,ITERM,NCOEF) *.==========> *. MULTIDIMENSIONAL FIT PACKAGE - AUTHOR: D. LIENART *.==========> *. 1. COMMON /HCPAR1/ *. *. IOPT SELECTS VARIOUS OPTIONS FOR THE FIT *. 1 ENABLES/DISABLES SUPERPOSITION OF PARAMETRI- *. ZATION ON HISTOGRAM *. 2 AMOUNT OF OUTPUT DESIRED *. 3 TYPE OF WEIGHTING *. 4 STANDARD ELEMENTARY FUNCTION TYPE *. 5 SELECTS BASIC FUNCTIONS CLASS *. 6 BASIC FUNCTION SELECTION MODE *. 7 REGRESSION MODE *. 8 NORMALIZATION TYPE *. ND NUMBER OF VARIABLES (DIM OF X-SPACE) *. NP NUMBER OF POINTS TO FIT *. NPMAX FIRST DIMENSION OF ARRAY X *. NBF NUMBER OF BASIC FUNCTIONS AFTER SELECTION *. NBFMAX NUMBER OF BASIC FUNCTIONS BEFORE SELECTION *. NEF NUMBER OF USER-DEFINED ELEMENTARY FUNCTIONS *. NCO NUMBER OF REGRESSORS *. NCOMAX MAXIMUM ALLOWED NUMBER OF REGRESSORS *. *. *. 2. COMMON /HCPAR2/ *. *. COEFF COEFFICIENTS OF THE REGRESSORS *. IBASFT BASIC FUNCTIONS TABLE: IBASFT(I,J) GIVES THE *. NUMBER OF THE ELEMENTARY FUNCTION IN VARIABLE I *. AND REGRESSOR J FOLLOWED BY THE FUNCTION CLASS *. EACH BASIC FUNCTION IS EITHER A USER-GIVEN BASIC *. FUNCTION OR A PRODUCT OF ND ELEMENTARY FUNCTIONS *. XMIN MINIMUM X-VALUE FOR EACH VARIABLE (DIM) *. XMAX MAXIMUM " " " *. ALIM LOWER BOUNDS OF NORMALIZATION INTERVALS *. BLIM UPPER " " " *. *. *. 3. COMMON /HCPOUT/ *. *. IFLAG STATUS FLAG *. RSSS RESIDUAL SUM OF SQUARES *. R2S MULTIPLE CORRELATION COEFFICIENT *. SECO STANDARD DEVIATIONS OF THE ESTIMATED COEFFICIENTS *. COMIN LOWER BOUND OF CONFIDENCE INTERVAL FOR COEFFICIENT *. COMAX UPPER " " " " *. *. *. 4. OTHER IMPORTANT DATA *. *. X INDEPENDENT VARIABLES *. Y DEPENDENT VARIABLE *. R2MIN MINIMUM ACCEPTABLE R2 (GOODNESS OF FIT TEST) *. EY ERRORS ON Y VARIABLE *. MAXPOW MAXIMUM DEGREE OF STANDARD POLYNOMIAL IN *. VARIABLE I *. SELLIM LIMITS THE NUMBER OF BASIC FUNCTIONS SELECTED BY *. LIMITING THE DEGREES OF THE STANDARD POLYNOMIALS *. WHICH MAKE UP A BASIC FUNCTION *. FLEVEL F-SIGNIFICANCE LEVEL USED FOR TESTING REJECTANCE OF *. ALREADY INCLUDED REGRESSORS (STEPWISE PROCEDURE) *.=========> *. CALLING SEQUENCE FOR 1- AND 2-DIM HISTOGRAMS *. MAIN ROUTINE, ORGANIZES WORKING SPACE IN /PAWC/ AND *. CONTROLS THE SUCCESSIVE STAGES OF THE FIT *..=========> ( R.Brun ,D.Lienart ) DIMENSION MAXPOW(1),COEFFI(1),ITERM(1,1) #include "hbook/hcflag.inc" #include "hbook/hcbook.inc" #include "hbook/hcbits.inc" #include "hbook/hcunit.inc" #include "hbook/hcpar0.inc" #include "hbook/hcpar1.inc" #include "hbook/hcpar2.inc" #include "hbook/hcpout.inc" DIMENSION DQ(2) #if defined(CERNLIB_DOUBLE) DOUBLE PRECISION DQ,COEFF,COEFFI,HRVAL #endif EQUIVALENCE (Q(1),DQ(1)) EXTERNAL HRVAL * * * INITIALIZATIONS * IFLAG=-1 CALL HFIND (IDH,'HPARAM') IF (LCID.EQ.0) THEN IFLAG=6 RETURN ENDIF IF (IQ(LCONT+KNOENT).EQ.0) THEN IFLAG=6 CALL HBUG('Empty histogram','HPARAM',ID) RETURN ENDIF CALL HDCOFL ND=1 NX=IQ(LCID+KNCX) NY=1 IF (I1.EQ.0) THEN ND=2 NY=IQ(LCID+KNCY) ENDIF NPMAX=NX*NY NBF=0 NBFMAX=500 NEF=0 NCOMAX=50 ITAP=0 ICONT=ICONTR DO 5 I=1,8 IOPT(I)=ICONT-(ICONT/10)*10 ICONT=ICONT/10 5 CONTINUE ISUP=0 IF (IOPT(1).EQ.1.AND.ND.EQ.1) ISUP=1 SELLIM=1. FLEVEL=1. R2MIN=R2MINI IF (IOPT(7).EQ.2) THEN R2MIN=1.5 ELSE IF (R2MIN.GE.1.) THEN R2MIN=2. ENDIF IF (IOPT(5).GE.1) NEF=PNEF IF (IOPT(5).EQ.2.OR.IOPT(6).EQ.2) NBF=PNBF IF (PSEL.GT.0..AND.PSEL.LE.ND) SELLIM=PSEL IF (PFLV.GT.0..AND.PFLV.LT.1000.) FLEVEL=PFLV IF (PLUN.GT.0..AND.PLUN.LT.100.) ITAP=PLUN IF (PNBX.GT.0..AND.PNBX.LE.2000.) NBFMAX=PNBX IF (PNCX.GT.0..AND.PNCX.LE.50.) NCOMAX=PNCX NV=1 #if !defined(CERNLIB_DOUBLE) IF (ISUP.EQ.1) CALL HFUNC (IDH,HRVAL) #endif #if defined(CERNLIB_DOUBLE) IF (ISUP.EQ.1) CALL HSUPIM (HRVAL) #endif NV=2 * * RESERVE WORKING SPACE IN /PAWC/: SET START ADDRESSES * LXYE=(ND+2)*NPMAX #if !defined(CERNLIB_DOUBLE) LAHPAR=NPMAX+(ND+1)*NBFMAX+(3*NCOMAX+NPMAX+6)*NCOMAX+LXYE #endif #if defined(CERNLIB_DOUBLE) LAHPAR=2*NPMAX+(ND+1)*NBFMAX+(6*NCOMAX+2*NPMAX+11)*NCOMAX+LXYE #endif CALL HWORK (LAHPAR,ICO,'HPARAM') IF (ICO.EQ.0) THEN IFLAG=6 RETURN ENDIF #if defined(CERNLIB_DOUBLE) IF ((ICO/2)*2.EQ.ICO) ICO=ICO+1 IBF=ICO+(10+2*NPMAX+6*NCOMAX)*NCOMAX+2*NPMAX ICO=(ICO+1)/2 #endif ICT=ICO+NCOMAX IW=ICT+NCOMAX IWT=IW+NPMAX*NCOMAX IWY=IWT+NPMAX IV=IWY+NCOMAX IVT=IV+NCOMAX*NCOMAX IVTT=IVT+NCOMAX*NCOMAX IDD=IVTT+NCOMAX*NCOMAX IFF=IDD+NCOMAX #if !defined(CERNLIB_DOUBLE) IBF=IFF+NCOMAX #endif IMB=IBF+ND*NBFMAX IBM=IMB+NBFMAX IX=IBM+NCOMAX IY=IX+ND*NPMAX IE=IY+NPMAX * * COPY HISTOGRAM INTO X,Y,E * CALL HHXYE (Q(IX),Q(IY),Q(IE)) IF (IFLAG.EQ.6) RETURN * * PRINT OUT FIT OPTIONS AND CHARACTERISTICS * WRITE (LOUT,100) IF (IOPT(2).GE.1) THEN WRITE (LOUT,110) ID,ND,LAHPAR,NBF,NEF,NCOMAX,(MAXPOW(I), + I=1,ND) WRITE (LOUT,120) (IOPT(I),I=2,8),SELLIM,FLEVEL IF (ISUP.EQ.1) WRITE (LOUT,160) IF (ITAP.NE.0) WRITE (LOUT,170) ITAP IF (R2MIN.EQ.1.5) THEN WRITE (LOUT,130) ELSE IF (R2MIN.EQ.2.) THEN WRITE (LOUT,140) ELSE WRITE (LOUT,150) R2MIN ENDIF ENDIF ENDIF IF (IOPT(2).EQ.2) CALL HCORRL (Q(IX),Q(IY)) * * IF (IOPT(3).EQ.0) THEN DO 10 I=1,NP Q(IY+I-1)=Q(IY+I-1)/Q(IE+I-1) 10 CONTINUE ENDIF * * IF (IOPT(8).GT.0) CALL HXNORM (Q(IX)) * * SET UP BASIC FUNCTIONS TABLE * IF (IOPT(6).EQ.2) THEN CALL UCOPY (ITERM(1,1),IQ(IBF),ND*NBF) ELSE CALL HSETBF (IQ(IBF),MAXPOW,SELLIM) IF (IFLAG.EQ.5) RETURN ENDIF * * #if !defined(CERNLIB_DOUBLE) CALL HMUFIT (Q(IX),Q(IY),Q(IE),IQ(IBF),Q(IW),Q(IWT),Q(IWY),Q(IV), + Q(IVT),Q(IVTT),Q(IDD),Q(IFF),Q(ICO),Q(ICT),IQ(IMB), + IQ(IBM),R2MIN,FLEVEL) #endif #if defined(CERNLIB_DOUBLE) CALL HMUFIT (Q(IX),Q(IY),Q(IE),IQ(IBF),DQ(IW),DQ(IWT),DQ(IWY), + DQ(IV),DQ(IVT),DQ(IVTT),DQ(IDD),DQ(IFF),DQ(ICO), + DQ(ICT),IQ(IMB),IQ(IBM),R2MIN,FLEVEL) #endif NCOEF=NCO DO 20 I=1,NCO #if !defined(CERNLIB_DOUBLE) COEFF(I)=Q(ICO+I-1) #endif #if defined(CERNLIB_DOUBLE) COEFF(I)=DQ(ICO+I-1) #endif COEFFI(I)=COEFF(I) DO 15 K=1,ND IBASFT(K,I)=IQ(IBF+ND*(I-1)+K-1) 15 CONTINUE 20 CONTINUE CALL UCOPY (IQ(IBF),ITERM(1,1),ND*NCO) IF (ITAP.NE.0) CALL HWRITF (ITAP) #if !defined(CERNLIB_DOUBLE) IF (ISUP.EQ.1) CALL HFUNC (IDH,HRVAL) #endif #if defined(CERNLIB_DOUBLE) IF (ISUP.EQ.1) CALL HSUPIM (HRVAL) #endif 100 FORMAT (///,1X,40('*'),/,' *',38X,'*',/,' * MULTIDIMENSIONAL' + ,' PARAMETRIZATION *'/,' *',38X,'*'/,1X,40('*')) 110 FORMAT (//' FIT CHARACTERISTICS AND OPTIONS'/,1X,31('*'),/ + /' ID = ',I3,/,' DIM = ',I2,/,' WORKING SPACE IN /PAWC/ = ' + ,I7,/,1X,I2,' USER-DEFINED BASIC FUNCTIONS'/,1X,I2, + ' USER-DEFINED ELEMENTARY FUNCTIONS'/,' MAX NUMBER OF', + ' REGRESSORS = ',I2,/,' MAX POWERS OF POLYNOMIALS IN ', + ' EACH DIM = ',10(I2,2X)) 120 FORMAT (' AMOUNT OF OUTPUT = ',I1,/,' WEIGHTING TYPE = ' + ,I1,/,' CLASS OF POLYNOMIALS = ',I1,/,' CLASS OF BASIC' + ,' FUNCTIONS = ',I1,/,' BASIC FUNCTION SELECTION MODE = ', + I1,/,' REGRESSION MODE = ',I1,/,' X-NORMALIZATION TYPE = ' + ,I1,/,' POWER LIMITOR = ',F5.2,/,' F-TEST LEVEL = ',F6.2) 130 FORMAT (/' FITTING PROCESS WILL STOP WHEN ALL CANDIDATE ', + 'BASIC FUNCTIONS ARE INCLUDED') 140 FORMAT (/' FITTING PROCESS WILL STOP WHEN THE RESIDUAL VARIANCE' + ,' HITS A MINIMUM') 150 FORMAT (/' FITTING PROCESS WILL STOP WHEN THE MULTIPLE ', + 'CORRELATION COEFFICIENT GETS HIGHER THAN ',F7.4) 160 FORMAT (' PARAMETRIZATION SUPERIMPOSED ON HISTOGRAM') 170 FORMAT (' FORTRAN CODE FPARAM WRITTEN ON UNIT ',I2) END