      SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients of the polynomial
C
C        P(x) = P1(x) * P2(x) + alpha * P3(x),
C
C     where P1(x), P2(x) and P3(x) are given real polynomials and alpha
C     is a real scalar.
C
C     Each of the polynomials P1(x), P2(x) and P3(x) may be the zero
C     polynomial.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DP1     (input) INTEGER
C             The degree of the polynomial P1(x).  DP1 >= -1.
C
C     DP2     (input) INTEGER
C             The degree of the polynomial P2(x).  DP2 >= -1.
C
C     DP3     (input/output) INTEGER
C             On entry, the degree of the polynomial P3(x).  DP3 >= -1.
C             On exit, the degree of the polynomial P(x).
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar value alpha of the problem.
C
C     P1      (input) DOUBLE PRECISION array, dimension (lenp1)
C             where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise.
C             If DP1 >= 0, then this array must contain the
C             coefficients of P1(x) in increasing powers of x.
C             If DP1 = -1, then P1(x) is taken to be the zero
C             polynomial, P1 is not referenced and can be supplied
C             as a dummy array.
C
C     P2      (input) DOUBLE PRECISION array, dimension (lenp2)
C             where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise.
C             If DP2 >= 0, then this array must contain the
C             coefficients of P2(x) in increasing powers of x.
C             If DP2 = -1, then P2(x) is taken to be the zero
C             polynomial, P2 is not referenced and can be supplied
C             as a dummy array.
C
C     P3      (input/output) DOUBLE PRECISION array, dimension (lenp3)
C             where lenp3 = MAX(DP1+DP2,DP3,0) + 1.
C             On entry, if DP3 >= 0, then this array must contain the
C             coefficients of P3(x) in increasing powers of x.
C             On entry, if DP3 = -1, then P3(x) is taken to be the zero
C             polynomial.
C             On exit, the leading (DP3+1) elements of this array
C             contain the coefficients of P(x) in increasing powers of x
C             unless DP3 = -1 on exit, in which case the coefficients of
C             P(x) (the zero polynomial) are not stored in the array.
C             This is the case, for instance, when ALPHA = 0.0 and
C             P1(x) or P2(x) is the zero polynomial.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given real polynomials
C
C                DP1           i           DP2           i
C        P1(x) = SUM a(i+1) * x ,  P2(x) = SUM b(i+1) * x  and
C                i=0                       i=0
C
C                DP3           i
C        P3(x) = SUM c(i+1) * x ,
C                i=0
C
C     the routine computes the coefficents of P(x) = P1(x) * P2(x) +
C                     DP3            i
C     alpha * P3(x) = SUM  d(i+1) * x  as follows.
C                     i=0
C
C     Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1.
C     Then if DP1 >= DP2,
C
C                i
C        d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1,
C               k=1
C
C                 i
C        d(i)  = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1
C               k=i-DP2
C
C     and
C                DP1+1
C        d(i)  = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1,
C               k=i-DP2
C
C     where f(i) = alpha * e(i).
C
C     Similar formulas hold for the case DP1 < DP2.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01FD by C. Klimann and
C     A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DP1, DP2, DP3, INFO
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  P1(*), P2(*), P3(*)
C     .. Local Scalars ..
      INTEGER           D1, D2, D3, DMAX, DMIN, DSUM, E3, I, J, K, L
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( DP1.LT.-1 ) THEN
         INFO = -1
      ELSE IF( DP2.LT.-1 ) THEN
         INFO = -2
      ELSE IF( DP3.LT.-1 ) THEN
         INFO = -3
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC01RD', -INFO )
         RETURN
      END IF
C
C     Computation of the exact degree of the polynomials, i.e., Di such
C     that either Di = -1 or Pi(Di+1) is non-zero.
C
      D1 = DP1
C     WHILE ( D1 >= 0 and P1(D1+1) = 0 ) DO
   20 IF ( D1.GE.0 ) THEN
         IF ( P1(D1+1).EQ.ZERO ) THEN
            D1 = D1 - 1
            GO TO 20
         END IF
      END IF
C     END WHILE 20
      D2 = DP2
C     WHILE ( D2 >= 0 and P2(D2+1) = 0 ) DO
   40 IF ( D2.GE.0 ) THEN
         IF ( P2(D2+1).EQ.ZERO ) THEN
            D2 = D2 - 1
            GO TO 40
         END IF
      END IF
C     END WHILE 40
      IF ( ALPHA.EQ.ZERO ) THEN
         D3 = -1
      ELSE
         D3 = DP3
      END IF
C     WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO
   60 IF ( D3.GE.0 ) THEN
         IF ( P3(D3+1).EQ.ZERO ) THEN
            D3 = D3 - 1
            GO TO 60
         END IF
      END IF
