subroutine conreg (nx,ny,z,frstd,vectd,lastd,flushd,ir,n,error)
  use gcont_interfaces, except_this=>conreg
  use gcont_contour
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is used elsewhere)
  !	Draw contour levels according to the parameters set up by
  !	subroutine MAP
  ! Arguments :
  !	NX	I	Number of X pixels			Input
  !	NY	I	Number of Y pixels			Input
  !	Z	R*4	Array of values				Input
  !	VECTD	Ext 	Vector drawing function			Input
  !	LASTD	Ext	End of contour drawing function		Input
  !	FRSTD	Ext	First vector drawing routine 		Input
  !	FLUSHD	Ext	A plot flushing routine			Input
  !	IR	I	Work space for contour storage
  !	N	I	Size of work space
  ! Subroutines :
  !	CONBIT
  !	STLINE
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real :: z(*)                      !
  external :: frstd                 !
  external :: vectd                 !
  external :: lastd                 !
  external :: flushd                !
  integer :: ir(*)                  !
  integer :: n                      !
  logical, intent(inout) :: error   ! Error return
  ! Local
  integer :: i
  real :: contr
  !
  call conbdn
  !
  ! Get number of bits
  call conbit(nx,ny,error)
  if (error) return
  ! No packing version
  nr = n/2
  !
  ! Process each level
  do i=1,ncl
    contr = clev(i)*qlev
    if (clev(i).lt.0) then
      call frstd(2,error)
    else
      call frstd(1,error)
    endif
    if (error) return
    ! Draw all lines at this level.
    call stline(contr,nx,ny,z,vectd,lastd,ir,error)
    if (error) return
    call flushd (error)
    if (error) return
  enddo
end subroutine conreg
!
subroutine stline(conval,nx,ny,z,vectd,lastd,ir,error)
  use gcont_interfaces, except_this=>stline
  use gcont_contour
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! 	This routine finds the beginnings of all contour lines at
  !	level CONVAL. First the edges are searched for lines intersecting
  !	the edge (open lines) then the interior is searched for lines
  !	which do not intersect the edge (closed lines).  Beginnings are
  !	stored in IR to prevent retracing of lines.  If IR is filled,
  !	the search is stopped for this CONVAL.
  ! Arguments :
  !	CONVAL	R*4	Contour value				Input
  !	NX	I	Number of X pixels			Input
  !	NY	I	Number of Y pixels			Input
  !	Z	R*4	Array of values				Input
  !	VECTD	Ext	Vector drawing function
  !	LASTD	Ext	End of contour drawing function
  !	IR	I	Work space for contour storage
  ! Subroutines :
  !	DRLINE
  !---------------------------------------------------------------------
  real :: conval                    !
  integer :: nx                     !
  integer :: ny                     !
  real :: z(*)                      !
  external :: vectd                 !
  external :: lastd                 !
  integer :: ir(2,*)                !
  logical, intent(inout) :: error   ! Error return
  ! Local
  ! Array IR is now in argument list
  integer :: m,n,ip1,i,izcor,jp1,j,k
  character(len=12) :: chain
  !
  m = nx
  n = ny
  !!Print *,'STLINE ',nx,ny,' Max buffer ',nr, 'IOFFP' ,ioffp
  cv = conval
  !
  np2 = 0
  iss = 0
  do ip1=2,m
    i = ip1-1
    if (z(i).ge.cv .or. z(ip1).lt.cv) goto 101
    ix = ip1
    iy = 1
    idx = -1
    idy = 0
    is = 1
    !!Print *,'DRLINE 1 ',ix,iy,' ids ',idx,idy,is
    call drline (nx,ny,z,vectd,lastd,ir,error)
    if (error) return
101 izcor=(n-1)*nx
    if (z(izcor+ip1).ge.cv .or. z(izcor+i).lt.cv) cycle    ! IP1
    ix = i
    iy = n
    idx = 1
    idy = 0
    is = 5
    !!Print *,'DRLINE 2 ',ix,iy,' ids ',idx,idy,is
    call drline (nx,ny,z,vectd,lastd,ir,error)
    if (error) return
  enddo
  !
  do jp1=2,n
    j = jp1-1
    izcor=(j-1)*nx
    if (z(izcor+m).ge.cv .or. z((jp1-1)*nx+m).lt.cv) goto 103
    ix = m
    iy = jp1
    idx = 0
    idy = -1
    is = 7
    !!Print *,'DRLINE 3 ',ix,iy,' ids ',idx,idy,is
    call drline (nx,ny,z,vectd,lastd,ir,error)
    if (error) return
