       subroutine displayr ( lunit, array, iar, jar
     1                     , ibeg, iend, jbeg, jend, clab, ctitle )
c
c    dac:zeus3d.displayr <----------- displays portion of 2-D real array
c                                                          october, 1990
c
c    written by: David Clarke
c    modified 1:
c
c  PURPOSE:  This subroutine writes to "lunit" the specified portion of
c  the specified real array "array".  The difference between "iend" and
c  "ibeg" should not be greater than 38.
c
c  INPUT VARIABLES:
c    lunit       logical unit to which display is sent
c    array       2-D real array to display
c    iar,jar     dimensions of "array"
c    ibeg,iend   range in "i" to be displayed
c    jbeg,jend   range in "j" to be displayed
c    clab        character string to label axes
c    ctitle      character string to head data
c
c  OUTPUT VARIABLES: NONE
c
c  LOCAL VARIABLES:
c
c  EXTERNALS: [NONE]
c
c-----------------------------------------------------------------------
c
c
c-----------------------------------------------------------------------
c------------------------ IMPLICIT STATEMENTS --------------------------
c-----------------------------------------------------------------------
c
       implicit      none
c
c-----------------------------------------------------------------------
c----------------------------- PARAMETERS ------------------------------
c-----------------------------------------------------------------------
c
c      Primary parameters:
c
       integer       in      , jn      , kn      , ijkn    , nxpx
     1             , nypx    , nxrd    , nyrd    , niov    , nios
     2             , ntsl    , mn      , nmd     , isig
       real*8        pi  , tiny  , huge  , one  , mone  , haf  , zro
c
       parameter     ( in = 5005, jn = 1, kn = 10, ijkn = 5005)
       parameter     ( nxpx = 1, nypx = 1, nxrd =   1, nyrd =   1 )
       parameter     ( niov =  20, nios =  20, ntsl =1000 )
       parameter     ( mn   =   1, nmd  =   1 )
       parameter     ( pi   = 3.1415926535898 )
       parameter     ( isig = 9, tiny = 1.0d-99, huge = 1.0d+99 )
       parameter     ( one  = 1.0d+00, mone = -1.0d+00
     1                               , haf  =  0.5d+00, zro = 0.0d+00)
c
c      Secondary parameters:
c
       integer        idim    , jdim
     1              , nt01    , nt02    , nt03    , nt04    , nt05
     2              , nt06    , nt07    , nt08    , nt09    , nt10
     3              , nt11    , nt12    , nt13    , nt14    , nt15
     4              , nt16    , nt17    , nt18    , nt19    , nt20
       parameter     ( idim =   kn, jdim =   in )
       parameter     ( nt01 = 600, nt02 = 600, nt03 =   7, nt04 =   5 )
       parameter     ( nt05 =  18, nt06 =   1, nt07 =  10, nt08 =  12 )
       parameter     ( nt09 =   5, nt10 =  54, nt11 =   8 )
       parameter     ( nt12 =        16, nt17 =         4 )
       parameter     ( nt13 = nt12 +  4, nt18 = nt17 +  1 )
       parameter     ( nt14 = nt13     , nt19 = nt18      )
       parameter     ( nt15 = nt14 + 30, nt20 = nt19 +  3 )
       parameter     ( nt16 = nt14 + 42 )
c
c-----------------------------------------------------------------------
c-------------------- SCRATCH SPACE (WORKER ARRAYS) --------------------
c-----------------------------------------------------------------------
c
c      1-D worker arrays
c
       real*8        wa1d    (ijkn), wb1d    (ijkn), wc1d    (ijkn)
     1             , wd1d    (ijkn), we1d    (ijkn), wf1d    (ijkn)
     2             , wg1d    (ijkn), wh1d    (ijkn), wi1d    (ijkn)
     3             , wj1d    (ijkn), wk1d    (ijkn), wl1d    (ijkn)
     4             , wm1d    (ijkn), wn1d    (ijkn), wo1d    (ijkn)
     5             , wp1d    (ijkn), wq1d    (ijkn), wr1d    (ijkn)
     6             , ws1d    (ijkn), wt1d    (ijkn), wu1d    (ijkn)
     7             , wv1d    (ijkn), ww1d    (ijkn), wx1d    (ijkn)
     8             , wy1d    (ijkn), wz1d    (ijkn)