C     END WHILE 60
C
C     Computation of P3(x) := ALPHA * P3(x).
C
      CALL DSCAL( D3+1, ALPHA, P3, 1 )
C
      IF ( ( D1.EQ.-1 ) .OR. ( D2.EQ.-1 ) ) THEN
         DP3 = D3
         RETURN
      END IF
C
C     P1(x) and P2(x) are non-zero polynomials.
C
      DSUM = D1 + D2
      DMAX = MAX( D1, D2 )
      DMIN = DSUM - DMAX
C
      IF ( D3.LT.DSUM ) THEN
         P3(D3+2) = ZERO
         CALL DCOPY( DSUM-D3-1, P3(D3+2), 0, P3(D3+3), 1 )
         D3 = DSUM
      END IF
C
      IF ( ( D1.EQ.0 ) .OR. ( D2.EQ.0 ) ) THEN
C
C        D1 or D2 is zero.
C
         IF ( D1.NE.0 ) THEN
            CALL DAXPY( D1+1, P2(1), P1, 1, P3, 1 )
         ELSE
            CALL DAXPY( D2+1, P1(1), P2, 1, P3, 1 )
         END IF
      ELSE
C
C        D1 and D2 are both nonzero.
C
C        First part of the computation.
C
         DO 80 I = 1,  DMIN + 1
            P3(I) = P3(I) + DDOT( I, P1, 1, P2, -1 )
   80    CONTINUE
C
C        Second part of the computation.
C
         DO 100 I = DMIN + 2, DMAX + 1
            IF ( D1.GT.D2 ) THEN
               K = I - D2
               P3(I) = P3(I) + DDOT( DMIN+1, P1(K), 1, P2, -1 )
            ELSE
               K = I - D1
               P3(I) = P3(I) + DDOT( DMIN+1, P2(K), -1, P1, 1 )
            END IF
  100    CONTINUE
C
C        Third part of the computation.
C
         E3 = DSUM + 2
C
         DO 120 I = DMAX + 2, DSUM + 1
            J = E3 - I
            K = I - DMIN
            L = I - DMAX
            IF ( D1.GT.D2 ) THEN
               P3(I) = P3(I) + DDOT( J, P1(K), 1, P2(L), -1 )
            ELSE
               P3(I) = P3(I) + DDOT( J, P1(L), -1, P2(K), 1 )
            END IF
  120    CONTINUE
C
      END IF
C
C     Computation of the exact degree of P3(x).
C
C     WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO
  140 IF ( D3.GE.0 ) THEN
         IF ( P3(D3+1).EQ.ZERO ) THEN
            D3 = D3 - 1
            GO TO 140
         END IF
      END IF
C     END WHILE 140
      DP3 = D3
C
      RETURN
C *** Last line of MC01RD ***
      END


FUNCTION bessk0_s(x)
  use mo_kind
  use mo_nrutil, ONLY : assert,poly
  use mo_nr, ONLY : bessi0
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: x
  REAL(SP) :: bessk0_s
  REAL(sp) :: y
  REAL(sp), DIMENSION(7) :: p = (/-0.57721566_sp,0.42278420_sp,&
       0.23069756_sp,0.3488590e-1_sp,0.262698e-2_sp,0.10750e-3_sp,&
       0.74e-5_sp/)
  REAL(sp), DIMENSION(7) :: q = (/1.25331414_sp,-0.7832358e-1_sp,&
       0.2189568e-1_sp,-0.1062446e-1_sp,0.587872e-2_sp,&
       -0.251540e-2_sp,0.53208e-3_sp/)
  call assert(x > 0.0, 'bessk0_s arg')
  if (x <= 2.0) then
     y=x*x/4.0_sp
     bessk0_s=(-log(x/2.0_sp)*bessi0(x))+poly(y,p)
  else
     y=(2.0_sp/x)
     bessk0_s=(exp(-x)/sqrt(x))*poly(y,q)
  end if
END FUNCTION bessk0_s

FUNCTION bessk0_v(x)
  use mo_kind
  use mo_nrutil, ONLY : assert,poly
  use mo_nr, ONLY : bessi0
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: x
  REAL(SP), DIMENSION(size(x)) :: bessk0_v
  REAL(sp), DIMENSION(size(x)) :: y
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  REAL(sp), DIMENSION(7) :: p = (/-0.57721566_sp,0.42278420_sp,&
       0.23069756_sp,0.3488590e-1_sp,0.262698e-2_sp,0.10750e-3_sp,&
       0.74e-5_sp/)
  REAL(sp), DIMENSION(7) :: q = (/1.25331414_sp,-0.7832358e-1_sp,&
       0.2189568e-1_sp,-0.1062446e-1_sp,0.587872e-2_sp,&
       -0.251540e-2_sp,0.53208e-3_sp/)
  call assert(all(x > 0.0), 'bessk0_v arg')
  mask = (x <= 2.0)
  where (mask)
     y=x*x/4.0_sp
     bessk0_v=(-log(x/2.0_sp)*bessi0(x))+poly(y,p,mask)
  elsewhere
     y=(2.0_sp/x)
     bessk0_v=(exp(-x)/sqrt(x))*poly(y,q,.not. mask)
  end where
