      subroutine CWOFZ (Z, W, FLAG)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>2002-11-06 CWOFZ Krogh Corrected comments.
c>>1996-03-30 CWOFZ Krogh Added external stmt., removed INT in type st.
c>>1992-10-13 CWOFZ WVS Improve efficiency and avoid underflow.
c>>1992-03-13 CWOFZ FTK Removed implicit statements.
c>>1991-08-23 CWOFZ WV Snyder Initial adaptation to Math77
c
c     Algorithm 680, collected algorithms from ACM.
c     Reference - GPM Poppe, CMJ Wijers: More efficient computation of
c     the complex error-function, ACM Trans. Math. Software.
c     Vol. 16, No. 1, Pp. 47.
c
c     Modified by W. V. Snyder for inclusion in Math77:
c     Reorganize checking for overflow and loss of precision so
c     there are no redundant or unnecessary checks.  In the process,
c     the range of applicability is expanded to the entire upper
c     half-plane.
c     Reorganize some calculations to be immune from overflow.
c     Split loop for two outer regions into two loops -- faster in
c     region.
c     Use R1MACH to fetch machine characteristics.
c     Use Math77 error message processor.
c
c  Given a complex number z = (xi,yi), this subroutine computes
c  the value of the Faddeeva function w(z) = exp(-z**2)*erfc(-i*z),
c  where erfc is the complex complementary error function and i
c  means sqrt(-1).
c  The accuracy of the algorithm for z in the 1st and 2nd quadrant
c  is 14 significant digits; in the 3rd and 4th it is 13 significant
c  digits outside a circular region with radius 0.126 around a zero
c  of the function.
c
c
c  Argument list
c     Z [in]    = real and imaginary parts of z in Z(1) and Z(2)
c     W [out]   = real and imaginary parts of w(z) in W(1) and W(2)
c     FLAG [out] = an error flag indicating the status of the
c       computation.  Type INTEGER, with values having the following
c       meaning:
c         0 : No error condition,
c        -1 : Overflow would occur,
c        +1 : There would be no significant digits in the answer.
c
c
c  The routine is not underflow-protected but any variable can be
c  put to zero upon underflow.
c
c--   S version uses CWOFZ, R1MACH, r1mach, serv1
c--   D version uses ZWOFZ, D1MACH, d1mach, derv1
c
c
c     RSQPD2 = 2/sqrt(pi) = reciprocal ( sqrt(pi) / 2 ).
c     LN2    = ln(2).
c     SQLGOV = sqrt(ln(RMAX)), where RMAX = the overflow limit for
c              floating point arithmetic.
c     LGOV2  = ln(RMAX) - ln(2)
c     LGUND  = ln(RMIN), where RMIN = underflow limit.
c     MXGONI = the largest possible argument of sin or cos, restricted
c              here to sqrt ( pi / (2*round-off-limit) ).
c     INOGXM = 1 / MXGONI.
c  The reason these values are needed as defined
c  will be explained by comments in the code.
c
      external R1MACH
      logical A
      integer FLAG, I, J, KAPN, N, NU
      real             C, H, H2, LN2, QLAMDA, QRHO, R1MACH, RSQPD2, RX
      real             RY, SX, SY, TX, TY, U, U1, U2, UV, V, V1, V2
      real             W(2), W1, X, XABS, XQUAD, XSUM, Y, YABS, YQUAD
      real             YSUM, Z(2)
      parameter (RSQPD2 =  1.128379167095512573896158903121545171688e0)
      parameter (LN2    = 0.6931471805599453094172321214581765680755e0)
      real             INOGXM, LGOV2, LGUND, MXGONI, SQLGOV
      save INOGXM, LGOV2, LGUND, MXGONI, SQLGOV
      data LGOV2 /-1.0e0/
c
      if (lgov2 .le. 0.0e0) then
        lgov2 = log(r1mach(2))
        sqlgov = sqrt(lgov2)
        lgov2 = lgov2 - ln2
        lgund = log(r1mach(1))
        mxgoni = sqrt(8.0e0 / r1mach(4)) / rsqpd2
        inogxm = 1.0e0 / mxgoni
      end if
c
      xabs = abs(z(1))
      yabs = abs(z(2))
      x    = xabs/6.3e0
      y    = yabs/4.4e0
c
      if (x .gt. y) then
        qrho = x * sqrt(1.0e0 + (y/x)**2)
      else if (y .eq. 0.0e0) then
        qrho = 0.0e0
      else
        qrho = y * sqrt(1.0e0 + (x/y)**2)
      end if
c
      a = qrho .lt. 0.292e0
      if (a) then
c
c       qrho .lt. 0.292, equivalently qrho**2 .lt. 0.085264: the Fadeeva
c       function is evaluated using a power-series (Abramowitz and
c       Stegun, equation (7.1.5), p.297).
c       N is the minimum number of terms needed to obtain the required
c       accuracy.
c
c       We know xquad and exp(-xquad) and yqyad and sin(yquad) won't
c       cause any trouble here, because qrho .lt. 1.
        xquad = (xabs - yabs) * (xabs + yabs)
        yquad = 2.0e0*xabs*yabs
        n     = int(6.5e0 + 72.0e0 * (1.0e0-0.85e0 * y) * qrho)
        j     = 2*n+1
        xsum  = rsqpd2/j
        ysum  = 0.0e0
        do 10 i = n, 1, -1
          j    = j - 2
          w1   = (xsum*xquad - ysum*yquad)/i
          ysum = (xsum*yquad + ysum*xquad)/i
          xsum = w1 + rsqpd2/j
 10     continue
        u1 = 1.0e0 - (xsum*yabs + ysum*xabs)
        v1 =         (xsum*xabs - ysum*yabs)
        w1 =  exp(-xquad)
        u2 =  w1*cos(yquad)
        v2 = -w1*sin(yquad)
c
        u  = u1*u2 - v1*v2
        v  = u1*v2 + v1*u2
      else
c
        rx = 0.0e0
        ry = 0.0e0
        sx = 0.0e0
        sy = 0.0e0
c
c       The loops in both branches of the IF block below are similar.
c       They could be combined to reduce space, but extra tests and
c       unnecessary computation would be needed.
c
        if (qrho .lt. 1.0e0) then
c         0.292 .le. qrho .lt. 1.0: w(z) is evaluated by a truncated
c         Taylor expansion, where the Laplace continued fraction
c         is used to calculate the derivatives of w(z).
c         KAPN is the minimum number of terms in the Taylor expansion
c         needed to obtain the required accuracy.
c         NU is the minimum number of terms of the continued fraction
c         needed to calculate the derivatives with the required
c         accuracy.
c         x*x + y*y is more accurate than qrho*qrho here:
          c    = (1.0e0-y) * sqrt(1.0e0-x*x-y*y)
          h    = 1.88e0 * c
          h2   = 2.0e0 * h
          nu   = int(17.5e0 + 26.0e0*c)
          kapn = int(8.5e0  + 34.0e0*c)
c         Select kapn so qlamda doesn't underflow.  Small kapn is good
c         (when possible) for performance also.
          if (h2 .lt. 0.25e0) kapn=min(kapn,1+int(lgund/log(h2)))
          qlamda = h2**(kapn-1)
c         0 < qlamda < 3.76**41 < 3.85e23.
          do 20 n = nu, kapn+1, -1
            tx  = yabs + h + n*rx
            ty  = xabs - n*ry
c           No overflow because tx*rx + ty*ry = 1 and 0.292 < qrho < 1:
            c = 0.5e0/(tx*tx + ty*ty)
            rx = tx*c
            ry = ty*c
20        continue
          do 30 n = kapn, 1, -1
            tx  = yabs + h + n*rx
            ty  = xabs - n*ry
c           No overflow because tx*rx + ty*ry = 1 and 0.292 < qrho < 1:
            c = 0.5e0/(tx*tx + ty*ty)
            rx = tx*c
            ry = ty*c
            tx = qlamda + sx
            sx = rx*tx - ry*sy
            sy = ry*tx + rx*sy
            qlamda = qlamda/h2
30        continue
          u = rsqpd2*sx
          v = rsqpd2*sy
        else
c         qrho .ge. 1.O: w(z) is evaluated using the Laplace continued
c         fraction.
c         NU is the minimum number of terms needed to obtain the
c         required accuracy.
          nu   = int(4.5e0 + (1442.0e0 / (26.0e0 * qrho + 77.0e0)))
          do 40 n = nu, 1, -1
            tx  = yabs + n*rx
            ty  = xabs - n*ry
            if (tx .gt. abs(ty)) go to 50
c           rx = 0.5*tx/(tx**2+ty**2) and ry = 0.5*ty/(tx**2+ty**2),
c           computed without overflow.  Underflow is OK.
            c = tx / ty
            ry = 0.5e0 / (ty * (1.0e0 + c*c))
            rx = ry * c
40        continue
          go to 60
c         Once tx>abs(ty), it stays that way.
50        continue
c           rx = 0.5*tx/(tx**2+ty**2) and ry = 0.5*ty/(tx**2+ty**2),
c           computed without overflow.  Underflow is OK.
            c = ty / tx
            rx = 0.5e0 / (tx * (1.0e0 + c*c))
            ry = rx * c
            n = n - 1
            if (n.eq.0) go to 60
            tx  = yabs + n*rx
            ty  = xabs - n*ry
          go to 50
60        u = rsqpd2*rx
          v = rsqpd2*ry
        end if
c
        if (yabs .eq. 0.0e0) then
          if (xabs .gt. sqlgov) then
            u = 0.0e0
          else
            u = exp(-xabs**2)
          end if
        end if
c
      end if
c
c     Evaluation of w(z) in the other quadrants.
c
      if (z(2) .lt. 0.0e0) then
        if (a) then
          u2 = u2 + u2
          v2 = v2 + v2
        else
c         Check whether sin(2*xabs*yabs) has any precision, without
c         allowing 2*xabs*yabs to overflow.
          if (yabs .gt. xabs) then
            if (yabs .gt. inogxm) then
c             The following protects 2*exp(-z**2) against overflow.
              if (lgov2/yabs .lt. yabs - xabs*(xabs/yabs)) go to 100
              w1 =  2.0e0*exp((yabs-xabs)*(yabs+xabs))
              uv = min(abs(u),abs(v))
              if (w1 .gt. uv) then
                if (xabs .gt. mxgoni/yabs) go to 110
              else
c               We put xabs*(w1/uv) here instead of simply xabs because
c               loss of precision in sin and cos will be diminished
c               relative to uv by w1.
                if (xabs*(w1/uv) .gt. mxgoni/yabs) go to 110
              end if
            end if
          else if (xabs .gt. inogxm) then
            if (lgov2/xabs .lt. xabs - yabs*(yabs/xabs)) then
c             (yabs-xabs)*(yabs+xabs) might have overflowed, but in that
c             case, exp((yabs-xabs)*(yabs+xabs)) would underflow.
              u2 = 0.0e0
              v2 = 0.0e0
              go to 80
            end if
c           (yabs-xabs)*(yabs+xabs) can't overflow here.
            w1 =  2.0e0*exp((yabs-xabs)*(yabs+xabs))
            uv = min(abs(u),abs(v))
            if (w1 .gt. uv) then
              if (yabs .gt. mxgoni/xabs) go to 110
            else
