src/resgraph2.f

Fortran project RESTRAX, source module src/resgraph2.f.

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
#