C$Procedure      SPHREC ( Spherical to rectangular coordinates )

      SUBROUTINE SPHREC ( R, COLAT, LONG, RECTAN  )

C$ Abstract
C
C     Convert from spherical coordinates to rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   R
      DOUBLE PRECISION   COLAT
      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   RECTAN ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     R          I   Distance of a point from the origin.
C     COLAT      I   Angle of the point from the Z-axis in radians.
C     LONG       I   Angle of the point from the XZ plane in radians.
C     RECTAN     O   Rectangular coordinates of the point.
C
C$ Detailed_Input
C
C     R          Distance of the point from the origin.
C
C     COLAT      Angle between the point and the positive z-axis in
C                radians.
C
C     LONG       Angle of the projection of the point to the XY plane
C                from the positive X-axis in radians. The positive
C                Y-axis is at longitude PI/2 radians.
C
C$ Detailed_Output
C
C     RECTAN     The rectangular coordinates of a point.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the rectangular coordinates of a point
C     whose position is input in spherical coordinates.
C
C     Spherical coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     from the z-axis.  The co-latitude of the positive Z-axis is
C     zero.  The longitude of the posive Y-axis is PI/2 radians.
C
C$ Examples
C
C     Below are two tables.
C
C     Listed in the first table (under R, COLAT and LONG ) are
C     spherical coordinate triples that approximately represent points
C     whose rectangular coordinates are taken from the set {-1, 0, 1}.
C     (Angular quantities are given in degrees.)
C
C     The result of the code fragment
C
C          Use the SPICELIB routine CONVRT to convert the angular
C          quantities to radians
C
C          CALL CONVRT ( COLAT, 'DEGREES', 'RADIANS', LAT  )
C          CALL CONVRT ( LONG,  'DEGREES', 'RADIANS', LONG )
C
C          CALL SPHREC ( R, COLAT, LONG, X )
C
C
C     are listed in the second parallel table under X(1), X(2) and X(3).
C
C       R          COLAT      LONG           X(1)       X(2)     X(3)
C       ----------------------------         --------------------------
C       0.0000     0.0000     0.0000         0.0000     0.0000   0.0000
C       1.0000    90.0000     0.0000         1.0000     0.0000   0.0000
C       1.0000    90.0000    90.0000         0.0000     1.0000   0.0000
C       1.0000     0.0000     0.0000         0.0000     0.0000   1.0000
C       1.0000    90.0000   180.0000        -1.0000     0.0000   0.0000
C       1.0000    90.0000   -90.0000         0.0000    -1.0000   0.0000
C       1.0000   180.0000     0.0000         0.0000     0.0000  -1.0000
C       1.4142    90.0000    45.0000         1.0000     1.0000   0.0000
C       1.4142    45.0000     0.0000         1.0000     0.0000   1.0000
C       1.4142    45.0000    90.0000         0.0000     1.0000   1.0000
C       1.7320    54.7356    45.0000         1.0000     1.0000   1.0000
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.4, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.3, 24-SEP-1997 (WLT)
C
C        The BRIEF I/O section was corrected so that it
C        correctly reflects the inputs and outputs.
C
C-    SPICELIB Version 1.0.2, 12-JUL-1995 (WLT)
C
C        The header documentation was corrected so that longitude
C        now is correctly described as the angle from the
C        XZ plane instead of XY.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     spherical to rectangular coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

C
C     Local Variables
C
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z

C
C     Convert to rectangular coordinates, storing in the results in
C     temporary variables
C
      X = R * DCOS(LONG) * DSIN(COLAT)
      Y = R * DSIN(LONG) * DSIN(COLAT)
      Z = R * DCOS(COLAT)

C
C     Move the results to the output variables
C
      RECTAN(1) = X
      RECTAN(2) = Y
      RECTAN(3) = Z

      RETURN
      END


module linalg
	real :: rate
contains
subroutine matmul(a,b,c,n)
	real, dimension (:,:), allocatable ::  a,b,c
	c=0.d0
	do i=1,n         ! Outer loop is parallelized.
	   do j=1,n      ! inner loops are interchanged
		  do k=1,n   ! new inner loop is vectorized
			 c(j,i)=c(j,i)+a(k,i)*b(j,k)
		  enddo
	   enddo
	enddo
end

subroutine init_system_clock()
	! First initialize the system_clock
	INTEGER :: cr,cm
	call system_clock(count_rate=cr)
	call system_clock(count_max=cm)
	rate = REAL(cr)
!	WRITE(*,*) "system_clock rate ",rate
end

subroutine init_matrix(a, b, c, n, exec_time)
	real, dimension (:,:), allocatable, intent (in out)  :: a,b,c
	integer, intent (in) :: n
	real :: exec_time
	INTEGER :: c1,c2

	CALL SYSTEM_CLOCK(c1)

	allocate ( a(n,n) )
	allocate ( b(n,n) )
	allocate ( c(n,n) )

	call RANDOM_NUMBER(a)
	call RANDOM_NUMBER(b)

	call SYSTEM_CLOCK(c2)

	exec_time = (c2 - c1)/rate
end

subroutine matmul_bench(a, b, c, n, exec_time)
	real, dimension (:,:), allocatable, intent (in out)  :: a,b,c
	integer, intent (in) :: n
	real :: exec_time
	INTEGER :: c1,c2

	call SYSTEM_CLOCK(c1)

	call matmul(a,b,c,n)

	call SYSTEM_CLOCK(c2)

	exec_time = (c2 - c1)/rate

end

subroutine matmul_benchmark(n, exec_time)
	real, dimension (:,:), allocatable :: a,b,c
	integer, intent (in) :: n
	real :: exec_time

	call  init_system_clock()
    call init_matrix(a, b, c, n, exec_time)
    call matmul_bench(a, b, c, n, exec_time)

end

end module linalg


!Slide a window by one point to determine outliers/bad data
!Input:
!       ai: array in to remove bad data from
!       ws: Window size to slide through ai
!       sigma: the factor of sigma to remove outliers outside of the range
!       fill: the fill value to replace outlier values with
!             special value fill=-2.379152e33 fills with median value
!Output:
!       ao: array that has all outliers removed from ai

subroutine hampel(ai, ao, nt, ws, numdev, fill)
   implicit none
   real, intent(in) :: fill
   integer*8, intent(in) :: nt, ws, numdev
   double precision, intent(in), dimension(nt) :: ai
   double precision, intent(out), dimension(nt) :: ao
   double precision :: X0, tmp(2*ws+1), L, S0, nan_median
   integer*8 :: i, cntr, win
   L=1.4286
   win=2*ws+1
   ao=ai
   do i=1+ws,nt-ws
      call dropna(ai(i-ws:i+ws),win,tmp,cntr)
      if (cntr .eq. 0) then
         cycle
      else
         X0 = nan_median(ai(i-ws:i+ws),win)
         S0 = L*nan_median(abs(ai(i-ws:i+ws)-X0),win)
         if (abs(ai(i)-X0) .gt. numdev*S0) then
            if (fill .eq. -2.379152e33) then
               ao(i) = X0
            else
               ao(i) = fill
            endif
         endif
      endif
   enddo
end subroutine


module funcs_mod
implicit none
private
public :: wp, f_real_real, square, cube
integer, parameter :: wp = kind(1.0d0)
!
interface ! defines a function signature
   pure function f_real_real(x) result(y)
   import wp
   implicit none
   real(kind=wp), intent(in) :: x
   real(kind=wp)             :: y
   end function f_real_real
end interface
!
contains
!
pure function square(x) result(y)
real(kind=wp), intent(in) :: x
real(kind=wp)             :: y
y = x**2
end function square
!
pure function cube(x) result(y)
real(kind=wp), intent(in) :: x
real(kind=wp)             :: y
y = x**3
end function cube
!
end module funcs_mod

module integral_mod
use funcs_mod, only: wp, f_real_real
implicit none
private
public :: integral
contains
!
pure function integral(f,a,b,n) result(y)
procedure(f_real_real)    :: f
! f can be any function with f_real_real signature
real(kind=wp), intent(in) :: a,b
integer      , intent(in) :: n
real(kind=wp)             :: y
integer                   :: i
real(kind=wp)             :: x,h,fsum
h = (b-a)/(n-1)
x = a
fsum = 0.0
do i=1,n
   if (i == 1 .or. i == n) then
      fsum = fsum + f(x)/2
   else
      fsum = fsum + f(x)
   end if
   x = x + h
end do
y = h*fsum
end function integral
!
end module integral_mod
!
program test_procedure_arg
use integral_mod, only: integral
use funcs_mod   , only: wp, square, cube
implicit none
real(kind=wp) :: a,b
integer       :: n
n = 10**6
a = 0.0_wp
b = 10.0_wp
print "(*(f12.6))", integral(square,a,b,n),integral(cube,a,b,n)
end program test_procedure_arg
! output:
!  333.333333 2500.000000


      SUBROUTINE BDAT03
C
C     THIS SUBROUTINE PROCESSES TRANS BULK DATA, GENERATES THE
C     TRANSFORMATION MATRIX, AND WRITES TO SCBDAT.
C
      EXTERNAL        RSHIFT,ANDF
      LOGICAL         TDAT
      INTEGER         BUF1,TRANS(2),GEOM4,COMBO,AAA(2),OUTT,BUF2,BUF4,
     1                ANDF,RSHIFT,IHD(10),Z
      DIMENSION       TEMP(9),XAX(3),YAX(3),ZAX(3),V2(3),OUT(9)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /CMB001/ SCR1,SCR2,SCBDAT,SCSFIL,SCCONN,SCMCON,SCTOC,
     1                GEOM4,CASECC
      COMMON /ZZZZZZ/ Z(1)
      COMMON /CMB002/ BUF1,BUF2,BUF3,BUF4,BUF5,SCORE,LCORE,INTP,OUTT
      COMMON /CMB003/ COMBO(7,5),CONSET,IAUTO,TOLER,NPSUB,CONECT,TRAN,
     1                MCON,RESTCT(7,7),ISORT,ORIGIN(7,3),IPRINT
      COMMON /OUTPUT/ ITITL(96),IHEAD(96)
      COMMON /SYSTEM/ XXX,IOT,JUNK(6),NLPP,JUNK1(2),LINE,JUNK2(2),
     1                IDAT(3)
      COMMON /CMB004/ TDAT(6)
      COMMON /BLANK / STEP,IDRY
      DATA    IHD   / 4H  SU , 4HMMAR , 4HY OF , 4H PRO  , 4HCESS    ,
     1                4HED T , 4HRANS , 4H BUL , 4HK DA  , 4HTA      /
      DATA    TRANS / 310,3 /,    AAA / 4HBDAT,4H03   /  ,
     1        IBLNK / 4H    /
C
      NGTRN = Z(BUF4)
      INUM  = 1
      IERR  = 0
      DO 10 I = 1,7
      DO 10 J = 1,3
      ORIGIN(I,J) = 0.0
   10 CONTINUE
      DO 20 I = 1,96
      IHEAD(I) = IBLNK
   20 CONTINUE
      J = 1
      DO 30 I = 76,85
      IHEAD(I) = IHD(J)
   30 J = J + 1
      CALL LOCATE (*220,Z(BUF1),TRANS(1),FLAG)
      IFILE = GEOM4
   40 CALL READ (*300,*130,GEOM4,ID,1,0,N)
      DO 50 I = 1,NPSUB
      IT = 1
      IF (ID .EQ. COMBO(I,3)) GO TO 80
   50 CONTINUE
      IF (NGTRN .EQ. 0) GO TO 70
      DO 60 I = 1,NGTRN
      IT = 2
      IF (ID .EQ. Z(BUF4+I)) GO TO 80
   60 CONTINUE
   70 CONTINUE
      CALL READ (*300,*310,GEOM4,TEMP,-9,0,NNN)
      GO TO 40
   80 TDAT(3) = .TRUE.
      IF (IT .EQ. 1) COMBO(I,3) = -COMBO(I,3)
      IF (IT .EQ. 2)  Z(BUF4+I) = -Z(BUF4+I)
      CALL READ (*300,*310,GEOM4,TEMP,9,0,NNN)
      IF (IT .NE. 1) GO TO 100
      DO 90 LL = 1,3
      ORIGIN(I,LL) = TEMP(LL)
   90 CONTINUE
  100 CONTINUE