END FUNCTION bessk0_v

FUNCTION dbessk0_s(x)
  use mo_kind
  use mo_nrutil, ONLY : assert,poly
  use mo_nr, ONLY : bessi0
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x
  REAL(DP) :: dbessk0_s
  REAL(DP) :: y
  REAL(DP), DIMENSION(7) :: p = (/-0.57721566_dp,0.42278420_dp,&
       0.23069756_dp,0.3488590e-1_dp,0.262698e-2_dp,0.10750e-3_dp,&
       0.74e-5_dp/)
  REAL(DP), DIMENSION(7) :: q = (/1.25331414_dp,-0.7832358e-1_dp,&
       0.2189568e-1_dp,-0.1062446e-1_dp,0.587872e-2_dp,&
       -0.251540e-2_dp,0.53208e-3_dp/)
  call assert(x > 0.0, 'dbessk0_s arg')
  if (x <= 2.0) then
     y=x*x/4.0_dp
     dbessk0_s=(-log(x/2.0_dp)*bessi0(x))+poly(y,p)
  else
     y=(2.0_dp/x)
     dbessk0_s=(exp(-x)/sqrt(x))*poly(y,q)
  end if
END FUNCTION dbessk0_s

FUNCTION dbessk0_v(x)
  use mo_kind
  use mo_nrutil, ONLY : assert,poly
  use mo_nr, ONLY : bessi0
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: x
  REAL(DP), DIMENSION(size(x)) :: dbessk0_v
  REAL(DP), DIMENSION(size(x)) :: y
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  REAL(DP), DIMENSION(7) :: p = (/-0.57721566_dp,0.42278420_dp,&
       0.23069756_dp,0.3488590e-1_dp,0.262698e-2_dp,0.10750e-3_dp,&
       0.74e-5_dp/)
  REAL(DP), DIMENSION(7) :: q = (/1.25331414_dp,-0.7832358e-1_dp,&
       0.2189568e-1_dp,-0.1062446e-1_dp,0.587872e-2_dp,&
       -0.251540e-2_dp,0.53208e-3_dp/)
  call assert(all(x > 0.0), 'dbessk0_v arg')
  mask = (x <= 2.0)
  where (mask)
     y=x*x/4.0_dp
     dbessk0_v=(-log(x/2.0_dp)*bessi0(x))+poly(y,p,mask)
  elsewhere
     y=(2.0_dp/x)
     dbessk0_v=(exp(-x)/sqrt(x))*poly(y,q,.not. mask)
  end where
