977 lines
23 KiB
Fortran
Executable File
977 lines
23 KiB
Fortran
Executable File
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
|