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