program unformatted_write
    use, intrinsic :: iso_fortran_env, only : error_unit, DP => REAL64
    implicit none
    real(kind=DP), parameter :: PI = acos(-1.0_DP), &
                                PHI = 0.5_DP*(1.0_DP + sqrt(5.0_DP)), &
                                B_REC = 0.5_DP*PI/log(PHI), &
                                DELTA_R = 1.0e-3_DP
    integer :: nr_values, i, unit_nr, istat
    character(len=1024) :: file_name, msg
    real(kind=DP) :: r

    call get_arguments(nr_values, file_name)
    open (newunit=unit_nr, file=file_name, form='unformatted', &
          access='sequential', action='write', status='new', iostat=istat, &
          iomsg=msg)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
        stop 3
    end if
    r = 1.0_DP
    do i = 1, nr_values
        write (unit=unit_nr, iostat=istat, iomsg=msg) &
            r, golden_spiral(r)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
        end if
        r = r + DELTA_R
    end do
    close(unit=unit_nr)

contains

    subroutine get_arguments(nr_values, file_name)
        implicit none
        integer, intent(out) :: nr_values
        character(len=*), intent(out) :: file_name
        character(len=128) :: buffer, msg
        integer :: istat

        if (command_argument_count() /= 2) then
            write (unit=error_unit, fmt='(A)') &
                'error: expecting number of values and file name as arguments'
            stop 1
        end if

        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iomsg=msg, iostat=istat) nr_values
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
            stop 2
        end if
        call get_command_argument(2, file_name)
    end subroutine get_arguments

    function golden_spiral(r) result(theta)
        implicit none
        real(kind=DP), value :: r
        real(kind=DP) :: theta
        theta = B_REC*log(r)
    end function golden_spiral

end program unformatted_write


    MODULE cdf_beta_mod
! ----------------------------------------------------------------------

!                               cdf_beta_mod
!                               *=*=*=*=*=*=

