      PROGRAM DECL06

C     Check dimensionning by real expressions in FOO

      INTEGER N
      PARAMETER (N=10)
      REAL A(N), B(N), C(N), D(N)
      CALL FOO(A, B, C, D, N-4, 1)
      END

      SUBROUTINE FOO(X, Y, Z, W, N, M)
      INTEGER N, M
      REAL X(N+1)
      REAL Y(N+1.0)
      REAL Z(N*1.5)
      REAL W(N*M)
      INTEGER I
      DO 10 I=1, N+1
         X(I) = 1
 10   CONTINUE
      END


!!
!! Program to compute geometric properties of a quadrilateral panel.
!! 100226 lb
!!
!!
PROGRAM fifth    ! Every Fortran program starts with a program statement

  !! modules are program units that themselves contain variable
  !! declarations and subroutines and functions.
  !! The contents of the module is made availbe in other program units
  !! with the USE statement

  USE precise, ONLY : defaultp
  USE fifthpanel

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  INTEGER, PARAMETER :: WP=defaultp

  INTEGER :: i, j, k

  INTEGER, PARAMETER :: npanels=1

  ! An array for panel corner coordinates
  INTEGER, DIMENSION(4,npanels) :: panels

  ! An array for point coordinates
  REAL(WP), DIMENSION(3,4) :: points
  REAL(WP), DIMENSION(3,4) :: corners  ! temporary storage for panel corners

  REAL(wp), DIMENSION(3,npanels) :: center
  REAL(wp), DIMENSION(3,3,npanels) :: coordsys
  REAL(wp), DIMENSION(2,4,npanels) :: cornerslocal
  REAL(wp), DIMENSION(npanels) :: area

  ! Variable declarations go before any executable statement

!! the actual program starts here

  ! Data for a test panel
  panels = RESHAPE( (/ 1, 2, 3, 4 /), (/4,1/))
  points = RESHAPE( (/ -1., -1., 0., &
                        1., -1., 0., &
                        1.,  1., 0., &
                       -1.,  1., 0. /), &
                        (/3,4/) )

  ! Simple start up message
  ! The character A is used for formating character constants and
  ! variables
  WRITE(6,'(A)') 'fifth, v 1.0, 100307, lb'
  WRITE(6,*)

  ! process geometry for each panel (here it is only one)
  DO i = 1, npanels
     WRITE(6,'(A)') 'Panel point numbers:'
     WRITE(6,'(4I6)') (panels(j,i), j=1,4)

     WRITE(6,'(A)') 'Panel point coordinates:'
     DO j = 1, 4
        WRITE(6,'(I5'': ''3(G12.6,2X))') panels(j,i), &
             (points(k,j), k = 1,3)
     END DO

     ! we store the panel corner points in a 3 by 4 array
     DO j=1, 4
        corners(:,j) = points(:,panels(j,i))
     END DO

     ! We call the panel geometry function in the module fifthpanel
     ! Output data is collected in arrays with additional dimension
     ! for number of panels
     CALL panelgeometry( corners, coordsys(:,:,i), cornerslocal(:,:,i), &
                      area(i), center(:,i) )

     ! We pick some output to check.
     WRITE(6,'(''nv: '',3(G12.6,2X))') coordsys(:,3,i)
     WRITE(6,'(''cl: '',8(G12.6,2X))') cornerslocal(:,:,i)
     WRITE(6,'(''A: '',G12.6)') area(i)

  END DO
! Every program ends with end program
END PROGRAM fifth
! end of file


program make_sg
  implicit none
  integer, parameter :: SI = selected_int_kind(8)
  integer, parameter :: DI = selected_int_kind(16)
  integer, parameter :: SR = selected_real_kind(6)
  integer, parameter :: DR = selected_real_kind(12)

  integer(SI) ix, iy, jx, jy
  real(DR), dimension(:,:,:,:), allocatable :: j_couple
  integer(SI), parameter :: OUT = 17
  integer(SI) :: n
  real(DR) :: tmp, tmp2
  real(DR) :: EPS = 1e-5
  integer(SI) :: count

  open(OUT, file = "SG_complex.dat", status = "replace")

  n = 20

  allocate(j_couple(n,n,n,n))

  j_couple = -10.0

  count = 0

  do while(count .lt. n**4 / 4)

    call random_number(tmp)
    ix = ceiling(tmp * n)

    call random_number(tmp)
    iy = ceiling(tmp * n)

    call random_number(tmp)
    jx = ceiling(tmp * n)

    call random_number(tmp)
    jy = ceiling(tmp * n)

    if(.not.(ix == jx .and. iy == jy)) then
      if((abs(j_couple(ix,iy,jx,jy) - (-10.0)) < EPS) .and. (abs(j_couple(jx,jy,ix,iy) - (-10.0)) < EPS)) then
        call random_number(tmp)
        call random_number(tmp2)

        if(tmp2 >= 0.5) then
          j_couple(ix,iy,jx,jy) = tmp
        else
          j_couple(ix,iy,jx,jy) = -tmp
        end if
        count = count + 1
      end if
    end if
  end do

  write(OUT, '(i0)') n
  do ix = 1,n
    do iy = 1,n
      do jx = 1,n
        do jy = 1,n
          if(.not. (abs(j_couple(ix,iy,jx,jy) - (-10.0)) < EPS)) then
            if(j_couple(ix,iy,jx,jy) < 0) then
              write(OUT, '(i0,1x,i0,1x,i0,1x,i0,1x,f9.6)') ix, iy, jx, jy, j_couple(ix,iy,jx,jy)
            else
              write(OUT, '(i0,1x,i0,1x,i0,1x,i0,1x,f8.6)') ix, iy, jx, jy, j_couple(ix,iy,jx,jy)
            end if
          end if
        end do
      end do
    end do
  end do

contains

  subroutine rnd_seed
    implicit none
    integer ::  i , seedize
    integer, dimension(:), allocatable :: seed

    call random_seed(size=seedize)
    allocate(seed(seedize))
    call random_seed(get = seed)
    do i = 1, seedize
      call system_clock(count = seed(i))
    end do

    call random_seed(put = seed(:))
    deallocate(seed)
  end subroutine rnd_seed

end program make_sg


!*==strtri.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b STRTRI
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download STRTRI + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          DIAG, UPLO
!       INTEGER            INFO, LDA, N
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> STRTRI computes the inverse of a real upper or lower triangular
!> matrix A.
!>
!> This is the Level 3 BLAS version of the algorithm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!> \endverbatim
!>
!> \param[in] DIAG
!> \verbatim
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the triangular matrix A.  If UPLO = 'U', the
!>          leading N-by-N upper triangular part of the array A contains
!>          the upper triangular matrix, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of the array A contains
!>          the lower triangular matrix, and the strictly upper
!>          triangular part of A is not referenced.  If DIAG = 'U', the
!>          diagonal elements of A are also not referenced and are
!>          assumed to be 1.
!>          On exit, the (triangular) inverse of the original matrix, in
!>          the same storage format.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
!>               matrix is singular and its inverse can not be computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERcomputational
!
!  =====================================================================
      SUBROUTINE STRTRI(Uplo,Diag,N,A,Lda,Info)
      IMPLICIT NONE
!*--STRTRI113
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Diag , Uplo
      INTEGER Info , Lda , N
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL nounit , upper
      INTEGER j , jb , nb , nn
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      EXTERNAL LSAME , ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL STRMM , STRSM , STRTI2 , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      upper = LSAME(Uplo,'U')
      nounit = LSAME(Diag,'N')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( .NOT.nounit .AND. .NOT.LSAME(Diag,'U') ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('STRTRI',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Check for singularity if non-unit.
!
      IF ( nounit ) THEN
         DO Info = 1 , N
            IF ( A(Info,Info)==ZERO ) RETURN
         ENDDO
         Info = 0
      ENDIF
!
!     Determine the block size for this environment.
!
      nb = ILAENV(1,'STRTRI',Uplo//Diag,N,-1,-1,-1)
      IF ( nb<=1 .OR. nb>=N ) THEN
!
!        Use unblocked code
!
         CALL STRTI2(Uplo,Diag,N,A,Lda,Info)
!
!        Use blocked code
!
      ELSEIF ( upper ) THEN
!
!           Compute inverse of upper triangular matrix
!
         DO j = 1 , N , nb
            jb = MIN(nb,N-j+1)
!
!              Compute rows 1:j-1 of current block column
!
            CALL STRMM('Left','Upper','No transpose',Diag,j-1,jb,ONE,A, &
     &                 Lda,A(1,j),Lda)
            CALL STRSM('Right','Upper','No transpose',Diag,j-1,jb,-ONE, &
     &                 A(j,j),Lda,A(1,j),Lda)
!
!              Compute inverse of current diagonal block
!
            CALL STRTI2('Upper',Diag,jb,A(j,j),Lda,Info)
         ENDDO
      ELSE
!
!           Compute inverse of lower triangular matrix
!
         nn = ((N-1)/nb)*nb + 1
         DO j = nn , 1 , -nb
            jb = MIN(nb,N-j+1)
            IF ( j+jb<=N ) THEN
!
!                 Compute rows j+jb:n of current block column
!
               CALL STRMM('Left','Lower','No transpose',Diag,N-j-jb+1,  &
     &                    jb,ONE,A(j+jb,j+jb),Lda,A(j+jb,j),Lda)
               CALL STRSM('Right','Lower','No transpose',Diag,N-j-jb+1, &
     &                    jb,-ONE,A(j,j),Lda,A(j+jb,j),Lda)
            ENDIF
!
!              Compute inverse of current diagonal block
!
            CALL STRTI2('Lower',Diag,jb,A(j,j),Lda,Info)
         ENDDO
      ENDIF
!
!
!     End of STRTRI
!
      END SUBROUTINE STRTRI


	SUBROUTINE TI_DIFD  ( dattm1, dattm2, days, iret )
C************************************************************************
C* TI_DIFD								*
C*									*
C* This subroutine computes the time difference in days between 	*
C* two standard GEMPAK times.  The time difference is time1 - time2.	*
C*									*
C* TI_DIFD  ( DATTM1, DATTM2, DAYS, IRET )				*
C*									*
C* Input parameters:							*
C*	DATTM1		CHAR*		First GEMPAK time		*
C*	DATTM2		CHAR*		Second GEMPAK time		*
C*									*
C* Output parameters:							*
C*	DAYS		REAL  		Difference in days		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*				  	-12 = invalid time range	*
C**									*
C* Log:									*
C* M. Goodman/RDS	12/85						*
C* M. desJardins/GSFC	11/87	GEMPAK 4				*
C* M. desJardins/GSFC	 1/89	From TI_DIFF and TI_MDIF		*
C* J. Nielsen/SUNYA      2/91   Changed jday > 59 to imm > 2		*
C* I. Durham/GSC	 9/98   Cleaned up				*
C* I. Durham/GSC	10/98   Made ndays to days and made 1440 a real	*
C************************************************************************
	CHARACTER*(*)	dattm1, dattm2
C------------------------------------------------------------------------
	CALL TI_DIFF ( dattm1, dattm2, nmin, iret )
C
	days = nmin / 1440.
C
	RETURN
	END


module Dh_allDs
	! contains functions that compute the dh/dsigma matrices of the material model
	! and one main (model-indepenent) function that calls all dh/dsigma functions of the model
	! and returns the function values as a matrix

	use constants
	use material_info
	use derived_types

    implicit none

contains

	function DhDs(sigma, alpha)
		! computes the dh/dsigma matrix
		! in case of multi surface plasticity the dh/dsigma matrices of all yield surfaces
		! of the model must be computed in this subroutine
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector

		! return variable
		real(kind=dbl), dimension(size(alpha),6,n_yf) :: DhDs				! results array of rank 3

		! internal variable
		! --------------------------------------------------------------------------

		! --------------------------------------
		! computation of all dh/dsigma matrices (modified leon, ...)
		! returning dh/dsigma matrices return array
		! --------------------------------------

		DhDs(:,:,1) = Dh_1Ds(sigma, alpha)

	end function DhDs

	function Dh_1Ds(sigma, alpha)

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma						! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha						! internal variables vector

		! return variable
		real(kind=dbl), dimension(size(alpha,1),6) :: Dh_1Ds

		! internal variables
		! --------------------------------------------------------------------------

		! ...

	end function Dh_1Ds

end module Dh_allDs


cc Copyright (C) 2009: Leslie Greengard and Zydrunas Gimbutas
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date: 2011-02-22 17:34:23 -0500 (Tue, 22 Feb 2011) $
c    $Revision: 1670 $
c
c
c-----------------------------------------------------------------------------
c
c      h2dterms - determine number of terms in mpole expansions for box
c           of size "bsize" with Helmholtz parameter zk.
c
c      h2dterms_list2 - build the number of terms table for all boxes
c           in list 2
c
c      h2dterms_list2e - build the number of terms table for all boxes
c           in extended list 2
c
c-----------------------------------------------------------------------------
c
c
c
      subroutine h2dterms(bsize, zk, eps, nterms, ier)
      implicit real *8 (a-h,o-z)
c
c     Determine number of terms in mpole expansions for box of size
c     "bsize" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of H_n * J_n.
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
      pi2 = 8*datan(1.0d0)
c
      z1 = (zk*bsize)*1.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc        if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*bsize) .lt. pi2) rscale = cdabs(zk*bsize)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c
      call jbessel2d(ntmax, z2, rscale, jfun, ifder, fjder)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = (xtemp1+xtemp2)*cdabs(hfun(0))
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
c
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c
c
c-------------------------------------------------------------
      subroutine h2dterms2(bsize, zk, eps, nterms, np, ier)
      implicit real *8 (a-h,o-z)
c
c     Determine number of terms in mpole expansions for box of size
c     "bsize" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of H_n+np * J_n.
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, z4,jfun(0:20000), jfun2(0:20000),
     1             ht0,ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
c
      z1 = (zk*bsize)*1.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc        if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*bsize) .lt. 1.0d0) rscale = cdabs(zk*bsize)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c
      call jbessel2d(ntmax, z2, rscale, jfun, ifder, fjder)

      z4 = 0.001*zk/2
