Source module last modified on Fri, 12 May 2006, 13:45;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#//////////////////////////////////////////////////////////////////////
#//// $Id: resgraph2.f,v 1.10 2006/05/12 11:45:29 saroun Exp $
#//// R E S T R A X 4.8
#////
#//// Graphics output subroutines (PGPlot library required)
#//// LEVEL 2 subroutines:
#//// FILL 2D-IMAGE ARRAY, PLOT 2D-IMAGE ARRAY , PLOT 1D-SCAN DATA
#//////////////////////////////////////////////////////////////////////
#*********************** FILL 2D-IMAGE ARRAY ******************************
#----------------------------------------------------------------------
SUBROUTINE FILARRAY(port,indx,shx,shy,aima,nimx,nimy,nm,tm)
# Fills array AIMA by events stored in KSTACK
# PORT ... plotting viewport (IX,IY defines projection plane)
# INDX ... dataset index. If INDX=0, then take current dataset.
# SHX,SHY ... shift QE points in X,Y with respect to the image centre.
# AIMA(NIMA,NIMA) ... returned real*4 array with resulting map
# NM<>0 ... events are transformed by matrix TM.
# NM<0 ... transposed matrix TM is used.
# TM ... transformation matrix for Q,E events
# (from C&N to plotting coordinates)
# CALLS: KSTACK routines
# CALLED BY: PlotResQE,PlotResol,PAGE1
#----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
integer*4 nimx,nimy,nm,i4,ncnt,ix,iy,j,k,jx,jy
integer*4 indx,idata
real*4 aima(nimx,nimy)
real*8 tm(4,4),e(4),e1(4),dimx,dimy,p,shx,shy
record /VIEWSET/ port
1 format(a20,4(2x,g17.5))
idata=indx
if(idata.le.0.or.idata.gt.mf_max) idata=mf_cur
dimx=(port.wx2-port.wx1)/nimx
dimy=(port.wy2-port.wy1)/nimy
ix=port.ix
iy=port.iy
do 131 j=1,nimx
do 131 k=1,nimy
aima(j,k)=0
131 continue
call KSTACK_N(ncnt,mf_cur) ! get number of events NCNT
if (ncnt.gt.0) then
do 132 i4=1,ncnt
if (nm.ne.0) then
call GETQE(i4,idata,e1,p)
call MXV(nm,4,4,tm,e1,e)
else
call GETQE(i4,idata,e,p)
endif
jx=int((e(ix)+shx)/dimx+nimx/2.)+1
jy=int((e(iy)+shy)/dimy+nimy/2.)+1
if((jx.gt.0).and.(jx.le.nimx)) then
if((jy.gt.0).and.(jy.le.nimy)) then
aima(jx,jy)=aima(jx,jy)+p
endif
endif
132 continue
endif
return
end
#--------------------------------------------------------------------
SUBROUTINE FILL_FCONE(port,aima,nimx,nimy,icom)
# Fills array AIMA by events stored in KSTACK for flatcone arrangement
# Assumes scan in A3,A4
# PORT ... plotting viewport (IX,IY defines projection plane)
# AIMA(NIMA,NIMA) ... returned real*4 array with resulting map
# ICOM=0 ... plot data (from data array SPX...)
# ICOM>0 ... plot fit using EXCI (from histogram array XHIST ...)
# CALLS: KSTACK routines
# CALLED BY: AB_MAP
#--------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
record /VIEWSET/ port
integer*4 nimx,nimy,idat,icom,i_io
real*4 aima(nimx,nimy)
real*8 imx0,imy0,dimx,dimy,da3,da4,a3,a4,a30(mdat),a40
real*8 scan(mhis,mdat),vq0(4),vq(4)
integer*4 i,j,k,idat0,ier,iz3,iz4,np
real*8 s00,s01,s10,s11,f0,f1,dum,z3,z4
real*8 ax(3),bx(3),xp,yp
equivalence (ax(1),mf_par(i_ax,1))
equivalence (bx(1),mf_par(i_bx,1))
9 format(128(1x,g10.4))
13 format( 'scale (',g12.5, ',',g12.5, ',',g12.5, ',',g12.5, ')')
1 format( 'FCONE: check scattering triangle: ',i9)
2 format( 'FCONE: unequal number steps in channels: ',i9, ' ID=',i9)
# write(*,*) 'FCONE: start'
dimx=(port.wx2-port.wx1)/nimx
dimy=(port.wy2-port.wy1)/nimy
imx0=(port.wx2+port.wx1)/2
imy0=(port.wy2+port.wy1)/2
do 10 j=1,nimx
do 10 k=1,nimy
aima(j,k)=0
10 continue
# get scan parameters from the 1st channel
# assume equidistant scan in A4 and A3
# assume equal number of steps for each channel
np=nhist(1)
if (icom.eq.0) then
da3=dqe0(5,1)*deg
da4=dqe0(6,1)*deg
np=npt(1)
do i=1,4
vq0(i)=qe0(i,1)
enddo
else
da3=mf_par(i_da3,1)*deg
da4=mf_par(i_da4,1)*deg
np=nhist(1)
do i=1,4
vq0(i)=mf_par(i_qh+i-1,1)
enddo
endif
call GET_A3A4(1,vq0,dum,a40,ier)
# write(*,*) 'GETA3A4 ier=',IER
#20 format(a,4(1x,G10.4),2(1x,a,1x,G10.4))
# write(*,20) 'VQ0: ',VQ0,' A3: ',DUM/deg,' A4',A40/deg
# pause
if (ier.ne.0.or.abs(dum).gt.1e-6) goto 98
# fill SCAN array with data values
# SCAN is a matrix for "orthogonal" (A3,A4) grid
idat0=0
k=0
if (icom.eq.0) then
do i=1,npt(mf_max)
idat=ipt(i)
if(idat.ne.idat0) then ! new channel
if (k.ne.0.and.k.ne.np) goto 99
k=0
a30(idat)=spx(i)*da3
idat0=idat
endif
k=k+1
if (k.gt.np) goto 99
scan(k,idat)=spy(i)
enddo
else
do i=1,nhist(mf_max)
idat=ihist(i)
if(idat.ne.idat0) then ! new channel
if (k.ne.0.and.k.ne.np) goto 99
k=0
a30(idat)=xhist(i)*da3
idat0=idat
endif
k=k+1
if (k.gt.np) goto 99
scan(k,idat)=rhist(i)
enddo
endif
i_io=25
close(i_io)
open(unit=i_io,file= 'fcone_channels.dat',status= 'Unknown')
write(i_io,13) xhist(1)*da3/deg,xhist(np)*da3/deg,
& 0,mf_par(i_da4,1)*mf_max
do j=1,np
write(i_io,9) (scan(j,i),i=1,mf_max)
enddo
close(i_io)
#11 format(a,6(1x,G12.6))
# write(*,11) 'NP: ',NP
# write(*,11) 'x-scale: ',PORT.WX1,PORT.WX2,DIMX
# write(*,11) 'y-scale: ',PORT.WY1,PORT.WY2,DIMY
# write(*,11) 'A30,A40: ',A30(1)/deg,A40/deg
# pause
# fill AMAT array by linear interpolation in SCAN
do i=1,4
vq(i)=vq0(i)
enddo
do i=1,nimx
do j=1,nimy
xp=port.wx1+(i-0.5)*dimx
yp=port.wy1+(j-0.5)*dimy
vq(1)=xp*ax(1)+yp*bx(1)
vq(2)=xp*ax(2)+yp*bx(2)
vq(3)=xp*ax(3)+yp*bx(3)
# write(*,*) 'pixel: ',I,J,VQ(1),VQ(2),DA4
call GET_A3A4(1,vq,a3,a4,ier)
# write(*,*) 'A3,A4: ',A3/deg,A4/deg
z4=(a4-a40)/da4
iz4=nint(z4)+1
# write(*,*) 'I3,I4: ',INT(Z3),INT(Z4)
if (ier.ne.0.or.iz4.le.0.or.iz4.gt.mf_max) then
aima(i,j)=0 ! out of data range
else
z3=(a3-a30(iz4))/da3
iz3=nint(z3)+1
if (iz3.le.0.or.iz3.gt.np) then
aima(i,j)=0 ! out of data range
else
# write(*,*) 'pixel: ',I,J,VQ(1),VQ(2)
# write(*,*) 'A3,A4: ',INT(Z3),INT(Z4),A3/deg,A4/deg
# pause
if (iz4.eq.mf_max) iz4=iz4-1
if (iz3.eq.np) iz3=iz3-1
s00=scan(iz3,iz4)
s01=scan(iz3,iz4+1)
s10=scan(iz3+1,iz4)
s11=scan(iz3+1,iz4+1)
f0=s00+(z4+1-iz4)*(s01-s00)
f1=s10+(z4+1-iz4)*(s11-s10)
aima(i,j)=f0+(z3+1-iz3)*(f1-f0)
endif
endif
enddo
enddo
# write(*,*) 'FCONE: OK'
# pause
return
98 write(smes,1) ier
return
99 write(smes,2) k,idat
return
end
#-----------------------------------------------------------------------
SUBROUTINE FILLQHKL(port,idat,ir,aima,nimx,nimy,clr,da3,nm,tm)
# Fills array AIMA by events stored in KSTACK
# PORT ... plotting viewport (IX,IY defines projection plane)
# IDAT ... dataset index. If IDAT=0, then take current dataset.
# IR<>0 ... add nominal QHKL
# AIMA(NIMA,NIMA) ... returned real*4 array with resulting map
# CLR=0 ... clear AIMA
# DA3 ... events are rotated by DA3 [deg] (sample rotation)
# NM<>0 ... events are transformed by matrix TM.
# TM ... transformation matrix for Q,E events
# (from C&N to plotting coordinates)
# CALLS: KSTACK routines
# CALLED BY: RES_IMAGE,MRES_ALL,AB_MAP
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'lattice.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
integer*4 nimx,nimy,idat,ir,clr,nm
real*4 aima(nimx,nimy)
real*8 imx0,imy0,tm(4,4)
real*8 e(4),e1(4),e2(4),da3
record /VIEWSET/ port
integer*4 i4,ncnt,icnt
integer*4 ix,iy,i,j,k,jx,jy
real*8 dimx,dimy,ex,ey,pp
real*8 aux(3,3)
1 format(a20,4(2x,g12.6))
dimx=(port.wx2-port.wx1)/nimx
dimy=(port.wy2-port.wy1)/nimy
imx0=(port.wx2+port.wx1)/2
imy0=(port.wy2+port.wy1)/2
ix=port.ix
iy=port.iy
if (clr.eq.0) then
do 131 j=1,nimx
do 131 k=1,nimy
aima(j,k)=0
131 continue
endif
# prepare rotation matrix
if (da3.ne.0) then
do i=1,3
do j=1,3
aux(i,j)=0.
enddo
aux(i,i)=1.
enddo
aux(1,1)=cos(da3)
aux(2,2)=aux(1,1)
aux(1,2)=sin(da3)
aux(2,1)=-aux(1,2)
endif
call KSTACK_N(ncnt,idat) ! get number of events NCNT
# fill array AIMA with events
icnt=0
if (ncnt.gt.0) then
do 132 i4=1,ncnt
call GETQE(i4,idat,e1,pp)
call M4xV4_3(mf_mrc(1,1,idat),e1,e) ! convert to [hkl]
if (ir.ne.0) then
do i=1,4
e(i)=e(i)+mf_par(i_qh+i-1,idat)
enddo
endif
if (da3.ne.0) then ! rotate by DA3
call M4xV4_3(smat,e,e1) ! convert QHKL to AB
call M3xV4(aux,e1,e2) ! rotate QHKL
call M4xV4_3(sinv,e2,e) ! convert QHKL to r.l.u
endif
if (nm.ne.0) then
# do i=1,4
# write(*,1) 'TM: ',(TM(i,j),j=1,4)
# enddo
# write(*,1) 'FILLQHKL: ',(E1(j),j=1,4)
# write(*,1) 'FILLQHKL: ',(E(j),j=1,4)
call M4xV4(tm,e,e1)
# write(*,1) 'FILLQHKL: ',(E1(j),j=1,4)
# pause
ex=e1(ix)
ey=e1(iy)
else
ex=e(ix)
ey=e(iy)
endif
if(ex.gt.port.wx1.and.ex.lt.port.wx2.and.
* ey.gt.port.wy1.and.ey.lt.port.wy2) then
jx=int((ex-port.wx1)/dimx)+1
jy=int((ey-port.wy1)/dimy)+1
aima(jx,jy)=aima(jx,jy)+pp
icnt=icnt+1
endif
132 continue
# write(*,*) 'Integrated ',ICNT,' events in data ',IDAT
endif
return
end
#------------------------------------------------------------
SUBROUTINE FILLSQ(port,aima,nimx,nimy,tm)
# Fills array AIMA by values of S(Q,E).
# Takes sample parameters from current dataset.
# PORT ... plotting viewport (IX,IY defines projection plane)
# AIMA(NIMA,NIMA) ... returned real*4 array with resulting map
# TM ... transformation matrix from plotting coordinates to r.l.u.
# CALLS: FILLQOMARRAY
# CALLED BY: PlotResQE,AB_MAP
#------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
INCLUDE 'exciimp.inc'
record /MODEL/ rm
integer*4 nimx,nimy,j,k,i,l
integer*4 idata
real*4 aima(nimx,nimy),aux(mimax,mimax,6),enorm
real*8 tm(4,4),gm,px,w,z,cn
record /VIEWSET/ port
idata=mf_cur ! take all parameters from the current data set
enorm=mf_par(i_en,idata)
#// fill QOM array with values corresponding to viewport pixels
call FILLQOMARRAY(port,idata,nimx,nimy,tm)
call getmodel(rm)
call getqomega(rq)
#// clear AIMA
do k=1,nimy
do j=1,nimx
aima(j,k)=0.
enddo
enddo
#// clear AUX
do i=1,rm.nbr
do k=1,nimy
do j=1,nimx
aux(j,k,i)=0.
enddo
enddo
enddo
#// loop through wen>0 branches
10 format( ' finite width branches: ',$)
20 format( ' zero width branches: ',$)
11 format(i2,1x,$)
write(sout,10)
do i=1,rm.nbr
if (rm.wen(i).gt.0) then
write(sout,11) i
do k=1,nimy
do j=1,nimx
l=k+(j-1)*nimy+(i-1)*nimx*nimy
aux(j,k,i)=rq.pqom(l)
enddo
enddo
endif
enddo
# loop through wen=0 branches
write(sout,20)
do i=1,rm.nbr
if (rm.wen(i).le.0) then
write(sout,11) i
gm=max(mf_par(i_gmod,idata),5.d0) ! typical disp. gradient
px=(abs((port.wx2-port.wx1)/nimx)+abs((port.wy2-port.wy1)/nimy))/2.0 ! pixel size
w=gm*px ! default gaussian width for visualisation
cn=sqrt(2*pi)*w
do k=1,nimy
do j=1,nimx
l=k+(j-1)*nimy+(i-1)*nimx*nimy
z=((enorm-rq.qom(4,l))/w)**2
aux(j,k,i)=rq.pqom(l)*exp(-0.5*z)/cn
enddo
enddo
endif
enddo
#// sum all branches
do i=1,rm.nbr
do k=1,nimy
do j=1,nimx
aima(j,k)=aima(j,k)+aux(j,k,i)
enddo
enddo
enddo
write(sout,*) 'FILLSQ OK'
end
#*********************** PLOT 2D-IMAGE ARRAY ******************************
#--------------------------------------------------------------------
SUBROUTINE AB_MAP(xmin,xmax,ymin,ymax,comment,aima,nima,icom)
# Plot projections on the scattering plane (for flatcone arrangement)
# XMIN..YMAX ... defines viewport area in units of AX..AZ, BX..BZ vectors
# COMMENT ... a string to appear on the plot
# AIMA(NIMA,NIMA) ... returned real*4 array with resulting map
# ICOM=ig_FCRES ... plot R(Q,E) for flatcone
# ICOM=ig_FCDATA ... plot 2D data for flatcone
# ICOM=ig_SQMAP ... map of S(Q) at E=const.
# CALLS: FILLQHKL,FILL_FCONE,FILLSQ
# CALLED BY: AB_IMAGE
#--------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'lattice.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
integer*4 nima,np,icom
real*8 xmin,xmax,ymin,ymax,da3
real*4 aima(nima,nima)
character*50 comment
record /VIEWSET/ port
character*32 namex,namey
integer*4 i,j
real*8 SUM,zmax
real*8 ax(3),bx(3)
equivalence (ax(1),mf_par(i_ax,1))
equivalence (bx(1),mf_par(i_bx,1))
#// prepare viewport
if (icom.eq.ig_fcres) then
port.head= 'Flat-cone resolution functions'
else if (icom.eq.ig_fcdata) then
port.head= 'Flat-cone data map'
else if (icom.eq.ig_sqmap) then
port.head= 'S(Q) map at E=const.'
endif
port.wx1=xmin
port.wx2=xmax
port.wy1=ymin
port.wy2=ymax
port.dx1=0.15
port.dx2=0.93
port.dy1=0.31
port.dy2=0.89
port.ix=1
port.iy=2
call FORMAT_HKL(ax,namex,32)
call FORMAT_HKL(bx,namey,32)
port.xtit= '\gc '//namex
port.ytit= '\gc '//namey
call pgslw(4)
call pgsch(1.5)
#// fill AIMA array with R(Q,E) events (ICOM=0)
#// or data from RHIST (ICOM=1)
if (icom.eq.ig_fcres) then
do i=1,mf_max
np=npt(i)-npt(i-1)
call FILLQHKL(port,i,1,aima,nima,nima,i-1,0.d0,1,mabr)
da3=mf_par(i_da3,i)
if(da3.ne.0.and.np.gt.2) then ! add images at scan limits for A3 scans
da3=da3*nint((np-1)/2.0)*deg
call FILLQHKL(port,i,1,aima,nima,nima,1,-da3,1,mabr)
call FILLQHKL(port,i,1,aima,nima,nima,1,da3,1,mabr)
endif
enddo
else if (icom.eq.ig_fcdata) then
call FILL_FCONE(port,aima,nima,nima,1) ! 1 .. from RHIST
else if (icom.eq.ig_sqmap) then
call FILLSQ(port,aima,nima,nima,mrab) ! 2 .. S(Q) map at E=EN
endif
sum=0.
zmax=0
do i=1,nima
do j=1,nima
sum=sum+aima(i,j)
if(aima(i,j).gt.zmax) zmax=aima(i,j)
enddo
enddo
if (sum.le.0) then
return
endif
do i=1,nima
do j=1,nima
aima(i,j)=aima(i,j)/sum*nima**2
enddo
enddo
if (icom.eq.ig_sqmap) then
call PLOT2D(port,aima,nima,nima,nima,nima,10.) ! log10 scale
else
call PLOT2D(port,aima,nima,nima,nima,nima,0.)
endif
call PLOTFRAME(port,1,1,1.8,0)
call pgslw(2)
call pgsch(1.0)
call pgsci(1)
call pgmtext( 'B',10.,-0.05,0.0,comment)
call pgiden
end
#----------------------------------------------------------------------
SUBROUTINE MRES_ALL(id,ix,iy,xmi,xma,ymi,yma,comment,aima,nima)
# Merge resolution functions for data set(s) into one matrix and plot
# INPUT
# ID ... dataset index, if=0 then merge all data sets
# IX,IY ... define axes in [hklE] (h=1 ...etc.)
# XMIN..YMAX ... define viewport area
# COMMENT ... a string to appear on the plot
# OUTPUT:
# AIMA(NIMA,NIMA) ... returned real*4 array with resulting map
#----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
integer*4 id,ix,iy,nima,np
real*8 xmi,xma,ymi,yma,da3
character*(*) comment
real*4 aima(nima,nima)
character*32 s1,s2,s3,s4
character*128 leg1
record /VIEWSET/ port
character*32 name(4),name1(4)
integer*4 i,j
real*8 SUM,zmax,aux(4,4)
data name/ '(\gc 0 0)', '(0 \gc 0)', '(0 0 \gc)', '\gDE [meV]'/
data name1/ 'h ', 'k ', 'k ', 'dE [meV]'/
102 format( 'nominal Q\dhkl\u = [',a, ',',a, ',',a, '] E = ',a, ' meV')
#// format legend
call FLOAT2STR(qhkl(1),s1)
call FLOAT2STR(qhkl(2),s2)
call FLOAT2STR(qhkl(3),s3)
call FLOAT2STR(res_dat(i_en),s4)
write(leg1,102) s1(1:len_trim(s1)),s2(1:len_trim(s2)),
& s3(1:len_trim(s3)),s4(1:len_trim(s4))
#// set PORT attributes
port.head= 'Projection of R(Q,E) [r.l.u]'
port.wx1=xmi
port.wx2=xma
port.wy1=ymi
port.wy2=yma
port.dx1=0.15
port.dx2=0.93
port.dy1=0.31
port.dy2=0.89
port.ix=ix
port.iy=iy
port.xtit=name(ix)
port.ytit=name(iy)
#// draw the graph
call pgslw(4)
call pgsch(1.5)
if (id.eq.0) then
do i=1,mf_max
np=npt(i)-npt(i-1)
call FILLQHKL(port,i,1,aima,nima,nima,i-1,0.d0,0,aux)
da3=mf_par(i_da3,i)
if(da3.ne.0.and.np.gt.2) then ! add images at scan limits for A3 scans
da3=da3*nint((np-1)/2.0)*deg
call FILLQHKL(port,i,1,aima,nima,nima,1,-da3,0,aux)
call FILLQHKL(port,i,1,aima,nima,nima,1,da3,0,aux)
endif
enddo
else
call FILLQHKL(port,id,1,aima,nima,nima,0,0.d0,0,aux)
endif
#// normalization of the array
sum=0.
zmax=0
do i=1,nima
do j=1,nima
sum=sum+aima(i,j)
if(aima(i,j).gt.zmax) zmax=aima(i,j)
enddo
enddo
if (sum.gt.0) then
do i=1,nima
do j=1,nima
aima(i,j)=aima(i,j)/sum*nima**2
enddo
enddo
call PLOT2D(port,aima,nima,nima,nima,nima,0.)
endif
call PLOTFRAME(port,1,1,1.8,0)
call pgslw(2)
call pgsch(1.0)
call pgsci(1)
call pgmtext( 'B',12.0,0.0,0.0,leg1(1:len_trim(leg1)))
call pgmtext( 'B',10.0,0.0,0.0,comment(1:len_trim(comment)))
call pgiden
end
#*********************** PLOT 1D-SCAN DATA ******************************
#--------------------------------------------------------------------
SUBROUTINE PLOTSCAN(port,xfx,fy,nf,ic,ip,iline)
# Plot function (FX,FY,NF). Plots also current dataset if there is one.
# PORT ... plotting viewport
# XFX ... x-values
# FY ... y-values
# NF ... number of points
# IC ... color
# IP ... point style
# ILINE ... line style
# CALLS:
# CALLED BY: PAGE2
#--------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
record /VIEWSET/ port
character*60 leg1,leg2
logical*4 escan
integer*4 nf,np,ib
real*4 xfx(nf),fy(nf)
real*4 spxd(nhi*4)
real*8 pmax,centre,range,en,de,z
integer*4 i,ic,ip,iline,j1,j2,jr,is1,il1,is2,il2
logical*4 plotdata
102 format( 'Q = [',g10.4, ' ',g10.4, ' ',g10.4, ']')
103 format( 'E = ',g10.4, ' ',a3)
104 format( '\gDq\dhkl\u = [',g10.4, ' ',g10.4, ' ',g10.4, ']')
105 format( '\gDE =',g10.4, ' ',a3)
en=res_dat(i_en)
de=res_dat(i_den)
#// define viewport:
escan=((abs(delq(1))+abs(delq(2))+abs(delq(3))).eq.0)
port.wy1=0
pmax=0
np=npt(mf_cur)-npt(mf_cur-1) ! number of points incurrent data set
ib=npt(mf_cur-1)+1 ! base index for the incurrent data set
if(np.gt.nhi*4) np=nhi*4
#// decide whether to plot also measured data
#// yes, if NP>0 and SPY(i)<>0
z=0.
do i=1,np
z=z+abs(spy(ib+i-1))
enddo
plotdata=(np.gt.0.and.z.gt.0)
if (nf.le.0.and..not.(plotdata)) return ! nothing to plot
#// if spectrum is loaded, get x-axis points from it
if (plotdata) then
do i=1,np
pmax=max(pmax,spy(i)*1.d0)
if(escan) then
spxd(i)=spx(i+ib-1)*de+en ! x-axis on energy scale
else
spxd(i)=spx(i+ib-1)
endif
#1 FORMAT(3(3x,G13.5))
# write(*,1) SPXD(I),SPX(I),SPY(I)
end do
endif
do i=1,nf
if(escan) xfx(i)=xfx(i)*de + en ! x-axis on energy scale
pmax=max(pmax,fy(i)*1.d0)
#1 FORMAT(3(3x,G13.5))
# write(*,1) XFX(I),(FY(I)-FPAR(2))/FPAR(1)
end do
#// if spectrum is loaded, get range from it
if(plotdata) then !
centre=(spxd(1)+spxd(np))/2.
# RANGE=ABS(XFX(NF)-XFX(1))+4.*ABS(XFX(2)-XFX(1))
range=abs(spxd(np)-spxd(1))*2
#// otherwise - help yourself
else
centre=(xfx(1)+xfx(nf))/2.
i=1
do 41 while ((fy(i).eq.0).and.(i.lt.nf))
41 i=i+1
if(i.gt.1) i=i-1
j1=i
# z1=MIN(-10,(i-2)XFX(i)-2*DX)
i=nf
do 42 while ((fy(i).eq.0).and.(i.gt.1))
42 i=i-1
if(i.lt.nf) i=i+1
j2=i
jr=j2-j1+5
jr=max(jr,20)
j1=max(j1-jr/2,1)
j2=min(j2+jr/2,nf)
range=abs(xfx(j2)-xfx(j1))
endif
port.wx1=centre-range/2.
port.wx2=centre+range/2.
port.wy2=pmax*1.25
if(escan) then
port.xtit= 'E '//cunit
else
port.xtit= 'steps '
endif
port.ytit= 'counts '
port.head= ' '
call CLRPORT(port)
call PLOTFRAME(port,1,1,1.,0)
#// spectrum:
if(iline.eq.0) then
call pgsls(1)
else
call pgsls(iline)
endif
call pgsci(ic)
if (ip.ne.0) call pgpoint(nf,xfx,fy,ip)
if (iline.ne.0) call pgline(nf,xfx,fy)
if(plotdata) then
call pgsch(2.)
call pgsci(3)
call pgpoint(np,spxd,spy(ib),17) ! Plot SPY starting from IB
call pgsch(1.)
endif
call pgsci(1)
call pgsls(1)
#// legend:
call pgsch(0.8)
write(leg1,102) qhkl
write(leg2,103) en,cunit(2:4)
call STRCOMPACT(leg1,is1,il1)
call STRCOMPACT(leg2,is2,il2)
call pgmtext( 'T',-1.5,0.05,0.0,leg1(is1:is1+il1-1)// ' '
& //leg2(is2:is2+il2-1))
write(leg1,104) delq
write(leg2,105) de,cunit(2:4)
call STRCOMPACT(leg1,is1,il1)
call STRCOMPACT(leg2,is2,il2)
call pgmtext( 'T',-3.0,0.05,0.0,leg1(is1:is1+il1-1)// ' '
& //leg2(is2:is2+il2-1))
call pgsch(1.0)
end
#--------------------------------------------------------------------
SUBROUTINE PLOTCELL(port,n,ic,ip,iline)
# Plot N-th dataset and corresponding histogram in PORT:
# Show filename and ChiSqr
# PORT ... plotting viewport
# N ... dataset index
# IC ... color
# IP ... point style
# ILINE ... line style
# CALLS: GETDATASCALE
# CALLED BY: PLOT_MDATA
#--------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
record /VIEWSET/ port
character*72 leg1,leg2,header
integer*4 nf,np,ib,n,ibh
real*4 fx(128),fy(128)
real*4 spxd(nhi*4),ss,chsize
real*8 pmax,centre,range,xstep,x0,z
integer*4 i,ic,ip,iline,k,is1,is2,il1,il2
logical*4 plotdata
character*5 xtit(5)
data xtit / 'QH', 'QK', 'QL', 'EN', 'A3'/
106 format( '\gx\u2\d = ',g10.4)
102 format( 'Q= [',g10.4, ' ',g10.4, ' ',g10.4, ']')
103 format( 'E= ',g10.4, ' ',a3)
104 format( '\gDQ=[',g10.4, ' ',g10.4, ' ',g10.4, ']')
105 format( '\gDE=',g10.4, ' ',a3)
#// get N-th data and histogram
np=npt(n)-npt(n-1) ! number of points incurrent data set
ib=npt(n-1)+1 ! base index for the incurrent data set
nf=nhist(n)-nhist(n-1) ! number of points in current histogram
ibh=nhist(n-1)+1 ! base index for current histogram
do i=1,nf
fy(i)=rhist(i+ibh-1)
fx(i)=xhist(i+ibh-1)
end do
if(np.gt.nhi*4) np=nhi*4
#// decide whether to plot also measured data
#// yes, if NP>0 and SPY(i)<>0
z=0.
do i=1,np
z=z+abs(spy(ib+i-1))
enddo
plotdata=(np.gt.0.and.z.gt.0)
#// Find optimum x-scale
call GETDATASCALE(n,centre,range,xstep,x0,k)
if (k.le.0) return
#// find maximum of Y and set X points
pmax=0
if (np.gt.0) then
do i=1,np
pmax=max(pmax,spy(i)*1.d0)
spxd(i)=spx(i+ib-1)*xstep+x0 ! x-scale for data
end do
endif
do i=1,nf
fx(i)=fx(i)*xstep + x0 ! x-scale for histogram
pmax=max(pmax,fy(i)*1.d0)
end do
if (pmax.le.0) return ! there is nothing to plot ...
#// Set Viewport
port.wx1=centre-range/2.
port.wx2=centre+range/2.
port.wy1=0.
port.wy2=pmax*1.2
port.xtit=xtit(k)
port.ytit= 'counts '
port.head= ' '
#// Set optimum character size
chsize=max(0.7,2.3*(port.dx2-port.dx1))
chsize=min(chsize,1.2)
call pgsch(chsize)
#// Plot main frame
call CLRPORT(port)
call PLOTFRAME(port,1,1,chsize,0)
# set line style
if(iline.eq.0) then
call pgsls(1)
else
call pgsls(iline)
endif
# set symbol size
ss=max(0.3,3.*(port.dx2-port.dx1))
ss=min(ss,2.)
call pgsch(ss)
#/ Plot curves
if(nf.gt.0) then
call pgsci(ic)
if (ip.ne.0) call pgpoint(nf,fx,fy,ip)
if (iline.ne.0) call pgline(nf,fx,fy)
endif
if(plotdata) then
call pgsci(3)
call pgpoint(np,spxd,spy(ib),17) ! Plot SPY starting from IB
endif
call pgsci(1)
call pgsls(1)
header= ' '
if(np.gt.0) header=mf_name(n)
# Plot Legend
if(plotdata) then
call pgsch(chsize*0.8)
write(leg1,106) dchisq(n)
if(mf_cur.eq.n) call pgsci(2)
call pgmtext( 'T',-1.5,0.6,0.0,header(1:16))
call pgsci(1)
call pgmtext( 'T',-1.5,0.05,0.0,leg1(1:20))
else
call pgsch(chsize*0.8)
write(leg1,102) (res_dat(i_qh+i-1),i=1,3)
write(leg2,103) res_dat(i_en),cunit(2:4)
call STRCOMPACT(leg1,is1,il1)
call STRCOMPACT(leg2,is2,il2)
call pgmtext( 'T',-1.5,0.05,0.0,leg1(is1:is1+il1-1)// ' '
& //leg2(is2:is2+il2-1))
write(leg1,104) (res_dat(i_dqh+i-1),i=1,3)
write(leg2,105) res_dat(i_den),cunit(2:4)
call STRCOMPACT(leg1,is1,il1)
call STRCOMPACT(leg2,is2,il2)
call pgmtext( 'T',-3.0,0.05,0.0,leg1(is1:is1+il1-1)// ' '
& //leg2(is2:is2+il2-1))
endif
call pgsch(1.)
end
# $Log: resgraph2.f,v $
# Revision 1.10 2006/05/12 11:45:29 saroun
# problems with CR/LF conversions
#