!-----------------------------------------------------------------------
! Support file for command PERSPECTIVE
!-----------------------------------------------------------------------
module greg_hautbas
  !---------------------------------------------------------------------
  ! Support module
  !---------------------------------------------------------------------
  logical :: lower      ! /LOWER is present
  logical :: vert_flag  ! /VERTICAL is present
end module greg_hautbas
!
module greg_nxtv1
  integer, parameter :: nn=3000
  integer :: kk,ll
  real :: xx(nn),yy(nn)
end module greg_nxtv1
!
subroutine threed (line,error)
  use gildas_def
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>threed
  use greg_axes
  use greg_hautbas
  use greg_kernel
  use greg_rg
  !---------------------------------------------------------------------
  ! @ private
  ! GREG Support routine for command
  !
  ! PERSPECTIVE [Altitude Azimuth]
  ! 1           [/FACTOR factor offset]
  ! 2           [/LOWER]
  ! 3           [/LINES]
  ! 4           [/STEP nx ny]
  ! 5           [/AXES Xmin Xmax Ymin Ymax]
  ! 6           [/CENTER]
  ! 7           [/VERTICAL Vmin Vmax]
  !
  ! 3D perspective plot, define the projective transformation
  !
  ! ALTitude      : degrees
  ! AZImuth       : degrees
  ! XLEN and YLEN : Length of X and Y axes (cf SET LOCATION)
  ! XOFF and YOFF : Origin position
  ! ZFACtor       : Conversion factor from Z to physical units
  ! ZOFF          : Origine offset along Z (physical units)
  !---------------------------------------------------------------------
  character(len=*) :: line          ! Command line               Input
  logical :: error                  ! Logical error flag         Output
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='PERSPECTIVE'
  integer :: l
  real*4 :: xlen,ylen,xoff,yoff,alt,az,goff,azi
  real*4 :: zfac,zoff,gxo1,gxo2,gyo1,gyo2,factor
  real*4 :: wsize,aaz,yoffset
  integer :: ier,nqx,nqy,nstx,nsty,ix1,ix2,ix3,iy1,iy2,iy3
  real(kind=4), pointer :: swdata(:,:)
  real(kind=4), allocatable :: xwork(:),ywork(:)
  real(kind=4), allocatable :: zdata(:,:)
  logical :: doswap
  real :: blnk3d,rcblank,reblank
  !
  save alt,az,factor,goff
  ! Data
  data alt /30./, az/45./, factor/1./, goff/0./
  ! Code
  ! Check whether one can do something
  if (rg%status.eq.code_pointer_null) then
    call greg_message(seve%e,rname,'No map loaded')
    error = .true.
    return
  endif
  ! Get a R4 blanking value
  rcblank = cblank
  reblank = eblank
  !
  ! Define size approximately the one of box
  wsize = 0.8
  goff  = 0.0
  !
  ! Set up parameters
  lower = sic_present(2,0)
  vert_flag = sic_present(7,0)
  call sic_r4 (line,0,1,alt,.false.,error)
  if (error) return
  call sic_r4 (line,0,2,az,.false.,error)
  if (error) return
  call sic_r4 (line,1,1,factor,.false.,error)
  if (error) return
  call sic_r4 (line,1,2,goff,.false.,error)
  if (error) return
  !
  ! If /CENTER option, change size for a square box
  if (sic_present(6,0)) then
    aaz = abs(az)
    if (aaz.le.45) then
      wsize=(1.5+0.1*exp(-aaz))/2.5
    elseif (aaz.le.135) then
      wsize=(1.5+0.1*exp(-abs(aaz-90.)))/2.5
    elseif (aaz.le.225) then
      wsize=(1.5+0.1*exp(-abs(aaz-180.)))/2.5
    elseif (aaz.le.315) then
      wsize=(1.5+0.1*exp(-abs(aaz-270.0)))/2.5
    endif
    ! Change offset also
    yoffset=((90.0-abs(alt))/20.)*(gy2-gy1)/20.0
    if (abs(alt).le.90.0) then
      goff=goff-yoffset
    elseif (abs(alt).le.180.0) then
      goff=goff+yoffset
    endif
  endif
  xlen = wsize*(gx2-gx1)
  ylen = wsize*(gy2-gy1)
  !
  ! Compute Z scaling factor
  if (.not.sic_present(7,2)) then
    call rgextr (0,zmin,zmax,rg%data,rcblank,reblank,.false.)
  endif
  if (vert_flag) then
    call sic_r4 (line,7,1,zmin,.false.,error)
    if (error) return
    call sic_r4 (line,7,2,zmax,.false.,error)
    if (error) return
  endif
  if (zmax-zmin.gt.0.0) then
    zfac = ylen*factor/(zmax-zmin)/1.5
  else
    zfac = 1.0
  endif
  zoff = -zmin
  !
  ! Axis bounds
  xl1=rg%xval+(1.0d0-rg%xref)*rg%xinc   ! Pas 0.5 comme dans RGMAP ?
  xl2=rg%xval+(rg%nx-rg%xref)*rg%xinc      ! Pas NX+0.5 comme dans RGMAP ?
  yl2=rg%yval+(1.0d0-rg%yref)*rg%yinc
  yl1=rg%yval+(rg%ny-rg%yref)*rg%yinc
  ! Plot axe information. Logical DOAXES used elsewhere, not here.
  if (sic_present(5,0)) then
    call sic_r4 (line,5,1,xl1,.false.,error)
    if (error) return
    call sic_r4 (line,5,2,xl2,.false.,error)
    if (error) return
    call sic_r4 (line,5,4,yl1,.false.,error)
    if (error) return
    call sic_r4 (line,5,3,yl2,.false.,error)
    if (error) return
  endif
  !
  if (.not.sic_present(3,0)) then
    ! No /LINES option, use perspective with both line directions
    !
    ! Swap image if needed
    if ( (gux2-gux1)*sign(1.d0,rg%xinc).gt.0) then
      ix1 = rg%nx
      ix2 = 1
      ix3 = -1
      doswap = .true.
    else
      ix1 = 1
      ix2 = rg%nx
      ix3 = 1
      doswap = .false.
    endif
    if ( (guy2-guy1)*sign(1.d0,rg%yinc).gt.0) then
      iy1 = 1
      iy2 = rg%ny
      iy3 = 1
    else
      iy1 = rg%ny
      iy2 = 1
      iy3 = -1
      doswap = .true.
    endif
    !
    ! /STEP option : load subset of map in buffer
    if (sic_present(4,0)) then
      call sic_i4 (line,4,2,nsty,.true.,error)
      if (error) return
      call sic_i4 (line,4,1,nstx,.true.,error)
      if (error) return
      nstx = max(nstx,1)
      nsty = max(nsty,1)
      if (nstx.ge.rg%nx) then
        call greg_message(seve%e,rname,'Step in X too large')
        error = .true.
        return
      endif
      if (nsty.ge.rg%ny) then
        call greg_message(seve%e,rname,'Step in Y too large')
        error = .true.
        return
      endif
      nqx = rg%nx/nstx
      if (nqx*nstx.ne.rg%nx) nqx=nqx+1
      nqy = rg%ny/nsty
      if (nqy*nsty.ne.rg%ny) nqy=nqy+1
      ix3 = nstx*ix3
      iy3 = nsty*iy3
      doswap = .true.
    else
      nqx = rg%nx
      nqy = rg%ny
    endif
    !
    ! Get work space
    l = 2*min(nqx,nqy)+1
    allocate(xwork(l),ywork(l),stat=ier)
    if (failed_allocate(rname,'xwork and ywork buffers',ier,error))  return
    !
    ! Get swap area
    if (doswap) then
      allocate(swdata(nqx,nqy),stat=ier)
      if (failed_allocate(rname,'swdata buffer',ier,error)) then
        deallocate(xwork,ywork)
        return
      endif
      call pswap (rg%data,rg%nx,rg%ny,swdata,nqx,nqy,ix1,ix2,ix3,iy1,iy2,iy3)
    else
      swdata => rg%data
    endif
    ! use a patch for blanked values:
    blnk3d = zmin
    !
    ! Set full page clipping window for this command
    gxo1 = gx1
    gxo2 = gx2
    gyo1 = gy1
    gyo2 = gy2
    gx1  = lx1
    gx2  = lx2
    gy1  = ly1
    gy2  = ly2
    !
    ! Rotate extra 90.0 degrees
    azi = az+90.0
    !
    ! Take care of bottom view
    xoff = 0.5*(gx2+gx1)
    if (lower) then
      alt = -alt
      zfac = -zfac
      yoff = -goff-0.5*(gy2+gy1) + ly2+ly1
    else
      yoff = goff+0.5*(gy2+gy1)
    endif
    call plt3d (swdata,nqx,nqy,xwork,ywork,l,alt,azi,xlen,xoff,ylen,yoff,  &
      zfac,zoff,blnk3d,rcblank,reblank,ier)
    !
    ! Signal any error
    if (ier.ne.0) then
      error = .true.
      if (ier.eq.1) then
        call greg_message(seve%e,rname,'Internal buffer too small')
      elseif (ier.eq.2) then
        call greg_message(seve%e,rname,'Insufficient work space')
      elseif (ier.eq.-1) then
        call greg_message(seve%e,rname,'Aborted by ^C')
      else
        call greg_message(seve%e,rname,'Unknown Error')
      endif
    endif
    !
    ! Reset previous situation
    if (lower) then
      alt = -alt
      zfac = -zfac
      yoff = goff+0.5*(gy2+gy1)
    endif
    gx1  = gxo1
    gx2  = gxo2
    gy1  = gyo1
    gy2  = gyo2
    ! Plot axes After:
    doaxes = sic_present(5,0)
    if (doaxes) then
      call plt3d (swdata,nqx,nqy,xwork,ywork,l,alt,azi,xlen,xoff,ylen,yoff,  &
        zfac,zoff,blnk3d,rcblank,reblank,ier)
      doaxes=.false.
    endif
    if (doswap) then
      deallocate(swdata)
      doswap = .false.
    endif
    deallocate(xwork,ywork)
    !
  else
    ! /LINES option
    nqx  = rg%nx
    nqy  = rg%ny
    if (sic_present(2,0)) then
      call greg_message(seve%e,rname,'/LOWER not implemented for /LINES')
      error = .true.
      return
    endif
    xoff = 0.5*(gx2+gx1)
    yoff = goff+0.5*(gy2+gy1)
    gxo1 = gx1
    gxo2 = gx2
    gyo1 = gy1
    gyo2 = gy2
    gx1  = lx1
    gx2  = lx2
    gy1  = ly1
    gy2  = ly2
    allocate(zdata(nqx,nqy),stat=ier)
    if (failed_allocate(rname,'zdata buffer',ier,error))  return
    zdata(:,:) = rg%data(:,:)
    call zmont(zdata,nqx,1,nqx,1,nqy,xoff,yoff,xlen,ylen,az,alt,zfac)
    deallocate(zdata)
    gx1  = gxo1
    gx2  = gxo2
    gy1  = gyo1
    gy2  = gyo2
  endif
