subroutine fit_min(narg) ! ------------------------ include 'fit.inc' integer narg, nf real earg call fit_set_inthdl call fit_check_range nfcnmx=1000 if (narg .gt. 0) nfcnmx=narg isw(1)=0 NF = NFCN CALL SIMPLEX if (ISW(1) .lt. 1) then NFCNMX = NFCNMX + NF - NFCN GO TO 360 endif return entry fit_fit(narg) ! ------------------- call fit_set_inthdl call fit_check_range nfcnmx=1000 if (narg .gt. 0) nfcnmx=narg isw(1)=0 360 NF = NFCN APSI = EPSI CALL MIGRAD IF (ISW(2) .LE. 2 .AND. ISW(1) .NE. 1) THEN NFCNMX = NFCNMX + NF - NFCN NF = NFCN CALL SIMPLEX ENDIF return entry fit_sim(narg) ! ------------------- call fit_set_inthdl call fit_check_range nfcnmx=1000 if (narg .gt. 0) nfcnmx=narg isw(1)=0 call simplex return entry fit_mig(narg) ! ------------------- call fit_set_inthdl call fit_check_range nfcnmx=1000 if (narg .gt. 0) nfcnmx=narg isw(1)=0 NF = NFCN APSI = EPSI CALL MIGRAD return entry fit_err(earg) ! ------------------- if (earg .gt. 0) then epsi=epsi*earg/up up=earg else epsi=epsi/up UP=1.0 endif IF (ISW(2).GE.1) CALL fit_print(1) return entry fit_pri(narg) ! ------------------- ISW(5) = narg return entry fit_epsi(earg) ! -------------------- if (earg .gt. 0) then epsi=earg else epsi=0.1*up endif return entry fit_vtest(earg) ! --------------------- if (earg .gt. 0) then vtest=earg else vtest=0.01 endif return end subroutine fit_set_inthdl include 'fit.inc' external fit_inthdl if (isyswr .ne. 0) 1 write(isyswr,'(t40,a)') 'Press Ctrl-C to abort fit-algorithm' call sys_int_hdl(fit_inthdl) end subroutine fit_inthdl include 'fit.inc' nfcnmx=0 end subroutine fit_reserr implicit none include 'fit.inc' integer i do i=1,nu if (werr(i) .ne. 0) werr(i)=max(0.1,u(i)*0.1) enddo if (ififu .eq. 1) then do i=3,nu,5 if (werr(i+1) .ne. 0) werr(i+1)=werr(i+3)+werr(i+4) enddo endif call fit_set(0,0.0,0.0,0.0,0.0) end subroutine fit_chisq(chisq, istat) real chisq integer istat include 'fit.inc' chisq=amin istat=isw(2) end subroutine fit_restore_wr include 'fit.inc' integer isave/0/ if (isave .ne. 0) then isyswr=isave isave=0 endif return entry fit_suspend_wr if (isyswr .ne. 0) then isave=isyswr isyswr=0 endif end subroutine fit_covar include 'fit.inc' integer i,j,k character line*130 if (isw(2) .lt. 3) then print *,'covariance matrix undefined' return endif do i=1,npar do k=1,npar,16 write(line, '(16g8.2)') (v(i,j),j=k,min(k+15,npar)) ! (100*v(i,j)/sqrt(abs(v(i,i)*v(j,j))) ! if (i .ge. k .and. i .le. k+15) then ! nam=' ' ! do l=1,nu ! if (lcorsp(l) .eq. i) then ! nam=psho(l) ! goto 9 ! endif ! enddo !9 line((i-k)*8+1:(i-k+1)*8)=' '//nam ! endif print *,line enddo if (i .gt. 26) print * enddo end subroutine fit_true_err(ipar, fstep) integer ipar real fstep include 'fit.inc' real sums0, sums, uc, start, step, step0, sl0, sl1 real p0 integer i,idir,j real usave(maxext), esave(maxext), trum, trup external fit_restore_wr step0=abs(werr(ipar)) if (step0 .eq. 0) then print *,pnam(ipar),' is not free' return endif call sys_err_hdl(fit_restore_wr) call fit_suspend_wr call fit_min(0) call fit_fix(ipar) call fit_min(0) do i=1,nu usave(i)=u(i) esave(i)=werr(i) enddo ! uc=up*max(1.0,amin)/nfree uc=up/nfree sums0=amin/uc start=u(ipar) print *,pnam(ipar),' chi^2' print *,start,amin do idir=-1,1,2 step=step0*idir sums=sums0 do j=1,100 sl0=sqrt(max(0.0,sums-sums0)) do i=1,nu werr(i)=esave(i) enddo p0=u(ipar) call fit_set(ipar,start+step*j*fstep,0.0,0.0,-1.0) call fit_min(0) if (nfcnmx .eq. 0) goto 99 sums=amin/uc print *,u(ipar),amin,sums-sums0 if (sums .gt. sums0+1) goto 50 enddo 50 sl1=sqrt(max(0.0,sums-sums0)) if (sl1 .le. sl0) then print *,'error' goto 99 endif step=p0-start+(u(ipar)-p0)*(1-sl0)/(sl1-sl0) if (idir .lt. 0) then trum=step else trup=step endif do i=1,nu u(i)=usave(i) werr(i)=esave(i) enddo call fit_set(0,0.0,0.0,0.0,0.0) call fit_min(0) enddo 99 call fit_rel(ipar) call fit_set(ipar, start, step0, 0.0, -1.0) call fit_restore_wr print *,'true error of ',pnam(ipar),':', trum, trup end