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