cc       z4 = 5.0d0/zk
      call prin2('z4=*',z4,2)
      call jbessel2d(ntmax,z4,rscale,jfun2,ifder,fjder)

cc      call prin2('jfun2=*',jfun2,20)
c
      xtemp1 = cdabs(jfun(0)*hfun(np)*jfun2(np))
      xtemp2 = cdabs(jfun(1)*hfun(np+1)*jfun2(np))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax-np
        xtemp1 = cdabs(jfun(j)*hfun(j+np)*jfun2(np))
        xtemp2 = cdabs(jfun(j-1)*hfun(j+np-1)*jfun2(np))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
c
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c------------------------------------------------------------------------
c
c
c
      subroutine h2dterms_far(bsize, zk, eps, nterms, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "bsize" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of H_n * J_n.
c
c     This routine aasumes slightly larger separation of boxes: the
c     first unit box is located at the origin and the second box is
c     located at (3,0,0).
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
c
      z1 = (zk*bsize)*2.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc        if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*bsize) .lt. 1.0d0) rscale = cdabs(zk*bsize)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c
      call jbessel2d(ntmax, z2, rscale, jfun, ifder, fjder)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_list2(bsize, zk, eps, itable, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "bsize" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Build nterms table for all boxes in list 2
c
c     Maximum number of terms is 1000, which
c     works for boxes up to 160 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      integer nterms_table(2:3,0:3)
      integer itable(-3:3,-3:3)
c
      ier = 0
c
c
c       first box in x direction
c
ccc      z1 = (zk*size)*1.5d0
c
c       second box in x direction
c
ccc      z1 = (zk*size)*2.5d0
c
c       on the diagonal
c
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*3
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*5
c
        do 1800 ii=2,3
        do 1800 jj=0,3
c
        dx=ii
        dy=jj
c
        if( dx .gt. 0 ) dx=dx-.5
        if( dy .gt. 0 ) dy=dy-.5
c
        rr=sqrt(dx*dx+dy*dy)
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(2.0d0)/2*5,1)
c
        z1 = (zk*bsize)*rr

c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc      if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*bsize) .lt. 1.0d0) rscale = cdabs(zk*bsize)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c
      call jbessel2d(ntmax, z2, rscale, jfun, ifder, fjder)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          goto 1600
        endif
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
 1600   continue
c
        nterms_table(ii,jj)=nterms
c
 1800   continue
c
ccc        call prinf('nterms=*',nterms_table,2*4*4)
c
c       build the rank table for all boxes in list 2
c
        do i=-3,3
        do j=-3,3
        itable(i,j)=0
        enddo
        enddo
c
        do 2200 i=-3,3
        do 2200 j=-3,3
c
        if( abs(i) .gt. 1 ) then
        itable(i,j)=nterms_table(abs(i),abs(j))
        else if( abs(j) .gt. 1) then
        itable(i,j)=nterms_table(abs(j),abs(i))
        endif
c
 2200   continue
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_list2e(bsize, zk, eps, itable, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "bsize" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Build nterms table for all boxes in extended list 2
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      integer nterms_table(2:7,0:7)
      integer itable(-7:7,-7:7)
c
      ier = 0
c
c
c       first box in x direction
c
ccc      z1 = (zk*size)*1.5d0
c
c       second box in x direction
c
ccc      z1 = (zk*size)*2.5d0
c
c       on the diagonal
c
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*3
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*5
c
        do 1800 ii=2,7
        do 1800 jj=0,7
c
        dx=ii
        dy=jj
c
        if( dx .gt. 0 ) dx=dx-.5
        if( dy .gt. 0 ) dy=dy-.5
c
        rr=sqrt(dx*dx+dy*dy)
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(2.0d0)/2*5,1)
c
        z1 = (zk*bsize)*rr

c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc      if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*bsize) .lt. 1.0d0) rscale = cdabs(zk*bsize)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c
      call jbessel2d(ntmax, z2, rscale, jfun, ifder, fjder)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          goto 1600
        endif
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
 1600   continue
c
        nterms_table(ii,jj)=nterms
c
 1800   continue
c
ccc        call prinf('nterms=*',nterms_table,2*4*4)
c
c       build the rank table for all boxes in extended list 2
c
        do i=-7,7
        do j=-7,7
        itable(i,j)=0
        enddo
        enddo
c
        do 2200 i=-7,7
        do 2200 j=-7,7
c
        if( abs(i) .gt. 2 ) then
        itable(i,j)=nterms_table(abs(i),abs(j))
        else if( abs(j) .gt. 2) then
        itable(i,j)=nterms_table(abs(j),abs(i))
        endif
c
 2200   continue
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_eval(itype, bsize, zk, eps, nterms, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "bsize" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
c
      z1 = (zk*bsize)*1.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc      if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 1000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*bsize) .lt. 1.0d0) rscale = cdabs(zk*bsize)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
        z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c
c       corners included
        if( itype .eq. 1 ) z2 = (zk*bsize) * dsqrt(2d0)/2.d0
c       edges included, no corners
        if( itype .eq. 2 ) z2 = (zk*bsize) * dsqrt(1d0)/2.d0
c       center only
        if( itype .eq. 3 ) z2 = (zk*bsize) * 1.0d0/2.d0
c       center only, small interior sphere
        if( itype .eq. 4 ) z2 = (zk*bsize) * 0.8d0/2.d0
c
      call jbessel2d(ntmax, z2, rscale, jfun, ifder, fjder)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
c
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c
c
c


        subroutine genlmass (x, shp,shgl)
c
        use pointer_data
c
        include "common.h"
        include "mpif.h"
c
        real*8 x(numnp,nsd)
c
        real*8 shp(MAXTOP,maxsh,MAXQPT),
     &            shgl(MAXTOP,nsd,maxsh,MAXQPT)
c
        real*8, allocatable :: tmpshp(:,:), tmpshgl(:,:,:)

c
c gmass came in via pointer_data and will
c be available wherever it is included  (allocate it now).
c

        allocate (gmass(nshg))
        gmass=zero
c
c.... loop over the element-blocks
c
        do iblk = 1, nelblk
          iel    = lcblk(1,iblk)
          lelCat = lcblk(2,iblk)
          lcsyst = lcblk(3,iblk)
          iorder = lcblk(4,iblk)
          nenl   = lcblk(5,iblk) ! no. of vertices per element
          nshl   = lcblk(10,iblk)
          mattyp = lcblk(7,iblk)
          npro   = lcblk(1,iblk+1) - iel
          inum   = iel + npro - 1
          ngauss = nint(lcsyst)
c
c
c.... compute and assemble the residual and tangent matrix
c
          allocate (tmpshp(nshl,MAXQPT))
          allocate (tmpshgl(nsd,nshl,MAXQPT))
          tmpshp(1:nshl,:) = shp(lcsyst,1:nshl,:)
          tmpshgl(:,1:nshl,:) = shgl(lcsyst,:,1:nshl,:)

          call AsImass (x,       tmpshp,
     &                  tmpshgl, mien(iblk)%p,
     &                  gmass)

          deallocate ( tmpshp )
          deallocate ( tmpshgl )
c
c.... end of interior element loop
c
       enddo

      return
      end

        subroutine AsImass (x,      shp,
     &                     shgl,    ien,
     &                     gmass)
c
c----------------------------------------------------------------------
c
c This routine computes and assembles the mass corresponding to the
c each node.
c
c Ken Jansen, Winter 2000.  (Fortran 90)
c----------------------------------------------------------------------
c
      include "common.h"
c
        real*8 x(numnp,nsd),
     &         shp(nshl,maxsh),       shgl(nsd,nshl,ngauss),
     &         gmass(nshg)

        integer ien(npro,nshl)

c
        real*8    xl(npro,nenl,nsd),    WdetJ(npro),
     &            sgn(npro,nshl),       shape(npro,nshl),
     &            locmass(npro,nshl),   shg(npro,nshl,nsd),
     &            fmstot(npro),         temp(npro),
     &            dxidx(npro,nsd,nsd),  shdrv(npro,nsd,nshl)

        integer aa
c
c
c
c.... gather the variables
c
c
c.... get the matrix of mode signs for the hierarchic basis functions.
c
        if (ipord .gt. 1) then
           call getsgn(ien,sgn)
        endif

        call localx(x,      xl,     ien,    nsd,    'gather  ')
c
c.... zero the matrices if they are being recalculated
c

        locmass=zero
        fmstot=zero

        do intp = 1, ngauss

           if (Qwt(lcsyst,intp) .eq. zero) cycle ! precaution
c
c.... get the hierarchic shape functions at this int point
c
           call getshp(shp,          shgl,      sgn,
     &                 shape,        shdrv)

c
c.... --------------------->  Element Metrics  <-----------------------
c
           call e3metric( xl,         shdrv,       dxidx,
     &                    shg,        WdetJ)

c
c  get this quad points contribution to the integral of the square of  the
c  shape function
c
           do aa = 1,nshl
              locmass(:,aa)= locmass(:,aa)
     &             + shape(:,aa)*shape(:,aa)*WdetJ
           enddo
c
c also accumulate this quad points contribution to the integral of the element
c volume (integral Na^2 d Omega)
c
           fmstot= fmstot + WdetJ ! intregral  d Omega
c
c.... end of integration loop
c
        enddo
c
c.... lumped mass if needed   Note that the locmass factors accumulated
c     over integration points and weighted with WdetJ already.
c

c.... scale the LHS matrix contribution with special lumping weighting
c
c  The first term we collect is the trace of integral Na^2 d Omega
c
        temp = zero
        do aa = 1, nshl
           temp = temp + locmass(:,aa) !reusing temp to save memory
        enddo

c
c scale the diagonal so that the trace will still yield Omega^e (the volume
c of the element)
c
        do aa = 1, nshl
           locmass(:,aa) = locmass(:,aa) * fmstot / temp
        enddo
c
c.... assemble the residual
c
        call local (gmass,    locmass,     ien,    1,  'scatter ')

c
c.... end
c
        return
        end

      subroutine lmassadd ( ac,       res,
     &                      rowp,     colm,
     &                      lhsK,     gmass)
c
      include "common.h"
c
      real*8 ac(nshg,ndof), res(nshg,4), tmp,tmp1
      real*8 lhsK(9,nnz_tot), gmass(nshg), rho(nshg)
      integer rowp(nnz*nshg),  colm(nshg+1)
      integer	n,	k
c
      integer sparseloc
c
c
      rho=datmat(1,1,1)  ! needs to be generalized for VOF or level set
      tmp1=flmpl*almi
      if((flmpl.ne.0).and.(lhs.eq.1)) then
c
c.... Add lmass to diag of lhsK
c
         do n = 1, nshg
	    k = sparseloc( rowp(colm(n)), colm(n+1)-colm(n), n )
     &       + colm(n)-1
            tmp=gmass(n)*tmp1*rho(n)
	    lhsK(1,k) = lhsK(1,k) + tmp
	    lhsK(5,k) = lhsK(5,k) + tmp
	    lhsK(9,k) = lhsK(9,k) + tmp
         enddo
      endif

      tmp1=flmpr

      if(flmpr.ne.0) then
         rho=rho*gmass*tmp1  ! reuse rho
         res(:,1)=res(:,1)-ac(:,1)*rho(:)
         res(:,2)=res(:,2)-ac(:,2)*rho(:)
         res(:,3)=res(:,3)-ac(:,3)*rho(:)
      endif

      return
      end

      subroutine lmassaddSclr ( ac,       res,
     &                          rowp,     colm,
     &                          lhsS,     gmass)
c
      include "common.h"
c
      real*8 ac(nshg),       res(nshg), tmp, tmp1
      real*8 lhsS(nnz_tot), gmass(nshg), rho(nshg)
      integer rowp(nnz*nshg),  colm(nshg+1)
      integer	n,	k
c
      integer sparseloc
c
c
      rho=datmat(1,1,1)  ! needs to be generalized for VOF or level set
      tmp1=flmpl*almi
      if((flmpl.ne.0).and.(lhs.eq.1)) then