end subroutine threed
!
subroutine pswap (xin,nx,ny,xout,mx,my,ix1,ix2,ix3,iy1,iy2,iy3)
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real :: xin(nx,ny)                !
  integer :: mx                     !
  integer :: my                     !
  real :: xout(mx,my)               !
  integer :: ix1                    !
  integer :: ix2                    !
  integer :: ix3                    !
  integer :: iy1                    !
  integer :: iy2                    !
  integer :: iy3                    !
  ! Local
  integer :: i,j,k,l
  !
  l = 0
  do j=iy1,iy2,iy3
    l = l+1
    k = 0
    do i=ix1,ix2,ix3
      k = k+1
      xout(k,l) = xin(i,j)
    enddo
  enddo
end subroutine pswap
!
subroutine plt3d(a,m,n,x,y,l,alt,az,xlen,xoff,ylen,yoff,zfac,zoff,blnk3d,  &
  rgblank,eblank,ier)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>plt3d
  use greg_axes
  !---------------------------------------------------------------------
  ! @ private
  ! 3D plot routine, adapted from SAS-3 routine of same name
  !---------------------------------------------------------------------
  integer :: m     ! Dimensions of data array A
  integer :: n     ! Dimensions of data array A
  real :: a(m,n)   ! Array, represents height of surface as function of location in plane
  integer :: l     ! Length of work arrays, .GE. 2*MIN(M,N)
  real :: x(l)     ! Real work array
  real :: y(l)     ! Real work array
  real :: alt      ! Altitude viewing angle in degrees
  real :: az       ! Azimuth viewing angle in degrees
  real :: xlen     ! Length of unprojected X axis in plot coordinates
  real :: xoff     ! Offset of origin in plot coordinates
  real :: ylen     ! Length of unprojected Y axis in plot coordinates
  real :: yoff     ! Offset of origin in plot coordinates
  real :: zfac     ! Scaling of Z-axis from data units to unprojected plot coordinates
  real :: zoff     ! Offset of Z-origin in plot coordinates
  real :: blnk3d   !
  real :: rgblank  !
  real :: eblank   !
  integer :: ier   ! Returns 0 for no error
  ! Local
  integer :: lmax,iaz,ifirst,istep,ilast,jfirst,jstep,jlast
  integer :: lli,ic,ibeg,lnth,ll,i,jbeg,j,lll
  real :: taz,talt,saz,sal,caz,cal,xsc,ysc
  real :: a1,a2,a3,b1,b2,b3,b4,xx,yy
  !
  logical :: error
  !
  ier = 0
  !
  taz = az*0.0174532925
  talt = alt*0.0174532925
  !
  saz = sin(taz)
  caz = cos(taz)
  sal = sin(talt)
  cal = cos(talt)
  !
  xsc = xlen/float(n-1)
  ysc = ylen/float(m-1)
  a1 = caz*xsc
  a2 = -saz*ysc
  a3 = xoff-0.5*(a1*float(n+1)+a2*float(m+1))
  b1 = saz*sal*xsc
  b2 = caz*sal*ysc
  b3 = zfac*cal
  b4 = b3*zoff+yoff-0.5*(b1*float(n+1)+b2*float(m+1))
  !
  ! Plot the axes if needed
  if (doaxes) then
    call sub_axes(a,m,n,a3,a2,a1,b1,b2,b3,b4,saz,caz,blnk3d)
    doaxes = .false.
    return
  endif
  error = .false.
  call gr_segm('PERSP',error)
  !
  ! Is buffer large enough ?
  lmax = 2*min(m,n)
  if (l.lt.lmax) then
    ier = 2
    return
  endif
  !
  iaz = 1
  if (a1 .le. 0.0) iaz = iaz+1
  if (a2 .le. 0.0) iaz = iaz+2
  !
  if (iaz.eq.2 .or. iaz.eq.4) then
    ifirst = m
    istep = -1
    ilast = 1
  else
    ifirst = 1
    istep = 1
    ilast = m
  endif
  !
  if (iaz.eq.1 .or. iaz.eq.2) then
    jfirst = n
    jstep = -1
    jlast = 1
  else
    jfirst = 1
    jstep = 1
    jlast = n
  endif
  !
  if (iaz.eq.1 .or. iaz.eq.4) then
    lli = -1
  else
    lli = 1
  endif
  !
  ic = 0
  ibeg = ifirst+istep
  !
  ! OK ready to go
  lll = 0