END FUNCTION dbessk0_v


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     12/96
!
!     a program for testing all gradient and inverse gradient routines
!
!     (1) first a scalar field is set in st by restricting a poly in x, y, z
!         to the sphere surface
!
!     (2) a scalar analysis is used to compute the coefs a, b of st
!
!     (3) a, b are input to the various gradient routines to compute a vector field
!         (v, w)
!
!     (4) the vector field (v, w) is compared with the gradient of st obtained
!         analytically
!
!     (5) the inverse gradient of (v, w) is computed and compared with (1)
!
program tgrad

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: dsfdp
    real(wp) :: dsfdt
    real(wp) :: dxdp
    real(wp) :: dxdt
    real(wp) :: dydp
    real(wp) :: dydt
    real(wp) :: dzdp
    real(wp) :: dzdt
    real(wp) :: err2s
    real(wp) :: err2v
    real(wp) :: err2w
    integer(ip) :: i
    integer(ip) :: icase
    integer(ip) :: ierror
    integer(ip) :: j
    integer(ip) :: k
    real(wp) :: phi
    real(wp) :: se
    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: ve
    real(wp) :: we
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    !
    !     set dimensions with parameter statements
    !
    integer(ip), parameter              :: nlat = 33, nlon = 18, nt = 4
    integer(ip), parameter              :: isym = 0, ityp = 0
    integer(ip), parameter              :: mdb = (nlon + 1)/2, mdab = (nlon+2)/2
    real(wp), dimension(mdb, nlat, nt)  :: br, bi, cr, ci
    real(wp), dimension(mdab, nlat, nt) :: a, b
    real(wp), dimension(nlat, nlon, nt) :: sf, v, w
    real(wp), dimension(nlat)           :: gaussian_latitudes, gaussian_weights
    real(wp), allocatable               :: wavetable(:)

    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")

    ! Set equally spaced colatitude and longitude increments
    dphi = TWO_PI/nlon
    dlat = PI/(nlat-1)

    ! Compute nlat-many gaussian latitudinal points
    call compute_gaussian_latitudes_and_weights(nlat, gaussian_latitudes, gaussian_weights, ierror)

    call name("gaqd")
    call iout(ierror, " error_flag")
    call vecout(gaussian_latitudes, "gaussian_latitudes", nlat)
    !
    !     test all analysis and synthesis subroutines
    !
    do icase=1, 4
        !
        !     icase=1 test gradec, igradec
        !     icase=2 test grades, igrades
        !     icase=3 test gradgc, igradgc
        !     icase=4 test gradgs, igradgs
        !
        call name("****")
        call name("****")
        call iout(icase, "icas")
        !
        !
        !     set scalar field as polys in x, y, z and set vector field (v, w) using
        !     v = dsfdt, w = 1/sint*dsfdp
        !
        do k=1, nt
            do j=1, nlon
                phi = (j-1)*dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    theta = (i-1)*dlat
                    if (icase>2) theta=gaussian_latitudes(i)
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    dxdp = -sint*sinp
                    dydt = cost*sinp
                    dydp = sint*cosp
                    dzdt = -sint
                    dzdp = 0.0
                    select case (k)
                        case (1)
                            sf(i, j, k) = x*y
                            dsfdt = x*dydt+y*dxdt
                            dsfdp = x*dydp+y*dxdp
                            v(i, j, k) = dsfdt
                            w(i, j, k) = (cosp*dydp+sinp*dxdp)
                        case (2)
                            sf(i, j, k) = x*z
                            dsfdp = x*dzdp+z*dxdp
                            dsfdt = x*dzdt+z*dxdt
                            v(i, j, k) = dsfdt
                            w(i, j, k) = cosp*dzdp-z*sinp
                        case (3)
                            sf(i, j, k) = y*z
                            dsfdt = y*dzdt + z*dydt
                            dsfdp = y*dzdp+ z*dydp
                            v(i, j, k) = dsfdt
                            w(i, j, k) = sinp*dzdp + z*cosp
                        case (4)
                            sf(i, j, k) = x*y*z
                            dsfdt = x*y*dzdt + x*z*dydt + y*z*dxdt
                            dsfdp = x*y*dzdp + x*z*dydp + y*z*dxdp
                            v(i, j, k) = dsfdt
                            w(i, j, k) = cosp*y*dzdp+cosp*z*dydp+sinp*z*dxdp
                    end select
                end do
            end do
        end do

        select case(icase)
            case(1)

                call name("**ec")
                !
                !     analyze scalar field st
                !
                call initialize_shaec(nlat, nlon, wavetable, ierror)
                call name("shai")
                call iout(ierror, "error_flag = ")

                call shaec(nlat, nlon, isym, nt, sf, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("sha ")
                call iout(ierror, "error_flag = ")

                !     compute gradient of st in v, w
                call initialize_vhsec(nlat, nlon, wavetable, ierror)
                call name("vhci")
                call iout(ierror, "error_flag = ")

                call gradec(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("grad")
                call iout(ierror, "error_flag = ")

            case(2)

                call name("**es")
                !
                !     analyze scalar field st
                !
                call initialize_shaes(nlat, nlon, wavetable, ierror)
                call name("shai")
                call iout(ierror, "error_flag = ")

                call shaes(nlat, nlon, isym, nt, sf, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("sha ")
                call iout(ierror, "error_flag = ")

                !     compute gradient of st in v, w
                call initialize_vhses(nlat, nlon, wavetable, ierror)
                call name("vhsi")
                call iout(ierror, "error_flag = ")

                call grades(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("grad")
                call iout(ierror, "error_flag = ")

            case(3)

                call name("**gc")
                call initialize_shagc(nlat, nlon, wavetable, ierror)
                call name("shai")
                call iout(ierror, "error_flag = ")

                call shagc(nlat, nlon, isym, nt, sf, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("sha ")
                call iout(ierror, "error_flag = ")

                !     compute gradient of st in v, w
                call initialize_vhsgc(nlat, nlon, wavetable, ierror)
                call name("vhgc")
                call iout(ierror, "error_flag = ")

                call gradgc(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("grad")
                call iout(ierror, "error_flag = ")

            case(4)

                call name("**gs")

                call initialize_shags(nlat, nlon, wavetable, ierror)
                call name("shai")
                call iout(ierror, "error_flag = ")

                call shags(nlat, nlon, isym, nt, sf, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("sha ")
                call iout(ierror, "error_flag = ")

                !     compute gradient of st in v, w
                call initialize_vhsgs(nlat, nlon, wavetable, ierror)
                call name("vhgs")
                call iout(ierror, "error_flag = ")

                call gradgs(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, mdab, nlat, wavetable, ierror)
                call name("grad")
                call iout(ierror, "error_flag = ")
        end select

        !     compute "error" in v, w
        err2v = 0.0
        err2w = 0.0
        do k=1, nt
            do j=1, nlon
                phi = (j-1)*dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    theta = (i-1)*dlat
                    if (icase>2) theta=gaussian_latitudes(i)
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    dxdp = -sint*sinp
                    dydt = cost*sinp
                    dydp = sint*cosp
                    dzdt = -sint
                    dzdp = 0.0
                    select case (k)
                        case (1)
                            dsfdt = x*dydt+y*dxdt
                            dsfdp = x*dydp+y*dxdp
                            ve = dsfdt
                            we = (cosp*dydp+sinp*dxdp)
                        case (2)
                            dsfdp = x*dzdp+z*dxdp
                            dsfdt = x*dzdt+z*dxdt
                            ve = dsfdt
                            we = cosp*dzdp-z*sinp
                        case (3)
                            dsfdt = y*dzdt + z*dydt
                            dsfdp = y*dzdp+ z*dydp
                            ve = dsfdt
                            we = sinp*dzdp + z*cosp
                        case (4)
                            dsfdt = x*y*dzdt + x*z*dydt + y*z*dxdt
                            dsfdp = x*y*dzdp + x*z*dydp + y*z*dxdp
                            ve = dsfdt
                            we = cosp*y*dzdp+cosp*z*dydp+sinp*z*dxdp
                    end select
                    err2v = err2v + (v(i, j, k)-ve)**2
                    err2w = err2w + (w(i, j, k)-we)**2
                end do
            end do
        end do
        !
        !     set and print least squares error in v, w
        !
        err2v = sqrt(err2v/(nt*nlat*nlon))
        err2w = sqrt(err2w/(nt*nlat*nlon))
        call vout(err2v, "errv")
        call vout(err2w, "errw")
        !
        !     now recompute sf by inverting (v, w) using igrad(ec, es, gc, gs)
        !
        select case (icase)
            case(1)

                call initialize_vhaec(nlat, nlon, wavetable, ierror)
                call name("vhai")
                call iout(ierror, "error_flag = ")

                call vhaec(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, &
                    mdb, nlat, wavetable, ierror)
                call name("vha ")
                call iout(ierror, "error_flag = ")

                call initialize_shsec(nlat, nlon, wavetable, ierror)
                call name("shec")
                call iout(ierror, "error_flag = ")

                call igradec(nlat, nlon, isym, nt, sf, nlat, nlon, br, bi, &
                    mdb, nlat, wavetable, ierror)
                call name("igra")
                call iout(ierror, "error_flag = ")

            case(2)
                !
                !     analyze vector field (v, w)
                !
                call initialize_vhaes(nlat, nlon, wavetable, ierror)
                call name("vhai")
                call iout(ierror, "error_flag = ")

                call vhaes(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, &
                    mdb, nlat, wavetable, ierror)
                call name("vha ")
                call iout(ierror, "error_flag = ")

                call initialize_shses(nlat, nlon, wavetable, ierror)
                call name("shes")
                call iout(ierror, "error_flag = ")

                call igrades(nlat, nlon, isym, nt, sf, nlat, nlon, br, bi, &
                    mdb, nlat, wavetable, ierror)
                call name("igra")
                call iout(ierror, "error_flag = ")

            case(3)

                call initialize_vhagc(nlat, nlon, wavetable, ierror)
                call name("vhai")
                call iout(ierror, "error_flag = ")

                call vhagc(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, &
                    mdb, nlat, wavetable, ierror)
                call name("vha ")
                call iout(ierror, "error_flag = ")

                call initialize_shsgc(nlat, nlon, wavetable, ierror)
                call name("shgc")
                call iout(ierror, "error_flag = ")

                call igradgc(nlat, nlon, isym, nt, sf, nlat, nlon, br, bi, &
                    mdb, nlat, wavetable, ierror)
                call name("igra")
                call iout(ierror, "error_flag = ")

            case(4)
                call initialize_vhags(nlat, nlon, wavetable, ierror)
                call name("vhai")
                call iout(ierror, "error_flag = ")

                call vhags(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, &
                    mdb, nlat, wavetable, ierror)
                call name("vha ")
                call iout(ierror, "error_flag = ")

                call initialize_shsgs(nlat, nlon, wavetable, ierror)
                call name("shgs")
                call iout(ierror, "error_flag = ")

                call igradgs(nlat, nlon, isym, nt, sf, nlat, nlon, br, bi, &
                    mdb, nlat, wavetable, ierror)
                call name("igra")
                call iout(ierror, "error_flag = ")

        end select

        !     compare this sf with original
        !
        err2s = 0.0
        do k=1, nt
            do j=1, nlon
                phi = (j-1)*dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    theta = (i-1)*dlat
                    if (icase > 2) theta=gaussian_latitudes(i)
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    select case (k)
                        case (1)
                            se = x*y
                        case (2)
                            se = x*z
                        case (3)
                            se = y*z
                        case (4)
                            se = x*y*z
                    end select
                    err2s = err2s + (sf(i, j, k)-se)**2
                end do
            end do
        end do
        err2s = sqrt(err2s/(nlat*nlon*nt))
        call vout(err2s, "errs")
    end do

    ! Release memory
    deallocate (wavetable)

end program tgrad


program cast_int2real
!! show Fortran standard casting rules.
!! This helps avoid needless 1._real64 etc.

implicit none (type, external)

call assert_equal(1 / 5., 0.2)
call assert_equal(1. / 5, 0.2)
call assert_equal(4*atan(1.), 3.14159265359)
call assert_equal(1 + 4., 5.)

contains

subroutine assert_equal(val, ref, atol)
real, intent(in) :: val, ref
real, intent(in), optional :: atol

real :: a

a = 0.0001
if(present(atol)) a = atol

if (abs(val - ref) > a) error stop

end subroutine assert_equal

end program


      SUBROUTINE GAUSS_SEIDEL(DIM, E, A, B, X)
        PARAMETER (MAX_ITER = 500)
        INTEGER DIM
        REAL NORMV, NORM
        DIMENSION A(DIM,DIM), B(DIM), X(DIM), NORMV(DIM)

        ITER = 0

10      DO 20 I = 1, DIM
          S = 0
          DO 30 J = 1, DIM
            IF (I.NE.J) THEN
              S = S + A(I, J) * X(J)
            END IF
30        CONTINUE

          XT = (1 / A(I, I)) * (B(I) - S)
          NORMV(I) = ABS(X(I) - XT)
          X(I) = XT
20      CONTINUE

C       Euclidean norm from LAPACK
        NORM = SNRM2(DIM, NORMV, 1)
        ITER = ITER + 1

        IF (NORM .GT. E) THEN
          IF (ITER .LT. MAX_ITER) THEN
            GOTO 10
          ELSE
            STOP "MAX ITERATIONS EXCEEDED"
          END IF
        END IF

      END


!
!-----------------------------------------------------------------------
!
      subroutine advance (U, Unew, lo, hi, Ncomp, ng, dx, dt)

      implicit none

      integer lo(2),hi(2),Ncomp,ng
      double precision    U(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng,Ncomp)
      double precision Unew(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng,Ncomp)
      double precision dx,dt

      ! Local variables
      integer ndo
      double precision, allocatable :: dU(:,:,:)

      double precision, parameter :: third     = 1.d0/3.d0
      double precision, parameter :: twothirds = 2.d0/3.d0

      integer          :: i,j
      double precision :: fac1, fac2, fac3

      fac1 = -1.d0/12.d0
      fac2 =  4.d0/3.d0
      fac3 = -5.0d0

      allocate(dU(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,Ncomp))

      if (ng < 6) then
         print *,'NOT ENOUGH GHOST CELLS IN ADVANCE ',ng
         stop
      end if

      ! First call to get RHS = Lap(U)
      ndo = 4

      do j = lo(2)-ndo,hi(2)+ndo
      do i = lo(1)-ndo,hi(1)+ndo

         dU(i,j,1) = U(i,j,2)

         dU(i,j,2) = (  fac1 * ( U(i-2,j,1) + U(i+2,j,1) + &
                                 U(i,j-2,1) + U(i,j+2,1) ) &
                      + fac2 * ( U(i-1,j,1) + U(i+1,j,1) + &
                                 U(i,j-1,1) + U(i,j+1,1) ) &
                      + fac3 *   U(i,j,1)  ) / (dx*dx)
      end do
      end do

      ! First update
      ! This Unew lives at t^{n+1}
      Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) = &
                U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) &
        + dt * dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)

      ! Second call to get RHS = Lap(Unew)
      ndo = 2

      do j = lo(2)-ndo,hi(2)+ndo
      do i = lo(1)-ndo,hi(1)+ndo

         dU(i,j,1) = Unew(i,j,2)

         dU(i,j,2) = (  fac1 * ( Unew(i-2,j,1) + Unew(i+2,j,1) + &
                                 Unew(i,j-2,1) + Unew(i,j+2,1) ) &
                      + fac2 * ( Unew(i-1,j,1) + Unew(i+1,j,1) + &
                                 Unew(i,j-1,1) + Unew(i,j+1,1) ) &
                      + fac3 *   Unew(i,j,1)  ) / (dx*dx)
      end do
      end do

      ! Second update
      ! This Unew lives at t^{n+1/2}
      Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) =        &
                .75d0 *    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
              + .25d0 * Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
         + dt * .25d0 *   dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)

      ! Third call to get RHS = Lap(Unew)
      ndo = 0

      do j = lo(2)-ndo,hi(2)+ndo
      do i = lo(1)-ndo,hi(1)+ndo

         dU(i,j,1) = Unew(i,j,2)

         dU(i,j,2) = (  fac1 * ( Unew(i-2,j,1) + Unew(i+2,j,1) + &
                                 Unew(i,j-2,1) + Unew(i,j+2,1) ) &
                      + fac2 * ( Unew(i-1,j,1) + Unew(i+1,j,1) + &
                                 Unew(i,j-1,1) + Unew(i,j+1,1) ) &
                      + fac3 *   Unew(i,j,1)  ) / (dx*dx)
      end do
      end do

      ! Third update
      ! This Unew lives at t^{n+1}
      Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) =        &
                third     *    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
              + twothirds * Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
         + dt * twothirds *   dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)

      deallocate(dU)

      end subroutine advance