c
c.... Add lmass to diag of lhsK
c
         do n = 1, nshg
	    k = sparseloc( rowp(colm(n)), colm(n+1)-colm(n), n )
     &       + colm(n)-1
            tmp=gmass(n)*tmp1*rho(n)
	    lhsS(k) = lhsS(k) + tmp
         enddo
      endif

      tmp1=flmpr
      if(flmpr.ne.0) then
         rho=rho*gmass*tmp1  ! reuse rho
         res(:)=res(:)-ac(:)*rho(:)
      endif

      return
      end


      SUBROUTINE SRFACE (X,Y,Z,M,MX,NX,NY,S,STEREO)
C
C +-----------------------------------------------------------------+
C |                                                                 |
C |                Copyright (C) 1986 by UCAR                       |
C |        University Corporation for Atmospheric Research          |
C |                    All Rights Reserved                          |
C |                                                                 |
C |                 NCARGRAPHICS  Version 1.00                      |
C |                                                                 |
C +-----------------------------------------------------------------+
C
C
C
C DIMENSION OF           X(NX),Y(NY),Z(MX,NY),M(2,NX,NY),S(6)
C ARGUMENTS
C
C LATEST REVISION        MARCH 1984
C
C PURPOSE                SRFACE DRAWS A PERSPECTIVE PICTURE OF A
C                        FUNCTION OF TWO VARIABLES WITH HIDDEN LINES
C                        REMOVED.  THE FUNCTION IS APPROXIMATED BY A
C                        TWO-DIMENSIONAL ARRAY OF HEIGHTS.
C
C USAGE                  IF THE FOLLOWING ASSUMPTIONS ARE MET, USE
C                                 CALL EZSRFC (Z,M,N,ANGH,ANGV,WORK)
C
C                          ASSUMPTIONS:
C                                  .THE ENTIRE ARRAY IS TO BE DRAWN,
C                                  .THE DATA IS EQUALLY SPACED (IN THE
C                               X-Y PLANE),
C                                  .NO STEREO PAIRS,
C                                  .SCALING     IS CHOSEN INTERNALLY.
C
C                        IF THESE ASSUMPTIONS ARE NOT MET USE
C                                 CALL SRFACE (X,Y,Z,M,MX,NX,NY,S,
C                                                STEREO)
C
C ARGUMENTS
C
C ON INPUT               Z
C FOR EZSRFC                     THE M BY N ARRAY TO BE DRAWN.
C
C                        M
C                          THE FIRST DIMENSION OF Z.
C
C                        N
C                          THE SECOND DIMENSION OF Z.
C
C                        ANGH
C                          ANGLE IN DEGREES IN THE X-Y PLANE TO THE
C                          LINE OF SIGHT (COUNTER-CLOCK WISE FROM
C                          THE PLUS-X AXIS).
C
C                        ANGV
C                          ANGLE IN DEGREES FROM THE X-Y PLANE TO
C                          THE LINE OF SIGHT (POSITIVE ANGLES ARE
C                          ABOVE THE MIDDLE Z, NEGATIVE BELOW).
C
C                        WORK
C                          A SCRATCH STORAGE DIMENSIONED AT LEAST
C                          2*M*N+M+N.
C
C ON OUTPUT              Z, M, N, ANGH, ANGV ARE UNCHANGED.  WORK
C FOR EZSRFC             HAS BEEN WRITTEN IN.
C
C
C ARGUMENTS
C
C ON INPUT               X
C FOR SRFACE                     A LINEAR ARRAY NX LONG CONTAINING THE X
C                          COORDINATES OF THE POINTS IN THE SURFACE
C                          APPROXIMATION.  SEE NOTE, BELOW.
C
C                        Y
C                          THE LINEAR ARRAY NY LONG CONTAINING THE
C                          Y COORDINATES OF THE POINTS IN THE
C                          SURFACE APPROXIMATION.  SEE NOTE, BELOW.
C
C                        Z
C                          AN ARRAY MX BY NY CONTAINING THE SURFACE
C                          TO BE DRAWN IN NX BY NY CELLS.
C                          Z(I,J) = F(X(I),Y(J)).  SEE NOTE, BELOW.
C
C                        M
C                          SCRATCH ARRAY AT LEAST 2*NX*NY WORDS
C                          LONG.
C
C                        MX
C                          FIRST DIMENSION OF Z.
C
C                        NX
C                          NUMBER OF POINTS IN THE X DIRECTION
C                          IN Z.  WHEN PLOTTING AN ENTIRE ARRAY,
C                          MX=NX.  SEE APPENDIX 1 OF THE GRAPHICS
C                          CHAPTER FOR AN EXPLANATION OF USING THIS
C                          ARGUMENT LIST TO PROCESS ANY PART OF AN
C                          ARRAY.
C
C                        NY
C                          NUMBER OF POINTS IN THE Y DIRECTION IN Z.
C
C                        S
C                          S DEFINES THE LINE OF SIGHT.  THE VIEWER'S
C                          EYE IS AT (S(1), S(2), S(3)) AND THE
C                          POINT LOOKED AT IS AT (S(4), S(5), S(6)).
C                          THE EYE SHOULD BE OUTSIDE THE BLOCK WITH
C                          OPPOSITE CORNERS (X(1), Y(1), ZMIN) AND
C                          (X(NX), Y(NY), ZMAX) AND THE POINT LOOKED
C                          AT SHOULD BE INSIDE IT.      FOR     A NICE
C                          PERSPECTIVE EFFECT, THE DISTANCE BETWEEN
C                          THE EYE AND THE POINT LOOKED AT SHOULD BE
C                          5 TO 10 TIMES THE SIZE OF THE BLOCK.  SEE
C                          NOTE, BELOW.
C
C                        STEREO
C                          FLAG TO INDICATE IF STEREO PAIRS ARE TO
C                          BE DRAWN.  0.0 MEANS NO STEREO PAIR (ONE
C                          PICTURE).  NON-ZERO MEANS PUT OUT TWO
C                          PICTURES.  THE VALUE OF STEREO IS THE
C                          RELATIVE ANGLE BETWEEN THE EYES.  A VALUE
C                          OF 1.0 PRODUCES STANDARD SEPARATION.
C                          NEGATIVE STEREO REVERSES THE LEFT AND
C                          RIGHT FIGURES.
C
C ON OUTPUT              X, Y, Z, MX, NX, NY, S, STEREO ARE
C FOR SRFACE             UNCHANGED.  M HAS BEEN WRITTEN IN.
C
C NOTES                  . THE RANGE OF Z COMPARED WITH THE RANGE
C                          OF X AND Y DETERMINES THE SHAPE OF THE
C                          PICTURE.  THEY ARE ASSUMED TO BE IN THE
C                          SAME UNITS AND NOT WILDLY DIFFERENT IN
C                          MAGNITUDE.  S IS ASSUMED TO BE IN THE
C                          SAME UNITS AS X, Y, AND Z.
C                        . PICTURE SIZE CAN BE MADE RELATIVE TO
C                          DISTANCE.  SEE COMMENTS IN SETR.
C                        . TRN32S CAN BE USED TO TRANSLATE FROM 3
C                          SPACE TO 2 SPACE.  SEE COMMENTS THERE.
C                        . DATA WITH EXTREME DISCONTINUITIES MAY
C                          CAUSE VISIBILITY ERRORS.  IF THIS PROBLEM
C                          OCCURS, USE A DISTANT EYE POSITION
C                          AWAY FROM THE +Z AXIS.
C                        . THE DEFAULT LINE COLOR IS SET TO
C                          COLOR INDEX 1.  IF THE USER WISHES TO
C                          CHANGE THE LINE COLOR, HE CAN DO SO BY
C                          DEFINING COLOR INDEX 1 BEFORE CALLING
C                          SRFACE, OR BY PUTTING THE COMMON BLOCK
C                          SRFINT IN HIS CALLING PROGRAM AND
C                          DEFINING AND USING COLOR INDEX ISRFMJ
C                          (DEFAULTED TO 1 IN BLOCKDATA.)
C
C ENTRY POINTS           SRFACE, SRFGK, EZSRFC, SETR, DRAWS, TRN32S,
C                        CLSET, CTCELL, SRFABD
C
C COMMON BLOCKS          PWRZ1S, SRFBLK, SRFINT, SRFIP1
C
C I/O                    PLOTS
C
C PRECISION              SINGLE
C
C LANGUAGE               FORTRAN
C
C HISTORY                CONVERTED TO FORTRAN 77 AND GKS IN MARCH 1984.
C
C                        PREPARED FOR SIGGRAPH, AUGUST 1976.
C
C                        STANDARDIZED IN JANUARY 1973.
C
C                        WRITTEN IN DECEMBER 1971.      REPLACED K.S.+G.
C                        ALGORITHM CALLED SOLIDS AT NCAR.
C
C
C ALGORITHM              HIGHEST SO FAR IS VISIBLE FROM ABOVE.  (SEE
C                        REFERENCE.)
C
C REFERENCE              WRIGHT, T.J., A TWO SPACE SOLUTION TO THE
C                        HIDDEN LINE PROBLEM FOR PLOTTING A FUNCTION
C                        OF TWO VARIABLES.      IEEE TRANS.     COMP.,
C                        PP 28-33, JANUARY 1973.
C
C ACCURACY               IF THE ENDS OF A LINE SEGMENT ARE VISIBLE,
C                        THE MIDDLE IS ASSUMED VISIBLE.
C
C TIMING                 PROPORTIONAL TO NX*NY.
C
C
C INTERNAL PARAMETERS    NAME   DEFAULT  FUNCTION
C                        ----   -------  --------
C                        IFR        1    -1  CALL FRAME FIRST.
C                                         0  DO NOT CALL FRAME.
C                                        +1  CALL FRAME WHEN DONE.
c +NOAO:  The value of ifr has been changed from its default of +1 to 0.
c -NOAO
C
C                        ISTP       0    STEREO TYPE IF STEREO
C                                        NON-ZERO.
C                                        -1  ALTERNATING FRAMES,
C                                                  SLIGHTLY OFFSET (FOR
C                                                  MOVIES.  IROTS = 0).
C                                               0  BLANK FRAME BETWEEN
C                                                  FOR STEREO   SLIDE.
C                                                  IROTS = 1).
C                                        +1  BOTH ON SAME FRAME.
C                                                  (LEFT PICTURE TO LEFT
C                                                  SIDE.  IROTS = 0).
C
C                        IROTS      0     0  +Z IN VERTICAL PLOTTING
C                                                  DIRECTION (CINE MODE).
C                                        +1  +Z IN HORIZONTAL
C                                                  PLOTTING DIRECTION
C                                                  (COMIC MODE).
C
C                        IDRX       1    +1  DRAW LINES OF CONSTANT
C                                                  X.
C                                               0  DO   NOT.
C
C                        IDRY       1    +1  DRAW LINES OF CONSTANT
C                                                  Y.
C                                               0  DO   NOT.
C
C                        IDRZ       0    +1  DRAW LINES OF CONSTANT
C                                                  Z (CONTOUR   LINES).
C                                               0  DO   NOT.
C
C                        IUPPER         0        +1  DRAW UPPER SIDE OF
C                                                  SURFACE.
C                                        0  DRAW BOTH SIDES.
C                                        -1  DRAW LOWER SIDE.
C
C                        ISKIRT         0        +1  DRAW A SKIRT AROUND THE
C                                                  SURFACE.
C                                                  BOTTOM = HSKIRT.
C                                               0  DO   NOT.
C
C                        NCLA       6    APPROXIMATE NUMBER OF
C                                        LEVELS OF CONSTANT Z THAT
C                                        ARE DRAWN IF LEVELS ARE NOT
C                                        SPECIFIED.  40 LEVELS
C                                        MAXIMUM.
C
C                        THETA    .02    ANGLE IN RADIANS BETWEEN
C                                        EYES FOR STEREO PAIRS.
C
C                        HSKIRT    0.    HEIGHT OF SKIRT
C                                                  (IF ISKIRT   = 1).
C
C                        CHI       0.    HIGHEST LEVEL OF CONSTANT
C                                        Z.
C
C                        CLO       0.    LOWEST LEVEL OF CONSTANT Z.
C
C                        CINC      0.    INCREMENT BETWEEN LEVELS.
C
C                          [IF CHI, CLO, OR CINC IS ZERO, A NICE
C                               VALUE IS GENERATED AUTOMATICALLY.]
C
C                        IOFFP     0     FLAG TO CONTROL USE OF SPECIAL
C                                        VALUE FEATURE.  DO NOT HAVE
C                                        BOTH IOFFP=1 AND ISKIRT=1.
C                                               0 FEATURE NOT   IN USE
C                                        +1  FEATURE IN USE.  NO LINES
C                                                  DRAWN TO DATA POINTS IN Z
C                                                  THAT ARE EQUAL TO SPVAL.
C
C                        SPVAL     0.    SPECIAL VALUE USED TO MARK UN-
C                                        KNOWN DATA WHEN IOFFP=1.
C
C
C
      DIMENSION       X(NX)      ,Y(NY)    ,Z(MX,NY), M(2,NX,NY),
     1                S(6)
      DIMENSION       WIN1(4)    ,VP1(4)           ,LASF(13)
      COMMON /SRFINT/ ISRFMJ     ,ISRFMN          ,ISRFTX