70 continue
  lnth = min0(2*iabs(ibeg-ifirst)+1,lmax)
  if (lli.eq.-1) then
    ll = lnth+1
  else
    ll = 0
  endif
  i = ibeg
  j = jfirst
  xx = float(j)
  yy = float(i)
  ll = ll+lli
  x(ll) = a1*xx+a2*yy+a3
  if (sic_fini4(a(i,j)).and.abs(a(i,j)-rgblank).gt.eblank) then
    y(ll) = b1*xx+b2*yy+b3*a(i,j)+b4
    lll=lll+1
  else                         ! NaNs and INFs are here
    y(ll) = b1*xx+b2*yy+b3*blnk3d+b4
    if(lll.gt.1) then
      if (lli.eq.-1) then
        call nxtvu(ic,x(ll+1),y(ll+1),lll,ier)
      else
        call nxtvu(ic,x(ll-lll),y(ll-lll),lll,ier)
      endif
      if (ier.ne.0) return
    endif
    lll=0
  endif
80 i = i-istep
  yy = float(i)
  ll = ll+lli
  x(ll) = a1*xx+a2*yy+a3
  if (sic_fini4(a(i,j)).and.abs(a(i,j)-rgblank).gt.eblank) then
    y(ll) = b1*xx+b2*yy+b3*a(i,j)+b4
    lll = lll+1
  else                         ! NaNs and INFs are here
    y(ll) = b1*xx+b2*yy+b3*blnk3d+b4
    if(lll.gt.1) then
      if (lli.eq.-1) then
        call nxtvu(ic,x(ll+1),y(ll+1),lll,ier)
      else
        call nxtvu(ic,x(ll-lll),y(ll-lll),lll,ier)
      endif
      if (ier.ne.0) return
    endif
    lll=0
  endif
  if (j.eq.jlast) goto 85
  j = j+jstep
  xx = float(j)
  ll = ll+lli
  x(ll) = a1*xx+a2*yy+a3
  if (sic_fini4(a(i,j)).and.abs(a(i,j)-rgblank).gt.eblank) then
    y(ll) = b1*xx+b2*yy+b3*a(i,j)+b4
    lll = lll+1
  else
    y(ll) = b1*xx+b2*yy+b3*blnk3d+b4
    if(lll.gt.1) then
      if (lli.eq.-1) then
        call nxtvu(ic,x(ll+1),y(ll+1),lll,ier)
      else
        call nxtvu(ic,x(ll-lll),y(ll-lll),lll,ier)
      endif
      if (ier.ne.0) return
    endif
    lll=0
  endif
  if (i.ne.ifirst) goto 80
  !
  !85    CALL NXTVU(IC,X,Y,LNTH,IER)