c
c      2-D worker arrays
c
       real*8        wa2d    (idim,jdim), wa2dt   (jdim,idim)
     1             , wb2d    (idim,jdim), wb2dt   (jdim,idim)
     1             , wc2d    (idim,jdim), wc2dt   (jdim,idim)
     2             , wd2d    (idim,jdim), wd2dt   (jdim,idim)
     1             , we2d    (idim,jdim), we2dt   (jdim,idim)
     2             , wf2d    (idim,jdim), wf2dt   (jdim,idim)
c
c      3-D worker arrays
c
       real*8        wa3d    (  in,  jn,  kn), wb3d    (  in,  jn,  kn)
     1             , wc3d    (  in,  jn,  kn), wd3d    (  in,  jn,  kn)
     2             , we3d    (  in,  jn,  kn), wf3d    (  in,  jn,  kn)
     3             , wg3d    (  in,  jn,  kn)
c
       equivalence   ( wa2d    , wa2dt    ), ( wb2d    , wb2dt    )
     1             , ( wc2d    , wc2dt    ), ( wd2d    , wd2dt    )
     2             , ( we2d    , we2dt    ), ( wf2d    , wf2dt    )
       equivalence   ( wa3d    , wa2d     ), ( wb3d    , wb2d     )
     1             , ( wc3d    , wc2d     ), ( wd3d    , wd2d     )
     2             , ( we3d    , we2d     ), ( wf3d    , wf2d     )
c
c---------------------------- Common Blocks ----------------------------
c
       common / scratchr /
     1               wa1d    , wb1d    , wc1d    , wd1d    , we1d
     2             , wf1d    , wg1d    , wh1d    , wi1d    , wj1d
     3             , wk1d    , wl1d    , wm1d    , wn1d    , wo1d
     4             , wp1d    , wq1d    , wr1d    , ws1d    , wt1d
     5             , wu1d    , wv1d    , ww1d    , wx1d    , wy1d
     6             , wz1d
       common / scratchr /
     1               wa3d    , wb3d    , wc3d    , wd3d    , we3d
     2             , wf3d
     3             , wg3d
c
       character*(*) clab    , ctitle
       integer       lunit   , iar     , jar     , ibeg    , iend
     1             , jbeg    , jend    , i       , j       , iran
     1             , i1      , i2      , imax
       real*8        armax   , armaxt  , armin   , q1      , q2
     1             , qmax
c
       integer       ilab    (ijkn), jlab    (ijkn), dummy   (ijkn)
c
       real*8        array   ( iar, jar)
c
cRAF       equivalence   ( ilab    , wx1d     ), ( jlab    , wy1d     )
cRAF     1             , ( dummy   , wz1d     )
c
c-----------------------------------------------------------------------
c
c      Write "ctitle" to "lunit"
c
       write (lunit, 2010) ctitle
c
c      Set limits for i-sweep
c
       iran =  min ( 38, iend - ibeg + 1 )
       i1   = ibeg
       i2   = ibeg + iran - 1
c
c      Set axis labels
c
       do 10 i=i1,i2
         ilab(i) = i
10     continue
       do 20 j=jbeg,jend
         jlab(j) = j
20     continue
c
c      Find extrema of array "array"
c
       armin = huge
       armax =-armin
       do 40 j=jbeg,jend
         do 30 i=i1,i2
           armax =   max ( armax, array(i,j) )
           armin =   min ( armin, array(i,j) )
30       continue
40     continue
       if (armax .lt. abs(armin)) armax = armin
       armaxt = armax
       if (armax .eq. 0.0) armax = 1.0