c             We put yabs*(w1/uv) here instead of simply yabs because
c             loss of precision in sin and cos will be diminished
c             relative to uv by w1.
              if (yabs*(w1/uv) .gt. mxgoni/xabs) go to 110
            end if
          end if
          yquad = 2.0e0*xabs*yabs
          u2 =  w1*cos(yquad)
          v2 = -w1*sin(yquad)
80        continue
        end if
c
        u = u2 - u
        v = v2 - v
        if (z(1) .gt. 0.0e0) v = -v
      else
        if (z(1) .lt. 0.0e0) v = -v
      end if
c
      flag = 0
      w(1) = u
      w(2) = v
      return
c
c     Overflow
100   flag = -1
      call ermsg ('CWOFZ',-1,2,
     1'EXP(-REAL(Z**2)) would overflow, Y .lt. - SQRT(X**2 + LN(infinity
     2/2))'
     2,',')
      call serv1 ('LN(infinity/2)',lgov2,',')
      go to 120
c     No significant digits
110   flag = +1
      call ermsg ('CWOFZ',+1,2,
     1'Too few significant digits in COS(IMAG(Z**2)),',',')
      call ermor ('2*Y*ABS(X) .lt. -SQRT(2*pi/eps)',',')
      call serv1 ('SQRT(2*pi/eps)',mxgoni,',')
120   call serv1 ('REAL(Z)',z(1),',')
      call serv1 ('IMAG(Z)',z(2),'.')
      w(1) = r1mach(2)
      w(2) = w(1)
      return
c
      end


      SUBROUTINE b_error_spectrum
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE stel_constants
      USE boundary
      USE bnorm_mod
      USE mpi_params                                         !mpi stuff
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: n, mn
      REAL(rprec) :: sinmn, cosmn, dluvdu(nedge)
!-----------------------------------------------
!
!     Want Fourier coefficients of b-error in straight line coordinates
!
!     bmn_err = integral[ sim(mu' - nv') b_error(u',v') du' dv'
!
!     where u' = u + lambda(u),  v' = v. Converting to u,v:
!
!     bmn_err = integral[ sin{m(u+lambda) - nv} b_error(u,v) (1 + d(lambda)/du) du dv
!
!     for m != 0, integrate this by parts to get:
!
!     bmn_err = -1/m integral[ cos{m(u+lambda) - nv} d(b_error)/du du dv ]

!     Compute lamda and d(lambda)/du in u,v space
      DO n = 1, nedge
         luv(n) = zero; dluvdu(n) = 1
         DO mn = 1, mnmax
            sinmn = SIN(xm_b(mn)*thetab(n) - xn_b(mn)*phib(n))
            cosmn = COS(xm_b(mn)*thetab(n) - xn_b(mn)*phib(n))
            luv(n) = luv(n) + lmns_b(mn)*sinmn
            dluvdu(n) = dluvdu(n) + lmns_b(mn)*cosmn*xm_b(mn)
         END DO
      END DO

!     Spectrum of b-error in straight line coordinates
      DO mn = 1, mnmax_bmn
         bmn(mn) = zero
         DO n = 1, nedge
            sinmn = SIN (xm_bmn(mn)*(thetab(n) + luv(n))
     1            -      xn_bmn(mn)*phib(n))
            bmn(mn) = bmn(mn) + b_error(n)*sinmn*dluvdu(n)
         END DO
         bmn(mn) = 2*bmn(mn)/nedge
         IF( myid .eq. master ) THEN                             !mpi stuff
           PRINT 100, NINT(xm_bmn(mn)), NINT(xn_bmn(mn))/3, bmn(mn)
         END IF     !IF( myid .eq. master )                     !mpi stuff
      END DO
  100 FORMAT(2i5,1pe15.5)

      END SUBROUTINE b_error_spectrum


!*==dggev3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  DGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGGEV3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR,
!      $                   ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK,
!      $                   INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVL, JOBVR
!       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
!      $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
!      $                   VR( LDVR, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!> the generalized eigenvalues, and optionally, the left and/or right
!> generalized eigenvectors.
!>
!> A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!> singular. It is usually represented as the pair (alpha,beta), as
!> there is a reasonable interpretation for beta=0, and even for both
!> being zero.
!>
!> The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!> of (A,B) satisfies
!>
!>                  A * v(j) = lambda(j) * B * v(j).
!>
!> The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!> of (A,B) satisfies
!>
!>                  u(j)**H * A  = lambda(j) * u(j)**H * B .
!>
!> where u(j)**H is the conjugate-transpose of u(j).
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVL
!> \verbatim
!>          JOBVL is CHARACTER*1
!>          = 'N':  do not compute the left generalized eigenvectors;
!>          = 'V':  compute the left generalized eigenvectors.
!> \endverbatim
!>
!> \param[in] JOBVR
!> \verbatim
!>          JOBVR is CHARACTER*1
!>          = 'N':  do not compute the right generalized eigenvectors;
!>          = 'V':  compute the right generalized eigenvectors.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A, B, VL, and VR.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>          On entry, the matrix A in the pair (A,B).
!>          On exit, A has been overwritten.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB, N)
!>          On entry, the matrix B in the pair (A,B).
!>          On exit, B has been overwritten.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] ALPHAR
!> \verbatim
!>          ALPHAR is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] ALPHAI
!> \verbatim
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!>          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
!>          the j-th eigenvalue is real; if positive, then the j-th and
!>          (j+1)-st eigenvalues are a complex conjugate pair, with
!>          ALPHAI(j+1) negative.
!>
!>          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!>          may easily over- or underflow, and BETA(j) may even be zero.
!>          Thus, the user should avoid naively computing the ratio
!>          alpha/beta.  However, ALPHAR and ALPHAI will be always less
!>          than and usually comparable with norm(A) in magnitude, and
!>          BETA always less than and usually comparable with norm(B).
!> \endverbatim
!>
!> \param[out] VL
!> \verbatim
!>          VL is DOUBLE PRECISION array, dimension (LDVL,N)
!>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!>          after another in the columns of VL, in the same order as
!>          their eigenvalues. If the j-th eigenvalue is real, then
!>          u(j) = VL(:,j), the j-th column of VL. If the j-th and
!>          (j+1)-th eigenvalues form a complex conjugate pair, then
!>          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
!>          Each eigenvector is scaled so the largest component has
!>          abs(real part)+abs(imag. part)=1.
!>          Not referenced if JOBVL = 'N'.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the matrix VL. LDVL >= 1, and
!>          if JOBVL = 'V', LDVL >= N.
!> \endverbatim
!>
!> \param[out] VR
!> \verbatim
!>          VR is DOUBLE PRECISION array, dimension (LDVR,N)
!>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!>          after another in the columns of VR, in the same order as
!>          their eigenvalues. If the j-th eigenvalue is real, then
!>          v(j) = VR(:,j), the j-th column of VR. If the j-th and
!>          (j+1)-th eigenvalues form a complex conjugate pair, then
!>          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
!>          Each eigenvector is scaled so the largest component has
!>          abs(real part)+abs(imag. part)=1.
!>          Not referenced if JOBVR = 'N'.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the matrix VR. LDVR >= 1, and
!>          if JOBVR = 'V', LDVR >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          = 1,...,N:
!>                The QZ iteration failed.  No eigenvectors have been
!>                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
!>                should be correct for j=INFO+1,...,N.
!>          > N:  =N+1: other than QZ iteration failed in DHGEQZ.
!>                =N+2: error return from DTGEVC.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date January 2015
!
!> \ingroup doubleGEeigen
!
!  =====================================================================
      SUBROUTINE DGGEV3(Jobvl,Jobvr,N,A,Lda,B,Ldb,Alphar,Alphai,Beta,Vl,&
     &                  Ldvl,Vr,Ldvr,Work,Lwork,Info)
      IMPLICIT NONE