C
C     DEFINE Z-AXIS
C
      ZAX(1) = TEMP(4) - TEMP(1)
      ZAX(2) = TEMP(5) - TEMP(2)
      ZAX(3) = TEMP(6) - TEMP(3)
C
C     DEFINE Y-AXIS
C
      V2(1)  = TEMP(7) - TEMP(1)
      V2(2)  = TEMP(8) - TEMP(2)
      V2(3)  = TEMP(9) - TEMP(3)
      YAX(1) = ZAX(2)*V2(3) - ZAX(3)*V2(2)
      YAX(2) = ZAX(3)*V2(1) - ZAX(1)*V2(3)
      YAX(3) = ZAX(1)*V2(2) - ZAX(2)*V2(1)
C
C     DEFINE X-AXIS
C
      XAX(1) = YAX(2)*ZAX(3) - ZAX(2)*YAX(3)
      XAX(2) = YAX(3)*ZAX(1) - ZAX(3)*YAX(1)
      XAX(3) = YAX(1)*ZAX(2) - ZAX(1)*YAX(2)
C
C     CHANGE TO UNIT VECTORS
C
      ZMAG = SQRT(ZAX(1)**2 + ZAX(2)**2 + ZAX(3)**2)
      YMAG = SQRT(YAX(1)**2 + YAX(2)**2 + YAX(3)**2)
      XMAG = SQRT(XAX(1)**2 + XAX(2)**2 + XAX(3)**2)
      DO 110 I = 1,3
      ZAX(I) = ZAX(I)/ZMAG
      YAX(I) = YAX(I)/YMAG
      XAX(I) = XAX(I)/XMAG
  110 CONTINUE
      CALL WRITE (SCBDAT,ID,1,0)
      CALL WRITE (SCBDAT, 1,1,0)
      CALL WRITE (SCBDAT,TEMP(1),3,0)
      OUT(1) = XAX(1)
      OUT(2) = YAX(1)
      OUT(3) = ZAX(1)
      OUT(4) = XAX(2)
      OUT(5) = YAX(2)
      OUT(6) = ZAX(2)
      OUT(7) = XAX(3)
      OUT(8) = YAX(3)
      OUT(9) = ZAX(3)
      CALL WRITE (SCBDAT,OUT,9,0)
      IF (ANDF(RSHIFT(IPRINT,6),1) .NE. 1) GO TO 120
      INUM = INUM + 1
      IF (MOD(INUM,2) .EQ. 0) CALL PAGE
      WRITE (OUTT,430) ID
      WRITE (OUTT,440) (TEMP(I),I=1,3)
      WRITE (OUTT,420) ( OUT(I),I=1,9)
  120 CONTINUE
      GO TO 40
  130 CONTINUE
C
C     PROCESS REPEATED GTRAN IDS
C
      IF (NGTRN .LT. 2) GO TO 160
      NGTRN1 = NGTRN - 1
      DO 150 I = 1,NGTRN1
      IF (Z(BUF4+I) .GE. 0) GO TO 150
      KK = I + 1
      DO 140 J = KK,NGTRN
      IF (IABS(Z(BUF4+I)) .EQ. Z(BUF4+J)) Z(BUF4+J) = -Z(BUF4+J)
  140 CONTINUE
  150 CONTINUE
  160 NPM1 = NPSUB - 1
      DO 190 I = 1,NPM1
      IF (COMBO(I,3) .GE. 0) GO TO 190
      KK = I + 1
      DO 180 J = KK,NPSUB
      IF (IABS(COMBO(I,3)) .NE. COMBO(J,3)) GO TO 180
      COMBO(J,3) = -COMBO(J,3)
      DO 170 JDH = 1,3
      ORIGIN(J,JDH) = ORIGIN(I,JDH)
  170 CONTINUE
  180 CONTINUE
  190 CONTINUE
C
C     TEST TO SEE THAT ALL TRANS HAVE BEEN FOUND
C
      DO 200 I = 1,NPSUB
      IF (COMBO(I,3) .LE. 0) GO TO 200
      IERR = 1
      WRITE (OUTT,400) UFM,COMBO(I,3)
  200 CONTINUE
      IF (NGTRN .EQ. 0) GO TO 220
      DO 210 I = 1,NGTRN
      IF (Z(BUF4+I) .LE. 0) GO TO 210
      IERR = 1
      WRITE (OUTT,410) UFM,Z(BUF4+I)
  210 CONTINUE
  220 CALL EOF (SCBDAT)
      CALL WRITE (SCBDAT,ID,1,1)
      CALL CLOSE (SCBDAT,1)
      DO 230 I = 1,NPSUB
      COMBO(I,3) = IABS(COMBO(I,3))
  230 CONTINUE
      IF (IERR .EQ. 1) IDRY = -2
      RETURN
C
  300 IMSG = -2
      GO TO 320
  310 IMSG = -3
  320 CALL MESAGE (IMSG,IFILE,AAA)
      RETURN