c +NOAO: common block added 4NOV85 to allow user control of viewport
      common /noaovp/ vpx1, vpx2, vpy1, vpy2
c -NOAO
c +NOAO: Blockdata srfabd rewritten as run time initialization
c     EXTERNAL        SRFABD
      call srfabd
c -NOAO
      CALL Q8QST4 ('GRAPHX','SRFACE','SRFACE','VERSION 01')
C
C     THIS DRIVER SAVES THE CURRENT NORMALIZATION TRANSFORMATION
C     INFORMATION, DEFINES THE NORMALIZATION TRANSFORMATION
C     APPROPRIATE FOR SRFGK, CALLS SRFGK, AND RESTORES THE ORIGINAL
C     NORMALIZATION TRANSFORMATION.
C
C     GET CURRENT NORMALIZATION TRANSFORMATION NUMBER
C
      CALL GQCNTN (IER,NTORIG)
C
C     STORE WINDOW AND VIEWPORT OF NORMALIZATION TRANSFORMATION 1
C
      CALL GQNT (NTORIG,IER,WIN1,VP1)
      CALL GETUSV('LS',IOLLS)
C
C     SET WINDOW AND VIEWPORT FOR SRFGK
C
c     CALL SET(0.,1.,0.,1.,1.,1024.,1.,1024.,1)
c +NOAO: viewport limits now stored in common block noaovp
      CALL SET(vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1)
c -NOAO
C
C     SET LINE COLOR TO INDIVIDUAL (SAVE CURRENT SETTING)
C
      CALL GQASF (IER,LASF)
      LASFSV  = LASF(3)
      LASF(3) = 1
      CALL GSASF(LASF)
C
C     SET LINE COLOR INDEX TO COMMON VARIABLE ISRFMJ (SAVE
C     CURRENT SETTING)
C
      CALL GQPLCI (IER,LCISV)
      CALL GSPLCI (ISRFMJ)
C
C     DRAW PLOT
C
      CALL SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO)
C
C     RESTORE INITIAL LINE COLOR SETTINGS
C
      LASF(3) = LASFSV
      CALL GSASF(LASF)
      CALL GSPLCI (LCISV)
C
C     RESTORE ORIGINAL NORMALIZATION TRANSFORMATION
C
      CALL SET(VP1(1),VP1(2),VP1(3),VP1(4),WIN1(1),WIN1(2),
     -         WIN1(3),WIN1(4),IOLLS)
      CALL GSELNT (NTORIG)
C
      RETURN
      END
      SUBROUTINE SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO)
C
      DIMENSION       X(NX)      ,Y(NY)   ,Z(MX,NY)  ,M(2,NX,NY) ,
     1                S(6)
      DIMENSION       MXS(2)     ,MXF(2) ,MXJ(2) ,MYS(2),
     1                MYF(2)     ,MYJ(2)
      COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41)     ,NCL,
     1                LL         ,FACT       ,IROT       ,NDRZ,
     2                NUPPER     ,NRSWT      ,BIGD       ,UMIN,
     3                UMAX       ,VMIN       ,VMAX       ,RZERO,
     4                IOFFP      ,NSPVAL     ,SPVAL      ,BIGEST
      COMMON /PWRZ1S/ XXMIN      ,XXMAX      ,YYMIN      ,YYMAX,
     1                ZZMIN      ,ZZMAX      ,DELCRT     ,EYEX,
     2                EYEY       ,EYEZ
      COMMON /SRFIP1/ IFR        ,ISTP       ,IROTS      ,IDRX ,
     1                IDRY       ,IDRZ       ,IUPPER     ,ISKIRT,
     2                NCLA       ,THETA      ,HSKIRT     ,CHI,
     3                CLO        ,CINC       ,ISPVAL
c +NOAO:
      common /noaovp/ vpx1, vpx2, vpy1, vpy2
c -NOAO
C
      DATA JF, IF, LY, LX, ICNST /1, 1, 2, 2, 0/
      CALL Q8QST4 ('GRAPHX','SRFACE','SRFGK','VERSION 01')
      BIGEST = R1MACH(2)
      MMXX = MX
      NNXX = NX
      NNYY = NY
      STER = STEREO
      NXP1 = NNXX+1
      NYP1 = NNYY+1
      NLA = NCLA
      NSPVAL = ISPVAL
      NDRZ = IDRZ
      IF (IDRZ .NE. 0)
     1    CALL CLSET (Z,MMXX,NNXX,NNYY,CHI,CLO,CINC,NLA,40,CL,NCL,
     2                ICNST,IOFFP,SPVAL,BIGEST)
      IF (IDRZ .NE. 0) NDRZ = 1-ICNST
      STHETA = SIN(STER*THETA)
      CTHETA = COS(STER*THETA)
      RX = S(1)-S(4)
      RY = S(2)-S(5)
      RZ = S(3)-S(6)
      D1 = SQRT(RX*RX+RY*RY+RZ*RZ)
      D2 = SQRT(RX*RX+RY*RY)
      DX = 0.
      DY = 0.
      IF (STEREO .EQ. 0.) GO TO  20
      D1 = D1*STEREO*THETA
      IF (D2 .GT. 0.) GO TO  10
      DX = D1
      GO TO  20
   10 AGL = ATAN2(RX,-RY)
      DX = D1*COS(AGL)
      DY = D1*SIN(AGL)
   20 IROT = IROTS
      NPIC = 1
      IF (STER .NE. 0.) NPIC = 2
      FACT = 1.
      IF (NRSWT .NE. 0) FACT = RZERO/D1
      IF (ISTP.EQ.0 .AND. STER.NE.0.) IROT = 1
      DO 570 IPIC=1,NPIC
         NUPPER = IUPPER
         IF (IFR .LT. 0) CALL FRAME
C
C SET UP MAPING FROM FLOATING POINT 3-SPACE TO CRT SPACE.
C
         SIGN1 = IPIC*2-3
         EYEX = S(1)+SIGN1*DX
         POIX = S(4)+SIGN1*DX
         EYEY = S(2)+SIGN1*DY
         POIY = S(5)+SIGN1*DY
         EYEZ = S(3)
         POIZ = S(6)
         LL = 0
         XEYE = EYEX
         YEYE = EYEY
         ZEYE = EYEZ
         CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0)
         LL = IPIC+2*ISTP+3
         IF (STER .EQ. 0.) LL = 1
         IF (NRSWT .NE. 0) GO TO 100
         XXMIN = X(1)
         XXMAX = X(NNXX)
         YYMIN = Y(1)
         YYMAX = Y(NNYY)
         UMIN = BIGEST
         VMIN = BIGEST
         ZZMIN = BIGEST
         UMAX = -UMIN
         VMAX = -VMIN
         ZZMAX = -ZZMIN
         DO  40 J=1,NNYY
            DO  30 I=1,NNXX
                ZZ = Z(I,J)
                IF (IOFFP.EQ.1 .AND. ZZ.EQ.SPVAL) GO TO 30
                ZZMAX = AMAX1(ZZMAX,ZZ)
                ZZMIN = AMIN1(ZZMIN,ZZ)
                CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1)
                UMAX = AMAX1(UMAX,UT)
                UMIN = AMIN1(UMIN,UT)
                VMAX = AMAX1(VMAX,VT)
                VMIN = AMIN1(VMIN,VT)
   30             CONTINUE
   40    CONTINUE
         IF (ISKIRT .NE. 1) GO TO  70
         NXSTP = NNXX-1
         NYSTP = NNYY-1
         DO  60 J=1,NNYY,NYSTP
            DO  50 I=1,NNXX,NXSTP
                CALL TRN32S (X(I),Y(J),HSKIRT,UT,VT,DUMMY,1)
                UMAX = AMAX1(UMAX,UT)
                UMIN = AMIN1(UMIN,UT)
                VMAX = AMAX1(VMAX,VT)
                VMIN = AMIN1(VMIN,VT)
   50             CONTINUE
   60    CONTINUE
   70    CONTINUE
         WIDTH = UMAX-UMIN
         HIGHT = VMAX-VMIN
         DIF = .5*(WIDTH-HIGHT)
         IF (DIF)  80,100, 90
   80    UMIN = UMIN+DIF
         UMAX = UMAX-DIF
         GO TO 100
   90    VMIN = VMIN-DIF
         VMAX = VMAX+DIF
  100    XEYE = EYEX
         YEYE = EYEY
         ZEYE = EYEZ
         CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0)
         DO 120 J=1,NNYY
            DO 110 I=1,NNXX
                CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1)
                M(1,I,J)        = UT
                M(2,I,J)        = VT
  110             CONTINUE
  120    CONTINUE
C
C INITIALIZE UPPER AND LOWER VISIBILITY ARRAYS
C
         DO 130 K=1,1024
            LIMU(K) = 0
            LIML(K) = 1024
  130    CONTINUE
C
C FIND ORDER TO DRAW LINES
C
         NXPASS = 1
         IF (S(1) .GE. X(NNXX)) GO TO 160
         IF (S(1) .LE. X(1)) GO TO 170
         DO 140 I=2,NNXX
            LX = I
            IF (S(1) .LE. X(I)) GO TO 150
  140    CONTINUE
  150    MXS(1) = LX-1
         MXJ(1) = -1
         MXF(1) = 1
         MXS(2) = LX
         MXJ(2) = 1
         MXF(2) = NNXX
         NXPASS = 2
         GO TO 180
  160    MXS(1) = NNXX
         MXJ(1) = -1
         MXF(1) = 1
         GO TO 180
  170    MXS(1) = 1
         MXJ(1) = 1
         MXF(1) = NNXX
  180    NYPASS = 1
         IF (S(2) .GE. Y(NNYY)) GO TO 210
         IF (S(2) .LE. Y(1)) GO TO 220
         DO 190 J=2,NNYY
            LY = J
            IF (S(2) .LE. Y(J)) GO TO 200
  190    CONTINUE
  200    MYS(1) = LY-1
         MYJ(1) = -1
         MYF(1) = 1
         MYS(2) = LY
         MYJ(2) = 1
         MYF(2) = NNYY
         NYPASS = 2
         GO TO 230
  210    MYS(1) = NNYY
         MYJ(1) = -1
         MYF(1) = 1
         GO TO 230
  220    MYS(1) = 1
         MYJ(1) = 1
         MYF(1) = NNYY
C
C PUT ON SKIRT ON FRONT SIDE IF WANTED
C
  230    IF (NXPASS.EQ.2 .AND. NYPASS.EQ.2) GO TO 490
         IF (ISKIRT .EQ. 0) GO TO 290
         IN = MXS(1)
         IF = MXF(1)
         JN = MYS(1)
         JF = MYF(1)
         IF (NYPASS .NE. 1) GO TO 260
         CALL TRN32S (X(1),Y(JN),HSKIRT,UX1,VX1,DUMMY,1)
         CALL TRN32S (X(NNXX),Y(JN),HSKIRT,UX2,VX2,DUMMY,1)
         QU = (UX2-UX1)/(X(NNXX)-X(1))
         QV = (VX2-VX1)/(X(NNXX)-X(1))
         YNOW = Y(JN)
         DO 240 I=1,NNXX
            CALL TRN32S (X(I),YNOW,HSKIRT,RU,RV,DUMMY,1)
            CALL DRAWS (IFIX(RU),IFIX(RV),M(1,I,JN),M(2,I,JN),1,0)
  240    CONTINUE
         CALL DRAWS (IFIX(UX1),IFIX(VX1),IFIX(UX2),IFIX(VX2),1,1)
         IF (IDRY .NE. 0) GO TO 260
         DO 250 I=2,NNXX
            CALL DRAWS (M(1,I-1,JN),M(2,I-1,JN),M(1,I,JN),M(2,I,JN),1,1)
  250    CONTINUE
  260    IF (NXPASS .NE. 1) GO TO 290
         CALL TRN32S (X(IN),Y(1),HSKIRT,UY1,VY1,DUMMY,1)
         CALL TRN32S (X(IN),Y(NNYY),HSKIRT,UY2,VY2,DUMMY,1)
         QU = (UY2-UY1)/(Y(NNYY)-Y(1))
         QV = (VY2-VY1)/(Y(NNYY)-Y(1))
         XNOW = X(IN)
         DO 270 J=1,NNYY
            CALL TRN32S (XNOW,Y(J),HSKIRT,RU,RV,DUMMY,1)
            CALL DRAWS (IFIX(RU),IFIX(RV),M(1,IN,J),M(2,IN,J),1,0)
  270    CONTINUE
         CALL DRAWS (IFIX(UY1),IFIX(VY1),IFIX(UY2),IFIX(VY2),1,1)
         IF (IDRX .NE. 0) GO TO 290
         DO 280 J=2,NNYY
            CALL DRAWS (M(1,IN,J-1),M(2,IN,J-1),M(1,IN,J),M(2,IN,J),1,1)
  280    CONTINUE