!*--DGGEV3229
!
!  -- LAPACK driver routine (version 3.6.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     January 2015
!
!     .. Scalar Arguments ..
      CHARACTER Jobvl , Jobvr
      INTEGER Info , Lda , Ldb , Ldvl , Ldvr , Lwork , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Alphai(*) , Alphar(*) , B(Ldb,*) ,    &
     &                 Beta(*) , Vl(Ldvl,*) , Vr(Ldvr,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL ilascl , ilbscl , ilv , ilvl , ilvr , lquery
      CHARACTER chtemp
      INTEGER icols , ierr , ihi , ijobvl , ijobvr , ileft , ilo , in , &
     &        iright , irows , itau , iwrk , jc , jr , lwkopt
      DOUBLE PRECISION anrm , anrmto , bignum , bnrm , bnrmto , eps ,   &
     &                 smlnum , temp
!     ..
!     .. Local Arrays ..
      LOGICAL ldumma(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DGEQRF , DGGBAK , DGGBAL , DGGHD3 , DHGEQZ , DLABAD ,    &
     &         DLACPY , DLASCL , DLASET , DORGQR , DORMQR , DTGEVC ,    &
     &         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      DOUBLE PRECISION DLAMCH , DLANGE
      EXTERNAL LSAME , DLAMCH , DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF ( LSAME(Jobvl,'N') ) THEN
         ijobvl = 1
         ilvl = .FALSE.
      ELSEIF ( LSAME(Jobvl,'V') ) THEN
         ijobvl = 2
         ilvl = .TRUE.
      ELSE
         ijobvl = -1
         ilvl = .FALSE.
      ENDIF
!
      IF ( LSAME(Jobvr,'N') ) THEN
         ijobvr = 1
         ilvr = .FALSE.
      ELSEIF ( LSAME(Jobvr,'V') ) THEN
         ijobvr = 2
         ilvr = .TRUE.
      ELSE
         ijobvr = -1
         ilvr = .FALSE.
      ENDIF
      ilv = ilvl .OR. ilvr
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      IF ( ijobvl<=0 ) THEN
         Info = -1
      ELSEIF ( ijobvr<=0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvl<1 .OR. (ilvl .AND. Ldvl<N) ) THEN
         Info = -12
      ELSEIF ( Ldvr<1 .OR. (ilvr .AND. Ldvr<N) ) THEN
         Info = -14
      ELSEIF ( Lwork<MAX(1,8*N) .AND. .NOT.lquery ) THEN
         Info = -16
      ENDIF
!
!     Compute workspace
!
      IF ( Info==0 ) THEN
         CALL DGEQRF(N,N,B,Ldb,Work,Work,-1,ierr)
         lwkopt = MAX(1,8*N,3*N+INT(Work(1)))
         CALL DORMQR('L','T',N,N,N,B,Ldb,Work,A,Lda,Work,-1,ierr)
         lwkopt = MAX(lwkopt,3*N+INT(Work(1)))
         IF ( ilvl ) THEN
            CALL DORGQR(N,N,N,Vl,Ldvl,Work,Work,-1,ierr)
            lwkopt = MAX(lwkopt,3*N+INT(Work(1)))
         ENDIF
         IF ( ilv ) THEN
            CALL DGGHD3(Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,  &
     &                  Work,-1,ierr)
            lwkopt = MAX(lwkopt,3*N+INT(Work(1)))
            CALL DHGEQZ('S',Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Alphar,Alphai,&
     &                  Beta,Vl,Ldvl,Vr,Ldvr,Work,-1,ierr)
            lwkopt = MAX(lwkopt,2*N+INT(Work(1)))
         ELSE
            CALL DGGHD3('N','N',N,1,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,Work, &
     &                  -1,ierr)
            lwkopt = MAX(lwkopt,3*N+INT(Work(1)))
            CALL DHGEQZ('E',Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Alphar,Alphai,&
     &                  Beta,Vl,Ldvl,Vr,Ldvr,Work,-1,ierr)
            lwkopt = MAX(lwkopt,2*N+INT(Work(1)))
         ENDIF

         Work(1) = lwkopt
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGGEV3 ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = DLANGE('M',N,N,A,Lda,Work)
      ilascl = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         anrmto = smlnum
         ilascl = .TRUE.
      ELSEIF ( anrm>bignum ) THEN
         anrmto = bignum
         ilascl = .TRUE.
      ENDIF
      IF ( ilascl ) CALL DLASCL('G',0,0,anrm,anrmto,N,N,A,Lda,ierr)
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = DLANGE('M',N,N,B,Ldb,Work)
      ilbscl = .FALSE.
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
         bnrmto = smlnum
         ilbscl = .TRUE.
      ELSEIF ( bnrm>bignum ) THEN
         bnrmto = bignum
         ilbscl = .TRUE.
      ENDIF
      IF ( ilbscl ) CALL DLASCL('G',0,0,bnrm,bnrmto,N,N,B,Ldb,ierr)
!
!     Permute the matrices A, B to isolate eigenvalues if possible
!
      ileft = 1
      iright = N + 1
      iwrk = iright + N
      CALL DGGBAL('P',N,A,Lda,B,Ldb,ilo,ihi,Work(ileft),Work(iright),   &
     &            Work(iwrk),ierr)
!
!     Reduce B to triangular form (QR decomposition of B)
!
      irows = ihi + 1 - ilo
      IF ( ilv ) THEN
         icols = N + 1 - ilo
      ELSE
         icols = irows
      ENDIF
      itau = iwrk
      iwrk = itau + irows
      CALL DGEQRF(irows,icols,B(ilo,ilo),Ldb,Work(itau),Work(iwrk),     &
     &            Lwork+1-iwrk,ierr)
!
!     Apply the orthogonal transformation to matrix A
!
      CALL DORMQR('L','T',irows,icols,irows,B(ilo,ilo),Ldb,Work(itau),  &
     &            A(ilo,ilo),Lda,Work(iwrk),Lwork+1-iwrk,ierr)
!
!     Initialize VL
!
      IF ( ilvl ) THEN
         CALL DLASET('Full',N,N,ZERO,ONE,Vl,Ldvl)
         IF ( irows>1 ) CALL DLACPY('L',irows-1,irows-1,B(ilo+1,ilo),   &
     &                              Ldb,Vl(ilo+1,ilo),Ldvl)
         CALL DORGQR(irows,irows,irows,Vl(ilo,ilo),Ldvl,Work(itau),     &
     &               Work(iwrk),Lwork+1-iwrk,ierr)
      ENDIF
!
!     Initialize VR
!
      IF ( ilvr ) CALL DLASET('Full',N,N,ZERO,ONE,Vr,Ldvr)
!
!     Reduce to generalized Hessenberg form
!
      IF ( ilv ) THEN
!
!        Eigenvectors requested -- work on whole matrix.
!
         CALL DGGHD3(Jobvl,Jobvr,N,ilo,ihi,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr, &
     &               Work(iwrk),Lwork+1-iwrk,ierr)
      ELSE
         CALL DGGHD3('N','N',irows,1,irows,A(ilo,ilo),Lda,B(ilo,ilo),   &
     &               Ldb,Vl,Ldvl,Vr,Ldvr,Work(iwrk),Lwork+1-iwrk,ierr)
      ENDIF
!
!     Perform QZ algorithm (Compute eigenvalues, and optionally, the
!     Schur forms and Schur vectors)
!
      iwrk = itau
      IF ( ilv ) THEN
         chtemp = 'S'
      ELSE
         chtemp = 'E'
      ENDIF
      CALL DHGEQZ(chtemp,Jobvl,Jobvr,N,ilo,ihi,A,Lda,B,Ldb,Alphar,      &
     &            Alphai,Beta,Vl,Ldvl,Vr,Ldvr,Work(iwrk),Lwork+1-iwrk,  &
     &            ierr)
      IF ( ierr/=0 ) THEN
         IF ( ierr>0 .AND. ierr<=N ) THEN
            Info = ierr
         ELSEIF ( ierr>N .AND. ierr<=2*N ) THEN
            Info = ierr - N
         ELSE
            Info = N + 1
         ENDIF
         GOTO 100
      ENDIF
!
!     Compute Eigenvectors
!
      IF ( ilv ) THEN
         IF ( .NOT.(ilvl) ) THEN
            chtemp = 'R'
         ELSEIF ( ilvr ) THEN
            chtemp = 'B'
         ELSE
            chtemp = 'L'
         ENDIF
         CALL DTGEVC(chtemp,'B',ldumma,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,N, &
     &               in,Work(iwrk),ierr)
         IF ( ierr/=0 ) THEN
            Info = N + 2
            GOTO 100
         ENDIF
!
!        Undo balancing on VL and VR and normalization
!
         IF ( ilvl ) THEN
            CALL DGGBAK('P','L',N,ilo,ihi,Work(ileft),Work(iright),N,Vl,&
     &                  Ldvl,ierr)
            DO jc = 1 , N
               IF ( Alphai(jc)>=ZERO ) THEN
                  temp = ZERO
                  IF ( Alphai(jc)==ZERO ) THEN
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vl(jr,jc)))
                     ENDDO
                  ELSE
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vl(jr,jc))+ABS(Vl(jr,jc+1)))
                     ENDDO
                  ENDIF
                  IF ( temp>=smlnum ) THEN
                     temp = ONE/temp
                     IF ( Alphai(jc)==ZERO ) THEN
                        DO jr = 1 , N
                           Vl(jr,jc) = Vl(jr,jc)*temp
                        ENDDO
                     ELSE
                        DO jr = 1 , N
                           Vl(jr,jc) = Vl(jr,jc)*temp
                           Vl(jr,jc+1) = Vl(jr,jc+1)*temp
                        ENDDO
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
         IF ( ilvr ) THEN
            CALL DGGBAK('P','R',N,ilo,ihi,Work(ileft),Work(iright),N,Vr,&
     &                  Ldvr,ierr)
            DO jc = 1 , N
               IF ( Alphai(jc)>=ZERO ) THEN
                  temp = ZERO
                  IF ( Alphai(jc)==ZERO ) THEN
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vr(jr,jc)))
                     ENDDO
                  ELSE
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vr(jr,jc))+ABS(Vr(jr,jc+1)))
                     ENDDO
                  ENDIF
                  IF ( temp>=smlnum ) THEN
                     temp = ONE/temp
                     IF ( Alphai(jc)==ZERO ) THEN
                        DO jr = 1 , N
                           Vr(jr,jc) = Vr(jr,jc)*temp
                        ENDDO
                     ELSE
                        DO jr = 1 , N
                           Vr(jr,jc) = Vr(jr,jc)*temp
                           Vr(jr,jc+1) = Vr(jr,jc+1)*temp
                        ENDDO
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
!
!        End of eigenvector calculation
!
      ENDIF
!
!     Undo scaling if necessary
!
!
 100  IF ( ilascl ) THEN
         CALL DLASCL('G',0,0,anrmto,anrm,N,1,Alphar,N,ierr)
         CALL DLASCL('G',0,0,anrmto,anrm,N,1,Alphai,N,ierr)
      ENDIF
!
      IF ( ilbscl ) CALL DLASCL('G',0,0,bnrmto,bnrm,N,1,Beta,N,ierr)
!
      Work(1) = lwkopt
!
!     End of DGGEV3
!
      END SUBROUTINE DGGEV3


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_analysis_routines) scalar_analysis_regular_grid

