cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
C...Giving the x*f pdf of a companion quark, with its partner at XS,
C...using an approximate gluon density like (1-X)^NPOW/X. The value
C...corresponds to an unrescaled range between 0 and 1-X.

      DOUBLE PRECISION FUNCTION PYFCMP(XC,XS,NPOW)
      IMPLICIT NONE
      DOUBLE PRECISION XC, XS, Y, FAC
      INTEGER NPOW

      PYFCMP=0D0
C...Parent gluon momentum fraction
      Y=XC+XS
      IF (Y.GE.1D0) RETURN
C...Common factor (includes factor XC, since PYFCMP=x*f)
      FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
C...Store normalized companion x*f distribution.
      IF (NPOW.LE.0) THEN
        PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
      ELSEIF (NPOW.EQ.1) THEN
        PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
      ELSEIF (NPOW.EQ.2) THEN
        PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
     &       +3D0*XS*(1D0+XS)*LOG(XS)))
      ELSEIF (NPOW.EQ.3) THEN
        PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
     &       +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
      ELSEIF (NPOW.GE.4) THEN
        PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
     &       XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
      ENDIF
      RETURN
      END


module mod_fenwick_tree
  implicit none

  type t_fenwick_tree
    private
    integer :: n, p
    integer, pointer :: arr(:) => null()
  contains
    procedure :: init => init_bit
    procedure :: release => release_bit
    procedure :: add => get_addition
    procedure :: sum => get_summation
    procedure :: range => get_partial_summation
    procedure :: val => get_value
    procedure :: lower_bound => get_lower_bound
    procedure :: update => get_updated
    procedure :: max => get_maximum
    final :: finalize
  end type t_fenwick_tree

contains

  subroutine init_bit(this,n)
    class(t_fenwick_tree), intent(inout) :: this
    integer, intent(in) :: n
    integer :: p

    p = 1
    this%n = n
    allocate(this%arr(n))
    this%arr = 0
    do while (lshift(p,1) <= n)
      p = lshift(p,1)
    end do
    this%p = p
  end

  subroutine release_bit(this)
    class(t_fenwick_tree), intent(inout) :: this

    if (associated(this%arr)) deallocate(this%arr)
  end

  subroutine finalize(this)
    type(t_fenwick_tree), intent(inout) :: this

    if (associated(this%arr)) deallocate(this%arr)
  end

  subroutine get_addition(this,i,v)
    class(t_fenwick_tree), intent(inout) :: this
    integer, intent(in) :: i
    integer, intent(in) :: v
    integer :: x

    x = i
    do while (x <= this%n)
      this%arr(x) = this%arr(x)+v
      x = x+and(x,-x)
    end do
  end

  function get_summation(this,i) result(s)
    class(t_fenwick_tree), intent(in) :: this
    integer, intent(in) :: i
    integer :: x
    integer :: s

    s = -1
    if (i > this%n) return
    s = 0
    x = i
    do while (x > 0)
      s = s+this%arr(x)
      x = x-and(x,-x)
    end do
  end

  function get_partial_summation(this,l,r) result(s)
    class(t_fenwick_tree), intent(in) :: this
    integer, intent(in) :: l, r
    integer :: i, j
    integer :: s

    s = -1
    if (l > r) return
    s = 0
    i = l-1
    j = r
    do while (j > i)
      s = s+this%arr(j)
      j = j-and(j,-j)
    end do
    do while (i > j)
      s = s-this%arr(i)
      i = i-and(i,-i)
    end do
  end

  function get_value(this,i) result(v)
    class(t_fenwick_tree), intent(in) :: this
    integer, intent(in) :: i
    integer :: x
    integer :: v

    v = get_partial_summation(this,i,i)
  end

  function get_lower_bound(this,v) result(x)
    class(t_fenwick_tree), intent(in) :: this
    integer, intent(in) :: v
    integer :: x, k
    integer :: w

    x = 0
    if (v <= 0) return
    k = this%p
    w = v
    do while (k > 0)
      if (x+k <= this%n .and. this%arr(x+k) < w) then
        w = w-this%arr(x+k)
        x = x+k
      end if
      k = rshift(k,1)
    end do
    x = x+1
  end

  subroutine get_updated(this,i,v)
    class(t_fenwick_tree), intent(inout) :: this
    integer, intent(in) :: i
    integer, intent(in) :: v
    integer :: x

    x = i
    do while (x <= this%n)
      if (this%arr(x) < v) this%arr(x) = v
      x = x+and(x,-x)
    end do
  end

  function get_maximum(this,i) result(m)
    class(t_fenwick_tree), intent(in) :: this
    integer, intent(in) :: i
    integer :: x, m

    x = i
    m = 0
    do while (x > 0)
      m = max(m,this%arr(x))
      x = x-and(x,-x)
    end do
  end

  function len_of_lis(a) result(m)
    integer, intent(in) :: a(:)
    type(t_fenwick_tree) :: bit
    integer :: m, n, i, t

    n = size(a)
    call init_bit(bit,n)
    m = 0
    do i = 1, n
      t = get_maximum(bit,a(i)-1)+1
      m = max(m,t)
      call get_updated(bit,a(i),t)
    end do
  end

  function inv_num(a) result(m)
    integer, intent(in) :: a(:)
    type(t_fenwick_tree) :: bit
    integer :: m, n, i, t

    n = size(a)
    call init_bit(bit,n)
    m = 0
    do i = 1, n
      call get_addition(bit,a(i),1)
      m = m+i-get_summation(bit,a(i))
    end do
  end

end module mod_fenwick_tree


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine randomfields(inpc,textpart,istep,istat,n,iline,
     &        ipol,inl,ipoinp,inp,ipoinpc,nener,physcon,ier)
!
!     reading the input deck: *RANDOM FIELD
!
!     characterized by standarddeviation and correlation length
!
      implicit none
!
      character*1 inpc(*)
      character*132 textpart(16)
!
      integer istep,istat,n,key,i,iline,ipol,inl,ipoinp(2,*),
     &  inp(3,*),ipoinpc(0:*),nener,k,ipos,neigenvectors,ier
!
      real*8 physcon(*),dummy
!
      if(istep.lt.1) then
         write(*,*) '*ERROR reading *RANDOM FIELD: *RANDOM FIELD can'
         write(*,*) '       only be used within a *SENSITIVITY step'
         ier=1
         return
      endif
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
!
!     reading the standard deviation and the correlation length
!
!     Number of eigenvectors used for the creation of the random field
!
      read(textpart(1)(1:20),'(i10)',iostat=istat) neigenvectors
      physcon(11)=1.d0*neigenvectors
!
!     Standard deviation
!
      read(textpart(2)(1:20),'(f20.0)',iostat=istat) physcon(12)
!
!     Correlation length
!
      read(textpart(3)(1:20),'(f20.0)',iostat=istat) physcon(13)
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
!
      return
      end


! { dg-do run }
!
! Check pr57117 is fixed.

program pr57117
  implicit none

  type :: ti
    integer :: i
  end type

  class(ti), allocatable :: x(:,:), y(:,:)
  integer :: i

  allocate(x(2,6))
  select type (x)
    class is (ti)
       x%i = reshape([(i,i=1, 12)],[2,6])
  end select
  allocate(y, source=transpose(x))

  if (any( ubound(y) /= [6,2])) STOP 1
  if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) STOP 2
  deallocate (x,y)
end