module constants
	! module containing constants
    implicit none

	! kind number of double precision float
    integer, parameter :: dbl = kind(1.0D0)

	! Pi
	real(kind=dbl), parameter :: Pi = &
			 3.14159265358979323846264338327950288_dbl

	! iteration number for switching tolerances of inner newton iteration
	integer, parameter :: k_alt = 25

	! maximum allowed iterations of inner newton iteration
	integer, parameter :: k_max = 50

	! tolerances for the inner newton iteration
	! for k < k_alt
	real(kind=dbl), parameter :: atol_def = 1.0D-9
	real(kind=dbl), parameter :: rtol_def = 1.0D-6

	! tolerances for the inner newton iteration
	! for k > k_alt
	real(kind=dbl), parameter :: atol_alt = 1.0D-8
	real(kind=dbl), parameter :: rtol_alt = 1.0D-4

	! tolerances for yield function values in plausibility check
	real(kind=dbl), parameter :: yf_tol_def = 1.0D-7		! for k in inner newton iteration < k_alt
	real(kind=dbl), parameter :: yf_tol_alt = 1.0D-6		! for k in inner newton iteration > k_alt

	! maximum value of damage variable
	real(kind=dbl), parameter :: omega_max = 0.99_dbl

	! flag for switch between numerical/analytical computation of jacobian
	logical, parameter :: jac_num_flag = .True.			! computation via numerical differentiation of R-vector: .True.
														! computation via analytical derivatives: .False.