contains
    !     subroutine shaec(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
    !                      wshaec, lshaec, work, lwork, ierror)
    !
    !     subroutine shaec performs the spherical harmonic analysis
    !     on the array g and stores the result in the arrays a and b.
    !     the analysis is performed on an equally spaced grid.  the
    !     associated legendre functions are recomputed rather than stored
    !     as they are in subroutine shaes.  the analysis is described
    !     below at output parameters a, b.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     isym   = 0  no symmetries exist about the equator. the analysis
    !                 is performed on the entire sphere.  i.e. on the
    !                 array g(i, j) for i=1, ..., nlat and j=1, ..., nlon.
    !                 (see description of g below)
    !
    !            = 1  g is antisymmetric about the equator. the analysis
    !                 is performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the analysis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the analysis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !            = 2  g is symmetric about the equator. the analysis is
    !                 performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the analysis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the analysis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of analyses.  in the program that calls shaec,
    !            the arrays g, a and b can be three dimensional in which
    !            case multiple analyses will be performed.  the third
    !            index is the analysis index which assumes the values
    !            k=1, ..., nt.  for a single analysis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that the arrays g, a and b
    !            have only two dimensions.
    !
    !     g      a two or three dimensional array (see input parameter
    !            nt) that contains the discrete function to be analyzed.
    !            g(i, j) contains the value of the function at the colatitude
    !            point theta(i) = (i-1)*pi/(nlat-1) and longitude point
    !            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
    !            above at the input parameter isym.
    !
    !
    !     idg    the first dimension of the array g as it appears in the
    !            program that calls shaec.  if isym equals zero then idg
    !            must be at least nlat.  if isym is nonzero then idg
    !            must be at least nlat/2 if nlat is even or at least
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     jdg    the second dimension of the array g as it appears in the
    !            program that calls shaec.  jdg must be at least nlon.
    !
    !     mdab   the first dimension of the arrays a and b as it appears
    !            in the program that calls shaec. mdab must be at least
    !            min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays a and b as it appears
    !            in the program that calls shaec. ndab must be at least nlat
    !
    !     wshaec an array which must be initialized by subroutine shaeci.
    !            once initialized, wshaec can be used repeatedly by shaec
    !            as long as nlon and nlat remain unchanged.  wshaec must
    !            not be altered between calls of shaec.
    !
    !     lshaec the dimension of the array wshaec as it appears in the
    !            program that calls shaec. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshaec must be at least
    !
    !            2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
    !
    !     output parameters
    !
    !     a, b    both a, b are two or three dimensional arrays (see input
    !            parameter nt) that contain the spherical harmonic
    !            coefficients in the representation of g(i, j) given in the
    !            discription of subroutine shsec. for isym=0, a(m, n) and
    !            b(m, n) are given by the equations listed below. symmetric
    !            versions are used when isym is greater than zero.
    !
    !
    !
    !     definitions
    !
    !     1. the normalized associated legendre functions
    !
    !     pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
    !                       *sin(theta)**m/(2**n*factorial(n)) times the
    !                       (n+m)th derivative of (x**2-1)**n with respect
    !                       to x=cos(theta)
    !
    !     2. the normalized z functions for m even
    !
    !     zbar(m, n, theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of
    !                       the integral from tau = 0 to tau = pi of
    !                       cos(k*theta)*cos(k*tau)*pbar(m, n, tau)*sin(tau)
    !                       (first and last terms in this sum are divided
    !                       by 2)
    !
    !     3. the normalized z functions for m odd
    !
    !     zbar(m, n, theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of
    !                       of the integral from tau = 0 to tau = pi of
    !                       sin(k*theta)*sin(k*tau)*pbar(m, n, tau)*sin(tau)
    !
    !     4. the fourier transform of g(i, j).
    !
    !     c(m, i)          = 2/nlon times the sum from j=1 to j=nlon
    !                       of g(i, j)*cos((m-1)*(j-1)*2*pi/nlon)
    !                       (the first and last terms in this sum
    !                       are divided by 2)
    !
    !     s(m, i)          = 2/nlon times the sum from j=2 to j=nlon
    !                       of g(i, j)*sin((m-1)*(j-1)*2*pi/nlon)
    !
    !     5. the maximum (plus one) longitudinal wave number
    !
    !            mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !
    !     then for m=0, ..., mmax-1 and n=m, ..., nlat-1 the arrays a, b
    !     are given by
    !
    !     a(m+1, n+1)      = the sum from i=1 to i=nlat of
    !                       c(m+1, i)*zbar(m, n, theta(i))
    !                       (first and last terms in this sum are
    !                       divided by 2)
    !
    !     b(m+1, n+1)      = the sum from i=1 to i=nlat of
    !                       s(m+1, i)*zbar(m, n, theta(i))
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idg
    !            = 6  error in the specification of jdg
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshaec
    !
    module subroutine shaec(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
        wshaec, ierror)

        ! Dummy arguments
        integer(ip), intent(in)   :: nlat
        integer(ip), intent(in)   :: nlon
        integer(ip), intent(in)   :: isym
        integer(ip), intent(in)   :: nt
        real(wp),    intent(in)   :: g(idg, jdg, nt)
        integer(ip), intent(in)   :: idg
        integer(ip), intent(in)   :: jdg
        real(wp),    intent(out)  :: a(mdab, ndab, nt)
        real(wp),    intent(out)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)   :: mdab
        integer(ip), intent(in)   :: ndab
        real(wp),    intent(in)   :: wshaec(:)
        integer(ip), intent(out)  :: ierror

        ! Local variables
        integer(ip) :: imid
        integer(ip) :: ist

        integer(ip) :: labc
        integer(ip) :: ls
        integer(ip) :: lzz1
        integer(ip) :: mmax
        integer(ip) :: nln, lwork
        integer(ip)             :: required_wavetable_size
        type(SpherepackUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshaec(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, idg, jdg, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshaec, ierror)

        mmax = min(nlat, nlon/2+1)
        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        labc = 3*((mmax-2)*(2*nlat-mmax-1))/2

        select case (isym)
            case (0)
                ls = nlat
                ist = imid
            case default
                ls = imid
                ist = 0
        end select

        nln = nt*ls*nlon

        ! Set required workspace size
        lwork = nln+max(ls*nlon, 3*nlat*imid)

        block
            integer(ip) :: iw1, jw1, jw2, jw3
            real(wp)    :: work(lwork)

            ! Set workspace pointers
            iw1 = lzz1+labc+1
            jw1 = ist + 1
            jw2 = nln + 1
            jw3 = jw2

            call shaec_lower_utility_routine(nlat, isym, nt, g, idg, jdg, a, b, &
                mdab, ndab, imid, ls, nlon, &
                work, work(jw1:), work(jw3:), wshaec, wshaec(iw1:))
        end block

    end subroutine shaec

    !     subroutine shaeci(nlat, nlon, wshaec, lshaec, dwork, ldwork, ierror)
    !
    !     subroutine shaeci initializes the array wshaec which can then
    !     be used repeatedly by subroutine shaec.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     lshaec the dimension of the array wshaec as it appears in the
    !            program that calls shaeci. the array wshaec is an output
    !            parameter which is described below. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshaec must be at least
    !
    !            2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
    !
    !     dwork  a real dwork array that does not have to be saved.
    !
    !     ldwork the dimension of the array dwork as it appears in the
    !            program that calls shaeci.  ldwork  must be at least
    !            nlat+1.
    !
    !
    !     output parameters
    !
    !     wshaec an array which is initialized for use by subroutine shaec.
    !            once initialized, wshaec can be used repeatedly by shaec
    !            as long as nlon and nlat remain unchanged.  wshaec must
    !            not be altered between calls of shaec.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lshaec
    !
    module subroutine shaeci(nlat, nlon, wshaec, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: wshaec(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)             :: imid, iw1, labc, lzz1, mmax
        integer(ip)             :: required_wavetable_size
        type(SpherepackUtility) :: util

        imid = (nlat + 1)/2
        mmax = min(nlat, nlon/2+1)
        lzz1 = 2*nlat*imid
        labc = 3*((mmax-2)*(2*nlat-mmax-1))/2
        required_wavetable_size = lzz1+labc+nlon+15

        ! Check validity of input arguments
        if (nlat < 3) then
            ierror = 1
        else if (nlon < 4) then
            ierror = 2
        else if (size(wshaec) < required_wavetable_size) then
            ierror = 3
        else
            ierror = 0
        end if

        call util%initialize_scalar_analysis_regular_grid(nlat, nlon, wshaec)

        ! Set wavetable index pointer
        iw1 = lzz1+labc+1

        call util%hfft%initialize(nlon, wshaec(iw1:))

    end subroutine shaeci

    !
    !     whrfft must have at least nlon+15 locations
    !     wzfin must have 2*l*(nlat + 1)/2 + ((l-3)*l+2)/2 locations
    !     zb must have 3*l*(nlat + 1)/2 locations
    !     work must have ls*nlon locations
    !
    subroutine shaec_lower_utility_routine(nlat, isym, nt, g, idgs, jdgs, a, b, mdab, ndab, imid, &
        idg, jdg, g_even, g_odd, zb, wzfin, whrfft)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(in)  :: g(idgs, jdgs, nt)
        integer(ip), intent(in)  :: idgs
        integer(ip), intent(in)  :: jdgs
        real(wp),    intent(out) :: a(mdab, ndab, nt)
        real(wp),    intent(out) :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        integer(ip), intent(in)  :: imid
        integer(ip), intent(in)  :: idg
        integer(ip), intent(in)  :: jdg
        real(wp),    intent(out) :: g_even(idg, jdg, nt)
        real(wp),    intent(out) :: g_odd(idg, jdg, nt)
        real(wp),    intent(out) :: zb(imid, nlat, 3)
        real(wp),    intent(in)  :: wzfin(:)
        real(wp),    intent(in)  :: whrfft(:)

        ! Local variables
        integer(ip) :: i
        integer(ip) :: indx(3)
        integer(ip) :: imm1
        integer(ip) :: j
        integer(ip) :: k
        integer(ip) :: ls
        integer(ip) :: m
        integer(ip) :: order_stride
        integer(ip) :: m_trunc
        integer(ip) :: mp1
        integer(ip) :: mp2
        integer(ip) :: degree_stride
        integer(ip) :: nlon
        integer(ip) :: np1
        integer(ip) :: nt
        real(wp) :: tsn, fsn
        type(SpherepackUtility) :: util

        ls = idg
        nlon = jdg
        m_trunc = min(nlat, nlon/2+1)

        if (2*m_trunc-1 > nlon) then
            order_stride = m_trunc-1
        else
            order_stride = m_trunc
        end if

        tsn = TWO/nlon
        fsn = FOUR/nlon

        if (even(nlat)) then
            imm1 = imid
        else
            imm1 = imid-1
        end if

        select case(isym)
            case(0)
                do i=1, imm1
                    g_even(i, 1:nlon, :) = tsn * (g(i, 1:nlon, :) + g((nlat + 1)-i, 1:nlon, :))
                    g_odd(i, 1:nlon, :) = tsn * (g(i, 1:nlon, :) - g((nlat + 1)-i, 1:nlon, :))
                end do
            case default
                g_even(1:imm1, 1:nlon, :) = fsn * g(1:imm1, 1:nlon, :)
        end select

        if (isym /= 1 .and. odd(nlat)) then
            g_even(imid, 1:nlon, :) = tsn * g(imid, 1:nlon, :)
        end if

        ! Fast Fourier transform
        fft_loop: do k=1, nt

            call util%hfft%forward(ls, nlon, g_even(:, :, k), ls, whrfft)

            if (odd(nlon)) exit fft_loop

            g_even(1:ls, nlon, k) = HALF * g_even(1:ls, nlon, k)

        end do fft_loop

        ! Preset coefficients to 0.0
        a = ZERO
        b = ZERO

        if (isym /= 1) then

            call util%zfin(2, nlat, nlon, 0, zb, indx, wzfin)

            do k=1, nt
                do i=1, imid
                    do np1=1, nlat, 2
                        a(1, np1, k) = a(1, np1, k)+zb(i, np1, indx(3))*g_even(i, 1, k)
                    end do
                end do
            end do

            if (even(nlat)) then
                degree_stride = nlat-1
            else
                degree_stride = nlat
            end if

            do mp1=2, order_stride
                m = mp1-1
                call util%zfin(2, nlat, nlon, m, zb, indx, wzfin)
                do k=1, nt
                    do i=1, imid
                        do np1=mp1, degree_stride, 2
                            a(mp1, np1, k) = a(mp1, np1, k)+zb(i, np1, indx(3))*g_even(i, 2*mp1-2, k)
                            b(mp1, np1, k) = b(mp1, np1, k)+zb(i, np1, indx(3))*g_even(i, 2*mp1-1, k)
                        end do
                    end do
                end do
            end do

            if (order_stride /= m_trunc .and. m_trunc <= degree_stride) then
                call util%zfin(2, nlat, nlon, order_stride, zb, indx, wzfin)
                do k=1, nt
                    do i=1, imid
                        do np1=m_trunc, degree_stride, 2
                            a(m_trunc, np1, k) = a(m_trunc, np1, k)+zb(i, np1, indx(3))*g_even(i, 2*m_trunc-2, k)
                        end do
                    end do
                end do
            end if
            if (isym == 2) return
        end if

        call util%zfin(1, nlat, nlon, 0, zb, indx, wzfin)

        do k=1, nt
            do i=1, imm1
                do np1=2, nlat, 2
                    a(1, np1, k) = a(1, np1, k)+zb(i, np1, indx(3))*g_odd(i, 1, k)
                end do
            end do
        end do

        if (even(nlat)) then
            degree_stride = nlat
        else
            degree_stride = nlat-1
        end if

        do mp1=2, order_stride
            m = mp1-1
            mp2 = mp1+1
            call util%zfin(1, nlat, nlon, m, zb, indx, wzfin)
            do k=1, nt
                do i=1, imm1
                    do np1=mp2, degree_stride, 2
                        a(mp1, np1, k) = a(mp1, np1, k)+zb(i, np1, indx(3)) * g_odd(i, 2*mp1-2, k)
                        b(mp1, np1, k) = b(mp1, np1, k)+zb(i, np1, indx(3)) * g_odd(i, 2*mp1-1, k)
                    end do
                end do
            end do
        end do

        mp2 = m_trunc+1
        if (order_stride /= m_trunc .and. mp2 <= degree_stride) then
            call util%zfin(1, nlat, nlon, order_stride, zb, indx, wzfin)
            do k=1, nt
                do i=1, imm1
                    do np1=mp2, degree_stride, 2
                        a(m_trunc, np1, k) = a(m_trunc, np1, k) + zb(i, np1, indx(3)) * g_odd(i, 2*m_trunc-2, k)
                    end do
                end do
            end do
        end if

    end subroutine shaec_lower_utility_routine

end submodule scalar_analysis_regular_grid


SUBROUTINE HARMON(N,aK,LMAX2,F,DF,RI)
  use structure, ONLY: BR1
  IMPLICIT REAL*8 (A-H,O-Z)
  REAL*8, intent(out):: F(LMAX2+1,N),DF(LMAX2+1,N)
  INTEGER, intent(in):: N, LMAX2
  REAL*8, intent(in) :: aK(N), RI
  ! locals
  LMX=LMAX2+1
  DO I=1,N
     XA=RI*aK(I)
     CALL SPHBES(LMAX2,XA,F(1,I))
     CALL DVBES1(F(1,I),DF(1,I),XA,RI,LMX)
     DO J=1,LMX
        DF(J,I)=aK(I)*DF(J,I)
     ENDDO
  ENDDO
  RETURN
END SUBROUTINE HARMON


*> \brief \b DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAGTF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, N
*       DOUBLE PRECISION   LAMBDA, TOL
*       ..
*       .. Array Arguments ..
*       INTEGER            IN( * )
*       DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
*> tridiagonal matrix and lambda is a scalar, as
*>
*>    T - lambda*I = PLU,
*>
*> where P is a permutation matrix, L is a unit lower tridiagonal matrix
*> with at most one non-zero sub-diagonal elements per column and U is
*> an upper triangular matrix with at most two non-zero super-diagonal
*> elements per column.
*>
*> The factorization is obtained by Gaussian elimination with partial
*> pivoting and implicit row scaling.
*>
*> The parameter LAMBDA is included in the routine so that DLAGTF may
*> be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
*> inverse iteration.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix T.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (N)
*>          On entry, A must contain the diagonal elements of T.
*>
*>          On exit, A is overwritten by the n diagonal elements of the
*>          upper triangular matrix U of the factorization of T.
*> \endverbatim
*>
*> \param[in] LAMBDA
*> \verbatim
*>          LAMBDA is DOUBLE PRECISION
*>          On entry, the scalar lambda.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (N-1)
*>          On entry, B must contain the (n-1) super-diagonal elements of
*>          T.
*>
*>          On exit, B is overwritten by the (n-1) super-diagonal
*>          elements of the matrix U of the factorization of T.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is DOUBLE PRECISION array, dimension (N-1)
*>          On entry, C must contain the (n-1) sub-diagonal elements of
*>          T.
*>
*>          On exit, C is overwritten by the (n-1) sub-diagonal elements
*>          of the matrix L of the factorization of T.
*> \endverbatim
*>
*> \param[in] TOL
*> \verbatim
*>          TOL is DOUBLE PRECISION
*>          On entry, a relative tolerance used to indicate whether or
*>          not the matrix (T - lambda*I) is nearly singular. TOL should
*>          normally be chose as approximately the largest relative error
*>          in the elements of T. For example, if the elements of T are
*>          correct to about 4 significant figures, then TOL should be
*>          set to about 5*10**(-4). If TOL is supplied as less than eps,
*>          where eps is the relative machine precision, then the value
*>          eps is used in place of TOL.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N-2)
*>          On exit, D is overwritten by the (n-2) second super-diagonal
*>          elements of the matrix U of the factorization of T.
*> \endverbatim
*>
*> \param[out] IN
*> \verbatim
*>          IN is INTEGER array, dimension (N)
*>          On exit, IN contains details of the permutation matrix P. If
*>          an interchange occurred at the kth step of the elimination,
*>          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
*>          returns the smallest positive integer j such that
*>
*>             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
*>
*>          where norm( A(j) ) denotes the sum of the absolute values of
*>          the jth row of the matrix A. If no such j exists then IN(n)
*>          is returned as zero. If IN(n) is returned as positive, then a
*>          diagonal element of U is small, indicating that
*>          (T - lambda*I) is singular or nearly singular,
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0   : successful exit
*>          .lt. 0: if INFO = -k, the kth argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup auxOTHERcomputational
*
*  =====================================================================
      SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
      DOUBLE PRECISION   LAMBDA, TOL
*     ..
*     .. Array Arguments ..
      INTEGER            IN( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * )
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            K
      DOUBLE PRECISION   EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DLAGTF', -INFO )
         RETURN
      END IF
*
      IF( N.EQ.0 )
     $   RETURN
*
      A( 1 ) = A( 1 ) - LAMBDA
      IN( N ) = 0
      IF( N.EQ.1 ) THEN
         IF( A( 1 ).EQ.ZERO )
     $      IN( 1 ) = 1
         RETURN
      END IF
*
      EPS = DLAMCH( 'Epsilon' )
*
      TL = MAX( TOL, EPS )
      SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
      DO 10 K = 1, N - 1
         A( K+1 ) = A( K+1 ) - LAMBDA
         SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
         IF( K.LT.( N-1 ) )
     $      SCALE2 = SCALE2 + ABS( B( K+1 ) )
         IF( A( K ).EQ.ZERO ) THEN
            PIV1 = ZERO
         ELSE
            PIV1 = ABS( A( K ) ) / SCALE1
         END IF
         IF( C( K ).EQ.ZERO ) THEN
            IN( K ) = 0
            PIV2 = ZERO
            SCALE1 = SCALE2
            IF( K.LT.( N-1 ) )
     $         D( K ) = ZERO
         ELSE
            PIV2 = ABS( C( K ) ) / SCALE2
            IF( PIV2.LE.PIV1 ) THEN
               IN( K ) = 0
               SCALE1 = SCALE2
               C( K ) = C( K ) / A( K )
               A( K+1 ) = A( K+1 ) - C( K )*B( K )
               IF( K.LT.( N-1 ) )
     $            D( K ) = ZERO
            ELSE
               IN( K ) = 1
               MULT = A( K ) / C( K )
               A( K ) = C( K )
               TEMP = A( K+1 )
               A( K+1 ) = B( K ) - MULT*TEMP
               IF( K.LT.( N-1 ) ) THEN
                  D( K ) = B( K+1 )
                  B( K+1 ) = -MULT*D( K )
               END IF
               B( K ) = TEMP
               C( K ) = MULT
            END IF
         END IF
         IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
     $      IN( N ) = K
   10 CONTINUE
      IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
     $   IN( N ) = N
*
      RETURN
*
*     End of DLAGTF
*
      END


Function ulangl(x, y)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  ulangl = 0.
  r = sqrt(x**2+y**2)
  If (r<1E-20) Return
  If (abs(x)/r<0.8) Then
    ulangl = sign(acos(x/r), y)
  Else
    ulangl = asin(y/r)
    If (x<0. .And. ulangl>=0.) Then
      ulangl = paru(1) - ulangl
    Else If (x<0.) Then
      ulangl = -paru(1) - ulangl
    End If
  End If
  Return
End Function ulangl


      subroutine zffti1 (n,wa,ifac)
      implicit double precision (a-h,o-z)
      dimension       wa(*)      ,ifac(*)    ,ntryh(4)
      data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/3,4,2,5/
      nl = n
      nf = 0
      j = 0
  101 j = j+1
      if (j-4) 102,102,103
  102 ntry = ntryh(j)
      go to 104
  103 ntry = ntry+2
  104 nq = nl/ntry
      nr = nl-ntry*nq
      if (nr) 101,105,101
  105 nf = nf+1
      ifac(nf+2) = ntry
      nl = nq
      if (ntry .ne. 2) go to 107
      if (nf .eq. 1) go to 107
      do 106 i=2,nf
         ib = nf-i+2
         ifac(ib+2) = ifac(ib+1)
  106 continue
      ifac(3) = 2
  107 if (nl .ne. 1) go to 104
      ifac(1) = n
      ifac(2) = nf
      tpi = 6.28318530717959d0
      argh = tpi/dble(n)
      i = 2
      l1 = 1
      do 110 k1=1,nf
         ip = ifac(k1+2)
         ld = 0
         l2 = l1*ip
         ido = n/l2
         idot = ido+ido+2
         ipm = ip-1
         do 109 j=1,ipm
            i1 = i
            wa(i-1) = 1.
            wa(i) = 0.
            ld = ld+l1
            fi = 0.
            argld = dble(ld)*argh
            do 108 ii=4,idot,2
               i = i+2
               fi = fi+1.
               arg = fi*argld
               wa(i-1) = cos(arg)
               wa(i) = sin(arg)
  108       continue
            if (ip .le. 5) go to 109
            wa(i1-1) = wa(i-1)
            wa(i1) = wa(i)
  109    continue
         l1 = l2
  110 continue
      return
      end


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Tue May 21 13:15:59
!
!a=./f && make $a && $a < unixdict.txt
!gfortran -std=f2003 -Wall -ffree-form f.f03 -o f
!    1    2    3    4    5    6    7    8    9   10   12   18   20   21   24   27   30   36   40   42 1002
!
!Compilation finished at Tue May 21 13:15:59

program Harshad
  integer :: i, h = 0
  do i=1, 20
    call nextHarshad(h)
    write(6, '(i5)', advance='no') h
  enddo
  h = 1000
  call nextHarshad(h)
  write(6, '(i5)') h

contains

  subroutine nextHarshad(h) ! alter input integer h to be the next greater Harshad number.
    integer, intent(inout) :: h
    h = h+1 ! bigger
    do while (.not. isHarshad(h))
      h = h+1
    end do
  end subroutine nextHarshad

  logical function isHarshad(a)
    integer, intent(in) :: a
    integer :: mutable, digit_sum
    isHarshad = .false.
    if (a .lt. 1) return ! false if a < 1
    mutable = a
    digit_sum = 0
    do while (mutable /= 0)
      digit_sum = digit_sum + mod(mutable, 10)
      mutable = mutable / 10
    end do
    isHarshad = 0 .eq. mod(a, digit_sum)
  end function isHarshad

end program Harshad


! { dg-do run }
! { dg-require-effective-target fortran_large_int }
! Take the pack intrinsic through its paces, with all types that are
! normally accessible.
program main
  implicit none
  integer,parameter :: k = selected_int_kind (range (0_8) + 1)
  integer :: i
  integer(kind=k), dimension(3,3) :: ik
  integer(kind=k), dimension(9) :: vik
  integer(kind=k), dimension(9) :: rik

  vik = (/(i+10,i=1,9)/)
  ik = reshape((/1_k, -1_k, 2_k, -2_k, 3_k, -3_k, 4_k, -4_k, 5_k/), shape(ik))
  rik = pack(ik,ik>0,vik)
  if (any(rik /= (/1_k, 2_k, 3_k, 4_k, 5_k, 16_k, 17_k, 18_k, 19_k/))) &
       & call abort

end program main


program tarefab2

    ! númeor de passos N
    parameter (N = 1000)
    ! vetores posição e probabilidade (indice com referencia ao unit dos arquivos de saida)
    dimension iposicao(-N:N), p(10:12)

    ! declarando arquivos de saida
    open(10, file='saida-b2-1-10407962')
    open(11, file='saida-b2-2-10407962')
    open(12, file='saida-b2-3-10407962')

    ! valores de cada propabilidade a ser testada
    p = (/1e0/3, 1e0/4, 1e0/5/)

    ! recebe o número de andarilhos M
    write(*,*) 'Digite o valor M de andarilhos:'
    read(*,*) M

    ! loop das probabilidades
    do k = 10, 12

        ! valores iniciais das variáveis
        iposicao = 0
        iandarilho = 0
        soma = 0
        soma2 = 0

        ! loop dos andarilhos
        do j = 1, M
            ! zera a posição do andarilho
            ix = 0

            ! loop dos passos
            do i = 1, N

                ! condicional para direção do passo
                if (rand().lt.p(k)) then
                    ! <= p, passo para direita
                    ix = ix + 1
                else
                    ! > p, passo para esquerda
                    ix = ix - 1
                end if
            end do

            ! soma os andarilhos na posição final
            iposicao(ix) = iposicao(ix) + 1

            ! soma para <x>
            soma = soma + ix
            ! soma2 para <x**2>
            soma2 = soma2 + ix**2
        end do

        ! loop para gerar o arquivo de saida
        do i = -N, N
            ! condicional para retirar as posições sem andarilhos
            if ( iposicao(i).ne.0 ) then
                write(k,'(I0," ",I0)') i, iposicao(i)
            end if
        end do

        ! escreve no terminal <x> e <x**2>
        write(*,'("<x>: ",1F0.3," <x**2>: ",1F0.3)') abs(soma)/M, abs(soma2)/M

    end do

end program tarefab2


      SUBROUTINE ZHAFTO	(IERROR)
C
C LATEST REVISION	 JULY, 1984
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 EZHAFTON AND TO TEST HAFTON ON A SINGLE
C			 PROBLEM
C
C USAGE			 CALL ZHAFTO (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT		 IERROR
C			   AN INTEGER VARIABLE
C			   = 0,	IF THE TEST WAS	SUCCESSFUL,
C			   = 1,	OTHERWISE
C
C I/O			 IF THE	TEST IS	SUCCESSFUL, THE	MESSAGE
C
C			   HAFTON TEST SUCCESSFUL  . . . SEE PLOT TO
C			   VERIFY PERFORMANCE
C
C			 IS PRINTED ON UNIT 6.
C			 IN ADDITION, TWO FRAMES CONTAINING THE
C			 HALF-TONE PLOT	ARE PRODUCED ON	THE MACHINE
C			 GRAPHICS DEVICE.  IN ORDER TO DETERMINE IF THE
C			 TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE
C			 THESE PLOTS.
C
C PRECISION		 SINGLE
C
C REQUIRED LIBRARY	 HAFTON
C FILES
C
C LANGUAGE		 ANSI FORTRAN 77
C
C ALGORITHM		 THE FUNCTION
C			   Z(X,Y) = X +	Y + 1./((X-.1)**2+Y**2+.09)
C				    -1./((X+.1)**2+Y**2+.09)
C			 FOR X = -1. TO	+1. IN INCREMENTS OF .1	AND
C			     Y = -1.2 TO +1.2 IN INCREMENTS OF .1
C			 IS COMPUTED.
C			 THAFTO	CALLS SUBROUTINES EZHFTN AND HAFTON TO
C			 DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z.
C
C PORTABILITY		 ANSI STANDARD
C
C
C Z CONTAINS THE VALUES	TO BE PLOTTED.
C
C
      REAL	      Z(21,25)
C
C SPECIFY COORDINATES FOR PLOT TITLES.	ON AN ABSTRACT GRID WHERE
C THE COORDINATES RANGE	FROM 0.0 TO 1.0, THE VALUES TX AND TY
C DEFINE THE CENTER OF THE LEFT	EDGE OF	THE TITLE STRING.
C
      DATA TX/0.0762/, TY/0.9769/
C
C SPECIFY SOME ARGUMENT	VALUES FOR ROUTINE HAFTON.
C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI
C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV
C SPECIFIES THE	NUMBER OF UNIQUE LEVELS	BETWEEN	FLO AND	FHI,  THE
C ABSOLUTE VALUE OF NOPT DETERMINES THE	MAPPING	OF Z ONTO THE
C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR
C INVERSNESS OF	THE MAPPING.
C
      DATA FLO/-4.0/, FHI/4.0/,	NLEV/8/, NOPT/-3/
C
C
      SAVE
C
C INITIALIZE ERROR PARAMETER
C
      IERROR = 0
C
C FILL TWO DIMENSIONAL ARRAY TO	BE PLOTTED
C
      DO  20 I=1,21
	 X = .1*FLOAT(I-11)
	 DO  10	J=1,25
	    Y =	.1*FLOAT(J-13)
	    Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)-
     1		     1./((X+.10)**2+Y**2+.09)
   10	 CONTINUE
   20 CONTINUE
C
C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE
C
      CALL GSELNT (0)
C
C
C
C ENTRY	EZHFTN REQUIRES	ONLY THE ARRAY NAME AND	ITS DIMENSIONS
C
C   THE	TITLE FOR THIS PLOT IS
C
C     DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON
C
      CALL WTSTR (TX,TY,
     1		'DEMONSTRATION PLOT FOR	ENTRY EZHFTN OF	HAFTON',2,0,-1)
      CALL EZHFTN (Z,21,25)
C
C ENTRY	HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED
C
C   THE	TITLE FOR THIS PLOT IS
C
C     DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON
C
c     CALL GSELNT (0)
c     CALL WTSTR (TX,TY,
c    1		'DEMONSTRATION PLOT FOR	ENTRY HAFTON OF	HAFTON',2,0,-1)
c     CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.)
c     CALL NEWFM
C
c     WRITE (6,1001)
      RETURN
C
C
c1001 FORMAT ('	    HAFTON TEST	SUCCESSFUL',24X,
c    1	      'SEE PLOT	TO VERIFY PERFORMANCE')
C
      END


! The subroutine for phytoplankton closure model
SUBROUTINE PHY_NPCLOSURE(NO3,PAR_,Temp_,PHY,VPHY,VNO3, COVNP,mu0hatSI,  &
        muNet,SI,theta,QN, PP_P_N, PP_N_P, Chl, NPP, PP_PP_NP, PP_NP_NN)
USE PARAM_MOD
Implicit none
real, intent(in)  :: NO3, PAR_,Temp_,PHY, VPHY, VNO3, COVNP
real, intent(out) :: muNet, theta, QN, SI, PP_P_N,PP_N_P, Chl, NPP, PP_NP_NN, PP_PP_NP, &
mu0hatSI

! muNet: mean growth rate at <N>
real :: mu0hat
real :: alphaI, cff,cff1, eta, dYdN,d2YdN2, dEta_dN, d2ChldN2, Q
real :: KN, tf, fN, dmuQ_dN, d2NPPdN2
real, parameter :: Qmin = 0.06, Qmax=0.18

alphaI   = exp(params(iaI0_C))
tf       = TEMPBOL(Ep,Temp_)   !Temperature effect

!The temperature and light dependent component
mu0hat   = tf*exp(params(imu0))
mu0hatSI = mu_Edwards2015(PAR_, params(iIopt),mu0hat, alphaI)
SI       = mu0hatSI/mu0hat
KN       = exp(params(iKN))
fN       = NO3/(NO3 + Kn)  !Nitrogen limitation index

! Phytoplankton growth rate at the mean nitrogen:
muNet = mu0hatSI*fN
!N:C ratio at <N>
cff1  = 1.-Qmin/Qmax
cff   = 1.-cff1*fN
QN    = Qmin/cff
Q     = 1./QN

!Chl:C ratio at <N>
cff   = (thetamax - thetamin)/PAR_
theta = thetamin + muNet/alphaI*cff   !Unit: gChl/molC

!Chl:N ratio at <N>
eta      = theta*Q
dYdN     = Kn/(NO3 + Kn)**2
d2YdN2   = -dYdN * 2. /(NO3 + Kn)
cff1     = 1./Qmax - 1./Qmin
dEta_dN  = dYdN*(theta*cff1 + Q*mu0hatSI/alphaI*cff)
d2ChldN2 = 2.*PHY*(dYdN**2 * (cff1*cff*mu0hatSI/alphaI) - dEta_dN/(NO3+Kn))

!Ensemble mean Chl
Chl      = PHY*eta + .5*(2.*COVNP*dEta_dN + VNO3*d2ChldN2)
Chl      = max(Chl, eps)

dmuQ_dN  = dYdN*(muNet*cff1 + Q*mu0hatSI)
d2NPPdN2 = PHY*(d2YdN2*dmuQ_dN/dYdN + 2.*dYdN**2*mu0hatSI*cff1)

! NPP: ensemble mean carbon based primary production
NPP      = PHY*muNet*Q + .5*(2.*COVNP*dmuQ_dN + VNO3*d2NPPdN2)
NPP      = max(NPP, 0.)

PP_P_N = PHY*muNet + mu0hatSI*Kn*COVNP/(Kn+NO3)**2
PP_N_P = mu0hatSI*Kn*PHY*VNO3/(Kn+NO3)**3

! Calculate sources and sinks of variances of N, P, and covariance of NP
PP_PP_NP = mu0hatSI*(fN*VPHY   + Kn*PHY*COVNP/(Kn+NO3)**2)
PP_NP_NN = mu0hatSI*(fN*COVNP  + Kn*PHY* VNO3/(Kn+NO3)**2)
return
END SUBROUTINE PHY_NPCLOSURE


      SUBROUTINE POISSON_SOL_CAIRN(X, Z)
      USE global
      IMPLICIT NONE

      REAL*8 ::  X(1,NXP4), Z(1,NXP4), DIFF(1,NXP4)
      REAL*8 :: PP, X_OLD(1,NXP4), PO, YH, YC
      INTEGER :: IT, IC
      pp = 2.0
      DO WHILE (PP .GT. TOL)
         X_OLD = X
         DO 113 IC= 3,NXP2
         YH =  (1-BTH*(X(1,IC))+BTH*(X(1,IC))**2)*EXP(X(1,IC))
         YC = (1-BTC*(X(1,IC)/TU)+BTC*(X(1,IC)/TU)**2)*EXP(X(1,IC)/TU)
         PO = 0.5*(X(1,IC+1)+X(1,IC-1) + (Z(1,IC) - (1-F)*YH  - F*YC)*DX*DX)
         X(1,IC) =PO + W*(PO-X_OLD(1,IC));
  113    CONTINUE
!C---- Boundary condition -------
      X(1,1)      = X(1,NXP1)
      X(1,2)      = X(1,NXP2)
      X(1,NXP3)   = X(1,3)
      X(1,NXP4)   = X(1,4)
!C-------------------------------
      DIFF = X_OLD-X
      DIFF = ABS(DIFF)
      PP   = MAXVAL(DIFF)
      END DO
      RETURN
      END


      SUBROUTINE FOUR1(DATA,NN,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
      N=2*NN
      J=1
      DO 11 I=1,N,2
        IF(J.GT.I)THEN
          TEMPR=DATA(J)
          TEMPI=DATA(J+1)
          DATA(J)=DATA(I)
          DATA(J+1)=DATA(I+1)
          DATA(I)=TEMPR
          DATA(I+1)=TEMPI
        ENDIF
        M=N/2
1       IF ((M.GE.2).AND.(J.GT.M)) THEN
          J=J-M
          M=M/2
        GO TO 1
        ENDIF
        J=J+M
11    CONTINUE
      MMAX=2
2     IF (N.GT.MMAX) THEN
        ISTEP=2*MMAX
        THETA=6.28318530717959D0/(ISIGN*MMAX)
        WPR=-2.D0*DSIN(0.5D0*THETA)**2
        WPI=DSIN(THETA)
        WR=1.D0
        WI=0.D0
        DO 13 M=1,MMAX,2
          DO 12 I=M,N,ISTEP
            J=I+MMAX
            TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
            TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
            DATA(J)=DATA(I)-TEMPR
            DATA(J+1)=DATA(I+1)-TEMPI
            DATA(I)=DATA(I)+TEMPR
            DATA(I+1)=DATA(I+1)+TEMPI
12        CONTINUE
          WTEMP=WR
          WR=WR*WPR-WI*WPI+WR
          WI=WI*WPR+WTEMP*WPI+WI
13      CONTINUE
        MMAX=ISTEP
      GO TO 2
      ENDIF
      RETURN
      END


C
      SUBROUTINE FELDG(GLAT,GLON,ALT,BNORTH,BEAST,BDOWN,BABS)
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NEWBILCAL" program to produce IGRF geomagnetic model (GSFC)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c  ------------------------------------------------------------------------
C-------------------------------------------------------------------
C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL
C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61,
C      1970.
C--------------------------------------------------------------------
C CHANGES (D. BILITZA, NOV 87):
C   - FIELD COEFFICIENTS IN BINARY DATA FILES INSTEAD OF BLOCK DATA
C   - CALCULATES DIPOL MOMENT
C--------------------------------------------------------------------
C  INPUT:  ENTRY POINT FELDG
C               GLAT  GEODETIC LATITUDE IN DEGREES (NORTH)
C               GLON  GEODETIC LONGITUDE IN DEGREES (EAST)
C               ALT   ALTITUDE IN KM ABOVE SEA LEVEL
C
C          ENTRY POINT FELDC
C              V(3)  CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM)
C                     X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE
C                     Y-AXIS POINTING TO EQUATOR AT 90 LONG.
C                     Z-AXIS POINTING TO NORTH POLE
C
C          COMMON BLANK AND ENTRY POINT FELDI ARE NEEDED WHEN USED
C            IN CONNECTION WITH L-CALCULATION PROGRAM SHELLG.
C
C          COMMON /MODEL/ AND /GENER/
C              UMR     = ATAN(1.0)*4./180.   <DEGREE>*UMR=<RADIANT>
C              ERA       EARTH RADIUS FOR NORMALIZATION OF CARTESIAN
C                     COORDINATES (6371.2 KM)
C              AQUAD, BQUAD   SQUARE OF MAJOR AND MINOR HALF AXIS FOR
C                     EARTH ELLIPSOID AS RECOMMENDED BY INTERNATIONAL
C                     ASTRONOMICAL UNION (6378.160, 6356.775 KM).
c comment (MRR): This is IAU 1964 (r=6378.160; 1/f=298.25)
C              NMAX    MAXIMUM ORDER OF SPHERICAL HARMONICS
C              TIME       YEAR (DECIMAL: 1973.5) FOR WHICH MAGNETIC
C                     FIELD IS TO BE CALCULATED
C              G(M)       NORMALIZED FIELD COEFFICIENTS (SEE FELDCOF)
C                     M=NMAX*(NMAX+2)
C------------------------------------------------------------------------
C  OUTPUT: BABS   MAGNETIC FIELD STRENGTH IN GAUSS
C          BNORTH, BEAST, BDOWN   COMPONENTS OF THE FIELD WITH RESPECT
C                TO THE LOCAL GEODETIC COORDINATE SYSTEM, WITH AXIS
C                POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST
C                AND DOWNWARD.
C-----------------------------------------------------------------------

      INTEGER  NMAX,I,K,IH,IL,IS,IHMAX,LAST,M,IMAX
      REAL*4   V(3),B(3)
      REAL*4   TIME
      REAL*4   G(144)
      REAL*4   f,x,y,z,s,t,bnorth,beast,bdown,babs
      REAL*4   glat,glon,alt,rlat,ct,st,d,rlon,cp,sp,rq
      real*4   bxxx,byyy,bzzz,brho,xxx,yyy,zzz,rho
      REAL*4   UMR,ERAD,AQUAD,BQUAD
      REAL*4   XI(3),H(144)
      CHARACTER*33        NAME

      COMMON /SHCOM/  XI,H
c ** MR ** changed Common to align on boundaries
c ** org **     COMMON/MODEL/       NAME,NMAX,TIME,G
      COMMON/MODEL/       TIME,G,NMAX,NAME
      COMMON/GENER/       UMR,ERAD,AQUAD,BQUAD
C
C-- IS RECORDS ENTRY POINT
C
C*****ENTRY POINT  FELDG  TO BE USED WITH GEODETIC CO-ORDINATES
      IS=1
      RLAT=GLAT*UMR
      CT=SIN(RLAT)
      ST=COS(RLAT)
      D=SQRT(AQUAD-(AQUAD-BQUAD)*CT*CT)
      RLON=GLON*UMR
      CP=COS(RLON)
      SP=SIN(RLON)
      ZZZ=(ALT+BQUAD/D)*CT/ERAD
      RHO=(ALT+AQUAD/D)*ST/ERAD
      XXX=RHO*CP
      YYY=RHO*SP
      GOTO10
      ENTRY FELDC(V,B)
C*****ENTRY POINT  FELDC  TO BE USED WITH CARTESIAN CO-ORDINATES
      IS=2
      XXX=V(1)
      YYY=V(2)
      ZZZ=V(3)
10    RQ=1./(XXX*XXX+YYY*YYY+ZZZ*ZZZ)
      XI(1)=XXX*RQ
      XI(2)=YYY*RQ
      XI(3)=ZZZ*RQ
      GOTO20
      ENTRY FELDI
C*****ENTRY POINT  FELDI  USED FOR L COMPUTATION
      IS=3
20    IHMAX=NMAX*NMAX+1
      LAST=IHMAX+NMAX+NMAX
      IMAX=NMAX+NMAX-1
      DO 8 I=IHMAX,LAST
8     H(I)=G(I)
      DO 6 K=1,3,2
      I=IMAX
      IH=IHMAX
1     IL=IH-I
      F=2./FLOAT(I-K+2)
      X=XI(1)*F
      Y=XI(2)*F
      Z=XI(3)*(F+F)
      I=I-2
      IF(I-1)5,4,2
2     DO 3 M=3,I,2
      H(IL+M+1)=G(IL+M+1)+Z*H(IH+M+1)+X*(H(IH+M+3)-H(IH+M-1))
     &                               -Y*(H(IH+M+2)+H(IH+M-2))
3     H(IL+M)=G(IL+M)+Z*H(IH+M)+X*(H(IH+M+2)-H(IH+M-2))
     &                         +Y*(H(IH+M+3)+H(IH+M-1))
4     H(IL+2)=G(IL+2)+Z*H(IH+2)+X*H(IH+4)-Y*(H(IH+3)+H(IH))
      H(IL+1)=G(IL+1)+Z*H(IH+1)+Y*H(IH+4)+X*(H(IH+3)-H(IH))
5     H(IL)=G(IL)+Z*H(IH)+2.*(X*H(IH+1)+Y*H(IH+2))
      IH=IL
      IF(I.GE.K)GOTO1
6     CONTINUE
      IF(IS.EQ.3)RETURN
      S=.5*H(1)+2.*(H(2)*XI(3)+H(3)*XI(1)+H(4)*XI(2))
      T=(RQ+RQ)*SQRT(RQ)
      BXXX=T*(H(3)-S*XXX)
      BYYY=T*(H(4)-S*YYY)
      BZZZ=T*(H(2)-S*ZZZ)
      IF(IS.EQ.2)GOTO7
      BABS=SQRT(BXXX*BXXX+BYYY*BYYY+BZZZ*BZZZ)
      BEAST=BYYY*CP-BXXX*SP
      BRHO=BYYY*SP+BXXX*CP
      BNORTH=BZZZ*ST-BRHO*CT
      BDOWN=-BZZZ*CT-BRHO*ST
      RETURN
7     B(1)=BXXX
      B(2)=BYYY
      B(3)=BZZZ
      RETURN
      END
C


      SUBROUTINE STPBS1(X,NCODE,BJ1,BY1)
C     SUBROUTINE BES1        J AND Y BESSEL FUNCTIONS OF FIRST ORDER
C     E. ALBANO, ORGN 3721, EXT 1022, OCT 1967
C     COMPUTES J1(X) IF X IS GREATER THAN -3.
C     COMPUTES Y1(X) IF (X IS GREATER THAN E AND NCODE = 1 ),
C           WHERE
      INTEGER NAME(2)
      DATA NAME /4HSTPB,4HS1  /
      E=0.00001
C                 REF. US DEPT OF COMMERCE HANBOOK (AMS 58)  PG. 370
      A=ABS(X)
      IF(A-3.) 10,10,100
   10 Z=X*X/9.
      BJ1=X*(0.5+Z*(-0.56249985+Z*(0.21093573+Z*(-0.03954289+Z*
     1      (0.00443319+Z*(-0.00031761+0.00001109*Z))))))
      IF(NCODE-1) 15,20,15
   15 RETURN
   20 IF(X-E) 200,25,25
   25 BY1=0.63661977*BJ1*(ALOG(X)-.69314718)+(-0.6366198 +Z*
     1   (0.2212091+Z*(2.1682709 +Z*(-1.3164827+Z*(0.3123951+Z*
     2   (-0.0400976+0.0027873*Z))))))/X
      RETURN
  100 IF(X) 250,250,110
  110 U=1./SQRT(X)
      Z=3./X
      W=0.79788456+Z*(0.00000156+Z*(0.01659667+Z*(0.00017105+Z*
     1  (-0.00249511+Z*(0.00113653-0.00020033*Z)))))
      T=X-2.35619449+Z*(0.12499612+Z*(0.00005650+Z*(-0.00637879+Z*
     1  (0.00074348+Z*(0.00079824-0.00029166*Z)))))
      UW=U*W
      BJ1=UW*COS(T)
      IF(NCODE-1) 15,120,15
  120 BY1=UW*SIN(T)
 1000 RETURN
  200 CONTINUE
  250 CONTINUE
      CALL MESAGE(-7,0,NAME)
      GO TO 1000
      END


      subroutine mercpatch(rdata)
c subroutine to calulate lat,long at line 1,sample 1 for mercator projection
c It updates rdata buffer elements 1 and 2.

      real scl,rdata(40),rad,req,leq,pi,smp,alog,atan
      data pi/3.1415926/
C==================================================================
      call mve(4,1,rdata(39),l,1,1)
      if(l.ne.6)return
      SCL=RDATA(7)
      RAD=57.29578
      REQ=RDATA(26)
      IF(RDATA(2).NE.1.)THEN
C        FIND LINE OF EQUATOR
         LEQ=(REQ/SCL)*ALOG(TAN(PI/4.+RDATA(3)/(2.*RAD)))+RDATA(2)
C        FIND LATITUDE OF LINE 1.
         RDATA(3)=(2.*(ATAN(EXP(SCL*(LEQ-1.)/REQ))-PI/4.)*RAD)
         RDATA(2)=1.
      ENDIF
      IF(RDATA(1).NE.1.)THEN
C        FIND SAMPLE OF PRIME MERIDIAN
         SMP=(REQ/SCL)*(RDATA(6)/RAD)+RDATA(1)
C        FIND LONGITUDE OF SAMPLE 1.
         RDATA(6)=((SMP-1.)*SCL*RAD)/REQ
         RDATA(1)=1.
      ENDIF
      return
      end


      SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1,
     $                   LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR,
     $                   LDCFRE, IWORK, DWORK, ZWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To evaluate the transfer matrix T(s) of a left polynomial matrix
C     representation [T(s) = inv(P(s))*Q(s)] or a right polynomial
C     matrix representation [T(s) = Q(s)*inv(P(s))] at any specified
C     complex frequency s = SVAL.
C
C     This routine will calculate the standard frequency response
C     matrix at frequency omega if SVAL is supplied as (0.0,omega).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether a left polynomial matrix representation
C             or a right polynomial matrix representation is to be used
C             to evaluate the transfer matrix as follows:
C             = 'L':  A left matrix fraction is input;
C             = 'R':  A right matrix fraction is input.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     SVAL    (input) COMPLEX*16
C             The frequency at which the transfer matrix or the
C             frequency respose matrix is to be evaluated.
C             For a standard frequency response set the real part
C             of SVAL to zero.
C
C     INDEX   (input) INTEGER array, dimension (MAX(M,P))
C             If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
C             maximum degree of the polynomials in the I-th row of the
C             denominator matrix P(s) of the given left polynomial
C             matrix representation.
C             If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
C             maximum degree of the polynomials in the I-th column of
C             the denominator matrix P(s) of the given right polynomial
C             matrix representation.
C
C     PCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             The leading porm-by-porm-by-kpcoef part of this array must
C             contain the coefficients of the denominator matrix P(s).
C             PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
C             LERI = 'L' then iorj = I, otherwise iorj = J.
C             Thus for LERI = 'L', P(s) =
C             diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
C             If LERI = 'R', PCOEFF is modified by the routine but
C             restored on exit.
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P) if LERI = 'L',
C             LDPCO1 >= MAX(1,M) if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P) if LERI = 'L',
C             LDPCO2 >= MAX(1,M) if LERI = 'R'.
C
C     QCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,kpcoef)
C             If LERI = 'L' then porp = M, otherwise porp = P.
C             The leading porm-by-porp-by-kpcoef part of this array must
C             contain the coefficients of the numerator matrix Q(s).
C             QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C             If LERI = 'R', QCOEFF is modified by the routine but
C             restored on exit.
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,P)   if LERI = 'L',
C             LDQCO1 >= MAX(1,M,P) if LERI = 'R'.
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M)   if LERI = 'L',
C             LDQCO2 >= MAX(1,M,P) if LERI = 'R'.
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimated reciprocal of the condition number of the
C             denominator matrix P(SVAL).
C             If RCOND is nearly zero, SVAL is approximately a system
C             pole.
C
C     CFREQR  (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P))
C             The leading porm-by-porp part of this array contains the
C             frequency response matrix T(SVAL).
C
C     LDCFRE  INTEGER
C             The leading dimension of array CFREQR.
C             LDCFRE >= MAX(1,P)   if LERI = 'L',
C             LDCFRE >= MAX(1,M,P) if LERI = 'R'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (liwork)
C             where liwork = P, if LERI = 'L',
C                   liwork = M, if LERI = 'R'.
C
C     DWORK   DOUBLE PRECISION array, dimension (ldwork)
C             where ldwork = 2*P, if LERI = 'L',
C                   ldwork = 2*M, if LERI = 'R'.
C
C     ZWORK   COMPLEX*16 array, dimension (lzwork),
C             where lzwork = P*(P+2), if LERI = 'L',
C                   lzwork = M*(M+2), if LERI = 'R'.
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             = 1:  if P(SVAL) is exactly or nearly singular;
C                   no frequency response is calculated.
C
C     METHOD
C
C     The method for a left matrix fraction will be described here;
C     right matrix fractions are dealt with by obtaining the dual left
C     fraction and calculating its frequency response (see SLICOT
C     Library routine TC01OD). The first step is to calculate the
C     complex value P(SVAL) of the denominator matrix P(s) at the
C     desired frequency SVAL. If P(SVAL) is approximately singular,
C     SVAL is approximately a pole of this system and so the frequency
C     response matrix T(SVAL) is not calculated; in this case, the
C     routine returns with the Error Indicator (INFO) set to 1.
C     Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s)
C     at frequency SVAL is calculated in a similar way to P(SVAL), and
C     the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is
C     found by solving the corresponding system of complex linear
C     equations.
C
C     REFERENCES
C
C     None
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     February 22, 1998 (changed the name of TC01MD).
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         LERI
      INTEGER           INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M,
     $                  P
      DOUBLE PRECISION  RCOND
      COMPLEX*16        SVAL
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  DWORK(*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  QCOEFF(LDQCO1,LDQCO2,*)
      COMPLEX*16        CFREQR(LDCFRE,*), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           LLERI
      INTEGER           I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR,
     $                  MAXIND, MINMP, MPLIM, MWORK, PWORK
      DOUBLE PRECISION  CNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, ZLANGE
      EXTERNAL          DLAMCH, LSAME, ZLANGE
C     .. External Subroutines ..
      EXTERNAL          TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS,
     $                  ZSWAP
C     .. Intrinsic Functions ..
      INTRINSIC         DCMPLX, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LLERI = LSAME( LERI, 'L' )
      MPLIM = MAX( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN
         INFO = -8
      ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN
         INFO = -10
      ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN
         INFO = -11
      ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TC05AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 .OR. P.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
C
      IF ( LLERI ) THEN
C
C        Initialization for left matrix fraction.
C
         PWORK = P
         MWORK = M
      ELSE
C
C        Initialization for right matrix fraction: obtain dual system.
C
         PWORK = M
         MWORK = P
         IF ( MPLIM.GT.1 )
     $      CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, INFO )
      END IF
C
      LDZWOR = PWORK
      IZWORK = LDZWOR*LDZWOR + 1
      MAXIND = 0
C
      DO 10 I = 1, PWORK
         IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I)
   10 CONTINUE