C************************************************************************
C  This test routine is used to test CYLPATCH, a FORTRAN subroutine.
C  CLYPATCH  computes the special line and sample point and special
C  latitude and longitude points for the normal cylindrical projection.
C  This test routine builds the necessary data in a standard MAP
C  buffer.  After testing the subroutine using this FORTRAN driver, a
C  "C" version is invoked "tzcylpatch".  tzcylpatch uses a bridge
C  "zcylpatch" to invoke CYLPATCH.  The test cases are the same, only
C  in "C".
C************************************************************************
C  RDATA is a real*4 40 element array as described in CONVEV.
C   rdata(1) - sample
C   rdata(2) - line
C   rdata(3) - Latitude
C   rdata(6) - Longitude
C   rdata(7) - scale (km/pixel)
C   rdata(39) - projection type = 9
C   rdata(25) - polar radius (km)
C   rdata(26) - equatorial radius (km)
C  Some values will be changed after execution of CYLPATCH.
C   rdata(1) - special sample point
C   rdata(2) - special line point
C   rdata(3) - Latitude at sample 1
C   rdata(6) - Longitude (west) at sample 1
C  If rdata(39) is not equal to 9 (integer), then data is not for a
C  cylindrical projection. CYLPATCH returns without making any changes.
C************************************************************************

      include 'VICMAIN_FOR'
      subroutine main44
      implicit none
      real rdata(40)
      integer idata(40),j
      character*80 msg
      equivalence(idata(1),rdata(1))
      idata(39)=9
      rdata(1)=1.
      rdata(2)=1.
      rdata(3)=85.7461
      rdata(6)=239.916
      rdata(7)=10.
      rdata(25)=1815.
      rdata(26)=1815.
      call xvmessage
     +     ('at line=1. sample=1. lati=85.7461 long=239.916',' ')
      call xvmessage('radius=1815., scal=10',' ')
      write(msg,40)(RDATA(j),j=25,26)
      call xvmessage(msg,' ')
      write(msg,50)(RDATA(j),j=1,5)
      call xvmessage(msg,' ')
      write(msg,51)(RDATA(j),j=6,10)
      call xvmessage(msg,' ')
      call xvmessage(' ',' ')
      call cylpatch(rdata)
      call xvmessage('output should be lati=0 at line=182, samp=761 long
     *=239.916',' ')
      write(msg,41) RDATA(1)
      call xvmessage(msg,' ')
      write(msg,42) RDATA(2)
      call xvmessage(msg,' ')
      write(msg,43) RDATA(3)
      call xvmessage(msg,' ')
      write(msg,44) RDATA(6)
      call xvmessage(msg,' ')
      write(msg,52)(RDATA(j),j=1,5)
      call xvmessage(msg,' ')
      write(msg,51)(RDATA(j),j=6,10)
      call xvmessage(msg,' ')
      call xvmessage(' ',' ')
      rdata(1)=100.
      rdata(2)=100.
      rdata(3)=26.8586
      rdata(6)=208.6638
      call xvmessage
     +    ('at line=100,samp=100,lati=26.8586,long=208.6638',' ')
      write(msg,50)(RDATA(j),j=1,5)
      call xvmessage(msg,' ')
      write(msg,51)(RDATA(j),j=6,10)
      call xvmessage(msg,' ')
      call xvmessage(' ',' ')
      call cylpatch(rdata)
      call xvmessage('output should be lati=0 at line=182, samp=761 long
     *=239.916', ' ')
      write(msg,41) RDATA(1)
      call xvmessage(msg,' ')
      write(msg,42) RDATA(2)
      call xvmessage(msg,' ')
      write(msg,43) RDATA(3)
      call xvmessage(msg,' ')
      write(msg,44) RDATA(6)
      call xvmessage(msg,' ')
      write(msg,52)(RDATA(j),j=1,5)
      call xvmessage(msg,' ')
      write(msg,51)(RDATA(j),j=6,10)
      call xvmessage(msg,' ')
      call xvmessage(' ',' ')
      call xvmessage('NOW TRY "C" INTERFACE',' ')
      call tzcylpatch
40    format ('RADII=',2f10.4)
41    format ('sample=',f12.5)
42    format ('line=  ',f12.5)
43    format ('lati=  ',f12.5)
44    format ('long=  ',f12.5)
50    format ('input  data=',5f12.7)
51    format ('            ',5f12.7)
52    format ('output data=',5f12.7)
      return
      end


!##############################################################################
!# ****************************************************************************
!# <name> anisotropicdiffusion_callback </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains callback functions for the poisson problem that are
!# used during the matrix/vector assembly for specifying analytical data.
!# There are three callback functions involved, which may be called depending
!# on the situation. All of them correspond to a specific interface for
!# callback functions, defined in 'intf_xxxx.inc' files.
!#
!# 1.) coeff_Laplace
!#     -> Returns the coefficients for the Laplace matrix. This routine is
!#        only used if the problem to calculate has nonconstant coefficients!
!#        Otherwise the routine is dead.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientMatrixSc.inc'
!#
!# 2.) coeff_RHS
!#     -> Returns analytical values for the right hand side of the Laplace
!#        equation.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 3.) getBoundaryValues
!#     -> Returns analytic values on the (Dirichlet) boundary of the
!#        problem to solve.
!#     -> Corresponds to the interface defined in the file
!#        'intf_bcassembly.inc'
!#
!# 4.) getBoundaryValuesFBC
!#
!#     -> Returns analytic values in the inner of the domain on
!#        fictitious boundary objects
!#     -> Corresponds to the interface defined in the file
!#        'intf_bcfassembly.inc'
!#
!# 5.) getReferenceFunction
!#
!#     -> Returns the values of the analytic function and its derivatives,
!#        corresponding to coeff_RHS
!#     -> Is only used for the postprocessing to calculate the $L_2$- and
!#        $H_1$-error of the FE function in comparison to the analytic
!#        function
!#
!# 6.) getMonitorFunction
!#
!#     -> Returns the values of the monitor function which is used to
!#        perform h-adaptivity
!# </purpose>
!##############################################################################

module anisotropicdiffusion_callback

  use fsystem
  use storage
  use genoutput
  use mprimitives
  use linearsolver
  use boundary
  use triangulation
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use derivatives
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use matrixfilters
  use vectorfilters
  use bcassembly
  use element

  implicit none

contains

! ***************************************************************************
  !<subroutine>

  subroutine coeff_Laplace (rdiscretisationTrial,rdiscretisationTest,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the bilinear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the bilinear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisationTrial

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisationTest

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(in)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF`s on all elements trial in the trial space.
    ! DIMENSION(#local DOF`s in trial space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTrial

    ! An array accepting the DOF`s on all elements trial in the trial space.
    ! DIMENSION(#local DOF`s in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It is usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    Dcoefficients = 1.0_DP

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine coeff_RHS (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(in)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF`s on all elements trial in the trial space.
    ! DIMENSION(#local DOF`s in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It is usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    integer :: isolution
    real(DP), dimension(2,2) :: A

    ! Get information about the solution from the collection --
    ! as configured in the main program.
    isolution = rcollection%IquickAccess(1)
    A(1,1) = rcollection%DquickAccess(1)
    A(1,2) = rcollection%DquickAccess(2)
    A(2,1) = rcollection%DquickAccess(3)
    A(2,2) = rcollection%DquickAccess(4)

    select case (isolution)
    case (0,2)

      !    u(x,y) = 16*x*(1-x)*y*(1-y)
      ! => f(x,y) = 32 * (y*(1-y)+x*(1-x))
      !    + Rotation, given by the matrix A

      Dcoefficients (1,:,:) = -(&
        -32.0_DP*A(1,1)*DPoints(2,:,:)*(1 - DPoints(2,:,:)) + &
          A(1,2)*(16.0_DP*(1.0_DP - DPoints(1,:,:))*(1.0_DP - DPoints(2,:,:)) &
        -16.0_DP*(1.0_DP - DPoints(1,:,:))*DPoints(2,:,:) &
        -16.0_DP*DPoints(1,:,:)*(1.0_DP - DPoints(2,:,:)) &
        +16.0_DP*DPoints(1,:,:)*DPoints(2,:,:)) &
        +A(2,1)*(16.0_DP*(1.0_DP - DPoints(1,:,:))*(1 - DPoints(2,:,:)) &
        -16.0_DP*(1.0_DP - DPoints(1,:,:))*DPoints(2,:,:) &
        -16.0_DP*DPoints(1,:,:)*(1 - DPoints(2,:,:)) &
        +16.0_DP*DPoints(1,:,:)*DPoints(2,:,:)) &
        -32.0_DP*A(2,2)*DPoints(1,:,:)*(1 - DPoints(1,:,:)) )

    case (3)
      Dcoefficients (1,:,:) = 32.0_DP * &
                      ( Dpoints(2,:,:)*(1.0_DP-Dpoints(2,:,:)) + &
                        Dpoints(1,:,:)*(1.0_DP-Dpoints(1,:,:)) )

    case DEFAULT

      Dcoefficients (1,:,:) = 0.0_DP

    end select

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine getReferenceFunction (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! This subroutine is called during the calculation of errors. It has to compute
  ! the (analytical) values of a function in a couple of points on a couple
  ! of elements. These values are compared to those of a computed FE function
  ! and used to calculate an error.
  !
  ! The routine accepts a set of elements and a set of points on these
  ! elements (cubature points) in in real coordinates.
  ! According to the terms in the linear form, the routine has to compute
  ! simultaneously for all these points.
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in)                      :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out)                      :: Dvalues
!</output>

!</subroutine>

    integer :: isolution
    real(DP), dimension(2,2) :: A

    ! Get information about the solution from the collection --
    ! as configured in the main program.
    isolution = rcollection%IquickAccess(1)
    A(1,1) = rcollection%DquickAccess(1)
    A(1,2) = rcollection%DquickAccess(2)
    A(2,1) = rcollection%DquickAccess(3)
    A(2,2) = rcollection%DquickAccess(4)

  select case (cderivative)
  case (DER_FUNC)
    ! u(x,y) = 16*x*(1-x)*y*(1-y)
    Dvalues (:,:) = 16.0_DP * Dpoints(1,:,:)*(1.0_DP-Dpoints(1,:,:)) * &
                              Dpoints(2,:,:)*(1.0_DP-Dpoints(2,:,:))
  case (DER_DERIV_X)
    !    u(x,y)   = 16*x*(1-x)*y*(1-y)
    ! => u_x(x,y) = 16 * ( y*(1-x)*(1-y)-x*y*(1-y) )
    Dvalues (:,:) = 16.0_DP * ( &
        Dpoints(2,:,:) * (1.0_DP-Dpoints(1,:,:)) * (1.0_DP-Dpoints(2,:,:)) - &
        Dpoints(1,:,:) * Dpoints(2,:,:) * (1.0_DP-Dpoints(2,:,:)) )
  case (DER_DERIV_Y)
    !    u(x,y)   = 16*x*(1-x)*y*(1-y)
    ! => u_y(x,y) = 16 * ( x*(1-x)*(1-y)-x*y*(1-x) )
    Dvalues (:,:) = 16.0_DP * ( &
        Dpoints(1,:,:) * (1.0_DP-Dpoints(1,:,:)) * (1.0_DP-Dpoints(2,:,:)) - &
        Dpoints(1,:,:) * Dpoints(2,:,:) * (1.0_DP-Dpoints(1,:,:)) )
  case DEFAULT
    ! Unknown. Set the result to 0.0.
    Dvalues = 0.0_DP
  end select

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine getBoundaryValues (Icomponents,rdiscretisation,rboundaryRegion,ielement, &
                                   cinfoNeeded,iwhere,dwhere, Dvalues, rcollection)

  use collection
  use spatialdiscretisation
  use discretebc

!<description>
  ! This subroutine is called during the discretisation of boundary
  ! conditions. It calculates a special quantity on the boundary, which is
  ! then used by the discretisation routines to generate a discrete
  ! 'snapshot' of the (actually analytic) boundary conditions.
!</description>

!<input>
  ! Component specifier.
  ! For Dirichlet boundary:
  !   Icomponents(1) defines the number of the boundary component, the value
  !   should be calculated for (e.g. 1=1st solution component, e.g. X-velocitry,
  !   2=2nd solution component, e.g. Y-velocity,...)
  integer, dimension(:), intent(in)                           :: Icomponents

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Boundary region that is currently being processed.
  type(t_boundaryRegion), intent(in)                          :: rboundaryRegion

  ! The element number on the boundary which is currently being processed
  integer, intent(in)                                         :: ielement

  ! The type of information, the routine should calculate. One of the
  ! DISCBC_NEEDxxxx constants. Depending on the constant, the routine has
  ! to return one or multiple information value in the result array.
  integer, intent(in)                                         :: cinfoNeeded

  ! A reference to a geometric object where information should be computed.
  ! cinfoNeeded=DISCBC_NEEDFUNC :
  !   iwhere = number of the point in the triangulation or
  !          = 0, if only the parameter value of the point is known; this
  !               can be found in dwhere,
  ! cinfoNeeded=DISCBC_NEEDDERIV :
  !   iwhere = number of the point in the triangulation or
  !          = 0, if only the parameter value of the point is known; this
  !               can be found in dwhere,
  ! cinfoNeeded=DISCBC_NEEDINTMEAN :
  !   iwhere = number of the edge where the value integral mean value
  !            should be computed
  integer, intent(in)                                          :: iwhere

  ! A reference to a geometric object where information should be computed.
  ! cinfoNeeded=DISCBC_NEEDFUNC :
  !   dwhere = parameter value of the point where the value should be computed,
  ! cinfoNeeded=DISCBC_NEEDDERIV :
  !   dwhere = parameter value of the point where the value should be computed,
  ! cinfoNeeded=DISCBC_NEEDINTMEAN :
  !   dwhere = 0 (not used)
  real(DP), intent(in)                                        :: dwhere

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional                 :: rcollection

!</input>

!<output>
  ! This array receives the calculated information. If the caller
  ! only needs one value, the computed quantity is put into Dvalues(1).
  ! If multiple values are needed, they are collected here (e.g. for
  ! DISCBC_NEEDDERIV: Dvalues(1)=x-derivative, Dvalues(2)=y-derivative,...)
  real(DP), dimension(:), intent(out)                         :: Dvalues
!</output>

!</subroutine>

    real(DP) :: dx,dy
    integer :: isolution
    real(DP), dimension(2,2) :: A

    ! Get information about the solution from the collection --
    ! as configured in the main program.
    isolution = rcollection%IquickAccess(1)
    A(1,1) = rcollection%DquickAccess(1)
    A(1,2) = rcollection%DquickAccess(2)
    A(2,1) = rcollection%DquickAccess(3)
    A(2,2) = rcollection%DquickAccess(4)

    ! Get the X/Y-coordinates of the boundary point:
    !
    call boundary_getCoords(rdiscretisation%p_rboundary, &
        rboundaryRegion%iboundCompIdx, dwhere, dx, dy)

!    ! Return zero Dirichlet boundary values for all situations.
!    SELECT CASE (isolution)
!    CASE (0)
!      Dvalues(1) = 0.0_DP
!
!    CASE (1)
!      Dvalues(1) = 0.0_DP
!      IF ((dwhere .GE. 0.0_DP) .AND. (dwhere .LE. 0.2_DP)) Dvalues(1) = 1.0_DP
!      IF ((dwhere .GE. 0.2_DP) .AND. (dwhere .LE. 0.3_DP)) &
!        CALL mprim_linearRescale(dwhere,0.2_DP,0.3_DP,1.0_DP,0.5_DP,Dvalues(1))
!      IF ((dwhere .GE. 0.3_DP) .AND. (dwhere .LE. 1.7_DP)) Dvalues(1) = 0.5_DP
!      IF ((dwhere .GE. 1.7_DP) .AND. (dwhere .LE. 1.8_DP)) &
!        CALL mprim_linearRescale(dwhere,1.7_DP,1.8_DP,0.5_DP,0.0_DP,Dvalues(1))
!      IF ((dwhere .GE. 1.8_DP) .AND. (dwhere .LE. 2.2_DP)) Dvalues(1) = 0.0_DP
!      IF ((dwhere .GE. 2.2_DP) .AND. (dwhere .LE. 2.3_DP)) &
!        CALL mprim_linearRescale(dwhere,2.2_DP,2.3_DP,0.0_DP,0.5_DP,Dvalues(1))
!      IF ((dwhere .GE. 2.3_DP) .AND. (dwhere .LE. 3.7_DP)) Dvalues(1) = 0.5_DP
!      IF ((dwhere .GE. 3.7_DP) .AND. (dwhere .LE. 3.8_DP)) &
!        CALL mprim_linearRescale(dwhere,3.7_DP,3.8_DP,0.5_DP,1.0_DP,Dvalues(1))
!      IF ((dwhere .GE. 3.8_DP) .AND. (dwhere .LE. 4.0_DP)) Dvalues(1) = 1.0_DP
!
!    CASE DEFAULT
!      Dvalues(1) = 0.0_DP
!
!    END SELECT
    Dvalues(1) = analyticalFunction (isolution,dx,dy)

  end subroutine

  ! ***************************************************************************

!<function>

  real(DP) function analyticalFunction (ifunction,dx,dy)

!<description>
  ! Calculates the value of an analytical function in a point (dx,dy).
  ! ifunction is an identifier for the function to be evaluated.
!</description>

!<input>
  ! Identifier for the function to evaluate.
  integer, intent(in) :: ifunction

  ! Point where to evaluate
  real(DP), intent(in) :: dx,dy
!</input>

!<return>
  ! Value of the function.
!</return>

!</subroutine>

    real(DP) :: dvalue

    ! Return zero Dirichlet boundary values for all situations.
    select case (ifunction)
    case (0)
      dvalue = 0.0_DP

    case (1)
      dvalue = 0.0_DP
      if (dy .eq. 0.0_DP) then
        if ((dx .ge. 0.0_DP) .and. (dx .le. 0.2_DP)) dvalue = 1.0_DP
        if ((dx .ge. 0.2_DP) .and. (dx .le. 0.3_DP)) &
          call mprim_linearRescale(dx,0.2_DP,0.3_DP,1.0_DP,0.5_DP,dvalue)
        if ((dx .ge. 0.3_DP) .and. (dx .le. 1.0_DP)) dvalue = 0.5_DP
      else if (dx .eq. 1.0_DP) then
        if ((dy .ge. 0.0_DP) .and. (dy .le. 0.7_DP)) dvalue = 0.5_DP
        if ((dy .ge. 0.7_DP) .and. (dy .le. 0.8_DP)) &
          call mprim_linearRescale(dy,0.7_DP,0.8_DP,0.5_DP,0.0_DP,dvalue)
        if ((dy .ge. 0.8_DP) .and. (dy .le. 1.0_DP)) dvalue = 0.0_DP
      else if (dy .eq. 1.0_DP) then
        if ((dx .ge. 0.8_DP) .and. (dx .le. 1.0_DP)) dvalue = 0.0_DP
        if ((dx .ge. 0.7_DP) .and. (dx .le. 0.8_DP)) &
          call mprim_linearRescale(dx,0.7_DP,0.8_DP,0.5_DP,0.0_DP,dvalue)
        if ((dx .ge. 0.0_DP) .and. (dx .le. 0.7_DP)) dvalue = 0.5_DP
      else if (dx .eq. 0.0_DP) then
        if ((dy .ge. 0.3_DP) .and. (dy .le. 1.0_DP)) dvalue = 0.5_DP
        if ((dy .ge. 0.2_DP) .and. (dy .le. 0.3_DP)) &
          call mprim_linearRescale(dy,0.2_DP,0.3_DP,1.0_DP,0.5_DP,dvalue)
        if ((dy .ge. 0.0_DP) .and. (dy .le. 0.2_DP)) dvalue = 1.0_DP
      end if
    case (2)
      dvalue = 16.0_DP*dx*(1-dx)*dy*(1-dy)
    case (4)
      if ((dx .eq. 0.0_DP) .or. (dy .eq. 0.0_DP) .or. &
          (dx .eq. 1.0_DP) .or. (dy .eq. 1.0_DP)) then
        dvalue = 0.0_DP
      else
        dvalue = 2.0_DP
      end if

    case DEFAULT
      dvalue = 0.0_DP

    end select

    analyticalFunction = dvalue

  end function

  ! ***************************************************************************

!<subroutine>

  subroutine getMonitorFunction(rtriangulation,rsolution,ieltype,ierrorestimator,rindicator)

    use pprocgradients
    use pprocerror

!<description>
  ! This routine defines a 'monitor function' for the adaptive grid refinement
  ! with the h-adaptivity refinement strategy. rindicator is a vector with
  ! NEL entries for all the elements in the triangulation. The routine must
  ! fill each entry with a value that tells the h-adaptivity routines whether
  ! to refine that element or not.
!</descrition>

!<input>
    ! The triangulation structure of the underlying mesh which is to be refined
    type(t_triangulation), intent(in) :: rtriangulation

    ! The solution vector
    type(t_vectorScalar), intent(inout)  :: rsolution

    ! The type of element used for the FE solution
    integer, intent(in) :: ieltype

    ! The type of error estimator
    integer, intent(in) :: ierrorestimator
!</input>

!</inputoutput>
    ! An indicator vector. Entry i in the vector rindicatir that tells the
    ! mesh adaption routines whether to refine element i or to do coarsening
    ! with it. A value > 1.0 will refine element i, a value < 0.01 will result
    ! in coarsening -- as specified during the initialisation of the
    ! mesh refinement in the main program.
    type(t_vectorScalar), intent(inout) :: rindicator

!</subroutine>

    ! local variables
    type(t_vectorBlock)         :: rgradient,rgradientRef
    type(t_blockDiscretisation) :: rdiscrBlock,rdiscrBlockRef
    real(DP)                    :: dsolutionError,dgradientError,daux

    ! Initialise block discretisations
    call spdiscr_initBlockDiscr (rdiscrBlock,2,&
        rtriangulation, rsolution%p_rspatialdiscr%p_rboundary)
    call spdiscr_initBlockDiscr (rdiscrBlockRef,2,&
        rtriangulation, rsolution%p_rspatialdiscr%p_rboundary)

    ! What kind of element type is used for the FE solution
    select case(ieltype)
    case(1)
      ! Initialise spatial discretisations for gradient with P0-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E000, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E000, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(2))

      ! Initialise spatial discretisations for reference gradient with P1-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E001, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E001, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(2))

    case(2)
      ! Initialise spatial discretisations for gradient with P1-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E001, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E001, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(2))

      ! Initialise spatial discretisations for reference gradient with P2-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E002, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E002, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(2))

    case(11)
      ! Initialise spatial discretisations for gradient with Q0-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E010, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E010, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(2))

      ! Initialise spatial discretisations for reference gradient with Q1-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E011, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E011, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(2))

    case(13)
      ! Initialise spatial discretisations for gradient with Q1-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E011, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E011, SPDISC_CUB_AUTOMATIC, rdiscrBlock%RspatialDiscr(2))

      ! Initialise spatial discretisations for reference gradient with Q2-elements
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E013, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(1))
      call spdiscr_deriveSimpleDiscrSc (rsolution%p_rspatialdiscr,&
          EL_E013, SPDISC_CUB_AUTOMATIC, rdiscrBlockRef%RspatialDiscr(2))

    case(-1)
      ! Initialise spatial discretisations for gradient with P0/Q0-elements
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E000, EL_E010, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlock%RspatialDiscr(1))
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E000, EL_E010, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlock%RspatialDiscr(2))

      ! Initialise spatial discretisations for reference gradient with P1/Q1-elements
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E001, EL_E011, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlockRef%RspatialDiscr(1))
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E001, EL_E011, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlockRef%RspatialDiscr(2))

    case(-2)
      ! Initialise spatial discretisations for gradient with P1/Q1-elements
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E001, EL_E011, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlock%RspatialDiscr(1))
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E001, EL_E011, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlock%RspatialDiscr(2))

      ! Initialise spatial discretisations for reference gradient with P2/Q2-elements
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E002, EL_E013, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlockRef%RspatialDiscr(1))
      call spdiscr_deriveDiscr_triquad (rsolution%p_rspatialdiscr,&
          EL_E002, EL_E013, SPDISC_CUB_AUTOMATIC, SPDISC_CUB_AUTOMATIC, &
          rdiscrBlockRef%RspatialDiscr(2))

    case DEFAULT
      call output_line('Unsupproted element type!',&
          OU_CLASS_ERROR,OU_MODE_STD,'getMonitorFunction')
      call sys_halt()
    end select

    ! Create block vector for gradient values
    call lsysbl_createVecBlockByDiscr (rdiscrBlock,   rgradient,    .true.)
    call lsysbl_createVecBlockByDiscr (rdiscrBlockRef,rgradientRef, .true.)

    ! Recover consistent gradient
    call ppgrd_calcGradient (rsolution, rgradient)

    ! Recover smoothed gradient
    select case(ierrorestimator)
    case (1)
      call ppgrd_calcGradient (rsolution, rgradientRef)

    case (2)
      call ppgrd_calcGradSuperPatchRecov (rsolution, rgradientRef, PPGRD_NODEPATCH)

    case (3)
      call ppgrd_calcGradSuperPatchRecov (rsolution, rgradientRef, PPGRD_ELEMPATCH)

    case (4)
      call ppgrd_calcGradSuperPatchRecov (rsolution, rgradientRef, PPGRD_FACEPATCH)

    case DEFAULT
      call output_line('Invalid type of error estimator!',&
          OU_CLASS_ERROR,OU_MODE_STD,'getMonitorFunction')
      call sys_halt()
    end select

    ! Compute gradient error
    call pperr_blockErrorEstimate(rgradient,rgradientRef,&
        PPERR_L2ERROR, dgradientError,relementError=rindicator)

    ! rindicator is currently the absolute error. If the relative error
    ! is to be used, the following lines must be commented in:
    !
    ! ! Compute L2-norm of solution
    ! CALL pperr_scalar(rsolution,PPERR_L2ERROR,dsolutionError)
    !
    ! ! Prepare indicator for grid refinement/coarsening
    ! daux=SQRT((dsolutionError**2+dgradientError**2)/REAL(rindicator%NEQ,DP))
    ! CALL lsyssc_scaleVector(rindicator,1._DP/daux)

    call output_line('!!gradient error!! = '//trim(sys_sdEL(dgradientError,10)))

    ! Release temporal discretisation structure
    call spdiscr_releaseBlockDiscr(rdiscrBlock)
    call spdiscr_releaseBlockDiscr(rdiscrBlockRef)

    ! Release vectors
    call lsysbl_releaseVector(rgradient)
    call lsysbl_releaseVector(rgradientRef)
  end subroutine

end module


c
c     file resm3cr.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c     subroutine resm3cr(nx,ny,nz,icros,work,res)
c
c
c ... purpose
c
c
c     subroutine resm3cr computes the fine grid residual in the nx by ny by nz
c     array res after calling mud3cr.  if
c
c          L * p = f
c
c     is the n by n (n = nx*ny*nz) block tri-diagonal linear system resulting
c     from the pde discretization (done internally in mud3cr) and phi
c     is the approximation to p obtained by calling mud3cr, then resm3cr computes
c     the nx by ny by nz residual array
c
c          res = f - L * phi.
c
c     one of the vector norms of res,
c
c          || res ||
c
c     can be computed as a "measure" of how well phi satisfies the
c     discretization equations.  for example, the following statements
c     will compute the location and size of the maximum residual in res
c     on cray computers:
c
c          ijk = isamax(nx*ny*nz,res,1)
c
c          kmax = (ijk-1)/(nx*ny) + 1
c
c          jmax = (ijk-(kmax-1)*nx*ny-1)/nx + 1
c
c          imax = ij - nx*((kmax-1)*ny-jmax+1)
c
c          resmax = abs(res(imax,jmax,kmax))
c
c
c *** please note:
c
c          let pe be the exact continuous solution to the elliptic pde
c          evaluated on the nx by ny by nz discretization grid
c
c          let p be the exact solution to the linear discretization
c
c          let phi be the approximation to p generated by the mudpack solver
c
c     then discretization level error is defined by the condition
c
c          || phi - p || < || p - pe ||.
c                        =
c
c     a common measure of multigrid efficieny is that discretization level
c     error is reached in one full multigrid cycle (see references [2,9] in
c     the mudpack file "readme").  this can happen before the residual is
c     reduced to the level of roundoff error.  consequently, || res || is
c     a conservative measure of accuracy which can be wasteful if multi-
c     grid cycles are executed until it reaches the level of roundoff error.
c
c     || res || can be used to estimate the convergence rate of multigrid
c     iteration.  let r(n) be the residual and e(n) be the error after
c     executing n cycles.  they are related by the residual equation
c
c          L * e(n) = r(n).
c
c     it follows that the ratio
c
c          || r(n+1) || / || r(n) ||
c
c     estimates
c
c          || e(n+1) || / || e(n) ||
c
c     which in turn estimates the convergence rate
c
c          c = max || e(k+1) || / || e(k) ||.
c               k
c
c     notice
c                         n
c          || e(n) || <  c  || e(0) ||.
c
c
c ... assumptions (see mud3.d or mud3sa.d)
c
c     (1) nx,ny,nz have the same values as iparm(14),iparm(15),iparm(16)
c         (used to set the fine grid resolution when calling mud3cr
c
c     (2) icros,work,phi are the same arguments used in calling mud3cr
c
c     (3) icros,work,phi have not changed since the last call to mud3cr
c
c     (3) assures a copy of the last approximation phi and the discretization
c     coefficients are contained in work.  If these assumptions are not
c     true then resm3cr cannot compute the residual in res.
c
      subroutine resm3cr(nx,ny,nz,icros,wk,res)
c
c     compute fine grid residual in res after calling mud3cr
c
      implicit none
      integer nx,ny,nz,ic,ir,ixy,ixz,iyz,kxy,kxz,kyz
      integer icros(3)
      real wk(*),res(nx,ny,nz)
c
c     set fine grid pointers for wk
c
      kxy = icros(1)
      kxz = icros(2)
      kyz = icros(3)
      ic = 1+(nx+2)*(ny+2)*(nz+2)
      ir = ic+7*nx*ny*nz
      ixy = ir + nx*ny*nz
      ixz = ixy + kxy*nx*ny*nz
      iyz = ixz + kxz*nx*ny*nz
      call rem3cr(nx,ny,nz,wk,wk(ir),wk(ic),wk(ixy),wk(ixz),wk(iyz),
     +            kxy,kxz,kyz,res)
      return
      end

      subroutine rem3cr(nx,ny,nz,phi,rhs,cof,coxy,coxz,coyz,
     +                  kxy,kxz,kyz,resf)
      implicit none
      integer nx,ny,nz,i,j,k,kxy,kxz,kyz
      real phi(0:nx+1,0:ny+1,0:nz+1),rhs(nx,ny,nz),resf(nx,ny,nz)
      real cof(nx,ny,nz,7),coxy(nx,ny,nz),coxz(nx,ny,nz),coyz(nx,ny,nz)
      do k=1,nz
	do j=1,ny
	  do i=1,nx
	    resf(i,j,k) =  rhs(i,j,k)-(
     +                     cof(i,j,k,1)*phi(i-1,j,k)+
     +                     cof(i,j,k,2)*phi(i+1,j,k)+
     +                     cof(i,j,k,3)*phi(i,j-1,k)+
     +                     cof(i,j,k,4)*phi(i,j+1,k)+
     +                     cof(i,j,k,5)*phi(i,j,k-1)+
     +                     cof(i,j,k,6)*phi(i,j,k+1)+
     +                     cof(i,j,k,7)*phi(i,j,k))
	  end do
	end do
      end do
c
c   adjust residual with cross coefs as necessary on interior
c
      if (kxy .eq. 1) then
	do k=2,nz-1
	  do j=2,ny-1
	    do i=2,nx-1
	    resf(i,j,k) =  resf(i,j,k) - coxy(i,j,k)*(
     +                     phi(i+1,j+1,k)+phi(i-1,j-1,k) -(
     +                     phi(i+1,j-1,k)+phi(i-1,j+1,k)))
	    end do
	  end do
	end do
      end if
      if (kxz .eq. 1) then
	do k=2,nz-1
	  do j=2,ny-1
	    do i=2,nx-1
	    resf(i,j,k) =  resf(i,j,k) - coxz(i,j,k)*(
     +                     phi(i+1,j,k+1)+phi(i-1,j,k-1) -(
     +                     phi(i+1,j,k-1)+phi(i-1,j,k+1)))
	    end do
	  end do
	end do
      end if
      if (kyz .eq. 1) then
	do k=2,nz-1
	  do j=2,ny-1
	    do i=2,nx-1
	    resf(i,j,k) =  resf(i,j,k) - coyz(i,j,k)*(
     +                     phi(i,j+1,k+1)+phi(i,j-1,k-1) - (
     +                     phi(i,j+1,k-1)+phi(i,j-1,k+1)))
	    end do
	  end do
	end do
      end if
      return
      end


PROGRAM ic
!  Emulate the first successful numerical weather prediction.
!  It was run on the ENIAC during 1948 and 1949.
!  The results and method were written up in Tellus 2, p. 237 1950.
!      Robert Grumbine 2 May 1995. Fortran 77
! Typographical translation to Fortran 90 23 March 2019

!  Non-dimensional constants
  INTEGER p, q, n, ip, jp
  PARAMETER (p = 18)
  PARAMETER (q = 15)
  PARAMETER (n = 24)
  PARAMETER (ip = 9)
  PARAMETER (jp = 13)

!  Declare Dimensional Constants
  REAL g, radius, omega, ds, dt
  PARAMETER (g      = 9.81)
  PARAMETER (radius = 6.37E6)
  PARAMETER (omega  = 7.292E-5)
  PARAMETER (ds     = 7.36E5)
  PARAMETER (dt     = omega*86400/n)

!  Rescale feet (input dimension of Z's) to meters
  REAL fttom
  PARAMETER (fttom = 3.048)
  REAL pi
  PARAMETER (pi = 3.141592654)

!  Declare temporary arrays -
!    These were used because of the memory constraint on the ENIAC --
!      these values were on punched cards recycled through the system
  REAL s(0:p,0:p), t(0:q,0:q), v(0:p,0:q)
  REAL r(0:p,0:q), f(0:p,0:q), h(0:p,0:q)
  REAL a(0:p,0:q), b(0:p,0:q)
  REAL alpha(0:p,0:q), beta(0:p,0:q)
  REAL zp(0:p,0:q), zetap(0:p,0:q)

!  Declare data, physical info.
  REAL z(0:p,0:q), zeta(0:p,0:q), eta(0:p,0:q)

!  Declare computational variables
  INTEGER i, j, k, l, m

!***********************************************************!!
!  Set up the initial conditions deck
  DATA (z(0,j),j=0,q)  /910, 899, 900, 885, 880, 890, 895, 885, 895, 920, 910, 890, 870, 860, 850, 840/
  DATA (z(1,j),j=0,q)  /907, 900, 895, 880, 870, 885, 890, 890, 900, 925, 920, 900, 880, 870, 840, 830/
  DATA (z(2,j),j=0,q)  /905, 901, 890, 877, 865, 865, 880, 885, 900, 920, 930, 910, 885, 860, 820, 800/
  DATA (z(3,j),j=0,q)  /908, 901, 888, 870, 847, 830, 830, 850, 890, 900, 900, 890, 860, 800, 760, 720/
  DATA (z(4,j),j=0,q)  /910, 905, 888, 871, 840, 790, 760, 780, 860, 865, 830, 800, 750, 720, 680, 680/
  DATA (z(5,j),j=0,q)  /915, 910, 898, 880, 850, 795, 740, 740, 800, 830, 770, 720, 685, 670, 670, 670/
  DATA (z(6,j),j=0,q)  /918, 919, 915, 900, 865, 810, 750, 730, 750, 740, 730, 690, 655, 665, 665, 665/
  DATA (z(7,j),j=0,q)  /930, 931, 926, 915, 883, 825, 770, 725, 700, 680, 670, 660, 660, 655, 655, 660/
  DATA (z(8,j),j=0,q)  /932, 945, 942, 932, 900, 850, 780, 720, 660, 610, 600, 620, 640, 650, 655, 665/
  DATA (z(9,j),j=0,q)  /935, 950, 950, 942, 924, 890, 800, 710, 640, 600, 590, 580, 600, 645, 660, 675/
  DATA (z(10,j),j=0,q) /933, 940, 945, 942, 926, 890, 810, 720, 650, 600, 580, 560, 620, 655, 670, 685/
  DATA (z(11,j),j=0,q) /931, 934, 939, 935, 897, 880, 830, 750, 690, 620, 600, 600, 630, 670, 685, 700/
  DATA (z(12,j),j=0,q) /925, 926, 925, 920, 890, 865, 830, 760, 710, 670, 620, 620, 650, 690, 700, 710/
  DATA (z(13,j),j=0,q) /920, 919, 896, 903, 875, 845, 810, 760, 735, 730, 710, 720, 720, 740, 730, 730/
  DATA (z(14,j),j=0,q) /915, 913, 889, 897, 860, 825, 790, 780, 790, 830, 840, 850, 820, 780, 760, 740/
  DATA (z(15,j),j=0,q) /912, 910, 885, 891, 860, 830, 820, 840, 860, 890, 900, 900, 850, 790, 770, 755/
  DATA (z(16,j),j=0,q) /908, 908, 885, 900, 880, 870, 880, 890, 910, 925, 920, 900, 870, 800, 780, 765/
  DATA (z(17,j),j=0,q) /905, 907, 886, 905, 890, 900, 910, 920, 920, 920, 900, 890, 870, 840, 800, 780/
  DATA (z(18,j),j=0,q) /903, 906, 886, 910, 900, 920, 920, 925, 915, 910, 890, 880, 860, 850, 820, 810/
!***********************************************************!!

! BEGIN THE EXECUTION HERE
! This file is not comparable to anything in the original program.
  OPEN (UNIT=1, FILE="original_eniac_ic.txt", FORM="FORMATTED")
  OPEN (UNIT=2, FILE="original_eniac_ic.bin", FORM="UNFORMATTED")

  PRINT *,SECOND()*1000.,' ms'
!  z = z - 820
! Rescale the heights (10's of feet) to metric
  z    = z / fttom
  PRINT *,'average initial z = ',SUM(z)/FLOAT(p+1)/FLOAT(q+1)
  WRITE(1,*) z
  WRITE(2) z

  PRINT *,SECOND()*1000.,' ms'

!***********************************************************!!

  END


!
!  Written by Leandro Martínez, 2009-2011.
!  Copyright (c) 2009-2011, Leandro Martínez, Jose Mario Martinez,
!  Ernesto G. Birgin.
!
! Subroutines that set the indexes of a three-dimensional array
! given the undimensional counter of the vector (for an array
! with dimensions (0:nboxes(1)+1,0:nboxes(2)+1,0:nboxes(3)+1), and
! vice-versa.
!

subroutine ibox_to_ijk(ibox,i,j,k)

  use compute_data, only : nb2
  implicit none
  integer :: ibox, i, j, k, iibox

  k = mod(ibox,nb2(3))
  if ( k == 0 ) k = nb2(3)

  iibox = ibox - k
  iibox = iibox / nb2(3) + 1
  j = mod(iibox,nb2(2))
  if ( j == 0 ) j = nb2(2)

  iibox = iibox - j
  iibox = iibox / nb2(2) + 1
  i = mod(iibox,nb2(1))
  if ( i == 0 ) i = nb2(1)

  k = k - 1
  j = j - 1
  i = i - 1

end subroutine ibox_to_ijk

subroutine ijk_to_ibox(i,j,k,ibox)

  use compute_data, only : nb2
  implicit none
  integer :: i, j, k, ibox

  ibox = i*nb2(2)*nb2(3) + j*nb2(3) + k + 1

end subroutine ijk_to_ibox


!------------------------------------------------------------------------------!
!> Numerical utilities related to the output of VMEC.
!------------------------------------------------------------------------------!
module VMEC_utilities
#include <PB3D_macros.h>
    use str_utilities
    use output_ops
    use messages
    use num_vars, only: &
        &dp, max_str_ln, pi
    use VMEC_vars

    implicit none
    private
    public calc_trigon_factors, fourier2real
#if ldebug
    public debug_calc_trigon_factors
#endif

    ! global variables
#if ldebug
    logical :: debug_calc_trigon_factors = .false.                              !< plot debug information for calc_trigon_factors() \ldebug
#endif

    ! interfaces

    !> \public Inverse Fourier transformation, from VMEC.
    !!
    !! Also calculates the poloidal or  toroidal derivatives in VMEC coords., as
    !! indicated by the variable \c deriv(2).
    !!
    !! (The normal derivative  is done on the variables in  Fourier space, and should
    !! be provided here in \c varf_i if needed).
    !!
    !! There are two variants:
    !!  -# version using trigon_factors, which is  useful when the grid on which
    !!  the trigonometric  factors are defined  is not regular and  ideally when
    !!  they are reused multiple times.
    !!  -# version using \f$\theta\f$ and  \f$\zeta\f$ directly, which is useful
    !!  for small, unique calculations.
    !!
    !! Both  these  versions  make  use  of  a  factor  that  represents  angular
    !! derivatives. For <tt>deriv = [j,k]</tt>, this is:
    !!  - \f$m^j (-n)^k (-1)^{\frac{j+k+1}{2}}\f$   for \c varf_c,
    !!  - \f$m^j (-n)^k (-1)^{\frac{j+k}{2}}\f$     for \c varf_s,
    !!
    !! where  the  divisions  have  to  be  done  using  integers,  i.e.  without
    !! remainder. The  first two factors  are straightforward, and the  third one
    !! originates in  the change of  sign when deriving a  cosine, but not  for a
    !! sine.
    !!
    !! Finally, depending  on whether  \f$(j+k)\f$ is even  or odd,  the correct
    !! \f$\cos\f$ or \f$\sin\f$ is chosen.
    !!
    !! \return ierr
    interface fourier2real
        !> \public
        module procedure fourier2real_1
        !> \public
        module procedure fourier2real_2
    end interface

contains
    !> \private version with trigonometric factors
    integer function fourier2real_1(varf_c,varf_s,trigon_factors,varr,sym,&
        &deriv) result(ierr)

        character(*), parameter :: rout_name = 'fourier2real_1'

        ! input / output
        real(dp), intent(in) :: varf_c(:,:)                                     !< \f$\cos\f$ factor of variable in Fourier space
        real(dp), intent(in) :: varf_s(:,:)                                     !< \f$\sin\f$ factor of variable in Fourier space
        real(dp), intent(in) :: trigon_factors(:,:,:,:,:)                       !< trigonometric factor cosine and sine at these angles (see calc_trigon_factors())
        real(dp), intent(inout) :: varr(:,:,:)                                  !< variable in real space
        logical, intent(in), optional :: sym(2)                                 !< whether to use \c varf_c (1) and / or \c varf_s (2)
        integer, intent(in), optional :: deriv(2)                               !< optional derivatives in angular coordinates

        ! local variables
        character(len=max_str_ln) :: err_msg                                    ! error message
        integer :: dims(3)                                                      ! dimensions of varr
        integer :: id, kd                                                       ! counters
        integer :: deriv_loc(2)                                                 ! local derivative
        logical :: sym_loc(2)                                                   ! local sym
        real(dp) :: deriv_fac                                                   ! factur due to derivatives

        ! initialize ierr
        ierr = 0

        ! set local deriv and sym
        deriv_loc = [0,0]
        sym_loc = [.true.,.true.]
        if (present(deriv)) deriv_loc = deriv
        if (present(sym)) sym_loc = sym

        ! set dimensions
        dims = shape(varr)

        ! test
        if (.not.sym_loc(1) .and. .not.sym_loc(2)) then
            ierr = 1
            err_msg = 'Need at least the cosine or the sine factor'
            CHCKERR(err_msg)
        end if
        if (size(trigon_factors,1).ne.mnmax_V .and. &
            &size(trigon_factors,2).ne.dims(1) .and. &
            &size(trigon_factors,3).ne.dims(2) .and. &
            &size(trigon_factors,4).ne.dims(3) .and. &
            &size(trigon_factors,5).ne.2) then
            ierr = 1
            err_msg = 'Trigonometric factors are not set up'
            CHCKERR(err_msg)
        end if

        ! initialize
        varr = 0.0_dp

        ! sum over modes
        do id = 1,mnmax_V
            ! setup derivative factor for varf_c
            deriv_fac = mn_V(id,1)**deriv_loc(1)*(-mn_V(id,2))**deriv_loc(2)*&
                &(-1)**((sum(deriv_loc)+1)/2)

            ! add terms ~ varf_c
            if (sym_loc(1)) then
                if (mod(sum(deriv_loc),2).eq.0) then                            ! even number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_c(id,kd) * deriv_fac * &
                            &trigon_factors(id,:,:,kd,1)
                    end do
                else                                                            ! odd number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_c(id,kd) * deriv_fac * &
                            &trigon_factors(id,:,:,kd,2)
                    end do
                end if
            end if

            ! setup derivative factor for varf_s
            deriv_fac = mn_V(id,1)**deriv_loc(1)*(-mn_V(id,2))**deriv_loc(2)*&
                &(-1)**(sum(deriv_loc)/2)

            ! add terms ~ varf_s
            if (sym_loc(2)) then
                if (mod(sum(deriv_loc),2).eq.0) then                            ! even number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_s(id,kd) * deriv_fac * &
                            &trigon_factors(id,:,:,kd,2)
                    end do
                else                                                            ! odd number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_s(id,kd) * deriv_fac * &
                            &trigon_factors(id,:,:,kd,1)
                    end do
                end if
            end if
        end do
    end function fourier2real_1
    !> \private version with angles
    integer function fourier2real_2(varf_c,varf_s,theta,zeta,varr,sym,deriv) &
        &result(ierr)

        character(*), parameter :: rout_name = 'fourier2real_2'

        ! input / output
        real(dp), intent(in) :: varf_c(:,:)                                     !< \f$\cos\f$ factor of variable in Fourier space
        real(dp), intent(in) :: varf_s(:,:)                                     !< \f$\sin\f$ factor of variable in Fourier space
        real(dp), intent(in) :: theta(:,:,:)                                    !< \f$\theta_\text{E}\f$
        real(dp), intent(in) :: zeta(:,:,:)                                     !< \f$\zeta_\text{E}\f$
        real(dp), intent(inout) :: varr(:,:,:)                                  !< variable in real space
        logical, intent(in), optional :: sym(2)                                 !< whether to use \c varf_c (1) and / or \c varf_s (2)
        integer, intent(in), optional :: deriv(2)                               !< optional derivatives in angular coordinates

        ! local variables
        character(len=max_str_ln) :: err_msg                                    ! error message
        integer :: dims(3)                                                      ! dimensions of varr
        integer :: id, kd                                                       ! counters
        integer :: deriv_loc(2)                                                 ! local derivative
        logical :: sym_loc(2)                                                   ! local sym
        real(dp) :: deriv_fac                                                   ! factur due to derivatives
        real(dp), allocatable :: ang(:,:,:)                                     ! angle of trigonometric functions

        ! initialize ierr
        ierr = 0

        ! set local deriv and sym
        deriv_loc = [0,0]
        sym_loc = [.true.,.true.]
        if (present(deriv)) deriv_loc = deriv
        if (present(sym)) sym_loc = sym

        ! test
        if (.not.sym_loc(1) .and. .not.sym_loc(2)) then
            ierr = 1
            err_msg = 'Need at least the cosine or the sine factor'
            CHCKERR(err_msg)
        end if

        ! set dimensions
        dims = shape(varr)

        ! initialize angle
        allocate(ang(dims(1),dims(2),dims(3)))

        ! initialize output
        varr = 0.0_dp

        ! sum over modes
        do id = 1,mnmax_V
            ! set angle
            ang = mn_V(id,1)*theta - mn_V(id,2)*zeta

            ! setup derivative factor for varf_c
            deriv_fac = mn_V(id,1)**deriv_loc(1)*(-mn_V(id,2))**deriv_loc(2)*&
                &(-1)**((sum(deriv_loc)+1)/2)

            ! add terms ~ varf_c
            if (sym_loc(1)) then
                if (mod(sum(deriv_loc),2).eq.0) then                            ! even number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_c(id,kd) * deriv_fac * cos(ang(:,:,kd))
                    end do
                else                                                            ! odd number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_c(id,kd) * deriv_fac * sin(ang(:,:,kd))
                    end do
                end if
            end if

            ! setup derivative factor for varf_s
            deriv_fac = mn_V(id,1)**deriv_loc(1)*(-mn_V(id,2))**deriv_loc(2)*&
                &(-1)**(sum(deriv_loc)/2)

            ! add terms ~ varf_s
            if (sym_loc(2)) then
                if (mod(sum(deriv_loc),2).eq.0) then                            ! even number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_s(id,kd) * deriv_fac * sin(ang(:,:,kd))
                    end do
                else                                                            ! odd number of derivatives
                    do kd = 1,dims(3)
                        varr(:,:,kd) = varr(:,:,kd) + &
                            &varf_s(id,kd) * deriv_fac * cos(ang(:,:,kd))
                    end do
                end if
            end if
        end do
    end function fourier2real_2

    !> Calculate the trigonometric cosine and sine factors.
    !!
    !! This  is  done  on  a   grid  <tt>(1:mnmax_V)</tt>  at  given  3D  arrays
    !! for   the   (VMEC)   E(quilibrium)   angles   \f$\theta_\text{E}\f$   and
    !! \f$\zeta_\text{E}\f$.
    !!
    !! The dimensions of the output array are
    !!
    !! <tt>(1:mnmax_V,1:n_ang_1,1:n_ang_2,1:n_r,1:2)</tt>
    !!
    !! where  \c mnmax_V  is the number  of modes  in VMEC \c  n_r is  the total
    !! number of normal points.
    !!
    !! \see See grid_vars.grid_type for a discussion on \c ang_1 and \c ang_2.
    !!
    !! \return ierr
    integer function calc_trigon_factors(theta,zeta,trigon_factors) &
        &result(ierr)

        character(*), parameter :: rout_name = 'calc_trigon_factors'

        ! input / output
        real(dp), intent(in) :: theta(:,:,:)                                    !< poloidal angles in equilibrium coords.
        real(dp), intent(in) :: zeta(:,:,:)                                     !< toroidal angles in equilibrium coords.
        real(dp), intent(inout), allocatable :: trigon_factors(:,:,:,:,:)       !< trigonometric factor cosine and sine at these angles

        ! local variables
        character(len=max_str_ln) :: err_msg                                    ! error message
        integer :: n_ang_1, n_ang_2, n_r                                        ! sizes of 3D real output array
        real(dp), allocatable :: cos_theta(:,:,:,:)                             ! cos(m theta) for all m
        real(dp), allocatable :: sin_theta(:,:,:,:)                             ! sin(m theta) for all m
        real(dp), allocatable :: cos_zeta(:,:,:,:)                              ! cos(n theta) for all n
        real(dp), allocatable :: sin_zeta(:,:,:,:)                              ! sin(n theta) for all n
        integer :: id, m, n                                                     ! counters

        ! initialize ierr
        ierr = 0

        ! set n_ang_1 and n_r
        n_ang_1 = size(theta,1)
        n_ang_2 = size(theta,2)
        n_r = size(theta,3)

#if ldebug
        if (debug_calc_trigon_factors) then
            call writo('Calculate trigonometric factors for grid of size ['//&
                &trim(i2str(n_ang_1))//','//trim(i2str(n_ang_2))//','//&
                &trim(i2str(n_r))//']')
        end if
#endif

        ! tests
        if (size(zeta,1).ne.n_ang_1 .or. size(zeta,2).ne.n_ang_2 .or. &
            &size(zeta,3).ne.n_r) then
            ierr = 1
            err_msg = 'theta and zeta need to have the same size'
            CHCKERR(err_msg)
        end if

        ! setup cos_theta, sin_theta, cos_zeta and sin_zeta
        allocate(cos_theta(0:mpol_V-1,n_ang_1,n_ang_2,n_r))
        allocate(sin_theta(0:mpol_V-1,n_ang_1,n_ang_2,n_r))
        allocate(cos_zeta(-ntor_V:ntor_V,n_ang_1,n_ang_2,n_r))
        allocate(sin_zeta(-ntor_V:ntor_V,n_ang_1,n_ang_2,n_r))

        do m = 0,mpol_V-1
#if ldebug
            if (debug_calc_trigon_factors) then
                call writo('Calculating for m = '//trim(i2str(m))//&
                    &' of [0..'//trim(i2str(mpol_V-1))//']')
            end if
#endif
            cos_theta(m,:,:,:) = cos(m*theta)
            sin_theta(m,:,:,:) = sin(m*theta)
        end do
        do n = -ntor_V,ntor_V
#if ldebug
            if (debug_calc_trigon_factors) then
                call writo('Calculating for n = '//trim(i2str(n))//&
                    &' of ['//trim(i2str(-ntor_V))//'..'//&
                    &trim(i2str(ntor_V))//']')
            end if
#endif
            cos_zeta(n,:,:,:) = cos(n*nfp_V*zeta)
            sin_zeta(n,:,:,:) = sin(n*nfp_V*zeta)
        end do

        ! initialize trigon_factors
        allocate(trigon_factors(mnmax_V,n_ang_1,n_ang_2,n_r,2),STAT=ierr)
        CHCKERR('Failed to allocate trigonometric factors')
        trigon_factors = 0.0_dp

        ! calculate cos(m theta - n zeta) =
        !   cos(m theta) cos(n zeta) + sin(m theta) sin(n zeta)
        ! and sin(m theta - n zeta) =
        !   sin(m theta) cos(n zeta) - cos(m theta) sin(n zeta)
        ! Note: need to scale the indices mn_V(:,2) by nfp_V.
        do id = 1,mnmax_V
#if ldebug
            if (debug_calc_trigon_factors) then
                call writo('Calculating for id = '//trim(i2str(id))//&
                        &' of [1..'//trim(i2str(mnmax_V))//']')
            end if
#endif
            trigon_factors(id,:,:,:,1) = &
                &cos_theta(mn_V(id,1),:,:,:)*&
                &cos_zeta(mn_V(id,2)/nfp_V,:,:,:) + &
                &sin_theta(mn_V(id,1),:,:,:)*&
                &sin_zeta(mn_V(id,2)/nfp_V,:,:,:)
            trigon_factors(id,:,:,:,2) = &
                &sin_theta(mn_V(id,1),:,:,:)*&
                &cos_zeta(mn_V(id,2)/nfp_V,:,:,:) - &
                &cos_theta(mn_V(id,1),:,:,:)*&
                &sin_zeta(mn_V(id,2)/nfp_V,:,:,:)
        end do

        ! deallocate variables
        deallocate(cos_theta,sin_theta)
        deallocate(cos_zeta,sin_zeta)
    end function calc_trigon_factors
end module VMEC_utilities


C
C
C  $Id: trip.f,v 1.1 1994-08-11 23:17:37 boote Exp $
C
C This subprogram is used by subroutine COEFF1 in library
C ncarm.  It is lower-level, i.e. not called by users.
C *******************************************************
      SUBROUTINE TRIP (N,A,B,C,Y,Z,INT)
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                Z(1)
      SAVE
C
C ARITHMETIC STATEMENT FUNCTION USED TO LOCATE ENTRIES IN ARRAY Z.
C
      II(INDEX)=(INDEX-1)*INT+1
C
C GAUSSIAN ELIMINATION
C
      BN = B(N)
      YN = Y(N)
      V = C(N)
      Y(1) = Y(1)/B(1)
      A(1) = A(1)/B(1)
      B(1) = C(1)/B(1)
      NM2 = N-2
      DO 101 J=2,NM2
         DEN = B(J)-A(J)*B(J-1)
         B(J) = C(J)/DEN
         Y(J) = (Y(J)-A(J)*Y(J-1))/DEN
         A(J) = -A(J)*A(J-1)/DEN
         BN = BN-V*A(J-1)
         YN = YN-V*Y(J-1)
         V = -V*B(J-1)
  101 CONTINUE
      DEN = B(N-1)-A(N-1)*B(N-2)
      B(N-1) = (C(N-1)-A(N-1)*A(N-2))/DEN
      Y(N-1) = (Y(N-1)-A(N-1)*Y(N-2))/DEN
      BN = BN-V*A(N-2)
      YN = YN-V*Y(N-2)
      V = A(N)-V*B(N-2)
C BACK SUBSTITUTION
      IIN = II(N)
      Z(IIN) = (YN-V*Y(N-1))/(BN-V*B(N-1))
      IIN2 = II(N-1)
      Z(IIN2) = Y(N-1)-B(N-1)*Z(IIN)
      NM1 = N-1
      IN = II(N)
      DO 102 J=2,NM1
         K = N-J
         IK = II(K)
      IKT = IK+INT
  102 Z(IK) = Y(K)-B(K)*Z(IKT)-A(K)*Z(IN)
      RETURN
      END


      real function wtlqk(iwt)                                           wtlqk
c--------------------------------------------------------------------    wtlqk
c  returns statistical weighting parameter for this datum.  formula      wtlqk
c  used is consistent with that in lquake2.                              wtlqk
c  arguments-                                                           wtlqk
c    iwt - interger weight read from phase data card.                    wtlqk
c--------------------------------------------------------------------    wtlqk
      sigma=0.05+iwt*0.05                                                wtlqk
      wtlqk=1.0/sigma                                                    wtlqk
      return                                                             wtlqk
      end                                                                wtlqk

c $Id$


!####################################################################
!        The subroutine "drsaehubdestiter" derives code from Richard
!        Brent's Fortran77 function "zeroin"; cf., Brent, R.P.
!        1973, Algorithms for Minimization without Derivatives
!        (Englewood Cliffs, NJ: Prentice- Hall).
!
!        I obtained the code of "zeroin.f" from
!        http://www.netlib.org/go/zeroin.f,
!        on June 24, 2011.
!
!        Richard's original code is licensed under GNU General
!        Public License (cf.,
!        http//:maths.anu.edu.au/~brent/software.html; June 24, 2011).
!
!        I modified the original code in order that it meets
!        the gfortran f90 standards, and added some specific
!        blocks that I need for my computations.
!
!        I therefore license the subroutine "drsaehubdestiter"
!        also under GNU General Public License; GPL >=2.
!
!        You can find a copy of the GPL-2 license under
!        $RHOME/share/licenses/GPL-2
!        where $RHOME denotes the root directory of your R
!        (r-project.org) installation.
!
!####################################################################
!
!====================================================================
!SUBROUTINE:   drsaehubdestiter
!PART OF:      rsae
!DESCRIPTION:  root-finding device; evaluates drsaehubdest between
!              lower and upper; there must be a sign change in the
!              interval, otherwise the sub stops
!DEPENDENCY:   none
!ON ENTRY:
!  INTEGER n(1), g(1), nsize(g), dec(1)
!  REAL v(1), k(1), kappa(1), lower(1), upper(1), tol(1), res(n)
!ON RETURN
!  INTEGER info(1)
!  REAL zeroin(1)
!--------------------------------------------------------------------
!
SUBROUTINE drsaehubdestiter(n, g, nsize, v, k, kappa, res, lower, upper, &
      tol, zeroin, info, dec, decorr)
   IMPLICIT NONE
   !zeroin declarations
   INTEGER, INTENT(OUT) :: info  !info was not in Richard's original
   !defintion (since zeroin was a function)
   DOUBLE PRECISION, INTENT(IN) :: lower, upper, tol
   DOUBLE PRECISION, INTENT(OUT) :: zeroin
   !foo declarations
   INTEGER, INTENT(IN) :: n, g, dec, decorr
   INTEGER, INTENT(IN) :: nsize(g)
   DOUBLE PRECISION, INTENT(IN) :: v, k, kappa
   DOUBLE PRECISION, INTENT(IN) :: res(n)
   !local declarations
   INTEGER, PARAMETER :: ITMAX = 100
   INTEGER :: iter
   DOUBLE PRECISION :: a, b, c, d, e, fa, fb, fc, tol1, xm, p, q, r, s
   !define a precision constant, cf R .Machine$double.eps for double
   !data type, i.e., 64bit sized blocks
   DOUBLE PRECISION, PARAMETER :: EPS = 2.3E-16
   !initialize
   info = 0
   !start with checking whether there is a sign change, if not break
   a = lower
   b = upper
   !note that these function calls have been added to Richard's
   !original code
   !compute fa (i.e., evaluation for a = lower)
   CALL drsaehubdest(n, g, nsize, a, v, k, kappa, res, fa, dec, decorr)
   !compute fb (i.e., evaluation for b = upper)
   CALL drsaehubdest(n, g, nsize, b, v, k, kappa, res, fb, dec, decorr)
   !check that f(lower) and f(upper) have different signs
   IF ((fa > 0D0 .and. fb > 0D0) .or. (fa < 0D0 .and. fb < 0D0)) THEN
      !return -1; this violates the assumption and therefore be detected
      info = -1
      zeroin = 0D0
   ELSE
      c = b
      fc = fb
      DO iter = 1,ITMAX
         IF ((fb > 0D0 .and. fc > 0D0) .or. &
               (fb < 0D0 .and. fc < 0D0)) THEN
            c = a
            fc = fa
            d = b - a
            e = d
         END IF
         IF (ABS(fc) < ABS(fb)) THEN
            a = b
            b = c
            c = a
            fa = fb
            fb = fc
            fc = fa
         END IF
         tol1 = 2D0 * EPS * ABS(b)+ 5D-1 * tol
         xm = 5D-1 * (c-b)
         IF (ABS(xm) <= tol1 .or. fb == 0D0) THEN
            zeroin = b
            !if it converges, then info=# iterations
            info = iter
            EXIT
         END IF
         ! see if a bisection is forced
         IF (ABS(e) >= tol1 .and. ABS(fa) > ABS(fb)) THEN
            s = fb / fa
            IF (a == c) THEN
               !linear interpolation
               p = 2D0 * xm * s
               q = 1D0 - s
            ELSE
               !inverse quadratic interpolation
               q = fa / fc
               r = fb / fc
               p = s * (2D0 * xm * q * (q - r) - (b - a) * (r - 1D0))
               q = (q - 1D0) * (r - 1D0) * (s - 1D0)
            END IF
            IF (p > 0D0) THEN
               q = -q
            END IF
            p = ABS(p)
            IF (2D0 * p  <  MIN(3D0 * xm * q - ABS(tol1 * q), &
                  ABS(e * q))) THEN
               e = d
               d = p / q
            ELSE
               d = xm
               e = d
            END IF
         ELSE
            d = xm
            e = d
         END IF
         a = b
         fa = fb
         !note merge and sign work that way in gfortran (which may no
         !be true
         !for others; I did not check it)
         b = b + MERGE(d, SIGN(tol1, xm), ABS(d) > tol1)
         ! note this function call has been added to Richard's origial
         !code
         !eval function at b
         CALL drsaehubdest(n, g, nsize, b, v, k, kappa, res, fb, dec,&
            decorr)
      END DO
      !return b; however, it did not converge, therefore info=0, still
      zeroin = b
   END IF
END SUBROUTINE
!
!####################################################################
! EOF rsaeext.f90
!####################################################################


!==========================================================================
pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i)
!==========================================================================
! Returns the value of the 1-D function iy (integer) at the points of column
! vector x_i using linear interpolation. The vector x specifies the
! coordinates of the underlying interval.
!==========================================================================

use gsw_mod_toolbox, only : gsw_util_sort_real

use gsw_mod_kinds

implicit none

integer, intent(in) :: iy(:)
real (r8), intent(in) :: x(:), x_i(:)

real (r8) :: y_i(size(x_i))

logical, allocatable :: in_rng(:)
integer, allocatable :: j(:), k(:), r(:), jrev(:), ki(:)
real (r8), allocatable :: xi(:), xxi(:), u(:)

integer :: imax_x(1), imin_x(1), i, n, m, ii, nx, nxi
real (r8) :: max_x, min_x

min_x = minval(x); imin_x = minloc(x)
max_x = maxval(x); imax_x = maxloc(x)

where (x_i .le. min_x) y_i = iy(imin_x(1))
where (x_i .ge. max_x) y_i = iy(imax_x(1))

nx = size(x)
nxi = size(x_i)

allocate (in_rng(nxi))
in_rng = (x_i .gt. min_x .and. x_i .lt. max_x)

n = count(in_rng)
if (n .eq. 0) return

allocate (xi(n), k(n), ki(n), r(n), u(n))
m = nx + n
allocate (xxi(m), j(m), jrev(m))

ii = 0
do i = 1, nxi
    if (in_rng(i)) then
        ii = ii + 1
        xi(ii) = x_i(i)
        ki(ii) = i
    end if
end do

k = gsw_util_sort_real(xi)
xxi = (/ x, xi(k) /)
j = gsw_util_sort_real(xxi)

jrev(j) = (/ (i, i=1,size(j)) /)
r(k) = jrev(nx+1:) - (/ (i, i=1,size(xi)) /)

u = (xi-x(r))/(x(r+1)-x(r))
y_i(ki) = iy(r) + (iy(r+1)-iy(r))*u

return

end function

!--------------------------------------------------------------------------


program main
use routines
implicit none

integer:: i
integer(kind=16) :: fnumber

do i = 0, 100
   call f_routine(i, fnumber)
   write(*,*) i, fnumber
end do

end program main


SUBROUTINE StaggerXY_3D(vin,nx,ny,nz,onx,ony,onz,vout)

!==========================================================
!  This routine computes a stagger grid
!  using a given horizontal uniform grid
!
!  Input:
!	vin:    Data prepare to stagger
!	nx:	X grid point number before stagger
!	ny:	Y grid point number before stagger
!	nz:	Z grid point number before stagger
!       onx:    X grid point number after stagger
!       ony:    Y grid point number after stagger
!       onz:    Z grid point number after stagger
!
!  Output:
!	vout:   Data after stagger
!
!==========================================================

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nx,ny,nz,onx,ony,onz
  REAL, INTENT(IN) ::    vin(nx,ny,nz)
  REAL, INTENT(OUT) ::   vout(onx,ony,onz)

  ! Local variables:

  REAL :: vinx(nx-1,ny,nz),viny(nx,ny-1,nz),vinyy(nx-1,ny-1,nz)

  ! Linear interpolation:

    if(nx /= onx .and. ny /= ony .and. onz /= 1) then

        vinx(1:nx-1,1:ny,1:nz) = 0.5*( &
             vin(1:nx-1,1:ny,1:nz)+ &
             vin(2:nx  ,1:ny,1:nz))
        vinyy(1:nx-1,1:ny-1,1:nz) = 0.5*( &
             vinx(1:nx-1,1:ny-1,1:nz)+ &
             vinx(1:nx-1,2:ny  ,1:nz))

        vout(1:onx,1:ony,1:nz) = vinyy(1:nx-1,1:ny-1,1:nz)

    elseif(nx /= onx .and. ny /= ony .and. onz == 1) then

        vinx(1:nx-1,1:ny,1) = 0.5*( &
             vin(1:nx-1,1:ny,1)+ &
             vin(2:nx  ,1:ny,1))
        vinyy(1:nx-1,1:ny-1,1) = 0.5*( &
             vinx(1:nx-1,1:ny-1,1)+ &
             vinx(1:nx-1,2:ny  ,1))

        vout(1:onx,1:ony,1) = vinyy(1:nx-1,1:ny-1,1)

    elseif(nx /= onx .and. ny == ony) then

        vinx(1:nx-1,1:ny,1:nz) = 0.5*( &
             vin(1:nx-1,1:ny,1:nz)+ &
             vin(2:nx  ,1:ny,1:nz))

        vout(1:onx,1:ony,1:nz) = vinx(1:nx-1,1:ny,1:nz)

    elseif(nx == onx .and. ny /= ony) then

        viny(1:nx,1:ny-1,1:nz) = 0.5*( &
             vin(1:nx,1:ny-1,1:nz)+ &
             vin(1:nx,2:ny  ,1:nz))

        vout(1:onx,1:ony,1:nz) = viny(1:nx,1:ny-1,1:nz)

    endif

END SUBROUTINE StaggerXY_3D

SUBROUTINE StaggerXY_2D(vin,nx,ny,onx,ony,vout)

!==========================================================
!  This routine computes a stagger grid
!  using a given horizontal uniform grid
!
!  Input:
!	vin:    Data prepare to stagger
!	nx:	X grid point number before stagger
!	ny:	Y grid point number before stagger
!       onx:    X grid point number after stagger
!       ony:    Y grid point number after stagger
!
!  Output:
!	vout:   Data after stagger
!
!==========================================================

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nx,ny,onx,ony
  REAL, INTENT(IN) ::    vin(nx,ny)
  REAL, INTENT(OUT) ::   vout(onx,ony)

  ! Local variables:

  REAL :: vinx(nx-1,ny),viny(nx,ny-1),vinyy(nx-1,ny-1)

  ! Linear interpolation:

    if(nx /= onx .and. ny /= ony) then

        vinx(1:nx-1,1:ny) = 0.5*( &
             vin(1:nx-1,1:ny)+ &
             vin(2:nx  ,1:ny))
        vinyy(1:nx-1,1:ny-1) = 0.5*( &
             vinx(1:nx-1,1:ny-1)+ &
             vinx(1:nx-1,2:ny))

        vout(1:onx,1:ony) = vinyy(1:nx-1,1:ny-1)

    elseif(nx /= onx .and. ny == ony) then

        vinx(1:nx-1,1:ny) = 0.5*( &
             vin(1:nx-1,1:ny)+ &
             vin(2:nx  ,1:ny))

        vout(1:onx,1:ony) = vinx(1:nx-1,1:ny)

    elseif(nx == onx .and. ny /= ony) then

        viny(1:nx,1:ny-1) = 0.5*( &
             vin(1:nx,1:ny-1)+ &
             vin(1:nx,2:ny))

        vout(1:onx,1:ony) = viny(1:nx,1:ny-1)

    endif

END SUBROUTINE StaggerXY_2D

SUBROUTINE UntaggerXY_3D(vin,nx,ny,nz,onx,ony,vout)

!==========================================================
!  This routine computes a unstagger grid
!  using a given horizontal stagger grid
!
!  Input:
!	vin:    stagger Data prepare to unstagger
!	nx:	number of stagger grid in X
!	ny:     number of stagger grid in Y
!	nz:     Z grid point number after unstagger
!       onx:    X grid point number after unstagger
!       ony:    Y grid point number after unstagger
!
!  Output:
!	vout:   Data after unstagger
!
!==========================================================

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nx,ny,nz,onx,ony
  REAL, INTENT(IN) ::    vin(nx,ny,nz)
  REAL, INTENT(OUT) ::   vout(onx,ony,nz)

  ! Local variables:

  INTEGER :: i,j,k
  REAL :: vinx(onx,ony,nz),viny(onx,ony,nz),vinyy(nx,ony,nz)

  ! Linear interpolation:

    if(nx /= onx .and. ny /= ony) then

       do k = 1,nz
          do i=1,nx
             do j=2,ny
                   vinyy(i,j,k) = &
                   0.5*(vin(i,j-1,k)+ vin(i,j,k))
             enddo
             vinyy(i,1,k) = &
                   1.5*vin(i,1,k)-&
                   0.5*vin(i,2,k)
             vinyy(i,ony,k) = &
                   1.5*vin(i,ny,k)-&
                   0.5*vin(i,ny-1,k)
          enddo
       enddo

       do k = 1,nz
          do j=1,ony
             do i=2,nx
                vinx(i,j,k) = &
                0.5*(vinyy(i-1,j,k)+ vinyy(i,j,k))
             enddo
             vinx(1,j,k) = &
                1.5*vinyy(1,j,k)-&
                0.5*vinyy(2,j,k)
             vinx(onx,j,k) = &
                1.5*vinyy(nx,j,k)-&
                0.5*vinyy(nx-1,j,k)
          enddo
       enddo

       vout(1:onx,1:ony,1:nz) = vinx(1:onx,1:ony,1:nz)

    elseif(nx /= onx .and. ny == ony) then

       do k = 1,nz
          do j=1,ony
             do i=2,nx
                vinx(i,j,k) = &
                0.5*(vin(i-1,j,k)+ vin(i,j,k))
             enddo
             vinx(1,j,k) = &
                1.5*vin(1,j,k)-&
                0.5*vin(2,j,k)
             vinx(onx,j,k) = &
                1.5*vin(nx,j,k)-&
                0.5*vin(nx-1,j,k)
          enddo
       enddo

       vout(1:onx,1:ony,1:nz) = vinx(1:onx,1:ony,1:nz)

    elseif(nx == onx .and. ny /= ony) then

       do k = 1,nz
          do i=1,onx
             do j=2,ny
                   viny(i,j,k) = &
                   0.5*(vin(i,j-1,k)+ vin(i,j,k))
             enddo
             viny(i,1,k) = &
                   1.5*vin(i,1,k)-&
                   0.5*vin(i,2,k)
             viny(i,ony,k) = &
                   1.5*vin(i,ny,k)-&
                   0.5*vin(i,ny-1,k)
          enddo
       enddo

       vout(1:onx,1:ony,1:nz) = viny(1:onx,1:ony,1:nz)

    endif

END SUBROUTINE UntaggerXY_3D

SUBROUTINE UntaggerXY_2D(vin,nx,ny,onx,ony,vout)

!==========================================================
!  This routine computes a unstagger grid
!  using a given horizontal stagger grid
!
!  Input:
!	vin:    stagger Data prepare to unstagger
!	nx:	number of stagger grid in X
!	ny:     number of stagger grid in Y
!       onx:    X grid point number after unstagger
!       ony:    Y grid point number after unstagger
!
!  Output:
!	vout:   Data after unstagger
!
!==========================================================

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nx,ny,onx,ony
  REAL, INTENT(IN) ::    vin(nx,ny)
  REAL, INTENT(OUT) ::   vout(onx,ony)

  ! Local variables:

    INTEGER :: i,j
    REAL :: vinx(onx,ony),viny(onx,ony),vinyy(nx,ony)

  ! Linear interpolation:

    if(nx /= onx .and. ny /= ony) then

          do i=1,nx
             do j=2,ny
                   vinyy(i,j) = &
                   0.5*(vin(i,j-1)+ vin(i,j))
             enddo
             vinyy(i,1) = &
                   1.5*vin(i,1)-&
                   0.5*vin(i,2)
             vinyy(i,ony) = &
                   1.5*vin(i,ny)-&
                   0.5*vin(i,ny-1)
          enddo

          do j=1,ony
             do i=2,nx
                vinx(i,j) = &
                0.5*(vinyy(i-1,j)+ vinyy(i,j))
             enddo
             vinx(1,j) = &
                1.5*vinyy(1,j)-&
                0.5*vinyy(2,j)
             vinx(onx,j) = &
                1.5*vinyy(nx,j)-&
                0.5*vinyy(nx-1,j)
          enddo

        vout(1:onx,1:ony) = vinx(1:onx,1:ony)

    elseif(nx /= onx .and. ny == ony) then

          do j=1,ony
             do i=2,nx
                vinx(i,j) = &
                0.5*(vin(i-1,j)+ vin(i,j))
             enddo
             vinx(1,j) = &
                1.5*vin(1,j)-&
                0.5*vin(2,j)
             vinx(onx,j) = &
                1.5*vin(nx,j)-&
                0.5*vin(nx-1,j)
          enddo

        vout(1:onx,1:ony) = vinx(1:onx,1:ony)

    elseif(nx == onx .and. ny /= ony) then

          do i=1,onx
             do j=2,ny
                   viny(i,j) = &
                   0.5*(vin(i,j-1)+ vin(i,j))
             enddo
             viny(i,1) = &
                   1.5*vin(i,1)-&
                   0.5*vin(i,2)
             viny(i,ony) = &
                   1.5*vin(i,ny)-&
                   0.5*vin(i,ny-1)
          enddo

        vout(1:onx,1:ony) = viny(1:onx,1:ony)

    endif

END SUBROUTINE UntaggerXY_2D


     program demo_grid
     use M_calcomp, only : plots, plot, newpen, grid
     use M_calcomp, only : END
     implicit none
     real              :: xmax=8.5,ymax=11.0
     real              :: step
        call plots(0.0,xmax,0.0,ymax)  ! make a 8 1/2 x 11 inch page
        call newpen(1)                 ! red
        step=0.25                      ! make 1/4 inch grid
        call grid(0.0,0.0,step,step,int(xmax/step)+1,int(ymax/step)+1)
        call newpen(2)                 ! green
        step=0.50                      ! make 1/2 inch grid
        call grid(0.0,0.0,step,step,int(xmax/step)+1,int(ymax/step)+1)
        call plot(0.0,0.0,END)         ! end graphics
     end program demo_grid


!! R432 type-param-decl
!    is type-param-name [ = scalar-int-initialization-expr ]

TYPE big_deal(k, d, l)
   INTEGER, KIND :: k = kind(0.0), d = 13
   INTEGER (KIND=4), LEN :: l = 13
end type

end


SUBROUTINE dismsh(loads,nf,ratmax,g_coord,g_num,argv,nlen,ips)
!
! This subroutine produces a PostScript output file "*.dis" displaying
! the deformed finite element mesh.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::g_coord(:,:),loads(0:),ratmax
 INTEGER,INTENT(IN)::g_num(:,:),ips,nf(:,:),nlen
 CHARACTER(*),INTENT(IN)::argv
 REAL(iwp)::width,height,scale=72,sxy,xo,yo,x,y,dismag,vmax
 REAL(iwp)::xmin,xmax,ymin,ymax,dmax,zero=0.0_iwp,pt5=0.5_iwp,            &
   opt5=1.5_iwp,fpt5=5.5_iwp,d8=8.0_iwp,ept5=8.5_iwp,d11=11.0_iwp
 INTEGER::i,ii,j,jj,nn,nel,nod
 OPEN(ips,FILE=argv(1:nlen)//'.dis')
!
 nn=UBOUND(nf,2)
 xmin=g_coord(1,1)
 xmax=g_coord(1,1)
 ymin=g_coord(2,1)
 ymax=g_coord(2,1)
 DO i=2,nn
   IF(g_coord(1,i)<xmin)xmin=g_coord(1,i)
   IF(g_coord(1,i)>xmax)xmax=g_coord(1,i)
   IF(g_coord(2,i)<ymin)ymin=g_coord(2,i)
   IF(g_coord(2,i)>ymax)ymax=g_coord(2,i)
 END DO
 width=xmax-xmin
 height=ymax-ymin
 dmax=ratmax*width
 IF(height>width)dmax=ratmax*height
!
 vmax=zero
 DO i=1,nn
   DO j=1,2
     IF(ABS(loads(nf(j,i)))>vmax)vmax=ABS(loads(nf(j,i)))
   END DO
 END DO
 dismag=dmax/vmax
!
 xmin=g_coord(1,1)
 xmax=g_coord(1,1)
 ymin=g_coord(2,1)
 ymax=g_coord(2,1)
 DO i=1,nn
   IF(g_coord(1,i)+dismag*loads(nf(1,i))<xmin)                            &
     xmin=g_coord(1,i)+dismag*loads(nf(1,i))
   IF(g_coord(1,i)+dismag*loads(nf(1,i))>xmax)                            &
     xmax=g_coord(1,i)+dismag*loads(nf(1,i))
   IF(g_coord(2,i)+dismag*loads(nf(2,i))<ymin)                            &
     ymin=g_coord(2,i)+dismag*loads(nf(2,i))
   IF(g_coord(2,i)+dismag*loads(nf(2,i))>ymax)                            &
     ymax=g_coord(2,i)+dismag*loads(nf(2,i))
!
   IF(g_coord(1,i)<xmin)xmin=g_coord(1,i)
   IF(g_coord(1,i)>xmax)xmax=g_coord(1,i)
   IF(g_coord(2,i)<ymin)ymin=g_coord(2,i)
   IF(g_coord(2,i)>ymax)ymax=g_coord(2,i)
 END DO
!
 width =xmax-xmin
 height=ymax-ymin
!
!                       allow 1.5" margin minimum on each side of figure
!
!                       portrait mode
!
 IF(height.GE.d11/ept5*width)THEN
!
!                       height governs the scale
!
   sxy=scale*d8/height
   xo=scale*pt5*(ept5-d8*width/height)
   yo=scale*opt5
 ELSE
!
!                       width governs the scale
!
   sxy=scale*fpt5/width
   xo=scale*opt5
   yo=scale*pt5*(d11-fpt5*height/width)
 END IF
!
 nel=UBOUND(g_num,2)
 nod=UBOUND(g_num,1)
!
!                       start PostScript output
!
 WRITE(ips,'(a)')'%!PS-Adobe-1.0'
 WRITE(ips,'(a)')'%%DocumentFonts: none'
 WRITE(ips,'(a)')'%%Pages: 1'
 WRITE(ips,'(a)')'%%EndComments'
 WRITE(ips,'(a)')'/m {moveto} def'
 WRITE(ips,'(a)')'/l {lineto} def'
 WRITE(ips,'(a)')'/s {stroke} def'
 WRITE(ips,'(a)')'/c {closepath} def'
 WRITE(ips,'(a)')'%%EndProlog'
 WRITE(ips,'(a)')'%%Page: 0 1'
 WRITE(ips,'(a)')'gsave'
!
!                       draw the deformed mesh
!
 WRITE(ips,'(2f9.2,a)') xo, yo, ' translate'
 WRITE(ips,'(f9.2,a)') 0.5, ' setlinewidth'
 IF(nod==5)nod=4
 IF(nod==9)nod=8
 IF(nod==10)nod=9
 IF(nod==15)nod=12
 DO i=1,nel
   ii=g_num(1,i)
   IF(ii==0)CYCLE
   x=sxy*(g_coord(1,ii)+dismag*loads(nf(1,ii))-xmin)
   y=sxy*(g_coord(2,ii)+dismag*loads(nf(2,ii))-ymin)
   WRITE(ips,'(2f9.2,a)') x, y,' m'
   DO j=2,nod
     jj=g_num(j,i)
     x=sxy*(g_coord(1,jj)+dismag*loads(nf(1,jj))-xmin)
     y=sxy*(g_coord(2,jj)+dismag*loads(nf(2,jj))-ymin)
     WRITE(ips,'(2f9.2,a)') x, y,' l'
   END DO
   WRITE(ips,'(a)')'c s'
 END DO
!
 WRITE(ips,'(a)')'grestore'
 WRITE(ips,'(a)')'showpage'
 CLOSE(ips)
!
RETURN
END SUBROUTINE dismsh