85 continue
  if (lll.gt.0) then
    if (lli.eq.-1) then
      call nxtvu(ic,x(ll),y(ll),lll,ier)
    else
      call nxtvu(ic,x(ll-lll+1),y(ll-lll+1),lll,ier)
    endif
    if (ier.ne.0) return
  endif
  lll=0
  ic = 1
  if (ibeg.eq.ilast) goto 90
  ibeg = ibeg+istep
  goto 70
  !
90 jbeg = jfirst
100 lnth = min0(2*iabs(jbeg-jlast)+1,lmax)
  if (lli.eq.-1) then
    ll = lnth+1
  else
    ll = 0
  endif
  i = ilast
  j = jbeg
  xx = float(j)
  yy = float(i)
  ll = ll+lli
  x(ll) = a1*xx+a2*yy+a3
  if (sic_fini4(a(i,j)).and.abs(a(i,j)-rgblank).gt.eblank) then
    y(ll) = b1*xx+b2*yy+b3*a(i,j)+b4
    lll=lll+1
  else                         ! NaNs and INFs are here
    y(ll) = b1*xx+b2*yy+b3*blnk3d+b4
    if(lll.gt.1) then
      if (lli.eq.-1) then
        call nxtvu(ic,x(ll+1),y(ll+1),lll,ier)
      else
        call nxtvu(ic,x(ll-lll),y(ll-lll),lll,ier)
      endif
      if (ier.ne.0) return
    endif
    lll=0
  endif
110 j = j+jstep
  xx = float(j)
  ll = ll+lli
  x(ll) = a1*xx+a2*yy+a3
  if (sic_fini4(a(i,j)).and.abs(a(i,j)-rgblank).gt.eblank) then
    y(ll) = b1*xx+b2*yy+b3*a(i,j)+b4
    lll=lll+1
  else                         ! NaNs and INFs are here
    y(ll) = b1*xx+b2*yy+b3*blnk3d+b4
    if(lll.gt.1) then
      if (lli.eq.-1) then
        call nxtvu(ic,x(ll+1),y(ll+1),lll,ier)
      else
        call nxtvu(ic,x(ll-lll),y(ll-lll),lll,ier)
      endif
      if (ier.ne.0) return
    endif
    lll=0
  endif
  if (i.eq.ifirst) goto 120
  i = i-istep
  yy = float(i)
  ll = ll+lli
  x(ll) = a1*xx+a2*yy+a3
  if (sic_fini4(a(i,j)).and.abs(a(i,j)-rgblank).gt.eblank) then
    y(ll) = b1*xx+b2*yy+b3*a(i,j)+b4
    lll=lll+1
  else                         ! NaNs and INFs are here
    y(ll) = b1*xx+b2*yy+b3*blnk3d+b4
    if(lll.gt.1) then
      if (lli.eq.-1) then
        call nxtvu(ic,x(ll+1),y(ll+1),lll,ier)
      else
        call nxtvu(ic,x(ll-lll),y(ll-lll),lll,ier)
      endif
      if (ier.ne.0) return
    endif
    lll=0
  endif
  if (j.ne.jlast) goto 110
  !
  !120   CALL NXTVU(1,X,Y,LNTH,IER)