103 if (z((jp1-1)*nx+1).ge.cv .or. z(izcor+1).lt.cv)  cycle  ! JP1
    ix = 1
    iy = j
    idx = 0
    idy = 1
    is = 3
    !!Print *,'DRLINE 4 ',ix,iy,' ids ',idx,idy,is
    call drline (nx,ny,z,vectd,lastd,ir,error)
    if (error) return
  enddo                        ! JP1
  !
  iss = 1
  do jp1=3,n
    j = jp1-1
    izcor=(j-1)*nx
    do ip1=2,m
      i = ip1-1
      if (z(izcor+i).ge.cv .or. z(izcor+ip1).lt.cv) cycle  ! IP1
      if (.not.(z(izcor+i)  .eq.z(izcor+i)) .or.  &
          .not.(z(izcor+ip1).eq.z(izcor+ip1)))  cycle   ! IP1
      if (np2.eq.0) goto 106
      do k=1,np2
        if (ir(1,k).eq.ip1 .and. ir(2,k).eq.j)  goto 107
      enddo                    ! K
106   np2 = np2+1
      if (np2 .gt. nr) then
        write(chain,'(1PG11.4)') conval
        call gcont_message(seve%w,'RGMAP','Contour storage exhausted for '//  &
        chain)
        return
      endif
      ir(1,np2) = ip1
      ir(2,np2) = j
      ix = ip1
      iy = j
      idx = -1
      idy = 0
      is = 1
    !!Print *,'DRLINE 5 ',ix,iy,' ids ',idx,idy,is
      call drline (nx,ny,z,vectd,lastd,ir,error)
      if (error) return
107   continue
    enddo  ! IP1
  enddo  ! JP1
end subroutine stline
!
subroutine drline (nx,ny,z,vectd,lastd,ir,error)
  use gcont_contour
  use gcont_interfaces, only : gcont_message
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! 	This routine traces a contour line when given the beginning by STLINE.
  ! 	Transformations can be added by deleting the statement functions for
  ! 	FX and FY in DRLINE and MINMAX and adding external functions.
  ! 	X=1. at Z(1,J), X=FLOAT(M) at Z(M,J). X takes on non-integer values.
  ! 	Y=1. at Z(I,1), Y=FLOAT(N) at Z(I,N). Y takes on non-integer values.
  ! Arguments :
  !	NX	I	Number of pixels along X axis		Input
  !	NY	I	Number of pixels along Y axis		Input
  !	Z	R*4 (*)	Array of values				Input
  !	VECTD	Ext	Vector drawing function
  !	LASTD	Ext	End of contour drawing function
  !	IR	I (*)	Workspace for contour storage
  !		It is assumed that all the necessary setup
  !		have been done before the call to DRLINE
  ! Subroutines :
  !	VECTD, LASTD, ISHIFT
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real :: z(*)                      !
  external :: vectd                 !
  external :: lastd                 !
  integer :: ir(2,*)                !
  logical, intent(inout) :: error   ! Error return
  ! Local
  integer :: m,n,ix0,iy0,is0,ix2,iy2,isub,isbig
  integer :: ix3,iy3,ix4,iy4
  real :: x,y,xold,yold,z1,z2,z3,z4
  character(len=80) :: mess
  logical :: ipen,ipeno
  !
  data ipen,ipeno /.true.,.true./
  !
  ! Statement functions
  !      FX(X,Y) = X and FY(X,Y) = Y
  !
  !      C(P1,P2) = (P1-CV)/(P1-P2)
  !     cut(cv,p1,p2) = (p1-cv)/(p1-p2)
  !
  ! Code
  m = nx
  n = ny
  !
  ix0 = ix
  iy0 = iy
  is0 = is
  !
  ix2 = ix+inx(is)
  iy2 = iy+iny(is)
  z1 = z((iy-1) *nx+ix )
  z2 = z((iy2-1)*nx+ix2)
  ipen = z1.eq.z1 .and. z2.eq.z2  ! Never connect with NaNs
  if (ioffp.ne.0) then  ! IOFFP is 1 when blanking must be checked, 0 if not
    ipen = ipen .and.  &
           abs(z1-spval).gt.epsval .and.  &
           abs(z2-spval).gt.epsval
  endif
  ipeno = ipen
  !
  if (idx.ne.0) then
    y = iy
    isub = ix+idx
    IF ((iy-1)*nx+ix.gt.NX*NY) Print *,'Invalid Z adress'
    IF ((iy-1)*nx+isub.gt.NX*NY) Print *,'Invalid Z adress ISUB,IY'
    x = cut(cv,z((iy-1)*nx+ix),z((iy-1)*nx+isub)) * float(idx) + float(ix)
    !*SG** if (.not.(x.eq.x)) x = float(ix)+float(idx)
  else
    x = ix
    isub = iy+idy
    IF ((iy-1)*nx+ix.gt.NX*NY) Print *,'Invalid Z adress'
    IF ((isub-1)*nx+ix.gt.NX*NY) Print *,'Invalid Z adress IX,ISUB'
    y = cut(cv,z((iy-1)*nx+ix),z((isub-1)*nx+ix)) * float(idy) + float(iy)
    !*SG** if (.not.(y.eq.y)) y = float(iy)+float(idy)
  endif
  call vectd (x,y,error)
  if (error) return
  ! call frstd (x,y)  ! (fx(x,y),fy(x,y))
  !
  ! Loop on pixels around