C
C PICK PROPER ALGORITHM
C
  290    LI = MXJ(1)
         MI = MXS(1)-LI
         NI = IABS(MI-MXF(1))
         LJ = MYJ(1)
         MJ = MYS(1)-LJ
         NJ = IABS(MJ-MYF(1))
C
C WHEN LINE OF SIGHT IS NEARER TO PARALLEL TO THE X AXIS,
C HAVE J LOOP OUTER-MOST, OTHERWISE HAVE I LOOP OUTER-MOST.
C
         IF (ABS(RX) .LE. ABS(RY)) GO TO 360
         IF (ISKIRT.NE.0 .OR. NYPASS.NE.1) GO TO 310
         I = MXS(1)
         DO 300 J=2,NNYY
            CALL DRAWS (M(1,I,J-1),M(2,I,J-1),M(1,I,J),M(2,I,J),0,1)
  300    CONTINUE
  310    DO 350 II=1,NNXX
            I = MI+II*LI
            IPLI = I+LI
            IF (NYPASS .EQ. 1) GO TO 320
            K = MYS(1)
            L = MYS(2)
            IF (IDRX .NE. 0)
     1          CALL DRAWS (M(1,I,K),M(2,I,K),M(1,I,L),M(2,I,L),1,1)
            IF (NDRZ.NE.0 .AND. II.NE.NI)
     1          CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI),K)
  320             DO 340 JPASS=1,NYPASS
                LJ = MYJ(JPASS)
                MJ = MYS(JPASS)-LJ
                NJ = IABS(MJ-MYF(JPASS))
                DO 330 JJ=1,NJ
                  J = MJ+JJ*LJ
                  JPLJ = J+LJ
                  IF (IDRX.NE.0 .AND. JJ.NE.NJ)
     1                CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,JPLJ),
     2                            M(2,I,JPLJ),1,1)
                  IF (I.NE.MXF(1) .AND. IDRY.NE.0)
     1                CALL DRAWS (M(1,IPLI,J),M(2,IPLI,J),M(1,I,J),
     2                            M(2,I,J),1,1)
                  IF (NDRZ.NE.0 .AND. JJ.NE.NJ .AND. II.NE.NNXX)
     1                CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI),
     2                             MIN0(J,J+LJ))
  330                CONTINUE
  340             CONTINUE
  350    CONTINUE
         GO TO 430
  360    IF (ISKIRT.NE.0 .OR. NXPASS.NE.1) GO TO 380
         J = MYS(1)
         DO 370 I=2,NNXX
            CALL DRAWS (M(1,I-1,J),M(2,I-1,J),M(1,I,J),M(2,I,J),0,1)
  370    CONTINUE
  380    DO 420 JJ=1,NNYY
            J = MJ+JJ*LJ
            JPLJ = J+LJ
            IF (NXPASS .EQ. 1) GO TO 390
            K = MXS(1)
            L = MXS(2)
            IF (IDRY .NE. 0)
     1          CALL DRAWS (M(1,K,J),M(2,K,J),M(1,L,J),M(2,L,J),1,1)
            IF (NDRZ.NE.0 .AND. JJ.NE.NJ)
     1          CALL CTCELL (Z,MMXX,NNXX,NNYY,M,K,MIN0(J,J+LJ))
  390             DO 410 IPASS=1,NXPASS
                LI = MXJ(IPASS)
                MI = MXS(IPASS)-LI
                NI = IABS(MI-MXF(IPASS))
                DO 400 II=1,NI
                  I = MI+II*LI
                  IPLI = I+LI
                  IF (IDRY.NE.0 .AND. II.NE.NI)
     1                CALL DRAWS (M(1,I,J),M(2,I,J),M(1,IPLI,J),
     2                            M(2,IPLI,J),1,1)
                  IF (J.NE.MYF(1) .AND. IDRX.NE.0)
     1                CALL DRAWS (M(1,I,JPLJ),M(2,I,JPLJ),M(1,I,J),
     2                            M(2,I,J),1,1)
                  IF (NDRZ.NE.0 .AND. II.NE.NI .AND. JJ.NE.NNYY)
     1                CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI),
     2                             MIN0(J,J+LJ))
  400                CONTINUE
  410             CONTINUE
  420    CONTINUE
  430    IF (ISKIRT .EQ. 0) GO TO 520
C
C FIX UP IF SKIRT IS USED WITH LINES ONE WAY.
C
         IF (IDRX .NE. 0) GO TO 460
         DO 450 IPASS=1,NXPASS
            IF (NXPASS .EQ. 2) IF = 1+(IPASS-1)*(NNXX-1)
            DO 440 J=2,NNYY
                CALL DRAWS (M(1,IF,J-1),M(2,IF,J-1),M(1,IF,J),M(2,IF,J),
     1                     1,0)
  440             CONTINUE
  450    CONTINUE
  460    IF (IDRY .NE. 0) GO TO 520
         DO 480 JPASS=1,NYPASS
            IF (NYPASS .EQ. 2) JF = 1+(JPASS-1)*(NNYY-1)
            DO 470 I=2,NNXX
                CALL DRAWS (M(1,I-1,JF),M(2,I-1,JF),M(1,I,JF),M(2,I,JF),
     1                     1,0)
  470             CONTINUE
  480    CONTINUE
         GO TO 520
C
C ALL VISIBLE IF VIEWED FROM DIRECTLY ABOVE OR BELOW.
C
  490    IF (NUPPER.GT.0 .AND. S(3).LT.S(6)) GO TO 520
         IF (NUPPER.LT.0 .AND. S(3).GT.S(6)) GO TO 520
         NUPPER = 1
         IF (S(3) .LT. S(6)) NUPPER = -1
         DO 510 I=1,NNXX
            DO 500 J=1,NNYY
                IF (IDRX.NE.0 .AND. J.NE.NNYY)
     1             CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,J+1),M(2,I,J+1),
     2                          1,0)
                IF (IDRY.NE.0 .AND. I.NE.NNXX)
     1             CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I+1,J),M(2,I+1,J),
     2                          1,0)
                IF (IDRZ.NE.0 .AND. I.NE.NNXX .AND. J.NE.NNYY)
     1             CALL CTCELL (Z,MMXX,NNXX,NNYY,M,I,J)
  500             CONTINUE
  510    CONTINUE
  520    IF (STER .EQ. 0.) GO TO 560
         IF (ISTP) 540,530,550
  530    CALL FRAME
  540    CALL FRAME
         GO TO 570
  550    IF (IPIC .NE. 2) GO TO 570
  560    IF (IFR .GT. 0) CALL FRAME
  570 CONTINUE
      RETURN
      END
      SUBROUTINE EZSRFC (Z,M,N,ANGH,ANGV,WORK)
      DIMENSION       Z(M,N)     ,WORK(1)
C
C                         WORK(2*M*N+M+N)
C
C PERSPECTIVE PICTURE OF A SURFACE STORED IN A TWO DIMENSIONAL ARRAY
C VIA A VERY SHORT ARGUMENT LIST.
C
C ASSUMPTIONS--
C     THE ENTIRE ARRAY IS TO BE DRAWN,
C     THE DATA IS EQUALLY SPACED (IN THE X-Y PLANE),
C     NO STEREO PAIRS.
C IF THESE ASSUMPTIONS ARE NOT MET USE SRFACE.
C
C ARGUMENTS--
C     Z    THE 2 DIMENSIONAL ARRAY TO BE DRAWN.
C     M    THE FIRST DIMENSION OF Z.
C     N    THE SECOND DIMENSION OF Z.
C     ANGH ANGLE IN DEGREES IN THE X-Y PLANE TO THE LINE OF SIGHT
C          (COUNTER-CLOCK WISE FROM THE PLUS-X AXIS).
C     ANGV ANGLE IN DEGREES FROM THE X-Y PLANE TO THE LINE OF SIGHT
C          (POSITIVE ANGLES ARE ABOVE THE MIDDLE Z, NEGATIVE BELOW).
C     WORK A SCRATCH STORAGE DIMENSIONED AT LEAST 2*M*N+M+N.
C
      COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41)     ,NCL,
     1                LL         ,FACT       ,IROT       ,NDRZ,
     2                NUPPER     ,NRSWT      ,BIGD       ,UMIN,
     3                UMAX       ,VMIN       ,VMAX       ,RZERO,
     4                NOFFP      ,NSPVAL     ,SPV        ,BIGEST
      DIMENSION       S(6)
      DATA S(4),S(5),S(6)/0.0,0.0,0.0/
C
C  FACT1 IS THE PERSPECTIVE RATIO AND IS DEFINED TO BE THE RATIO
C         MAXIMUM(LENGTH,WIDTH)/HEIGHT
C
C  FACT2 IS THE RATIO   (LENGTH OF LINE OF SIGHT)/MAXIMUM(LENGTH,WIDTH)
C
      DATA FACT1,FACT2/2.0,5.0/
      BIGEST = R1MACH(2)
C
C FIND RANGE OF Z
C
      MX = M
      NY = N
      ANG1 = ANGH*3.14159265358979/180.
      ANG2 = ANGV*3.14159265358979/180.
      FLO = BIGEST
      HI = -FLO
      DO  20 J=1,NY
         DO  10 I=1,MX
            IF (NOFFP.EQ.1 .AND. Z(I,J).EQ.SPV) GO TO   10
            HI = AMAX1(Z(I,J),HI)
            FLO = AMIN1(Z(I,J),FLO)
   10    CONTINUE
   20 CONTINUE
C
C SET UP LINEAR X AND Y ARRAYS FOR SRFACE
C
      DELTA = (HI-FLO)/(AMAX0(MX,NY)-1.)*FACT1
      XMIN = -(FLOAT(MX/2)*DELTA+FLOAT(MOD(MX+1,2))*DELTA)
      YMIN = -(FLOAT(NY/2)*DELTA+FLOAT(MOD(NY+1,2))*DELTA)
      DO  30 I=1,MX
         WORK(I) = XMIN+FLOAT(I-1)*DELTA
   30 CONTINUE
      DO  40 J=1,NY
         K = MX+J
         WORK(K) = YMIN+FLOAT(J-1)*DELTA
   40 CONTINUE
C
C SET UP EYE POSITION
C
      FACTE = (HI-FLO)*FACT1*FACT2
      CANG2 = COS(ANG2)
      S(1) = FACTE*CANG2*COS(ANG1)
      S(2) = FACTE*CANG2*SIN(ANG1)
      S(3) = FACTE*SIN(ANG2)+(FLO+HI)*.5
C
C READY
C
      CALL SRFACE (WORK(1),WORK(MX+1),Z,WORK(K+1),MX,MX,NY,S,0.)
      RETURN
      END
      SUBROUTINE SETR (XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,R0)
C
C THIS ROUTINE ESTABLISHES CERTAIN CONSTANTS SO THAT SRFACE
C PRODUCES A PICTURE WHOSE SIZE CHANGES WITH RESPECT TO THE
C VIEWERS DISTANCE FROM THE OBJECT.  IT CAN ALSO BE USED
C WHEN MAKING A MOVIE OF AN OBJECT EVOLVING IN TIME TO KEEP
C IT POSITIONED PROPERLY ON THE SCREEN, SAVING COMPUTER TIME
C IN THE BARGIN.  CALL IT WITH R0 NEGATIVE TO TURN OFF THIS
C FEATURE.
C PARAMETERS
C XMIN,XMAX - RANGE OF X ARRAY THAT WILL BE PASSED TO SRFACE.
C YMIN,YMAX - SAME IDEA, BUT FOR Y.
C ZMIN,ZMAX - SAME IDEA, BUT FOR Z.  IF A MOVIE IS BEING
C               MADE OF AN EVOLVING Z ARRAY, ZMIN       AND ZMAX
C               SHOULD CONTAIN RANGE OF THE UNION       OF ALL THE Z
C               ARRAYS.  THEY NEED NOT BE       EXACT.
C R0             - DISTANCE BETWEEN OBSERVER    AND POINT LOOKED AT
C               WHEN THE PICTURE IS TO FILL THE SCREEN WHEN
C               VIEWED FROM THE DIRECTION       WHICH MAKES THE PIC-
C               TURE BIGGEST.  IF       R0 IS NOT POSITIVE, THEN THE
C               RELATIVE SIZE FEATURE IS TURNED OFF, AND SUB-
C               SEQUENT PICTURES WILL FILL THE SCREEN.
C
      COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41)     ,NCL,
     1                LL         ,FACT       ,IROT       ,NDRZ,
     2                NUPPER     ,NRSWT      ,BIGD       ,UMIN,
     3                UMAX       ,VMIN       ,VMAX       ,RZERO,
     4                IOFFP      ,NSPVAL     ,SPVAL      ,BIGEST
      COMMON /PWRZ1S/ XXMIN      ,XXMAX      ,YYMIN      ,YYMAX,
     1                ZZMIN      ,ZZMAX      ,DELCRT     ,EYEX,
     2                EYEY       ,EYEZ
