*DECK PCHCM
      SUBROUTINE PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR)
C***BEGIN PROLOGUE  PCHCM
C***PURPOSE  Check a cubic Hermite function for monotonicity.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      SINGLE PRECISION (PCHCM-S, DPCHCM-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION,
C             PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Computing & Mathematics Research Division
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C *Usage:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, ISMON(N), IERR
C        REAL  X(N), F(INCFD,N), D(INCFD,N)
C        LOGICAL  SKIP
C
C        CALL  PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR)
C
C *Arguments:
C
C     N:IN  is the number of data points.  (Error return if N.LT.2 .)
C
C     X:IN  is a real array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F:IN  is a real array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D:IN  is a real array of derivative values.  D(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     INCFD:IN  is the increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP:INOUT  is a logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed.
C           SKIP will be set to .TRUE. on normal return.
C
C     ISMON:OUT  is an integer array indicating on which intervals the
C           PCH function defined by  N, X, F, D  is monotonic.
C           For data interval [X(I),X(I+1)],
C             ISMON(I) = -3  if function is probably decreasing;
C             ISMON(I) = -1  if function is strictly decreasing;
C             ISMON(I) =  0  if function is constant;
C             ISMON(I) =  1  if function is strictly increasing;
C             ISMON(I) =  2  if function is non-monotonic;
C             ISMON(I) =  3  if function is probably increasing.
C                If ABS(ISMON)=3, this means that the D-values are near
C                the boundary of the monotonicity region.  A small
C                increase produces non-monotonicity; decrease, strict
C                monotonicity.
C           The above applies to I=1(1)N-1.  ISMON(N) indicates whether
C              the entire function is monotonic on [X(1),X(N)].
C
C     IERR:OUT  is an error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C          (The ISMON-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C *Description:
C
C          PCHCM:  Piecewise Cubic Hermite -- Check Monotonicity.
C
C     Checks the piecewise cubic Hermite function defined by  N,X,F,D
C     for monotonicity.
C
C     To provide compatibility with PCHIM and PCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C *Cautions:
C     This provides the same capability as old PCHMC, except that a
C     new output value, -3, was added February 1989.  (Formerly, -3
C     and +3 were lumped together in the single value 3.)  Codes that
C     flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed.
C     Codes that check via "IF (ISMON.GE.3)" should change the test to
C     "IF (IABS(ISMON).GE.3)".  Codes that declare monotonicity via
C     "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)".
C
C***REFERENCES  F. N. Fritsch and R. E. Carlson, Monotone piecewise
C                 cubic interpolation, SIAM Journal on Numerical Ana-
C                 lysis 17, 2 (April 1980), pp. 238-246.
C***ROUTINES CALLED  CHFCM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820518  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   831201  Reversed order of subscripts of F and D, so that the
C           routine will work properly when INCFD.GT.1 .  (Bug!!)
C   870707  Minor cosmetic changes to prologue.
C   890208  Added possible ISMON value of -3 and modified code so
C           that 1,3,-1 produces ISMON(N)=2, rather than 3.
C   890306  Added caution about changed output.
C   890407  Changed name from PCHMC to PCHCM, as requested at the
C           March 1989 SLATEC CML meeting, and made a few other
C           minor modifications necessitated by this change.
C   890407  Converted to new SLATEC format.
C   890407  Modified DESCRIPTION to LDOC format.
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  PCHCM
C
C  Fortran intrinsics used:  ISIGN.
C  Other routines used:  CHFCM, XERMSG.
C
C ----------------------------------------------------------------------
C
C  Programming notes:
C
C     An alternate organization would have separate loops for computing
C     ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N).  The
C     first loop can be readily parallelized, since the NSEG calls to
C     CHFCM are independent.  The second loop can be cut short if
C     ISMON(N) is ever equal to 2, for it cannot be changed further.
C
C     To produce a double precision version, simply:
C        a. Change PCHCM to DPCHCM wherever it occurs,
C        b. Change CHFCM to DCHFCM wherever it occurs, and
C        c. Change the real declarations to double precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, ISMON(N), IERR
      REAL  X(N), F(INCFD,N), D(INCFD,N)
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, NSEG
      REAL  DELTA
      INTEGER  CHFCM
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  PCHCM
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
      SKIP = .TRUE.
C
C  FUNCTION DEFINITION IS OK -- GO ON.
C
    5 CONTINUE
      NSEG = N - 1
      DO 90  I = 1, NSEG
         DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I))
C                   -------------------------------
         ISMON(I) = CHFCM (D(1,I), D(1,I+1), DELTA)
C                   -------------------------------
         IF (I .EQ. 1)  THEN
            ISMON(N) = ISMON(1)
         ELSE
C           Need to figure out cumulative monotonicity from following
C           "multiplication table":
C
C                    +        I S M O N (I)
C                     +  -3  -1   0   1   3   2
C                      +------------------------+
C               I   -3 I -3  -3  -3   2   2   2 I
C               S   -1 I -3  -1  -1   2   2   2 I
C               M    0 I -3  -1   0   1   3   2 I
C               O    1 I  2   2   1   1   3   2 I
C               N    3 I  2   2   3   3   3   2 I
C              (N)   2 I  2   2   2   2   2   2 I
C                      +------------------------+
C           Note that the 2 row and column are out of order so as not
C           to obscure the symmetry in the rest of the table.
C
C           No change needed if equal or constant on this interval or
C           already declared nonmonotonic.
            IF ( (ISMON(I).NE.ISMON(N)) .AND. (ISMON(I).NE.0)
     .                                  .AND. (ISMON(N).NE.2) )  THEN
               IF ( (ISMON(I).EQ.2) .OR. (ISMON(N).EQ.0) )  THEN
                  ISMON(N) =  ISMON(I)
               ELSE IF (ISMON(I)*ISMON(N) .LT. 0)  THEN
C                 This interval has opposite sense from curve so far.
                  ISMON(N) = 2
               ELSE
C                 At this point, both are nonzero with same sign, and
C                 we have already eliminated case both +-1.
                  ISMON(N) = ISIGN (3, ISMON(N))
               ENDIF
            ENDIF
         ENDIF
   90 CONTINUE
C
C  NORMAL RETURN.
C
      IERR = 0
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'PCHCM',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'PCHCM', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'PCHCM', 'X-ARRAY NOT STRICTLY INCREASING'
     +   , IERR, 1)
      RETURN
C------------- LAST LINE OF PCHCM FOLLOWS ------------------------------
      END


MODULE ran001
IMPLICIT NONE
SAVE
  INTEGER :: n = 9876
END MODULE ran001

PROGRAM dice
IMPLICIT NONE
  INTEGER :: i, iseed, sum = 0, roll
  INTEGER :: roll_die
  REAL :: r, avg
  WRITE(*, *) "Enter a number to seed the random generator:"
  READ(*, *) iseed
  WRITE(*, *) "Rolling the dice..."

  CALL seed(iseed)
  DO i = 1, 10000
    roll = roll_die()
    WRITE(*, '(I4)') roll
    sum = sum + roll
  END DO
  WRITE(*, *) "Roll average: ", REAL(sum) / 10000.0

END PROGRAM dice

INTEGER FUNCTION roll_die()
IMPLICIT NONE
  REAL :: r
  CALL random0(r)
  roll_die = CEILING(r * 6)
END FUNCTION roll_die

SUBROUTINE random0(ran)
USE ran001
IMPLICIT NONE
  REAL, INTENT(OUT) :: ran
  n = MOD(8121 * n + 28411, 134456)
  ran = REAL(n) / 134456.
END SUBROUTINE random0

SUBROUTINE seed(iseed)
USE ran001
IMPLICIT NONE
  INTEGER, INTENT(IN) :: iseed
  n = ABS(iseed)
END SUBROUTINE seed


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program circ_test_orient
!===============================================================================
! Reading a list of orientational data, check whether they are statistically
! significantly aligned with a particular direction.  Give the chosen orientation
! to test normally; it is converted to orientational data (doubled) internally.
   use statistical

   implicit none

   integer,  parameter :: nmax = 10000
   real(8) :: angles(nmax), test_angle, alpha = 0.05
   integer :: iostat, n
   character(len=250) :: arg

   ! Get command line parameters
   if (command_argument_count() < 1) call usage
   call get_command_argument(1, arg)
   if (arg(1:2) == "-h") call usage
   read(arg,*,iostat=iostat) test_angle
   if (iostat /= 0) then
      write(0,'(a)') 'circ_test_orient: Error: Cannot get value of alpha from ' &
         //'argument "'//trim(arg)//'"'
      stop
   endif
   if (command_argument_count() == 2) then
      call get_command_argument(2, arg)
      read(arg,*,iostat=iostat) alpha
      if (iostat /= 0) then
         write(0,'(a)') 'circ_test_orient: Error: Cannot get value of alpha from ' &
            //'argument "'//trim(arg)//'"'
         stop
      endif
   endif

   n = 1
   do
      read(*,*,iostat=iostat) angles(n)
      if (iostat < 0) then
         n = n - 1
         exit
      endif
      if (iostat > 0) then
         write(0,'(a)') 'circ_test_orient: Error: Problem reading angle from stdin.'
         stop
      endif
      n = n + 1
   enddo

   if (circ_test_random_orient(angles(1:n),test_angle,alpha=alpha,degrees=.true.)) then
      write(*,'(a,f0.3,a)') 'Angles differ significantly from random towards ', &
         test_angle,' degrees: Reject H0 (random)'
   else
      write(*,'(a,f0.3,a)') 'Angles do not differ significantly from random towards ', &
         test_angle,' degrees: Accept H0 (random)'
   endif

contains
   !============================================================================
   subroutine usage
   !============================================================================
   write(0,'(a)') &
      'Usage: circ_test_orient [test angle] (alpha) < [orientations in degrees]', &
      'Tests whether a set of angles (on stdin) significantly differ from random', &
      'towards the test angle, in the 5% limit.', &
      'Optionally set the significance level by calling with alpha = 0.1|0.05|0.01|0.005|0.001|0.0001'
   stop
   end subroutine usage
   !----------------------------------------------------------------------------
end program circ_test_orient
!-------------------------------------------------------------------------------


      SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV,
     $                   LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC,
     $                   QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To calculate a combined measurement and time update of one
