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