src/sim_grf.f

Fortran project SIMRES, source module src/sim_grf.f.

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