c
c      Display array "array" depending on "iran".
c
       if (iran .ge. 20) then
         qmax = 99.0
         q1   = 0.499
       endif
       if ( (iran .ge. 16) .and. (iran .le. 19) ) then
         qmax = 999.0
         q1   = 0.4999
       endif
       if ( (iran .ge. 13) .and. (iran .le. 15) ) then
         qmax = 9999.0
         q1   = 0.49999
       endif
       if ( (iran .ge. 11) .and. (iran .le. 12) ) then
         qmax = 99999.0
         q1   = 0.499999
       endif
       if ( (iran .ge.  9) .and. (iran .le. 10) ) then
         qmax = 999999.0
         q1   = 0.4999999
       endif
       do 60 j=jend,jbeg,-1
         if (iran .ge. 9) then
           do 50 i=i1,i2
             q2       = qmax * array(i,j) / armax
             dummy(i) =  int ( q2 + sign ( q1, q2 ) )
50         continue
           if (iran .ge. 26)
     1       write (lunit, 2020) jlab(j), (dummy(i),i=i1,i2)
           if ( (iran .ge. 20) .and. (iran .le. 25) )
     1       write (lunit, 2030) jlab(j), (dummy(i),i=i1,i2)
           if ( (iran .ge. 16) .and. (iran .le. 19) )
     1       write (lunit, 2040) jlab(j), (dummy(i),i=i1,i2)
           if ( (iran .ge. 13) .and. (iran .le. 15) )
     1       write (lunit, 2050) jlab(j), (dummy(i),i=i1,i2)
           if ( (iran .ge. 11) .and. (iran .le. 12) )
     1       write (lunit, 2060) jlab(j), (dummy(i),i=i1,i2)
           if ( (iran .ge.  9) .and. (iran .le. 10) )
     1       write (lunit, 2070) jlab(j), (dummy(i),i=i1,i2)
         endif
         if (iran .eq. 8)
     1     write (lunit, 2080) jlab(j), (array(i,j),i=i1,i2)
         if (iran .le. 7)
     1     write (lunit, 2090) jlab(j), (array(i,j),i=i1,i2)
60     continue
c
c      Label horizontal axis
c
       if (iran .ge. 26)
     1   write (lunit, 2100) clab, (ilab(i),i=i1,i2)
       if ( (iran .ge. 20) .and. (iran .le. 25) )
     1   write (lunit, 2110) clab, (ilab(i),i=i1,i2)
       if ( (iran .ge. 16) .and. (iran .le. 19) )
     1   write (lunit, 2120) clab, (ilab(i),i=i1,i2)
       if ( (iran .ge. 13) .and. (iran .le. 15) )
     1   write (lunit, 2130) clab, (ilab(i),i=i1,i2)
       if ( (iran .ge. 11) .and. (iran .le. 12) )
     1   write (lunit, 2140) clab, (ilab(i),i=i1,i2)
       if ( (iran .ge.  9) .and. (iran .le. 10) )
     1   write (lunit, 2150) clab, (ilab(i),i=i1,i2)
       if (iran .eq. 8)
     1   write (lunit, 2160) clab, (ilab(i),i=i1,i2)
       if (iran .le. 7)
     1   write (lunit, 2170) clab, (ilab(i),i=i1,i2)
c
c      Indicate scale of displayed data.
c
       imax =  int ( qmax + 0.1 )
       if (iran .ge. 9) write (lunit, 2180) imax, armaxt
       if (iran .lt. 9) write (lunit, 2190)
c
c-----------------------------------------------------------------------
c----------------------- Write format statements -----------------------
c-----------------------------------------------------------------------
c
2010   format('DISPLAYR:',/,'DISPLAYR: ',a)
2020   format(i3,1x,38i2)
2030   format(i3,1x,25i3)
2040   format(i3,1x,19i4)
2050   format(i3,1x,15i5)
2060   format(i3,1x,12i6)
2070   format(i3,1x,10i7)
2080   format(i3,1x,1p8g9.2)
2090   format(i3,1x,1p7g10.3)
2100   format(a3,1x,38i2)
2110   format(a3,1x,25i3)
2120   format(a3,1x,19i4)
2130   format(a3,1x,15i5)
2140   format(a3,1x,12i6)
2150   format(a3,1x,10i7)
2160   format(a3,1x,8i9)
2170   format(a3,1x,7i10)
2180   format('DISPLAYR: Data scaled so that a display of ',i6
     1       ,' corresponds to ',1pg12.5)
2190   format('DISPLAYR: Data are not scaled.')
c
       return
       end