C
  400 FORMAT (A23,' 6511, THE REQUESTED TRANS SET ID',I9,
     1       ' HAS NOT BEEN DEFINED BY BULK DATA.')
  410 FORMAT (A23,' 6513, THE TRANS SET ID',I9,' REQUESTED BY A GTRAN ',
     1       'BULK DATA CARD HAS NOT BEEN DEFINED.')
  420 FORMAT (43X,5H*****,42X,5H*****, /3(43X,1H*,50X,1H*, /43X,1H*,1X,
     1       3E15.6,4X,1H*,/),43X,1H*,50X,1H*, /43X,5H*****,42X,5H*****)
  430 FORMAT (//48X,34HTRANS SET IDENTIFICATION NUMBER = ,I8)
  440 FORMAT ( /50X,37HCOORDINATES OF ORIGIN IN BASIC SYSTEM ,
     1         /45X,3E15.6, //58X,21HTRANSFORMATION MATRIX/)
      END


SUBROUTINE BuildStencilsGridX(alpha,order,x,DiffStencils,Nx,Ny)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: rank, alpha, Nx, Ny, order, Diff, i
REAL(KIND=long), DIMENSION(:), ALLOCATABLE   :: Stencil, tmpStencil
!INTEGER, DIMENSION(:), ALLOCATABLE   		 :: idx
INTEGER :: idx(2*alpha+1)
REAL(KIND=long), DIMENSION(:,:), ALLOCATABLE :: c
REAL(KIND=long), DIMENSION(Nx,2*alpha+1)     :: DiffStencils
REAL(KIND=long), DIMENSION(Nx,Ny)            :: x
REAL(KIND=long)                              :: x0
rank = 2*alpha+1
ALLOCATE( Stencil(rank)    )
ALLOCATE( tmpStencil(rank) )
ALLOCATE( c(rank,order+1)  )
IF (Nx==1 .AND. order==0) THEN
    ! Direct interpolation
	Stencil           = zero
	Stencil(alpha+1)  = one
	DiffStencils(1,:) = Stencil
ELSE IF (Nx==1 .AND. order>0) THEN
    ! For a stencil of one point, the derivative is zero
	Stencil           = zero
	Stencil(alpha+1)  = zero
	DiffStencils(1,:) = Stencil
ELSE
!	ALLOCATE( idx(rank) )
	DO i=-alpha,alpha,1
		idx(i+alpha+1) = i
	END DO
	DO i = 1 , alpha
		Diff = alpha-i+1
		! Expansion point where the approximation is to be defined
		x0 = x(i,1) ! FIXME: y-index fixed

		! Determine local finite difference stencil coefficients
		CALL weights(x0,x(i+idx+Diff,1),rank-1,rank-1,order,c) ! FIXME: y-index fixed
		Stencil    = c(1:rank,order+1)
		DiffStencils(i,:) = Stencil
	END DO
	DO i = alpha+1 , Nx-alpha
		! Expansion point where the approximation is to be defined
		x0 = x(i,1) ! FIXME: y-index fixed

		! Determine local finite difference stencil coefficients
		! FIXME: put his outside loop if we do not need flexible grids (e.g. in the case of transformation to an equi-distant grid)
		CALL weights(x0,x(i+idx,1),rank-1,rank-1,order,c) ! FIXME: y-index fixed
		Stencil    = c(1:rank,order+1)
		DiffStencils(i,:) = Stencil
	END DO
	DO i = Nx-alpha+1 , Nx
		Diff = (Nx-alpha)-i
		! Expansion point where the approximation is to be defined
		x0 = x(i,1) ! FIXME: y-index fixed

		! Determine local finite difference stencil coefficients
		CALL weights(x0,x(i+idx+Diff,1),rank-1,rank-1,order,c) ! FIXME: y-index fixed
		Stencil    = c(1:rank,order+1)
		DiffStencils(i,:) = Stencil
	END DO
ENDIF
DEALLOCATE(Stencil,tmpStencil,c)

END SUBROUTINE BuildStencilsGridX


*DECK FC
      SUBROUTINE FC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT,
     +   NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, W, IW)
C***BEGIN PROLOGUE  FC
C***PURPOSE  Fit a piecewise polynomial curve to discrete data.
C            The piecewise polynomials are represented as B-splines.
C            The fitting is done in a weighted least squares sense.
C            Equality and inequality constraints can be imposed on the
C            fitted curve.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A1, K1A2A, L8A3
C***TYPE      SINGLE PRECISION (FC-S, DFC-D)
C***KEYWORDS  B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING,
C             WEIGHTED LEAST SQUARES
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C      This subprogram fits a piecewise polynomial curve
C      to discrete data.  The piecewise polynomials are
C      represented as B-splines.
C      The fitting is done in a weighted least squares sense.
C      Equality and inequality constraints can be imposed on the
C      fitted curve.
C
C      For a description of the B-splines and usage instructions to
C      evaluate them, see
C
C      C. W. de Boor, Package for Calculating with B-Splines.
C                     SIAM J. Numer. Anal., p. 441, (June, 1977).
C
C      For further documentation and discussion of constrained
C      curve fitting using B-splines, see
C
C      R. J. Hanson, Constrained Least Squares Curve Fitting
C                   to Discrete Data Using B-Splines, a User's
C                   Guide. Sandia Labs. Tech. Rept. SAND-78-1291,
C                   December, (1978).
C
C  Input..
C      NDATA,XDATA(*),
C      YDATA(*),
C      SDDATA(*)
C                         The NDATA discrete (X,Y) pairs and the Y value
C                         standard deviation or uncertainty, SD, are in
C                         the respective arrays XDATA(*), YDATA(*), and
C                         SDDATA(*).  No sorting of XDATA(*) is
C                         required.  Any non-negative value of NDATA is
C                         allowed.  A negative value of NDATA is an
C                         error.  A zero value for any entry of
C                         SDDATA(*) will weight that data point as 1.
C                         Otherwise the weight of that data point is
C                         the reciprocal of this entry.
C
C      NORD,NBKPT,
C      BKPT(*)
C                         The NBKPT knots of the B-spline of order NORD
C                         are in the array BKPT(*).  Normally the
C                         problem data interval will be included between
C                         the limits BKPT(NORD) and BKPT(NBKPT-NORD+1).
C                         The additional end knots BKPT(I),I=1,...,
C                         NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are
C                         required to compute the functions used to fit
C                         the data.  No sorting of BKPT(*) is required.
C                         Internal to  FC( ) the extreme end knots may
C                         be reduced and increased respectively to
C                         accommodate any data values that are exterior
C                         to the given knot values.  The contents of
C                         BKPT(*) is not changed.
C
C                         NORD must be in the range 1 .LE. NORD .LE. 20.
C                         The value of NBKPT must satisfy the condition
C                         NBKPT .GE. 2*NORD.
C                         Other values are considered errors.
C
C                         (The order of the spline is one more than the
C                         degree of the piecewise polynomial defined on
C                         each interval.  This is consistent with the
C                         B-spline package convention.  For example,
C                         NORD=4 when we are using piecewise cubics.)
C
C      NCONST,XCONST(*),
C      YCONST(*),NDERIV(*)
C                         The number of conditions that constrain the
C                         B-spline is NCONST.  A constraint is specified
C                         by an (X,Y) pair in the arrays XCONST(*) and
C                         YCONST(*), and by the type of constraint and
C                         derivative value encoded in the array
C                         NDERIV(*).  No sorting of XCONST(*) is
C                         required.  The value of NDERIV(*) is
C                         determined as follows.  Suppose the I-th
C                         constraint applies to the J-th derivative
C                         of the B-spline.  (Any non-negative value of
C                         J < NORD is permitted.  In particular the
C                         value J=0 refers to the B-spline itself.)
C                         For this I-th constraint, set
C                          XCONST(I)=X,
C                          YCONST(I)=Y, and
C                          NDERIV(I)=ITYPE+4*J, where
C
C                          ITYPE = 0,      if (J-th deriv. at X) .LE. Y.
C                                = 1,      if (J-th deriv. at X) .GE. Y.
C                                = 2,      if (J-th deriv. at X) .EQ. Y.
C                                = 3,      if (J-th deriv. at X) .EQ.
C                                             (J-th deriv. at Y).
C                          (A value of NDERIV(I)=-1 will cause this
C                          constraint to be ignored.  This subprogram
C                          feature is often useful when temporarily
C                          suppressing a constraint while still
C                          retaining the source code of the calling
C                          program.)
C
C        MODE
C                         An input flag that directs the least squares
C                         solution method used by FC( ).
C
C                         The variance function, referred to below,
C                         defines the square of the probable error of
C                         the fitted curve at any point, XVAL.
C                         This feature of  FC( ) allows one to use the
C                         square root of this variance function to
C                         determine a probable error band around the
C                         fitted curve.
C
C                         =1  a new problem.  No variance function.
C
C                         =2  a new problem.  Want variance function.
C
C                         =3  an old problem.  No variance function.
C
C                         =4  an old problem.  Want variance function.
C
C                         Any value of MODE other than 1-4 is an error.
C
C                         The user with a new problem can skip directly
C                         to the description of the input parameters
C                         IW(1), IW(2).
C
C                         If the user correctly specifies the new or old
C                         problem status, the subprogram FC( ) will
C                         perform more efficiently.
C                         By an old problem it is meant that subprogram
C                         FC( ) was last called with this same set of
C                         knots, data points and weights.
C
C                         Another often useful deployment of this old
C                         problem designation can occur when one has
C                         previously obtained a Q-R orthogonal
C                         decomposition of the matrix resulting from
C                         B-spline fitting of data (without constraints)
C                         at the breakpoints BKPT(I), I=1,...,NBKPT.
C                         For example, this matrix could be the result
C                         of sequential accumulation of the least
C                         squares equations for a very large data set.
C                         The user writes this code in a manner
C                         convenient for the application.  For the
C                         discussion here let
C
C                                      N=NBKPT-NORD, and K=N+3
C
C                         Let us assume that an equivalent least squares
C                         system
C
C                                      RC=D
C
C                         has been obtained.  Here R is an N+1 by N
C                         matrix and D is a vector with N+1 components.
C                         The last row of R is zero.  The matrix R is
C                         upper triangular and banded.  At most NORD of
C                         the diagonals are nonzero.
C                         The contents of R and D can be copied to the
C                         working array W(*) as follows.
C
C                         The I-th diagonal of R, which has N-I+1
C                         elements, is copied to W(*) starting at
C
C                                      W((I-1)*K+1),
C
C                         for I=1,...,NORD.
C                         The vector D is copied to W(*) starting at
C
C                                      W(NORD*K+1)
C
C                         The input value used for NDATA is arbitrary
C                         when an old problem is designated.  Because
C                         of the feature of FC( ) that checks the
C                         working storage array lengths, a value not
C                         exceeding NBKPT should be used.  For example,
C                         use NDATA=0.
C
C                         (The constraints or variance function request
C                         can change in each call to FC( ).)  A new
C                         problem is anything other than an old problem.
C
C      IW(1),IW(2)
C                         The amounts of working storage actually
C                         allocated for the working arrays W(*) and
C                         IW(*).  These quantities are compared with the
C                         actual amounts of storage needed in FC( ).
C                         Insufficient storage allocated for either
C                         W(*) or IW(*) is an error.  This feature was
C                         included in FC( ) because misreading the
C                         storage formulas for W(*) and IW(*) might very
C                         well lead to subtle and hard-to-find
C                         programming bugs.
C
C                         The length of W(*) must be at least
C
C                           NB=(NBKPT-NORD+3)*(NORD+1)+
C                               2*MAX(NDATA,NBKPT)+NBKPT+NORD**2
C
C                         Whenever possible the code uses banded matrix
C                         processors BNDACC( ) and BNDSOL( ).  These
C                         are utilized if there are no constraints,
C                         no variance function is required, and there
C                         is sufficient data to uniquely determine the
C                         B-spline coefficients.  If the band processors
C                         cannot be used to determine the solution,
C                         then the constrained least squares code LSEI
C                         is used.  In this case the subprogram requires
C                         an additional block of storage in W(*).  For
C                         the discussion here define the integers NEQCON
C                         and NINCON respectively as the number of
C                         equality (ITYPE=2,3) and inequality
C                         (ITYPE=0,1) constraints imposed on the fitted
C                         curve.  Define
C
C                           L=NBKPT-NORD+1
C
C                         and note that
C
C                           NCONST=NEQCON+NINCON.
C
C                         When the subprogram FC( ) uses LSEI( ) the
C                         length of the working array W(*) must be at
C                         least
C
C                           LW=NB+(L+NCONST)*L+
C                              2*(NEQCON+L)+(NINCON+L)+(NINCON+2)*(L+6)
C
C                         The length of the array IW(*) must be at least
C
C                           IW1=NINCON+2*L
C
C                         in any case.
C
C  Output..
C      MODE
C                         An output flag that indicates the status
C                         of the constrained curve fit.
C
C                         =-1  a usage error of FC( ) occurred.  The
C                              offending condition is noted with the
C                              SLATEC library error processor, XERMSG.
C                              In case the working arrays W(*) or IW(*)
C                              are not long enough, the minimal
C                              acceptable length is printed.
C
C                         = 0  successful constrained curve fit.
C
C                         = 1  the requested equality constraints
C                              are contradictory.
C
C                         = 2  the requested inequality constraints
C                              are contradictory.
C
C                         = 3  both equality and inequality constraints
C                              are contradictory.
C
C      COEFF(*)
C                         If the output value of MODE=0 or 1, this array
C                         contains the unknowns obtained from the least
C                         squares fitting process.  These N=NBKPT-NORD
C                         parameters are the B-spline coefficients.
C                         For MODE=1, the equality constraints are
C                         contradictory.  To make the fitting process
C                         more robust, the equality constraints are
C                         satisfied in a least squares sense.  In this
C                         case the array COEFF(*) contains B-spline
C                         coefficients for this extended concept of a
C                         solution.  If MODE=-1,2 or 3 on output, the
C                         array COEFF(*) is undefined.
C
C  Working Arrays..
C      W(*),IW(*)
C                         These arrays are respectively typed REAL and
C                         INTEGER.
C                         Their required lengths are specified as input
C                         parameters in IW(1), IW(2) noted above.  The
C                         contents of W(*) must not be modified by the
C                         user if the variance function is desired.
C
C  Evaluating the
C  Variance Function..
C                         To evaluate the variance function (assuming
C                         that the uncertainties of the Y values were
C                         provided to  FC( ) and an input value of
C                         MODE=2 or 4 was used), use the function
C                         subprogram  CV( )
C
C                           VAR=CV(XVAL,NDATA,NCONST,NORD,NBKPT,
C                                  BKPT,W)
C
C                         Here XVAL is the point where the variance is
C                         desired.  The other arguments have the same
C                         meaning as in the usage of FC( ).
C
C                         For those users employing the old problem
C                         designation, let MDATA be the number of data
C                         points in the problem.  (This may be different
C                         from NDATA if the old problem designation
C                         feature was used.)  The value, VAR, should be
C                         multiplied by the quantity
C
C                         REAL(MAX(NDATA-N,1))/MAX(MDATA-N,1)
C
C                         The output of this subprogram is not defined
C                         if an input value of MODE=1 or 3 was used in
C                         FC( ) or if an output value of MODE=-1, 2, or
C                         3 was obtained.  The variance function, except
C                         for the scaling factor noted above, is given
C                         by
C
C                           VAR=(transpose of B(XVAL))*C*B(XVAL)
C
C                         The vector B(XVAL) is the B-spline basis
C                         function values at X=XVAL.
C                         The covariance matrix, C, of the solution
C                         coefficients accounts only for the least
C                         squares equations and the explicitly stated
C                         equality constraints.  This fact must be
C                         considered when interpreting the variance
C                         function from a data fitting problem that has
C                         inequality constraints on the fitted curve.
C
C  Evaluating the
C  Fitted Curve..
C                         To evaluate derivative number IDER at XVAL,
C                         use the function subprogram BVALU( ).
C
C                           F = BVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER,
C                                      XVAL,INBV,WORKB)
C
C                         The output of this subprogram will not be
C                         defined unless an output value of MODE=0 or 1
C                         was obtained from  FC( ), XVAL is in the data
C                         interval, and IDER is nonnegative and .LT.
C                         NORD.
C
C                         The first time BVALU( ) is called, INBV=1
C                         must be specified.  This value of INBV is the
C                         overwritten by BVALU( ).  The array WORKB(*)
C                         must be of length at least 3*NORD, and must
C                         not be the same as the W(*) array used in
C                         the call to FC( ).
C
C                         BVALU( ) expects the breakpoint array BKPT(*)
C                         to be sorted.
C
C***REFERENCES  R. J. Hanson, Constrained least squares curve fitting
C                 to discrete data using B-splines, a users guide,
C                 Report SAND78-1291, Sandia Laboratories, December
C                 1978.
C***ROUTINES CALLED  FCMN
C***REVISION HISTORY  (YYMMDD)
C   780801  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   900510  Convert references to XERRWV to references to XERMSG.  (RWC)
C   900607  Editorial changes to Prologue to make Prologues for EFC,
C           DEFC, FC, and DFC look as much the same as possible.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  FC
      REAL             BKPT(*), COEFF(*), SDDATA(*), W(*), XCONST(*),
     *   XDATA(*), YCONST(*), YDATA(*)
      INTEGER IW(*), MODE, NBKPT, NCONST, NDATA, NDERIV(*), NORD
C
      EXTERNAL FCMN
C
      INTEGER I1, I2, I3, I4, I5, I6, I7, MDG, MDW
C
C***FIRST EXECUTABLE STATEMENT  FC
      MDG = NBKPT - NORD + 3
      MDW = NBKPT - NORD + 1 + NCONST