100 is = is+1
  if (is .gt. 8) is = is-8
  idx = inx(is)
  idy = iny(is)
  ix2 = ix+idx
  iy2 = iy+idy
  !
  ! The code below was crashing on complex images if the 
  !       if (np2.gt.nr) goto 120  
  ! line near the end of code was commented out... (see comments
  ! later)
  !
  !!if (iss .eq. 0) then
  !!  if (ix2.gt.m .or. iy2.gt.n .or. ix2.lt.1 .or. iy2.lt.1)  goto 120
  !!endif
  !
  ! With the line commended out, we must take care that 
  ! out of bound condition may happen even if ISS = 1
  if (ix2.gt.m .or. iy2.gt.n .or. ix2.lt.1 .or. iy2.lt.1)  then
    !
    ! Direct close for ISS = 0 (ISS=0 indicates the beginning of segments)
    if (iss.eq.0) goto 120
    !
    ! Close contour at edges if ISS = 1
    write(mess,'(A,I0,A,I0,A)') 'Contour exiting from edge (',ix,',',iy,')'
    call gcont_message(seve%d,'RGMAP',mess)
    np2 = np2+1
    if (np2.gt.nr) np2 = 1
    ir(1,np2) = ix
    ir(2,np2) = iy
    goto 120
  endif
  !
  if (cv.le.z((iy2-1)*nx+ix2)) then
    is = is+4
    ix = ix2
    iy = iy2
    goto 100
  endif
  if (is/2*2 .eq. is) goto 100
  !
  isbig = is+(8-is)/6*8
  ix3 = ix+inx(isbig-1)
  iy3 = iy+iny(isbig-1)
  ix4 = ix+inx(isbig-2)
  iy4 = iy+iny(isbig-2)
  ipeno = ipen
  if (iss .eq. 0) then
    if (ix3.gt.m .or. iy3.gt.n .or. ix3.lt.1 .or. iy3.lt.1)  goto 120
    if (ix4.gt.m .or. iy4.gt.n .or. ix4.lt.1 .or. iy4.lt.1)  goto 120
  endif

  z1 = z((iy -1)*nx+ix )
  z2 = z((iy2-1)*nx+ix2)
  z3 = z((iy3-1)*nx+ix3)
  z4 = z((iy4-1)*nx+ix4)
  ipen = z1.eq.z1 .and. z2.eq.z2 .and. z3.eq.z3 .and. z4.eq.z4  ! Never connect with NaNs
  if (ioffp.ne.0) then
    ipen = ipen .and.  &
           abs(z1-spval).gt.epsval .and.  &
           abs(z2-spval).gt.epsval .and.  &
           abs(z3-spval).gt.epsval .and.  &
           abs(z4-spval).gt.epsval
  endif
  !
  if (idx.ne.0) then
    y = iy
    isub = ix+idx
    x = cut(cv,z((iy-1)*nx+ix),z((iy-1)*nx+isub)) * float(idx) + float(ix)
    !*SG** if (.not.(x.eq.x)) x = float(ix)+float(idx)
  else
    x = ix
    isub = iy+idy
    y = cut(cv,z((iy-1)*nx+ix),z((isub-1)*nx+ix)) * float(idy) + float(iy)
    !*SG** if (.not.(y.eq.y)) y = float(iy)+float(idy)
  endif
  !
  if (ipen) then
    if (.not.ipeno) then
      call lastd (error)
      if (error) return
      call vectd (xold,yold,error)
      if (error) return
    endif
    call vectd (x,y,error)
    if (error) return
  endif
  !
  xold = x
  yold = y
  !
  ! Store start of contour
  if (is .eq. 1) then
    np2 = np2+1
    !! With the condition below, the previous error case near
    ! label 100 (the one with debug message) never happens
    !! if (np2.gt.nr) goto 120  
    if (np2.gt.nr) then
      np2 = 1
      ir(1,np2) = ix
      ir(2,np2) = iy
      goto 120
    else
      ir(1,np2) = ix
      ir(2,np2) = iy
    endif
  endif
  if (iss .eq. 0) goto 100
  if (ix.ne.ix0 .or. iy.ne.iy0 .or. is.ne.is0) goto 100
  !
  ! End of line
