Initial commit
This commit is contained in:
297
gen/fit_fit.f
Normal file
297
gen/fit_fit.f
Normal file
@ -0,0 +1,297 @@
|
||||
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
|
||||
Reference in New Issue
Block a user