C                         USAGE IN FCMN( ) OF W(*)..
C     I1,...,I2-1      G(*,*)
C
C     I2,...,I3-1      XTEMP(*)
C
C     I3,...,I4-1      PTEMP(*)
C
C     I4,...,I5-1      BKPT(*) (LOCAL TO FCMN( ))
C
C     I5,...,I6-1      BF(*,*)
C
C     I6,...,I7-1      W(*,*)
C
C     I7,...           WORK(*) FOR LSEI( )
C
      I1 = 1
      I2 = I1 + MDG*(NORD+1)
      I3 = I2 + MAX(NDATA,NBKPT)
      I4 = I3 + MAX(NDATA,NBKPT)
      I5 = I4 + NBKPT
      I6 = I5 + NORD*NORD
      I7 = I6 + MDW*(NBKPT-NORD+1)
      CALL  FCMN(NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, NCONST,
     1   XCONST, YCONST, NDERIV, MODE, COEFF, W(I5), W(I2), W(I3),
     2   W(I4), W(I1), MDG, W(I6), MDW, W(I7), IW)
      RETURN
      END


Module strain_mod
  ! Module for all strain-related calculations

Contains

  Subroutine Strains(F, m, DT, ndir, eps)
    ! The purpose of this subroutine is to calculate the strains (eps, plas12, inel12)
    ! for the given deformation gradient and temperature.
    !
    ! If a nonzero value for R_phi0 is provided, the strains are given in the fiber reference frame

    Use matProp_Mod
    Use forlog_Mod

    ! Arguments
    Type(matProps), intent(IN) :: m
    Double Precision, intent(IN) :: F(3,3)                    ! Deformation gradient
    Double Precision, intent(IN) :: DT                        ! Coefficients of thermal expansion and temperature change
    Integer, intent(IN) :: ndir
    Double Precision, intent(OUT) :: eps(ndir,ndir)           ! GL stain tensor, without plasticity

    ! Locals
    Parameter (zero=0.d0)
    ! -------------------------------------------------------------------- !

    ! Initialize strain tensor
    eps = zero

    ! Calculate the Green-Lagrange strain
    eps = GLStrain(F,ndir)

    ! Account for thermal strains
    If (DT /= zero) Then
      eps(1,1) = eps(1,1) - m%cte(1)*DT
      eps(2,2) = eps(2,2) - m%cte(2)*DT
      eps(3,3) = eps(3,3) - m%cte(3)*DT
    End If

    Return
  End Subroutine Strains

  Pure Function GLStrain(F, ndir)
    ! Computes the Green-Lagrange strain from the deformation gradient

    ! Input
    Double Precision, intent(IN) :: F(3,3)
    Integer, intent(IN) :: ndir

    ! Output
    Double Precision :: GLStrain(ndir,ndir)

    ! Locals
    Double Precision :: eye(ndir,ndir)  ! Identity
    Double Precision, parameter :: zero=0.d0, one=1.d0, half=0.5d0
    ! -------------------------------------------------------------------- !

    ! Initialize identity matrix
    eye = zero; Do I = 1,3; eye(I,I) = one; End Do

    GLStrain = (MATMUL(TRANSPOSE(F), F) - eye)*half

    Return
  End Function GLStrain

End Module strain_mod


MODULE expint_module

  implicit none

  PRIVATE
  PUBLIC :: expint

CONTAINS

  FUNCTION expint( n, x )
    implicit none
    real(8) :: expint
    integer,intent(IN) :: n
    real(8),intent(IN) :: x
    expint=expint_2( x )
!    expint=expint_1( n, x )
  END FUNCTION expint

  FUNCTION expint_2( x )

    implicit none
    real(8) :: expint_2
    real(8),intent(IN) :: x
    real(8),parameter :: euler=0.577215664901532860606512d0
    real(8) :: y,tny,eps,delta
    real(8) :: ai,bi,f0,f1,C0,C1,D0,D1,a0
    integer :: nmax,i,j

    nmax = 100000
    eps  = epsilon(1.0d0)
    tny  = tiny(1.0d0)

    if ( x <= 0.0d0 ) then

       stop "bad argument (stop@expint)"

    else if ( x >= 0.5d0 ) then

       f0 = tny
       C0 = f0
       D0 = 0.0d0
       a0 = 1.0d0

       do i=1,nmax
          bi = x + 2.0d0*i - 1.0d0
          ai = -(i-1)*(i-1) + a0
          D1 = bi + ai*D0
          if ( D1 == 0.0d0 ) D1=tny
          C1 = bi + ai/C0
          if ( C1 == 0.0d0 ) C1=tny
          D1 = 1.0d0/D1
          delta = C1*D1
          f1 = f0*delta
          if ( abs(delta-1.0d0) < eps ) exit
          f0 = f1
          C0 = C1
          D0 = D1
          a0 = 0.0d0
       end do

       if ( i > nmax ) stop "continued fraction is not converged(stop@expint)"

       expint_2 = f1*exp(-x)

    else if ( x < 0.5d0 ) then

       f0 = 0.0d0

       do i=1,nmax

          f1 = f0

          ai = 1.0d0
          do j=1,i
             ai = ai*( -x/dble(j) )
          end do

          f0 = f0 + ai/dble(i)

          if ( abs(f0-f1) < eps ) exit

       end do

       if ( i > nmax ) stop "power series is not converged(stop@expint)"

       expint_2 = - euler - log(x) - f0

    end if

  END FUNCTION expint_2

  function expint_1(n,x) result(expint)
    implicit none
    integer,intent(in) :: n
    real(8),intent(in) :: x
    real(8) :: expint
    integer,parameter :: maxit=200
    real(8),parameter :: esp=1.d-12, big=huge(x)*esp
    real(8),parameter :: euler=0.577215664901532860606512d0
    integer :: i,nm1,j
    real(8) :: a,b,c,d,del,fact,h,arsum

    if ( .not.(n>=0.and.x>=0.d0.and.(x>0.d0.or.n>1)) ) then
       write(*,*) 'Bad arguments in expint.f'
       stop
    end if

    if ( n==0 ) then
       expint=exp(-x)/x
       return
    end if
    nm1=n-1
    if ( x==0.d0 ) then
       expint=1.d0/nm1
    else if ( x>1.d0 ) then
       b=x+n
       c=big
       d=1.d0/b
       h=d
       do i=1,maxit
          a=-i*(nm1+i)
          b=b+2.d0
          d=1.d0/(a*d+b)
          c=b+a/c
          del=c*d
          h=h*del
          if ( abs(del-1.d0)<=esp ) exit
       end do
       if ( i>maxit ) then
          write(*,*) 'Continued fraction failed in expint.f'
          stop
       end if
       expint=h*exp(-x)
    else
       if ( nm1/=0 ) then
          expint=1.d0/nm1
       else
          expint=-log(x)-euler
       end if
       fact=1.d0
       do i=1,maxit
          fact=-fact*x/i
          if ( i/=nm1 ) then
             del=-fact/(i-nm1)
          else
             arsum = 0.d0
             do j=1,nm1
                arsum = arsum + 1.d0/j
             end do
             del = fact*(-LOG(x)-euler+arsum)
          end if
          expint=expint+del
          if ( abs(del)<abs(expint)*esp ) exit
       end do
       if ( i>maxit ) then
          write(*,*) 'series failed in expint.f'
          stop
       end if
    end if

  end function expint_1

END MODULE expint_module


MODULE mod_blas

  IMPLICIT NONE

  INTERFACE

     ! BLAS Level 1 function
     ! Double precision Euclidean norm
     DOUBLE PRECISION FUNCTION DNRM2( n, X, incx )
       INTEGER n, incx
       DOUBLE PRECISION X(*)
     END FUNCTION DNRM2

     ! BLAS Level 2 subroutine
     ! Double precision matrix-vector multiply C = alpha * A x + beta * y
     SUBROUTINE DGEMV( trans, m, n, &
                       alpha, A, lda, &
                              x, incx, &
                       beta,  y, incy )
       CHARACTER*1 trans
       INTEGER m, n, lda, incx, incy
       DOUBLE PRECISION alpha, beta
       DOUBLE PRECISION A(lda,*), X(*), Y(*)
     END SUBROUTINE DGEMV

  END INTERFACE

END MODULE mod_blas


! $UWHPSC/codes/mpi/quadrature/functions_mod.f90

module functions_mod

    ! Define the function we want to integrate.
    ! Also define the indefinite integral (anti-derivative) of g for
    ! use in computing the true solution to compute the error.

    ! The integer gevals can be initialized to 0 in the main program
    ! and then will count how many times the function g is called by each proc.
    ! Note that this is automatically local to each processor!

    ! k is the wave number used in g and gint.

    use mpi
    implicit none
    integer :: gevals
    real(kind=8) :: k
    save

contains

real(kind=8) function g(x)
    ! Test function to integrate
    implicit none
    real(kind=8), intent(in) :: x
    integer :: proc_num, ierr

    g = exp(0.1d0*x) + cos(k*x)
    gevals = gevals + 1

end function g

real(kind=8) function gint(x)
    ! Anti-derivative of g
    implicit none
    real(kind=8), intent(in) :: x
    gint = 10.d0*exp(0.1d0*x) + sin(k*x) / k
end function gint

end module functions_mod


module EquationClass
    use iso_fortran_env
    use MathClass
    implicit none

    type :: Equation_
        real(real64) :: a, b, c, d
        real(real64),allocatable :: x(:)
        logical :: LinearEquation, QuadraticEquation
    contains
        procedure, public :: setup => setupEquation
        procedure, public :: solve => solveEquation
    end type

contains

! ####################################
subroutine setupEquation(obj,LinearEquation,QuadraticEquation,a,b,c,d)
    class(Equation_),intent(inout) :: obj
    logical,optional,intent(in) :: LinearEquation,QuadraticEquation
    real(real64),optional,intent(in) :: a,b,c,d
    obj%LinearEquation=.false.
    obj%QuadraticEquation =.false.

    if(present(LinearEquation) )then
        if(LinearEquation .eqv. .true.)then
            if(allocated(obj%x) )then
                deallocate(obj%x)
            endif
            allocate(obj%x(1))
            obj%LinearEquation=.true.
            !allocate(obj%x(2) )
            obj%a = input(default=0.0d0, option=a)
            obj%b = input(default=0.0d0, option=b)
            print *, "Linear Equation"
            print *, obj%a, "x", "+",obj%b,"= 0"
            ! obj%c = input(default=0.0d0, option=c)
            ! obj%d = input(default=0.0d0, option=d)
            return
        endif
    endif

    if(present(QuadraticEquation))then
        if(QuadraticEquation .eqv. .true.)then
            if(allocated(obj%x) )then
                deallocate(obj%x)
            endif
            allocate(obj%x(2))
            obj%QuadraticEquation=.true.
            obj%a = input(default=0.0d0, option=a)
            obj%b = input(default=0.0d0, option=b)
            obj%c = input(default=0.0d0, option=c)
            print *, "Quadratic Equation"
            print *, obj%a, "x^2", "+",obj%b,"x +",obj%c,"= 0"
        endif
        return
    endif

end subroutine setupEquation
! ####################################

! ####################################
subroutine solveEquation(obj)
    class(Equation_),intent(inout) :: obj
    real(real64) :: Dval

    if(obj%LinearEquation .eqv. .true.)then
        if(obj%a ==0.0d0 .or. obj%a /= obj%a)then
            print *, "solveEquation :: ERROR :: ax +b =0, a=0"
            stop
        else
            obj%x(1) = - obj%b / obj%a
            print *, "x = ", obj%x(1)
        endif
        return
    endif
    if(obj%QuadraticEquation .eqv. .true.)then
        Dval = obj%b * obj%b - 4.0d0*obj%a*obj%c
        if(Dval < 0.0d0)then
            print *, "solveEquation :: ERROR :: D = b^2 - 4 a c < 0"
            stop
        else
            if(Dval == 0.0d0)then
                obj%x =  - obj%b/(2.0d0 * obj%a)
                print *, "x = ", obj%x(1)
            else
                obj%x(1) = (- obj%b + sqrt(Dval))/(2.0d0 * obj%a)
                obj%x(2) = (- obj%b - sqrt(Dval))/(2.0d0 * obj%a)
                print *, "x = ", obj%x(2)
            endif
        endif
        return
    endif