!	! flag to check if model formulation contains a damage law
!	logical, save :: damage_present				! True if damage law is detected, false if no damage law is detected

	! flag for activation/deactivation of damage computation
	logical, parameter :: damage_flag = .False.			! damage ist taken into account: .True.
														! damage is neglected: .False.

	! flag for switch between numerical/analytical computation of damaged elastoplastic tangent
	logical, parameter :: Cep_dam_num_flag = .False.	! Cep_dam is computed analytically: .False.
														! C_ep_dam is computed numerically: .True.

	! flag for switch between isotropic/transversal isotropic elasticity
	logical, parameter :: anisotropic_elastic_flag = .True.				! isotropic elasticity: .False.
																		! transversal isotropic elasticity: .True.

end module constants


module jacobian_construction

    ! Modules
    use mpi_tools

    ! Variables
    implicit none
    double precision, dimension(:,:), allocatable :: variable, jacobian
    double precision, dimension(:), allocatable :: rhs!, column

    double precision, parameter :: dt = 1.0
    double precision, parameter :: eps = 0.001
!    integer :: jac_count = 0
    private
    public :: rhs, jacobian, &  !column
              allocate_arrays, deallocate_arrays, &
              calc_column, calc_jacobian, &
              print_jacobian

contains

subroutine allocate_arrays(N)
    implicit none
    integer, intent(in)::N
    integer :: i

    if( .not. allocated(variable)) then
        allocate(variable(N,2))
        do i=1,N
            variable(i,1)=1.0
            variable(i,2)=1.0
        end do
    end if
    if( .not. allocated(jacobian)) allocate(jacobian(N,N))