120 continue
  if(lll.gt.0) then
    if (lli.eq.-1) then
      call nxtvu(ic,x(ll),y(ll),lll,ier)
    else
      call nxtvu(ic,x(ll-lll+1),y(ll-lll+1),lll,ier)
    endif
    if (ier.ne.0) return
  endif
  lll=0
  jbeg = jbeg+jstep
  if (jbeg.eq.jlast) goto 999
  goto 100
  !
999 continue
  !
  call gtsegm_close(error)
  !
end subroutine plt3d
!
subroutine nxtvu(ic,x,y,n,ier)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>nxtvu
  use greg_kernel
  use greg_nxtv1
  use greg_hautbas
  !---------------------------------------------------------------------
  ! @ private
  ! GREG Internal routine
  ! Find the next vector visible and plot it.
  !---------------------------------------------------------------------
  integer :: ic           ! Integer code                         Input
  integer :: n            ! Length of X and Y arrays             Input
  real :: x(n)            ! Work array
  real :: y(n)            ! Work array
  integer :: ier          ! Error code                           Output
  ! Local
  integer :: i,j,jj,ii,iov0,isw,iov1
  real :: ya0,yb0,xl,yl,x0,x1,ya1,yb1,frac,xi,yi
  !
  if (sic_ctrlc()) then
    ier = -1
    return
  endif
  if (n.gt.nn) then
    ier = 1
    return
  endif
  !
  ! First: always visible...
  if (ic.eq.0) then
    ll = nn-n+1
    i = ll
    xx(i) = x(1)
    yy(i) = y(1)
    if (lower) then
      call grelocate(xx(ll),ly2-yy(ll))
    else
      call grelocate(xx(ll),yy(ll))
    endif
    do j = 2,n
      i = i+1
      xx(i) = x(j)
      yy(i) = y(j)
      if (lower) then
        call gdraw(xx(i),ly2-yy(i))
      else
        call gdraw(xx(i),yy(i))
      endif
    enddo
    ier = 0
    return
  endif
  !
  ! Case IC not 0: check what is hidden
  ii = 1
  jj = ll
  kk = 0
  ya0 = y(1)
  yb0 = yy(ll)
  if (x(1).le.xx(ll)) then
    !
    ! X(1) <= X(LL)
    if (lower) then
      call grelocate(x(1),ly2 - ya0)
    else
      call grelocate(x(1),ya0)
    endif
40  call outp(x(ii),y(ii),ier)
    if (ii.eq.n) goto 360
    ii = ii+1
    ya0 = y(ii)
    if (x(ii) .gt. xx(ll)) goto 50
    if (lower) then
      call gdraw(x(ii),ly2 - ya0)
    else
      call gdraw(x(ii),ya0)
    endif
    goto 40
    !
50  ii = ii-1
    xl = x(ii)
    yl = y(ii)
    ya0 = alin(x(ii),x(ii+1),y(ii),y(ii+1),xx(ll))
    x0 = xx(ll)
    if (ya0 .gt. yb0) then
      iov0 = 1
    else
      if (lower) then
        call gdraw(x0,ly2 - ya0)
      else
        call gdraw(x0,ya0)
      endif
      call outp(x0,ya0,ier)
      call outp(x0,yb0,ier)
      iov0 = 0
    endif
    !
    ! X(1) > X(LL)
  else
70  call outp(xx(jj),yy(jj),ier)
    if (jj.eq.nn) goto 380
    jj = jj+1
    yb0 = yy(jj)
    if (x(1).ge.xx(jj)) goto 70
    !
    jj = jj-1
    yb0 = alin(xx(jj),xx(jj+1),yy(jj),yy(jj+1),x(1))
    x0 = x(1)
    if (ya0 .le. yb0) then
      iov0 = 0
    else
      call outp(x0,yb0,ier)
      call outp(x0,ya0,ier)
      xl = x0
      yl = ya0
      iov0 = 1
    endif
  endif
  !
  ! Common block
120 continue
  if (ii.eq.n) goto 300
  if (jj.eq.nn) goto 310
  if (x(ii+1) .le. xx(jj+1)) then
    isw = +1
    ii = ii+1
    x1 = x(ii)
    ya1 = y(ii)
    yb1 = alin(xx(jj),xx(jj+1),yy(jj),yy(jj+1),x1)
  else
    if (xx(jj+1) .ge. x(n)) goto 340
    isw = -1
    jj = jj+1
    x1 = xx(jj)
    ya1 = alin(x(ii),x(ii+1),y(ii),y(ii+1),x1)
    yb1 = yy(jj)
  endif
  if (ya1 .le. yb1) goto 160
  iov1 = 1
  if (iov0.eq.0) goto 170
150 continue
  if (isw.eq.-1) goto 200
  call outp (x1,ya1,ier)
  if (lower) then
    call grelocate(xl,ly2-yl)
    call gdraw(x1,ly2-ya1)
  else
    call grelocate(xl,yl)
    call gdraw(x1,ya1)
  endif
  xl = x1
  yl = ya1
  goto 200
160 iov1 = 0
  if (iov0.eq.0) goto 190
170 frac = (yb0-ya0)/(ya1-yb1+yb0-ya0)
  xi = (x1-x0)*frac+x0
  yi = (ya1-ya0)*frac+ya0
  call outp(xi,yi,ier)
  if (iov0.eq.0) goto 180
  if (lower) then
    call grelocate(xl,ly2 - yl)
    call gdraw(xi,ly2 - yi)
  else
    call grelocate(xl,yl)
    call gdraw(xi,yi)
  endif
  xl = xi
  yl = yi
  goto 190