end subroutine
! ####################################

end module EquationClass


!==============================================================================!
  subroutine Surf_Mod_Statistics(surf)
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Surf_Type),  target :: surf
!-----------------------------------[Locals]-----------------------------------!
  type(Vert_Type), pointer :: vert(:)
  type(Elem_Type), pointer :: elem(:)
  type(Side_Type), pointer :: side(:)
  integer,         pointer :: nv, ns, ne
  integer                  :: item, i, j, k, c, d, e, s, v, si, sj, sk
  integer                  :: nne_s, nne_e
  real, allocatable        :: nne(:)
  real                     :: a(3), b(3), tri_v(3)
  real                     :: max_rat, min_rat, max_l, min_l
  character(len=160) :: line
  integer, parameter :: T=33                ! indent
!==============================================================================!

  ! Take aliases
  nv   => surf % n_verts
  ns   => surf % n_sides
  ne   => surf % n_elems
  vert => surf % vert
  side => surf % side
  elem => surf % elem

  !--------------------------!
  !   Compute side lengths   !
  !--------------------------!
  do s = 1, ns
    c = side(s) % c
    d = side(s) % d
    side(s) % length = Math_Mod_Distance(                 &
            vert(c) % x_n, vert(c) % y_n, vert(c) % z_n,  &
            vert(d) % x_n, vert(d) % y_n, vert(d) % z_n)
  end do

  !-----------------------------!
  !   Compute elements' areas   !
  !-----------------------------!
  do e = 1, ne
    i = elem(e) % i
    j = elem(e) % j
    k = elem(e) % k
    a(1) = vert(j) % x_n - vert(i) % x_n
    a(2) = vert(j) % y_n - vert(i) % y_n
    a(3) = vert(j) % z_n - vert(i) % z_n
    b(1) = vert(k) % x_n - vert(i) % x_n
    b(2) = vert(k) % y_n - vert(i) % y_n
    b(3) = vert(k) % z_n - vert(i) % z_n
    tri_v = Math_Mod_Cross_Product(a, b)
    elem(e) % area = sqrt(dot_product(tri_v, tri_v)) * 0.5
  end do

  !------------------------------!
  !   Extreme side size ratios   !
  !------------------------------!
  max_rat = -HUGE
  min_rat = +HUGE
  do e = 1, ne
    si = elem(e) % si
    sj = elem(e) % sj
    sk = elem(e) % sk
    max_l = max(side(si) % length, side(sj) % length, side(sk) % length)
    min_l = min(side(si) % length, side(sj) % length, side(sk) % length)
    max_rat = max(max_rat, max_l/min_l)
    min_rat = min(min_rat, max_l/min_l)
  end do

  !--------------------------------!
  !   Count number of neighbours   !
  !--------------------------------!
  call Surf_Mod_Count_Vertex_Elements(surf)
  nne_s = minval(vert(1:nv) % nne)
  nne_e = maxval(vert(1:nv) % nne)
  allocate(nne(nne_s:nne_e)); nne = 0.0
  do v = 1, nv
    nne(vert(v) % nne) = nne(vert(v) % nne) + 1.0
  end do

  if(this_proc < 2) then

    line( 1:160) = ' '
    line( 1+T:63+T) =   &
               '#=============================================================#'
    print *, trim(line)
    line( 1+T:63+T) =   &
               '#                   Surface mesh statistics                   #'
    print *, trim(line)
    line( 1+T:63+T) =   &
               '#-------------------------------------------------------------#'
    print *, trim(line)

    ! Number of elements (1), nodes (2) and sides (3)
    do item = 1, 3
      line( 1:160) = ' '
      line( 1+T: 1+T) = '#'
      line(63+T:63+T) = '#'
      line( 3+T: 3+T) = '-'
      if(item.eq.1) line( 5+T: 5+T+20) = 'Number of elements: '
      if(item.eq.1) write(line(32+T:37+T), '(i6)') surf % n_elems
      if(item.eq.2) line( 5+T: 5+T+20) = 'Number of vertices: '
      if(item.eq.2) write(line(32+T:37+T), '(i6)') surf % n_verts
      if(item.eq.3) line( 5+T: 5+T+20) = 'Number of sides:    '
      if(item.eq.3) write(line(32+T:37+T), '(i6)') surf % n_sides
      print *, trim(line)
    end do

    line( 1+T:63+T) =  &
               '#-------------------------------------------------------------#'
    print *, trim(line)

    ! Maximum (1) and minimum (2) element area
    ! Maximum (3) and minimum (4) side length
    ! Maximum (5) and minimum (6) side length ratio
    do item = 1, 6
      line( 1:160) = ' '
      line( 1+T: 1+T) = '#'
      line(63+T:63+T) = '#'
      line( 3+T: 3+T) = '-'
      if(item.eq.1) line( 5+T: 5+T+33) = 'Maximum element area:          '
      if(item.eq.1) write(line(36+T:47+T), '(1pe12.5)')  &
                          maxval(elem(1:ne) % area)
      if(item.eq.2) line( 5+T: 5+T+33) = 'Minimum element area:          '
      if(item.eq.2) write(line(36+T:47+T), '(1pe12.5)')  &
                          minval(elem(1:ne) % area)
      if(item.eq.3) line( 5+T: 5+T+33) = 'Maximum side length:           '
      if(item.eq.3) write(line(36+T:47+T), '(1pe12.5)')  &
                          maxval(side(1:ns) % length)
      if(item.eq.4) line( 5+T: 5+T+33) = 'Minimum side length:           '
      if(item.eq.4) write(line(36+T:47+T), '(1pe12.5)')  &
                          minval(side(1:ns) % length)
      if(item.eq.5) line( 5+T: 5+T+33) = 'Maximum side ratio in element: '
      if(item.eq.5) write(line(36+T:47+T), '(1pe12.5)') max_rat
      if(item.eq.6) line( 5+T: 5+T+33) = 'Minimum side ratio in element: '
      if(item.eq.6) write(line(36+T:47+T), '(1pe12.5)') min_rat
      print *, trim(line)
    end do

    line( 1+T:63+T) =  &
               '#-------------------------------------------------------------#'
    print *, trim(line)

    ! Number of neighbours
    do item = nne_s, nne_e
      line( 1:160) = ' '
      line( 1+T: 1+T) = '#'
      line(63+T:63+T) = '#'
      line( 3+T: 3+T) = '-'
      line( 5+T: 5+T+43) = 'Percentage of vertices with XX neighbours: '
      write(line(33+T:34+T), '(i2)') item
      write(line(48+T:53+T), '(f6.2)') nne(item) / nv * 100.0
      line(55+T:55+T) = '%'
      print *, trim(line)
    end do

    line( 1+T:63+T) =  &
               '#-------------------------------------------------------------#'
    print *, trim(line)
    print *, ''

  end if

  end subroutine


module universal_constants
  use kind_parameters, only : rkind
  implicit none

  private
  public :: pi
  public :: atmospheric_pressure

  real(rkind), parameter :: pi = 3.141592654_rkind
  real(rkind), parameter :: atmospheric_pressure = 101325._rkind ! Pascals

end module


!> @brief Finite Difference Approximations module
module FDA
implicit none

contains

  !> @brief Finite Difference Coefficient calculation

  !> Compute coefficients for finite difference approximation for the
  !! derivative of order k at xbar based on grid values at points in xpt.
  !!
  !! @param[in]   xbar   location at which we want to approximate the derivative
  !!                     (may but need not be a grid point)
  !! @param[in]   xpt    grid point locations which the stencil is to extend over
  !!                     (distinct, otherwise arbitrary)
  !! @param[out]  c      weights at grid locations xpt(0:n) for derivatives
  !!                     of order 0:m, found in c(0:n,0:m)
  subroutine FDAFDC(xbar, xpt, c)
    real(kind(0.d0)), intent(in)                    :: xbar
    real(kind(0.d0)), intent(in), dimension(:)      :: xpt
    real(kind(0.d0)), intent(out), dimension(:,:)   :: c

    ! local variables
    real(kind(0.d0))                                :: c1, c2, c3, c4, c5
    integer                                         :: k, j, i, mn, devs

    devs = size(c, dim=2)
    c1 = 1.d0
    c4 = xpt(1)-xbar

    do k = 1, devs
      do j = 1 , size(c, dim=1)
        c(j,k) = 0.d0
      end do
    end do

    c(1,1) = 1.d0
    do i = 2, size(c, dim=1)
      mn = min(i,devs)
      c2 = 1.0d0
      c5 = c4
      c4 = xpt(i) - xbar

      do j = 1, i
        c3 = xpt(i)-xpt(j)
        c2 = c2 * c3

        if ( j .eq. i ) then
          do k = mn, 1, -1
            c(i,k) = c1 * (k * c(i-1,k-1) - c5 * c(i-1,k))/c2
          end do

          c(i,1) = -c1 * c5 * c(i-1,1)/c2
        endif

        do k = mn, 2, -1
          c(j,k) = (c4 * c(j,k) - k * c(j,k-1))/c3
        end do

        c(j,1) = c4 * c(j,1)/c3
      end do

      c1 = c2
    end do

  end subroutine FDAFDC

end module FDA


! ------------------------ begin dcdt -------------------
      subroutine dcdt (y,dt,npts,indx1,indx2,ldc,ldt)
!+
!  dcdt - fits dc or trend between indices indx1 and indx2.
!         then removes dc or detrends whole trace.
!         y is real, dt = delta t.
!         if remove dc, ldc = .true.
!         if detrend, ldt = .true.
!-

! Dates: 12/14/00 - Cleaned up formatting of original program
!        04/28/15 - Replaced comment characters * or C with ! (The Fortran 95 standard)

      real y(*)
      logical ldc,ldt

      if (.not. ldc .and. .not. ldt) then
        return
      end if

!
!...fit dc and trend between indices indx1 and indx2.
      nsum = indx2-indx1+1
      sumx = 0.0
      sumx2 = 0.0
      sumy = 0.0
      sumxy = 0.0
      do i=indx1,indx2
         xsubi = (i-1)*dt
         sumxy = sumxy+xsubi*y(i)
         sumx = sumx+xsubi
         sumx2 = sumx2+xsubi*xsubi
         sumy = sumy+y(i)
      end do
!
!... remove dc.
      if (ldc) then
        avy = sumy/nsum
        do i=1,npts
          y(i) = y(i)-avy
        end do
! Debug
        write(*,'(a)') ' indx1, indx2, avy'
        write(*, *)      indx1, indx2, avy
! Debug

        return
      endif
!
!... detrend. see draper and smith, p. 10.
      if (ldt) then
        bxy = (sumxy-sumx*sumy/nsum)/(sumx2-sumx*sumx/nsum)
        axy = (sumy-bxy*sumx)/nsum
        qxy = dt*bxy
        do i=1,npts
          y(i) = y(i)-(axy+(i-1)*qxy)
        end do
        return
      endif
!
      return
      end
! ------------------------ end dcdt -------------------


