Initial commit
This commit is contained in:
200
gen/fit_print.f
Normal file
200
gen/fit_print.f
Normal file
@ -0,0 +1,200 @@
|
||||
subroutine FIT_PRINT(IKODE)
|
||||
c ---------------------------
|
||||
include 'fit.inc'
|
||||
|
||||
integer ikode
|
||||
|
||||
integer i,l, n1, n2, j, k, ll
|
||||
real dx, al, ba, du1, du2, pos, yi, dpos, rms, xm, drms, dyi
|
||||
real fact
|
||||
|
||||
character txt*32,pname*8,line*80
|
||||
real uc
|
||||
|
||||
if (nu .eq. 0) return
|
||||
if (nfree .le. 0) nfree=1
|
||||
if (ikode .eq. 2) goto 400
|
||||
|
||||
if (ikode .ge. 1) call fit_confun_print
|
||||
if (isyswr .ne. 0) then
|
||||
write (isyswr,1000) ififu,amin,nfree,nfcn,sigma/max(1e-10,amin)
|
||||
if (isw(2) .ge. 1) then
|
||||
write (isyswr,1001) 'Error'
|
||||
else
|
||||
write (isyswr,1001) 'Step '
|
||||
endif
|
||||
endif
|
||||
|
||||
! calculate errors of corr. parameters.
|
||||
do j=1,ncor
|
||||
i=icord(j)
|
||||
fact=cfac(i)
|
||||
k=icto(i)
|
||||
if (icsw(i) .lt. 0) then
|
||||
if (ififu .eq. 1) then
|
||||
if (u(k) .ne. 0) fact=u(i)/u(k) ! Error of Max.Int from Int.Int and vice versa
|
||||
endif
|
||||
endif
|
||||
werr(i) = werr(k)*fact
|
||||
enddo
|
||||
|
||||
uc=up*max(1.0,amin)/nfree
|
||||
do i= 1, nu
|
||||
20 l = lcorsp(i)
|
||||
if (l .ne. 0) then ! variable parameter. calculate external error if v exists
|
||||
if (isw(2) .ge. 1) then
|
||||
dx = sqrt(abs(v(l,l)*uc))
|
||||
if (lcode(i) .gt. 1) then
|
||||
al = alim(i)
|
||||
ba = blim(i) - al
|
||||
du1 = al + 0.5 *(sin(x(l)+dx) +1.0) * ba - u(i)
|
||||
du2 = al + 0.5 *(sin(x(l)-dx) +1.0) * ba - u(i)
|
||||
if (dx .gt. 1.0) du1 = ba
|
||||
dx = 0.5 * (abs(du1) + abs(du2))
|
||||
endif
|
||||
werr(i) = dx
|
||||
endif
|
||||
if (isyswr .ne. 0) then
|
||||
call cvt_real_str(line( 1:14), ll, u(i), 14, 3, 6, 0)
|
||||
call cvt_real_str(line(15:28), ll, werr(i), 14, 3, 6, 0)
|
||||
call cvt_real_str(line(29:42), ll, x(l), 14, 3, 6, 0)
|
||||
call cvt_real_str(line(43:56), ll, dirin(l),14, 3, 6, 0)
|
||||
write (isyswr,1002) i,psho(i),pnam(i),line(1:56)
|
||||
1002 FORMAT (1X,I3,2X,A4,1X,A8,2X,a)
|
||||
if (lcode(i) .gt. 1) then
|
||||
if (abs(cos(x(l))) .lt. 0.001) then
|
||||
write(isyswr,1004) alim(i), blim(i)
|
||||
1 , ' --- Parameter is at limit ---'
|
||||
else
|
||||
write(isyswr,1004) alim(i), blim(i)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
elseif (ikode .gt. 0) then ! fixed / corr. parameter. print only if ikode .gt.0
|
||||
if (icsw(i) .ne. 0) then
|
||||
pname=psho(icto(i))
|
||||
if (pname .eq. ' ') pname=pnam(icto(i))
|
||||
if (icsw(i) .gt. 0) then
|
||||
if (coff(i) .eq. 0.0) then
|
||||
write(txt, '(A,f10.3,2a)',err=390)
|
||||
1 '=', cfac(i), '*', pname
|
||||
else
|
||||
write(txt, '(A,f10.3,3a,g12.5)',err=390)
|
||||
1 '=', cfac(i), '*', pname
|
||||
1 ,'+', coff(i)
|
||||
endif
|
||||
else
|
||||
werr(i)=0
|
||||
write(txt, '(6A)') 'correlated to ',pname(1:3)
|
||||
1 ,', G',pname(2:3),' and L',pname(2:3)
|
||||
endif
|
||||
else
|
||||
txt='fixed'
|
||||
endif
|
||||
390 if (isyswr .ne.0) then
|
||||
call cvt_real_str(line( 1:14), ll, u(i), 14, 3, 6, 0)
|
||||
write (isyswr,1003) i,psho(i),pnam(i),line(1:14),txt
|
||||
1003 FORMAT (1X,I3,2X,A4,1X,A8,2X,a,3x,a)
|
||||
endif
|
||||
endif
|
||||
if (ififu .eq. 1 .and. mod(i,5) .eq. 2 .and. isyswr .ne.0)
|
||||
1 write(isyswr, *)
|
||||
enddo
|
||||
if (ikode.lt.1 .and.isw(2).lt.1 .or. isyswr .eq. 0) return
|
||||
|
||||
400 YINTEG = 0.
|
||||
DYINTEG = 0.
|
||||
|
||||
ni=0
|
||||
IF (IFIFU .EQ. 6) THEN
|
||||
if (nxmin .ge. nxmax) return
|
||||
call fit_sort(nxmin,nxmax)
|
||||
N1=NXMIN+1
|
||||
do while (abs(xval(n1)-u(3)) .gt. u(4)/2
|
||||
1 .and. u(3) .gt. xval(n1) .and. n1 .lt. nxmax)
|
||||
n1=n1+1
|
||||
enddo
|
||||
N2=NXMAX-1
|
||||
do while (abs(xval(n2)-u(3)) .gt. u(4)/2
|
||||
1 .and. u(3) .lt. xval(n2) .and. n2 .gt. nxmin)
|
||||
n2=n2-1
|
||||
enddo
|
||||
if (n2 .le. n1) return
|
||||
|
||||
! calculate center of gravity
|
||||
|
||||
POS=0
|
||||
DO 401,I=N1,N2
|
||||
DX = ABS( XVAL(I+1)-XVAL(I-1) )/2. ! weight of point I
|
||||
YI = (YVAL(I)-U(1)-U(2)*(XVAL(I)-U(3)))*DX ! intensity area (minus background)
|
||||
YINTEG=YINTEG+YI
|
||||
DYI=DX*DX*(SIG(I)**2+WERR(1)*WERR(1)+(WERR(2)*XVAL(I))**2) ! error^2 of intensity
|
||||
DYINTEG=DYINTEG+DYI
|
||||
POS=POS+(XVAL(I)-U(3))*YI ! sum of positions
|
||||
401 CONTINUE
|
||||
DYINTEG=SQRT(DYINTEG)
|
||||
if (YINTEG .eq. 0) YINTEG=1
|
||||
POS=POS/YINTEG+U(3) ! mean position
|
||||
|
||||
! calculate mean square deviation and error of center of gravity
|
||||
DPOS=0
|
||||
RMS=0
|
||||
DO 402,I=N1,N2
|
||||
XM = XVAL(I)-POS
|
||||
DX = ABS( XVAL(I+1)-XVAL(I-1) )/2.
|
||||
YI = (YVAL(I)-U(1)-U(2)*(XVAL(I)-U(3)))*DX
|
||||
DYI=DX*DX*(SIG(I)**2+WERR(1)*WERR(1)+(WERR(2)*XVAL(I))**2)
|
||||
DPOS=DPOS+XM*XM*DYI ! sum for error of position
|
||||
RMS=RMS+XM*XM*YI ! sum of deviation^2 form mean pos.
|
||||
402 CONTINUE
|
||||
RMS=ABS(RMS/YINTEG)
|
||||
|
||||
! calculate error of mean square deviation
|
||||
|
||||
DRMS=0
|
||||
DO 403,I=N1,N2
|
||||
DX = ABS( XVAL(I+1)-XVAL(I-1) )/2.
|
||||
DYI=DX*DX*(SIG(I)**2+WERR(1)*WERR(1)+(WERR(2)*XVAL(I))**2)
|
||||
DRMS=DRMS+((XVAL(I)-POS)**2-RMS)*DYI ! sum for error of root mean square deviation
|
||||
403 CONTINUE
|
||||
U(5)=POS
|
||||
U(6)=SQRT(RMS*8*LOG(2.0))
|
||||
WERR(5)=SQRT(ABS(DPOS))/YINTEG
|
||||
WERR(6)=SQRT(ABS(DRMS*8*LOG(2.0)))/YINTEG
|
||||
ni=3
|
||||
u(7)=YINTEG
|
||||
werr(7)=dYINTEG
|
||||
if (ikode .eq. 2) return
|
||||
WRITE (ISYSWR,'(5X,A,5X,2F14.5)') 'Mean Posit.',u(5),werr(5)
|
||||
WRITE (ISYSWR,'(5X,A,5X,2F14.5)') 'Mean Width ',U(6),WERR(6)
|
||||
elseif (ififu .eq. 1) then
|
||||
DO 409 I=NXMIN+1,NXMAX-1
|
||||
XM = XVAL(I)-U(3)
|
||||
DX = ABS( XVAL(I+1)-XVAL(I-1) )/2.
|
||||
YI = (YVAL(I)-U(1)-U(2)*XM)*DX
|
||||
YINTEG=YINTEG+YI
|
||||
DYI=DX*DX*(SIG(I)**2+WERR(1)*WERR(1)+(WERR(2)*XM)**2)
|
||||
DYINTEG=DYINTEG+DYI
|
||||
409 CONTINUE
|
||||
DYINTEG=SQRT(DYINTEG)
|
||||
if (nu .lt. maxext) then
|
||||
u(nu+1)=YINTEG
|
||||
werr(nu+1)=dYINTEG
|
||||
ni=1
|
||||
endif
|
||||
ENDIF
|
||||
if (ikode .eq. 2) return
|
||||
if (YINTEG .ne. 0 .and. dYINTEG .ne. 0)
|
||||
1 WRITE (ISYSWR,1007) YINTEG,DYINTEG
|
||||
990 WRITE (ISYSWR,1005) UP
|
||||
RETURN
|
||||
1000 FORMAT(/' ... fcn',I2,' Chi**2 =',F12.5,2X,'nf =',i6,i8
|
||||
1 ,' Calls , edm =',E9.2,' ...')
|
||||
1001 FORMAT (6X,' Parameter Value ',A,' ',
|
||||
1 ' Intern.Value Int.Step Size')
|
||||
1004 FORMAT (1X,6X,'Limits:', 2F14.5,A)
|
||||
1005 FORMAT (' ...... Errors correspond to function change of ',
|
||||
1 F10.4,' ......')
|
||||
1007 FORMAT (5X,'Integr.Int. Exp:',2F14.3)
|
||||
1008 FORMAT (5X,'Max.Intens. ',I2,' :',2F14.3)
|
||||
END
|
||||
Reference in New Issue
Block a user