180 xl = xi
  yl = yi
  goto 150
  !
190 continue
  if (isw.eq.+1) goto 200
  call outp(xx(jj),yy(jj),ier)
200 continue
  if (ier.ne.0) return
  x0 = x1
  ya0 = ya1
  yb0 = yb1
  iov0 = iov1
  goto 120
  !
  ! Exit tests
310 x1 = xx(nn)
  ya1 = alin(x(ii),x(ii+1),y(ii),y(ii+1),x1)
  yb1 = yy(nn)
  if (ya1 .gt. yb1) goto 320
  call outp(x1,yb1,ier)
  call outp(x1,ya1,ier)
  if (lower) then
    call grelocate(x1,ly2 - ya1)
  else
    call grelocate(x1,ya1)
  endif
  goto 330
380 ii = 1
320 continue
  if (lower) then
    call grelocate(x(ii),ly2-y(ii))
  else
    call grelocate(x(ii),y(ii))
  endif
330 if (ii.eq.n) goto 400
  ii = ii+1
  call outp(x(ii),y(ii),ier)
  if (lower) then
    call gdraw(x(ii),ly2-y(ii))
  else
    call gdraw(x(ii),y(ii))
  endif
  goto 330
300 continue
  if (jj.eq.nn) goto 400
340 x1 = x(n)
  ya1 = y(n)
  yb1 = alin(xx(jj),xx(jj+1),yy(jj),yy(jj+1),x1)
  if (ya1 .le. yb1) goto 350
  call outp(x1,ya1,ier)
  call outp(x1,yb1,ier)
  if (lower) then
    call grelocate(xl,ly2 - yl)
    call gdraw(x1,ly2 - ya1)
  else
    call grelocate(xl,yl)
    call gdraw (x1,ya1)
  endif
350 continue
  if (jj.eq.nn) goto 400
  jj = jj+1
  call outp(xx(jj),yy(jj),ier)
  goto 350
360 jj = 0
  goto 350
400 ll = nn-kk+1
  i = ll
  do j = 1,kk
    xx(i) = xx(j)
    yy(i) = yy(j)
    i = i+1
  enddo
end subroutine nxtvu
!
subroutine outp(x,y,ier)
  use greg_nxtv1
  !---------------------------------------------------------------------
  ! @ private
  ! GREG Internal routine
  ! Buffers the vector to keep track of vectors plotted
  !---------------------------------------------------------------------
  real :: x                         !              Input
  real :: y                         !              Input
  integer :: ier                    ! Error code   Output
  ! Local
  real, parameter :: eps=.001
  !
  if (kk.eq.0) then
    kk = 1
    xx(1) = x
    yy(1) = y
  elseif (kk.eq.ll-1) then
    ier = 1
  elseif (abs(xx(kk)-x)+abs(yy(kk)-y) .ge. eps) then
    kk = kk+1
    xx(kk) = x
    yy(kk) = y
  endif
end subroutine outp
!
function alin(x0,x1,y0,y1,x)
  !---------------------------------------------------------------------
  ! @ private
  ! GREG Internal routine
  ! Find the Y coordinate of absissae X along line (X0,Y0)-->(X1,Y1)
  !---------------------------------------------------------------------
  real :: alin          ! Y coordinate of point                 Output
  real :: x0            ! X coordinate of start point           Input
  real :: x1            ! X coordinate of end point             Input
  real :: y0            ! Y coordinate of start point           Input
  real :: y1            ! Y coordinate of end point             Input
  real :: x             ! X coordinate of point                 Input
  !
  if (x0.ne.x1) then
    alin = (x-x0)*(y1-y0)/(x1-x0)+y0
  elseif (y1.gt.y0) then
    alin = y1
  else
    alin = y0
  endif