program main
  use sho
  implicit none
  integer :: status = 0
  call init
  print*, "Tmax (in seconds)                        : ", sho_tmax
  print*, "Tmax (in binary periods)                 : ", sho_tmax/sho_period
  do while (sho_t.le.sho_tmax)
    call sho_interrupt
    call sho_rk4
    !call sho_collision_test
    if (sho_test == 1) then ! Ends progam if test mass gets too close to accretor
      print*, "Binary Periods completed before collision: ", sho_t/(2.0*sho_pi/omega)
      call exit(status)
    end if
    call sho_update
  end do
    call sho_exit
end program main


!>----------------------------------------
!! Simple program to test and time sorting routines
!!
!! Generates n random numbers, uses heap_sort to sort them,
!!  Then tests that the sort succeeded and prints timing info
!!
!! Next this is repeated for quick_sort.
!!
!! Initial data show that this implementation of quick_sort is ~2x faster than
!!  the (somewhat naive) implementation of heap_sort
!!
!!----------------------------------------
program test_sort
    use sort_mod

    implicit none

    real, parameter :: valid_error = 1e-5
    integer*8, parameter :: n = 1000000

    real, allocatable, dimension(:) :: to_sort, sorted
    integer :: i, start_time, end_time, COUNT_RATE, COUNT_MAX

    allocate(to_sort(n))
    allocate(sorted(n))

    !-------------------------------
    ! SETUP sorting
    !-------------------------------
    call random_number(to_sort)
    sorted=0
    ! test heap_sort (system_clock is used to time how long it takes)

    call system_clock(start_time)
    !-------------------------------
    ! HEAP SORT
    !-------------------------------
    call heap_sort(to_sort, sorted)

    call system_clock(end_time, COUNT_RATE, COUNT_MAX)
    if (start_time>end_time) end_time=end_time+COUNT_MAX

    call show_results(sorted, "HEAP_SORT", (end_time-start_time) / real(COUNT_RATE))

    !-------------------------------
    ! SETUP sorting
    !-------------------------------
    ! now test quick_sort
    call random_number(to_sort)
    sorted = 0

    call system_clock(start_time)
    !-------------------------------
    ! QUICK SORT
    !-------------------------------
    call quick_sort(to_sort, sorted)

    call system_clock(end_time, COUNT_RATE, COUNT_MAX)
    if (start_time>end_time) end_time=end_time+COUNT_MAX

    call show_results(sorted, "QUICK_SORT", (end_time-start_time) / real(COUNT_RATE))

    !-------------------------------
    ! SETUP sorting
    !-------------------------------
    ! now test quick_sort
    call random_number(to_sort)

    call system_clock(start_time)
    !-------------------------------
    ! QUICK SORT in place
    !-------------------------------
    call sort(to_sort)

    call system_clock(end_time, COUNT_RATE, COUNT_MAX)
    if (start_time>end_time) end_time=end_time+COUNT_MAX

    call show_results(to_sort, "QUICK_SORT (in place)", (end_time-start_time) / real(COUNT_RATE))

contains
    !>--------------------------
    !! Print out results from a given sort test
    !!
    !!--------------------------
    subroutine show_results(data, name, time)
        implicit none
        real, dimension(:), intent(in) :: data
        character(len=*),   intent(in) :: name
        real,               intent(in) :: time

        integer :: i, n, err

        n = size(data)

        print*, "---------------------------"
        err = 0
        do i=1,n-1
            if (sorted(i+1)<sorted(i)) then
                err = 1
            endif
        end do
        print*, trim(name)
        if ( err < valid_error ) then
            print*, "  PASSED"
        else
            print*, "  FAILED:", err
        endif
        print*, "---------------------------"
        print*, "   Elapsed time = ", time

    end subroutine show_results

end program test_sort


! { dg-do run }
! Tests the fix for PR31994, aka 31867, in which the offset
! of 'a' in both subroutines was being evaluated incorrectly.
! The testcase for PR31867 is char_length_5.f90
!
! Contributed by Elizabeth Yip <elizabeth.l.yip@boeing.com>
!            and Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
program main
  call PR31994
  call PR31994_comment6
contains
  subroutine PR31994
    implicit none
    complex (kind=4), dimension(2,2) :: a, b, c
    a(1,1) = (1.,1.)
    a(2,1) = (2.,2.)
    a(1,2) = (3.,3.)
    a(2,2) = (4.,4.)
    b=conjg (transpose (a))
    c=transpose (a)
    c=conjg (c)
    if (any (b .ne. c)) STOP 1
  end subroutine PR31994
  subroutine PR31994_comment6
    implicit none
    real ,dimension(2,2)::a
    integer ,dimension(2,2) :: b, c
    a = reshape ((/1.,2.,3.,4./), (/2,2/))
    b=int (transpose(a))
    c = int (a)
    c = transpose (c)
    if (any (b .ne. c)) STOP 2
  end subroutine PR31994_comment6
END program main


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.
    ! This default version simply sets eta = max(h + b,0)

    ! For more specific initial conditions
    !  copy this to an application directory and
    !  loop over all grid cells to set values of q(1:meqn, 1:mx).

    use geoclaw_module, only: grav  !uncomment if needed
    use grid_module, only: xgrid,zgrid,mx_grid

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i
    real(kind=8) :: xcell,x0,width,eta

    x0 = -60.d3   ! initial location of step
    width = 30.e3

    do i=1,mx
      xcell = 0.5*(xgrid(i) + xgrid(i+1))
      !if (xcell > x0) then
      if ((xcell < x0-width) .or. (xcell > x0)) then
          eta = 0.d0
        else
          eta = 1.d0
        endif
      q(1,i) = max(0.0, eta - aux(1,i))
      q(2,i) = eta*sqrt(grav*q(1,i))  ! right-going

   enddo

end subroutine qinit


      SUBROUTINE slDMAT (N, A, Y, D, JF, IW)
*+
*     - - - - -
*      D M A T
*     - - - - -
*
*  Matrix inversion & solution of simultaneous equations
*  (double precision)
*
*  For the set of n simultaneous equations in n unknowns:
*     A.Y = X
*
*  where:
*     A is a non-singular N x N matrix
*     Y is the vector of N unknowns
*     X is the known vector
*
*  DMATRX computes:
*     the inverse of matrix A
*     the determinant of matrix A
*     the vector of N unknowns
*
*  Arguments:
*
*     symbol  type   dimension           before              after
*
*       N      i                    no. of unknowns       unchanged
*       A      d      (N,N)             matrix             inverse
*       Y      d       (N)            known vector      solution vector
*       D      d                           -             determinant
*     * JF     i                           -           singularity flag
*       IW     i       (N)                 -              workspace
*
*  * JF is the singularity flag.  If the matrix is non-singular, JF=0
*    is returned.  If the matrix is singular, JF=-1 & D=0D0 are
*    returned.  In the latter case, the contents of array A on return
*    are undefined.
*
*  Algorithm:
*     Gaussian elimination with partial pivoting.
*
*  Speed:
*     Very fast.
*
*  Accuracy:
*     Fairly accurate - errors 1 to 4 times those of routines optimized
*     for accuracy.
*
*  P.T.Wallace   Starlink   4 December 2001
*
*  Copyright (C) 2001 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

      INTEGER N
      DOUBLE PRECISION A(N,N),Y(N),D
      INTEGER JF
      INTEGER IW(N)

      DOUBLE PRECISION SFA
      PARAMETER (SFA=1D-20)

      INTEGER K,IMX,I,J,NP1MK,KI
      DOUBLE PRECISION AMX,T,AKK,YK,AIK

      JF=0
      D=1D0
      DO K=1,N
         AMX=DABS(A(K,K))
         IMX=K
         IF (K.NE.N) THEN
            DO I=K+1,N
               T=DABS(A(I,K))
               IF (T.GT.AMX) THEN
                  AMX=T
                  IMX=I
               END IF
            END DO
         END IF
         IF (AMX.LT.SFA) THEN
            JF=-1
         ELSE
            IF (IMX.NE.K) THEN
               DO J=1,N
                  T=A(K,J)
                  A(K,J)=A(IMX,J)
                  A(IMX,J)=T
               END DO
               T=Y(K)
               Y(K)=Y(IMX)
               Y(IMX)=T
               D=-D
            END IF
            IW(K)=IMX
            AKK=A(K,K)
            D=D*AKK
            IF (DABS(D).LT.SFA) THEN
               JF=-1
            ELSE
               AKK=1D0/AKK
               A(K,K)=AKK
               DO J=1,N
                  IF (J.NE.K) A(K,J)=A(K,J)*AKK
               END DO
               YK=Y(K)*AKK
               Y(K)=YK
               DO I=1,N
                  AIK=A(I,K)
                  IF (I.NE.K) THEN
                     DO J=1,N
                        IF (J.NE.K) A(I,J)=A(I,J)-AIK*A(K,J)
                     END DO
                     Y(I)=Y(I)-AIK*YK
                  END IF
               END DO
               DO I=1,N
                  IF (I.NE.K) A(I,K)=-A(I,K)*AKK
               END DO
            END IF
         END IF
      END DO
      IF (JF.NE.0) THEN
         D=0D0
      ELSE
         DO K=1,N
            NP1MK=N+1-K
            KI=IW(NP1MK)
            IF (NP1MK.NE.KI) THEN
               DO I=1,N
                  T=A(I,NP1MK)
                  A(I,NP1MK)=A(I,KI)
                  A(I,KI)=T
               END DO
            END IF
         END DO
      END IF

      END


!> \file mo_standard_score.f90

!> \brief Routines for calculating the normalization (anomaly)/standard score/z score and the
!>        deseasonalized (standard score on monthly basis) values of a time series.

!> \details In environmental research often the centralization and standardization are estimated
!>          for characterizing the dynamics of a signal.

!> \author Matthias Zink
!> \date May 2015