!    if( .not. allocated(column)) allocate(column(N))
    if( .not. allocated(rhs)) allocate(rhs(N))

end subroutine allocate_arrays

subroutine deallocate_arrays()
    implicit none

    if( allocated(variable) ) deallocate(variable)
    if( allocated(jacobian) ) deallocate(jacobian)
!    if( allocated(column) ) deallocate(column)
    if( allocated(rhs) ) deallocate(rhs)

end subroutine deallocate_arrays

double precision function pde_mass(pos)
    implicit none
    integer, intent(in) :: pos

    pde_mass = ( variable(pos,2) - variable(pos,1) ) / dt - 3.0

end function pde_mass

subroutine calc_column()
    implicit none
!    double precision, dimension(:), intent(in out) :: array
    !
    integer :: i

    do i=1+rank,size(rhs),mpi_size
        rhs(i)=-1.0*pde_mass(i)
    end do

end subroutine

subroutine calc_jacobian()
    implicit none
    integer :: i,j,k, n
    double precision :: f_var

!    if( rank == 0 ) write(*,*) size(jacobian)
    n = size(jacobian,1)
    do k=0+rank,n*n-1,mpi_size
        j = mod(k,n)+1
        i = floor(real(k)/n) + 1
        f_var = pde_mass(i)

        variable(j,2) = variable(j,2) + eps
        jacobian(i,j)=(pde_mass(i)- f_var)/eps
        variable(j,2) = variable(j,2) - eps
        write(*,*) rank, k, i, j, rank, jacobian(i,j)
    end do