end function alin
!
subroutine sub_axes(a,m,n,a3,a2,a1,b1,b2,b3,b4,saz,caz,blnk3d)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>sub_axes
  use greg_pen
  use greg_axes
  !---------------------------------------------------------------------
  ! @ private
  ! GREG Internal routine
  ! Cette routine trace les axes sur la vue en perspective lorsque
  ! l'option /AXES est presente dans la commande PERSPECTIVE.
  !---------------------------------------------------------------------
  integer :: m                      !
  integer :: n                      !
  real :: a(m,n)                    !
  real :: a3                        !
  real :: a2                        !
  real :: a1                        !
  real :: b1                        !
  real :: b2                        !
  real :: b3                        !
  real :: b4                        !
  real :: saz                       !
  real :: caz                       !
  real :: blnk3d                    !
  ! Local
  real :: zz,ex1,ey1,ex2,ey2,ex3,ey3,ex4,ey4
  real :: eyy1,eyy2,eyy3,eyy4,zmin1,zmin2,zmin3,zmin4
  real :: zmax1,zmax2,zmax3,zmax4, aval
  real :: alpha1,beta1,alpha2,beta2,alpha3,beta3,alpha4,beta4
  real :: zlx1,zlx2,zlx3,zlx4, zly1,zly2,zly3,zly4, zlzz
  real, parameter :: pi=3.141592653
  logical :: error
  !
  ! Base thickness is proportional to ZMIN-ZMAX
  zz  =  zmin-0.1*(zmax-zmin)
  !
  ! The 8 corners of the box. Patched for INFs and NaNs
  ex1 = a3+a2+a1
  ey1 = b1+b2+b4+b3*a(1,1)
  if ((ey1.eq.ey1+1) .or. .not.(ey1.eq.ey1))  ey1=b1+b2+b4+b3*blnk3d
  ex3 = a1*n+a2*m+a3
  ey3 = b1*n+b2*m+b3*a(m,n)+b4
  if ((ey3.eq.ey3+1) .or. .not.(ey3.eq.ey3))  ey3=b1*n+b2*m+b3*blnk3d+b4
  ex2 = a1*n+a2+a3
  ey2 = b1*n+b2+b4+b3*a(1,n)
  if ((ey2.eq.ey2+1) .or. .not.(ey2.eq.ey2))  ey2=b1*n+b2+b4+b3*blnk3d
  ex4 = a1+a2*m+a3
  ey4 = b1+b2*m+b3*a(m,1)+b4
  if ((ey4.eq.ey4+1) .or. .not.(ey4.eq.ey4))  ey4=b1+b2*m+b3*blnk3d+b4
  eyy4 = b1+b2*m+b3*zz+b4
  eyy3 = b1*n+b2*m+b4+b3*zz
  eyy2 = b1*n+b2+b4+b3*zz
  eyy1 = b1+b2+b4+b3*zz
  !
  ! Define vertical axis
  zmin1 = b1+b2+b4+b3*zmin
  zmin2 = b1*n+b2+b4+b3*zmin
  zmin3 = b1*n+b2*m+b4+b3*zmin
  zmin4 = b1+b2*m+b4+b3*zmin
  zmax1 = b1+b2+b4+b3*zmax
  zmax2 = b1*n+b2+b4+b3*zmax
  zmax3 = b1*n+b2*m+b4+b3*zmax
  zmax4 = b1+b2*m+b4+b3*zmax
  zlzz  = zmax1-zmin1
  !
  ! Compute angles of axes
  if (ex1.eq.ex4) then
    alpha1 = 0.0
    beta4  =-90.0
  else
    aval  =  (eyy1-eyy4)/(ex1-ex4)
    alpha1= atan(aval)*180.0/pi
    beta4 =-atan(-aval)*180.0/pi
  endif
  if (ex3.eq.ex4) then
    alpha2 = 0.0
    beta1  =-90.0
  else
    aval  =  (eyy4-eyy3)/(ex4-ex3)
    alpha2= atan(aval)*180.0/pi
    beta1 =-atan(-aval)*180.0/pi
  endif
  if (ex3.eq.ex2) then
    alpha3=0.0
    beta2 = -90.
  else
    aval  =  (eyy3-eyy2)/(ex3-ex2)
    alpha3=atan(aval)*180./pi
    beta2 =-atan(-aval)*180./pi
  endif
  if (ex2.eq.ex1) then
    alpha4= 0.0
    beta3 =-90.
  else
    aval  = (eyy2-eyy1)/(ex2-ex1)
    alpha4= atan(aval)*180./pi
    beta3 =-atan(-aval)*180./pi
  endif
  !
  ! Compute length of axes
  zlx1 = sqrt((ex1-ex4)**2+(eyy1-eyy4)**2)
  zlx2 = sqrt((ex4-ex3)**2+(eyy4-eyy3)**2)
  zlx3 = sqrt((ex3-ex2)**2+(eyy3-eyy2)**2)
  zlx4 = sqrt((ex2-ex1)**2+(eyy2-eyy1)**2)
  zly1 = zlx2
  zly2 = zlx3
  zly3 = zlx4
  zly4 = zlx1
  !
  ! Plot the corners
  error = .false.
  call gr_segm('3BOX',error)
  if (saz.le.0.0) then
    if (caz.le.0.0) then
      call permute(xl1,xl2)
      call echange(xl1,xl2,yl1,yl2)
      call grline(ex4,ey4,ex4,eyy4)
      call grline(ex2,ey2,ex2,eyy2)
      call grline(ex3,ey3,ex3,eyy3)
      call echange(xl1,xl2,yl1,yl2)
      call permute(xl1,xl2)
    else
      call permute(xl1,xl2)
      call permute(yl1,yl2)
      call grline(ex1,ey1,ex1,eyy1)
      call grline(ex3,ey3,ex3,eyy3)
      call grline(ex2,ey2,ex2,eyy2)
      call permute(xl1,xl2)
      call permute(yl1,yl2)
    endif
  else
    if (caz.ge.0.0) then
      call permute(yl1,yl2)
      call echange(xl1,xl2,yl1,yl2)
      call grline(ex4,ey4,ex4,eyy4)
      call grline(ex2,ey2,ex2,eyy2)
      call grline(ex1,ey1,ex1,eyy1)
      call echange(xl1,xl2,yl1,yl2)
      call permute(yl1,yl2)
    else
      call grline(ex3,ey3,ex3,eyy3)
      call grline(ex1,ey1,ex1,eyy1)
      call grline(ex4,ey4,ex4,eyy4)
    endif
  endif
  call gtsegm_close(error)
  if (error)  return
  !
  ! Now the real axis
  if (saz.le.0.0) then
    if (caz.le.0.0) then
      call permute(xl1,xl2)
      call echange(xl1,xl2,yl1,yl2)
      call traxes(alpha2,beta2,ex3,eyy3,zlx2,zly2,ex2,eyy2,ex4,eyy4,zmin2,zlzz)
      call echange(xl1,xl2,yl1,yl2)
      call permute(xl1,xl2)
    else
      call permute(xl1,xl2)
      call permute(yl1,yl2)
      call traxes(alpha3,beta3,ex2,eyy2,zlx3,zly3,ex1,eyy1,ex3,eyy3,zmin1,zlzz)
      call permute(xl1,xl2)
      call permute(yl1,yl2)
    endif
  else
    if (caz.ge.0.0) then
      call permute(yl1,yl2)
      call echange(xl1,xl2,yl1,yl2)
      call traxes(alpha4,beta4,ex1,eyy1,zlx4,zly4,ex4,eyy4,ex2,eyy2,zmin4,zlzz)
      call echange(xl1,xl2,yl1,yl2)
      call permute(yl1,yl2)
    else
      call traxes(alpha1,beta1,ex4,eyy4,zlx1,zly1,ex3,eyy3,ex1,eyy1,zmin3,zlzz)
    endif
  endif
  !