MODULE mo_standard_score

  ! This module contains routines for the masked calculation of
  ! the standard_score of a time series (centralized and standardized time series).

  ! Written May 2015, Matthias Zink

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2015 Matthias Zink
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: i4, sp, dp

  IMPLICIT NONE

  PUBLIC :: standard_score                 ! standard score of a population
  PUBLIC :: classified_standard_score      ! standard score for classes of a population (e.g. classes=months)

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

  !     NAME
  !         standard_score

  !     PURPOSE
  !>         \brief    Calculates the standard score / normalization (anomaly) / z-score.
  !>         \details  In statistics, the standard score is the (signed) number of standard deviations an observation
  !>           or datum is above the mean. Thus, a positive standard score indicates a datum above the mean,
  !>           while a negative standard score indicates a datum below the mean.
  !>           It is a dimensionless quantity obtained by subtracting the population mean from
  !>           an individual raw score and then dividing the difference by the population standard deviation.
  !>           This conversion process is called standardizing or normalizing (however, "normalizing" can
  !>           refer to many types of ratios).\n
  !>           Standard scores are also called z-values, z-scores, normal scores, and standardized variables; the use
  !>           of "Z" is because the normal distribution is also known as the "Z distribution". They are most frequently
  !>           used to compare a sample to a standard normal deviate, though they can be defined without assumptions of
  !>           normality (Wikipedia, May 2015).
  !>
  !>          \f[ standard\_score = \frac{x - \mu_x}{\sigma_x} \f]
  !>           where \f$ \mu_x \f$ is the mean of a population \f$ x \f$ and \f$ \sigma_x \f$ its standard deviation.
  !>
  !>           If an optional mask is given, the calculations are over those locations that correspond
  !>           to true values in the mask.

  !     CALLING SEQUENCE
  !         out = standard_score(data, mask=mask)

  !     INDENT(IN)
  !>        \param[in] "real(sp/dp), dimension(:) :: data" data to calculate the standard score for

  !     INDENT(INOUT)
  !         None

  !     INDENT(OUT)
  !        None

  !     INDENT(IN), OPTIONAL
  !>        \param[in] "logical, dimension(:),optinal :: mask" indication which cells to use for calculation
  !>           If present, only those locations in mask having true values in mask are evaluated.

  !     INDENT(INOUT), OPTIONAL
  !         None

  !     INDENT(OUT), OPTIONAL
  !         None

  !     RETURN
  !>        \return real(sp/dp) :: standard_score — standard score / normalization (anomaly) / z-score

  !     RESTRICTIONS
  !         Input values must be floating points.

  !     EXAMPLE
  !         data = (/ 1., 2, 3., -999., 5., 6. /)
  !         out  = standard_score(data, mask=(data >= 0.))
  !         -> see also example in test directory

  !     LITERATURE
  !>         \note Richard J. Larsen and Morris L. Marx (2000) An Introduction to Mathematical Statistics and Its
  !>            Applications, Third Edition, ISBN 0-13-922303-7. p. 282.

  !     HISTORY
  !>         \author Matthias Zink
  !>         \date   May 2015

  INTERFACE standard_score
     MODULE PROCEDURE standard_score_sp, standard_score_dp
  END INTERFACE standard_score

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

  !     NAME
  !         classified_standard_score

  !     PURPOSE
  !>         \brief    Calculates the  classified standard score (e.g. classes are months).
  !>         \details  In statistics, the standard score is the (signed) number of standard deviations an observation
  !>           or datum is above the mean. Thus, a positive standard score indicates a datum above the mean,
  !>           while a negative standard score indicates a datum below the mean.
  !>           It is a dimensionless quantity obtained by subtracting the population mean from
  !>           an individual raw score and then dividing the difference by the population standard deviation.
  !>           This conversion process is called standardizing or normalizing (however, "normalizing" can
  !>           refer to many types of ratios).\n
  !>           Standard scores are also called z-values, z-scores, normal scores, and standardized variables; the use
  !>           of "Z" is because the normal distribution is also known as the "Z distribution". They are most frequently
  !>           used to compare a sample to a standard normal deviate, though they can be defined without assumptions of
  !>           normality (Wikipedia, May 2015).\n
  !>           In this particular case the standard score is calculated for means and standard deviations derived from
  !>           classes of the time series. Such classes could be for example months. Thus, the output would be a
  !>           deseasonalized time series.
  !>
  !>          \f[ classified\_standard\_score = \frac{x_i - \mu_{c_{x_i}}}{\sigma_{c_{x_i}}} \f]
  !>           where \f$ x_i \f$ is an element of class \f$ c_{x_i} \f$. \f$ x \f$ is a population, \f$ \mu_{c_{x_i}} \f$
  !>           is the mean of all members of a class \f$ c_{x_i} \f$ and \f$ \sigma_{c_{x_i}} \f$ its standard deviation.
  !>
  !>           If an optinal mask is given, the calculations are over those locations that correspond to true values in the mask.

  !     CALLING SEQUENCE
  !         out = classified_standard_score(data, mask=mask)

  !     INDENT(IN)
  !>        \param[in] "integer,     dimension(:) :: classes" classes to categorize data (e.g. months)
  !>        \param[in] "real(sp/dp), dimension(:) :: data"    data to calculate the standard score for

  !     INDENT(INOUT)
  !         None

  !     INDENT(OUT)
  !        None

  !     INDENT(IN), OPTIONAL
  !>        \param[in] "logical, dimension(:), optional :: mask" indication which cells to use for calculation
  !>           If present, only those locations in mask having true values in mask are evaluated.

  !     INDENT(INOUT), OPTIONAL
  !         None

  !     INDENT(OUT), OPTIONAL
  !         None

  !     RETURN
  !>        \return real(sp/dp) :: classified_standard_score — classified standard score (e.g. deseasonalized
  !>                                                                                time series)

  !     RESTRICTIONS
  !         Input values must be floating points.

  !     EXAMPLE
  !         data    = (/ 1., 2, 3., -999., 5., 6. /)
  !         classes = (/ 1,  1, 1,     2,  2 , 2 /)
  !         out  = classified_standard_score(data, classes, mask=(data >= 0.))
  !         -> see also example in test directory

  !     LITERATURE
  !        None

  !     HISTORY
  !>         \author Matthias Zink
  !>         \date   May 2015

  INTERFACE classified_standard_score
     MODULE PROCEDURE classified_standard_score_sp, classified_standard_score_dp
  END INTERFACE classified_standard_score

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

  PRIVATE

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

CONTAINS

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

  FUNCTION standard_score_sp(data, mask)

    use mo_moment, only: average, stddev

    implicit none

    real(sp), dimension(:),             intent(in) :: data ! data arrau input
    logical,  dimension(:), optional,   intent(in) :: mask ! optional input
    real(sp), dimension(size(data, dim=1))         :: standard_score_sp

    ! local
    logical, dimension(size(data, dim=1))          :: maske

    ! check if optional mask matches shape of data
    if (present(mask)) then
       if (size(mask) .ne. size(data)) stop '***Error: standard_score_sp: size(mask) .ne. size(data)'
       maske = mask
    else
       maske(:) = .true.
    endif

    ! check if enough values (>1) are available
    if (count(maske) .LE. 2) stop '***Error: standard_score_sp: less than 2 elements avaiable'

    standard_score_sp = ( data(:) - average(data, mask=maske) ) / stddev(data, mask=maske, ddof=1_i4)

  END FUNCTION standard_score_sp

  FUNCTION standard_score_dp(data, mask)

    use mo_moment, only: average, stddev

    implicit none

    real(dp), dimension(:),             intent(in) :: data ! data arrau input
    logical,  dimension(:), optional,   intent(in) :: mask ! optional input
    real(dp), dimension(size(data, dim=1))         :: standard_score_dp

    ! local
    logical, dimension(size(data, dim=1))          :: maske

    ! check if optional mask matches shape of data
    if (present(mask)) then
       if (size(mask) .ne. size(data)) stop '***Error: standard_score_dp: size(mask) .ne. size(data)'
       maske = mask
    else
       maske(:) = .true.
    endif

    ! check if enough values (>1) are available
    if (count(maske) .LE. 2) stop '***Error: standard_score_dp: less than 2 elements avaiable'

    standard_score_dp = ( data(:) - average(data, mask=maske) ) / stddev(data, mask=maske, ddof=1_i4)

  END FUNCTION standard_score_dp

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

  FUNCTION classified_standard_score_sp(data, classes, mask)

    use mo_moment,    only: average, stddev
    use mo_orderpack, only: unista

    implicit none

    real(sp),    dimension(:),             intent(in) :: data    ! data array with input
    integer,     dimension(:),             intent(in) :: classes ! array indicateing classes
    logical,     dimension(:), optional,   intent(in) :: mask    ! array masking elements of data
    real(sp),    dimension(size(data, dim=1))         :: classified_standard_score_sp

    ! local
    integer(i4)                                       :: iclass, ielem        ! loop variable
    integer(i4)                                       :: number_of_classes    ! number of unique classes in vector
    ! classes
    integer(i4), dimension(size(data, dim=1))         :: unique_classes       ! vector of uniqe classes
    real(sp)                                          :: class_mean           ! mean of class
    real(sp)                                          :: class_stddev         ! standard deviation of class
    logical,     dimension(size(data, dim=1))         :: maske                ! data mask
    logical,     dimension(size(data, dim=1))         :: mask_class_maske     ! combined mask for current class and
    ! maske

    ! check if optional mask matches shape of data
    if (present(mask)) then
       if (size(mask) .ne. size(data)) stop '***Error: classified_standard_score_sp: size(mask) .ne. size(data)'
       maske = mask
    else
       maske(:) = .true.
    endif

    ! check if enough values (>1) are available
    if (count(maske) .LE. 2) stop '***Error: classified_standard_score_sp: less than 2 elements available'

    ! initialization
    classified_standard_score_sp = 0.0_sp

    ! write classes to new array for getting unique array elements
    unique_classes = classes
    call unista(unique_classes, number_of_classes) ! (unique arry elements in the 1:number_of_classes
    !                                              ! indexes of array unique_classes)

    ! loop over classes
    do iclass = 1, number_of_classes
       ! calculate mean and standard deviation for class
       mask_class_maske = (maske .AND. (classes==unique_classes(iclass)))
       class_mean   = average(data, mask=mask_class_maske)
       class_stddev = stddev(data, mask=mask_class_maske, ddof=1_i4)
       ! loop over array elements
       do ielem = 1, size(data, dim=1)
          if (.NOT. mask_class_maske(ielem)) cycle ! skip masked values and other classes
          classified_standard_score_sp(ielem) = ( data(ielem) - class_mean ) / class_stddev
       end do
    end do

  END FUNCTION classified_standard_score_sp

  FUNCTION classified_standard_score_dp(data, classes, mask)

    use mo_moment,    only: average, stddev
    use mo_orderpack, only: unista

    implicit none

    real(dp),    dimension(:),             intent(in) :: data    ! data array with input
    integer,     dimension(:),             intent(in) :: classes ! array indicateing classes
    logical,     dimension(:), optional,   intent(in) :: mask    ! array masking elements of data
    real(dp),    dimension(size(data, dim=1))         :: classified_standard_score_dp

    ! local
    integer(i4)                                       :: iclass, ielem        ! loop variable
    integer(i4)                                       :: number_of_classes    ! number of unique classes in vector classes
    integer(i4), dimension(size(data, dim=1))         :: unique_classes       ! vector of uniqe classes
    real(dp)                                          :: class_mean           ! mean of class
    real(dp)                                          :: class_stddev         ! standard deviation of class
    logical,     dimension(size(data, dim=1))         :: maske                ! data mask
    logical,     dimension(size(data, dim=1))         :: mask_class_maske     ! combined mask for current class and maske

    ! check if optional mask matches shape of data
    if (present(mask)) then
       if (size(mask) .ne. size(data)) stop '***Error: classified_standard_score_dp: size(mask) .ne. size(data)'
       maske = mask
    else
       maske(:) = .true.
    endif

    ! check if enough values (>1) are available
    if (count(maske) .LE. 2) stop '***Error: classified_standard_score_dp: less than 2 elements avaiable'

    ! initialization
    classified_standard_score_dp = 0.0_dp

    ! write classes to new array for getting unique array elements
    unique_classes = classes
    call unista(unique_classes, number_of_classes) ! (unique arry elements in the 1:number_of_classes
    !                                              ! indexes of array unique_classes)

    ! loop over classes
    do iclass = 1, number_of_classes
       ! calculate mean and standard deviation for class
       mask_class_maske = (maske .AND. (classes==unique_classes(iclass)))
       class_mean   = average(data, mask=mask_class_maske)
       class_stddev = stddev(data, mask=mask_class_maske, ddof=1_i4)
       ! loop over array elements
       do ielem = 1, size(data, dim=1)
          if (.NOT. mask_class_maske(ielem)) cycle ! skip masked values and other classes
          classified_standard_score_dp(ielem) = ( data(ielem) - class_mean ) / class_stddev
       end do
    end do

  END FUNCTION classified_standard_score_dp

END MODULE mo_standard_score


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! Test assignment of array-valued intrinsics with F2003 allocatable
! assignment semantics. Compile with -Mallocatable=03.
! Like al21.f90 but source array is allocatable too.
program al22
  implicit none
  logical :: fail = .false.
  integer :: i
  real, allocatable :: a1(:)
  real :: a2(4,4)
  a1 = [ (i, i=1, 16) ]
  a2 = reshape(a1, [4, 4])

  call test_minval()
  call test_product()
  call test_sum()
  call test_cshift()
  call test_eoshift()
  if (.not. fail) write(*,'("PASS")')

