281 lines
5.3 KiB
Fortran
281 lines
5.3 KiB
Fortran
SUBROUTINE fit_WIN(xb0, xe0)
|
|
C -----------------------------
|
|
include 'fit.inc'
|
|
|
|
real xb0, xe0
|
|
real xb, xe, x1
|
|
integer i,j
|
|
|
|
C
|
|
1000 FORMAT (/,4X,'FIT : X-START , X-END ',$)
|
|
1001 FORMAT (2F10.0)
|
|
|
|
if (xb0 .eq. 0.0 .and. xe0 .eq. 0.0) then
|
|
100 WRITE(ISYSWR,1000)
|
|
READ(ISYSRD,1001,ERR=100,END=999) XB,XE
|
|
else
|
|
xb=xb0
|
|
xe=xe0
|
|
endif
|
|
nxmin=1
|
|
nxmax=npkt
|
|
if (npkt .le. 0) return
|
|
|
|
if (xb .ne. xe) then
|
|
|
|
call fit_sort(1, npkt)
|
|
|
|
if (xb .gt. xe) then ! exchange if not in order
|
|
x1=xb
|
|
xb=xe
|
|
xe=x1
|
|
endif
|
|
do i=1,npkt
|
|
if (xval(i) .ge. xb) then
|
|
nxmin=i
|
|
do j=i,npkt
|
|
if (xval(j) .gt. xe) then
|
|
nxmax=max(i,j-1)
|
|
goto 11
|
|
endif
|
|
enddo
|
|
nxmax=npkt
|
|
goto 11
|
|
endif
|
|
enddo
|
|
11 nregion=1
|
|
regx1(nregion)=xb
|
|
regx2(nregion)=xe
|
|
regy1(nregion)=0
|
|
regy2(nregion)=0
|
|
else
|
|
nregion=1
|
|
regx1(nregion)=0
|
|
regx2(nregion)=0
|
|
regy1(nregion)=0
|
|
regy2(nregion)=0
|
|
endif
|
|
call extoin
|
|
call fit_check_range
|
|
call fnctn(x,amin)
|
|
|
|
nset=1
|
|
do i=nxmin,nxmax
|
|
nset=max(iset(i),nset)
|
|
enddo
|
|
|
|
if (nxmax .lt. nxmin) then
|
|
print *,'no more datapoints present - enlarge fit window'
|
|
endif
|
|
|
|
999 RETURN
|
|
|
|
END
|
|
|
|
|
|
|
|
SUBROUTINE FIT_EXCLUDE(X1, X2, Y1, Y2)
|
|
! --------------------------------------
|
|
|
|
include 'fit.inc'
|
|
|
|
real x1, x2, y1, y2
|
|
|
|
integer i
|
|
real xm1, xm2, ym1, ym2
|
|
|
|
xm1=min(x1,x2)
|
|
xm2=max(x1,x2)
|
|
ym1=min(y1,y2)
|
|
ym2=max(y1,y2)
|
|
if (xm1 .eq. xm2 .and. ym1 .eq. ym2) return
|
|
if (nregion .lt. maxregion) then
|
|
nregion=nregion+1
|
|
regx1(nregion)=xm2
|
|
regx2(nregion)=xm1
|
|
regy1(nregion)=ym2
|
|
regy2(nregion)=ym1
|
|
endif
|
|
i=nxmin
|
|
do while (i .le. nxmax)
|
|
if ((xm1.le.xval(i) .and. xval(i).le.xm2 .or. xm1.eq.xm2) .and.
|
|
1 (ym1.le.yval(i) .and. yval(i).le.ym2 .or. ym1.eq.ym2)) then
|
|
call fit_sort_exch(i, nxmax)
|
|
nxmax=nxmax-1
|
|
else
|
|
i=i+1
|
|
endif
|
|
enddo
|
|
if (nxmax .lt. nxmin) then
|
|
print *,'no more datapoints present - enlarge fit window'
|
|
else
|
|
call fit_sort(nxmin, nxmax)
|
|
endif
|
|
end
|
|
|
|
|
|
SUBROUTINE FIT_INCLUDE(X1, X2, Y1, Y2)
|
|
! --------------------------------------
|
|
|
|
include 'fit.inc'
|
|
|
|
real x1, x2, y1, y2
|
|
|
|
integer i
|
|
real xm1, xm2, ym1, ym2
|
|
external fit_sort_load, fit_sort_exch, fit_sort_comp
|
|
|
|
xm1=min(x1,x2)
|
|
xm2=max(x1,x2)
|
|
ym1=min(y1,y2)
|
|
ym2=max(y1,y2)
|
|
if (nregion .lt. maxregion) then
|
|
nregion=nregion+1
|
|
regx1(nregion)=xm1
|
|
regx2(nregion)=xm2
|
|
regy1(nregion)=ym1
|
|
regy2(nregion)=ym2
|
|
endif
|
|
i=1
|
|
if (i .eq. nxmin) i=nxmax+1
|
|
do while (i .le. npkt)
|
|
if ((xm1.le.xval(i) .and. xval(i).le.xm2 .or. xm1.eq.xm2) .and.
|
|
1 (ym1.le.yval(i) .and. yval(i).le.ym2 .or. ym1.eq.ym2)) then
|
|
if (i .lt. nxmin) then
|
|
nxmin=nxmin-1
|
|
call fit_sort_exch(i, nxmin)
|
|
else
|
|
nxmax=nxmax+1
|
|
call fit_sort_exch(i, nxmax)
|
|
i=i+1
|
|
endif
|
|
else
|
|
i=i+1
|
|
endif
|
|
if (i .eq. nxmin) i=nxmax+1
|
|
enddo
|
|
call fit_sort(nxmin, nxmax)
|
|
end
|
|
|
|
|
|
subroutine fit_restore_region(purge)
|
|
!
|
|
! code is not optimal (sort is called several times)
|
|
!
|
|
logical purge
|
|
|
|
include 'fit.inc'
|
|
|
|
integer i,j,m
|
|
|
|
if (nregion .eq. 0) then
|
|
nxmin=1
|
|
nxmax=npkt
|
|
else
|
|
nxmin=1
|
|
nxmax=0
|
|
m=nregion
|
|
if (m .ge. maxregion) then
|
|
print *,'excluded region too complex - simplified'
|
|
m=maxregion
|
|
endif
|
|
nregion=0
|
|
do i=1,m
|
|
if (regx1(i) .gt. regx2(i) .or. regy1(i) .gt. regy2(i)) then
|
|
call fit_exclude(regx1(i), regx2(i), regy1(i), regy2(i))
|
|
else
|
|
call fit_include(regx1(i), regx2(i), regy1(i), regy2(i))
|
|
endif
|
|
enddo
|
|
endif
|
|
if (purge) then
|
|
if (nxmin .ne. 1) then
|
|
j=0
|
|
do i=nxmin,nxmax
|
|
j=j+1
|
|
xval(j)=xval(i)
|
|
yval(j)=yval(i)
|
|
sig (j)=sig (i)
|
|
rmon(j)=rmon(i)
|
|
iset(j)=iset(i)
|
|
enddo
|
|
npkt=j
|
|
nxmin=1
|
|
nxmax=npkt
|
|
else
|
|
npkt=nxmax
|
|
endif
|
|
endif
|
|
end
|
|
|
|
|
|
subroutine fit_keep(keep)
|
|
! -------------------------
|
|
|
|
implicit none
|
|
include 'fit.inc'
|
|
character kp*1, keep*(*)
|
|
|
|
character text*72
|
|
integer i
|
|
|
|
write(isyswr, *)
|
|
do i=1,nregion
|
|
if (regx1(i) .gt. regx2(i) .or. regy1(i) .gt. regy2(i)) then
|
|
text='excluded'
|
|
else
|
|
if (i .eq. 1) then
|
|
text='window'
|
|
else
|
|
text='included'
|
|
endif
|
|
endif
|
|
call fit_cvt_range(regx1(i), regx2(i), text(12:35), ' < x <')
|
|
call fit_cvt_range(regy1(i), regy2(i), text(39:72), ' < y <')
|
|
if (text .ne. 'window') write(isyswr, '(x,a)') text
|
|
enddo
|
|
if (nregion .ge. maxregion)
|
|
1 print *,'excluded region too complex - simplified'
|
|
write(isyswr, *)
|
|
if (keep .eq. ' ') then
|
|
if (keepregion) then
|
|
kp='Y'
|
|
else
|
|
kp='N'
|
|
endif
|
|
write(isyswr,'(x,3a,$)')
|
|
1 'Keep window/region on DAT command ([',kp,']) ? '
|
|
READ (ISYSRD,'(a1)',ERR=999,end=999) kp
|
|
else
|
|
kp=keep
|
|
endif
|
|
if (kp .eq. 'N' .or. kp .eq. 'n' .or. kp .eq. '0') then
|
|
keepregion=.false.
|
|
elseif (kp .eq. 'Y' .or. kp .eq. 'y' .or. kp .eq. '1') then
|
|
keepregion=.true.
|
|
endif
|
|
999 end
|
|
|
|
|
|
|
|
subroutine fit_cvt_range(r1, r2, text, sep)
|
|
|
|
include 'fit.inc'
|
|
|
|
character text*(*), sep*(*)
|
|
real r1,r2
|
|
|
|
integer i, l
|
|
|
|
if (r1 .eq. r2) return
|
|
i=(len(text)-len(sep))/2
|
|
text(i+1:i+len(sep))=sep
|
|
if (r1 .gt. r2) then
|
|
call cvt_real_str(text(1:i), l, r2, i, 0, 7, 3)
|
|
call cvt_real_str(text(i+len(sep)+1:), l, r1, 1, 0, 7, 3)
|
|
else
|
|
call cvt_real_str(text(1:i), l, r1, i, 0, 7, 3)
|
|
call cvt_real_str(text(i+len(sep)+1:), l, r2, 1, 0, 7, 3)
|
|
endif
|
|
end
|