!  -  SUBROUTINE CDF_BETA(WHICH, CUM, CCUM, X, CX, A, B, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_BETA(X, A, B, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_BETA(X, A, B, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_BETA(CUM, CCUM, A, B, STATUS, CHECK_INPUT)

!                             The Distribution
!                             ================

!    The density of the beta distribution is defined on x in [0,1] and is
!    proportional to:

!                                 a      b
!                                x  (1-x)

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    four arguments is to be calculated.
!  Input Range: [ 1:4 ]
!     1.  CUM and CCUM
!     2.  X and CX
!     3.  A
!     4.  B
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the beta distribution.
!  Range: [ 0:1 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the beta
!    distribution.
!  Range: [ 0:1 ]
!  - REAL (dpkind), OPTIONAL :: X. The upper limit of integration of the
!    beta density. The lower limit is 0.
!  Range: [ 0:1 ]
!  - REAL (dpkind), OPTIONAL :: CX. One minus the upper limit of
!    integration of the beta density. The lower limit is 0.
!  Range: [ 0:1 ]
!  - REAL (dpkind) :: A. The first parameter of the beta density.
!  Range: [ 10^-10:10^10 ]
!  - REAL (dpkind) :: B. The second parameter of the beta density.
!  Range: [ 10^-10:10^10 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code.  Possible values:
!      0 problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 X outside range
!     -5 CX outside range
!     -6 A outside range
!     -7 B outside range
!      3 CUM + CCUM is not nearly one
!      4 X + CX is not nearly one
!    -50 Answer (if any) is BELOW the LOWER search bound
!     50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.

!  NOTE: CUM and CCUM and also X and CX must add to (nearly) one.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_beta, cdf_beta, cum_beta, inv_beta
! ..
    CONTAINS

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

      FUNCTION ccum_beta(x,cx,a,b,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_beta
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: a, b
        REAL (dpkind), OPTIONAL, INTENT (IN) :: cx, x
        INTEGER, INTENT (OUT) :: status
        LOGICAL, INTENT (IN) :: check_input
! ..
        CALL cdf_beta(which=1,ccum=ccum_beta,x=x,cx=cx,a=a,b=b, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_beta

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

      SUBROUTINE cdf_beta(which,cum,ccum,x,cx,a,b,status,check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind) :: a, b
        REAL (dpkind), OPTIONAL :: ccum, cum, cx, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
! .. Local Arrays
        TYPE (zf_locals) :: local
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, local_cx, local_x, &
          try_ccum, try_cum
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
        has_status = PRESENT(status)

! status = 0 means no error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_beta%name,'cum','ccum', &
          local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        CALL check_complements(x,cx,the_beta%name,'x','cx',local_x, &
          local_cx,set_values=(which/=2),bad_status=4,status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = local_x
        params(4) = local_cx
        params(5) = a
        params(6) = b

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

! ++++++++++          ++++++++++          ++++++++++
! Range check arguments and see that they add to one
! ++++++++++          ++++++++++          ++++++++++

        IF (local_check_input) THEN
! Assure that x + cx nearly one

          IF (which/=2) THEN
            IF ( .NOT. add_to_one(local_x,local_cx,the_beta%name,'x','cx' &
              ,4,status)) RETURN
          END IF

          CALL validate_parameters(the_beta,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF

        END IF

!++++++++++++++++++++++++++++++++++++++++++++++++++
! Compute the Answers
!++++++++++++++++++++++++++++++++++++++++++++++++++

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)

        CASE (1)
! Calculate cum and ccum

          CALL local_cum_beta(local_x,local_cx,a,b,local_cum,local_ccum)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

          RETURN

        CASE (2)
! Calculate x and cx

          local_x = half
          zf_status = 0

          CALL cdf_set_zero_finder(the_beta,3,local)

          IF (match_cum) THEN
            DO
              CALL rc_interval_zf(zf_status,local_x,fx,local)

              IF (zf_status/=1) EXIT

              local_cx = one - local_x

              CALL local_cum_beta(local_x,local_cx,a,b,try_cum,try_ccum)

              fx = try_cum - cum
            END DO

          ELSE
            DO
              CALL rc_interval_zf(zf_status,local_cx,fx,local)

              IF (zf_status/=1) EXIT

              local_x = one - local_cx

              CALL local_cum_beta(local_x,local_cx,a,b,try_cum,try_ccum)

              fx = try_ccum - ccum
            END DO
          END IF

          IF (PRESENT(x)) x = local_x
          IF (PRESENT(cx)) cx = local_cx

        CASE (3)
! Calculate a

          a = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_beta,5,local)

          DO
            CALL rc_step_zf(zf_status,a,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_beta(local_x,local_cx,a,b,try_cum,try_ccum)

            IF (match_cum) THEN
              fx = try_cum - cum
            ELSE
              fx = try_ccum - ccum
            END IF
          END DO

        CASE (4)
! Calculate b

          b = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_beta,6,local)

          DO
            CALL rc_step_zf(zf_status,b,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_beta(local_x,local_cx,a,b,try_cum,try_ccum)

            IF (match_cum) THEN
              fx = try_cum - cum
            ELSE
              fx = try_ccum - ccum
            END IF
          END DO

        END SELECT

        IF (has_status) THEN
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_beta

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

      FUNCTION cum_beta(x,cx,a,b,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_beta
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: a, b
        REAL (dpkind), OPTIONAL, INTENT (IN) :: cx, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_beta(which=1,cum=cum_beta,x=x,cx=cx,a=a,b=b, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_beta

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

      FUNCTION inv_beta(cum,ccum,a,b,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_beta
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: a, b
        REAL (dpkind), OPTIONAL, INTENT (IN) :: ccum, cum
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_beta(which=2,cum=cum,ccum=ccum,x=inv_beta,a=a,b=b, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_beta

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

      SUBROUTINE local_cum_beta(x,y,a,b,cum,ccum)
!----------------------------------------------------------------------
!          Double precision cUMulative incomplete BETa distribution

!                              Function

!     Calculates the cdf to X of the incomplete beta distribution
!     with parameters a and b.  This is the integral from 0 to x
!     of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)

!                              Arguments

!     X --> Upper limit of integration.
!     Y --> 1 - X.
!     A --> First parameter of the beta distribution.
!     B --> Second parameter of the beta distribution.
!     CUM <-- Cumulative incomplete beta distribution.
!     CCUM <-- Compliment of Cumulative incomplete beta distribution.

!                              Method

!     Cumulative distribution function  (CUM)  is calculated directly by
!     code associated with the following reference.
!     DiDinato, A. R. and Morris,  A.   H.  Algorithm 708: Significant
!     Digit Computation of the Incomplete  Beta  Function Ratios.  ACM
!     Trans. Math.  Softw. 18 (1993), 360-373.
!     Computation of other parameters involve a seach for a value that
!     produces  the desired  value  of CUM.   The search relies  on  the
!     monotinicity of CUM with the other parameter.
!----------------------------------------------------------------------
! .. Use Statements ..
        USE biomath_mathlib_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: a, b, x, y
        REAL (dpkind), INTENT (OUT) :: ccum, cum
! ..
! .. Local Scalars ..
        INTEGER :: ierr
! ..
        IF (x<=zero) THEN
          cum = zero
          ccum = one
          RETURN
        END IF

        IF (y<=zero) THEN
          cum = one
          ccum = zero
          RETURN
        END IF

! Because of the bounds on a, b, x, y
! ierr can not be <> 0

        CALL bratio(a,b,x,y,cum,ccum,ierr)

        RETURN

      END SUBROUTINE local_cum_beta

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

    END MODULE cdf_beta_mod


	SUBROUTINE TI_DAYW  ( idtarr, idayw, iret )
C************************************************************************
C* TI_DAYW								*
C*									*
C* This subroutine returns the day of the week, IDAYW, given an integer	*
C* time.  IDAYW is set to 1 for Sunday, 2 for Monday, 3 for Tuesday,	*
C* 4 for Wednesday, 5 for Thursday, 6 for Friday, and 7 for Saturday.	*
C*									*
C* This subroutine does not check that a valid time was entered.  The 	*
C* year must be a full four-digit year.					*
C*									*
C* TI_DAYW  ( IDTARR, IDAYW, IRET )					*
C*									*
C* Input parameters:							*
C*	IDTARR (5)	INTEGER		Time array (YYYY,MM,DD,HH,MM)	*
C*									*
C* Output parameters:							*
C*	IDAYW		INTEGER		Day of week (1 - Sun,...)	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/87	Adapted from DAYOFWEEK in TRAFIC	*
C* M. desJardins/GSFC	 9/88	Add 1900 to YY				*
C* I. Durham/GSC	 9/98   Added March leap year correction	*
C* I. Durham/GSC	 9/98	Rewrote using new computation		*
C* S. Jacobs/NCEP	11/99	Simplified calculation			*
C************************************************************************
	INTEGER		idtarr (*)
C*
	INTEGER		jdtarr (5)
C------------------------------------------------------------------------
	iret = 0
C
C*	Get the number of days for the first of the given month.
C
	DO  i = 1, 5
	    jdtarr (i) = idtarr (i)
	END DO
	jdtarr (3) = 1
	CALL TI_ITOJ ( jdtarr, jyear, jday, ier )
C
C*	Compute the offset for this month.
C
	ioff  = MOD ( jday-1, 7 )
C
C*	Compute the day of the week.
C
	iy    = idtarr (1)
	id    = idtarr (3)
	idayw = MOD ( ( iy + (iy-1)/4 - (iy-1)/100 + (iy-1)/400 +
     +		        ioff + (id-1) ), 7 ) + 1
C
	RETURN
	END


      SUBROUTINE slVN (V, UV, VM)
*+
*     - - -
*      V N
*     - - -
*
*  Normalizes a 3-vector also giving the modulus (single precision)
*
*  Given:
*     V       real(3)      vector
*
*  Returned:
*     UV      real(3)      unit vector in direction of V
*     VM      real         modulus of V
*
*  If the modulus of V is zero, UV is set to zero as well
*
*  P.T.Wallace   Starlink   23 November 1995
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL V(3),UV(3),VM

      INTEGER I
      REAL W1,W2

*  Modulus
      W1=0.0
      DO I=1,3
         W2=V(I)
         W1=W1+W2*W2
      END DO
      W1=SQRT(W1)
      VM=W1

*  Normalize the vector
      IF (W1.LE.0.0) W1=1.0
      DO I=1,3
         UV(I)=V(I)/W1
      END DO

      END


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
c
c tweaked Alex Barnett to call FINUFFT 2/17/17
c dyn malloc; type 2 uses same input data fk0, 3/8/17
c Single-prec version 4/5/17
c
c Compile with (multithreaded version):
c gfortran nufft1d_demof.f dirft1df.f -o nufft1d_demof ../lib/libfinufft.a
c          -lstdc++ -lfftw3f -lfftw3f_threads -lm -fopenmp
c
      program nufft1d_demof
      implicit none
c
c --- local variables
c
      integer i,ier,iflag,j,k1,mx,ms,nj
      real*4, allocatable :: xj(:),sk(:)
      real*4 err,eps,pi
      parameter (pi=3.141592653589793238462643383279502884197e0)
      complex*8, allocatable :: cj(:),cj0(:),cj1(:),fk0(:),fk1(:)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
      ms = 90
      nj = 128
c     first alloc everything
      allocate(fk0(ms))
      allocate(fk1(ms))
      allocate(sk(ms))
      allocate(xj(nj))
      allocate(cj(nj))
      allocate(cj0(nj))
      allocate(cj1(nj))
      do k1 = -nj/2, (nj-1)/2
         j = k1+nj/2+1
         xj(j) = pi * cos(-pi*j/nj)
         cj(j) = cmplx( sin(pi*j/nj), cos(pi*j/nj))
      enddo
c
c     --------------------------------------------------
c     start tests
c     --------------------------------------------------
c
      iflag = 1
      print*,' Start 1D testing: ', ' nj =',nj, ' ms =',ms
      do i = 1,3
         if (i.eq.1) eps=1e-2
         if (i.eq.2) eps=1e-4
         if (i.eq.3) eps=1e-6
	 print*,' '
  	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 1D Type1 method
c     -----------------------
c
         call dirft1d1f(nj,xj,cj,iflag, ms,fk0)
         call finufft1d1_f(nj,xj,cj,iflag,eps, ms,fk1,ier)
         call errcomp(fk0,fk1,ms,err)
         print *,' ier = ',ier
         print *,' type 1 error = ',err
c
c     -----------------------
c     call 1D Type2 method
c     -----------------------
c
         call dirft1d2f(nj,xj,cj0,iflag, ms,fk0,ier)
         call finufft1d2_f(nj,xj,cj1,iflag, eps, ms,fk0,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 2 error = ',err
c
c     -----------------------
c     call 1D Type3 method
c     -----------------------
         do k1 = 1, ms
            sk(k1) = 48*cos(k1*pi/ms)
         enddo
         call dirft1d3f(nj,xj,cj,iflag, ms,sk,fk0)
         call finufft1d3_f(nj,xj,cj,iflag,eps, ms,sk,fk1,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*8 fk0(n), fk1(n)
      real *4 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cabs(fk1(k)-fk0(k))**2
         salg = salg + cabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


      real function crit(z,q)
c
c     + + + PURPOSE + + +
c
c     Function CRIT computes the critical flow depth.
c
c     Called from: SRS FRICHN, FSLPAR
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real z, q
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     z -
c     q -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cchcon.inc'
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      crit = (2.0*beta*q**2/(agrav*z**2)) ** 0.2
c
      return
      end


      program  main
      implicit none
!     include 'omp_lib.h'

      integer i, sum1;
      sum1 = 0
!$omp parallel do reduction(+:sum1)
      do i = 1, 100
        sum1 = sum1 + i
      enddo
      print *, "sum of 1 to 100 is:", sum1

      end


function YilmIndexVector(i, l, m)
!-------------------------------------------------------------------------------
!
!   This function will give the index in a 1-dimensional array of the spherical
!   harmonic coefficient corresponding to the element Cilm. The elements of the
!   1D vector array are packed according to (where positive m corresponds
!   to i=1 (the cosine coefficients), and negative m corresponds to i=1
!   (the sine coefficients))
!
!   0,0
!   1, 0; 1, 1; 1, -1
!   2,0 ; 2, 1; 2, 2; 2, -1; 2, -2
!
!   This mapping is given by the function:
!
!       YilmIndex = l**2 + (i-1)*l + m + 1
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer(int32) :: YilmIndexVector
    integer(int32), intent(in) :: i, l, m

    if (i /= 1 .and. i /= 2) then
        print*, "Error --- YilmIndexVector"
        print*, "I must be 1 (for cosine terms) or 2 (for sine terms)."
        print*, "I = ", i
        stop

    end if

    if (l < 0) then
        print*, "Error --- YilmIndexVector"
        print*, "L must be positive."
        print*, "L = ", l
        stop

    end if

    if (m < 0 .or. m > l) then
        print*, "Error --- YilmIndexVector"
        print*, "M must be positive and less than L."
        print*, "M = ", m
        print*, "L = ", l
        stop

    end if

    if (m == 0 .and. i == 2) then
        print*, "Error --- YilmIndexVector"
        print*, "When M = 0, I must be 1."
        print*, "I = ", i
        print*, "M = ", m
        stop

    end if

    yilmindexvector = l**2 + (i-1)*l + m + 1

end function YilmIndexVector


subroutine mbvab1(a,b,c,n1,n2,en1,en2)

!-----------------------------------------------------------------------
!
! This routine evaluates the matrix-vector product A = B C, where
! A -> R(n1), B -> Mat(n1,n2), C -> R(n2), and also computes  the
! Euclidian norms of A and C
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: n1,n2
  real(rp),    intent(in)  :: b(n1,n2), c(n2)
  real(rp),    intent(out) :: a(n1),en1,en2
  integer(ip)              :: i,k

  do i=1,n1
     a(i)=0.0_rp
     do k=1,n2
        a(i)=a(i)+b(i,k)*c(k)
     end do
  end do

  en1=0.0_rp
  en2=0.0_rp
  do i=1,n1
     en1=en1+a(i)*a(i)
  end do
  do i=1,n2
     en2=en2+c(i)*c(i)
  end do
  en1=sqrt(en1)
  en2=sqrt(en2)

end subroutine mbvab1


module fmg_cycle_mod

contains

    recursive subroutine fmg_cycle(ct,lvl)

        use constants
        use traverse_mod
        use cycle_tower_mod
        use v_cycle_mod

        implicit none

        integer, intent(in) :: lvl
        type(cycle_tower), intent(inout) :: ct

        integer :: i

        ! Always start with initial guess of zero for the solution
        call setval(ct%uu(lvl),0.d0,all=.true.)

        call print_cycle_tower(ct,lvl,'Down FMG-cycle: ')

        if (lvl == 1) then

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,'Before relaxation: ')
            end if

            if (ct%verbose >= 2) then
                write(*,'(a,i3,a)') '    FMG-Cycle BOTTOM -- Applying ',ct%fmg_bot,' relaxations.'
            end if

            ! Just smooth a bunch of times at the bottom; can choose a different solver
            do i = 1,ct%fmg_bot
                call gsrb(ct%uu(lvl),ct%ff(lvl),ct%bb(lvl,:),ct%dx(lvl))
            end do

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,' After relaxation: ')
            end if

        else

            ! Coarsen and continue downwards
            call restriction(ct%ff(lvl-1),ct%res(lvl))
            call fmg_cycle(ct,lvl-1)

            ! Interpolate solution
            call prolongation(ct%uu(lvl),ct%uu(lvl-1),ct%interp_type)

            ! Apply entire V-cycle on the way up
            if (ct%verbose == 1) then
                ct%verbose = ct%verbose - 1
                call v_cycle(ct,lvl,lvl)
                ct%verbose = ct%verbose + 1
            else
                call v_cycle(ct,lvl,lvl)
            end if

        end if

        ! If at the top, correct solution by adding the error that we've just solved for
        if (lvl == ct%nlvl) then
            call plus_plus(ct%sol,ct%uu(lvl))
            call multifab_fill_boundary(ct%sol)
        end if

    end subroutine fmg_cycle

end module fmg_cycle_mod


# accumulate (sum) all the elements of a list

__accum([], acc): acc.
__accum(h <~ [t], acc):
    __accum(t, acc + h).

accum(a):
    __accum(a, 0).

# accumulate (sum) the first n elements of a list
__accumn(_, acc, 0):
      acc.
__accumn(h <~ [t], acc, n):
    __accumn(t, acc + h, n - 1).

accumn(a,n):
     __accumn(a, 0, n).


 module KS
   implicit none
   save
   integer,          parameter :: Nx = 131072
   integer,	     parameter :: Nruns = 8
   double precision, parameter :: dt = 1d0/16d0
   double precision, parameter :: T  = 200d0
   double precision, parameter :: pi = 3.14159265358979323846d0
   double precision, parameter :: Lx = (pi/16d0)*Nx
   logical,          parameter :: printnorms = .true.
 end module KS

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
double precision function ksnorm(u,Nx)
    double complex, intent(in) :: u(0:Nx-1)
    double precision :: s
    integer n;

    s = 0.0d0;
    do n = 0, Nx-1
       s = s + (abs(u(n)))**2
    end do
    mynorm = sqrt(s/Nx)
 end function ksnorm

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 program main
   use KS
   implicit none
   integer :: i,Nt,r, skip=1
   real :: tstart, tend, avgtime
   double precision :: u0norm
   double precision :: uTnorm
   double precision :: x(0:Nx-1)
   double complex   :: u0(0:Nx-1)
   double complex   :: u(0:Nx-1)
   double precision :: s

   !allocate(x(0:Nx-1))
   !allocate(u(0:Nx-1))

   Nt = floor(T/dt)
   x = Lx * (/(i,i=0,Nx-1)/) / dble(Nx)
   u0 = cos(x) + 0.1d0*sin(x/8d0) + 0.01d0*cos((2*pi/Lx)*x)

   s = 0.0d0
   do i = 0, Nx-1
       s = s + (abs(u0(i)))**2
   end do
   u0norm = sqrt(s/Nx)

   avgtime = 0.
   do r = 1, Nruns
      u = u0
      call cpu_time(tstart)
      call ksintegrate(Nt, u)
      call cpu_time(tend)
      print*, 'cputime = ', tend-tstart
      if(r>skip)  avgtime = avgtime + tend-tstart
   end do
   avgtime = avgtime/(Nruns-skip)

   s = 0.0d0
   do i = 0, Nx-1
       s = s + (abs(u(i)))**2
   end do
   uTnorm = sqrt(s/Nx)

   if (printnorms) then
      print*, 'norm(u(0)) = ', u0norm
      print*, 'norm(u(T)) = ', uTnorm
   end if

   print*, 'avgtime (seconds) = ', avgtime

   open(10, status='unknown', file='u.dat')
   write(10,'(3e20.12)') (x(i),u(i), i=0,Nx-1)
   close(10)

 end program main

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 subroutine ksintegrate(Nt, u)
   use KS
   implicit none
   integer,          intent(in)    :: Nt
   double complex,   intent(inout) :: u(0:Nx-1)
   double precision :: dt2, dt32, Nx_inv
   double precision :: A_inv(0:Nx-1), B(0:Nx-1), L(0:Nx-1), kx(0:Nx-1)
   double complex   :: alpha(0:Nx-1), G(0:Nx-1), Nn(0:Nx-1), Nn1(0:Nx-1)
   double complex, save :: u_(0:Nx-1), uu(0:Nx-1)
   double complex, save :: us(0:Nx-1), uus(0:Nx-1)
   logical, save :: planned=.false.
   integer*8, save :: plan_u2us, plan_us2u, plan_uu2uus
   integer :: n, fftw_patient=32, fftw_estimate=64, fftw_forward=-1, fftw_backward=1

   if(.not.planned) then
      call dfftw_plan_dft_1d(plan_u2us, Nx, u_, us, fftw_forward, fftw_estimate)
      call dfftw_plan_dft_1d(plan_us2u, Nx, us, u_, fftw_backward, fftw_estimate)
      call dfftw_plan_dft_1d(plan_uu2uus, Nx, uu, uus, fftw_forward, fftw_estimate)
      planned = .true.
   end if

   do n = 0, Nx/2-1
      kx(n) = n
   end do
   kx(Nx/2) = 0d0
   do n = Nx/2+1, Nx-1
      kx(n) = -Nx + n;
   end do
   alpha = (2d0*pi/Lx)*kx
   L = alpha**2 - alpha**4
   G = -0.5d0*dcmplx(0d0,1d0)*alpha

   Nx_inv = 1d0/Nx
   dt2  = dt/2d0
   dt32 = 3d0*dt/2d0
   A_inv = 1d0/(1d0 - dt2*L)
   B     = 1d0 + dt2*L

   uu = u*u
   call dfftw_execute(plan_uu2uus)
   Nn  = G*uus
   Nn1 = Nn

   u_ = u
   call dfftw_execute(plan_u2us)

   do n = 1, Nt
      Nn1 = Nn
      call dfftw_execute(plan_us2u)
      u_ = u_ * Nx_inv
      uu = u_*u_
      call dfftw_execute(plan_uu2uus)
      Nn = G*uus
      us = A_inv * (B*us + dt32*Nn - dt2*Nn1)
      !us = A_inv * (B*us)
   end do

   call dfftw_execute(plan_us2u)
   u = u_ * Nx_inv

 end subroutine ksintegrate


program test4

  use multigrid

  implicit none

  integer, parameter :: num=selected_real_kind(p=15)
  real(num) :: pi = 4.0_num * ATAN(1.0_num)
  real(num) :: pi2 = 8.0_num * ATAN(1.0_num)

  integer :: nx, ny, ix, iy

  real(num) :: x,y,  dx, dy, L2, x_min, x_max, y_min, y_max

  real(num), dimension(:), allocatable :: xc, yc
  real(num), dimension(:,:), allocatable :: f,analytic, phi, eta
  real(num), dimension(:), allocatable :: L2_arr, n_arr

  integer :: power, power_min, power_max

  type(mg_input) :: input

  ! setup a test problem

  print *,'Test4: True test of D(eta G(phi)) = f , where eta is spatially varying'

  power_min = 3
  power_max = 10

  allocate(L2_arr(1:1+power_max-power_min))
  allocate(n_arr(1:1+power_max-power_min))
  L2_arr = 1e6_num
  n_arr = 0

  different_resolutions: do power= power_min, power_max

    nx = 2**power
    ny = nx
    x_min = 0.0_num
    x_max = 1.0_num
    y_min = x_min
    y_max = x_max

    allocate(xc(-1:nx+2))
    allocate(yc(-1:ny+2))

    dx = (x_max - x_min) / real(nx,num)
    xc(-1) = x_min - 3.0_num * dx / 2.0_num
    do ix = 0,nx+2
      xc(ix) = xc(ix-1) + dx
    enddo

    dy = (y_max - y_min) / real(ny,num)
    yc(-1) = y_min - 3.0_num * dy / 2.0_num
    do iy = 0,ny+2
      yc(iy) = yc(iy-1) + dy
    enddo

    allocate(phi(-1:nx+2,-1:ny+2)) ! again, redundant ghosts but for comparison to CCAPS
    phi = 0.0_num

    allocate(analytic(1:nx,1:ny)) ! again, redundant ghosts but for comparison to CCAPS
    analytic = 0.0_num

    allocate(f(1:nx,1:ny))

    do iy = 1, ny
    do ix = 1, nx
      x = xc(ix)
      y = yc(iy)
      f(ix,iy) = -16.0_num * pi**2 * (cos(pi2*x)*cos(pi2*y) +1.0_num) * sin(pi2*x) * sin(pi2*y)
!      f(ix,iy) = -4.0_num * pi**2 * ( 4.0_num * sin(pi2 * x) * sin(pi2 * y) + sin(2.0_num * pi2 *x) * sin(2.0_num * pi2 *y))
    enddo
    enddo

    allocate(eta(1:nx,1:ny)) ! again, redundant ghosts but for comparison to CCAPS
    do iy = 1, ny
    do ix = 1, nx
     eta(ix,iy) = 2.0_num + cos(2.0_num * pi * xc(ix)) * cos(2.0_num * pi * yc(iy))
    enddo
    enddo
    ! solve for phi

  input = mg_input(tol = 1e-12_num, nx=nx, ny = ny, dx=dx, dy=dy, f = f, phi = phi, &
            & bc_xmin = 'periodic', bc_ymin='periodic', bc_xmax='periodic', bc_ymax = 'periodic', &
            & deallocate_after = .true., &
            & eta = eta, eta_present = .true., &
            & eta_bc_xmin = 'periodic', eta_bc_ymin='periodic', eta_bc_xmax='periodic', eta_bc_ymax = 'periodic')

  call mg_interface(input)

  phi = input%phi

    ! test against analytical solution

    do iy = 1, ny
    do ix = 1, nx
      x = xc(ix)
      y = yc(iy)
      analytic(ix,iy) = sin(pi2*x)*sin(pi2*y)
    enddo
    enddo

    ! subtract the average of phi since there is nothing to anchor the solution
    phi = phi- sum(phi(1:nx,1:ny)) / real(nx*ny,num)

    L2 = sqrt(sum(abs(analytic(1:nx,1:ny)-phi(1:nx,1:ny))**2) / real(nx*ny,num))

    print *,'L2',L2

    L2_arr(power-power_min+1) = L2
    n_arr(power-power_min+1) = real(nx,num)

    ! deallocate all so can do again

    deallocate(xc)
    deallocate(yc)
    deallocate(f)
    deallocate(phi)
    deallocate(analytic)
    deallocate(eta)

  enddo different_resolutions

  print *, 'L2 _arr',L2_arr
  print *, 'n _arr',n_arr

  call execute_command_line("rm -rf test4_l2.dat")
  call execute_command_line("rm -rf test4_nx.dat")

  open(10, file="test4_l2.dat", access="stream")
  write(10) L2_arr
  close(10)

  open(10, file="test4_nx.dat", access="stream")
  write(10) n_arr
  close(10)

  call execute_command_line("python test4_plots.py")
  call execute_command_line("rm test4_l2.dat")
  call execute_command_line("rm test4_nx.dat")

end program test4


!! BSD 3-Clause License
!
! Copyright (c) 2021, Fabio Durastante, Lidia Aceto
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
program optimalxitest
  ! This test program uses Brent's method to compute the value of the optimal
  ! :math:`\xi`, and thus :math:`N`, for the computation of the Wright function.

  use iso_fortran_env, only: real32, real64, real128, output_unit
  use brentmod, only: fminbnd
  implicit none

  real(real64) :: c,N
  real(real64) :: mu = 3

  write(output_unit,'("Optimal c/N Test")')

  N = fminbnd(0.1_real64, 0.99_real64, 0.5_real64, 200.0_real64, &
    & epsilon(c), epsilon(c), 1.0D-3, fobjective, c)

  write(output_unit,'("c = ",F20.16," N = ",I3)')c,floor(N)

contains

  function fobjective(carg) result(f)
    use iso_fortran_env, only: real64
    implicit none

    real(real64) :: carg
    real(real64) :: f
    ! Constants and local variables
    real(real64) :: pi = 3.141592653589793
    real(real64) :: l,ltol

    l    = - log(epsilon(c))
    ltol = - log(1.0E-15)

    f = (sqrt(l*ltol)/pi)* &
          & sqrt(1.0_real64 + (1.0_real64/carg)*(1.0_real64 + ((2.0_real64 - mu)/ltol) &
          & *log(1.0_real64-carg)))

    write(output_unit,'("f = ",F20.16," c = ",F20.16)')f,carg

  end function fobjective

end program optimalxitest


module boundary_condition_m

    implicit none

    type bc_t

        character :: type ! N for Neumann, D for Dirichlet
        real(kind=8) :: a, b, c ! Boundary condition formulated as a+b*x+c*x^2

    end type bc_t

contains

real(kind=8) function bc_get_value(t, x)
    type(bc_t), intent(in) :: t
    real(kind=8), intent(in) :: x

    bc_get_value = t%a+t%b*x+t%c*x**2

end function bc_get_value

end module boundary_condition_m


*DECK DBESJ0
      DOUBLE PRECISION FUNCTION DBESJ0 (X)
C***BEGIN PROLOGUE  DBESJ0
C***PURPOSE  Compute the Bessel function of the first kind of order
C            zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      DOUBLE PRECISION (BESJ0-S, DBESJ0-D)
C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESJ0(X) calculates the double precision Bessel function of
C the first kind of order zero for double precision argument X.
C
C Series for BJ0        on the interval  0.          to  1.60000E+01
C                                        with weighted error   4.39E-32
C                                         log weighted error  31.36
C                               significant figures required  31.21
C                                    decimal places required  32.00
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9B0MP, DCSEVL, INITDS
C***REVISION HISTORY  (YYMMDD)
C   770701  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***END PROLOGUE  DBESJ0
      DOUBLE PRECISION X, BJ0CS(19), AMPL, THETA, XSML, Y, D1MACH,
     1  DCSEVL
      LOGICAL FIRST
      SAVE BJ0CS, NTJ0, XSML, FIRST
      DATA BJ0CS(  1) / +.1002541619 6893913701 0731272640 74 D+0     /
      DATA BJ0CS(  2) / -.6652230077 6440513177 6787578311 24 D+0     /
      DATA BJ0CS(  3) / +.2489837034 9828131370 4604687266 80 D+0     /
      DATA BJ0CS(  4) / -.3325272317 0035769653 8843415038 54 D-1     /
      DATA BJ0CS(  5) / +.2311417930 4694015462 9049241177 29 D-2     /
      DATA BJ0CS(  6) / -.9911277419 9508092339 0485193365 49 D-4     /
      DATA BJ0CS(  7) / +.2891670864 3998808884 7339037470 78 D-5     /
      DATA BJ0CS(  8) / -.6121085866 3032635057 8184074815 16 D-7     /
      DATA BJ0CS(  9) / +.9838650793 8567841324 7687486364 15 D-9     /
      DATA BJ0CS( 10) / -.1242355159 7301765145 5158970068 36 D-10    /
      DATA BJ0CS( 11) / +.1265433630 2559045797 9158272103 63 D-12    /
      DATA BJ0CS( 12) / -.1061945649 5287244546 9148175129 59 D-14    /
      DATA BJ0CS( 13) / +.7470621075 8024567437 0989155840 00 D-17    /
      DATA BJ0CS( 14) / -.4469703227 4412780547 6270079999 99 D-19    /
      DATA BJ0CS( 15) / +.2302428158 4337436200 5230933333 33 D-21    /
      DATA BJ0CS( 16) / -.1031914479 4166698148 5226666666 66 D-23    /
      DATA BJ0CS( 17) / +.4060817827 4873322700 8000000000 00 D-26    /
      DATA BJ0CS( 18) / -.1414383600 5240913919 9999999999 99 D-28    /
      DATA BJ0CS( 19) / +.4391090549 6698880000 0000000000 00 D-31    /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESJ0
      IF (FIRST) THEN
         NTJ0 = INITDS (BJ0CS, 19, 0.1*REAL(D1MACH(3)))
         XSML = SQRT(8.0D0*D1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.4.0D0) GO TO 20
C
      DBESJ0 = 1.0D0
      IF (Y.GT.XSML) DBESJ0 = DCSEVL (.125D0*Y*Y-1.D0, BJ0CS, NTJ0)
      RETURN
C
 20   CALL D9B0MP (Y, AMPL, THETA)
      DBESJ0 = AMPL * COS(THETA)
C
      RETURN
      END


      SUBROUTINE fdjac(n,x,fvec,np,df)
      INTEGER n,np,NMAX
      REAL df(np,np),fvec(n),x(n),EPS
      PARAMETER (NMAX=40,EPS=1.e-4)
CU    USES funcv
      INTEGER i,j
      REAL h,temp,f(NMAX)
      do 12 j=1,n
        temp=x(j)
        h=EPS*abs(temp)
        if(h.eq.0.)h=EPS
        x(j)=temp+h
        h=x(j)-temp
        call funcv(n,x,f)
        x(j)=temp
        do 11 i=1,n
          df(i,j)=(f(i)-fvec(i))/h
11      continue
12    continue
      return
      END

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


      PROGRAM xzbrak
C     driver for routine zbrak
      INTEGER N,NBMAX
      REAL X1,X2
      PARAMETER(N=100,NBMAX=20,X1=1.0,X2=50.0)
      INTEGER i,nb
      REAL bessj0,xb1(NBMAX),xb2(NBMAX)
      EXTERNAL bessj0
      nb=NBMAX
      call zbrak(bessj0,X1,X2,N,xb1,xb2,nb)
      write(*,'(/1x,a/)') 'Brackets for roots of BESSJ0:'
      write(*,'(/1x,t17,a,t27,a,t40,a,t50,a/)') 'lower','upper',
     *     'F(lower)','F(upper)'
      do 11 i=1,nb
        write(*,'(1x,a,i2,2(4x,2f10.4))') 'Root ',i,xb1(i),xb2(i),
     *       bessj0(xb1(i)),bessj0(xb2(i))
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xzbrak.for


c=======================================================================
      subroutine sweep(a,dim,m,k1,k2,ier)
c=======================================================================
c     Subroutine to sweep the mxm matrix a on its k1 st thru k2 th
c     diagonals. ier is 1 if a is singular. dim is the real dimension
c     of a.
c
c     Typically in regression: sweep(a,dim,m+1,1,m,ier)
c     The output is:
c                   (xtx)^(-1)     : (xtx)^(-1) xty
c                  -ytx (xtx)^(-1) : yty-ytx (xtx)^(-1) xty
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c=======================================================================
      implicit none
      integer dim,i,ier,j,k,k1,k2,m
      real*8 a(dim,dim),d

      ier=1

      do k=k1,k2
         if(abs(a(k,k)).lt.1.e-20) return
         d=1./a(k,k)
         a(k,k)=1.
         do i=1,m
            a(k,i)=d*a(k,i)
            if(i.ne.k) a(i,k)=-a(i,k)*d
         end do

         do i=1,m
            do j=1,m
               if((i.ne.k).and.(j.ne.k)) a(i,j)=a(i,j)+a(i,k)*a(k,j)/d
            end do
         end do
       end do

       ier=0
       return
       end

c=======================================================================
      subroutine condmvn(ind,a,m,aw,perm)
c=======================================================================
c     computes the conditional covariance matrix
c     A1.2 = A11 - A12*inv(A22)*A21 and the
c     matrix for conditional mean vector A12*inv(A22)
c
c     Note: perm = Q permutation matrix. The ind coordinate is
c           placed in the first entry by using Q*A*Q^T
c
c     Alejandro Jara, 2007
c=======================================================================
      implicit none

c+++++Input
      integer ind,m
      real*8 a(m,m)

c+++++Working
      integer maxm
      parameter(maxm=100)
      integer i,j,k,ier
      integer counter
      real*8 aw2(maxm,maxm),tmp1

c+++++Output
      real*8 aw(m,m),perm(m,m)

c+++++Algorithm

      if(maxm.lt.m)then
         call rexit("Increase 'maxm' in 'condmvn'")
      end if

      if(ind.eq.1)then
         do i=1,m
            do j=1,m
               perm(i,j)=0.0d0
            end do
         end do
         do i=1,m
            perm(i,i)=1.d0
         end do
         do i=1,m
            do j=1,m
               aw(i,j)=a(i,j)
            end do
         end do
       else
         do i=1,m
            do j=1,m
               perm(i,j)=0.0d0
            end do
         end do
         perm(1,ind)=1.0d0
         counter=1
         do i=1,m
            if(i.ne.ind)then
               counter=counter+1
               perm(counter,i)=1.0d0
            end if
         end do
         do i=1,m
            do j=1,m
               tmp1=0.d0
               do k=1,m
                  tmp1=tmp1+perm(i,k)*a(k,j)
               end do
               aw2(i,j)=tmp1
            end do
         end do

         do i=1,m
            do j=1,m
               tmp1=0.d0
               do k=1,m
                  tmp1=tmp1+aw2(i,k)*perm(j,k)
               end do
               aw(i,j)=tmp1
            end do
         end do
      end if

c      do i=1,m
c         do j=1,m
c            call dblepr("aw",-1,aw(i,j),1)
c         end do
c      end do

      call sweep(aw,m,m,2,m,ier)
      if(ier.eq.1)then
         call rexit("error in computing conditionals")
      end if

      return
      end


MODULE qshep2d

! ALGORITHM 660, COLLECTED ALGORITHMS FROM ACM.

! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
! VOL. 14, NO. 2, P.149.

! Code converted using TO_F90 by Alan Miller
! Date: 2001-01-18  Time: 10:10:42

IMPLICIT NONE

CONTAINS

SUBROUTINE qshep2(n,x,y,f,nq,nw,nr,lcell,lnext,xmin,ymin,dx,dy,rmax,rsq,a,ier)
INTEGER, INTENT(IN)   :: n, nq, nw, nr
REAL, INTENT(IN)      :: x(:), y(:), f(:)
INTEGER, INTENT(OUT)  :: lcell(:,:), lnext(:), ier
REAL, INTENT(OUT)     :: xmin, ymin, dx, dy, rmax, rsq(n), a(:,:)

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767
!                                                    01/08/90

!   THIS SUBROUTINE COMPUTES A SET OF PARAMETERS A AND RSQ DEFINING A SMOOTH
! (ONCE CONTINUOUSLY DIFFERENTIABLE) BI-VARIATE FUNCTION Q(X,Y) WHICH
! INTERPOLATES DATA VALUES F AT SCATTERED NODES (X,Y).  THE INTERPOLANT Q MAY
! BE EVALUATED AT AN ARBITRARY POINT BY FUNCTION QS2VAL, AND ITS FIRST
! DERIVATIVES ARE COMPUTED BY SUBROUTINE QS2GRD.

!   THE INTERPOLATION SCHEME IS A MODIFIED QUADRATIC SHEPARD METHOD --

! Q = (W(1)*Q(1)+W(2)*Q(2)+..+W(N)*Q(N))/(W(1)+W(2)+..+W(N))

! FOR BIVARIATE FUNCTIONS W(K) AND Q(K).  THE NODAL FUNCTIONS ARE GIVEN BY

! Q(K)(X,Y) =  A(1,K)*(X-X(K))**2 + A(2,K)*(X-X(K))*(Y-Y(K))
!            + A(3,K)*(Y-Y(K))**2 + A(4,K)*(X-X(K))
!            + A(5,K)*(Y-Y(K))         + F(K) .

! THUS, Q(K) IS A QUADRATIC FUNCTION WHICH INTERPOLATES THE DATA VALUE AT
! NODE K.  ITS COEFFICIENTS A(,K) ARE OBTAINED BY A WEIGHTED LEAST SQUARES FIT
! TO THE CLOSEST NQ DATA POINTS WITH WEIGHTS SIMILAR TO W(K).
! NOTE THAT THE RADIUS OF INFLUENCE FOR THE LEAST SQUARES FIT IS FIXED FOR
! EACH K, BUT VARIES WITH K.

!   THE WEIGHTS ARE TAKEN TO BE

! W(K)(X,Y) = ( (R(K)-D(K))+ / R(K)*D(K) )**2

! WHERE (R(K)-D(K))+ = 0 IF R(K) <= D(K) AND D(K)(X,Y) IS THE EUCLIDEAN
! DISTANCE BETWEEN (X,Y) AND (X(K),Y(K)).  THE RADIUS OF INFLUENCE R(K) VARIES
! WITH K AND IS CHOSEN SO THAT NW NODES ARE WITHIN THE RADIUS.
! NOTE THAT W(K) IS NOT DEFINED AT NODE (X(K),Y(K)), BUT Q(X,Y) HAS LIMIT F(K)
! AS (X,Y) APPROACHES (X(K),Y(K)).

! ON INPUT --

!        N = NUMBER OF NODES AND ASSOCIATED DATA VALUES.
!            N >= 6.

!        X,Y = ARRAYS OF LENGTH N CONTAINING THE CARTESIAN
!              COORDINATES OF THE NODES.

!        F = ARRAY OF LENGTH N CONTAINING THE DATA VALUES
!            IN ONE-TO-ONE CORRESPONDENCE WITH THE NODES.

!        NQ = NUMBER OF DATA POINTS TO BE USED IN THE LEAST SQUARES FIT FOR
!             COEFFICIENTS DEFINING THE NODAL FUNCTIONS Q(K).
!             A HIGHLY RECOMMENDED VALUE IS NQ = 13.
!             5 <= NQ <= MIN(40,N-1).

!        NW = NUMBER OF NODES WITHIN (AND DEFINING) THE RADII OF INFLUENCE
!             R(K) WHICH ENTER INTO THE WEIGHTS W(K).  FOR N SUFFICIENTLY
!             LARGE, A RECOMMENDED VALUE IS NW = 19.
!             1 <= NW <= MIN(40,N-1).

!        NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID DEFINED IN
!             SUBROUTINE STORE2.  A RECTANGLE CONTAINING THE NODES IS
!             PARTITIONED INTO CELLS IN ORDER TO INCREASE SEARCH EFFICIENCY.
!             NR = SQRT(N/3) IS RECOMMENDED.
!             NR >= 1.

! THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.

!        LCELL = ARRAY OF LENGTH >= NR**2.

!        LNEXT = ARRAY OF LENGTH >= N.

!        RSQ = ARRAY OF LENGTH >= N.

!        A = ARRAY OF LENGTH >= 5N.

! ON OUTPUT --

!        LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED
!                WITH CELLS.  REFER TO STORE2.

!        LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDI-
!                CES.  REFER TO STORE2.

!        XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL
!                          DIMENSIONS.  REFER TO STORE2.

!        RMAX = SQUARE ROOT OF THE LARGEST ELEMENT IN RSQ --
!               MAXIMUM RADIUS R(K).

!        RSQ = ARRAY CONTAINING THE SQUARES OF THE RADII R(K)
!              WHICH ENTER INTO THE WEIGHTS W(K).

!        A = 5 BY N ARRAY CONTAINING THE COEFFICIENTS FOR
!            QUADRATIC NODAL FUNCTION Q(K) IN COLUMN K.

!   NOTE THAT THE ABOVE OUTPUT PARAMETERS ARE NOT DEFINED
! UNLESS IER = 0.

!        IER = ERROR INDICATOR --
!              IER = 0 IF NO ERRORS WERE ENCOUNTERED.
!              IER = 1 IF N, NQ, NW, OR NR IS OUT OF RANGE.
!              IER = 2 IF DUPLICATE NODES WERE ENCOUNTERED.
!              IER = 3 IF ALL NODES ARE COLLINEAR.

! MODULES REQUIRED BY QSHEP2 -- GETNP2, GIVENS, ROTATE,
!                                  SETUP2, STORE2

! INTRINSIC FUNCTIONS CALLED BY QSHEP2 -- ABS, MIN, FLOAT,
!                                            MAX0, MIN0, SQRT

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

INTEGER :: i, ib, ierr, ip1, irm1, irow, j, jp1, k, lmax, lnp, neq,  &
           nn, nnq, nnr, nnw, np, npts(40), nqwmax
REAL :: av, avsq, b(6,6), c, ddx, ddy, dmin, fk, rq, rs, rsmx,  &
        rsold, rws, s, sum, t, xk, xmn, yk, ymn

REAL, PARAMETER  :: dtol = 0.01, rtol = 1.0e-5, sf = 1.0

! LOCAL PARAMETERS --

! AV =               ROOT-MEAN-SQUARE DISTANCE BETWEEN K AND THE NODES IN THE
!                 LEAST SQUARES SYSTEM (UNLESS ADDITIONAL NODES ARE
!                 INTRODUCED FOR STABILITY).
!                 THE FIRST 3 COLUMNS OF THE MATRIX ARE SCALED BY 1/AVSQ,
!                 THE LAST 2 BY 1/AV
! AVSQ =       AV*AV
! B =               TRANSPOSE OF THE AUGMENTED REGRESSION MATRIX
! C =               FIRST COMPONENT OF THE PLANE ROTATION USED TO ZERO THE
!                 LOWER TRIANGLE OF B**T -- COMPUTED BY SUBROUTINE GIVENS
! DDX,DDY =    LOCAL VARIABLES FOR DX AND DY
! DMIN =       MINIMUM OF THE MAGNITUDES OF THE DIAGONAL ELEMENTS OF THE
!                 REGRESSION MATRIX AFTER ZEROS ARE INTRODUCED BELOW THE
!                 DIAGONAL
! DTOL =       TOLERANCE FOR DETECTING AN ILL-CONDITIONED SYSTEM.
!                 THE SYSTEM IS ACCEPTED WHEN DMIN >= DTOL
! FK =               DATA VALUE AT NODE K -- F(K)
! I =               INDEX FOR A, B, AND NPTS
! IB =               DO-LOOP INDEX FOR BACK SOLVE
! IERR =       ERROR FLAG FOR THE CALL TO STORE2
! IP1 =        I+1
! IRM1 =       IROW-1
! IROW =       ROW INDEX FOR B
! J =               INDEX FOR A AND B
! JP1 =        J+1
! K =               NODAL FUNCTION INDEX AND COLUMN INDEX FOR A
! LMAX =       MAXIMUM NUMBER OF NPTS ELEMENTS (MUST BE CONSISTENT WITH
!                 THE DIMENSION STATEMENT ABOVE)
! LNP =        CURRENT LENGTH OF NPTS
! NEQ =        NUMBER OF EQUATIONS IN THE LEAST SQUARES FIT
! NN,NNQ,NNR = LOCAL COPIES OF N, NQ, AND NR
! NNW =        LOCAL COPY OF NW
! NP =               NPTS ELEMENT
! NPTS =       ARRAY CONTAINING THE INDICES OF A SEQUENCE OF NODES TO BE USED
!                 IN THE LEAST SQUARES FIT OR TO COMPUTE RSQ.  THE NODES ARE
!                 ORDERED BY DISTANCE FROM K AND THE LAST ELEMENT
!                 (USUALLY INDEXED BY LNP) IS USED ONLY TO DETERMINE RQ,
!                 OR RSQ(K) IF NW > NQ
! NQWMAX =     MAX(NQ,NW)
! RQ =               RADIUS OF INFLUENCE WHICH ENTERS INTO THE
!                 WEIGHTS FOR Q(K) (SEE SUBROUTINE SETUP2)
! RS =               SQUARED DISTANCE BETWEEN K AND NPTS(LNP) --
!                 USED TO COMPUTE RQ AND RSQ(K)
! RSMX =       MAXIMUM RSQ ELEMENT ENCOUNTERED
! RSOLD =      SQUARED DISTANCE BETWEEN K AND NPTS(LNP-1) --
!                 USED TO COMPUTE A RELATIVE CHANGE IN RS
!                 BETWEEN SUCCEEDING NPTS ELEMENTS
! RTOL =       TOLERANCE FOR DETECTING A SUFFICIENTLY LARGE
!                 RELATIVE CHANGE IN RS.  IF THE CHANGE IS
!                 NOT GREATER THAN RTOL, THE NODES ARE
!                 TREATED AS BEING THE SAME DISTANCE FROM K
! RWS =        CURRENT VALUE OF RSQ(K)
! S =               SECOND COMPONENT OF THE PLANE GIVENS ROTATION
! SF =               MARQUARDT STABILIZATION FACTOR USED TO DAMP
!                 OUT THE FIRST 3 SOLUTION COMPONENTS (SECOND
!                 PARTIALS OF THE QUADRATIC) WHEN THE SYSTEM
!                 IS ILL-CONDITIONED.  AS SF INCREASES, THE
!                 FITTING FUNCTION APPROACHES A LINEAR
! SUM =        SUM OF SQUARED EUCLIDEAN DISTANCES BETWEEN
!                 NODE K AND THE NODES USED IN THE LEAST
!                 SQUARES FIT (UNLESS ADDITIONAL NODES ARE
!                 ADDED FOR STABILITY)
! T =               TEMPORARY VARIABLE FOR ACCUMULATING A SCALAR
!                 PRODUCT IN THE BACK SOLVE
! XK,YK =      COORDINATES OF NODE K -- X(K), Y(K)
! XMN,YMN =    LOCAL VARIABLES FOR XMIN AND YMIN

nn = n
nnq = nq
nnw = nw
nnr = nr
nqwmax = MAX(nnq,nnw)
lmax = MIN(40,nn-1)
IF (5 <= nnq .AND. 1 <= nnw .AND. nqwmax <= lmax .AND. nnr >= 1) THEN

! CREATE THE CELL DATA STRUCTURE, AND INITIALIZE RSMX.

  CALL store2(nn,x,y,nnr,lcell,lnext,xmn,ymn,ddx,ddy,ierr)
  IF (ierr /= 0) GO TO 150
  rsmx = 0.

! OUTER LOOP ON NODE K

  DO  k = 1, nn
    xk = x(k)
    yk = y(k)
    fk = f(k)

! MARK NODE K TO EXCLUDE IT FROM THE SEARCH FOR NEAREST
!   NEIGHBORS.

    lnext(k) = -lnext(k)

! INITIALIZE FOR LOOP ON NPTS.

    rs = 0.
    sum = 0.
    rws = 0.
    rq = 0.
    lnp = 0

! COMPUTE NPTS, LNP, RWS, NEQ, RQ, AND AVSQ.

    10 sum = sum + rs
    IF (lnp /= lmax) THEN
      lnp = lnp + 1
      rsold = rs
      CALL getnp2(xk,yk,x,y,nnr,lcell,lnext,xmn,ymn,ddx,ddy,np,rs)
      IF (rs == 0.) GO TO 140
      npts(lnp) = np
      IF ((rs-rsold)/rs < rtol) GO TO 10
      IF (rws == 0. .AND. lnp > nnw) rws = rs
      IF (rq == 0. .AND. lnp > nnq) THEN

!   RQ = 0 (NOT YET COMPUTED) AND LNP > NQ.        RQ =
!     SQRT(RS) IS SUFFICIENTLY LARGE TO (STRICTLY) INCLUDE
!     NQ NODES.  THE LEAST SQUARES FIT WILL INCLUDE NEQ =
!     LNP - 1 EQUATIONS FOR 5 <= NQ <= NEQ < LMAX
!     <= N-1.

        neq = lnp - 1
        rq = SQRT(rs)
        avsq = sum / REAL(neq)
      END IF

!   BOTTOM OF LOOP -- TEST FOR TERMINATION.

      IF (lnp > nqwmax) GO TO 20
      GO TO 10
    END IF

! ALL LMAX NODES ARE INCLUDED IN NPTS.        RWS AND/OR RQ**2 IS
!   (ARBITRARILY) TAKEN TO BE 10 PERCENT LARGER THAN THE
!   DISTANCE RS TO THE LAST NODE INCLUDED.

    IF (rws == 0.) rws = 1.1 * rs
    IF (rq == 0.) THEN
      neq = lmax
      rq = SQRT(1.1*rs)
      avsq = sum / REAL(neq)
    END IF

! STORE RSQ(K), UPDATE RSMX IF NECESSARY, AND COMPUTE AV.

    20 rsq(k) = rws
    IF (rws > rsmx) rsmx = rws
    av = SQRT(avsq)

! SET UP THE AUGMENTED REGRESSION MATRIX (TRANSPOSED) AS THE COLUMNS OF B,
!   AND ZERO OUT THE LOWER TRIANGLE (UPPER TRIANGLE OF B) WITH GIVENS
!   ROTATIONS -- QR DECOMPOSITION WITH ORTHOGONAL MATRIX Q NOT STORED.

    i = 0
    30 i = i + 1
    np = npts(i)
    irow = MIN(i,6)
    CALL setup2(xk,yk,fk,x(np),y(np),f(np),av,avsq,rq,b(1,irow))
    IF (i == 1) GO TO 30
    irm1 = irow - 1
    DO  j = 1, irm1
      jp1 = j + 1
      CALL givens(b(j,j),b(j,irow),c,s)
      CALL rotate(6-j,c,s,b(jp1:,j),b(jp1:,irow))
    END DO
    IF (i < neq) GO TO 30

! TEST THE SYSTEM FOR ILL-CONDITIONING.

    dmin = MIN(ABS(b(1,1)),ABS(b(2,2)),ABS(b(3,3)),ABS(b(4,4)), ABS(b(5,5)))
    IF (dmin*rq < dtol) THEN
      IF (neq /= lmax) THEN

! INCREASE RQ AND ADD ANOTHER EQUATION TO THE SYSTEM TO IMPROVE THE
!   CONDITIONING.  THE NUMBER OF NPTS ELEMENTS IS ALSO INCREASED IF NECESSARY.

        50 rsold = rs
        neq = neq + 1
        IF (neq /= lmax) THEN
          IF (neq /= lnp) THEN

!   NEQ < LNP

            np = npts(neq+1)
            rs = (x(np)-xk) ** 2 + (y(np)-yk) ** 2
            IF ((rs-rsold)/rs < rtol) GO TO 50
            rq = SQRT(rs)
            GO TO 30
          END IF

!   ADD AN ELEMENT TO NPTS.

          lnp = lnp + 1
          CALL getnp2(xk,yk,x,y,nnr,lcell,lnext,xmn,ymn,ddx,ddy, np,rs)
          IF (np == 0) GO TO 140
          npts(lnp) = np
          IF ((rs-rsold)/rs < rtol) GO TO 50
          rq = SQRT(rs)
          GO TO 30
        END IF

        rq = SQRT(1.1*rs)
        GO TO 30
      END IF

! STABILIZE THE SYSTEM BY DAMPING SECOND PARTIALS -- ADD MULTIPLES OF THE
!   FIRST THREE UNIT VECTORS TO THE FIRST THREE EQUATIONS.

      DO  i = 1, 3
        b(i,6) = sf
        ip1 = i + 1
        DO  j = ip1, 6
          b(j,6) = 0.
        END DO
        DO  j = i, 5
          jp1 = j + 1
          CALL givens(b(j,j),b(j,6),c,s)
          CALL rotate(6-j,c,s,b(jp1:,j),b(jp1:,6))
        END DO
      END DO

! TEST THE STABILIZED SYSTEM FOR ILL-CONDITIONING.

      dmin = MIN(ABS(b(1,1)),ABS(b(2,2)),ABS(b(3,3)),  &
             ABS(b(4,4)),ABS(b(5,5)))
      IF (dmin*rq < dtol) GO TO 150
    END IF

! SOLVE THE 5 BY 5 TRIANGULAR SYSTEM FOR THE COEFFICIENTS

    DO  ib = 1, 5
      i = 6 - ib
      t = 0.
      IF (i /= 5) THEN
        ip1 = i + 1
        DO  j = ip1, 5
          t = t + b(j,i) * a(j,k)
        END DO
      END IF
      a(i,k) = (b(6,i)-t) / b(i,i)
    END DO

! SCALE THE COEFFICIENTS TO ADJUST FOR THE COLUMN SCALING.

    DO  i = 1, 3
      a(i,k) = a(i,k) / avsq
    END DO
    a(4,k) = a(4,k) / av
    a(5,k) = a(5,k) / av

! UNMARK K AND THE ELEMENTS OF NPTS.

    lnext(k) = -lnext(k)
    DO  i = 1, lnp
      np = npts(i)
      lnext(np) = -lnext(np)
    END DO
  END DO

! NO ERRORS ENCOUNTERED.

  xmin = xmn
  ymin = ymn
  dx = ddx
  dy = ddy
  rmax = SQRT(rsmx)
  ier = 0
  RETURN
END IF

! N, NQ, NW, OR NR IS OUT OF RANGE.

ier = 1
RETURN

! DUPLICATE NODES WERE ENCOUNTERED BY GETNP2.

140 ier = 2
RETURN

! NO UNIQUE SOLUTION DUE TO COLLINEAR NODES.

150 xmin = xmn
ymin = ymn
dx = ddx
dy = ddy
ier = 3

RETURN
END SUBROUTINE qshep2

FUNCTION qs2val(px,py,n,x,y,f,nr,lcell,lnext,xmin,ymin,dx,dy,rmax,rsq,a) &
         RESULT(fn_val)
INTEGER, INTENT(IN)  :: n, nr, lcell(:,:), lnext(:)
REAL, INTENT(IN)     :: px, py, x(:), y(:), f(:), xmin, ymin, dx, dy,  &
                        rmax, rsq(:), a(:,:)
REAL                 :: fn_val

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767
!                                                    10/28/87

!   THIS FUNCTION RETURNS THE VALUE Q(PX,PY) WHERE Q IS THE WEIGHTED SUM
! OF QUADRATIC NODAL FUNCTIONS DEFINED IN SUBROUTINE QSHEP2.
! QS2GRD MAY BE CALLED TO COMPUTE A GRADIENT OF Q ALONG WITH THE VALUE,
! AND/OR TO TEST FOR ERRORS.

! ON INPUT --

!        PX,PY = CARTESIAN COORDINATES OF THE POINT P AT
!                WHICH Q IS TO BE EVALUATED.

!        N = NUMBER OF NODES AND DATA VALUES DEFINING Q.
!            N >= 6.

!        X,Y,F = ARRAYS OF LENGTH N CONTAINING THE NODES AND
!                DATA VALUES INTERPOLATED BY Q.

!        NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID.
!             REFER TO STORE2.  NR >= 1.

!        LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED WITH CELLS.
!                REFER TO STORE2.

!        LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDICES.
!                REFER TO STORE2.

!        XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL DIMENSIONS.
!                          DX AND DY MUST BE POSITIVE.  REFER TO STORE2.

!        RMAX = SQUARE ROOT OF THE LARGEST ELEMENT IN RSQ -- MAXIMUM RADIUS.

!        RSQ = ARRAY OF LENGTH N CONTAINING THE SQUARED RADII
!              WHICH ENTER INTO THE WEIGHTS DEFINING Q.

!        A = 5 BY N ARRAY CONTAINING THE COEFFICIENTS FOR THE
!            NODAL FUNCTIONS DEFINING Q.

!   INPUT PARAMETERS ARE NOT ALTERED BY THIS FUNCTION.   THE PARAMETERS OTHER
! THAN PX AND PY SHOULD BE INPUT UNALTERED FROM THEIR VALUES ON OUTPUT FROM
! QSHEP2.  THIS FUNCTION SHOULD NOT BE CALLED IF A NONZERO ERROR FLAG WAS
! RETURNED BY QSHEP2.

! ON OUTPUT --

!        QS2VAL = FUNCTION VALUE Q(PX,PY) UNLESS N, NR, DX, DY, OR RMAX IS
!                 INVALID, IN WHICH CASE NO VALUE IS RETURNED.

! MODULES REQUIRED BY QS2VAL -- NONE

! INTRINSIC FUNCTIONS CALLED BY QS2VAL -- IFIX, SQRT

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

! Local variables
REAL     :: delx, dely, ds, dxsq, dysq, rd, rds, rs, sw, swq, w, xp, yp
INTEGER  :: i, imax, imin, j, jmax, jmin, k, kp

xp = px
yp = py
IF (n < 6 .OR. nr < 1 .OR. dx <= 0. .OR. dy <= 0. .OR. rmax < 0.) RETURN

! SET IMIN, IMAX, JMIN, AND JMAX TO CELL INDICES DEFINING THE RANGE OF THE
!   SEARCH FOR NODES WHOSE RADII INCLUDE P.
!   THE CELLS WHICH MUST BE SEARCHED ARE THOSE INTERSECTED BY (OR CONTAINED
!   IN) A CIRCLE OF RADIUS RMAX CENTERED AT P.

imin = (xp-xmin-rmax)/dx + 1
imax = (xp-xmin+rmax)/dx + 1
IF (imin < 1) imin = 1
IF (imax > nr) imax = nr
jmin = (yp-ymin-rmax)/dy + 1
jmax = (yp-ymin+rmax)/dy + 1
IF (jmin < 1) jmin = 1
IF (jmax > nr) jmax = nr

! THE FOLLOWING IS A TEST FOR NO CELLS WITHIN THE CIRCLE OF RADIUS RMAX.

IF (imin <= imax .AND. jmin <= jmax) THEN

! ACCUMULATE WEIGHT VALUES IN SW AND WEIGHTED NODAL FUNCTION VALUES IN SWQ.
!   THE WEIGHTS ARE W(K) = ((R-D)+/(R*D))**2 FOR R**2 = RSQ(K) AND
!   D = DISTANCE BETWEEN P AND NODE K.

  sw = 0.
  swq = 0.

! OUTER LOOP ON CELLS (I,J).

  DO  j = jmin, jmax
    DO  i = imin, imax
      k = lcell(i,j)
      IF (k /= 0) THEN

! INNER LOOP ON NODES K.

        10 delx = xp - x(k)
        dely = yp - y(k)
        dxsq = delx * delx
        dysq = dely * dely
        ds = dxsq + dysq
        rs = rsq(k)
        IF (ds < rs) THEN
          IF (ds == 0.) GO TO 40
          rds = rs * ds
          rd = SQRT(rds)
          w = (rs+ds-rd-rd) / rds
          sw = sw + w
          swq = swq + w * (a(1,k)*dxsq + a(2,k)*delx*dely + a(3,k)*dysq +  &
                a(4,k)*delx + a(5,k)*dely + f(k))
        END IF

! BOTTOM OF LOOP ON NODES IN CELL (I,J).

        kp = k
        k = lnext(kp)
        IF (k /= kp) GO TO 10
      END IF
    END DO
  END DO

! SW = 0 IFF P IS NOT WITHIN THE RADIUS R(K) FOR ANY NODE K.

  IF (sw == 0.) GO TO 50
  fn_val = swq / sw
  RETURN

! (PX,PY) = (X(K),Y(K))

  40 fn_val = f(k)
  RETURN
END IF

! ALL WEIGHTS ARE 0 AT P.

50 fn_val = 0.

RETURN
END FUNCTION qs2val

SUBROUTINE qs2grd(px,py,n,x,y,f,nr,lcell,lnext,xmin,ymin,dx,dy,  &
                  rmax,rsq,a,q,qx,qy,ier)
INTEGER, INTENT(IN)   :: n, nr, lcell(:,:), lnext(:)
REAL, INTENT(IN)      :: px, py, x(:), y(:), f(:), xmin, ymin, dx, dy,  &
                         rmax, rsq(:), a(:,:)
REAL, INTENT(OUT)     :: q, qx, qy
INTEGER, INTENT(OUT)  :: ier

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767
!                                                    10/28/87

!   THIS SUBROUTINE COMPUTES THE VALUE AND GRADIENT AT (PX,PY) OF THE
! INTERPOLATORY FUNCTION Q DEFINED IN SUBROUTINE QSHEP2.
! Q(X,Y) IS A WEIGHTED SUM OF QUADRATIC NODAL FUNCTIONS.

! ON INPUT --

!        PX,PY = CARTESIAN COORDINATES OF THE POINT AT WHICH
!                Q AND ITS PARTIALS ARE TO BE EVALUATED.

!        N = NUMBER OF NODES AND DATA VALUES DEFINING Q.
!            N >= 6.

!        X,Y,F = ARRAYS OF LENGTH N CONTAINING THE NODES AND
!                DATA VALUES INTERPOLATED BY Q.

!        NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID.
!             REFER TO STORE2.  NR >= 1.

!        LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED WITH CELLS.
!                REFER TO STORE2.

!        LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDICES.
!                REFER TO STORE2.

!        XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL DIMENSIONS.
!                          DX AND DY MUST BE POSITIVE.  REFER TO STORE2.

!        RMAX = SQUARE ROOT OF THE LARGEST ELEMENT IN RSQ -- MAXIMUM RADIUS.

!        RSQ = ARRAY OF LENGTH N CONTAINING THE SQUARED RADII
!              WHICH ENTER INTO THE WEIGHTS DEFINING Q.

!        A = 5 BY N ARRAY CONTAINING THE COEFFICIENTS FOR THE
!            NODAL FUNCTIONS DEFINING Q.

!   INPUT PARAMETERS ARE NOT ALTERED BY THIS SUBROUTINE.
! THE PARAMETERS OTHER THAN PX AND PY SHOULD BE INPUT UNALTERED FROM THEIR
! VALUES ON OUTPUT FROM QSHEP2.  THIS SUBROUTINE SHOULD NOT BE CALLED IF A
! NONZERO ERROR FLAG WAS RETURNED BY QSHEP2.

! ON OUTPUT --

!        Q = VALUE OF Q AT (PX,PY) UNLESS IER .EQ. 1, IN
!            WHICH CASE NO VALUES ARE RETURNED.

!        QX,QY = FIRST PARTIAL DERIVATIVES OF Q AT (PX,PY) UNLESS IER .EQ. 1.

!        IER = ERROR INDICATOR
!              IER = 0 IF NO ERRORS WERE ENCOUNTERED.
!              IER = 1 IF N, NR, DX, DY OR RMAX IS INVALID.
!              IER = 2 IF NO ERRORS WERE ENCOUNTERED BUT (PX,PY) IS NOT WITHIN
!                      THE RADIUS R(K) FOR ANY NODE K (AND THUS Q=QX=QY=0).

! MODULES REQUIRED BY QS2GRD -- NONE

! INTRINSIC FUNCTIONS CALLED BY QS2GRD -- IFIX, SQRT

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

! Local variables
REAL     :: delx, dely, ds, dxsq, dysq, qk, qkx, qky, rd, rds, rs,  &
            sw, swq, swqx, swqy, sws, swx, swy, t, w, wx, wy, xp, yp
INTEGER  :: i, imax, imin, j, jmax, jmin, k, kp

xp = px
yp = py
IF (n >= 6 .AND. nr >= 1 .AND. dx > 0. .AND. dy > 0. .AND. rmax >= 0.) THEN

! SET IMIN, IMAX, JMIN, AND JMAX TO CELL INDICES DEFINING P.
!   THE RANGE OF THE SEARCH FOR NODES WHOSE RADII INCLUDE THE CELLS WHICH MUST
!   BE SEARCHED ARE THOSE INTERSECTED BY (OR CONTAINED IN) A CIRCLE OF RADIUS
!   RMAX CENTERED AT P.

  imin = (xp-xmin-rmax)/dx + 1
  imax = (xp-xmin+rmax)/dx + 1
  IF (imin < 1) imin = 1
  IF (imax > nr) imax = nr
  jmin = (yp-ymin-rmax)/dy + 1
  jmax = (yp-ymin+rmax)/dy + 1
  IF (jmin < 1) jmin = 1
  IF (jmax > nr) jmax = nr

! THE FOLLOWING IS A TEST FOR NO CELLS WITHIN THE CIRCLE OF RADIUS RMAX.

  IF (imin > imax .OR. jmin > jmax) GO TO 50

! Q = SWQ/SW = SUM(W(K)*Q(K))/SUM(W(K)) WHERE THE SUM IS FROM K = 1 TO N,
!   Q(K) IS THE QUADRATIC NODAL FUNCTION, AND W(K) = ((R-D)+/(R*D))**2 FOR
!   RADIUS R(K) AND DISTANCE D(K).
!   THUS

!         QX = (SWQX*SW - SWQ*SWX)/SW**2  AND
!         QY = (SWQY*SW - SWQ*SWY)/SW**2

!   WHERE SWQX AND SWX ARE PARTIAL DERIVATIVES WITH RESPECT TO X OF SWQ
!   AND SW, RESPECTIVELY.  SWQY AND SWY ARE DEFINED SIMILARLY.

  sw = 0.
  swx = 0.
  swy = 0.
  swq = 0.
  swqx = 0.
  swqy = 0.

! OUTER LOOP ON CELLS (I,J).

  DO  j = jmin, jmax
    DO  i = imin, imax
      k = lcell(i,j)
      IF (k /= 0) THEN

! INNER LOOP ON NODES K.

        10 delx = xp - x(k)
        dely = yp - y(k)
        dxsq = delx * delx
        dysq = dely * dely
        ds = dxsq + dysq
        rs = rsq(k)
        IF (ds < rs) THEN
          IF (ds == 0.) GO TO 40
          rds = rs * ds
          rd = SQRT(rds)
          w = (rs+ds-rd-rd) / rds
          t = 2. * (rd-rs) / (ds*rds)
          wx = delx * t
          wy = dely * t
          qkx = 2. * a(1,k) * delx + a(2,k) * dely
          qky = a(2,k) * delx + 2. * a(3,k) * dely
          qk = (qkx*delx+qky*dely) / 2.
          qkx = qkx + a(4,k)
          qky = qky + a(5,k)
          qk = qk + a(4,k) * delx + a(5,k) * dely + f(k)
          sw = sw + w
          swx = swx + wx
          swy = swy + wy
          swq = swq + w * qk
          swqx = swqx + wx * qk + w * qkx
          swqy = swqy + wy * qk + w * qky
        END IF

! BOTTOM OF LOOP ON NODES IN CELL (I,J).

        kp = k
        k = lnext(kp)
        IF (k /= kp) GO TO 10
      END IF
    END DO
  END DO

! SW = 0 IFF P IS NOT WITHIN THE RADIUS R(K) FOR ANY NODE K.

  IF (sw == 0.) GO TO 50
  q = swq / sw
  sws = sw * sw
  qx = (swqx*sw-swq*swx) / sws
  qy = (swqy*sw-swq*swy) / sws
  ier = 0
  RETURN

! (PX,PY) = (X(K),Y(K))

  40 q = f(k)
  qx = a(4,k)
  qy = a(5,k)
  ier = 0
  RETURN
END IF

! INVALID INPUT PARAMETER.

ier = 1
RETURN

! NO CELLS CONTAIN A POINT WITHIN RMAX OF P, OR
!   SW = 0 AND THUS DS >= RSQ(K) FOR ALL K.

50 q = 0.
qx = 0.
qy = 0.
ier = 2

RETURN
END SUBROUTINE qs2grd

SUBROUTINE getnp2(px,py,x,y,nr,lcell,lnext,xmin,ymin,dx,dy,np,dsq)
INTEGER, INTENT(IN)      :: nr, lcell(:,:)
INTEGER, INTENT(IN OUT)  :: lnext(:)
REAL, INTENT(IN)         :: px, py, x(1), y(1), xmin, ymin, dx, dy
INTEGER, INTENT(OUT)     :: np
REAL, INTENT(OUT)        :: dsq

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767

!   GIVEN A SET OF N NODES AND THE DATA STRUCTURE DEFINED IN SUBROUTINE STORE2,
! THIS SUBROUTINE USES THE CELL METHOD TO FIND THE CLOSEST UNMARKED NODE NP TO
! A SPECIFIED POINT P.
! NP IS THEN MARKED BY SETTING LNEXT(NP) TO -LNEXT(NP).  (A NODE IS MARKED IF
! AND ONLY IF THE CORRESPONDING LNEXT ELEMENT IS NEGATIVE.   THE ABSOLUTE
! VALUES OF LNEXT ELEMENTS, HOWEVER, MUST BE PRESERVED.)   THUS, THE CLOSEST
! M NODES TO P MAY BE DETERMINED BY A SEQUENCE OF M CALLS TO THIS ROUTINE.
! NOTE THAT IF THE NEAREST NEIGHBOR TO NODE K IS TO BE DETERMINED (PX = X(K)
! AND PY = Y(K)), THEN K SHOULD BE MARKED BEFORE THE CALL TO THIS ROUTINE.

!   THE SEARCH IS BEGUN IN THE CELL CONTAINING (OR CLOSEST TO) P AND PROCEEDS
! OUTWARD IN RECTANGULAR LAYERS UNTIL ALL CELLS WHICH CONTAIN POINTS WITHIN
! DISTANCE R OF P HAVE BEEN SEARCHED, WHERE R IS THE DISTANCE FROM P TO THE
! FIRST UNMARKED NODE ENCOUNTERED (INFINITE IF NO UNMARKED NODES ARE PRESENT).

! ON INPUT --

!        PX,PY = CARTESIAN COORDINATES OF THE POINT P WHOSE
!                NEAREST UNMARKED NEIGHBOR IS TO BE FOUND.

!        X,Y = ARRAYS OF LENGTH N, FOR N >= 2, CONTAINING
!              THE CARTESIAN COORDINATES OF THE NODES.

!        NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID.
!             NR >= 1.

!        LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED WITH CELLS.

!        LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDICES
!                (OR THEIR NEGATIVES).

!        XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL DIMENSIONS.
!                          DX AND DY MUST BE POSITIVE.

!   INPUT PARAMETERS OTHER THAN LNEXT ARE NOT ALTERED BY THIS ROUTINE. WITH
! THE EXCEPTION OF (PX,PY) AND THE SIGNS OF LNEXT ELEMENTS, THESE PARAMETERS
! SHOULD BE UNALTERED FROM THEIR VALUES ON OUTPUT FROM SUBROUTINE STORE2.

! ON OUTPUT --

!        NP = INDEX (FOR X AND Y) OF THE NEAREST UNMARKED NODE TO P,
!             OR 0 IF ALL NODES ARE MARKED OR NR < 1 OR DX <= 0 OR
!             DY <= 0.
!             LNEXT(NP) < 0 IF NP .NE. 0.

!        DSQ = SQUARED EUCLIDEAN DISTANCE BETWEEN P AND NODE
!              NP, OR 0 IF NP = 0.

! MODULES REQUIRED BY GETNP2 -- NONE

! INTRINSIC FUNCTIONS CALLED BY GETNP2 -- ABS, IFIX, SQRT

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

! Local variables
LOGICAL  :: first
REAL     :: delx, dely, r, rsmin, rsq, xp, yp
INTEGER  :: i, i0, i1, i2, imax, imin, j, j0, j1, j2, jmax, jmin, l, lmin, ln

xp = px
yp = py

! TEST FOR INVALID INPUT PARAMETERS.

IF (nr >= 1 .AND. dx > 0. .AND. dy > 0.) THEN

! INITIALIZE PARAMETERS --

!   FIRST = TRUE IFF THE FIRST UNMARKED NODE HAS YET TO BE ENCOUNTERED,
!   IMIN,IMAX,JMIN,JMAX = CELL INDICES DEFINING THE RANGE OF THE SEARCH,
!   DELX,DELY = PX-XMIN AND PY-YMIN,
!   I0,J0 = CELL CONTAINING OR CLOSEST TO P,
!   I1,I2,J1,J2 = CELL INDICES OF THE LAYER WHOSE INTERSECTION WITH THE RANGE
!                  DEFINED BY IMIN,..., JMAX IS CURRENTLY BEING SEARCHED.

  first = .true.
  imin = 1
  imax = nr
  jmin = 1
  jmax = nr
  delx = xp - xmin
  dely = yp - ymin
  i0 = delx/dx + 1
  IF (i0 < 1) i0 = 1
  IF (i0 > nr) i0 = nr
  j0 = dely/dy + 1
  IF (j0 < 1) j0 = 1
  IF (j0 > nr) j0 = nr
  i1 = i0
  i2 = i0
  j1 = j0
  j2 = j0

! OUTER LOOP ON LAYERS, INNER LOOP ON LAYER CELLS, EXCLUDING
!   THOSE OUTSIDE THE RANGE (IMIN,IMAX) X (JMIN,JMAX).

  10 i = 0
  loop40:  DO  j = j1, j2
    IF (j > jmax) GO TO 50
    IF (j >= jmin) THEN
      DO  i = i1, i2
        IF (i > imax) CYCLE loop40
        IF (i >= imin) THEN
          IF (j == j1 .OR. j == j2 .OR. i == i1 .OR. i == i2) THEN

! SEARCH CELL (I,J) FOR UNMARKED NODES L.

            l = lcell(i,j)
            IF (l /= 0) THEN

!   LOOP ON NODES IN CELL (I,J).

              20 ln = lnext(l)
              IF (ln >= 0) THEN

!   NODE L IS NOT MARKED.

                rsq = (x(l)-xp) ** 2 + (y(l)-yp) ** 2
                IF (first) THEN

!   NODE L IS THE FIRST UNMARKED NEIGHBOR OF P ENCOUNTERED.
!     INITIALIZE LMIN TO THE CURRENT CANDIDATE FOR NP, AND RSMIN TO THE
!     SQUARED DISTANCE FROM P TO LMIN.  IMIN, IMAX, JMIN, AND JMAX ARE UPDATED
!     TO DEFINE THE SMALLEST RECTANGLE CONTAINING A CIRCLE OF RADIUS R =
!     SQRT(RSMIN) CENTERED AT P, AND CONTAINED IN (1,NR) X (1,NR) (EXCEPT
!     THAT, IF P IS OUTSIDE THE RECTANGLE DEFINED BY THE NODES, IT IS POSSIBLE
!     THAT IMIN > NR, IMAX < 1, JMIN > NR, OR JMAX < 1).
!     FIRST IS RESET TO FALSE.

                  lmin = l
                  rsmin = rsq
                  r = SQRT(rsmin)
                  imin = (delx-r)/dx + 1
                  IF (imin < 1) imin = 1
                  imax = (delx+r)/dx + 1
                  IF (imax > nr) imax = nr
                  jmin = (dely-r)/dy + 1
                  IF (jmin < 1) jmin = 1
                  jmax = (dely+r)/dy + 1
                  IF (jmax > nr) jmax = nr
                  first = .false.
                ELSE

!   TEST FOR NODE L CLOSER THAN LMIN TO P.

                  IF (rsq < rsmin) THEN

!   UPDATE LMIN AND RSMIN.

                    lmin = l
                    rsmin = rsq
                  END IF
                END IF
              END IF

!   TEST FOR TERMINATION OF LOOP ON NODES IN CELL (I,J).

              IF (ABS(ln) /= l) THEN
                l = ABS(ln)
                GO TO 20
              END IF
            END IF
          END IF
        END IF
      END DO
    END IF
  END DO loop40

! TEST FOR TERMINATION OF LOOP ON CELL LAYERS.

  50 IF (i1 > imin .OR. i2 < imax .OR. j1 > jmin .OR. j2 < jmax) THEN
    i1 = i1 - 1
    i2 = i2 + 1
    j1 = j1 - 1
    j2 = j2 + 1
    GO TO 10
  END IF

! UNLESS NO UNMARKED NODES WERE ENCOUNTERED, LMIN IS THE
!   CLOSEST UNMARKED NODE TO P.

  IF (.NOT.first) THEN
    np = lmin
    dsq = rsmin
    lnext(lmin) = -lnext(lmin)
    RETURN
  END IF
END IF

! ERROR -- NR, DX, OR DY IS INVALID OR ALL NODES ARE MARKED.

np = 0
dsq = 0.

RETURN
END SUBROUTINE getnp2

SUBROUTINE givens(a,b,c,s)
REAL, INTENT(IN OUT)  :: a, b
REAL, INTENT(OUT)     :: c, s

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767

!   THIS ROUTINE CONSTRUCTS THE GIVENS PLANE ROTATION --
!     ( C  S)
! G = (     ) WHERE C*C + S*S = 1 -- WHICH ZEROS THE SECOND ENTRY OF THE
!     (-S  C)
! 2-VECTOR (A B)-TRANSPOSE.  A CALL TO GIVENS IS NORMALLY FOLLOWED BY A CALL
! TO ROTATE WHICH APPLIES THE TRANSFORMATION TO A 2 BY N MATRIX.
! THIS ROUTINE WAS TAKEN FROM LINPACK.

! ON INPUT --

!        A,B = COMPONENTS OF THE 2-VECTOR TO BE ROTATED.

! ON OUTPUT --

!        A = VALUE OVERWRITTEN BY R = +/-SQRT(A*A + B*B)

!        B = VALUE OVERWRITTEN BY A VALUE Z WHICH ALLOWS C
!            AND S TO BE RECOVERED AS FOLLOWS --
!              C = SQRT(1-Z*Z), S=Z     IF ABS(Z) <= 1.
!              C = 1/Z, S = SQRT(1-C*C) IF ABS(Z) > 1.

!        C = +/-(A/R)

!        S = +/-(B/R)

! MODULES REQUIRED BY GIVENS -- NONE

! INTRINSIC FUNCTIONS CALLED BY GIVENS - ABS, SQRT

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

REAL  :: aa, bb, r, u, v

! LOCAL PARAMETERS --

! AA,BB = LOCAL COPIES OF A AND B
! R =          C*A + S*B = +/-SQRT(A*A+B*B)
! U,V =   VARIABLES USED TO SCALE A AND B FOR COMPUTING R

aa = a
bb = b
IF (ABS(aa) > ABS(bb)) THEN

! ABS(A) > ABS(B)

  u = aa + aa
  v = bb / u
  r = SQRT(.25+v*v) * u
  c = aa / r
  s = v * (c+c)

! NOTE THAT R HAS THE SIGN OF A, C > 0, AND S HAS SIGN(A)*SIGN(B).

  b = s
  a = r
  RETURN
END IF

! ABS(A) <= ABS(B)

IF (bb /= 0.) THEN
  u = bb + bb
  v = aa / u

! STORE R IN A.

  a = SQRT(.25+v*v) * u
  s = bb / a
  c = v * (s+s)

! NOTE THAT R HAS THE SIGN OF B, S > 0, AND C HAS SIGN(A)*SIGN(B).

  b = 1.
  IF (c /= 0.) b = 1. / c
  RETURN
END IF

! A = B = 0.

c = 1.
s = 0.

RETURN
END SUBROUTINE givens

SUBROUTINE rotate(n,c,s,x,y)
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN)      :: c, s
REAL, INTENT(IN OUT)  :: x(:), y(:)

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767

!                                             ( C  S)
!   THIS ROUTINE APPLIES THE GIVENS ROTATION (           ) TO THE
!                                             (-S  C)
!                (X(1) ... X(N))
! 2 BY N MATRIX (               ).
!                (Y(1) ... Y(N))

! ON INPUT --

!        N = NUMBER OF COLUMNS TO BE ROTATED.

!        C,S = ELEMENTS OF THE GIVENS ROTATION.   THESE MAY BE DETERMINED
!              BY SUBROUTINE GIVENS.

!        X,Y = ARRAYS OF LENGTH >= N CONTAINING THE VECTORS TO BE ROTATED.

! PARAMETERS N, C, AND S ARE NOT ALTERED BY THIS ROUTINE.

! ON OUTPUT --

!        X,Y = ROTATED VECTORS.

! MODULES REQUIRED BY ROTATE -- NONE

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

INTEGER  :: i
REAL     :: xi, yi

! LOCAL PARAMETERS --

! I =          DO-LOOP INDEX
! XI,YI = X(I), Y(I)

IF (n <= 0 .OR. (c == 1. .AND. s == 0.)) RETURN
DO  i = 1, n
  xi = x(i)
  yi = y(i)
  x(i) = c * xi + s * yi
  y(i) = -s * xi + c * yi
END DO

RETURN
END SUBROUTINE rotate

SUBROUTINE setup2(xk,yk,fk,xi,yi,fi,s1,s2,r,row)
REAL, INTENT(IN)   :: xk, yk, fk, xi, yi, fi, s1, s2, r
REAL, INTENT(OUT)  :: row(6)

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767

!   THIS ROUTINE SETS UP THE I-TH ROW OF AN AUGMENTED REGRESSION MATRIX FOR A
! WEIGHTED LEAST-SQUARES FIT OF A QUADRATIC FUNCTION Q(X,Y) TO A SET OF DATA
! VALUES F, WHERE Q(XK,YK) = FK.  THE FIRST 3 COLUMNS (QUADRATIC TERMS) ARE
! SCALED BY 1/S2 AND THE FOURTH AND FIFTH COLUMNS (LINEAR TERMS) ARE SCALED
! BY 1/S1.  THE WEIGHT IS (R-D)/(R*D) IF R > D AND 0 IF R <= D, WHERE D
! IS THE DISTANCE BETWEEN NODES I AND K.

! ON INPUT --

!        XK,YK,FK = COORDINATES AND DATA VALUE AT NODE K -- INTERPOLATED BY Q.

!        XI,YI,FI = COORDINATES AND DATA VALUE AT NODE I.

!        S1,S2 = RECIPROCALS OF THE SCALE FACTORS.

!        R = RADIUS OF INFLUENCE ABOUT NODE K DEFINING THE WEIGHT.

!        ROW = ARRAY OF LENGTH 6.

! INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.

! ON OUTPUT --

!        ROW = VECTOR CONTAINING A ROW OF THE AUGMENTED REGRESSION MATRIX.

! MODULES REQUIRED BY SETUP2 -- NONE

! INTRINSIC FUNCTION CALLED BY SETUP2 -- SQRT

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

REAL  :: d, dx, dy, dxsq, dysq, w, w1, w2

! LOCAL PARAMETERS -

! I =         DO-LOOP INDEX
! DX =         XI - XK
! DY =         YI - YK
! DXSQ = DX*DX
! DYSQ = DY*DY
! D =         DISTANCE BETWEEN NODES K AND I
! W =         WEIGHT ASSOCIATED WITH THE ROW
! W1 =         W/S1
! W2 =         W/S2

dx = xi - xk
dy = yi - yk
dxsq = dx * dx
dysq = dy * dy
d = SQRT(dxsq+dysq)
IF (d > 0. .AND. d < r) THEN
  w = (r-d) / r / d
  w1 = w / s1
  w2 = w / s2
  row(1) = dxsq * w2
  row(2) = dx * dy * w2
  row(3) = dysq * w2
  row(4) = dx * w1
  row(5) = dy * w1
  row(6) = (fi-fk) * w
  RETURN
END IF

! NODES K AND I COINCIDE OR NODE I IS OUTSIDE OF THE RADIUS OF INFLUENCE.
!   SET ROW TO THE ZERO VECTOR.

row(1:6) = 0.

RETURN
END SUBROUTINE setup2

SUBROUTINE store2(n,x,y,nr,lcell,lnext,xmin,ymin,dx,dy,ier)
INTEGER, INTENT(IN)      :: n, nr
INTEGER, INTENT(IN OUT)  :: lcell(:,:), lnext(:)
REAL, INTENT(IN)         :: x(:), y(:)
REAL, INTENT(OUT)        :: xmin, ymin, dx, dy
INTEGER, INTENT(OUT)     :: ier

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

!                                                ROBERT RENKA
!                                        UNIV. OF NORTH TEXAS
!                                              (817) 565-2767

!   GIVEN A SET OF N ARBITRARILY DISTRIBUTED NODES IN THE PLANE, THIS
! SUBROUTINE CREATES A DATA STRUCTURE FOR A CELL-BASED METHOD OF SOLVING
! CLOSEST-POINT PROBLEMS.   THE SMALLEST RECTANGLE CONTAINING THE NODES IS
! PARTITIONED INTO AN NR BY NR UNIFORM GRID OF CELLS, AND NODES ARE
! ASSOCIATED WITH CELLS.   IN PARTICULAR, THE DATA STRUCTURE STORES THE
! INDICES OF THE NODES CONTAINED IN EACH CELL.
! FOR A UNIFORM RANDOM DISTRIBUTION OF NODES, THE NEAREST NODE TO AN
! ARBITRARY POINT CAN BE DETERMINED IN CONSTANT EXPECTED TIME.

! ON INPUT --

!        N = NUMBER OF NODES.  N >= 2.

!        X,Y = ARRAYS OF LENGTH N CONTAINING THE CARTESIAN
!              COORDINATES OF THE NODES.

!        NR = NUMBER OF ROWS AND COLUMNS IN THE GRID.  THE CELL DENSITY
!             (AVERAGE NUMBER OF NODES PER CELL) IS D = N/(NR**2).
!             A RECOMMENDED VALUE, BASED ON EMPIRICAL EVIDENCE,
!             IS D = 3 -- NR = SQRT(N/3).  NR >= 1.

! THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.

!        LCELL = ARRAY OF LENGTH >= NR**2.

!        LNEXT = ARRAY OF LENGTH >= N.

! ON OUTPUT --

!        LCELL = NR BY NR CELL ARRAY SUCH THAT LCELL(I,J) CONTAINS THE INDEX
!                (FOR X AND Y) OF THE FIRST NODE (NODE WITH SMALLEST INDEX) IN
!                CELL (I,J), OR LCELL(I,J) = 0 IF NO NODES ARE CONTAINED IN
!                THE CELL.  THE UPPER RIGHT CORNER OF CELL (I,J) HAS
!                COORDINATES (XMIN+I*DX,YMIN+J*DY).
!                LCELL IS NOT DEFINED IF IER .NE. 0.

!        LNEXT = ARRAY OF NEXT-NODE INDICES SUCH THAT LNEXT(K) CONTAINS THE
!                INDEX OF THE NEXT NODE IN THE CELL WHICH CONTAINS NODE K, OR
!                LNEXT(K) = K IF K IS THE LAST NODE IN THE CELL FOR
!                K = 1,...,N.  (THE NODES CONTAINED IN A CELL ARE ORDERED BY
!                THEIR INDICES.)
!                IF, FOR EXAMPLE, CELL (I,J) CONTAINS NODES 2, 3, AND 5 (AND
!                NO OTHERS), THEN LCELL(I,J) = 2, LNEXT(2) = 3, LNEXT(3) = 5,
!                AND LNEXT(5) = 5.  LNEXT IS NOT DEFINED IF IER .NE. 0.

!        XMIN,YMIN = CARTESIAN COORDINATES OF THE LOWER LEFT CORNER OF THE
!                    RECTANGLE DEFINED BY THE NODES (SMALLEST NODAL
!                    COORDINATES) UNLESS IER = 1.  THE UPPER RIGHT CORNER IS
!                    (XMAX,YMAX) FOR XMAX = XMIN + NR*DX AND
!                    YMAX = YMIN + NR*DY.

!        DX,DY = DIMENSIONS OF THE CELLS UNLESS IER = 1.  DX = (XMAX-XMIN)/NR
!                AND DY = (YMAX-YMIN)/NR WHERE XMIN, XMAX, YMIN, AND YMAX ARE
!                THE EXTREMA OF X AND Y.

!        IER = ERROR INDICATOR --
!              IER = 0 IF NO ERRORS WERE ENCOUNTERED.
!              IER = 1 IF N < 2 OR NR < 1.
!              IER = 2 IF DX = 0 OR DY = 0.

! MODULES REQUIRED BY STORE2 -- NONE

! INTRINSIC FUNCTIONS CALLED BY STORE2 -- FLOAT, IFIX

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

! Local variables
INTEGER  :: i, j, k, kb, l, nn, nnr, np1
REAL     :: delx, dely, xmn, xmx, ymn, ymx

nn = n
nnr = nr
IF (nn >= 2 .AND. nnr >= 1) THEN

! COMPUTE THE DIMENSIONS OF THE RECTANGLE CONTAINING THE NODES.

  xmn = x(1)
  xmx = xmn
  ymn = y(1)
  ymx = ymn
  DO  k = 2, nn
    IF (x(k) < xmn) xmn = x(k)
    IF (x(k) > xmx) xmx = x(k)
    IF (y(k) < ymn) ymn = y(k)
    IF (y(k) > ymx) ymx = y(k)
  END DO
  xmin = xmn
  ymin = ymn

! COMPUTE CELL DIMENSIONS AND TEST FOR ZERO AREA.

  delx = (xmx-xmn) / REAL(nnr)
  dely = (ymx-ymn) / REAL(nnr)
  dx = delx
  dy = dely
  IF (delx == 0. .OR. dely == 0.) GO TO 50

! INITIALIZE LCELL.

  DO  j = 1, nnr
    DO  i = 1, nnr
      lcell(i,j) = 0
    END DO
  END DO

! LOOP ON NODES, STORING INDICES IN LCELL AND LNEXT.

  np1 = nn + 1
  DO  k = 1, nn
    kb = np1 - k
    i = (x(kb)-xmn)/delx + 1
    IF (i > nnr) i = nnr
    j = (y(kb)-ymn)/dely + 1
    IF (j > nnr) j = nnr
    l = lcell(i,j)
    lnext(kb) = l
    IF (l == 0) lnext(kb) = kb
    lcell(i,j) = kb
  END DO

! NO ERRORS ENCOUNTERED

  ier = 0
  RETURN
END IF

! INVALID INPUT PARAMETER

ier = 1
RETURN

! DX = 0 OR DY = 0

50 ier = 2
RETURN
END SUBROUTINE store2

END MODULE qshep2d

PROGRAM qs2test
!                           QS2TEST

!   THIS PROGRAM TESTS THE SCATTERED DATA INTERPOLATION PACKAGE QSHEP2D
! BY PRINTING THE MAXIMUM ERRORS ASSOCIATED WITH INTERPOLATED VALUES AND
! GRADIENTS ON A 10 BY 10 UNIFORM GRID IN THE UNIT SQUARE.  THE DATA SET
! CONSISTS OF 36 NODES WITH DATA VALUES TAKEN FROM A QUADRATIC FUNCTION FOR
! WHICH THE METHOD IS EXACT.  THE RATIO OF MAXIMUM INTERPOLATION ERROR
! RELATIVE TO THE MACHINE PRECISION IS ALSO PRINTED.  THIS SHOULD BE O(1).
! THE INTERPOLATED VALUES FROM QS2VAL AND QS2GRD ARE COMPARED FOR AGREEMENT.

USE qshep2d
IMPLICIT NONE
INTEGER :: i, ier, j, k, lcell(3,3), lnext(36)
REAL    :: a(5,36), dx, dy, eps, eq, eqx, eqy, f(36), p(10), px, py, q, q1, &
           qx, qy, rmax, rq, rsq(36), x(36), xmin, y(36), yk, ymin

! QSHEP2 PARAMETERS AND LOGICAL UNIT FOR OUTPUT

INTEGER, PARAMETER  :: lout = 6, n = 36, nq = 13, nr = 3, nw = 19

! GENERATE A 6 BY 6 GRID OF NODES IN THE UNIT SQUARE WITH THE NATURAL ORDERING.

k = 0
DO  j = 1, 6
  yk = (6-j) / 5.
  DO  i = 1, 6
    k = k + 1
    x(k) = (i-1) / 5.
    y(k) = yk
  END DO
END DO

! COMPUTE THE DATA VALUES.

DO  k = 1, n
  f(k) = fq(x(k),y(k))
END DO

! COMPUTE PARAMETERS DEFINING THE INTERPOLANT Q.

CALL qshep2(n,x,y,f,nq,nw,nr,lcell,lnext,xmin,ymin,dx,dy,rmax,rsq,a,ier)
IF (ier == 0) THEN

! GENERATE A 10 BY 10 UNIFORM GRID OF INTERPOLATION POINTS (P(I),P(J)) IN THE
!   UNIT SQUARE.  THE FOUR CORNERS COINCIDE WITH NODES.

  DO  i = 1, 10
    p(i) = (i-1) / 9.
  END DO

! COMPUTE THE MACHINE PRECISION EPS.

  eps = EPSILON(1.0)

! COMPUTE INTERPOLATION ERRORS AND TEST FOR AGREEMENT IN THE
!   Q VALUES RETURNED BY QS2VAL AND QS2GRD.

  EQ = 0.
  eqx = 0.
  eqy = 0.
  DO  j = 1, 10
    py = p(j)
    DO  i = 1, 10
      px = p(i)
      q1 = qs2val(px,py,n,x,y,f,nr,lcell,lnext,xmin,ymin,dx,dy,rmax,rsq,a)
      CALL qs2grd(px,py,n,x,y,f,nr,lcell,lnext,xmin,ymin,dx,dy,  &
                  rmax,rsq,a,q,qx,qy,ier)
      IF (ier /= 0) GO TO 80
      IF (ABS(q1-q) > 3.*ABS(q)*eps) GO TO 90
      EQ = MAX(EQ,ABS(fq(px,py)-q))
      eqx = MAX(eqx,ABS(fx(px,py)-qx))
      eqy = MAX(eqy,ABS(fy(px,py)-qy))
    END DO
  END DO

! PRINT ERRORS AND THE RATIO EQ/EPS.

  rq = EQ / eps
  WRITE (lout,5000)
  WRITE (lout,5100) EQ, rq
  WRITE (lout,5200) eqx
  WRITE (lout,5300) eqy
  STOP
END IF

! ERROR IN QSHEP2

WRITE (lout,5400) ier
STOP

! ERROR IN QS2GRD

80 WRITE (lout,5500) ier
STOP

! VALUES RETURNED BY QS2VAL AND QS2GRD DIFFER BY A RELATIVE
!   AMOUNT GREATER THAN 3*EPS.

90 WRITE (lout,5600) q1, q
STOP

5000 FORMAT(//' ','MAXIMUM ABSOLUTE ERRORS IN THE INTERPOLANT Q AND PARTIAL'/ &
            ' DERIVATIVES QX AND QY RELATIVE TO MACHINE PRECISION EPS'//  &
            t12, 'FUNCTION   MAX ERROR   MAX ERROR/EPS'/)
5100 FORMAT (t15, 'Q       ', e9.3, '       ', f4.2)
5200 FORMAT (t15, 'QX      ', e9.3)
5300 FORMAT (t15, 'QY      ', e9.3)
5400 FORMAT (///' *** ERROR IN QSHEP2 -- IER =', i2, ' ***')
5500 FORMAT (///' *** ERROR IN QS2GRD -- IER =', i2, ' ***')
5600 FORMAT (///' *** ERROR -- INTERPOLATED VALUES ',  &
             'Q1 (QS2VAL) AND Q2 (QS2GRD) DIFFER --'//  &
             t7, 'Q1 = ', e21.14, '     Q2 = ', e21.14)

CONTAINS

! QUADRATIC TEST FUNCTION AND PARTIAL DERIVATIVES

! fq(xx,yy) = ((xx + 2.*yy)/3.) ** 2
! fx(xx,yy) = 2. * (xx + 2.*yy) / 9.
! fy(xx,yy) = 4. * (xx + 2.*yy) / 9.

FUNCTION fq(xx, yy) RESULT(fn_val)
REAL, INTENT(IN)  :: xx, yy
REAL              :: fn_val

fn_val = ((xx + 2.*yy)/3.) ** 2
RETURN
END FUNCTION fq

FUNCTION fx(xx, yy) RESULT(fn_val)
REAL, INTENT(IN)  :: xx, yy
REAL              :: fn_val

fn_val = 2. * (xx + 2.*yy) / 9.
RETURN
END FUNCTION fx

FUNCTION fy(xx, yy) RESULT(fn_val)
REAL, INTENT(IN)  :: xx, yy
REAL              :: fn_val

fn_val = 4. * (xx + 2.*yy) / 9.
RETURN
END FUNCTION fy

END PROGRAM qs2test


      SUBROUTINE kendl2(tab,i,j,ip,jp,tau,z,prob)
      INTEGER i,ip,j,jp
      REAL prob,tau,z,tab(ip,jp)
CU    USES erfcc
      INTEGER k,ki,kj,l,li,lj,m1,m2,mm,nn
      REAL en1,en2,pairs,points,s,var,erfcc
      en1=0.
      en2=0.
      s=0.
      nn=i*j
      points=tab(i,j)
      do 12 k=0,nn-2
        ki=k/j
        kj=k-j*ki
        points=points+tab(ki+1,kj+1)
        do 11 l=k+1,nn-1
          li=l/j
          lj=l-j*li
          m1=li-ki
          m2=lj-kj
          mm=m1*m2
          pairs=tab(ki+1,kj+1)*tab(li+1,lj+1)
          if(mm.ne.0)then
            en1=en1+pairs
            en2=en2+pairs
            if(mm.gt.0)then
              s=s+pairs
            else
              s=s-pairs
            endif
          else
            if(m1.ne.0)en1=en1+pairs
            if(m2.ne.0)en2=en2+pairs
          endif
11      continue
12    continue
      tau=s/sqrt(en1*en2)
      var=(4.*points+10.)/(9.*points*(points-1.))
      z=tau/sqrt(var)
      prob=erfcc(abs(z)/1.4142136)
      return
      END

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