C
C
      CALL Q8QST4 ('GRAPHX','SRFACE','SETR','VERSION 01')
      IF (R0)  10, 10, 20
   10 NRSWT = 0
      RETURN
   20 NRSWT = 1
      XXMIN = XMIN
      XXMAX = XMAX
      YYMIN = YMIN
      YYMAX = YMAX
      ZZMIN = ZMIN
      ZZMAX = ZMAX
      RZERO = R0
      LL = 0
      XAT = (XXMAX+XXMIN)*.5
      YAT = (YYMAX+YYMIN)*.5
      ZAT = (ZZMAX+ZZMIN)*.5
      ALPHA = -(YYMIN-YAT)/(XXMIN-XAT)
      YEYE = -RZERO/SQRT(1.+ALPHA*ALPHA)
      XEYE = YEYE*ALPHA
      YEYE = YEYE+YAT
      XEYE = XEYE+XAT
      ZEYE = ZAT
      CALL TRN32S (XAT,YAT,ZAT,XEYE,YEYE,ZEYE,0)
      XMN = XXMIN
      XMX = XXMAX
      YMN = YYMIN
      YMX = YYMAX
      ZMN = ZZMIN
      ZMX = ZZMAX
      CALL TRN32S (XMN,YMN,ZAT,UMN,DUMMY,DUMMIE,1)
      CALL TRN32S (XMX,YMN,ZMN,DUMMY,VMN,DUMMIE,1)
      CALL TRN32S (XMX,YMX,ZAT,UMX,DUMMY,DUMMIE,1)
      CALL TRN32S (XMX,YMN,ZMX,DUMMY,VMX,DUMMIE,1)
      UMIN = UMN
      UMAX = UMX
      VMIN = VMN
      VMAX = VMX
      BIGD = SQRT((XXMAX-XXMIN)**2+(YYMAX-YYMIN)**2+(ZZMAX-ZZMIN)**2)*.5
      RETURN
      END
      SUBROUTINE DRAWS (MX1,MY1,MX2,MY2,IDRAW,IMARK)
C
C THIS ROUTINE DRAWS THE VISIBLE PART OF THE LINE CONNECTING
C (MX1,MY1) AND (MX2,MY2).  IF IDRAW .NE. 0, THE LINE IS DRAWN.
C IF IMARK .NE. 0, THE VISIBILITY ARRAY IS MARKED.
C
      LOGICAL               VIS1         ,VIS2
      DIMENSION       PXS(2)     ,PYS(2)
      COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41)     ,NCL,
     1                LL         ,FACT       ,IROT       ,NDRZ,
     2                NUPPER     ,NRSWT      ,BIGD       ,UMIN,
     3                UMAX       ,VMIN       ,VMAX       ,RZERO,
     4                IOFFP      ,NSPVAL     ,SPVAL      ,BIGEST
      DATA STEEP/5./
      DATA MX, MY /0, 0/
C
c +NOAO: Blockdata srfabd rewritten as run time initialization
c     EXTERNAL        SRFABD
      call srfabd
c -NOAO
C MAKE LINE LEFT TO RIGHT.
C
      MMX1 = MX1
      MMY1 = MY1
      MMX2 = MX2
      MMY2 = MY2
      IF (MMX1.EQ.NSPVAL .OR. MMX2.EQ.NSPVAL) RETURN
      IF (MMX1 .GT. MMX2) GO TO  10
      NX1 = MMX1
      NY1 = MMY1
      NX2 = MMX2
      NY2 = MMY2
      GO TO  20
   10 NX1 = MMX2
      NY1 = MMY2
      NX2 = MMX1
      NY2 = MMY1
   20 IF (NUPPER .LT. 0) GO TO 180
C
C CHECK UPPER VISIBILITY.
C
      VIS1 = NY1 .GE. (LIMU(NX1)-1)
      VIS2 = NY2 .GE. (LIMU(NX2)-1)
C
C VIS1 AND VIS2 TRUE MEANS VISIBLE.
C
      IF (VIS1 .AND. VIS2) GO TO 120
C
C VIS1 AND VIS2 FALSE MEANS INVISIBLE.
C
      IF (.NOT.(VIS1 .OR. VIS2)) GO TO 180
C
C FIND CHANGE POINT.
C
      IF (NX1 .EQ. NX2) GO TO 110
      DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1)
      NX1P1 = NX1+1
      FNY1 = NY1
      IF (VIS1) GO TO  60
      DO  30 K=NX1P1,NX2
         MX = K
         MY = FNY1+FLOAT(K-NX1)*DY
         IF (MY .GT. LIMU(K)) GO TO  40
   30 CONTINUE
   40 IF (ABS(DY) .GE. STEEP) GO TO  90
   50 NX1 = MX
      NY1 = MY
      GO TO 120
   60 DO  70 K=NX1P1,NX2
         MX = K
         MY = FNY1+FLOAT(K-NX1)*DY
         IF (MY .LT. LIMU(K)) GO TO  80
   70 CONTINUE
   80 IF (ABS(DY) .GE. STEEP) GO TO 100
      NX2 = MX-1
      NY2 = MY
      GO TO 120
   90 IF (LIMU(MX) .EQ. 0) GO TO  50
      NX1 = MX
      NY1 = LIMU(NX1)
      GO TO 120
  100 NX2 = MX-1
      NY2 = LIMU(NX2)
      GO TO 120
  110 IF (VIS1) NY2 = MIN0(LIMU(NX1),LIMU(NX2))
      IF (VIS2) NY1 = MIN0(LIMU(NX1),LIMU(NX2))
  120 IF (IDRAW .EQ. 0) GO TO 150
C
C DRAW VISIBLE PART OF LINE.
C
      IF (IROT) 130,140,130
  130 CONTINUE
      PXS(1) = FLOAT(NY1)
      PXS(2) = FLOAT(NY2)
      PYS(1) = FLOAT(1024-NX1)
      PYS(2) = FLOAT(1024-NX2)
      CALL GPL (2,PXS,PYS)
      GO TO 150
  140 CONTINUE
      PXS(1) = FLOAT(NX1)
      PXS(2) = FLOAT(NX2)
      PYS(1) = FLOAT(NY1)
      PYS(2) = FLOAT(NY2)
      CALL GPL (2,PXS,PYS)
  150 IF (IMARK .EQ. 0) GO TO 180
      IF (NX1 .EQ. NX2) GO TO 170
      DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1)
      FNY1 = NY1
      DO 160 K=NX1,NX2
         LTEMP = FNY1+FLOAT(K-NX1)*DY
	 IF (LTEMP .GT. LIMU(K)) LIMU(K) = LTEMP
  160 CONTINUE
      GO TO 180
  170 LTEMP = MAX0(NY1,NY2)
      IF (LTEMP .GT. LIMU(NX1)) LIMU(NX1) = LTEMP
  180 IF (NUPPER) 190,190,370
C
C SAME IDEA AS ABOVE, BUT FOR LOWER SIDE.
C
  190 IF (MMX1 .GT. MMX2) GO TO 200
      NX1 = MMX1
      NY1 = MMY1
      NX2 = MMX2
      NY2 = MMY2
      GO TO 210
  200 NX1 = MMX2
      NY1 = MMY2
      NX2 = MMX1
      NY2 = MMY1
  210 VIS1 = NY1 .LE. (LIML(NX1)+1)
      VIS2 = NY2 .LE. (LIML(NX2)+1)
      IF (VIS1 .AND. VIS2) GO TO 310
      IF (.NOT.(VIS1 .OR. VIS2)) GO TO 370
      IF (NX1 .EQ. NX2) GO TO 300
      DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1)
      NX1P1 = NX1+1
      FNY1 = NY1
      IF (VIS1) GO TO 250
      DO 220 K=NX1P1,NX2
         MX = K
         MY = FNY1+FLOAT(K-NX1)*DY
         IF (MY .LT. LIML(K)) GO TO 230
  220 CONTINUE
  230 IF (ABS(DY) .GE. STEEP) GO TO 280
  240 NX1 = MX
      NY1 = MY
      GO TO 310
  250 DO 260 K=NX1P1,NX2
         MX = K
         MY = FNY1+FLOAT(K-NX1)*DY
         IF (MY .GT. LIML(K)) GO TO 270
  260 CONTINUE
  270 IF (ABS(DY) .GE. STEEP) GO TO 290
      NX2 = MX-1
      NY2 = MY
      GO TO 310
  280 IF (LIML(MX) .EQ. 1024) GO TO 240
      NX1 = MX
      NY1 = LIML(NX1)
      GO TO 310
  290 NX2 = MX-1
      NY2 = LIML(NX2)
      GO TO 310
  300 IF (VIS1) NY2 = MAX0(LIML(NX1),LIML(NX2))
      IF (VIS2) NY1 = MAX0(LIML(NX1),LIML(NX2))
  310 IF (IDRAW .EQ. 0) GO TO 340
      IF (IROT) 320,330,320
  320 CONTINUE
      PXS(1) = FLOAT(NY1)
      PXS(2) = FLOAT(NY2)
      PYS(1) = FLOAT(1024-NX1)
      PYS(2) = FLOAT(1024-NX2)
      CALL GPL (2,PXS,PYS)
      GO TO 340
  330 CONTINUE
      PXS(1) = FLOAT(NX1)
      PXS(2) = FLOAT(NX2)
      PYS(1) = FLOAT(NY1)
      PYS(2) = FLOAT(NY2)
      CALL GPL (2,PXS,PYS)
  340 IF (IMARK .EQ. 0) GO TO 370
      IF (NX1 .EQ. NX2) GO TO 360
      DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1)
      FNY1 = NY1
      DO 350 K=NX1,NX2
         LTEMP = FNY1+FLOAT(K-NX1)*DY
	 IF (LTEMP .LT. LIML(K)) LIML(K) = LTEMP
  350 CONTINUE
      RETURN
  360 LTEMP = MIN0(NY1,NY2)
      IF (LTEMP .LT. LIML(NX1)) LIML(NX1) = LTEMP
  370 RETURN
      END
      SUBROUTINE TRN32S (X,Y,Z,XT,YT,ZT,IFLAG)
C
C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR-
C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE
C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15,
C 2, 193-204,1968.
C IFLAG=0 ARGUMENTS
C X,Y,Z    ARE THE 3-SPACE COORDINATES OF THE INTERSECTION
C          OF THE LINE OF SIGHT AND THE IMAGE PLANE.    THIS
C          POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT.
C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION.
C
C IFLAG=1 ARGUMENTS
C X,Y,Z    ARE THE 3-SPACE COORDINATES OF A POINT TO BE
C          TRANSFORMED.
C XT,YT    THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR-
C          MATION.
C          USE IFIX(XT) AND IFIX(YT) IN GPL CALLS.
C ZT            NOT USED.
C IF LL (IN COMMON) =0 XT AND YT ARE IN THE SAME SCALE AS X, Y, AND Z.
C
      COMMON /PWRZ1S/ XXMIN      ,XXMAX      ,YYMIN  ,YYMAX,
     1                ZZMIN      ,ZZMAX      ,DELCRT ,EYEX,
     2                EYEY       ,EYEZ
      COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41)     ,NCL,
     1                LL         ,FACT       ,IROT       ,NDRZ,
     2                NUPPER     ,NRSWT      ,BIGD       ,UMIN,
     3                UMAX       ,VMIN       ,VMAX       ,RZERO,
     4                IOFFP      ,NSPVAL     ,SPVAL      ,BIGEST
      DIMENSION       NLU(7)     ,NRU(7)     ,NBV(7)     ,NTV(7)
C
C SAVE INSERTED BY BEN DOMENICO 9/8/85 BECAUSE OF ASSUMPTION THAT
C   JUMP, JUMP2, AND JUMP3 ARE PRESERVED BETWEEN CALLS.
C   THERE MAY BE OTHER SUCH ASSUMPTIONS AS WELL.
C
      SAVE
C
C PICTURE CORNER COORDINATES FOR LL=1
C
      DATA NLU(1),NRU(1),NBV(1),NTV(1)/  10,1014,  10,1014/
C
C PICTURE CORNER COORDINATES FOR LL=2
C
      DATA NLU(2),NRU(2),NBV(2),NTV(2)/  10, 924,  50, 964/
C
C PICTURE CORNER COORDINATES FOR LL=3
C
      DATA NLU(3),NRU(3),NBV(3),NTV(3)/ 100,1014,  50, 964/
C
C PICTURE CORNER COORDINATES FOR LL=4
C
      DATA NLU(4),NRU(4),NBV(4),NTV(4)/  10,1014,  10,1014/
C
C PICTURE CORNER COORDINATES FOR LL=5
C
      DATA NLU(5),NRU(5),NBV(5),NTV(5)/  10,1014,  10,1014/
C
C PICTURE CORNER COORDINATES FOR LL=6
C
      DATA NLU(6),NRU(6),NBV(6),NTV(6)/  10, 512, 256, 758/
C
C PICTURE CORNER COORDINATES FOR LL=7
C
      DATA NLU(7),NRU(7),NBV(7),NTV(7)/ 512,1014, 256, 758/