end subroutine sub_axes
!
subroutine traxes (alpha,beta,ex,exx,zlxx,zlyy,ey,eyy,ez,ezz,vz,zlzz)
  use greg_interfaces, except_this=>traxes
  use greg_axes
  use greg_xyz
  use greg_hautbas
  !---------------------------------------------------------------------
  ! @ private
  ! GREG Internal routine
  ! Cette routine est utilisee par la routine SUB_AXES pour afficher ces
  ! axes
  !---------------------------------------------------------------------
  real :: alpha              ! Orientation de l'axe des abscisses
  real :: beta               ! Orientation de l'axe des ordonnees
  real :: ex                 ! abscisse du coin apparaissant au centre
  real :: exx                ! ordonnee du coin apparaissant au centre
  real :: zlxx               ! longueur de l'axe des abscisses
  real :: zlyy               ! longueur de l'axe des ordonnees
  real :: ey                 ! abscisse du coin apparaissant a gauche
  real :: eyy                ! ordonnee du coin apparaissant a gauche
  real :: ez                 ! abscisse du coin apparaissant a droite
  real :: ezz                ! ordonnee du coin apparaissant a droite
  real :: vz                 ! ordonnee du bas de l'axe vertical
  real :: zlzz               ! longueur de l'axe des donnees
  ! Local
  character(len=4) :: atype
  character(len=1) :: ochar
  character(len=120) :: line
  real :: esp,angsav1,angsav2
  real, parameter :: pi=3.141592653
  !
  call inqang(angsav1,angsav2)
  esp = abs(ez-ey)
  !
  ! X Axis : check visibility and plot
  if ((abs(ez-ex).ge.0.5) .or. (abs(ezz-exx).ge.0.2)) then
    call setang(alpha,angsav2)
    if (alpha.gt.60.0) then
      ochar = 'O'
    else
      ochar = 'P'
    endif
    write (line,100) ' XL ',xl1,xl2,ex,exx,zlxx,ochar
    call gr_exec1(line)
    if (gr_error()) goto 99
    !
    ! Text below X axis
    xposx = ex+0.5*(ez-ex)+(.5+esp/11.0)*sin(pi*alpha/180.0)
    xposy = exx+0.5*(ezz-exx)-(.5+esp/11.0)*cos(pi*alpha/180.0)
  endif
  !
  ! Y Axis: Check visibility and plot
  if ((abs(ey-ex).ge.0.5) .or. (abs(eyy-exx).ge.0.2)) then
    if (beta.gt.-60.0) then
      call setang(beta,angsav2)
      atype = ' XL '
      ochar = 'P'
      write(line,100) atype,yl1,yl2,ey,eyy,zlyy,ochar
    else
      !
      call setang(90.0+beta,angsav2)
      atype = ' YL '
      ochar = 'O'
      !
      !            WRITE(LINE,100) ATYPE,YL1,YL2,EY,EYY,ZLYY,OCHAR
      ! Note reverse axis starting from end
      write(line,100) atype,yl2,yl1,ex,exx,zlyy,ochar
    endif
    call gr_exec1(line)
    if (gr_error()) goto 99
    !
    ! Text below Y axis
    yposx=ey+0.5*(ex-ey)-(.5+esp/11.0)*sin(-beta*pi/180.0)
    yposy=exx+0.5*(eyy-exx)-(.5+esp/11.0)*cos(-beta*pi/180.0)
  endif
  !
  ! Z axis if required
  if (vert_flag) then
    call setang(0.0,angsav2)
    write(line,100) ' YL ',zmin,zmax,ey,vz,zlzz,'O'
    call gr_exec1(line)
    if (gr_error()) goto 99
  endif
99 call setang(angsav1,angsav2)
  return
100 format('AXIS',a,2(1x,e15.7),' /LOCATION ',3(1x,f8.2),  &
      ' /TICK OUT /LABEL ',a)
end subroutine traxes
!
subroutine echange (xl1,xl2,yl1,yl2)
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  real*4 :: xl1                     !
  real*4 :: xl2                     !
  real*4 :: yl1                     !
  real*4 :: yl2                     !
  ! Local
  real*4 :: varint
  !
  varint = xl1
  xl1 = yl1
  yl1 = varint
  varint = xl2
  xl2 = yl2
  yl2 = varint
end subroutine echange
!
subroutine permute (val1,val2)
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  real*4 :: val1                    !
  real*4 :: val2                    !
  ! Local
  real*4 :: varint
  !
  varint = val1
  val1 = val2
  val2 = varint
end subroutine permute