contains

  subroutine test_minval()
    real, allocatable :: b1(:)
    b1 = minval(a2, 1)
    call check('minval', b1, [1.0, 5.0, 9.0, 13.0])
  end subroutine

  subroutine test_cshift()
    real, allocatable :: b1(:)
    b1 = cshift(a1, 4)
    call check('cshift', b1, [ &
       5.0,  6.0,  7.0,  8.0, 9.0, 10.0, 11.0, 12.0, &
      13.0, 14.0, 15.0, 16.0, 1.0,  2.0,  3.0,  4.0  &
    ])
  end subroutine

  subroutine test_product()
    real, allocatable :: b1(:)
    b1 = product(a2, 1)
    call check('product', b1, [24.0, 1680.0, 11880.0, 43680.0])
  end subroutine

  subroutine test_sum()
    real, allocatable :: b1(:)
    b1 = sum(a2, 1)
    call check('sum', b1, [10.0, 26.0, 42.0, 58.0])
  end subroutine

  subroutine test_eoshift()
    real, allocatable :: b1(:)
    b1 = eoshift(a1, 4)
    call check('cshift', b1, [ &
       5.0,  6.0,  7.0,  8.0, 9.0, 10.0, 11.0, 12.0, &
      13.0, 14.0, 15.0, 16.0, 0.0,  0.0,  0.0,  0.0  &
    ])
  end subroutine

  ! Check that actual is the same as expected; report failure if not.
  subroutine check(label, actual, expected)
    character(len=*) :: label
    real :: actual(:)
    real :: expected(:)
    if (size(actual) /= size(expected)) then
    else if (any(actual /= expected)) then
    else
      return
    end if
    write(*,'("FAIL: ",a)') label
    print *," expected:", expected
    print *," actual:  ", actual
    fail = .true.
  end subroutine

end


!*==crotg.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b CROTG
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE CROTG(CA,CB,C,S)
!
!       .. Scalar Arguments ..
!       COMPLEX CA,CB,S
!       REAL C
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CROTG determines a complex Givens rotation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] CA
!> \verbatim
!>          CA is COMPLEX
!> \endverbatim
!>
!> \param[in] CB
!> \verbatim
!>          CB is COMPLEX
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is COMPLEX
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup complex_blas_level1
!
!  =====================================================================
      SUBROUTINE CROTG(Ca,Cb,C,S)
      IMPLICIT NONE
!*--CROTG66
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      COMPLEX Ca , Cb , S
      REAL C
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      COMPLEX alpha
      REAL norm , scale
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CABS , CONJG , SQRT
!     ..
      IF ( CABS(Ca)==0. ) THEN
         C = 0.
         S = (1.,0.)
         Ca = Cb
      ELSE
         scale = CABS(Ca) + CABS(Cb)
         norm = scale*SQRT((CABS(Ca/scale))**2+(CABS(Cb/scale))**2)
         alpha = Ca/CABS(Ca)
         C = CABS(Ca)/norm
         S = alpha*CONJG(Cb)/norm
         Ca = alpha*norm
      ENDIF
      END SUBROUTINE CROTG


!*****************************************************************************************
!>
!  Units test for 1d-6d tensor product b-spline interpolation.

    program bspline_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    integer(ip),parameter :: nx = 50     !! number of points in x
    integer(ip),parameter :: ny = 50     !! number of points in y
    integer(ip),parameter :: nz = 50     !! number of points in z
    integer(ip),parameter :: nx_new = 256     !! nbr of interpolated x-points
    integer(ip),parameter :: ny_new = 256     !! nbr of interpolated y-points
    integer(ip),parameter :: nz_new = 256     !! nbr of interpolated z-points
    integer(ip),parameter :: kx = 4     !! order in x
    integer(ip),parameter :: ky = 4     !! order in y
    integer(ip),parameter :: kz = 4     !! order in z

    integer(ip),parameter :: iknot = 0  !! automatically select the knots

    real(wp), parameter   :: x_min=0._wp, x_max=10._wp !! range og x-grid
    real(wp), parameter   :: y_min=0._wp, y_max=10._wp !! range og y-grid
    real(wp), parameter   :: z_min=0._wp, z_max=10._wp !! range og z-grid

    real(wp) :: x(nx),y(ny),z(nz),tx(nx+kx),ty(ny+ky),tz(nz+kz)
    real(wp) :: fcn_3d(nx,ny,nz)

    real(wp),dimension(ky,kz)                    :: w1_3d
    real(wp),dimension(kz)                       :: w2_3d
    real(wp),dimension(3*max(kx,ky,kz))          :: w3_3d

    real(wp) :: tol,dx,dy,dz,dx_new,dy_new,dz_new,int_3d,int_3d_new, &
                sum_x,sum_y,f_2d
    real(wp),dimension(6) :: val,tru,err,errmax
    logical :: fail
    integer(ip) :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids
    integer(ip),dimension(6) :: iflag
    integer(ip) :: inbvx,inbvy,inbvz,inbvq,inbvr,inbvs
    integer(ip) :: iloy,iloz,iloq,ilor,ilos
    integer ::     count_rate, count_max,count,t_start,t_final
    real    ::     time_s

    real(wp), allocatable :: xout(:),yout(:),zout(:),fout(:,:,:)

    call system_clock(count_max=count_max, count_rate=count_rate)

    call system_clock(t_start)

    print*, ""
    print*, "-----------3D-Bspline Interpolation--------------"
    print*, ""

    fail = .false.
    tol = 100 * epsilon(1.0_wp)
    idx = 0
    idy = 0
    idz = 0
    allocate(xout(nx_new)); allocate(yout(ny_new));
    allocate(zout(nz_new)); allocate(fout(nx_new,ny_new,nz_new))

     dx = (x_max-x_min)/real(nx-1,wp); dy = (y_max-y_min)/real(ny-1,wp)
     dz = (z_max-z_min)/real(nz-1,wp)
!x-grid
     do i=1,nx
        x(i) = x_min + real(i-1,wp)*dx
     end do
!y-grid
     do j=1,ny
        y(j) = y_min + real(j-1,wp)*dy
     enddo
!z-grid
    do k=1,nz
        z(k) = z_min + real(k-1,wp)*dz
     enddo
!2d function to be interpolated
     do i=1,nx
       do j=1,ny
          do k=1,nz
             fcn_3d(i,j,k) = f3(x(i),y(j),z(k))
          enddo
       enddo
     end do

!defining the interpolated 3D-grid
     dx_new = (x_max-x_min)/real(nx_new-1,wp); dy_new = (y_max-y_min)/real(ny_new-1,wp)
     dz_new = (z_max-z_min)/real(nz_new-1,wp)
     do i=1,nx_new
        xout(i) = x_min + real(i-1,wp)*dx_new
     enddo
     do j=1,ny_new
        yout(j) = y_min + real(j-1,wp)*dy_new
     enddo
     do k=1,nz_new
        zout(k) = z_min + real(k-1,wp)*dz_new
     enddo
     print*,"--Grid parameter----"
     print*, "--nbr of point:nx, nx_new",nx, nx_new
     print*, "--nbr of point:ny, ny_new",ny, ny_new
     print*, "--nbr of point:nz, nz_new",nz, nz_new
     print*, "--spatial step:dx, dx_new", dx, dx_new
     print*, "--spatial step:dy, dy_new", dy, dy_new
     print*, "--spatial step:dz, dz_new", dz, dz_new
     print*,"--xmax,ymax,zmax",x_max,y_max,z_max
     print*,""

    !have to set these before the first evaluate call:
    inbvx = 1
    inbvy = 1
    inbvz = 1
    ! initialize

    call db3ink(x,nx,y,ny,z,nz,fcn_3d,kx,ky,kz,iknot,tx,ty,tz,fcn_3d,iflag(3))

    if (any(iflag/=0)) then
        do i=2,2
            if (iflag(i)/=0) then
                write(*,*) 'Error initializing ',i,'D spline: '//get_status_message(iflag(i))
            end if
        end do
    end if

    ! compute max error at interpolation points

     errmax = 0.0_wp
     do i=1,size(xout)
       do j=1,size(yout)
         do k=1,size(zout)
            call db3val(xout(i),yout(j),zout(k),idx,idy,idz,&
                 tx,ty,tz,nx,ny,nz,kx,ky,kz,fcn_3d,val(3),iflag(3),&
                 inbvx,inbvy,inbvz,iloy,iloz,&
                 w1_3d,w2_3d,w3_3d)

                     tru(3)    = f3(x(i),y(j),z(k))
                     err(3)    = abs(tru(3)-val(3))
                     errmax(3) = max(err(3),errmax(3))

                 fout(i,j,k) = val(3)
          enddo
        enddo
      end do

    ! check max error against tolerance
    do i=3,3
        write(*,*) i,'D: max error:', errmax(i)
!        if (errmax(i) >= tol) then
!            write(*,*)  ' ** test failed ** '
!        else
!            write(*,*)  ' ** test passed ** '
!        end if
        write(*,*) ''
    end do

!Evaluate the integral
!without interpolation
   sum_y=0._wp
   do j=1,ny
      sum_x=0._wp
      do k=1,nz
         sum_x = sum_x + sum(fcn_3d(1:nx,j,k))
      enddo
      sum_y = sum_y + sum_x
   enddo
   int_3d = sum_y*dx*dy*dz

!with interpolation
   sum_y=0._wp
   do j=1,ny_new
      sum_x = 0._wp
      do k=1,nz_new
         sum_x = sum_x + sum(fout(1:nx_new,j,k))
      enddo
      sum_y = sum_y + sum_x
   enddo
   int_3d_new = sum_y*dx_new*dy_new*dz_new

   print*,"--3D-Integral without interpolation", int_3d
   print*,"--3D-Integral with interpolation", int_3d_new

   call system_clock(t_final)

   time_s = real(t_final - t_start)/real(count_rate)
   print*,""
   print*, '--Time it takes (s)', time_s

!print out the output file
!    open(100,file='2Dxy-TestBspline-Without-Interpolation.dat')
!    open(101,file='2Dxy-TestBspline-With-Interpolation.dat')
!prinout data
!data without interpolation
!   do i=1,nx
!      do j=1,ny
!         f_2d = sum(fcn_3d(i,j,1:nz))*dz
!         write(100,*)x(i),y(j),f_2d
!      enddo
!      write(100,*)
!   enddo
!data with interpolation
!   do i=1,size(xout)
!     do j=1,size(yout)
!        f_2d = sum(fout(i,j,1:nz_new))
!      write(101,*)xout(i),yout(j),f_2d
!     enddo
!     write(101,*)
!   enddo

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp) :: x
        !f1 = 0.5_wp * (x*exp(-x) + sin(x) )
         f1 = sin(x)
        end function f1

        real(wp) function f2(x,y) !! 2d test function
        implicit none
        real(wp) x,y,piov2
        !piov2 = 2.0_wp * atan(1.0_wp)
        !f2 = 0.5_wp * (y*exp(-x) + sin(piov2*y) )
         f2 = 1._wp*sin(sqrt((x*x + y*y)*1._wp))
        end function f2

        real(wp) function f3 (x,y,z) !! 3d test function
        implicit none
        real(wp) x,y,z,piov2
        !piov2 = 2.0_wp*atan(1.0_wp)
        !f3 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) )
         f3 = 1._wp*sin(sqrt(x*x + y*y + z*z))
        end function f3

        real(wp) function f4 (x,y,z,q) !! 4d test function
        implicit none
        real(wp) x,y,z,q,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f4 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q )
        end function f4

        real(wp) function f5 (x,y,z,q,r) !! 5d test function
        implicit none
        real(wp) x,y,z,q,r,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f5 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r )
        end function f5

        real(wp) function f6 (x,y,z,q,r,s) !! 6d test function
        implicit none
        real(wp) x,y,z,q,r,s,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f6 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r + 2.0_wp*s )
        end function f6

    end program bspline_test