C
C STORE THE PARAMETERS OF THE SET32 CALL FOR USE WHEN
C TRN32 IS CALLED.
C
      IF (IFLAG)  40, 10, 40
   10 CONTINUE
      ASSIGN  60 TO JUMP3
      IF (IOFFP .EQ. 1) ASSIGN  50 TO JUMP3
      AX = X
      AY = Y
      AZ = Z
      EX = XT
      EY = YT
      EZ = ZT
C
C AS MUCH COMPUTATION AS POSSIBLE IS DONE DURING EXECUTION
C THIS ROUTINE WHEN IFLAG=0 BECAUSE CALLS IN THAT MODE ARE INFREQUENT.
C
      DX = AX-EX
      DY = AY-EY
      DZ = AZ-EZ
      D = SQRT(DX*DX+DY*DY+DZ*DZ)
      COSAL = DX/D
      COSBE = DY/D
      COSGA = DZ/D
      SINGA = SQRT(1.-COSGA*COSGA)
      ASSIGN 120 TO JUMP2
      IF (LL .EQ. 0) GO TO  20
      ASSIGN 100 TO JUMP2
      DELCRT = NRU(LL)-NLU(LL)
      U0 = UMIN
      V0 = VMIN
      U1 = NLU(LL)
      V1 = NBV(LL)
      U2 = NRU(LL)-NLU(LL)
      V2 = NTV(LL)-NBV(LL)
      U3 = U2/(UMAX-UMIN)
      V3 = V2/(VMAX-VMIN)
      U4 = NRU(LL)
      V4 = NTV(LL)
      IF (NRSWT .EQ. 0) GO TO  20
      U0 = -BIGD
      V0 = -BIGD
      U3 = U2/(2.*BIGD)
      V3 = V2/(2.*BIGD)
C
C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF
C THE 2-SPACE.  THE 3-SPACE Z AXIS IS TRANSFORMED INTO THE
C 2-SPACE Y AXIS.  IF THE LINE OF SIGHT IS CLOSE TO PARALLEL
C TO THE 3-SPACE Z AXIS, THE 3-SPACE Y AXIS IS CHOSEN (IN-
C STEAD OF THE 3-SPACE Z AXIS) TO BE TRANSFORMED INTO THE
C 2-SPACE Y AXIS.
C
   20 IF (SINGA .LT. 0.0001) GO TO  30
      R = 1./SINGA
      ASSIGN  70 TO JUMP
      RETURN
   30 SINBE = SQRT(1.-COSBE*COSBE)
      R = 1./SINBE
      ASSIGN  80 TO JUMP
      RETURN
   40 CONTINUE
      XX = X
      YY = Y
      ZZ = Z
      GO TO JUMP3,( 50, 60)
   50 IF (ZZ .EQ. SPVAL) GO TO 110
   60 Q = D/((XX-EX)*COSAL+(YY-EY)*COSBE+(ZZ-EZ)*COSGA)
      GO TO JUMP,( 70, 80)
   70 XX = ((EX+Q*(XX-EX)-AX)*COSBE-(EY+Q*(YY-EY)-AY)*COSAL)*R
      YY = (EZ+Q*(ZZ-EZ)-AZ)*R
      GO TO  90
   80 XX = ((EZ+Q*(ZZ-EZ)-AZ)*COSAL-(EX+Q*(XX-EX)-AX)*COSGA)*R
      YY = (EY+Q*(YY-EY)-AY)*R
   90 GO TO JUMP2,(100,120)
c + NOAO: Clipping is done at the gio level and is unnecessary here.  The
c following statements were preventing labels from being positioned properly
c at the edges of the surface plot, even when the viewport had been reset.
  100 xx = u1 + u3 * (fact * xx - u0)
      yy = v1 + v3 * (fact * yy - v0)
c 100 XX = AMIN1(U4,AMAX1(U1,U1+U3*(FACT*XX-U0)))
c     YY = AMIN1(V4,AMAX1(V1,V1+V3*(FACT*YY-V0)))
c -NOAO
      GO TO 120
  110 XX = NSPVAL
      YY = NSPVAL
C
  120 XT = XX
      YT = YY
      RETURN
      END
      SUBROUTINE CLSET (Z,MX,NX,NY,CHI,CLO,CINC,NLA,NLM,CL,NCL,ICNST,
     1                  IOFFP,SPVAL,BIGEST)
      DIMENSION       Z(MX,NY)   ,CL(NLM)
      DATA KK /0/
C
C CLSET PUTS THE VALUS OF THE CONTOUR LEVELS IN CL
C
      ICNST = 0
      GLO = CLO
      HA = CHI
      FANC = CINC
      CRAT = NLA
      IF (HA-GLO)  10, 20, 50
   10 GLO = HA
      HA = CLO
      GO TO  50
   20 GLO = BIGEST
      HA = -GLO
      DO  40 J=1,NY
         DO  30 I=1,NX
            IF (IOFFP.EQ.1 .AND. Z(I,J).EQ.SPVAL) GO TO  30
            GLO = AMIN1(Z(I,J),GLO)
            HA = AMAX1(Z(I,J),HA)
   30    CONTINUE
   40 CONTINUE
   50 IF (FANC)  60, 70, 90
   60 CRAT = -FANC
   70 FANC = (HA-GLO)/CRAT
      IF (FANC) 140,140, 80
   80 P = 10.**(IFIX(ALOG10(FANC)+500.)-500)
      FANC = AINT(FANC/P)*P
   90 IF (CHI-CLO) 110,100,110
  100 GLO = AINT(GLO/FANC)*FANC
      HA = AINT(HA/FANC)*FANC
  110 DO 120 K=1,NLM
         CC = GLO+FLOAT(K-1)*FANC
         IF (CC .GT. HA) GO TO 130
         KK = K
         CL(K) = CC
  120 CONTINUE
  130 NCL = KK
      RETURN
  140 ICNST = 1
      RETURN
      END
      SUBROUTINE CTCELL (Z,MX,NX,NY,M,I0,J0)
C
C CTCELL COMPUTES LINES OF CONSTANT Z (CONTOUR LINES) IN ONE
C CELL OF THE ARRAY Z FOR THE SRFACE PACKAGE.
C Z,MX,NX,NY ARE THE SAME AS IN SRFACE.
C M              BY     THE TIME CTCELL IS FIRST CALLED, M CONTAINS
C            THE TWO-SPACE PLOTTER LOCATION OF EACH Z POINT.
C            U(Z(I,J))=M(1,I,J).  V(Z(I,J))=M(2,I,J)
C I0,J0      THE CELL Z(I0,J0) TO Z(I0+1,J0+1) IS THE ONE TO
C            BE CONTOURED.
C
      DIMENSION       Z(MX,NY)   ,M(2,NX,NY)
      COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41)     ,NCL,
     1                LL         ,FACT       ,IROT       ,NDRZ,
     2                NUPPER     ,NRSWT      ,BIGD       ,UMIN,
     3                UMAX       ,VMIN       ,VMAX       ,RZERO,
     4                IOFFP      ,NSPVAL     ,SPVAL      ,BIGEST
      DATA IDUB/0/
      R(HO,HU) = (HO-CV)/(HO-HU)
      I1 = I0
      I1P1 = I1+1
      J1 = J0
      J1P1 = J1+1
      H1 = Z(I1,J1)
      H2 = Z(I1,J1P1)
      H3 = Z(I1P1,J1P1)
      H4 = Z(I1P1,J1)
      IF (IOFFP .NE. 1) GO TO  10
      IF (H1.EQ.SPVAL .OR. H2.EQ.SPVAL .OR. H3.EQ.SPVAL .OR.
     1    H4.EQ.SPVAL) RETURN
   10 IF (AMIN1(H1,H2,H3,H4) .GT. CL(NCL)) RETURN
      DO 110 K=1,NCL
C
C FOR EACH CONTOUR LEVEL, DESIDE WHICH OF THE 16 BASIC SIT-
C UATIONS EXISTS, THEN INTERPOLATE IN TWO-SPACE TO FIND THE
C END POINTS OF THE CONTOUR LINE SEGMENT WITHIN THIS CELL.
C
         CV = CL(K)
         K1 = (IFIX(SIGN(1.,H1-CV))+1)/2
         K2 = (IFIX(SIGN(1.,H2-CV))+1)/2
         K3 = (IFIX(SIGN(1.,H3-CV))+1)/2
         K4 = (IFIX(SIGN(1.,H4-CV))+1)/2
         JUMP = 1+K1+K2*2+K3*4+K4*8
         GO TO (120, 30, 50, 60, 70, 20, 80, 90, 90, 80,
     1           40, 70, 60, 50, 30,110),JUMP
   20    IDUB = 1
   30    RA = R(H1,H2)
         MUA = FLOAT(M(1,I1,J1))+RA*FLOAT(M(1,I1,J1P1)-M(1,I1,J1))
         MVA = FLOAT(M(2,I1,J1))+RA*FLOAT(M(2,I1,J1P1)-M(2,I1,J1))
         RB = R(H1,H4)
         MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1))
         MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1))
         GO TO 100
   40    IDUB = -1
   50    RA = R(H2,H1)
         MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1))
         MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1))
         RB = R(H2,H3)
         MUB = FLOAT(M(1,I1,J1P1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1))
         MVB = FLOAT(M(2,I1,J1P1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1))
         GO TO 100
   60    RA = R(H2,H3)
         MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1))
         MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1))
         RB = R(H1,H4)
         MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1))
         MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1))
         GO TO 100
   70    RA = R(H3,H2)
         MUA = FLOAT(M(1,I1P1,J1P1))+
     1         RA*FLOAT(M(1,I1,J1P1)-M(1,I1P1,J1P1))
         MVA = FLOAT(M(2,I1P1,J1P1))+
     1         RA*FLOAT(M(2,I1,J1P1)-M(2,I1P1,J1P1))
         RB = R(H3,H4)
         MUB = FLOAT(M(1,I1P1,J1P1))+
     1         RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1))
         MVB = FLOAT(M(2,I1P1,J1P1))+
     1         RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1))
         IDUB = 0
         GO TO 100
   80    RA = R(H2,H1)
         MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1))
         MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1))
         RB = R(H3,H4)
         MUB = FLOAT(M(1,I1P1,J1P1))+
     1         RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1))
         MVB = FLOAT(M(2,I1P1,J1P1))+
     1         RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1))
         GO TO 100
   90    RA = R(H4,H1)
         MUA = FLOAT(M(1,I1P1,J1))+RA*FLOAT(M(1,I1,J1)-M(1,I1P1,J1))
         MVA = FLOAT(M(2,I1P1,J1))+RA*FLOAT(M(2,I1,J1)-M(2,I1P1,J1))
         RB = R(H4,H3)
         MUB = FLOAT(M(1,I1P1,J1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1P1,J1))
         MVB = FLOAT(M(2,I1P1,J1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1P1,J1))
         IDUB = 0
  100    CALL DRAWS (MUA,MVA,MUB,MVB,1,0)
         IF (IDUB)  90,110, 70
  110 CONTINUE
  120 RETURN
      END


      subroutine mkherm2(fun,x,nx,y,ny,fherm)
C
C  create a data set for Hermite interpolation, from evaluation of
C  function and derivatives.  function of 2 indep. coordinates.
C
C  input:
C
      external fun                      ! passed real function(x,y)
      real x(nx)                        ! x coordinate array
      real y(ny)                        ! y coordinate array
C
C  the passed function fun must have the interface:
C
C        real function <name>(x,y,dfdx,dfdy,d2fdxdy)
C  where x,y are input, the function returns the function value,
C  and the arguments dfdx and dfdy return as output the function
C  derivative at the point (x,y).
C
C  output:
C
      real fherm(0:3,nx,ny)             ! function data & derivatives
C
C  fherm(0,i,j) = function value f at x(i),y(j)
C  fherm(1,i,j) = derivative df/dx at x(i),y(j)
C  fherm(2,i,j) = derivative df/dy at x(i),y(j)
C  fherm(3,i,j) = derivative d2f/dxdy at x(i),y(j)
C
C----------------------------
C
      do ix=1,nx
         do iy=1,ny
            fherm(0,ix,iy)=fun(x(ix),y(iy),dfdx,dfdy,d2fdxdy)
            fherm(1,ix,iy)=dfdx
            fherm(2,ix,iy)=dfdy
            fherm(3,ix,iy)=d2fdxdy
         enddo
      enddo
C
      return
      end


! ######################################################################
! ######################################################################
! ###########     _                           ____  ____      ##########
! ###########    | |__  _   _ _ __   ___ _ __(___ \|  _ \     ##########
! ###########    | '_ \| | | | '_ \ / _ \ '__| __) | | | |    ##########
! ###########    | | | | |_| | |_) |  __/ |   / __/| |_| |    ##########
! ###########    |_| |_|\__, | .__/ \___|_|  /_____|____/     ##########
! ###########           |___/|_|                              ##########
! ###########                                                 ##########
! ######################################################################
! ######################################################################