120 call lastd(error)
  !
contains
  function cut(cv,p1,p2)
    real(kind=4) :: cut  ! Function value on return
    real(kind=4), intent(in) :: cv  !
    real(kind=4), intent(in) :: p1  !
    real(kind=4), intent(in) :: p2  !
    cut = (p1-cv)/(p1-p2)
  end function cut
end subroutine drline
!
subroutine conblk(blank,value,tol)
  use gcont_interfaces, except_this=>conblk
  use gcont_contour
  !---------------------------------------------------------------------
  ! @ public
  !	Set blanking value for Regular mapping
  ! Arguments :
  !	BLANK	L	Blanking or not			Input
  !	VALUE	R*4	The blanking value		Input
  !	TOL	R*4	The tolerance			Input
  ! No subroutines
  !---------------------------------------------------------------------
  logical :: blank                  !
  real :: value                     !
  real :: tol                       !
  call conbdn
  !
  ! IOFFP .EQ. 0 means no blanking value
  ! SPVAL is the blanking value, and EPSVAL the tolerance
  !
  if (blank) then
    ioffp = 1
    spval = value
    epsval = tol
  else
    ioffp = 0
  endif
end subroutine conblk
!
subroutine conbit(nx,ny,error)
  use gcont_interfaces, except_this=>conbit
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !	Set up the Bit arithmetic for Regular mapping
  ! Arguments :
  !	NX	I	Number of I pixels		Input
  !	NY	I	Number of J Pixels		Input
  !	ERROR	L	Error return
  ! No subroutines
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  logical :: error                  !
  ! Local
  character(len=message_length) :: messag
  !
  ! Nonsmoothing Version
  if (nx.gt.1 .and. ny.gt.1 .and. nx.lt.32767 .and. ny.lt.32767)  return
  write (messag,1000) nx,ny
  call gcont_message(seve%e,'RGMAP',messag)
  error = .true.
  !
1000 format('Dimension error ',i12,' by ',i12)
end subroutine conbit
!
subroutine conlev(fact,array,n)
  use gcont_contour
  !---------------------------------------------------------------------
  ! @ public
  !	Setup the array of contour values
  ! Arguments :
  !	FACT	R*4	Multiplicative factor
  !	ARRAY	R*4	Contour value array
  !	N	I	Dimension of array
  ! No subroutine
  !---------------------------------------------------------------------
  real :: fact                      !
  real :: array(*)                  !
  integer :: n                      !
  ! Local
  integer :: i
  !
  qlev = fact
  ncl = min(n,maxcl)
  do i=1,ncl
    clev(i) = array(i)
  enddo
end subroutine conlev