C
      KPCOEF = MAXIND + 1
C
C     Calculate the complex denominator matrix P(SVAL), row by row.
C
      DO 50 I = 1, PWORK
         IJ = I
C
         DO 20 J = 1, PWORK
            ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO )
            IJ = IJ + PWORK
   20    CONTINUE
C
C        Possibly non-constant row: finish evaluating it.
C
         DO 40 K = 2, INDEX(I) + 1
C
            IJ = I
C
            DO 30 J = 1, PWORK
               ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) +
     $                       DCMPLX( PCOEFF(I,J,K), ZERO )
               IJ = IJ + PWORK
   30       CONTINUE
C
   40    CONTINUE
C
   50 CONTINUE
C
C     Check if this P(SVAL) is singular: if so, don't compute T(SVAL).
C     Note that DWORK is not actually referenced in ZLANGE routine.
C
      CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK )
C
      CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO )
C
      IF ( INFO.GT.0 ) THEN
C
C        Singular matrix.  Set INFO and RCOND for error return.
C
         INFO  = 1
         RCOND = ZERO
      ELSE
C
C        Estimate the reciprocal condition of P(SVAL).
C        Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK.
C
         CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND,
     $                ZWORK(IZWORK), DWORK, INFO )
C
         IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN
C
C           Nearly singular matrix.  Set INFO for error return.
C
            INFO  = 1
         ELSE
