Source module last modified on Wed, 30 Mar 2005, 16:49;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#//////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X 4.1
#////
#//// Graphics output subroutines (PGPlot library required)
#////
#////
#//////////////////////////////////////////////////////////////////////
#-------------------------------------------------------------
SUBROUTINE PLOT2D(port,a,nx,ny,ndx,ndy)
# plots a gray-scale map of the array A to the viewport PORT
#-------------------------------------------------------------
implicit none
INCLUDE 'sim_grf.inc'
integer*4 nx,ny,ndx,ndy
real*4 a(ndx,ndy)
real*4 amax,cx,dx,cy,dy,tr(6)
integer*4 i,j
record/VIEWSET/ port
dx=(port.wx2-port.wx1)/nx
cx=(port.wx2+port.wx1)/nx
dy=(port.wy2-port.wy1)/ny
cy=(port.wy2+port.wy1)/ny
tr(1)=-0.5*dx+port.wx1
tr(2)=dx
tr(3)=0.
tr(4)=-0.5*dy+port.wy1
tr(5)=0.
tr(6)=dy
amax=0.
do 20 i=1,nx
do 20 j=1,ny
if (a(i,j).gt.amax) amax=a(i,j)
20 continue
call pgvport(port.dx1,port.dx2,port.dy1,port.dy2)
call pgwindow(port.wx1,port.wx2,port.wy1,port.wy2)
call pggray(a,ndx,ndy,1,nx,1,ny,amax*1.1,0.,tr)
# CALL PGBOX('ABCNST',0.0,0,'ABCNST',0.0,0)
return
end
#---------------------------------------------------------------
SUBROUTINE PLOTFRAME(port,icl,ils,zch,iax)
# plots frame, axes and titles of the viewport PORT with given
# collor index (ICL), line style (ILS) and character size (ZCH)
# If IAX=0, axes at (0,0) are not plotted.
#---------------------------------------------------------------
implicit none
INCLUDE 'sim_grf.inc'
integer*4 icl,ils,iax
real*4 zch
record/VIEWSET/ port
call pgsch(zch)
call pgvport(port.dx1,port.dx2,port.dy1,port.dy2)
call pgwindow(port.wx1,port.wx2,port.wy1,port.wy2)
call pgsci(icl)
call pgsls(ils)
if(iax.eq.0) then
call pgbox( 'BCNST',0.0,0, 'BCNST',0.0,0)
else
call pgbox( 'ABCNST',0.0,0, 'ABCNST',0.0,0)
endif
call pglab(port.xtit,port.ytit,port.head)
call pgsch(1.0)
return
end
#-------------------------------------------------
SUBROUTINE INITGRF(iq)
# Initialization of the PGPlot graphics device.
# IQ=0 ... output to the current device
# IQ=1 ... output to the PostScript file "out.ps"
# IQ=2 ... prompts for another output device
#-------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*64 dst
integer pgbegin
integer*4 iq,idevstr
# IF(DST(1:5).NE.'/NULL')
dst=devstr
if(iq.eq.2) dst= '? '
if(iq.eq.1) dst= '"out.ps"/vps'
if(iq.eq.3) dst= '/NULL'
201 if (pgbegin(0,dst,1,1).ne.1) then
write(6,*) 'graphics error (PGBEGIN)'
dst= '? '
goto 201
end if
call pgpage(0.0,1.0)
call pgslw(2)
if(iq.ne.1) call pgqinf( 'DEV/TYPE',devstr,idevstr)
return
end
#------------------------------------------------------------
SUBROUTINE FILARRAY(port,iarr,aima,nimx,nimy,nm,tm)
# Fills array AIMA by events stored in the array EVA
# (handled by the subroutine EVARRAY).
# If NM<>0, events are transformed by matrix TM.
# If NM<0,transposed matrix TM is used.
# Range of the x,y coordinates is taken from the viewport
# parameters, stored in the record PORT.
#------------------------------------------------------------
implicit none
INCLUDE 'sim_grf.inc'
integer*4 iarr,nimx,nimy,nm
real*4 aima(nimx,nimy)
real*8 imx0,imy0,dimx,dimy,ex,ey,z,p
real*8 tm(4,4),e(4),e1(4),f(4)
record /VIEWSET/ port
integer*4 i4,ncnt,icnt,ix,iy,j,k,jx,jy
1 format(a20,4(2x,e12.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
do 131 j=1,nimx
do 131 k=1,nimy
aima(j,k)=0
131 continue
call EVARRAY(3,iarr,ncnt,e,p) ! get number of events NCNT
# write(*,*) 'FILLARRAY : ',ncnt
icnt=0
if (ncnt.gt.0) then
do 132 i4=1,ncnt
if (nm.ne.0) then
call EVARRAY(2,iarr,i4,e1,p) ! get event coor. E1(4) and P
call MXV(nm,4,4,tm,e1,e)
else
call EVARRAY(2,iarr,i4,e,p)
if(iarr.eq.1) call EVARRAY(2,0,i4,f,p)
z=sqrt(f(1)**2+f(2)**2+f(3)**2)
endif
if (ix.le.4) then
ex=e(ix)
else
if(ix.eq.7) then
ex=z
else
ex=f(ix-4)/z
endif
endif
if (iy.le.4) then
ey=e(iy)
else
if(iy.eq.7) then
ey=z
else
ey=f(iy-4)/z
endif
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)+p
icnt=icnt+1
endif
# write(*,*) I4,' ',Jx,' ',jy,' ',p
# pause
132 continue
write(*,*) 'Integrated ',icnt, ' events'
endif
return
end
#------------------------------------------------------------
SUBROUTINE FILLQHKL(port,aima,nimx,nimy)
# Fills array AIMA by (Q,E) events
# (handled by the subroutine NSTORE_).
# Range of the x,y coordinates is taken from the viewport
# parameters, stored in the record PORT.
#------------------------------------------------------------
implicit none
INCLUDE 'sim_grf.inc'
integer*4 nimx,nimy
real*4 aima(nimx,nimy)
real*8 imx0,imy0,dimx,dimy
real*8 e(4),e1(4),ex,ey,pp
record /VIEWSET/ port
integer*4 i4,ncnt,icnt,i1,ialloc,ix,iy,jx,jy,j,k
real*8 mcr(4,4),mcg(4,4),mcd(4,4),mrc(4,4),mdr(4,4),mgd(4,4)
common /transm/ mcr,mcg,mcd,mrc,mdr,mgd
1 format(a20,4(2x,e12.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
do 131 j=1,nimx
do 131 k=1,nimy
aima(j,k)=0
131 continue
call NSTORE_N(i1,ncnt,ialloc)
icnt=0
if (ncnt.gt.0) then
do 132 i4=1,ncnt
call NSTORE_GETQE(i4,e1,pp,0.)
call MXV(1,4,4,mrc,e1,e)
ex=e(ix)
ey=e(iy)
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
# write(*,*) JX,JY,PP, AIMA(JX,JY)
# pause
icnt=icnt+1
endif
132 continue
write(*,*) 'Integrated ',icnt, ' events'
endif
return
end
#----------------------------------------------------------------------
SUBROUTINE PLOTOUT(ic)
# handles graphics output
#----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
integer*4 ic,ilast,idev,icom
character*40 prn_command
save ilast
character*30 dst
data ilast/0/
icom=0
idev=0 ! output to DEVSTR
if((nos.ge.2).and.(ret(2).eq.1.)) idev=1 ! print
if((nos.ge.2).and.(ret(2).eq.0.)) idev=2 ! ask for new device
# IF(IDEV.NE.1.AND.SOUT.NE.6) IDEV=3 ! NULL device
#/// Only Beam profile can be shown (X.99)
icom=-2
if(nos.gt.0.and.ret(1).eq.-3) icom=-3 ! Plot resolution function
if (ic.eq.1) icom=-4
if (ic.eq.2) icom=-5
if (ic.eq.3) icom=-6
if (ic.eq.4) icom=-7
if (ic.eq.5) icom=-8
if (idev.eq.1) icom=ilast
dst=devstr
call INITGRF(idev)
# write(*,*) ICOM,NOS,IC,IDEV,ILAST
if(icom.eq.-2) then
call DET_IMAGE
else if(icom.eq.-3) then
call RES_IMAGE
else if(icom.eq.-4) then
call SVOL_IMAGE
else if(icom.eq.-5) then
call LAMBDA_PROF
else if(icom.eq.-6) then
call PEAK_PROF(0)
else if(icom.eq.-7) then
call PEAK_PROF(1)
else if(icom.eq.-8) then
call PEAK_PROF(2)
endif
call pgend
if (idev.ne.1) ilast=icom
if (idev.eq.1) then
call getenv( 'PGPLOT_ILL_PRINT_CMD',prn_command)
call system(prn_command// 'out.ps')
endif
devstr=dst
return
end
#************************************************************************
SUBROUTINE PRINTOUT
# Prints results
#************************************************************************
implicit none
include 'const.inc'
include 'inout.inc'
nos=2
ret(2)=1.
call PLOTOUT(0)
end
#----------------------------------------
SUBROUTINE DET_IMAGE
#----------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'sim_grf.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
real*4 aima(mimax,mimax)
record /VIEWSET/ vport
character*50 name(7)
character*1 cnum
character*50 comment
integer*4 indx,ix,iy,i_io,imin,imax,jmin,jmax,i,j
real*8 xmin,xmax,ymin,ymax,sum1,z
data indx /0/
data name/ 'X [mm]', 'Y [mm]', 'E [meV]', 'time [ms]', 'k(x)/k ',
1 'k(y)/k ', 'k [A-1]'/
1 format( ' (1) X '/ ' (2) Y'/ ' (3) E'/ ' (4) time'/ ' (5-7) k(x,y,z)')
2 format( ' type of the axes X,Y: ',$)
3 format( ' range ',a20, ' +- ',$)
4 format(1x,4(2x,e13.5))
5 format(1x,4(2x,a10,3x), ' integral=',e12.6)
6 format(1x,3(2x,a10,3x), ' integral=',e12.6)
7 format(2x,f10.3)
8 format(i1)
9 format(64(1x,g10.4))
10 format( 'Beam Profile ')
11 format( ' comment: ',$)
12 format(a50)
13 format( 'scale (',g12.5, ',',g12.5, ',',g12.5, ',',g12.5, ')')
name(3)= 'E '//cunit
write(sout,1)
write(sout,2)
read(sinp,*) ix,iy
if(sout.ne.6) write(sout,*) ix,iy
write(sout,3) name(ix)(1:20)
read(sinp,*) xmax
if(sout.ne.6) write(sout,7) xmax
write(sout,3) name(iy)(1:20)
read(sinp,*) ymax
if(sout.ne.6) write(sout,7) ymax
write(*,*)
write(sout,11)
read(sinp,12) comment
xmin=-xmax
ymin=-ymax
vport.wx1=xmin
vport.wx2=xmax
vport.wy1=ymin
vport.wy2=ymax
if(ix.eq.7) then
vport.wx1=vport.wx1+stp.ki
vport.wx2=vport.wx2+stp.ki
else if(iy.eq.7) then
vport.wy1=vport.wy1+stp.ki
vport.wy2=vport.wy2+stp.ki
endif
vport.dx1=0.15
vport.dx2=0.93
vport.dy1=0.31
vport.dy2=0.89
vport.ix=ix
vport.iy=iy
vport.xtit=name(ix)
vport.ytit=name(iy)
write(vport.head,9)
call pgslw(3)
call PLOTFRAME(vport,1,1,1.5,1)
call FILARRAY(vport,1,aima,mimax,mimax,0)
call PLOT2D(vport,aima,mimax,mimax,mimax,mimax)
call PLOTFRAME(vport,1,1,1.5,1)
call pgslw(2)
call pgsch(1.3)
call pgsci(1)
call pgmtext( 'B',10.,-0.05,0.0,comment)
call pgiden
i_io=2
sum1=0.
imin=mimax
imax=1
jmin=mimax
jmax=1
do i=1,mimax
do j=1,mimax
sum1=sum1+aima(i,j)
if(aima(i,j).ne.0) then
imin=min(imin,i)
imax=max(imax,i)
jmin=min(jmin,j)
jmax=max(jmax,j)
endif
enddo
enddo
if (sum1.eq.0) sum1=1
imax=min(imax+1,mimax)
jmax=min(jmax+1,mimax)
imin=max(imin-1,1)
jmin=max(jmin-1,1)
if(indx.lt.9) then
indx=indx+1
else
indx=1
endif
write(cnum,8) indx
i_io=2
close(i_io)
open(unit=i_io,file= 'ness_2d.mat',err=999,status= 'Unknown')
write(i_io,*) 'projection ('//name(ix)(1:10)// ','//name(iy)(1:10)
write(i_io,13) xmin,xmax,ymin,ymax
do i=1,mimax
write(i_io,9) (aima(i,j)*sum/sum1,j=1,mimax)
enddo
close(i_io)
open(unit=i_io,file= 'ness_2d_'//cnum// '.dat',err=999,
1 status= 'Unknown')
write(i_io,5) name(ix)(1:10),name(iy)(1:10), 'Events ',
1 'Intensity',sum
do i=imin,imax
do j=jmin,jmax
write(i_io,4) (i-0.5-mimax/2)*(xmax-xmin)/mimax,
1 (j-0.5-mimax/2)*(ymax-ymin)/mimax,
2 aima(i,j),aima(i,j)*sum/sum1
enddo
enddo
close(i_io)
open(unit=i_io,file= 'ness_x_'//cnum// '.dat',err=999,
1 status= 'Unknown')
write(i_io,6) name(ix)(1:10), 'Events ', 'Intensity ',sum
do i=1,mimax
z=0.
do j=1,mimax
z=z+aima(i,j)
end do
write(i_io,4) (i-0.5-mimax/2)*(xmax-xmin)/mimax,z,z*sum/sum1
enddo
close(i_io)
open(unit=i_io,file= 'ness_y_'//cnum// '.dat',err=999,
1 status= 'Unknown')
write(i_io,6) name(iy)(1:10), 'Events ', 'Intensity ',sum
do i=1,mimax
z=0.
do j=1,mimax
z=z+aima(j,i)
end do
write(i_io,4) (i-0.5-mimax/2)*(ymax-ymin)/mimax,z,z*sum/sum1
enddo
close(i_io)
return
999 write(*,*) 'Cannot open file as unit ',i_io
return
end
#XXXXXXXXXCXXXXXXXXXCXXXXXXXXXCXXXXXXXXXCXXXXXXXXXCXXXXXXXXXCXXXXXXXXXCX
#----------------------------------------
SUBROUTINE SVOL_IMAGE
#----------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'sim_grf.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 imin,imax,i,j,indx,i_io,jmin,jmax
real*4 xmax,xmin,ymax,ymin,sum1
record /VIEWSET/ vport
character*1 cnum
character*50 comment
character*50 filename
real*8 area,area1,mean(2),mat(2,2),cov(2,2),zmax,xx,yy
save indx
data indx /0/
4 format(1x,4(2x,e13.5))
8 format(i1)
9 format( 'Sample gauge area')
11 format( ' comment: ',$)
12 format(a50)
13 format( 'Gauge area [mm^2]: ',f10.4, ' spread: ',f10.4)
14 format( ' data output: ',$)
write(sout,11)
read(sinp,12) comment
write(sout,*)
xmax=sam.size(1)/2.0
ymax=sam.size(3)/2.0
xmin=-xmax
ymin=-ymax
vport.wx1=xmin
vport.wx2=xmax
vport.wy1=ymin
vport.wy2=ymax
vport.dx1=0.15
vport.dx2=0.93
vport.dy1=0.31
vport.dy2=0.89
vport.ix=1
vport.iy=2
vport.xtit= 'X [mm]'
vport.ytit= 'Y [mm]'
write(vport.head,9)
call pgslw(3)
call PLOTFRAME(vport,1,1,1.5,1)
call PLOT2D(vport,svol,mimax,mimax,mimax,mimax)
call PLOTFRAME(vport,1,1,1.5,1)
call pgslw(2)
call pgsch(1.3)
call pgsci(1)
call pgmtext( 'B',10.,-0.05,0.0,comment)
call pgiden
i_io=2
sum1=0.
imin=mimax
imax=1
jmin=mimax
jmax=1
zmax=0.
do i=1,mimax
do j=1,mimax
sum1=sum1+svol(i,j)
if(svol(i,j).ne.0) then
imin=min(imin,i)
imax=max(imax,i)
jmin=min(jmin,j)
jmax=max(jmax,j)
if(zmax.lt.svol(i,j)) zmax=svol(i,j)
endif
enddo
enddo
area=0.
do i=1,2
mean(i)=0.
do j=1,2
mat(i,j)=0.
enddo
enddo
do i=1,mimax
do j=1,mimax
area=area+svol(i,j)/zmax
xx=(i-32-0.5)*(xmax-xmin)/mimax
yy=(j-32-0.5)*(ymax-ymin)/mimax
mat(1,1)=mat(1,1)+svol(i,j)*xx**2
mat(1,2)=mat(1,2)+svol(i,j)*xx*yy
mat(2,1)=mat(1,2)
mat(2,2)=mat(2,2)+svol(i,j)*yy**2
mean(1)=mean(1)+svol(i,j)*xx
mean(2)=mean(2)+svol(i,j)*yy
enddo
enddo
do i=1,2
mean(i)=mean(i)/sum1
enddo
do i=1,2
do j=1,2
cov(i,j)=mat(i,j)/sum1-mean(i)*mean(j)
enddo
enddo
area=area*(xmax-xmin)/mimax*(ymax-ymin)/mimax
area1=2*pi*sqrt(cov(1,1)*cov(2,2)-cov(1,2)*cov(2,1))
write(sout,13) area,area1
if (sum1.eq.0) sum1=1
imax=min(imax+1,mimax)
jmax=min(jmax+1,mimax)
imin=max(imin-1,1)
jmin=max(jmin-1,1)
if(indx.lt.9) then
indx=indx+1
else
indx=1
endif
write(cnum,8) indx
write(sout,14)
read(sinp,12) filename
if(filename(1:1).eq. ' '.or.filename(1:1).eq.char(0)) return ! dont save
open(unit=i_io,file=filename,err=999,status= 'Unknown')
write(i_io,*) 'X [mm] Y [mm] Intensity ',comment
do i=imin,imax
do j=jmin,jmax
write(i_io,4) (i-0.5-mimax/2)*(xmax-xmin)/mimax,
1 (j-0.5-mimax/2)*(ymax-ymin)/mimax,
2 svol(i,j)*mimax*mimax/sum1
enddo
enddo
close(i_io)
return
999 write(*,*) 'Cannot open file as unit ',i_io
return
end
#----------------------------------------
SUBROUTINE LAMBDA_PROF
#----------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'sim_grf.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 i,j,indx,i_io,ncnt
real*4 xmax,xmin,ymax,ymin,lam,y0(64),y1(64),y2(64)
record /VIEWSET/ vport
character*50 comment
character*50 filename
real*4 fx(64),fy(64),dfy(64),fy1(64),fy2(64)
real*8 xyet(4),ks(4),p,dx,sum0,sum1
save indx
data indx /0/
4 format(1x,4(2x,e13.5))
8 format(i1)
9 format( 'Wavelength distribution')
11 format( ' comment: ',$)
12 format(a50)
13 format( ' data output: ',$)
call EVARRAY(3,0,ncnt,xyet,p) ! get number of events NCNT
if (ncnt.gt.0) then
comment= ' '
write(sout,11)
read(sinp,12) comment
xmax=sam.size(1)/2.0
xmin=-xmax
dx=(xmax-xmin)/64
do i=1,64
fx(i)=xmin+(i-1+0.5)*dx
enddo
do j=1,64
y0(j)=0.
y1(j)=0.
y2(j)=0.
enddo
sum0=0.
sum1=0.
ymin=1.e+30
ymax=-1.e+30
do i=1,ncnt
call EVARRAY(2,1,i,xyet,p)
call EVARRAY(2,0,i,ks,p)
lam=2*pi*(1./sqrt(ks(1)**2+ks(2)**2+ks(3)**2)-
* 1./stp.ki)
if(ymax.le.lam) ymax=lam
if(ymin.ge.lam) ymin=lam
j=int((xyet(1)-xmin)/dx)+1
if (j.ge.1.and.j.le.64) then
y0(j)=y0(j)+p
y1(j)=y1(j)+p*lam
sum1=sum1+p*lam
sum0=sum0+p
y2(j)=y2(j)+p*lam**2
endif
enddo
ymin=ymin-sum1/sum0
ymax=ymax-sum1/sum0
do i=1,64
if (y0(i).gt.0) then
fy(i)=y1(i)/y0(i)
dfy(i)=y2(i)/y0(i)-fy(i)**2
if(dfy(i).le.1e-8) then
dfy(i)=0.
else
dfy(i)=sqrt(dfy(i))
endif
fy1(i)=fy(i)-dfy(i)
fy2(i)=fy(i)+dfy(i)
else
fy(i)=0.
dfy(i)=0.
fy1(i)=0.
fy2(i)=0.
endif
enddo
vport.wx1=xmin
vport.wx2=xmax
vport.wy1=ymin
vport.wy2=ymax
vport.dx1=0.15
vport.dx2=0.93
vport.dy1=0.40
vport.dy2=0.89
vport.ix=1
vport.iy=2
vport.xtit= 'X [mm]'
vport.ytit= '\gD\gl [A]'
write(vport.head,9)
call pgslw(3)
call PLOTFRAME(vport,1,1,1.5,1)
call pgsci(4)
call pgsls(1)
call pgslw(2)
call pgerry(64,fx,fy1,fy2,0.0)
call pgline(64,fx,fy)
call pgpoint(64,fx,fy,17)
call pgslw(2)
call pgsch(1.3)
call pgsci(1)
call pgmtext( 'B',10.,-0.05,0.0,comment)
call pgiden
i_io=2
write(sout,13)
read(sinp,12) filename
if(filename(1:1).eq. ' '.or.filename(1:1).eq.char(0)) return ! dont save
open(unit=i_io,file=filename,err=999,status= 'Unknown')
write(i_io,*) comment
write(i_io,*) 'X [mm] Lam [A] dLam [A] '
do i=1,64
write(i_io,4) fx(i),fy(i),dfy(i)
enddo
close(i_io)
endif
return
999 write(*,*) 'Cannot open file as unit ',i_io
return
end
#-----------------------------------------------
SUBROUTINE PEAK_PROF(ivar)
# IVAR=0 ... Spatial profile at the PSD
# IVAR=1 ... Powder peak profile (on angular scale)
# IVAR=2 ... peak profile accumulated in SPCX,Y,D arrays
#------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'sim_grf.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 mf
parameter (mf=65)
integer*4 i,indx,i_io,ivar,nf
real*4 ymax
record /VIEWSET/ vport
character*55 comment
character*50 filename
real*4 fx(mf),fy(mf),dfy(mf),fy1(mf),fy2(mf)
real*8 suma,center,fwhm,wspread
real*4 par(3),dpar(3),CHI2SPC,tol
external CHI2SPC
save indx
data indx /0/
4 format(1x,4(2x,e13.5))
5 format( 'Integral: ',e13.5, ' ',a50)
8 format(i1)
9 format( 'Profile at the PSD')
10 format( 'Powder peak profile')
11 format( ' comment: ',$)
12 format(a50)
13 format( ' data output: ',$)
14 format( 'fwhm: ',g10.4, 'spread: ',g10.4, 'center: ',g10.4)
comment= ' '
nf=mf
if (ivar.ne.2) then
write(sout,11)
read(sinp,12) comment
endif
if (ivar.eq.0) then
call PSD_ARRAY(fx,fy,dfy,nf)
else if (ivar.eq.1) then
call THETA_SCAN(fx,fy,dfy,nf)
else if (ivar.eq.2) then
nf=spcn
do i=1,spcn
fx(i)=spcx(i)
fy(i)=spcy(i)
dfy(i)=spcd(i)
enddo
# write(*,*) 'PEAK_PROF: ',SPCN,SPCY(SPCN/2)
call GETPEAKPARAM(3,suma,center,fwhm,wspread)
write(comment,14) fwhm,wspread,center
endif
ymax=0.
do i=1,nf
fy1(i)=fy(i)-dfy(i)
fy2(i)=fy(i)+dfy(i)
if(ymax.le.fy(i)) ymax=fy(i)
enddo
vport.wx1=fx(1)
vport.wx2=fx(nf)
vport.wy1=0.
vport.wy2=ymax*1.1
vport.dx1=0.15
vport.dx2=0.93
vport.dy1=0.40
vport.dy2=0.89
vport.ix=1
vport.iy=2
if (ivar.eq.0) then
vport.xtit= 'X [mm]'
vport.ytit= 'Intensity'
write(vport.head,9)
else if (ivar.eq.1) then
vport.xtit= '\gD\gf [min]'
vport.ytit= 'Intensity'
write(vport.head,10)
else
vport.xtit= 'X'
vport.ytit= 'Y'
vport.head= 'Peak profile'
endif
call pgslw(3)
call PLOTFRAME(vport,1,1,1.5,0)
call pgsci(3)
call pgsls(1)
call pgslw(2)
call pgerry(nf,fx,fy1,fy2,0.0)
call pgline(nf,fx,fy)
call pgpoint(nf,fx,fy,17)
if (ivar.eq.2.and.fwhm.gt.0) then
par(1)=ymax
par(2)=center
par(3)=wspread
# write(*,*) PAR(1),PAR(2),PAR(3)
do i=1,3
dpar(i)=0.
enddo
tol=0.01
call LMOPT(CHI2SPC,par,3,tol,dpar,2)
# write(*,*) PAR(1),PAR(2),PAR(3)
if(abs(par(3)).gt.1e-10) then
do i=1,nf
fy1(i)=par(1)*exp(-0.5*(fx(i)-par(2))**2/
* (par(3)/r8ln2)**2)
enddo
call pgsci(2)
call pgline(nf,fx,fy1)
endif
endif
call pgslw(2)
call pgsch(1.3)
call pgsci(1)
call pgmtext( 'B',10.,-0.05,0.0,comment)
call pgiden
i_io=22
filename= ' '
write(sout,13)
read(sinp,12) filename
if(filename(1:1).eq. ' '.or.filename(1:1).eq.char(0)) then ! generate automatic filename
return
else
open(unit=i_io,file=filename,err=999,status= 'Unknown')
write(i_io,5) ipwd,comment
if (ivar.eq.0) then
write(i_io,*) 'X [mm] I dI '
else if (ivar.eq.1) then
write(i_io,*) 'd2Theta I dI '
endif
do i=1,nf
write(i_io,4) fx(i),fy(i),dfy(i)
enddo
close(i_io)
endif
return
999 write(*,*) 'Cannot open file as unit ',i_io
return
end
#----------------------------------------
SUBROUTINE RES_IMAGE
#----------------------------------------
implicit none
include 'const.inc'
include 'inout.inc'
INCLUDE 'sim_grf.inc'
INCLUDE 'rescal.inc'
real aima(mimax,mimax)
record /VIEWSET/ vport
character*32 name(4),name1(4)
character*50 leg1,leg2,comment
integer*4 indx,i_io,ix,iy,i,j
real*4 xmax,xmin,ymax,ymin,sum,zmax
# COMMON DUM1(30),Q(3),EN,D(3),DE,G(3),GMOD,DUM2(6)
save indx
data indx /0/
# DATA name/'\gDQx [1/A]','\gDQy [1/A]','\gDQz [1/A]','\gDE [meV]'/
# DATA name1/'Qx [1/A]','Qy [1/A]','Qz [1/A]','dE [meV]'/
# DATA name/'\gDh ','\gDk ','\gDl ','\gDE [meV]'/
data name/ '(\gc 0 0)', '(0 \gc 0)', '(0 0 \gc)', '\gDE [meV]'/
data name1/ 'h ', 'k ', 'k ', 'dE [meV]'/
3 format( ' range ',a20, ' +- ',$)
4 format(1x,4(2x,e13.5))
5 format(1x,4(2x,a10,3x))
6 format(1x,3(2x,a15,3x))
7 format(2x,f10.3)
8 format(i1)
9 format(64(1x,g10.4))
#1 FORMAT(' (1) Qx '/' (2) Qy'/' (3) Qz'/' (4) E')
1 format( ' (1) h '/ ' (2) k'/ ' (3) l'/ ' (4) E')
2 format( ' which projection (X,Y): ',$)
11 format( ' comment: ',$)
12 format(a50)
13 format( 'scale (',g12.5, ',',g12.5, ',',g12.5, ',',g12.5, ')')
80 write(sout,1)
write(sout,2)
read(sinp,*,err=80) ix,iy
if (ix.lt.0.or.ix.gt.4.or.iy.lt.0.or.iy.gt.4) then
goto 80
endif
write(sout,3) name1(ix)(1:20)
read(sinp,*) xmax
if(sout.ne.6) write(sout,7) xmax
write(sout,3) name1(iy)(1:20)
read(sinp,*) ymax
if(sout.ne.6) write(sout,7) ymax
comment= ' '
write(sout,11)
read(sinp,12) comment
write(*,*)
101 format( '\gD\gc [',f6.2, ' ',f6.2, ' ',f6.2, '] / r.l.u.')
102 format( 'Q\dhkl\u = [',f7.3, ' ',f7.3, ' ',f7.3, ']')
103 format( 'E = ',f7.2, ' ',a3)
104 format( 'QE = [',4(g12.5,1x), ']')
write(leg1,102) qhkl
write(leg2,103) res_dat(i_en),cunit
# CALL QNORM(G,GNR,GNA)
# ZRA=GNR/GNA
# DO 10 i=1,4
# DO 10 j=1,4
# MCN(i,j)=MCG(i,j)
# if(j.eq.1) MCN(i,j)=MCN(i,j)*ZRA
#10 CONTINUE
# CALL FILARRAY(VPORT,0,AIMA,MIMAX,MIMAX,-1,MCN)
# WRITE(VPORT.XTIT,101) G
vport.head= 'Projection of R(Q,E) [r.l.u]'
xmin=-xmax
ymin=-ymax
vport.wx1=xmin
vport.wx2=xmax
vport.wy1=ymin
vport.wy2=ymax
vport.dx1=0.15
vport.dx2=0.93
vport.dy1=0.31
vport.dy2=0.89
vport.ix=ix
vport.iy=iy
vport.xtit=name(ix)
vport.ytit=name(iy)
call pgslw(2)
call pgsch(1.5)
call PLOTFRAME(vport,1,1,1.5,0)
call FILLQHKL(vport,aima,mimax,mimax)
sum=0.
zmax=0
do i=1,mimax
do j=1,mimax
sum=sum+aima(i,j)
# write(*,*) i,j,aima(i,j),sum
# pause
if(aima(i,j).gt.zmax) zmax=aima(i,j)
enddo
enddo
# write(*,*) 'Plot resol: ',sum,zmax
if (sum.le.0) then
return
endif
do i=1,mimax
do j=1,mimax
aima(i,j)=aima(i,j)/sum*mimax**2
enddo
enddo
call PLOT2D(vport,aima,mimax,mimax,mimax,mimax)
call PLOTFRAME(vport,1,1,1.5,0)
call pgmtext( 'T',-1.5,0.025,0.0,leg1(1:36)// ' ; '//leg2)
call pgslw(2)
call pgsch(1.3)
call pgsci(1)
call pgmtext( 'B',10.,-0.05,0.0,comment)
call pgiden
i_io=2
close(i_io)
open(unit=i_io,file= 'ness_2d.mat',err=999,status= 'Unknown')
write(i_io,*) 'projection ('//name1(ix)(1:10)// ','//name1(iy)(1:10)
write(i_io,13) xmin,xmax,ymin,ymax
write(i_io,104) (res_dat(i_qh+i-1),i=1,4)
do j=1,mimax
write(i_io,9) (aima(i,j),i=1,mimax)
enddo
close(i_io)
return
999 write(*,*) 'Cannot open file as unit ',i_io
return
end