C     iteration of the time-invariant Kalman filter. This update is
C     given for the square root information filter, using the condensed
C     controller Hessenberg form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBX    CHARACTER*1
C             Indicates whether X    is to be computed as follows:
C                                i+1
C             = 'X':  X    is computed and stored in array X;
C                      i+1
C             = 'N':  X    is not required.
C                      i+1
C
C     MULTRC  CHARACTER*1             -1/2
C             Indicates how matrices R     and C    are to be passed to
C                                     i+1       i+1
C             the routine as follows:
C             = 'P':  Array RINV is not used and the array C must
C                                          -1/2
C                     contain the product R    C   ;
C                                          i+1  i+1
C             = 'N':  Arrays RINV and C must contain the matrices
C                     as described below.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e., the order of the
C                       -1      -1
C             matrices S   and A  .  N >= 0.
C                       i
C
C     M       (input) INTEGER
C             The actual input dimension, i.e., the order of the matrix
C              -1/2
C             Q    .  M >= 0.
C              i
C
C     P       (input) INTEGER
C             The actual output dimension, i.e., the order of the matrix
C              -1/2
C             R    .  P >= 0.
C              i+1
C
C     SINV    (input/output) DOUBLE PRECISION array, dimension
C             (LDSINV,N)
C             On entry, the leading N-by-N upper triangular part of this
C                                 -1
C             array must contain S  , the inverse of the square root
C                                 i
C             (right Cholesky factor) of the state covariance matrix
C             P    (hence the information square root) at instant i.
C              i|i
C             On exit, the leading N-by-N upper triangular part of this
C                             -1
C             array contains S   , the inverse of the square root (right
C                             i+1
C             Cholesky factor) of the state covariance matrix P
C                                                              i+1|i+1
C             (hence the information square root) at instant i+1.
C             The strict lower triangular part of this array is not
C             referenced.
C
C     LDSINV  INTEGER
C             The leading dimension of array SINV.  LDSINV >= MAX(1,N).
C
C     AINV    (input) DOUBLE PRECISION array, dimension (LDAINV,N)
C                                                                 -1
C             The leading N-by-N part of this array must contain A  ,
C             the inverse of the state transition matrix of the discrete
C             system in controller Hessenberg form (e.g., as produced by
C             SLICOT Library Routine TB01MD).
C
C     LDAINV  INTEGER
C             The leading dimension of array AINV.  LDAINV >= MAX(1,N).
C
C     AINVB   (input) DOUBLE PRECISION array, dimension (LDAINB,M)
C                                                                  -1
C             The leading N-by-M part of this array must contain  A  B,
C                             -1
C             the product of A   and the input weight matrix B of the
C             discrete system, in upper controller Hessenberg form
C             (e.g., as produced by SLICOT Library Routine TB01MD).
C
C     LDAINB  INTEGER
C             The leading dimension of array AINVB.  LDAINB >= MAX(1,N).
C
C     RINV    (input) DOUBLE PRECISION array, dimension (LDRINV,*)
C             If MULTRC = 'N', then the leading P-by-P upper triangular
C                                              -1/2
C             part of this array must contain R    , the inverse of the
C                                              i+1
C             covariance square root (right Cholesky factor) of the
C             output (measurement) noise (hence the information square
C             root) at instant i+1.
C             The strict lower triangular part of this array is not
C             referenced.
C             Otherwise, RINV is not referenced and can be supplied as a
C             dummy array (i.e., set parameter LDRINV = 1 and declare
C             this array to be RINV(1,1) in the calling program).
C
C     LDRINV  INTEGER
C             The leading dimension of array RINV.
C             LDRINV >= MAX(1,P) if MULTRC = 'N';
C             LDRINV >= 1        if MULTRC = 'P'.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain C   ,
C                                                       -1/2      i+1
C             the output weight matrix (or the product R    C    if
C                                                       i+1  i+1
C             MULTRC = 'P') of the discrete system at instant i+1.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     QINV    (input/output) DOUBLE PRECISION array, dimension
C             (LDQINV,M)
C             On entry, the leading M-by-M upper triangular part of this
C                                 -1/2
C             array must contain Q    , the inverse of the covariance
C                                 i
C             square root (right Cholesky factor) of the input (process)
C             noise (hence the information square root) at instant i.
C             On exit, the leading M-by-M upper triangular part of this
C                                    -1/2
C             array contains (QINOV )    , the inverse of the covariance
C                                  i
C             square root (right Cholesky factor) of the process noise
C             innovation (hence the information square root) at
C             instant i.
C             The strict lower triangular part of this array is not
C             referenced.
C
C     LDQINV  INTEGER
C             The leading dimension of array QINV.  LDQINV >= MAX(1,M).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain X , the estimated
C                                                i
C             filtered state at instant i.
C             On exit, if JOBX = 'X', and INFO = 0, then this array
C             contains X   , the estimated filtered state at
C                       i+1
C             instant i+1.
C             On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then
C                                  -1
C             this array contains S   X   .
C                                  i+1 i+1
C
C     RINVY   (input) DOUBLE PRECISION array, dimension (P)
C                                      -1/2
C             This array must contain R    Y   , the product of the
C                                      i+1  i+1
C                                      -1/2
C             upper triangular matrix R     and the measured output
C                                      i+1
C             vector Y    at instant i+1.
C                     i+1
C
C     Z       (input) DOUBLE PRECISION array, dimension (M)
C             This array must contain Z , the mean value of the state
C                                      i
C             process noise at instant i.
C
C     E       (output) DOUBLE PRECISION array, dimension (P)
C             This array contains E   , the estimated error at instant
C                                  i+1
C             i+1.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If JOBX = 'X', then TOL is used to test for near
C                                        -1
C             singularity of the matrix S   . If the user sets
C                                        i+1
C             TOL > 0, then the given value of TOL is used as a
C             lower bound for the reciprocal condition number of that
C             matrix; a matrix whose estimated condition number is less
C             than 1/TOL is considered to be nonsingular. If the user
C             sets TOL <= 0, then an implicitly computed, default
C             tolerance, defined by TOLDEF = N*N*EPS, is used instead,
C             where EPS is the machine precision (see LAPACK Library
C             routine DLAMCH).
C             Otherwise, TOL is not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             where LIWORK = N if JOBX = 'X',
C             and   LIWORK = 1 otherwise.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.  If INFO = 0 and JOBX = 'X', DWORK(2) returns
C             an estimate of the reciprocal of the condition number
C                                 -1
C             (in the 1-norm) of S   .
C                                 i+1
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)),
C                                 if JOBX = 'N';
C             LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1),
C                           3*N), if JOBX = 'X'.
C             For optimum performance LDWORK should be larger.
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;                        -1
C             = 1:  if JOBX = 'X' and the matrix S    is singular,
C                                                 i+1       -1
C                   i.e., the condition number estimate of S    (in the
C                                                           i+1
C                                                         -1    -1/2
C                   1-norm) exceeds 1/TOL.  The matrices S   , Q
C                                                         i+1   i
C                   and E have been computed.
C
C     METHOD
C
C     The routine performs one recursion of the square root information
C     filter algorithm, summarized as follows:
C
C       |    -1/2             -1/2    |     |         -1/2             |
C       |   Q         0      Q    Z   |     | (QINOV )     *     *     |
C       |    i                i    i  |     |       i                  |
C       |                             |     |                          |
C       |           -1/2      -1/2    |     |             -1    -1     |
C     T |    0     R    C    R    Y   |  =  |    0       S     S   X   |
C       |           i+1  i+1  i+1  i+1|     |             i+1   i+1 i+1|
C       |                             |     |                          |
C       |  -1 -1     -1 -1    -1      |     |                          |
C       | S  A  B   S  A     S  X     |     |    0         0     E     |
C       |  i         i        i  i    |     |                     i+1  |
C
C                   (Pre-array)                      (Post-array)
C
C     where T is an orthogonal transformation triangularizing the
C                        -1/2
C     pre-array, (QINOV )     is the inverse of the covariance square
C                      i
C     root (right Cholesky factor) of the process noise innovation
C                                                            -1  -1
C     (hence the information square root) at instant i and (A  ,A  B) is
C     in upper controller Hessenberg form.
C
C     An example of the pre-array is given below (where N = 6, M = 2,
C     and P = 3):
C
C         |x x |             | x|
C         |  x |             | x|
C         _______________________
C         |    | x x x x x x | x|
C         |    | x x x x x x | x|
C         |    | x x x x x x | x|
C         _______________________
C         |x x | x x x x x x | x|
C         |  x | x x x x x x | x|
C         |    | x x x x x x | x|
C         |    |   x x x x x | x|
C         |    |     x x x x | x|
C         |    |       x x x | x|
C
C     The inverse of the corresponding state covariance matrix P
C                                                               i+1|i+1
C     (hence the information matrix I) is then factorized as
C
C                    -1         -1     -1
C         I       = P       = (S   )' S
C          i+1|i+1   i+1|i+1    i+1    i+1
C
C     and one combined time and measurement update for the state is
C     given by X   .
C               i+1
C
C     The triangularization is done entirely via Householder
C     transformations exploiting the zero pattern of the pre-array.
C
C     REFERENCES
C
C     [1] Anderson, B.D.O. and Moore, J.B.
C         Optimal Filtering.
C         Prentice Hall, Englewood Cliffs, New Jersey, 1979.
C
C     [2] Van Dooren, P. and Verhaegen, M.H.G.
C         Condensed Forms for Efficient Time-Invariant Kalman Filtering.
C         SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988.
C
C     [3] Verhaegen, M.H.G. and Van Dooren, P.
C         Numerical Aspects of Different Kalman Filter Implementations.
C         IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.
C
C     [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
C         Algorithm 675: FORTRAN Subroutines for Computing the Square
C         Root Covariance Filter and Square Root Information Filter in
C         Dense or Hessenberg Forms.
C         ACM Trans. Math. Software, 15, pp. 243-256, 1989.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately
C
C           3    2                           2          3
C     (1/6)N  + N x (3/2 x M + P) + 2 x N x M  + 2/3 x M
C
C     operations and is backward stable (see [3]).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine FB01HD by M. Vanbegin,
C     P. Van Dooren, and M.H.G. Verhaegen.
C
C     REVISIONS
C
C     February 20, 1998, November 20, 2003, February 14, 2004.
C
C     KEYWORDS
C
C     Controller Hessenberg form, Kalman filtering, optimal filtering,
C     orthogonal transformation, recursive estimation, square-root
C     filtering, square-root information filtering.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TWO
      PARAMETER         ( ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBX, MULTRC
      INTEGER           INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV,
     $                  LDSINV, LDWORK, M, N, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*),
     $                  DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*),
     $                  RINVY(*), SINV(LDSINV,*), X(*), Z(*)
C     .. Local Scalars ..
      LOGICAL           LJOBX, LMULTR
      INTEGER           I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK,
     $                  LDW, M1, MP1, N1, NM, NP, WRKOPT
      DOUBLE PRECISION  RCOND
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD,
     $                  MB04ID, MB04KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      NP = N + P
      NM = N + M
      N1 = MAX( 1, N )
      M1 = MAX( 1, M )
      MP1 = M + 1
      INFO = 0
      LJOBX  = LSAME( JOBX, 'X' )
      LMULTR = LSAME( MULTRC, 'P' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDSINV.LT.N1 ) THEN
         INFO = -7
      ELSE IF( LDAINV.LT.N1 ) THEN
         INFO = -9
      ELSE IF( LDAINB.LT.N1 ) THEN
         INFO = -11
      ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDQINV.LT.M1 ) THEN
         INFO = -17
      ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M,
     $                                      NP*(N + 1) + N +
     $                                      MAX( N - 1, MP1 ), 3*N ) )
     $                                                             .OR.
     $    ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M,
     $                                      NP*(N + 1) + N +
     $                                      MAX( N - 1, MP1 ) ) ) ) THEN
         INFO = -25
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'FB01TD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, P ).EQ.0 ) THEN
         IF ( LJOBX ) THEN
            DWORK(1) = TWO
            DWORK(2) = ONE
         ELSE
            DWORK(1) = ONE
         END IF
         RETURN
      END IF
C
C     Construction of the needed part of the pre-array in DWORK.
C     To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and
C     (2,3) will be constructed when needed as shown below.
C
C     Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2)
C     blocks of DWORK, respectively. The upper trapezoidal structure of
C     [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the
C     following partition is used:
C
C       [ S1  S2 ] [ B1  A1 A3 ]
C       [ 0   S3 ] [ 0   A2 A4 ],
C
C     where B1, A3, and S1 are M-by-M matrices, A1 and S2 are
C     M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and
C     B1, S1, A2, and S3 are upper triangular. The right hand side
C     matrix above is stored in the workspace. If M > N, the partition
C     is [ SINV ] [ B1 B2  A ], where B1 is N-by-N, B2 is N-by-(M-N),
C     and B1 and SINV are upper triangular.
C     The variables called Ixy define the starting positions where the
C     (x,y) blocks of the pre-array are initially stored in DWORK.
C     Workspace: need N*(M+N).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      LDW = N1
      I32 = N*M + 1
C
      CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW )
      CALL DLACPY( 'Full',  MIN( M, N ), N, AINV, LDAINV, DWORK(I32),
     $             LDW )
      IF ( N.GT.M )
     $   CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV,
     $                DWORK(I32+M), LDW )
C
C                    [ B1  A1 ]
C     Compute SINV x [ 0   A2 ] or SINV x B1 as a product of upper
C     triangular matrices.
C     Workspace: need N*(M+N+1).
C
      II  = 1
      I13 = N*NM + 1
      WRKOPT = MAX( 1, N*NM + N )
C
      DO 10 I = 1, N
         CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV,
     $               LDSINV, DWORK(I13), 1 )
         CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 )
         II = II + N
   10 CONTINUE
C
C                    [ A3 ]
C     Compute SINV x [ A4 ] or SINV x [ B2 A ].
C
      CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M,
     $            ONE, SINV, LDSINV, DWORK(II), LDW )
C
C     Storing the process noise mean value in (1,3) block of DWORK.
C     Workspace: need N*(M+N) + M.
C
      CALL DCOPY( M, Z, 1, DWORK(I13), 1 )
      CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV,
     $            DWORK(I13), 1 )