C
C           Calculate the complex numerator matrix Q(SVAL), row by row.
C
            DO 90 I = 1, PWORK
C
               DO 60 J = 1, MWORK
                  CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO )
   60          CONTINUE
C
C              Possibly non-constant row: finish evaluating it.
C
               DO 80 K = 2, INDEX(I) + 1
C
                  DO 70 J = 1, MWORK
                     CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) +
     $                             DCMPLX( QCOEFF(I,J,K), ZERO )
   70             CONTINUE
C
   80          CONTINUE
C
   90       CONTINUE
C
C           Now calculate frequency response T(SVAL).
C
            CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR,
     $                   IWORK, CFREQR, LDCFRE, INFO )
         END IF
      END IF
C
C     For right matrix fraction, return to original (dual of the dual)
C     system.
C
      IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN
         CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1,
     $                LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 )
C
         IF ( INFO.EQ.0 ) THEN
C
C           Also, transpose T(SVAL) here if this was successfully
C           calculated.
C
            MINMP = MIN( M, P )
C
            DO 100 J = 1, MPLIM
               IF ( J.LT.MINMP ) THEN
                  CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1),
     $                        LDCFRE )
               ELSE IF ( J.GT.P ) THEN
                  CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE )
               ELSE IF ( J.GT.M ) THEN
                  CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 )
               END IF
  100       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of TC05AD ***
      END