program hyper2D

  use global_module   ! Simulation parameters: domain size, number of cells etc
  use grid            ! Loads and stores the grid
  use pde             ! Definition of the system of equations
  use integration     ! Functions for integrating in time and numerical fluxes
  use tools           ! Output subroutines etc etc

  implicit none

  ! The solution is a 3D matrix.
  ! The first index "eqID" represents the equation
  ! (for Euler 1: density, 2: x-momentum, 3: y-momentum, 4: total energy)
  ! the second index "i" represents the x-position
  ! the third index "j" represents the y-position.
  ! This might be counter-intuitive, but recall that Fortran represents data
  ! in column-major order.

  real(kind=8), dimension(:,:), allocatable :: U, U_new

  integer      :: Nt, t_ID ! Variables for time integration
  real(kind=8) :: dt, t_now, CFL_now

  write(*,*) "Reading grid file..."
  call load_grid_from_file

  write(*,*) "Initializing solution..."
  allocate(U(Neq,Nele), U_new(Neq,Nele))
  call initialize_solution(U) ! See the pde.f03 module

  write(*,*) "Writing solution at time step", 0, "..."
  call export_sol_vtk(0, U)

  ! $$$$$$$$$$$ Integrate in time $$$$$$$$$$$$$

  ! Nt = ceiling(t_end/dt) ! t_end and dt are defined in global_module.f90
  ! do t_ID = 1, Nt

  t_now = 0.0d0   ! Init
  dt    = 1.0d-10  ! Very first time step
  t_ID  = 0.0     ! Init

  do while( t_now .le. t_end)

    ! ------ Prepare variables ------
    t_ID  = t_ID + 1
    t_now = t_now + dt

    ws_over_sqrtA_maxabs = 0.0 ! Global variable, init to zero

    ! ------ Integrate by dt ------
    call forward_Euler_step(U, U_new, dt)

    ! ----- Write solution to VTK, every ... time steps -----
    if ( mod(t_ID, 100) .EQ. 0 ) then
      write(*,*) "Writing solution at time step", t_ID, "..."
      call export_sol_vtk(t_ID, U)
    end if

    ! ------ Estimate current Courant number and update time step -----
    CFL_now = ws_over_sqrtA_maxabs*dt
    write(*,'(A,EN15.5,A,F10.5,A,ES14.7,A)') 'Time', t_now, ' [s]. Current CFL: ', CFL_now, '. dt = ', dt, '[s]'
    dt      = dt*CFL_target/CFL_now

  end do

end program


      SUBROUTINE cfode(meth, elco, tesco)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER meth
      REAL(rprec), DIMENSION(13,12) :: elco
      REAL(rprec), DIMENSION(3,12) :: tesco
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: i, ib, nq, nqm1, nqp1
      REAL(rprec) :: agamq, fnq, fnqm1
      REAL(rprec), DIMENSION(12) :: pc
      REAL(rprec) :: pint, ragq, rqfac, rq1fac, tsign, xpin
C-----------------------------------------------
clll. optimize
c-----------------------------------------------------------------------
c cfode is called by the integrator routine to set coefficients
c needed there.  the coefficients for the current method, as
c given by the value of meth, are set for ALL orders and saved.
c the maximum order assumed here is 12 IF meth = 1 and 5 IF meth = 2.
c (a smaller value of the maximum order is also allowed.)
c cfode is called once at the beginning of the problem,
c and is not called again unless and until meth is changed.
c
c the elco array CONTAINS the basic method coefficients.
c the coefficients el(i), 1 .le. i .le. nq+1, for the method of
c order nq are stored in elco(i,nq).  they are given by a genetrating
c polynomial, i.e.,
c     l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq.
c for the IMPLICIT adams methods, l(x) is given by
c     dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1),    l(-1) = 0.
c for the bdf methods, l(x) is given by
c     l(x) = (x+1)*(x+2)* ... *(x+nq)/k,
c WHERE         k = factorial(nq)*(1 + 1/2 + ... + 1/nq).
c
c the tesco array CONTAINS test constants used for the
c local error test and the selection of step SIZE and/or order.
c at order nq, tesco(k,nq) is used for the selection of step
c SIZE at order nq - 1 IF k = 1, at order nq IF k = 2, and at order
c nq + 1 IF k = 3.
c-----------------------------------------------------------------------
c
      SELECT CASE (meth)
c
      CASE DEFAULT
         elco(1,1) = 1
         elco(2,1) = 1
         tesco(1,1) = 0
         tesco(2,1) = 2
         tesco(1,2) = 1
         tesco(3,12) = 0
         pc(1) = 1
         rqfac = 1
         DO nq = 2, 12
c-----------------------------------------------------------------------
c the pc array will contain the coefficients of the polynomial
c     p(x) = (x+1)*(x+2)*...*(x+nq-1).
c initially, p(x) = 1.
c-----------------------------------------------------------------------
            rq1fac = rqfac
            rqfac = rqfac/nq
            nqm1 = nq - 1
            fnqm1 = nqm1
            nqp1 = nq + 1
c form coefficients of p(x)*(x+nq-1). ----------------------------------
            pc(nq) = 0.0_dp
            DO ib = 1, nqm1
               i = nqp1 - ib
               pc(i) = pc(i-1) + fnqm1*pc(i)
            END DO
            pc(1) = fnqm1*pc(1)
c compute integral, -1 to 0, of p(x) and x*p(x). -----------------------
            pint = pc(1)
            xpin = pc(1)/2.0_dp
            tsign = 1.0_dp
            DO i = 2, nq
               tsign = -tsign
               pint = pint + tsign*pc(i)/i
               xpin = xpin + tsign*pc(i)/(i + 1)
            END DO
c store coefficients in elco and tesco. --------------------------------
            elco(1,nq) = pint*rq1fac
            elco(2,nq) = 1.0_dp
            DO i = 2, nq
               elco(i+1,nq) = rq1fac*pc(i)/i
            END DO
            agamq = rqfac*xpin
            ragq = 1.0_dp/agamq
            tesco(2,nq) = ragq
            IF (nq < 12) tesco(1,nqp1) = ragq*rqfac/nqp1
            tesco(3,nqm1) = ragq
         END DO
         RETURN
c
      CASE (2)
         pc(1) = 1.0_dp
         rq1fac = 1.0_dp
         DO nq = 1, 5
c-----------------------------------------------------------------------
c the pc array will contain the coefficients of the polynomial
c     p(x) = (x+1)*(x+2)*...*(x+nq).
c initially, p(x) = 1.
c-----------------------------------------------------------------------
            fnq = nq
            nqp1 = nq + 1
c form coefficients of p(x)*(x+nq). ------------------------------------
            pc(nqp1) = 0.0_dp
            DO ib = 1, nq
               i = nq + 2 - ib
               pc(i) = pc(i-1) + fnq*pc(i)
            END DO
            pc(1) = fnq*pc(1)
c store coefficients in elco and tesco. --------------------------------
            elco(:nqp1,nq) = pc(:nqp1)/pc(2)
            elco(2,nq) = 1.0_dp
            tesco(1,nq) = rq1fac
            tesco(2,nq) = nqp1/elco(1,nq)
            tesco(3,nq) = (nq + 2)/elco(1,nq)
            rq1fac = rq1fac/fnq
         END DO
         RETURN
      END SELECT

      END SUBROUTINE cfode


\ rnd.f     - random number generator
\ ------------------------------------------------------------------------

  .( loading rnd.f ) cr

\ ------------------------------------------------------------------------

  <headers

  0 var seed1               \ random number seed
  0 var seed2

\ ------------------------------------------------------------------------
\ semi not so random number generator

  headers>

: rnd           ( n1 --- n2 )
  seed1 123 * 234 +
  seed2 234 * 123 +
  2dup +   !> seed2
  2dup xor !> seed1
  + swap cells mod cell/ ;

\ ------------------------------------------------------------------------
\ seed rng (consider using /dev/random for this)

: rand
  time@ tv cell+ @ xor
  dup !> seed1 !> seed2 ;

\ ------------------------------------------------------------------------
\ seed random number generator using current time

  <headers

: xyzzy         ( --- )
  defers default
  rand ;

\ ------------------------------------------------------------------------
\ reset random number generator seed to zero

  headers>

: 0seed         ( --- )
  off> seed1 off> seed2 ;

\ ------------------------------------------------------------------------

  behead

\ ========================================================================


program main
  integer, parameter :: ssize = 2048
  real, dimension(ssize,ssize)::u
  real, dimension(ssize,ssize)::f
  real, dimension(ssize,ssize)::u_new
  real, dimension(ssize,ssize)::temp

  call zero(u)
  call zero(f)
  call zero(u_new)
  call random(u)
  do k=1, 10
    do i=2, 2047
      do j=2, 2047
        u_new(i,j) = 0.25*(h2*f(i,j) + u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1))
      enddo
    enddo
    write (*,*) "Iter ", k, "max= ",maxval(u_new)
    temp = u
    u = u_new
    u_new = u
  enddo

end program

subroutine zero(array)
  real, dimension(2048,2048)::array
  do i=1, 2048
    do j=1, 2048
      array(i,j)=0.0
    enddo
  enddo

end subroutine zero

subroutine random(array)
  real, dimension(2048,2048)::array
  do i=2,2047
    do j=2, 2047
      array(i,j) = rand()
    enddo
  enddo
end subroutine random

subroutine maximum(array)
  real, dimension(2048,2048)::array
  real :: maxi = 0.0
  do i=1, 2048
    do j=1, 2048
      if(array(i,j).gt.maxi) then
        maxi=array(i,j)
      end if
    end do
  end do
  write (*,*) "max=", maxi
end subroutine maximum


program test_mnist

  use mod_mnist, only: load_mnist
  use mod_kinds, only: ik, rk

  implicit none

  real(rk), allocatable :: tr_images(:,:), tr_labels(:)
  real(rk), allocatable :: te_images(:,:), te_labels(:)
  real(rk), allocatable :: va_images(:,:), va_labels(:)

  print *, 'Reading MNIST data..'
  call load_mnist(tr_images, tr_labels, te_images, te_labels, va_images, va_labels)
  print *, 'Training data:'
  print *, shape(tr_images), minval(tr_images), maxval(tr_images), sum(tr_images) / size(tr_images)
  print *, shape(tr_labels), sum(tr_labels) / size(tr_labels)
  print *, 'Testing data:'
  print *, shape(te_images), minval(te_images), maxval(te_images), sum(te_images) / size(te_images)
  print *, shape(te_labels), sum(te_labels) / size(te_labels)
  print *, 'Validation data:'
  print *, shape(va_images), minval(va_images), maxval(va_images), sum(va_images) / size(va_images)
  print *, shape(va_labels), sum(va_labels) / size(va_labels)

end program test_mnist


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_GLTR_EXAMPLE2
   USE GALAHAD_GLTR_DOUBLE                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, two = 2.0_working
   INTEGER, PARAMETER :: n = 2                ! problem dimension
   INTEGER :: i
   REAL ( KIND = working ) :: f, radius = 1.0_working  ! radius of ten
   REAL ( KIND = working ), DIMENSION( n ) :: X, R, VECTOR, H_vector
   TYPE ( GLTR_data_type ) :: data
   TYPE ( GLTR_control_type ) :: control
   TYPE ( GLTR_info_type ) :: info
   CALL GLTR_initialize( data, control )  ! Initialize control parameters
   control%f_0 = 4.731884325266608D+0
   control%print_level = 3
   control%out = 6
   control%unitm = .TRUE.                 ! M is the identity matrix
   R = (/ -4.637816414622023D+0, -1.222067920715109D-1 /)
   info%status = 1
   DO                                     !  Iteration to find the minimizer
      CALL GLTR_solve( n, radius, f, X, R, VECTOR, data, control, info )
      SELECT CASE( info%status )    ! Branch as a result of info%status
      CASE( 2, 6 )                  ! Form the preconditioned gradient
         VECTOR = VECTOR / two      ! Preconditioner is two times identity
      CASE ( 3, 7 )                 ! Form the matrix-vector product
        H_vector( 1 ) = 1.107272566595126D+3 * VECTOR( 1 ) + &
                        4.701123595505616D+2 * VECTOR( 2 )
        H_vector( 2 ) = 4.701123595505616D+2 * VECTOR( 1 ) + &
                        2.000000000000000D+2 * VECTOR( 2 )
        VECTOR = H_vector
      CASE ( 5 )        !  Restart
         R = (/ -4.637816414622023D+0, -1.222067920715109D-1 /)
      CASE ( - 2 : 0 )  !  Successful return
         WRITE( 6, "( I6, ' iterations. Solution and Lagrange multiplier = ',  &
        &       2ES12.4 )" ) info%iter + info%iter_pass2, f, info%multiplier
         CALL GLTR_terminate( data, control, info ) !  delete internal workspace
         EXIT
      CASE DEFAULT      !  Error returns
         WRITE( 6, "( ' GLTR_solve exit status = ', I6 ) " ) info%status
         CALL GLTR_terminate( data, control, info ) !  delete internal workspace
         EXIT
      END SELECT
   END DO
   write(6,*) ' x ', X
   END PROGRAM GALAHAD_GLTR_EXAMPLE2