C
C     Computing SINV x X in X.
C
      CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV,
     $            X, 1 )
C
C     Triangularization (2 steps).
C
C     Step 1: annihilate the matrix SINV x AINVB.
C     Workspace: need N*(N+2*M) + 3*M.
C
      I12   = I13  + M
      ITAU  = I12  + M*N
      JWORK = ITAU + M
C
      CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW,
     $             DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU),
     $             DWORK(JWORK) )
      WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M )
C
      IF ( N.EQ.0 ) THEN
         CALL DCOPY( P, RINVY, 1, E, 1 )
         IF ( LJOBX )
     $      DWORK(2) = ONE
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Apply the transformations to the last column of the pre-array.
C     (Only the updated (3,3) block is now needed.)
C
      IJ = 1
C
      DO 20 I = 1, M
         CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) +
     $               DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ),
     $                                  DWORK(IJ), 1, X, 1 )
         IJ = IJ + N
   20 CONTINUE
C
C     Now, the workspace for SINV x AINVB, as well as for the updated
C     (1,2) block of the pre-array, are no longer needed.
C     Move the computed (3,2) and (3,3) blocks of the pre-array in the
C     (1,1) and (1,2) block positions of DWORK, to save space for the
C     following computations.
C     Then, adjust the implicitly defined leading dimension of DWORK,
C     to make space for storing the (2,2) and (2,3) blocks of the
C     pre-array.
C     Workspace: need (P+N)*(N+1).
C
      CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW )
      IF ( N.GT.M )
     $   CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1),
     $                LDW )
      LDW = MAX( 1, NP )
C
      DO 40 I = N, 1, -1
         DO 30 IJ = MIN( N, I+M ), 1, -1
            DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ)
   30    CONTINUE
   40 CONTINUE
C
C     Copy of RINV x C in the (1,1) block of DWORK.
C
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW )
      IF ( .NOT.LMULTR )
     $   CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N,
     $               ONE, RINV, LDRINV, DWORK, LDW )
C
C     Copy the inclusion measurement in the (1,2) block and the updated
C     X in the (2,2) block of DWORK.
C
      I23 = NP*N + 1
      I33 = I23  + P
      CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 )
      CALL DCOPY( N, X, 1, DWORK(I33), 1 )
      WRKOPT = MAX( WRKOPT, NP*( N + 1 ) )
C
C     Step 2: QR factorization of the first block column of the matrix
C
C        [ RINV x C     RINV x Y ],
C        [ SINV x AINV  SINV x X ]
C
C     where the second block row was modified at Step 1.
C     Workspace: need   (P+N)*(N+1) + N + MAX(N-1,M+1);
C                prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the
C                       optimal block size for DGEQRF called in MB04ID.
C
      ITAU  = I23  + NP
      JWORK = ITAU + N
C
      CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23),
     $             LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1,
     $             INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Output SINV, X, and E and set the optimal workspace dimension
C     (and the reciprocal of the condition number estimate).
C
      CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV )
      CALL DCOPY( N, DWORK(I23), 1, X, 1 )
      IF( P.GT.0 )
     $   CALL DCOPY( P, DWORK(I23+N), 1, E, 1 )
C
      IF ( LJOBX ) THEN
C
C        Compute X.
C        Workspace: need 3*N.
C
         CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit',
     $                '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND,
     $                TOL, IWORK, DWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRKOPT = MAX( WRKOPT, 3*N )
            DWORK(2) = RCOND
         END IF
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of FB01TD***
      END


module TrivariateMLSQModule

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use STDIntVectorModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule

implicit none

include 'mpif.h'

private
public QuadMLSQ, New, Delete, LogStats
public InterpolateScalar, InterpolateVector !, InterpolateScalarGradient, InterpolateScalarLaplacian
!public MLSQScalarGradientAtParticles, MLSQLaplacianAtParticles, MLSQDoubleDotAtParticles
public GetParticlesNearFace, GetParticlesNearVertex
!
!----------------
! types and module variables
!----------------
!
type QuadMLSQ
	real(kreal), pointer :: coeffs1(:,:) => null()
	real(kreal), pointer :: coeffs2(:,:) => null()
	real(kreal), pointer :: coeffs3(:,:) => null()
	type(STDIntVector), pointer :: nearbyParticles(:) => null()
	contains
		final :: deletePrivate
end type

integer(kint), parameter :: nCoeffs = 10 ! trivariate quadratic polynomials have 10 coefficients

!
!----------------
! interfaces
!----------------
!
interface New
	module procedure newPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

interface LogStats
	module procedure logStatsPrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'MLSQ'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=MAX_STRING_LENGTH) :: logString

contains
!
!----------------
! Public methods
!----------------
!
subroutine newPrivate(self, aMesh, dataField)
	type(QuadMLSQ), intent(out) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: dataField
	integer(kint) :: i

	if ( .NOT. logInit ) call InitLogger(log, procRank)

	allocate(self%coeffs1(nCoeffs, aMesh%particles%N))
	self%coeffs1 = 0.0_kreal
	if ( dataField%nDim > 1 ) then
		allocate(self%coeffs2(nCoeffs, aMesh%particles%N))
		self%coeffs2 = 0.0_kreal
		if ( dataField%nDim == 3 ) then
			allocate(self%coeffs3(nCoeffs, aMesh%particles%N))
			self%coeffs3 = 0.0_kreal
		endif
	endif
	allocate(self%nearbyParticles(amesh%particles%N))

	do i = 1, aMesh%particles%N
		if ( .NOT. aMesh%particles%isActive(i) ) then
			call GetParticlesNearVertex( self%nearbyParticles(i), aMesh, i)
		endif
	enddo

	do i = 1, aMesh%faces%N
		if ( .NOT. aMesh%faces%hasChildren(i) ) then
			call GetParticlesNearFace( self%nearbyParticles( aMesh%faces%centerParticle(i)), aMesh, i)
		endif
	enddo

	call SetCoefficients(self, aMesh, dataField)
end subroutine

subroutine deletePrivate(self)
	type(QuadMLSQ), intent(inout) :: self
	integer(kint) :: i
	if ( associated(self%nearbyParticles) ) then
		deallocate(self%nearbyParticles)
	endif
	if ( associated(self%coeffs1) ) deallocate(self%coeffs1)
	if ( associated(self%coeffs2) ) deallocate(self%coeffs2)
	if ( associated(self%coeffs3) ) deallocate(self%coeffs3)
end subroutine

subroutine logStatsPrivate(self, aLog)
	type(QuadMLSQ), intent(in) :: self
	type(Logger), intent(inout) :: aLog
	!
	integer(kint) :: i

	call StartSection(aLog, "QuadMLSQ nearbyParticles:")
	do i = 1, size(self%nearbyParticles)
		write(logString,'(I6,A)') i, " :"
		call LogMessage(aLog, TRACE_LOGGING_LEVEL, trim(logString), self%nearbyParticles(i) )
	enddo
	call EndSection(aLog)
end subroutine

subroutine SetCoefficients(self, aMesh, aField)
	type(QuadMLSQ), intent(inout) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: aField
	!
	real(kreal) :: x0(3)
	real(kreal) :: dataLocs(3,31)
	real(kreal) :: A(31,10) ! GetParticlesNear* will return vectors of size <= 29
	real(kreal) :: b(31,3)
	integer(kint) :: mm
	integer(kint) :: i, j
	real(kreal) :: lpkWork(20)
	integer(kint) :: lpkLWork, lpkInfo

	lpkLWork = 20

	do i = 1, aMesh%particles%N
		dataLocs(:,1) = PhysCoord(aMesh%particles, self%nearbyParticles(i)%int(1))
		mm = self%nearbyParticles(i)%N + 2
		if ( aField%nDim == 1 ) then
			b(1,1) = aField%scalar( self%nearbyParticles(i)%int(1))
		else
			b(1,1) = aField%xComp( self%nearbyParticles(i)%int(1))
			b(1,2) = aField%yComp( self%nearbyParticles(i)%int(1))
			b(1,3) = aField%zComp( self%nearbyParticles(i)%int(1))
		endif

		do j = 2, self%nearbyParticles(i)%N
			dataLocs(:,j) = PhysCoord(aMesh%particles, self%nearbyParticles(i)%int(j))
			if ( aField%nDim == 1 ) then
				b(j,1) = aField%scalar(self%nearbyParticles(i)%int(j))
			else
				b(j,1) = aField%xComp(self%nearbyParticles(i)%int(j))
				b(j,2) = aField%yComp(self%nearbyParticles(i)%int(j))
				b(j,3) = aField%zComp(self%nearbyParticles(i)%int(j))
			endif
		enddo

		dataLocs(:, mm-1) = 0.0_kreal
		b(mm-1,:) = b(1,:)
		dataLocs(:,mm) = 2.0_kreal * dataLocs(:,1)
		b(mm,:) = b(1,:)

		do j = 1, mm
			dataLocs(:,j) = dataLocs(:,j) - dataLocs(:,1)
		enddo

		A(1:mm,1) = 1.0_kreal
		A(1:mm,2) = dataLocs(1,1:mm)
		A(1:mm,3) = dataLocs(2,1:mm)
		A(1:mm,4) = dataLocs(3,1:mm)
		A(1:mm,5) = dataLocs(1,1:mm) * dataLocs(2,1:mm)
		A(1:mm,6) = dataLocs(1,1:mm) * dataLocs(3,1:mm)
		A(1:mm,7) = dataLocs(2,1:mm) * dataLocs(3,1:mm)
		A(1:mm,8) = dataLocs(1,1:mm) * dataLocs(1,1:mm)
		A(1:mm,9) = dataLocs(2,1:mm) * dataLocs(2,1:mm)
		A(1:mm,10) = dataLocs(3,1:mm) * dataLocs(3,1:mm)

		if ( aField%nDim == 1 ) then
			!call DGELSY( mm, 10, 1, A, mm, b(1:mm,1), mm, lpkWork, lpkLWork, lpkInfo	)
			call wrapped_scalar_dgelsy( mm, 10, A(1:mm,:), b(1:mm,1) )
			self%coeffs1(:,i) = b(1:10,1)
		else
			call wrapped_vector_dgelsy(mm, 10, A(1:mm,:), b(1:mm,:))
			self%coeffs1(:,i) = b(1:10,1)
			self%coeffs2(:,i) = b(1:10,2)
			self%coeffs3(:,i) = b(1:10,3)
		endif
	enddo
end subroutine

!
!----------------
! Private methods
!----------------
!
subroutine wrapped_scalar_dgelsy( m, n, A, b )
	integer(kint), intent(in) :: m, n
	real(kreal), intent(inout), dimension(m,n) :: A
	real(kreal), intent(inout), dimension(m) :: b
	!
	integer(kint) :: nRhs, lda, ldb, rank, lwork, info
	integer(kint), dimension(n) :: jpvt
	real(kreal) :: rcond
	real(kreal), dimension(100) :: work
	real(kreal), dimension(n) :: svals

	nRhs = 1
	lda = m
	ldb = m
	lwork = 100
	jpvt = 0
	rcond = -1.0_kreal