program GDJACFW
!*************************************************************!
!    COMPUTATION OF JACOBIAN MATRIX FOR THE FORWARD MODELING  !
!                      OF CRUSTAL DEFORMATION                 !
!*************************************************************!

use prm_var

use mod_ctpin
use mod_gdjac

use mod_starea
use mod_subblms

implicit none

integer :: nsource, lsource, ls, ipl, iu
character(len=24) :: fcof,invjac,fwdjac,flobspd,flobspos,hd_jac,fctp="                        "

call getarg(1,fctp)

open(9,file=fctp)

CALL SETA(flobspd,flobspos,nsource) ! ctpin

open(33,file=flobspos,status='old')
	CALL OBSPO(33) ! jaclib
close(33)

do lsource = 1, nsource

	ls = lsource
	print *, ' ---------------------------------------------'
	print *, ' START OF JACOBI MATRIX CALCULATION. SOURCE=', ls

	iu = 40 + lsource

	CALL SETFCP(ls,fcof,invjac,fwdjac,hd_jac,ipl)

	!==== BLMS 断層面の基底関数の設定？ ====

	if(ipl == 0) then ! 断層面が曲面
		open(31,file=fcof,status='old')
			CALL STAREA
			CALL STMSAR
			CALL INP2DP(31)
			CALL MESH
		close(31)
	else if(ipl /= 0) then ! 断層面が平面
		CALL STMSAR2
		CALL MESHSS
	end if

	!==== /BLMS ====

	CALL BIBSP ! BI BSPLINE (DEGREE=NBDEG)

	open(iu,file=fwdjac,form='unformatted')

		CALL OUTPAR(flobspos,hd_jac,ls,iu)
		CALL JACOBIFW(iu)

	close(iu)

end do

close(9)

end


!! This would generally be supplied by the user

SUBROUTINE  rpn2qad_flux(meqn,maux,idir,iface,q, auxvec,flux)

    IMPLICIT NONE

    INTEGER meqn,maux,idir, m, iface
    DOUBLE PRECISION q(meqn), flux(meqn)
    DOUBLE PRECISION auxvec(maux)

    DOUBLE PRECISION urot, g
    INTEGER k

!!  # Cell-centered velocity has been projected to normals on each face.
    urot = auxvec(2+iface)

    g = auxvec(6+iface)  !! Edge length for iface = 0,1,2,3

    DO m = 1,meqn
        !! # Scaling done here (unlike in ForestClaw)
        flux(m) = g*urot*q(m)
    ENDDO

END SUBROUTINE rpn2qad_flux


      REAL FUNCTION INTGRL (STATE, RATE, DELT)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      REAL STATE, RATE, DELT

**    local variables
      SAVE

      INTGRL = STATE + RATE * DELT

      RETURN
      END