linse/fit
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
zolliker
2022-08-19 15:22:33 +02:00
commit d682fae506
545 changed files with 48172 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

976
gen/fit_plot.f Executable file
View File

@@ -0,0 +1,976 @@
subroutine fit_plot(hrdcopy)
! ----------------------------
include 'fit.inc'
character*1 hrdcopy
integer ncmax, ntxt, maxedi
real pw, tsiz, vbot, vlef, vrig
parameter (ncmax=1000, ntxt=15, pw=0.20, maxedi=maxpeak+2)
parameter (tsiz=0.9)
parameter (vbot=0.12, vlef=0.07, vrig=0.975)
integer medi, nedi
real xedi(maxedi), yedi(maxedi)
real scal(4), scam(4), xcal(ncmax), ycal(ncmax)
real a1, a2, ex, ey, eyi, top, ssz, vtop
real xm1, ym1, xm2, ym2, selx, sely, rbuf(8), ebuf(8)
real legx, legy, vwid
integer n1, n2, ncnt(3)
integer i,j,k,m,l0, ncal, gedi, l, n, ndig
integer i1,i2,pdig
integer nlines, maxlines/10/
integer ncol
character buf*80, key*1, coord*32, backslash*1, yaxis*80
logical doprint, selflg, bgedit, ok, tas_info, changed, doit
logical doshow
external fifun
real fifun, voigt, gra_trf, gra_itrf ! functions
integer normal_style, powder_style
parameter (normal_style=1, powder_style=2)
real bgr, xv
! statement function definition
bgr(xv)=u(1)+u(2)*(xv-u(3))
backslash=char(92)
if (autostyle .ne. 0) then
if (nxmax-nxmin .gt. 256 .and. nu .eq. 0) then
autostyle=powder_style
else
autostyle=normal_style
endif
endif
bgedit=.false.
doshow=.false.
if (hrdcopy .eq. 'Y' .or. hrdcopy .eq. 'y') then
doprint=.true.
call cho_choose('P')
else
doprint=.false.
call cho_choose('G')
if (hrdcopy .eq. 'B' .or. hrdcopy .eq. 'b') then
bgedit=.true.
endif
endif
if (hrdcopy .eq. 'S' .or. hrdcopy .eq. 's') then
doshow=.true.
endif
1 call gra_open(doprint, ok)
if (.not. ok) return
call pgask(.false.)
2 coord=' '
call pgbbuf
call gra_trfmode(trfmode, shift(trfmode))
call pgqinf('TYPE', buf, l)
call pgqcol(i,ncol)
if (ncol .ge. 7 .and. buf(1:l) .ne. 'VT125') then
call pgscr(0, 1.0, 1.0, 1.0)
call pgscr(1, 0.0, 0.0, 0.0)
call pgscr(2, 1.0, 0.0, 0.0)
call pgscr(3, 0.0, 1.0, 0.0)
call pgscr(4, 0.0, 0.0, 1.0)
call pgscr(5, 0.0, 1.0, 1.0)
call pgscr(6, 1.0, 0.0, 1.0)
call pgscr(7, 1.0, 1.0, 0.0)
endif
if (ncolor .lt. ncol) ncol=ncolor
call fit_print(2) ! calc exp.int.int
if (trfmode .eq. 0) then
ym1=0
else
ym1=yval(nxmin)+sig(nxmin)
endif
ym2=yval(nxmin)
xm1=xval(nxmin)
xm2=xval(nxmin)
do i=nxmin,nxmax
if (xval(i) .lt. xm1) xm1=xval(i)
if (xval(i) .gt. xm2) xm2=xval(i)
ey=yval(i)-sig(i)
if (ey .lt. ym1) then
if (trfmode .eq. 0) then
ym1=ey
else
ym1=min(ym1, max(ey, (yval(i)+sig(i))*0.5))
endif
endif
if (yval(i)+sig(i) .gt. ym2) ym2=yval(i)+sig(i)
enddo
if (shift(trfmode) .ne. 0) then
ym2=gra_itrf(gra_trf(ym2,nset))
endif
if (xm1 .eq. xm2) xm2=xm1+max(1.0,abs(xm1*1e-4))
if (ym1 .eq. ym2) then
ym1=ym2
ym2=ym2+1
endif
a2=0.5/(nxmax+2-nxmin)
a1=1+a2
scam(1)=xm1*a1-xm2*a2
scam(2)=xm2*a1-xm1*a2
if (ym1 .ne. 0 .and. trfmode .eq. 0) then
scam(3)=ym1*1.01-ym2*0.01
else
scam(3)=ym1
endif
scam(4)=ym2*1.01-ym1*0.01
do i=1,4
scal(i)=scam(i)
enddo
if (iscx .ne. 0) then ! predefined x-scaling
scal(1)=xbeg
scal(2)=xend
endif
if (iscy .ne. 0) then ! predefined y-scaling
scal(3)=ybeg
scal(4)=yend
endif
changed=.false.
if (ififu .eq. 1) then
nlines=min(nu/5,maxlines)
top=nlines+4.0
n1=1
n2=2
elseif (ififu .eq. 6) then
top=5.
pnam(5)='Mean Pos'
pnam(6)='Mean Wid'
n1=1
n2=6
else
n1=1
n2=min(nu,5*maxlines)
nlines=(n2+4)/5
top=nlines*2.5
endif
top=top+4.5
call pgsch(tsiz)
call pgqcs(0, ex, ey)
vtop=0.975-top*ey
call pgsvp(vlef,vrig,vbot,vtop) ! define window size
call pgswin(scal(1), scal(2)
1 , gra_trf(scal(3),1), gra_trf(scal(4),1))
if (trfmode .eq. 1) then ! log mode
call pgbox('BCINST', 0.0, 0, 'BCINSTL', 0.0, 0)
else
call pgbox('BCINST', 0.0, 0, 'BCINST', 0.0, 0)
endif
ssz=100.0*abs((scam(1)-scam(2))/(scal(1)-scal(2)))/(nxmax+2-nxmin)
if (ssz .gt. 1.5) ssz=1.5 ! calculate marker size
call pgsch(ssz)
if (autostyle .eq. powder_style) then
call gra_mult(xval(nxmin),yval(nxmin),sig(nxmin),iset(nxmin)
1 , nxmax-nxmin+1,1,-10,ncol)
else
call gra_mult(xval(nxmin),yval(nxmin),sig(nxmin),iset(nxmin)
1 , nxmax-nxmin+1,nstyl,styl,ncol)
endif
call pgsch(tsiz)
! draw fit function
if (ssz/300 .lt. 1.0/ncmax) then
ncal=ncmax
else
ncal=max(200,nint(300./ssz))
endif
call fit_put_xrange(scal(1),scal(2))
if (ififu .eq. 7) call fit_user1st
do i=1,ncal
xcal(i)=scal(1)+(scal(2)-scal(1))*(i-1)/(ncal-1)
enddo
if (nu .gt. 0) then
actset=1
if (ififu .eq. 6) then
j=nxmin+1
do while (j .lt. nxmax .and. xval(j) .lt. u(3)-u(4)/2)
j=j+1
enddo
i=1
xcal(1)=scal(1)
ycal(1)=gra_trf(bgr(xcal(i)),1)
i=i+1
xcal(i)=(xval(j)+xval(j-1))/2
ycal(i)=gra_trf(bgr(xcal(i)),1)
do while (j .lt. nxmax .and. xval(j) .lt. u(3)+u(4)/2)
if (i .lt. ncmax-2) then
i=i+1
xcal(i)=xval(j)
ycal(i)=yval(j)
endif
j=j+1
enddo
i=i+1
xcal(i)=(xval(j)+xval(j-1))/2
ycal(i)=gra_trf(bgr(xcal(i)),1)
ncal=i+1
xcal(ncal)=scal(2)
ycal(ncal)=gra_trf(bgr(xcal(ncal)),1)
call pgline(ncal, xcal, ycal)
call pgsls(4)
call pgmove(xcal(2), ycal(2))
call pgdraw(xcal(ncal-1), ycal(ncal-1))
call pgsls(1)
else
actset=1
do i=1,ncal
ycal(i)=gra_trf(fifun(xcal(i)),1)
enddo
call pgline(ncal, xcal, ycal)
endif
if (ififu .eq. 7 .and. nset .gt. 1) then ! draw multiple curves
do actset=2,nset
doit=.false.
c check if function values are different from last dataset
do i=1,ncal
ey=gra_trf(fifun(xcal(i)), actset)
if (ey .ne. ycal(i)) doit=.true.
ycal(i)=ey
enddo
if (doit) then
if (ncol .gt. 0) then
call pgsci(mod(actset+1,ncol)-1)
else
call pgsls(mod(actset-2,4)+2)
endif
call pgline(ncal, xcal, ycal)
endif
enddo
if (ncol .gt. 0) then
call pgsci(1)
else
call pgsls(1)
endif
endif
endif
if (ififu .eq. 1) then
if (nu .gt. 7) then
! draw single peaks
call pgsls(2)
do m=3,nu,5
do i=1,ncal
ycal(i)=gra_trf(bgr(xcal(i))
1 +voigt(xcal(i)-u(m), u(m+3), u(m+4))*u(m+2),1)
enddo
call pgline(ncal, xcal, ycal)
enddo
endif
! draw background
call pgsls(4)
if (trfmode .eq. 0) then
call pgmove(scal(1), gra_trf(bgr(scal(1)),1))
call pgdraw(scal(2), gra_trf(bgr(scal(2)),1))
else
do i=1,ncal
ycal(i)=gra_trf(bgr(xcal(i)),1)
enddo
call pgline(ncal, xcal, ycal)
endif
call pgsls(1)
endif
if (bgedit .and. nback .gt. npkt) then ! draw user background
call pgsci(2)
call pgmove(xval(npkt+1), gra_trf(yval(npkt+1),1))
do i=npkt+1,nback
ex=xval(i)
ey=gra_trf(yval(i),1)
call pgdraw(ex, ey)
call pgpt1(ex, ey, 4)
enddo
call pgsci(1)
endif
buf=' '
call sym_get_str('XAxis', l, buf)
tas_info=.false.
if (buf(1:l) .eq. 'QH' .or. buf(1:l) .eq. 'QL' .or.
1 buf(1:l) .eq. 'QK' .or. buf(1:l) .eq. 'EN' .or.
1 buf(1:l) .eq. 'h' .or. buf(1:l) .eq. 'k' .or.
1 buf(1:l) .eq. 'l' .or. buf(1:l) .eq. 'E') then
do i=1,8
rbuf(i)=0
enddo
call sym_get_real('QH', rbuf(1))
call sym_get_real('QK', rbuf(2))
call sym_get_real('QL', rbuf(3))
call sym_get_real('DQH', rbuf(4))
call sym_get_real('DQK', rbuf(5))
call sym_get_real('DQL', rbuf(6))
call sym_get_real('EN', rbuf(7))
call sym_get_real('DEN', rbuf(8))
do i=1,8
if (rbuf(i) .ne. 0) tas_info=.true.
enddo
endif
call sym_get_str('YAxis', i, yaxis)
call pglab(buf(1:l), yaxis(1:i), ' ')
buf=itit
i=index(buf, backslash)
j=0
do while (i .gt. 0)
i=j+i
buf(i+1:)=buf(i:)
j=i+1
i=index(buf(j+1:), backslash)
enddo
call pgsch(tsiz*1.25)
a1=0.01
call gra_show_par(a1, 0.0, 0, buf, 0, 0, 0.0, 0, 0.0)
call pgsch(tsiz)
top=-1.5
if (ififu .eq. 1) then
a1=0.01
call gra_show_par(a1, top,0,'Position'
1 ,nlines,5,u(3),5,werr(3))
a1=a1+pw
call gra_show_par(a1, top,0,'Max.Intensity'
1 ,nlines,5,u(4),5,werr(4))
a1=a1+pw
call gra_show_par(a1, top,0,'Int.Intensity'
1 ,nlines,5,u(5),5,werr(5))
a1=a1+pw
call gra_show_par(a1, top,0,'fwhm (Gaussian)'
1 ,nlines,5,u(6),5,werr(6))
a1=a1+pw
call gra_show_par(a1, top,0,'fwhm (Lorentzian)'
1 ,nlines,5,u(7),5,werr(7))
top=top-nlines-1.5
a1=0.01
call gra_show_par(a1,top,0,'Int.Intens.Exp.'
1 ,1,0,YINTEG,0,dYINTEG)
a1=pw+0.01
elseif (ififu .eq. 6) then
a1=0.01
call gra_show_par(a1,top,0,'Int.Intens.Exp.'
1 ,1,0,YINTEG,0,dYINTEG)
a1=pw+0.01
else
a1=0.01
endif
do i=n1,n2
call gra_show_par(a1,top,0,pnam(i),1,0,u(i),0,werr(i))
a1=a1+pw
if (a1 .gt. 1.0 .or.
1 ififu .eq. 6 .and. i .eq. 4 .or.
1 ififu .eq. 5 .and. i .eq. 3) then
a1=0.01
top=top-2.5
endif
enddo
if (a1 .gt. 0.01) then
top=top-2.5
a1=0.01
endif
if (ymon .ne. 0.0) then
call gra_show_par(a1,top,1,'Monitor',1,0,ymon,0,0.0)
endif
if (ififu .ne. 8) then
a2=0.01
buf='*** '//backslash//'gx'//backslash//'u2'//backslash//'d' ! chi square
call gra_show_par(a2,top-1.0,1,buf(4-isw(2):12),1,0,amin,0,0.0)
a1=max(a1,a2)
endif
call pgupdt
if (tas_info) then
do j=1,8
ebuf(j)=0
enddo
call gra_show_par(a1,top-1.0, 0, 'Steps', 0, 0, 0.0, 0, 0.0)
call gra_show_par(a1,top,3,'QHKL',6,1,rbuf,1,ebuf)
if (rbuf(7) .ne. 0 .or. rbuf(8) .ne. 0) then
call gra_show_par(a1,top,1,'EN',2,1,rbuf(7),1,ebuf(7))
endif
elseif (wavlen .ne. 0) then
call gra_show_par(a1,top,1,'WaveLength',1,0,wavlen,0,0.0)
endif
l=0
call sym_get_str('Range', l, buf)
if (l .gt. 1) then
l=l+7
buf(1:l)='Range: '//buf
call pglen(0, buf(1:l), ex, ey)
call gra_show_par(a1, top, 1, buf(1:l), 0,0,0.0,0,0.0)
a1=a1+ex+0.01
endif
if (temp .ne. 0) then
call gra_show_par(a1,top,1,'Temperature',1,0,temp,0,dtemp)
endif
a2=0
call sym_get_real('two_theta', a2)
if (a2 .ne. 0) then
call gra_show_par(a1,top,1,'2-Theta',1,0,a2,0,0.0)
endif
top=top-2.0
call str_trim(buf, fillis, l0)
call pglen(0, buf(1:l0), ex, ey)
call gra_show_par(0.99-ex, top, 1, buf(1:l0), 0,0,0.0,0,0.0)
if (legend .ne. 0) then ! show legend
call gra_trfmode(trfmode, 0.0)
call pgqcs(0, a2, ey)
legx=vlef+(vrig-vlef)*legendx/100
n=min(nset, nint(1.0/ey+top)-5, ncmax, maxset)
if (legend .lt. 0) then
n=min(n,-legend)
i1=0
i2=index(legendlabels, '|')
else
i2=2
endif
call pgswin(-0.5, 0.5, -3.0, 5.0)
legy=vtop-ey*0.5-(vtop-vbot)*legendy/100
if (legend .gt. 0 .and. legend .le. npd) then
call pgsvp(legx+0.005,legx+0.03,legy-ey,legy) ! set window to legend title
legy=legy-ey
pdig=1
if (legend .eq. 1) pdig=3 ! for numor with pal more digits
call gra_auto_fmt(ndig,vwid,ex,4
1 ,n,maxpd,pdpar(legend,1),0,0.0,pdig)
call pgtext(1.0, -2.0, userpar(usernp+legend))
endif
do i=1,n
if (i2 .ne. 1) then
call pgsvp(legx+0.01,legx+0.035,legy-ey,legy) ! set window to legend entry
legy=legy-ey
xcal(1)=-1.0
xcal(2)=0.0
xcal(3)=1.0
ycal(1)=1.0
ycal(2)=1.0
ycal(3)=1.0
ncnt(1)=i
ncnt(2)=i
ncnt(3)=i
if (autostyle .eq. powder_style) then
call gra_mult(xcal, ycal, ycal, ncnt, 3, 1, -10, ncol)
else
call gra_mult(xcal, ycal, ycal, ncnt, 3,nstyl,styl,ncol)
endif
endif
if (legend .lt. 0) then
if (i2 .eq. 0) then
call str_trim(legendlabels, legendlabels, i2)
i2=i2+1-i1
endif
if (i2 .gt. 1) then
call pgtext(1.0, -2.0, legendlabels(i1+1:i1+i2-1))
endif
i1=i1+i2
if (i1 .ge. len(legendlabels)) then
i2=1
else
i2=index(legendlabels(i1+1:), '|')
endif
else if (legend .le. npd) then
call cvt_real_str(buf, l, pdpar(legend,i), 1, ndig, 1, 2)
call pgptxt(1.0+vwid, -2.0, 0.0, 1.0, buf(1:l))
endif
enddo
call pgsvp(vlef,vrig,vbot,vtop) ! redefine window
call pgswin(scal(1), scal(2)
1 , gra_trf(scal(3),1), gra_trf(scal(4),1))
endif
if (ififu .eq. 1) then
nedi=nu/5+2
medi=maxedi
j=3
do i=3,nedi
xedi(i)=u(j)
yedi(i)=bgr(xedi(i))+u(j+1)
j=j+5
enddo
xedi(1)=u(3)
yedi(1)=u(1)
if (abs(scal(2)-u(3)) .gt. abs(scal(1)-u(3))) then
xedi(2)=scal(2)
else
xedi(2)=scal(1)
endif
yedi(2)=bgr(xedi(2))
else
nedi=0
medi=0
endif
gedi=nedi
c call pgupdt
call pgebuf
if (doprint) then
call gra_end_hcopy
elseif (doshow) then
c quit without close !cgt
else
3 selflg=.false.
4 call pgband(0, 0, 0.0, 0.0, ex, ey, key)
eyi=gra_itrf(ey)
call str_upcase(key, key)
if (key .eq. 'P') then ! print
doprint=.true.
goto 1
endif
if (key .eq. 'I') then
if (bgedit) then
if (nback .ge. maxdat) goto 3
do i=npkt+1,nback
if (ex .lt. xval(i)) then
j=i
goto 33
endif
enddo
j=nback+1
33 if (j .le. nback .and. j .gt. npkt+1) then
call pgsci(0)
call pgmove(xval(j-1), gra_trf(yval(j-1),1))
call pgdraw(xval(j), gra_trf(yval(j),1))
endif
do i=nback,j,-1
xval(i+1)=xval(i)
yval(i+1)=yval(i)
enddo
xval(j)=ex
yval(j)=eyi
call pgsci(2)
call pgpt1(xval(j), gra_trf(yval(j),1), 4)
if (j .gt. npkt+1) then
call pgmove(xval(j-1), gra_trf(yval(j-1),1))
call pgdraw(xval(j), gra_trf(yval(j),1))
else
call pgmove(xval(j), gra_trf(yval(j),1))
endif
if (j .le. nback) then
call pgdraw(xval(j+1), gra_trf(yval(j+1),1))
endif
nback=nback+1
call pgsci(1)
goto 3
endif
if (ififu .eq. 1 .or. nu .eq. 0) then ! insert peak
if (nu .le. 2) then
call fit_fun(0,1,ex,0.0)
write(isyswr, *)
else
call fit_create_peak
call fit_cop_par(nu-9, nu-4, 5)
if (lcode(nu-4) .le. 0) call fit_rel(nu-4) ! release Pos
if (icsw(nu-3) .lt. 0) then ! special cor.
if (lcode(nu-2) .le. 0) call fit_rel(nu-2) ! release IntInt
else
if (lcode(nu-3) .le. 0) call fit_rel(nu-3) ! release MaxInt
endif
u(nu-4)=ex
werr(nu-3)=0
u(nu-3)=0
werr(nu-2)=0
u(nu-2)=0
call fit_findhw(0, ex, u(nu-1), werr(nu-1))
werr(nu-4)=werr(nu-1)
werr(nu+1)=(eyi-bgr(ex))/10.
u(nu-3)=eyi-bgr(ex)
if (icsw(nu-3) .ne. 0) then
if (icsw(nu-3) .lt. 0) then
a1=voigt(0.0,u(nu-1),u(nu))
u(nu-2)=u(nu-3)/a1
werr(nu-2)=werr(nu-3)/a1
if (icsw(nu-2) .ne. 0) call fit_rel(nu-2)
else
call fit_rel(nu-3)
endif
endif
changed=.true.
call fit_set(0,0.0,0.0,0.0,0.0)
endif
call pgsci(2)
do i=1,ncal
ycal(i)=gra_trf(fifun(xcal(i)),1)
enddo
call pgline(ncal, xcal, ycal)
call pgsci(1)
goto 3
endif
goto 3
endif
if (key .eq. 'D') then
if (bgedit) then ! background stuff
if (nback .eq. npkt) goto 3
do i=npkt+1,nback
if (ex .lt. xval(i)) then
j=i
goto 45
endif
enddo
43 call pgsci(0)
if (nback .gt. npkt+1) then
call pgmove(xval(nback-1), gra_trf(yval(nback-1),1))
call pgdraw(xval(nback), gra_trf(yval(nback),1))
endif
call pgpt1(xval(nback), gra_trf(yval(nback),1), 4)
nback=nback-1
goto 49
45 if (j .gt. npkt+1 .and.
1 ex-xval(j-1) .lt. xval(j)-ex) j=j-1
if (j .eq. nback) goto 43
call pgsci(0)
if (j .le. npkt+1) then
call pgmove(xval(j), gra_trf(yval(j),1))
else
call pgmove(xval(j-1), gra_trf(yval(j-1),1))
call pgdraw(xval(j), gra_trf(yval(j),1))
endif
call pgdraw(xval(j+1), gra_trf(yval(j+1),1))
call pgpt1(xval(j), gra_trf(yval(j),1), 4)
nback=nback-1
do i=j,nback
xval(i)=xval(i+1)
yval(i)=yval(i+1)
enddo
if (j .eq. npkt+1) goto 49
call pgsci(2)
call pgmove(xval(j-1), gra_trf(yval(j-1),1))
call pgdraw(xval(j), gra_trf(yval(j),1))
49 call pgsci(1)
goto 3
endif
if (ififu .eq. 1 .and. nu .gt. 2) then
! remove peak
k=0
a1=1.0e38
do i=3,nu,5
if (abs(ex-u(i)) .lt. a1) then
k=i
a1=abs(ex-u(i))
endif
enddo
if (k .ne. 0) then
if (abs(ex-u(k)) .lt. max(abs(u(k+3)),abs(u(k+4)))) then ! only when within 2*fwhm
k=k+1
if (icsw(k) .le. 0) k=k+1
call fit_set(k,0.0,0.0,0.0,0.0) ! set intensity to zero
changed=.true.
call pgpage
goto 2
endif
endif
endif
goto 3
endif
if (key .eq. 'R') then ! repaint
call pgpage
goto 2
endif
if (key .eq. 'H') then ! toggle header
if (maxlines .eq. 10) then
maxlines=1
else
maxlines=10
endif
call pgpage
goto 2
endif
if (key .eq. 'X') then ! max scale
iscx=0
iscy=0
call pgpage
goto 2
endif
if (key .eq. 'Z' .or. key .eq. 'W' .or.
1 key .eq. 'E' .or. key .eq. 'N') then
xm1=min(scal(1),scal(2))
xm2=max(scal(1),scal(2))
ym1=gra_trf(min(scal(3),scal(4)),1)
ym2=gra_trf(max(scal(3),scal(4)),1)
ex=min(max(ex,xm1),xm2)
ey=min(max(ey,ym1),ym2)
if (.not. selflg) then
selflg=.true.
selx=ex
sely=ey
call pgsci(2)
call pgmove(ex,gra_trf(scal(3),1))
call pgdraw(ex,gra_trf(scal(4),1))
call pgmove(scal(1),ey)
call pgdraw(scal(2),ey)
call pgsci(1)
goto 4
endif
if (key .eq. 'Z') then ! zoom in
if (ex .ne. selx) then
if (scal(1) .gt. scal(2)) then
xbeg=max(ex,selx)
xend=min(ex,selx)
else
xbeg=min(ex,selx)
xend=max(ex,selx)
endif
iscx=1
endif
if (ey .ne. sely) then
if (scal(3) .gt. scal(4)) then
ybeg=gra_itrf(max(ey,sely))
yend=gra_itrf(min(ey,sely))
else
ybeg=gra_itrf(min(ey,sely))
yend=gra_itrf(max(ey,sely))
endif
iscy=1
endif
elseif (key .eq. 'W') then
if (ex .ne. selx) then
call fit_win(ex, selx)
else
call fit_win(1., 1.)
endif
elseif (key .eq. 'E') then
call fit_exclude(ex, selx, gra_itrf(ey), gra_itrf(sely))
elseif (key .eq. 'N') then
call fit_include(ex, selx, gra_itrf(ey), gra_itrf(sely))
endif
call pgpage
goto 2
endif
if (key .eq. 'O') then
xbeg= scal(1)*1.5-scal(2)*0.5
xend=-scal(1)*0.5+scal(2)*1.5
if (trfmode .eq. 0) then
ybeg= scal(3)*1.5-scal(4)*0.5
yend=-scal(3)*0.5+scal(4)*1.5
else
a1=max(scal(3),1e-30)
a1=sqrt(max(1.0,scal(4)/a1))
ybeg=scal(3)/a1
yend=scal(4)*a1
endif
iscx=1
iscy=1
call pgpage
goto 2
endif
if (key .eq. 'L') then
trfmode=1-trfmode
call pgpage
goto 2
endif
if (key .eq. 'C') then
if (ncolor .eq. 0) then
ncolor=999
else
ncolor=-ncolor
endif
write(buf, '(I8)') ncolor
call sys_setenv('FIT_COLORS', buf)
call sys_saveenv
call pgpage
goto 2
endif
if (key .eq. 'J') then
a1=ex-(scal(2)+scal(1))*0.5
xbeg=scal(1)+a1
xend=scal(2)+a1
if (trfmode .eq. 0) then
a1=ey-(scal(4)+scal(3))*0.5
ybeg=scal(3)+a1
yend=scal(4)+a1
else
ybeg=gra_trf(scal(3),1)
yend=gra_trf(scal(4),1)
a1=ey-0.5*(ybeg+yend)
ybeg=gra_itrf(ybeg+a1)
yend=gra_itrf(yend+a1)
endif
iscx=1
iscy=1
call pgpage
goto 2
endif
if (key .eq. 'S') then
call pgsci(0)
call pgmtxt('B', 3.0, 0.0, 0.0, coord)
call cvt_real_str(coord(1:15), l, ex, 1, 0, 5, 0)
l=l+1
coord(l:l)=','
call cvt_real_str(coord(l+1:l+15), i, ey, 1, 0, 5, 0)
coord(l+i+1:)=' '
call pgsci(1)
call pgmtxt('B', 3.0, 0.0, 0.0, coord)
goto 4
endif
if (key .ne. 'Q' .and. key .ne. 'K' .and.
1 key .ne. '3' .and. key .ne. '1' .and.
1 key .gt. ' ') then ! help for unknown key
call pgsci(2)
if (bgedit) then
call gra_show_par(0.01, top, 0
1 ,'P: print, I: insert pt., D: delete pt., R: repaint, '
1//'X: full size, Z: zoom in, O: zoom out, Q: quit'
1 , 0, 0, 0.0, 0, 0.0)
else
call gra_show_par(0.01, top, 0
1 ,'P: print, I: insert peak, D: delete peak, R: repaint, '
1//'X: full size, Z: zoom in, O: zoom out, Q: quit'
1 , 0, 0, 0.0, 0, 0.0)
endif
call pgsci(1)
goto 4
endif
if (key .eq. 'K') then ! keep (write) parameters values
cmdline=' '
call fit_write(' ')
endif
if (.not. autoplot) then
call gra_close !cgt
endif
endif
if (changed) call fit_print(1)
end
subroutine fit_plog(mode, shft)
implicit none
include 'fit.inc'
integer mode
real shft
trfmode=min(1,max(0,mode))
shift(trfmode)=shft
end
subroutine fit_legend(var)
implicit none
include 'fit.inc'
character var*(*)
character nup*32, pup*32
integer i,l,ios
if (var(1:1) .eq. '@') then
legendx=0
legendy=0
read(var(2:), *, iostat=ios) legendx, legendy
if (ios .ne. 0 .and. legendx .eq. 0) then
print *,'illegal legend position command, use 0,0'
endif
RETURN
endif
i=index(var,'|')
if (i .ne. 0) then
if (i .eq. 1 .and. legend .lt. 0) then
call str_trim(legendlabels, legendlabels, l)
if (legendlabels(l:l) .eq. '|') then ! strip off last bar
l=l-1
legend=legend+1
endif
if (l .lt. len(legendlabels)) legendlabels(l+1:)=var
else
legend=-1
legendlabels=var
endif
do i=1,len(var)
if (var(i:i) .eq. '|') legend=legend-1
enddo
RETURN
endif
call str_upcase(nup, var)
if (nup .eq. ' ') then
legend=1
if (npd .eq. 0) userpar(usernp+legend)=' '
elseif (nup .eq. '0') then
legend=0
else
do i=usernp+1,usernp+npd
call str_upcase(pup, userpar(i))
if (nup .eq. pup) then
legend=i-usernp
goto 3
endif
enddo
if (npd .ge. maxpd .or. npd+usernp .ge. maxext) npd=npd-1
call fit_userpdp(var)
legend=npd
if (fillis .ne. ' ') call fit_dat(fillis)
endif
3 continue
end
subroutine fit_colors(iarg)
implicit none
include 'fit.inc'
character*8 value
integer iarg
ncolor=iarg
write(value, '(i8)') ncolor
call sys_setenv('FIT_COLORS', value)
call sys_saveenv
end