!	call DGELSY(m, n, nRhs, A, lda, b, ldb, jpvt, rcond, rank, work, lwork, info)
	call DGELSS(m, n, nRhs, A, lda, b, ldb, svals, rcond, rank, work, lwork, info)

	if ( info < 0 ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL,trim(logkey)//" DGELSY ERROR : bad argument ", info)
	elseif (info > 0 ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL,trim(logKey)//" DGELSS ERROR : failed to converge", info)
	endif
end subroutine

subroutine wrapped_vector_dgelsy( m, n, A, b )
	integer(kint), intent(in) :: m, n
	real(kreal), intent(inout), dimension(m,n) :: A
	real(kreal), intent(inout), dimension(m,3) :: b
	!
	integer(kint) :: nRhs, lda, ldb, rank, lwork, info
	integer(kint), dimension(n) :: jpvt
	real(kreal) :: rcond
	real(kreal), dimension(4*n+1) :: work

	nRhs = 3
	lda = m
	ldb = m
	lwork = 4*n+1
	jpvt = 0

	call DGELSY(m, n, nRhs, A, lda, b, ldb, jpvt, rcond, rank, work, lwork, info)

	if ( info < 0 ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL,trim(logkey)//" DGELSY ERROR : bad argument ", info)
	endif
end subroutine

function InterpolateScalar( self, aMesh, queryPt )
	real(kreal) :: InterpolateScalar
	type(QuadMLSQ), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	real(kreal), dimension(3), intent(in) :: queryPt
	!
	integer(kint) :: np
	real(kreal), dimension(10) :: basis
	real(kreal), dimension(3) :: x0

	np = nearestParticle( aMesh, queryPt )

	x0 = PhysCoord(aMesh%particles, nP)

	basis(1) = 1.0_kreal
	basis(2) = queryPt(1) - x0(1)
	basis(3) = queryPt(2) - x0(2)
	basis(4) = queryPt(3) - x0(3)
	basis(5) = (queryPt(1) - x0(1)) * (queryPt(2) - x0(2))
	basis(6) = (queryPt(1) - x0(1)) * (queryPt(3) - x0(3))
	basis(7) = (queryPt(2) - x0(2)) * (queryPt(3) - x0(3))
	basis(8) = (queryPt(1) - x0(1)) * (queryPt(1) - x0(1))
	basis(9) = (queryPt(2) - x0(2)) * (queryPt(2) - x0(2))
	basis(10) = (queryPt(3) - x0(3)) * (queryPt(3) - x0(3))

	InterpolateScalar = sum( self%coeffs1(:,nP) * basis)
end function

function InterpolateVector( self, aMesh, queryPt )
	real(kreal), dimension(3) :: InterpolateVector
	type(QuadMLSQ), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	real(kreal), dimension(3), intent(in) :: queryPt
	!
	integer(kint) :: np
	real(kreal), dimension(10) :: basis
	real(kreal), dimension(3) :: x0

	np = nearestParticle( aMesh, queryPt )

	x0 = PhysCoord(aMesh%particles, nP)

	basis(1) = 1.0_kreal
	basis(2) = queryPt(1) - x0(1)
	basis(3) = queryPt(2) - x0(2)
	basis(4) = queryPt(3) - x0(3)
	basis(5) = (queryPt(1) - x0(1)) * (queryPt(2) - x0(2))
	basis(6) = (queryPt(1) - x0(1)) * (queryPt(3) - x0(3))
	basis(7) = (queryPt(2) - x0(2)) * (queryPt(3) - x0(3))
	basis(8) = (queryPt(1) - x0(1)) * (queryPt(1) - x0(1))
	basis(9) = (queryPt(2) - x0(2)) * (queryPt(2) - x0(2))
	basis(10) = (queryPt(3) - x0(3)) * (queryPt(3) - x0(3))

	InterpolateVector(1) = sum( self%coeffs1(:,np) * basis)
	InterpolateVector(2) = sum( self%coeffs2(:,nP) * basis)
	InterpolateVector(3) = sum( self%coeffs3(:,nP) * basis)
end function

subroutine GetParticlesNearFace( nearbyParticles, aMesh, faceIndex)
	type(STDIntVector), intent(out) :: nearbyParticles
	type(PolyMesh2d), intent(in) :: aMesh
	integer(kint), intent(in) :: faceIndex
	!
	type(STDIntVector) :: adjFaces, faceVerts
	integer(kint) :: i, j
	logical(klog) :: duplicateFound

	call initialize(nearbyParticles)
	call nearbyParticles%pushBack( aMesh%faces%centerParticle(faceIndex) )

	call CCWAdjacentFaces( aMesh, adjFaces, faceIndex )
	! DEBUG
	duplicateFound = .FALSE.
	do i = 1, adjFaces%N
		do j = i+1, adjFaces%N
			if ( adjFaces%int(i) == adjFaces%int(j) ) duplicateFound = .TRUE.
		enddo
	enddo

	if ( duplicateFound ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey)//"GetParticlesNearFace adjFaces duplicate ERROR at face : ", faceIndex )
		call LogMessage(log, ERROR_LOGGING_LEVEL, "adjFaces = ", adjFaces )
	endif
	! END DEBUG

	call CCWVerticesAroundFace( aMesh, faceVerts, faceIndex )
	! DEBUG
	duplicateFound = .FALSE.
	do i = 1, faceVerts%N
		do j = i+1, faceVerts%N
			if ( faceVerts%int(i) == faceVerts%int(j) ) duplicateFound = .TRUE.
		enddo
	enddo

	if ( duplicateFound ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey)//" GetParticlesNearFace faceVerts duplicate ERROR at face : ", faceIndex )
		call LogMessage(log, ERROR_LOGGING_LEVEL, "faceVerts = ", faceVerts )
	endif
	! END DEBUG

	do i = 1, adjFaces%N
		call nearbyParticles%pushBack( aMesh%faces%centerParticle( adjFaces%int(i) ))
	enddo
	do i = 1, faceVerts%N
		call nearbyParticles%pushBack( faceVerts%int(i) )
	enddo

	do i = 1, adjFaces%N
		call initialize(faceVerts)
		call CCWVerticesAroundFace( aMesh, faceVerts, adjFaces%int(i) )
		do j = 1, faceVerts%N
			call nearbyParticles%pushBackUnique( faceVerts%int(j))
		enddo
	enddo
end subroutine

subroutine GetParticlesNearVertex( nearbyParticles, aMesh, vertIndex)
	type(STDIntVector), intent(out) :: nearbyParticles
	type(PolyMesh2d), intent(in) :: aMesh
	integer(kint), intent(in) :: vertIndex
	!
	type(STDIntVector) :: adjFaces, faceVerts
	integer(kint) :: i, j
	logical(klog) :: duplicateFound

	call initialize(nearbyParticles)
	call nearbyParticles%pushBack(vertIndex)

	call CCWFacesAroundVertex( aMesh, adjFaces, vertIndex )
	! DEBUG
	duplicateFound = .FALSE.
	do i = 1, adjFaces%N
		do j = i + 1, adjFaces%N
			if ( adjFaces%int(i) == adjFaces%int(j) ) duplicateFound = .TRUE.
		enddo
	enddo
	if ( duplicateFound ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, &
			trim(logKey)//" GetParticlesNearVertex adjFaces duplicate ERROR at vert", vertIndex)
		call LogMessage(log, ERROR_LOGGING_LEVEL, "adjFaces = ", adjFaces )
	endif
	! END DEBUG

	do i = 1, adjFaces%N
		call nearbyParticles%pushBack( aMesh%faces%centerParticle(adjFaces%int(i)) )
	enddo

	do i = 1, adjFaces%N
		call initialize(faceVerts)
		call CCWVerticesAroundFace( aMesh, faceVerts, adjFaces%int(i))
		do j = 1, faceVerts%N
			call nearbyParticles%pushBackUnique( faceVerts%int(j))
		enddo
	enddo
end subroutine

subroutine InitLogger(aLog,rank)
! Initialize a logger for this module and processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

end module


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!program tvtsgs
!    use spherepack
!    implicit none
!    real(wp) :: a
!    real(wp) :: b
!    real(wp) :: bi
!    real(wp) :: br
!    real(wp) :: c
!    real(wp) :: ci
!    real(wp) :: cr
!    real(wp) :: da
!    real(wp) :: db
!    real(wp) :: dmax1
!    real(wp) :: dmax2
!    real(wp) :: dphi
!    real(wp) :: dtr
!    real(wp) :: hpi
!    integer(ip) :: i
!    integer(ip) :: idp
!    integer(ip) :: ierror
!    integer(ip) :: iq
!    integer(ip) :: isym
!    integer(ip) :: j
!    integer(ip) :: jdp
!    integer(ip) :: jq
!    integer(ip) :: k
!    integer(ip) :: ldwork
!    integer(ip) :: lwork
!    integer(ip) :: lwshi
!    integer(ip) :: lwvha
!    integer(ip) :: lwvhs
!    integer(ip) :: lwvts
!    integer(ip) :: mdab
!    integer(ip) :: mp1
!    integer(ip) :: ndab
!    integer(ip) :: nlat
!    integer(ip) :: nlon
!    integer(ip) :: np1
!    integer(ip) :: nt
!    real(wp) :: phi
!
!    real(wp) :: s
!    real(wp) :: theta
!    real(wp) :: tmp
!    real(wp) :: u
!    real(wp) :: v
!    real(wp) :: vt
!    real(wp) :: w
!    real(wp) :: work
!    real(wp) :: wshi
!    real(wp) :: wt
!    real(wp) :: wvha
!    real(wp) :: wvhs
!    real(wp) :: wvts
!    real(wp) :: x
!    real(wp) :: y
!    real(wp) :: z
!    !
!    !     this program checks vtsgs for computing the colatitudinal
!    !     derivatives of the velocity ....
!    !
!    parameter (nlat=17, nlon=32)
!    parameter (idp=nlat, jdp=nlon, mdab=nlat, ndab=nlat)
!    !
!    dimension u(idp, jdp), v(idp, jdp), w(idp, jdp), &
!        x(idp, jdp), y(idp, jdp), z(idp, jdp), &
!        vt(idp, jdp), wt(idp, jdp), &
!        a(mdab, ndab, 3), b(mdab, ndab, 3), &
!        da(mdab, ndab, 3, 3), db(mdab, ndab, 3, 3), &
!        tmp(mdab, ndab), br(mdab, ndab), bi(mdab, ndab), &
!        cr(mdab, ndab), ci(mdab, ndab), &
!        c(idp, jdp, 3, 3), s(idp, jdp, 3, 3), &
!        dthet(idp), dwts(idp)
!    dimension wshi(608411), wvha(1098771), wvhs(1098771), &
!        wvts(1098771), work(165765)
!    real dthet, dwts, dwork(25741)
!    !
!    lwshi = 608411
!    lwvha = 1098771
!    lwvhs = 1098771
!    lwvts = 1098771
!    lwork = 165765
!    ldwork = 25741
!    !
!    hpi = pi/2.
!    dtr = pi/180.
!    isym = 0
!    nt = 1
!    !
!    !     initialize spherepack routines
!    !
!    call shigs(nlat, nlon, wshi, lwshi, work, lwork, dwork, ldwork, ierror)
!    if(ierror /= 0) write (6, 55) ierror
!55  format('testvtsgs:  error' i4 ' in shigs')
!    call vhagsi(nlat, nlon, wvha, lwvha, dwork, ldwork, ierror)
!    if(ierror /= 0) write (6, 57) ierror
!57  format('testvtsgs:  error' i4 ' in vhagsi')
!    call vhsgsi(nlat, nlon, wvhs, lwvhs, dwork, ldwork, ierror)
!    if(ierror /= 0) write (6, 58) ierror
!58  format(' testvtsgs: error' i4 ' in vhsgsi')
!    call vtsgsi(nlat, nlon, wvts, lwvts, work, lwork, dwork, ldwork, ierror)
!    if(ierror /= 0) write (6, 59) ierror
!59  format(' testvtsgs: error' i4 ' in vtsgsi')
!    !
!    !     compute gauss points and weights
!    !
!    call compute_gaussian_latitudes_and_weights(nlat, dthet, dwts, work, lwork, ierror)
!    !
!    !     zero vector harmonic coefficients
!    !
!    do np1=1, nlat
!        do mp1=1, np1
!            br(mp1, np1) = 0.
!            bi(mp1, np1) = 0.
!            cr(mp1, np1) = 0.
!            ci(mp1, np1) = 0.
!        end do
!    end do
!    !
!    !     initialize arrays with random numbers
!    !     old style non-portable commented out
!    !
!    !     call srand(227)
!    !     do np1=1, nlat-1
!    !     do mp1=1, np1
!    !     br(mp1, np1) = rand()
!    !     bi(mp1, np1) = rand()
!    !     cr(mp1, np1) = rand()
!    !     ci(mp1, np1) = rand()
!    !     end do
!    !     end do
!    !
!    !     set vector harmonic coefficients
!    !     (new style using standard Fortran90
!    !     intrinsics
!    !
!    call RANDOM_SEED()
!    !
!    call RANDOM_NUMBER(tmp)
!    do np1=1, nlat-1
!        do mp1=1, np1
!            br(mp1, np1) = tmp(mp1, np1)
!        end do
!    end do
!    !
!    call RANDOM_NUMBER(tmp)
!    do np1=1, nlat-1
!        do mp1=1, np1
!            bi(mp1, np1) = tmp(mp1, np1)
!        end do
!    end do
!    !
!    call RANDOM_NUMBER(tmp)
!    do np1=1, nlat-1
!        do mp1=1, np1
!            cr(mp1, np1) = tmp(mp1, np1)
!        end do
!    end do
!    !
!    call RANDOM_NUMBER(tmp)
!    do np1=1, nlat-1
!        do mp1=1, np1
!            ci(mp1, np1) = tmp(mp1, np1)
!        end do
!    end do
!    !
!    call vhsgs(nlat, nlon, 0, 1, v, w, idp, jdp, br, bi, &
!        cr, ci, mdab, ndab, wvhs, lwvhs, work, lwork, ierror)
!    if(ierror /= 0) write (6, 79) ierror
!79  format(' testvtsgs: error' i4 ' in vhsgs at point 1')
!    !
!    do j=1, nlon
!        do i=1, nlat
!            u(i, j) = 0.
!        end do
!    end do
!    !
!    !     convert to cartesian coordinates
!    !
!    dphi = 2.*pi/nlon
!    do j=1, nlon
!        phi = (j-1)*dphi
!        do i=1, nlat
!            theta = dthet(i)
!            call stoc(theta, phi, u(i, j), v(i, j), w(i, j), x(i, j), y(i, j), z(i, j))
!        end do
!    end do
!    !
!    !     compute harmonic components of x component
!    !
!    call shags(nlat, nlon, 0, 1, x, idp, jdp, a(1, 1, 1), b(1, 1, 1), &
!        mdab, ndab, wshi, lwshi, work, lwork, ierror)
!    if(ierror /= 0) write (6, 16) ierror
!16  format(' testvtsgs: error' i4 ' in shags at point 2')
!    !
!    !     write harmonic coefficients for x
!    !
!    !      write (6, 20)
!    ! 20   format(//'  harmonic coefficients for x'//)
!    !      do mp1=1, nlat
!    !      do np1=mp1, nlat
!    !      write (6, 5) mp1, np1, a(mp1, np1, 1), b(mp1, np1, 1)
!    ! 5    format(2i5, 1p2e15.6)
!    !      end do
!    !      end do
!    !
!    !     compute harmonic components of y component
!    !
!    call shags(nlat, nlon, 0, 1, y, idp, jdp, a(1, 1, 2), b(1, 1, 2), &
!        mdab, ndab, wshi, lwshi, work, lwork, ierror)
!    if(ierror /= 0) write (6, 17) ierror
!17  format(' testvtsgs: error' i4 ' in shags at point 3')
!    !
!    !     write harmonic coefficients for y
!    !
!    !      write (6, 21)
!    ! 21   format(//'  harmonic coefficients for y'//)
!    !      do mp1=1, nlat
!    !      do np1=mp1, nlat
!    !      write (6, 5) mp1, np1, a(mp1, np1, 2), b(mp1, np1, 2)
!    !      end do
!    !      end do
!    !
!    !     compute harmonic components of z component
!    !
!    call shags(nlat, nlon, 0, 1, z, idp, jdp, a(1, 1, 3), b(1, 1, 3), &
!        mdab, ndab, wshi, lwshi, work, lwork, ierror)
!    if(ierror /= 0) write (6, 18) ierror
!18  format(' testvtsgs: error' i4 ' in shags at point 4')
!    !
!    !     write harmonic coefficients for z
!    !
!    !      write (6, 22)
!    ! 22   format(//'  harmonic coefficients for z'//)
!    !      do mp1=1, nlat
!    !      do np1=mp1, nlat
!    !      write (6, 5) mp1, np1, a(mp1, np1, 3), b(mp1, np1, 3)
!    !      end do
!    !      end do
!    !
!    !     compute partials of x, y, and z wrt z
!    !
!    call dbdz(nlat, nlat, a(1, 1, 1), b(1, 1, 1), da(1, 1, 1, 3), db(1, 1, 1, 3))
!    call dbdz(nlat, nlat, a(1, 1, 2), b(1, 1, 2), da(1, 1, 2, 3), db(1, 1, 2, 3))
!    call dbdz(nlat, nlat, a(1, 1, 3), b(1, 1, 3), da(1, 1, 3, 3), db(1, 1, 3, 3))
!    !
!    !     compute partials of x, y, and z wrt y
!    !
!    call dbdy(nlat, nlat, a(1, 1, 1), b(1, 1, 1), da(1, 1, 1, 2), db(1, 1, 1, 2))
!    call dbdy(nlat, nlat, a(1, 1, 2), b(1, 1, 2), da(1, 1, 2, 2), db(1, 1, 2, 2))
!    call dbdy(nlat, nlat, a(1, 1, 3), b(1, 1, 3), da(1, 1, 3, 2), db(1, 1, 3, 2))
!    !
!    !     compute partials of x, y, and z wrt x
!    !
!    call dbdx(nlat, nlat, a(1, 1, 1), b(1, 1, 1), da(1, 1, 1, 1), db(1, 1, 1, 1))
!    call dbdx(nlat, nlat, a(1, 1, 2), b(1, 1, 2), da(1, 1, 2, 1), db(1, 1, 2, 1))
!    call dbdx(nlat, nlat, a(1, 1, 3), b(1, 1, 3), da(1, 1, 3, 1), db(1, 1, 3, 1))
!    !
!    !     transform cartesian jacobian to physical space
!    !
!    call shsgs(nlat, nlon, 0, 9, c, idp, jdp, da, db, idp, idp, &
!        wshi, lwshi, work, lwork, ierror)
!    if(ierror /= 0) write (6, 19) ierror
!19  format(' testvtsgs: error' i4 ' in shsgs at point 5')
!    !
!    !     convert to jacobian to spherical coordinates
!    !        (multiply cartesian jacobian by q)
!    !
!    do k=1, 3
!        do j=1, nlon
!            phi = (j-1)*dphi
!            do i=1, nlat
!                theta = dthet(i)
!                call ctos(theta, phi, c(i, j, 1, k), c(i, j, 2, k), c(i, j, 3, k), &
!                    s(i, j, 1, k), s(i, j, 2, k), s(i, j, 3, k))
!            end do
!        end do
!    end do
!    !
!    !     form s = (q sq**T)**T
!    !
!    do k=1, 3
!        do j=1, nlon
!            phi = (j-1)*dphi
!            do i=1, nlat
!                theta = dthet(i)
!                call ctos(theta, phi, s(i, j, k, 1), s(i, j, k, 2), s(i, j, k, 3), &
!                    c(i, j, k, 1), c(i, j, k, 2), c(i, j, k, 3))
!            end do
!        end do
!    end do
!
!    do j=1, nlon
!        do i=1, nlat
!            do iq=1, 3
!                do jq=1, 3
!                    s(i, j, iq, jq) = c(i, j, iq, jq)
!                end do
!            end do
!        end do
!    end do
!    !
!    !     check derivative program
!    !
!    call vtsgs(nlat, nlon, 0, 1, vt, wt, idp, jdp, br, bi, cr, ci, &
!        mdab, ndab, wvts, lwvts, work, lwork, ierror)
!    if(ierror /= 0) write (6, 4) ierror
!4   format(' testvtsgs: error' i4 ' in vtsgs during initialization')
!    dmax1 = 0.
!    dmax2 = 0.
!    do j=1, nlon
!        do i=1, nlat
!            dmax1 = max(dmax1, abs(s(i, j, 2, 2)-vt(i, j)))
!            dmax2 = max(dmax2, abs(s(i, j, 3, 2)-wt(i, j)))
!        end do
!    end do
!    write (6, 2) dmax1, dmax2
!2   format(' testvtsgs: error in vt '1pe15.6' error in wt '1pe15.6)
!end program tvtsgs
!subroutine ctos(theta, phi, x, y, z, u, v, w)
!    implicit none
!    real(wp) :: cp
!    real(wp) :: ct
!    real(wp) :: phi
!    real(wp) :: sp
!    real(wp) :: st
!    real(wp) :: temp1
!    real(wp) :: temp2
!    real(wp) :: theta
!    real(wp) :: u
!    real(wp) :: v
!    real(wp) :: w
!    real(wp) :: x
!    real(wp) :: y
!    real(wp) :: z
!    !
!    !     this program computes the components of a vector
!    !     field in spherical coordinates u, v, and w, from
!    !     its components x, y, and z in cartesian coordinates
!    !
!    st = sin(theta)
!    ct = cos(theta)
!    sp = sin(phi)
!    cp = cos(phi)
!    temp1 = cp*x+sp*y
!    temp2 = cp*y-sp*x
!    u = st*temp1+ct*z
!    v = ct*temp1-st*z
!    w = temp2
!    return
!end subroutine ctos
!subroutine stoc(theta, phi, u, v, w, x, y, z)
!    implicit none
!    real(wp) :: cp
!    real(wp) :: ct
!    real(wp) :: phi
!    real(wp) :: sp
!    real(wp) :: st
!    real(wp) :: temp1
!    real(wp) :: temp2
!    real(wp) :: theta
!    real(wp) :: u
!    real(wp) :: v
!    real(wp) :: w
!    real(wp) :: x
!    real(wp) :: y
!    real(wp) :: z
!    !
!    !     this program computes the components of a vector
!    !     field in cartesian coordinates x, y, and z, from
!    !     its components u, v, and w in spherical coordinates
!    !
!    st = sin(theta)
!    ct = cos(theta)
!    sp = sin(phi)
!    cp = cos(phi)
!    temp1 = st*u+ct*v
!    temp2 = ct*u-st*v
!    x = cp*temp1-sp*w
!    y = sp*temp1+cp*w
!    z = temp2
!    return
!end subroutine stoc
!subroutine dbdx(l, mdim, a, b, dxa, dxb)
!    implicit none
!    real(wp) :: a
!    real(wp) :: a1
!    real(wp) :: a2
!    real(wp) :: b
!    real(wp) :: cn
!    real(wp) :: dxa
!    real(wp) :: dxb
!    real(wp) :: fm
!    real(wp) :: fn
!    integer(ip) :: l
!    integer(ip) :: lm1
!    integer(ip) :: mdim
!    integer(ip) :: mp1
!    integer(ip) :: n
!    integer(ip) :: np1
!    !
!    !     subroutine to compute the coefficients in the spherical
!    !     harmonic representation of the derivative with respect to x
!    !     of a scalar function. i.e. given the coefficients a and b
!    !     in the spectral representation of a function, then dbdx
!    !     computes the coefficients dxa and dxb in the spectral
!    !     representation of the derivative of the function
!    !     with respect to x.
!    !
!    !     the arrays a and dxa can be the same as well as the arrays
!    !     b and dxb, i.e. the arrays a and b can be overwritten by
!    !     dxa and dxb respectively.
!    !
!    !     dimension a(mdim, 1), b(mdim, 1), dxa(mdim, 1), dxb(mdim, 1)
!    dimension a(mdim, *), b(mdim, *), dxa(mdim, *), dxb(mdim, *)
!    dxa(1, 1) = sqrt(6.)*a(2, 2)
!    dxb(1, 1) = 0.
!    lm1 = l-1
!    do 10 np1=2, lm1
!        n = np1-1
!        fn = real(n)
!        cn = (fn+fn+3.)/(fn+fn+1.)
!        dxa(1, np1) = sqrt(cn*(fn+2.)*(fn+1.))*a(2, np1+1)
!        dxb(1, np1) = 0.
!        do 10 mp1=2, np1
!            fm = real(mp1-1)
!            a1 = .5*sqrt(cn*(fn+fm+2.)*(fn+fm+1.))
!            a2 = .5*sqrt(cn*(fn-fm+2.)*(fn-fm+1.))
!            dxa(mp1, np1) = a1*a(mp1+1, np1+1)-a2*a(mp1-1, np1+1)
!            dxb(mp1, np1) = a1*b(mp1+1, np1+1)-a2*b(mp1-1, np1+1)
!10      continue
!        do 5 mp1=1, l
!            dxa(mp1, l) = 0.
!            dxb(mp1, l) = 0.
!5       continue
!        return
!    end subroutine dbdx
!    subroutine dbdy(l, mdim, a, b, dya, dyb)
!        implicit none
!        real(wp) :: a
!        real(wp) :: a1
!        real(wp) :: a2
!        real(wp) :: b
!        real(wp) :: cn
!        real(wp) :: dya
!        real(wp) :: dyb
!        real(wp) :: fm
!        real(wp) :: fn
!        integer(ip) :: l
!        integer(ip) :: lm1
!        integer(ip) :: mdim
!        integer(ip) :: mp1
!        integer(ip) :: n
!        integer(ip) :: np1
!        !
!        !     subroutine to compute the coefficients in the spherical
!        !     harmonic representation of the derivative with respect to y
!        !     of a scalar function. i.e. given the coefficients a and b
!        !     in the spectral representation of a function, then dbdy
!        !     computes the coefficients dya and dyb in the spectral
!        !     representation of the derivative of the function
!        !     with respect to y.
!        !
!        !     the arrays a and dya can be the same as well as the arrays
!        !     b and dyb, i.e. the arrays a and b can be overwritten by
!        !     dya and dyb respectively.
!        !
!        !     dimension a(mdim, 1), b(mdim, 1), dya(mdim, 1), dyb(mdim, 1)
!        dimension a(mdim, *), b(mdim, *), dya(mdim, *), dyb(mdim, *)
!        dya(1, 1) = -sqrt(6.)*b(2, 2)
!        dyb(1, 1) = 0.
!        lm1 = l-1
!        do 10 np1=2, lm1
!            n = np1-1
!            fn = real(n)
!            cn = (fn+fn+3.)/(fn+fn+1.)
!            dya(1, np1) = -sqrt(cn*(fn+2.)*(fn+1.))*b(2, np1+1)
!            dyb(1, np1) = 0.
!            do 10 mp1=2, np1
!                fm = real(mp1-1)
!                a1 = .5*sqrt(cn*(fn+fm+2.)*(fn+fm+1.))
!                a2 = .5*sqrt(cn*(fn-fm+2.)*(fn-fm+1.))
!                dya(mp1, np1) = -a1*b(mp1+1, np1+1)-a2*b(mp1-1, np1+1)
!                dyb(mp1, np1) =  a1*a(mp1+1, np1+1)+a2*a(mp1-1, np1+1)
!10          continue
!            do 5 mp1=1, l
!                dya(mp1, l) = 0.
!                dyb(mp1, l) = 0.
!5           continue
!            return
!        end subroutine dbdy
!        subroutine dbdz(l, mdim, a, b, dza, dzb)
!            implicit none
!            real(wp) :: a
!            real(wp) :: a1
!            real(wp) :: b
!            real(wp) :: cn
!            real(wp) :: dza
!            real(wp) :: dzb
!            real(wp) :: fm
!            real(wp) :: fn
!            integer(ip) :: l
!            integer(ip) :: lm1
!            integer(ip) :: mdim
!            integer(ip) :: mp1
!            integer(ip) :: n
!            integer(ip) :: np1
!            !
!            !     subroutine to compute the coefficients in the spherical
!            !     harmonic representation of the derivative with respect to z
!            !     of a scalar function. i.e. given the coefficients a and b
!            !     in the spectral representation of a function, then dbdz
!            !     computes the coefficients dza and dzb in the spectral
!            !     representation of the derivative of the function
!            !     with respect to z.
!            !
!            !     the arrays a and dza can be the same as well as the arrays
!            !     b and dzb, i.e. the arrays a and b can be overwritten by
!            !     dza and dzb respectively.
!            !
!            dimension a(mdim, 1), b(mdim, 1), dza(mdim, 1), dzb(mdim, 1)
!            lm1 = l-1
!            do 10 np1=1, lm1
!                n = np1-1
!                fn = real(n)
!                cn = (fn+fn+3.)/(fn+fn+1.)
!                do 10 mp1=1, np1
!                    fm = real(mp1-1)
!                    a1 = sqrt(cn*(fn-fm+1.)*(fn+fm+1.))
!                    dza(mp1, np1) = a1*a(mp1, np1+1)
!                    dzb(mp1, np1) = a1*b(mp1, np1+1)
!10              continue
!                do 5 mp1=1, l
!                    dza(mp1, l) = 0.
!                    dzb(mp1, l) = 0.
!5               continue
!                return
!            end subroutine dbdz


    subroutine getindx(n,min,siz,loc,index,inflag)
!-----------------------------------------------------------------------

!     Gets the coordinate index location of a point within a grid
!     ***********************************************************

! n       number of "nodes" or "cells" in this coordinate direction
! min     origin at the center of the first cell
! siz     size of the cells
! loc     location of the point being considered
! index   output index within [1,n]
! inflag  true if the location is actually in the grid (false otherwise
!         e.g., if the location is outside then index will be set to
!         nearest boundary

!-----------------------------------------------------------------------
    integer ::   n,index
    real ::      min,siz,loc
    logical ::   inflag

! Compute the index of "loc":

    index = int( (loc-min)/siz + 1.5 )

! Check to see if in or out:

    if(index < 1) then
        index  = 1
        inflag = .FALSE.
    else if(index > n) then
        index  = n
        inflag = .FALSE.
    else
        inflag = .TRUE.
    end if

! Return to calling program:

    return
    end subroutine getindx


! { dg-do run }
! Tests the fix for PR33686, in which dependencies were not
! correctly handled for the assignments below.
!
! Contributed by Dick Hendrickson on comp.lang.fortran,
! " Most elegant syntax for inverting a permutation?" 20071006
!
! Test the fix for PR36091 as well...
! { dg-options "-fbounds-check" }
!
  integer :: p(4) = (/2,4,1,3/)
  forall (i = 1:4) p(p(i)) = i                ! This was the original
  if (any (p .ne. (/3,1,4,2/))) call abort ()

  forall (i = 1:4) p(5 - p(i)) = p(5 - i)     ! This is a more complicated version
  if (any (p .ne. (/1,2,3,4/))) call abort ()
end


      SUBROUTINE frenel(x,s,c)
      INTEGER MAXIT
      REAL c,s,x,EPS,FPMIN,PI,PIBY2,XMIN
      PARAMETER (EPS=6.e-8,MAXIT=100,FPMIN=1.e-30,XMIN=1.5,PI=3.1415927,
     *PIBY2=1.5707963)
      INTEGER k,n
      REAL a,absc,ax,fact,pix2,sign,sum,sumc,sums,term,test
      COMPLEX b,cc,d,h,del,cs
      LOGICAL odd
      absc(h)=abs(real(h))+abs(aimag(h))
      ax=abs(x)
      if(ax.lt.sqrt(FPMIN))then
        s=0.
        c=ax
      else if(ax.le.XMIN)then
        sum=0.
        sums=0.
        sumc=ax
        sign=1.
        fact=PIBY2*ax*ax
        odd=.true.
        term=ax
        n=3
        do 11 k=1,MAXIT
          term=term*fact/k
          sum=sum+sign*term/n
          test=abs(sum)*EPS
          if(odd)then
            sign=-sign
            sums=sum
            sum=sumc
          else
            sumc=sum
            sum=sums
          endif
          if(term.lt.test)goto 1
          odd=.not.odd
          n=n+2
11      continue
        pause 'series failed in frenel'
1       s=sums
        c=sumc
      else
        pix2=PI*ax*ax
        b=cmplx(1.,-pix2)
        cc=1./FPMIN
        d=1./b
        h=d
        n=-1
        do 12 k=2,MAXIT
          n=n+2
          a=-n*(n+1)
          b=b+4.
          d=1./(a*d+b)
          cc=b+a/cc
          del=cc*d
          h=h*del
          if(absc(del-1.).lt.EPS)goto 2
12      continue
        pause 'cf failed in frenel'
2       h=h*cmplx(ax,-ax)
        cs=cmplx(.5,.5)*(1.-cmplx(cos(.5*pix2),sin(.5*pix2))*h)
        c=real(cs)
        s=aimag(cs)
      endif
      if(x.lt.0.)then
        c=-c
        s=-s
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/frenel.for


      SUBROUTINE ROTATE(RLON,RLAT,ALPHA,ROTLON,ROTLAT)
C
C THIS SUBROUTINE COMPUTES THE ROTATED COORDINATES
C ROTLON,ROTLAT FOR A ROTATION BY ANGLE ALPHA
C
C CALLED BY: ANLYTC, INIT
C CALLS:
C
C REVISIONS:
C 7-13-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C ORIGINAL LONGITUDE
      REAL RLON
C ORIGINAL LATITUDE
      REAL RLAT
C ROTATION ANGLE
      REAL ALPHA
C
C     Output
C
C ROTATED LONGITUDE
      REAL ROTLON
C ROTATED LATITUDE
      REAL ROTLAT
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C------ Local Variables ------------------------------------------------
C
      REAL TEST
C
C----- Executable Statements -------------------------------------------
C
      IF (ALPHA .EQ. 0.0) THEN
C
C        NO ROTATION
C
         ROTLON = RLON
         ROTLAT = RLAT
      ELSE
C
C        ROTATION BY ANGLE ALPHA
C
C        ROTATED LATITUDE
C
         TEST = SIN(RLAT)*COS(ALPHA)-
     $            COS(RLAT)*COS(RLON)*SIN(ALPHA)
         IF (TEST .GT. 1.0) THEN
            ROTLAT = PI/2.0
         ELSEIF (TEST .LT. -1.0) THEN
            ROTLAT = -PI/2.0
         ELSE
            ROTLAT = ASIN(TEST)
         ENDIF
C
C        ROTATED LONGITUDE
C
         TEST = COS(ROTLAT)
         IF (TEST .EQ. 0.0) THEN
            ROTLON = 0.0
         ELSE
            TEST = SIN(RLON)*COS(RLAT)/TEST
            IF (TEST .GT. 1.0) THEN
               ROTLON = PI/2.0
            ELSEIF (TEST .LT. -1.0) THEN
               ROTLON = -PI/2.0
            ELSE
               ROTLON = ASIN(TEST)
            ENDIF
         ENDIF
C
C        ADJUST FOR CORRECT BRANCH OF INVERSE SINE
C
         TEST = COS(ALPHA)*COS(RLON)*COS(RLAT)
     $          + SIN(ALPHA)*SIN(RLAT)
         IF (TEST .LT. 0.0) THEN
            ROTLON = PI - ROTLON
         ENDIF
      ENDIF
C
      RETURN
C
      END


C++------------------------------------------------------------------
C Program CYLIN
C To project spherical coordinates (alpha, delta) on
C a cylinder limited at Delta_lim
C
C JLP
C Previous version of 05-07-88
C Version of 02/04/2007
C------------------------------------------------------------------
	PROGRAM CYLIN
	PARAMETER(IDIM=10000,IDIM1=10000,NMAGMAX=8)
	REAL*4 ALPHA(IDIM1),DELTA(IDIM1),XMAG(IDIM1)
	REAL*4 XX1(IDIM1),YY1(IDIM1),XMAG1(IDIM1)
	REAL*4 XX2(IDIM1),YY2(IDIM1),XMAG2(IDIM)
	REAL*4 XX3(IDIM1),YY3(IDIM1),XMAG3(IDIM)
	REAL*4 XX4(IDIM1),YY4(IDIM1),XMAG4(IDIM)
	REAL*4 XPLOT(IDIM,NMAGMAX),YPLOT(IDIM,NMAGMAX)
	INTEGER*4 NPTS(NMAGMAX)
	CHARACTER NCHAR(NMAGMAX)*4,SYMB(9)*4,PLOTDEV*32
        CHARACTER PCOLOR(NGAMAX)*30
	CHARACTER XLABEL*30,YLABEL*30,TITLE*40,ANS*1
	DATA SYMB/'1   ','41  ','42  ','43  ','44  ',
     1	'45  ','46  ','45  ','48  '/
	DATA PI/3.14159/

10	FORMAT(A)

C******************
C Reading the data:
	CALL READ_COORD(ALPHA,DELTA,XMAG,NSTAR)

C****************************
C Transforming the coordinates
C RAD: Radius of the cylinder:
	PRINT *,' RADIUS OF THE CYLINDER:'
	READ(5,*) RAD
	PRINT *,' ENTER DELTA_LIM: (DEGREES)'
	READ(5,*) DELTA_LIM
	DELTA_LIM=DELTA_LIM*PI/180.

C Possibility of symmetry:
	PRINT *,' SYMMETRY RELATIVE TO Y AXIS ?  (N)'
	READ(5,10) ANS

	IF((ANS.EQ.'Y').OR.(ANS.EQ.'y'))THEN
	   DO I=1,NSTAR
	     ALPHA(I)=2.*PI-ALPHA(I)
	   END DO
	ENDIF

C Changing the coordinates:
	CALL CHANGE_COORD(ALPHA,DELTA,XMAG,NSTAR,
     1	XX1,YY1,XMAG1,NSTAR1,XX2,YY2,XMAG2,NSTAR2,
     1	XX3,YY3,XMAG3,NSTAR3,RAD,DELTA_LIM)
C
	PRINT *,' NSTAR1, NSTAR2, NSTAR3',NSTAR1,NSTAR2,NSTAR3

C***********************
C Generating the curves:
	PRINT *,' LIMITING MAGNITUDE : (INTEGER < 7)'
	READ(5,*) NMAG

C Symbols: ('41' for NMAG)
	DO I=NMAG,1,-1
	  NCHAR(I)=SYMB(NMAG-I+1)
          PCOLOR(I)='Default'
	END DO

	PRINT *,' PLOT DEVICE ?'
	READ(5,10) PLOTDEV
	XLABEL=' '
	YLABEL=' '
	TITLE=' '

C First curves : cylinder
C Many pieces in X and Y : (otherwise, too small)
	NPARTSX=3
	NPARTSY=1
	PRINT *,' NUMBER OF PARTS IN X, AND Y ? (3,1)'
	READ(5,*) NPARTSX,NPARTSY

	HIGHT=2.*RAD*TAN(DELTA_LIM)
	XLENTH=2.*PI*RAD

	DO KY=1,NPARTSY

C Boundaries for the display:
	  YBOT=FLOAT(KY-1)*HIGHT/FLOAT(NPARTSY)-HIGHT/2.
	  YTOP=FLOAT(KY)*HIGHT/FLOAT(NPARTSY)-HIGHT/2

	  DO KX=1,NPARTSX

C Boundaries for the display:
	    XBOT=FLOAT(KX-1)*XLENTH/FLOAT(NPARTSX)
	    XTOP=FLOAT(KX)*XLENTH/FLOAT(NPARTSX)

	      NSTAR4=0

	      DO I=1,NSTAR1
	        IF((XX1(I).GE.XBOT).AND.(XX1(I).LE.XTOP)
     1	.AND.(YY1(I).GE.YBOT).AND.(YY1(I).LE.YTOP))THEN
	          NSTAR4=NSTAR4+1
	          XX4(NSTAR4)=XX1(I)
	          YY4(NSTAR4)=YY1(I)
	          XMAG4(NSTAR4)=XMAG1(I)
	        ENDIF
	      END DO

	    CALL GENE_CURVES(XX4,YY4,XMAG4,NSTAR4,XPLOT,YPLOT,
     1	IDIM,NMAG,NPTS)

	    PRINT *,' NPTS',(NPTS(J),J=1,NMAG)

C Output of the curve:
	    KCUR=NMAG
	    CALL NEWPLOT(XPLOT,YPLOT,NPTS,IDIM,KCUR,
     1	XLABEL,YLABEL,TITLE,NCHAR,PCOLOR,PLOTDEV,' ',' ')

	  END DO
	END DO

C*****************************
C Second curve : northern disc
	CALL GENE_CURVES(XX2,YY2,XMAG2,NSTAR2,XPLOT,YPLOT,
     1	IDIM,NMAG,NPTS)

	PRINT *,' NPTS',(NPTS(K),K=1,NMAG)

C Drawing a circle:
	KCUR=NMAG+1
	NPTS(KCUR)=MIN(200,IDIM)
	NCHAR(KCUR)='L   '
	DELTA_I=2*PI/FLOAT(NPTS(KCUR))
	DO I=1,NPTS(KCUR)
	  XPLOT(I,KCUR)=RAD*COS(I*DELTA_I)
	  YPLOT(I,KCUR)=RAD*SIN(I*DELTA_I)
	END DO

C Output of the second curve:
	CALL NEWPLOT(XPLOT,YPLOT,NPTS,IDIM,KCUR,
     1	XLABEL,YLABEL,TITLE,NCHAR,PLOTDEV,' ',' ')

C***************************
C Third curve : southern disc
	CALL GENE_CURVES(XX3,YY3,XMAG3,NSTAR3,XPLOT,YPLOT,
     1	IDIM,NMAG,NPTS)

	PRINT *,' NPTS',(NPTS(K),K=1,NMAG)

C Here, using the same circle as the second curve:
	KCUR=NMAG+1

C Output of the third curve:
	CALL NEWPLOT(XPLOT,YPLOT,NPTS,IDIM,KCUR,
     1	XLABEL,YLABEL,TITLE,NCHAR,PLOTDEV,' ',' ')

	END
C---------------------------------------------------------------
C Subroutine READ_COORD
C to read the coordinates from a direct access file:
C---------------------------------------------------------------
	SUBROUTINE READ_COORD(ALPHA,DELTA,XMAG,NSTAR)
	REAL*4 ALPHA(*),DELTA(*),XMAG(*)
	REAL*4 FSAO,ALPHAH,DELTAD
	INTEGER*2 NCT,IMV,IPG,ISP
	INTEGER*4 NSTAR
	CHARACTER*40 FILENAME
	DATA PI/3.14159/

10	FORMAT(A)

12	PRINT *,' Input file?'
	READ(5,10) FILENAME
	OPEN(1,FILE=FILENAME,STATUS='OLD',ACCESS='DIRECT',ERR=12)

C Reading the values:
C and conversion to radians
	PI12=PI/12.
	PI180=PI/180.

	DO I=1,30000
	  READ(1,REC=I,ERR=20) NCT,FSAO,ALPHAH,DELTAD,
     1	IMV,IPG,ISP
	  XMAG(I)=FLOAT(IMV)/100.
	  ALPHA(I)=PI12*ALPHAH
	  DELTA(I)=PI180*DELTAD
	END DO

C
	PRINT *,' The file has not been completly read'

20	NSTAR=I-1
	PRINT *,' ',NSTAR,' STARS'
	CLOSE(1)

	RETURN
	END
C---------------------------------------------------------------
C Subroutine GENE_CURVES
C
C Input:
C XX, YY
C XMAG
C NSTAR
C IDIM
C NMAG
C
C Output:
C XPLOT, YPLOT
C NPTS
C---------------------------------------------------------------
	SUBROUTINE GENE_CURVES(XX,YY,XMAG,NSTAR,XPLOT,YPLOT,
     1	IDIM,NMAG,NPTS)
	REAL*4 XX(*),YY(*),XMAG(*)
	REAL*4 XPLOT(IDIM,*),YPLOT(IDIM,*)
	INTEGER*4 NPTS(*)

C Erasing the counter:
	DO K=1,NMAG
	   NPTS(K)=0
	END DO

C Sorting the stars according to their magnitudes:
	DO I=1,NSTAR
	  K=MAX(INT(XMAG(I)),0)+1
	   IF(K.LE.NMAG)THEN
	     NPTS(K)=NPTS(K)+1
	     XPLOT(NPTS(K),K)=XX(I)
	     YPLOT(NPTS(K),K)=YY(I)
	   ENDIF
	END DO

	RETURN
	END
C-------------------------------------------------------------------
C Subroutine CHANGE_COORD
C Transforming the coordinates
C
C Warning: ALPHA and DELTA in radians !!!!!!!!!!!!!!!
C-------------------------------------------------------------------
	SUBROUTINE CHANGE_COORD(ALPHA,DELTA,XMAG,NSTAR,
     1	XX1,YY1,XMAG1,NSTAR1,XX2,YY2,XMAG2,NSTAR2,
     1	XX3,YY3,XMAG3,NSTAR3,RAD,DELTA_LIM)
	REAL*4 ALPHA(*),DELTA(*),XMAG(*)
	REAL*4 XX1(*),YY1(*),XMAG1(*),XX2(*),YY2(*),XMAG2(*)
	REAL*4 XX3(*),YY3(*),XMAG3(*)
	REAL*4 DELTA_LIM
	INTEGER*4 NSTAR,NSTAR1,NSTAR2

C RAD: Radius of the cylinder:
C RAD1: Radius of the sphere containing the bottom
C     and top edges of the cylinder
	RAD1=RAD/COS(DELTA_LIM)

C Erasing the counters:
	NSTAR1=0
	NSTAR2=0
	NSTAR3=0

C---------
C Main loop:

	DO I=1,NSTAR

C Under DELTA_LIM, simple projection on the equatorial plane:
C (Southern disc)
	  IF(DELTA(I).LT.-1.*DELTA_LIM)THEN
	    NSTAR3=NSTAR3+1
	    XX3(NSTAR3)= RAD1*COS(DELTA(I))*COS(ALPHA(I))
	    YY3(NSTAR3)= RAD1*COS(DELTA(I))*SIN(ALPHA(I))
	    XMAG3(NSTAR3)=XMAG(I)

C Over DELTA_LIM, simple projection on the equatorial plane:
C (Northern disc)
	  ELSEIF(DELTA(I).GT.DELTA_LIM)THEN
	    NSTAR2=NSTAR2+1
	    XX2(NSTAR2)= RAD1*COS(DELTA(I))*COS(ALPHA(I))
	    YY2(NSTAR2)= RAD1*COS(DELTA(I))*SIN(ALPHA(I))
	    XMAG2(NSTAR2)=XMAG(I)

C Else, cylindrical coordinates:
	  ELSE
	    NSTAR1=NSTAR1+1
	    XX1(NSTAR1)=RAD*ALPHA(I)
	    YY1(NSTAR1)=RAD*TAN(DELTA(I))
	    XMAG1(NSTAR1)=XMAG(I)
	  ENDIF

	END DO

	RETURN
	END


c     =====================================================
      subroutine qinit(meqn,mbc,mx,my,xlower,ylower,
     &     dx,dy,q,maux,aux)
c     =====================================================
c
c
      implicit double precision (a-h,o-z)
      dimension q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
      dimension aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc)
      common /cqinit/ A1,beta1,x1,y1, A2,beta2,x2,y2

      do i=1,mx
        xc = xlower + (i-0.5d0)*dx
        do j=1,my
            yc = ylower + (j-0.5d0)*dy
            call mapc2p(xc,yc,xp,yp)
            q(1,i,j) = A1*exp(-beta1*((xp - x1)**2 + (yp - y1)**2))
     &                  +A2*exp(-beta2*((xp - x2)**2 + (yp - y2)**2))
        enddo
      enddo

      return
      end


! { dg-do run }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
contains
  subroutine sub(a)
    optional :: a
    character(25) :: temp
    interface
      function a(x)
        real(kind=8):: a
        real(kind=8):: x
        intent(in) :: x
      end function a
    end interface
    if(present(a)) then
      write(temp,'(f16.10)')a(4.0d0)
      if (trim(temp) /= '   -0.6536436209') STOP 1
    endif
  end subroutine sub
end module m

use m
implicit none
intrinsic dcos
call sub()
call sub(dcos)
end


*DECK HSTPLR
      SUBROUTINE HSTPLR (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HSTPLR
C***PURPOSE  Solve the standard five-point finite difference
C            approximation on a staggered grid to the Helmholtz equation
C            in polar coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HSTPLR-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, POLAR
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C      HSTPLR solves the standard five-point finite difference
C      approximation on a staggered grid to the Helmholtz equation in
C      polar coordinates
C
C      (1/R)(d/DR)(R(dU/DR)) + (1/R**2)(d/dTHETA)(dU/dTHETA)
C
C                      + LAMBDA*U = F(R,THETA)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C    A,B
C      The range of R, i.e. A .LE. R .LE. B.  A must be less than B and
C      A must be non-negative.
C
C    M
C      The number of grid points in the interval (A,B).  The grid points
C      in the R-direction are given by R(I) = A + (I-0.5)DR for
C      I=1,2,...,M where DR =(B-A)/M.  M must be greater than 2.
C
C    MBDCND
C      Indicates the type of boundary conditions at R = A and R = B.
C
C      = 1  If the solution is specified at R = A and R = B.
C
C      = 2  If the solution is specified at R = A and the derivative
C           of the solution with respect to R is specified at R = B.
C           (see note 1 below)
C
C      = 3  If the derivative of the solution with respect to R is
C           specified at R = A (see note 2 below) and R = B.
C
C      = 4  If the derivative of the solution with respect to R is
C           specified at R = A (see note 2 below) and the solution is
C           specified at R = B.
C
C      = 5  If the solution is unspecified at R = A = 0 and the solution
C           is specified at R = B.
C
C      = 6  If the solution is unspecified at R = A = 0 and the
C           derivative of the solution with respect to R is specified at
C           R = B.
C
C      NOTE 1:  If A = 0, MBDCND = 2, and NBDCND = 0 or 3, the system of
C               equations to be solved is singular.  The unique solution
C               is determined by extrapolation to the specification of
C               U(0,THETA(1)).  But in this case the right side of the
C               system will be perturbed by the constant PERTRB.
C
C      NOTE 2:  If A = 0, do not use MBDCND = 3 or 4, but instead use
C               MBDCND = 1,2,5, or 6.
C
C    BDA
C      A one-dimensional array of length N that specifies the boundary
C      values (if any) of the solution at R = A.  When MBDCND = 1 or 2,
C
C               BDA(J) = U(A,THETA(J)) ,          J=1,2,...,N.
C
C      When MBDCND = 3 or 4,
C
C               BDA(J) = (d/dR)U(A,THETA(J)) ,    J=1,2,...,N.
C
C      When MBDCND = 5 or 6, BDA is a dummy variable.
C
C    BDB
C      A one-dimensional array of length N that specifies the boundary
C      values of the solution at R = B.  When MBDCND = 1,4, or 5,
C
C               BDB(J) = U(B,THETA(J)) ,          J=1,2,...,N.
C
C      When MBDCND = 2,3, or 6,
C
C               BDB(J) = (d/dR)U(B,THETA(J)) ,    J=1,2,...,N.
C
C    C,D
C      The range of THETA, i.e. C .LE. THETA .LE. D.  C must be less
C      than D.
C
C    N
C      The number of unknowns in the interval (C,D).  The unknowns in
C      the THETA-direction are given by THETA(J) = C + (J-0.5)DT,
C      J=1,2,...,N, where DT = (D-C)/N.  N must be greater than 2.
C
C    NBDCND
C      Indicates the type of boundary conditions at THETA = C
C      and THETA = D.
C
C      = 0  If the solution is periodic in THETA, i.e.
C           U(I,J) = U(I,N+J).
C
C      = 1  If the solution is specified at THETA = C and THETA = D
C           (see note below).
C
C      = 2  If the solution is specified at THETA = C and the derivative
C           of the solution with respect to THETA is specified at
C           THETA = D (see note below).
C
C      = 3  If the derivative of the solution with respect to THETA is
C           specified at THETA = C and THETA = D.
C
C      = 4  If the derivative of the solution with respect to THETA is
C           specified at THETA = C and the solution is specified at
C           THETA = d (see note below).
C
C      NOTE:  When NBDCND = 1, 2, or 4, do not use MBDCND = 5 or 6 (the
C      former indicates that the solution is specified at R =  0; the
C      latter indicates the solution is unspecified at R = 0).  Use
C      instead MBDCND = 1 or 2.
C
C    BDC
C      A one dimensional array of length M that specifies the boundary
C      values of the solution at THETA = C.   When NBDCND = 1 or 2,
C
C               BDC(I) = U(R(I),C) ,              I=1,2,...,M.
C
C      When NBDCND = 3 or 4,
C
C               BDC(I) = (d/dTHETA)U(R(I),C),     I=1,2,...,M.
C
C      When NBDCND = 0, BDC is a dummy variable.
C
C    BDD
C      A one-dimensional array of length M that specifies the boundary
C      values of the solution at THETA = D.  When NBDCND = 1 or 4,
C
C               BDD(I) = U(R(I),D) ,              I=1,2,...,M.
C
C      When NBDCND = 2 or 3,
C
C               BDD(I) = (d/dTHETA)U(R(I),D) ,    I=1,2,...,M.
C
C      When NBDCND = 0, BDD is a dummy variable.
C
C    ELMBDA
C      The constant LAMBDA in the Helmholtz equation.  If LAMBDA is
C      greater than 0, a solution may not exist.  However, HSTPLR will
C      attempt to find a solution.
C
C    F
C      A two-dimensional array that specifies the values of the right
C      side of the Helmholtz equation.  For I=1,2,...,M and J=1,2,...,N
C
C               F(I,J) = F(R(I),THETA(J)) .
C
C      F must be dimensioned at least M X N.
C
C    IDIMF
C      The row (or first) dimension of the array F as it appears in the
C      program calling HSTPLR.  This parameter is used to specify the
C      variable dimension of F.  IDIMF must be at least M.
C
C    W
C      A one-dimensional array that must be provided by the user for
C      work space.  W may require up to 13M + 4N + M*INT(log2(N))
C      locations.  The actual number of locations used is computed by
C      HSTPLR and is returned in the location W(1).
C
C
C             * * * * * *   On Output   * * * * * *
C
C    F
C      Contains the solution U(I,J) of the finite difference
C      approximation for the grid point (R(I),THETA(J)) for
C      I=1,2,...,M, J=1,2,...,N.
C
C    PERTRB
C      If a combination of periodic, derivative, or unspecified
C      boundary conditions is specified for a Poisson equation
C      (LAMBDA = 0), a solution may not exist.  PERTRB is a con-
C      stant, calculated and subtracted from F, which ensures
C      that a solution exists.  HSTPLR then computes this
C      solution, which is a least squares solution to the
C      original approximation.  This solution plus any constant is also
C      a solution; hence, the solution is not unique.  The value of
C      PERTRB should be small compared to the right side F.
C      Otherwise, a solution is obtained to an essentially different
C      problem.  This comparison should always be made to insure that
C      a meaningful solution has been obtained.
C
C    IERROR
C      An error flag that indicates invalid input parameters.
C      Except for numbers 0 and 11, a solution is not attempted.
C
C      =  0  No error
C
C      =  1  A .LT. 0
C
C      =  2  A .GE. B
C
C      =  3  MBDCND .LT. 1 or MBDCND .GT. 6
C
C      =  4  C .GE. D
C
C      =  5  N .LE. 2
C
C      =  6  NBDCND .LT. 0 or NBDCND .GT. 4
C
C      =  7  A = 0 and MBDCND = 3 or 4
C
C      =  8  A .GT. 0 and MBDCND .GE. 5
C
C      =  9  MBDCND .GE. 5 and NBDCND .NE. 0 or 3
C
C      = 10  IDIMF .LT. M
C
C      = 11  LAMBDA .GT. 0
C
C      = 12  M .LE. 2
C
C      Since this is the only means of indicating a possibly
C      incorrect call to HSTPLR, the user should test IERROR after
C      the call.
C
C    W
C      W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C     Arguments      W(see ARGUMENT LIST)
C
C     Latest         June 1, 1977
C     Revision
C
C     Subprograms    HSTPLR,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C     Required       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Written by Roland Sweet at NCAR in February, 1977
C
C     Algorithm      This subroutine defines the finite-difference
C                    equations, incorporates boundary data, adjusts the
C                    right side when the system is singular and calls
C                    either POISTG or GENBUN which solves the linear
C                    system of equations.
C
C     Space          8265(decimal) = 20111(octal) LOCATIONS ON THE
C     Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HSTPLR is roughly proportional
C                    to M*N*log2(N).  Some typical values are listed in
C                    the table below.
C                       The solution process employed results in a loss
C                    of no more than four significant digits for N and M
C                    as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine POISTG which is the routine that
C                    actually solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-6       1-4         56
C                        64       1-6       1-4        230
C
C     Portability    American National Standards Institute Fortran.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS
C     Resident
C     Routines
C
C     Reference      Schumann, U. and R. Sweet,'A Direct Method For
C                    The Solution Of Poisson's Equation With Neumann
C                    Boundary Conditions On A Staggered Grid of
C                    Arbitrary Size,' J. Comp. Phys. 20(1976),
C                    pp. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  U. Schumann and R. Sweet, A direct method for the
C                 solution of Poisson's equation with Neumann boundary
C                 conditions on a staggered grid of arbitrary size,
C                 Journal of Computational Physics 20, (1976),
C                 pp. 171-182.
C***ROUTINES CALLED  GENBUN, POISTG
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HSTPLR
C
C
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C***FIRST EXECUTABLE STATEMENT  HSTPLR
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9
      IF (IDIMF .LT. M) IERROR = 10
      IF (M .LE. 2) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/M
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/N
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
      ISW = 1
      MB = MBDCND
      IF (A.EQ.0. .AND. MBDCND.EQ.2) MB = 6
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      DO 101 I=1,M
         J = IWR+I
         W(J) = A+(I-0.5)*DELTAR
         W(I) = (A+(I-1)*DELTAR)/DLRSQ
         K = IWC+I
         W(K) = (A+I*DELTAR)/DLRSQ
         K = IWB+I
         W(K) = (ELMBDA-2./DLRSQ)*W(J)
  101 CONTINUE
      DO 103 I=1,M
         J = IWR+I
         A1 = W(J)
         DO 102 J=1,N
            F(I,J) = A1*F(I,J)
  102    CONTINUE
  103 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (104,104,106,106,108,108),MB
  104 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 105 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  105 CONTINUE
      GO TO 108
  106 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 107 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  107 CONTINUE
  108 GO TO (109,111,111,109,109,111),MB
  109 A1 = 2.*W(IWR)
      W(IWC) = W(IWC)-W(IWR)
      DO 110 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  110 CONTINUE
      GO TO 113
  111 A1 = DELTAR*W(IWR)
      W(IWC) = W(IWC)+W(IWR)
      DO 112 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  112 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  113 A1 = 2./DLTHSQ
      GO TO (123,114,114,116,116),NP
  114 DO 115 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)-A1*BDC(I)/W(J)
  115 CONTINUE
      GO TO 118
  116 A1 = 1./DELTHT
      DO 117 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)+A1*BDC(I)/W(J)
  117 CONTINUE
  118 A1 = 2./DLTHSQ
      GO TO (123,119,121,121,119),NP
  119 DO 120 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  120 CONTINUE
      GO TO 123
  121 A1 = 1./DELTHT
      DO 122 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  122 CONTINUE
  123 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 133,125,124
  124 IERROR = 11
      GO TO 133
  125 GO TO (133,133,126,133,133,126),MB
  126 GO TO (127,133,133,127,133),NP
  127 CONTINUE
      ISW = 2
      DO 129 J=1,N
         DO 128 I=1,M
            PERTRB = PERTRB+F(I,J)
  128    CONTINUE
  129 CONTINUE
      PERTRB = PERTRB/(M*N*0.5*(A+B))
      DO 131 I=1,M
         J = IWR+I
         A1 = PERTRB*W(J)
         DO 130 J=1,N
            F(I,J) = F(I,J)-A1
  130    CONTINUE
  131 CONTINUE
      A2 = 0.
      DO 132 J=1,N
         A2 = A2+F(1,J)
  132 CONTINUE
      A2 = A2/W(IWR+1)
  133 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  R(I)*DELTHT**2
C
      DO 135 I=1,M
         J = IWR+I
         A1 = DLTHSQ*W(J)
         W(I) = A1*W(I)
         J = IWC+I
         W(J) = A1*W(J)
         J = IWB+I
         W(J) = A1*W(J)
         DO 134 J=1,N
            F(I,J) = A1*F(I,J)
  134    CONTINUE
  135 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (LP .EQ. 0) GO TO 136
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 137
  136 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  137 CONTINUE
      W(1) = W(IWR+1)+3*M
      IF (A.NE.0. .OR. MBDCND.NE.2 .OR. ISW.NE.2) GO TO 141
      A1 = 0.
      DO 138 J=1,N
         A1 = A1+F(1,J)
  138 CONTINUE
      A1 = (A1-DLRSQ*A2/16.)/N
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C)
      A1 = BDA(1)-A1
      DO 140 I=1,M
         DO 139 J=1,N
            F(I,J) = F(I,J)+A1
  139    CONTINUE
  140 CONTINUE
  141 CONTINUE
      RETURN
      END