end subroutine

subroutine print_jacobian()
    implicit none
    integer :: i,j

    do i=1,size(jacobian,1)
        write(*,"(I5)",advance="no") i
        do j=1,size(jacobian,2)
            if( jacobian(i,j) /= 0.0 ) then
                write(*,"(I5,F11.5)",advance="no") j, jacobian(i,j)
            end if
        end do
        write(*,*)
    end do

end subroutine

end module jacobian_construction


!!# FUNCTION MODULE: <FUN_xyINTEGRAL1>
MODULE FUN_xyINTEGRAL1

!!## PURPOSE
!! Integrates the function $1$ over a polygon in 2D.

!!## METHOD
!! According to [1], the formula for the integral of $1$ over a polygon
!! is given by:
!
!! $$ S = \frac{1}{6} \sum_{i=1}^N ( x_{i-1} y_{i} - x_{i} y_{i-1} ) $$
!
!! where the vertices of the polygon are given by $(x_i,y_i)$
!! for $i=1,...,N$ and $(x_0,y_0)=(x_N,y_N)$.

!!## AUTHORS
!! [jb] John Burkardt
!! [waw] W. A. Wieselquist

!!## MODIFIED
!! 10 July 2001 [jb]
!! 14 April 2007 [waw]

!!## REFERENCES
!! [1] SF Bockman,
!!     Generalizing the Formula for Areas of Polygons to Moments,
!!     American Mathematical Society Monthly,
!!     1989, pages 131-132.

!!## EXTERNAL MODULES
USE FUN_xySAREA                                 !!((03-A-FUN_xySAREA.f90))
USE FUN_xyDIST                                  !!((04-B-FUN_xyDIST.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRAL1_Pg
 MODULE PROCEDURE xyINTEGRAL1_Pg_Rsp
 MODULE PROCEDURE xyINTEGRAL1_Pg_Rdp
ENDINTERFACE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRAL1_Ls
 MODULE PROCEDURE xyINTEGRAL1_Ls_Rsp
 MODULE PROCEDURE xyINTEGRAL1_Ls_Rdp
ENDINTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRAL1_Ls
PUBLIC :: xyINTEGRAL1_Ls_Rsp
PUBLIC :: xyINTEGRAL1_Ls_Rdp

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRAL1_Pg
PUBLIC :: xyINTEGRAL1_Pg_Rsp
PUBLIC :: xyINTEGRAL1_Pg_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <xyINTEGRAL1_Ls_Rsp>
FUNCTION xyINTEGRAL1_Ls_Rsp( Ls ) RESULT(INTEGRAL1)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_xyINTEGRAL1_Ls.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_xyINTEGRAL1_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRAL1_Ls_Rdp>
FUNCTION xyINTEGRAL1_Ls_Rdp( Ls ) RESULT(INTEGRAL1)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_xyINTEGRAL1_Ls.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_xyINTEGRAL1_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRAL1_Pg_Rsp>
FUNCTION xyINTEGRAL1_Pg_Rsp( N , Pg ) RESULT(INTEGRAL1)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "06-A-FUN_xyINTEGRAL1_Pg.f90.hdr"

!!--begin--
INCLUDE "06-A-FUN_xyINTEGRAL1_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRAL1_Pg_Rdp>
FUNCTION xyINTEGRAL1_Pg_Rdp( N , Pg ) RESULT(INTEGRAL1)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "06-A-FUN_xyINTEGRAL1_Pg.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_xyINTEGRAL1_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE