C
C	$Id: csleft.f,v 1.5 2008-07-27 03:10:07 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      LOGICAL FUNCTION CSLEFT (X1,Y1,Z1,X2,Y2,Z2,X0,Y0,Z0)
      DOUBLE PRECISION X1, Y1, Z1, X2, Y2, Z2, X0, Y0, Z0
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/15/96
C
C   This function determines whether node N0 is in the
C (closed) left hemisphere defined by the plane containing
C N1, N2, and the origin, where left is defined relative to
C an observer at N1 facing N2.
C
C
C On input:
C
C       X1,Y1,Z1 = Coordinates of N1.
C
C       X2,Y2,Z2 = Coordinates of N2.
C
C       X0,Y0,Z0 = Coordinates of N0.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       CSLEFT = TRUE if and only if N0 is in the closed
C              left hemisphere.
C
C Modules required by CSLEFT:  None
C
C***********************************************************
C
C CSLEFT = TRUE iff <N0,N1 X N2> = det(N0,N1,N2) .GE. 0.
C
      CSLEFT = X0*(Y1*Z2-Y2*Z1) - Y0*(X1*Z2-X2*Z1) +
     .       Z0*(X1*Y2-X2*Y1) .GE. 0.D0
      RETURN
      END


      MODULE cgamma_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  10:46:48   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE cgamma (ARGR, ARGI, RESR, RESI)
      USE vast_kind_param,ONLY: DOUBLE
      REAL(DOUBLE), INTENT(IN) :: ARGR
      REAL(DOUBLE), INTENT(IN) :: ARGI
      REAL(DOUBLE), INTENT(OUT) :: RESR
      REAL(DOUBLE), INTENT(OUT) :: RESI
!VAST.../DEF0/ EXPMAX(IN), EXPMIN(IN), PRECIS(IN)
!VAST.../DEF9/ PI(IN)
!VAST...Calls: ARCTAN
!...This routine performs I/O.
      END SUBROUTINE
      END INTERFACE
      END MODULE


!> Compare with `demo_linalg_zerosones`
!> It is not recommended to use the `zeros/ones` function,
!>  it is recommended to use `allocate(array(dim1, dim2, ..), source=0.0/1.0)`.
program demo_allocation
    use forlab_io, only: disp

    real, allocatable :: zero(:, :), one(:, :)
    real, allocatable :: array(:, :)

    allocate(zero(1, 2), source=0.0)
    allocate(one (1, 2), source=1.0)

    call disp(zero, "zeros: ")
    call disp(one , "ones : ")

    allocate(array(2, 2), source=0.0)
    call disp(array, "array with zeros: ")

    deallocate(array)
    allocate(array(2, 2), source=1.0)
    call disp(array, "array with ones : ")

end program demo_allocation


!@brief Module with definition of precision
module constants
  USE prec_mod, ONLY: prec
  implicit none
  real(prec), parameter :: f_zero = 1.0_prec !< Pi in Fire used precision.
  real(prec), parameter :: f_pi = 3.141592653589793238462643383279502884197_prec !< Pi in Fire used precision.
end module constants


module m
implicit none
contains
pure function sqrt_int(i) result(y)
integer, intent(in) :: i
real                :: y
if (i < 0) error stop "need i >= 0 in sqrt_int"
! plain stop not allowed in pure function
y = sqrt(real(i))
end function sqrt_int
end module m
!
program main
use m, only: sqrt_int
implicit none
print*,sqrt_int(-1)
stop "normal termination"
end program main
! output:
! ERROR STOP need i >= 0 in sqrt_int


subroutine iterator10
use fdeclarations

implicit none

j=90*n
if (mod(j,100)==0) then
ii=j/100
else
ii=int(j)/100
end if
z=n-ii
!fold=z
allocate(dmatrix(ii,w))
allocate(ematrix(z,w))

v=1
do i=zz*n-(n-1),zz*n-z
dmatrix(i-i+v,:)=matrix(a1(i),:)
v=v+1
end do

v=1
do i=zz*n-z+1,zz*n
ematrix(i-i+v,:)=matrix(a1(i),:)
v=v+1
end do

do i=1,z
co1matrix(i,zz)=ematrix(i,5)
end do

!open(69, file='dmatrix.txt', action='write', status='replace')!!!!!!!!!!!
!write(69,*) 'dmatrix'
!do f=1,ii
!write(69,10) (dmatrix(f,k), k=1,w)
!end do

!write(69,*) 'ematrix'
!do fff=1,z
!write(69,10) (ematrix(fff,k), k=1,w)
!end do

!10 format (8f7.3)

end subroutine iterator10


program test_arange
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use testing, only:assert, initialize_tests, report_tests
use functional, only:arange

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, ntests

n = 1
ntests = 19
call initialize_tests(tests, ntests)

tests(n) = assert(all(arange(1_int8, 3_int8) == [1_int8, 2_int8, 3_int8]), &
                  'arange,  int8')
n = n + 1

tests(n) = assert(all(arange(1_int16, 3_int16) == [1_int16, 2_int16, 3_int16]), &
                  'arange,  int16')
n = n + 1

tests(n) = assert(all(arange(1_int32, 3_int32) == [1_int32, 2_int32, 3_int32]), &
                  'arange,  int32')
n = n + 1

tests(n) = assert(all(arange(1_int64, 3_int64) == [1_int64, 2_int64, 3_int64]), &
                  'arange,  int64')
n = n + 1

tests(n) = assert(all(arange(1._real32, 3._real32) == [1._real32, 2._real32, 3._real32]), &
                  'arange,  real32')
n = n + 1

tests(n) = assert(all(arange(1._real64, 3._real64) == [1._real64, 2._real64, 3._real64]), &
                  'arange,  real32')
n = n + 1

tests(n) = assert(all(arange(1._real128, 3._real128) == [1._real128, 2._real128, 3._real128]), &
                  'arange,  real128')
n = n + 1

tests(n) = assert(all(arange(1._real128, 3._real128) == [1._real128, 2._real128, 3._real128]), &
                  'arange,  real128')
n = n + 1

tests(n) = assert(all(arange(cmplx(1._real32, 0._real32), &
                             cmplx(3._real32, 0._real32), &
                             cmplx(1._real32, 0._real32))&
                  == [cmplx(1._real32, 0._real32), &
                      cmplx(2._real32, 0._real32), &
                      cmplx(3._real32, 0._real32)]), &
                  'arange,  complex real32')
n = n + 1

tests(n) = assert(all(arange(cmplx(1._real64, 0._real64), &
                             cmplx(3._real64, 0._real64), &
                             cmplx(1._real64, 0._real64))&
                  == [cmplx(1._real64, 0._real64), &
                      cmplx(2._real64, 0._real64), &
                      cmplx(3._real64, 0._real64)]), &
                  'arange,  complex real64')
n = n + 1

tests(n) = assert(all(arange(cmplx(1._real128, 0._real128), &
                             cmplx(3._real128, 0._real128), &
                             cmplx(1._real128, 0._real128))&
                  == [cmplx(1._real128, 0._real128), &
                      cmplx(2._real128, 0._real128), &
                      cmplx(3._real128, 0._real128)]), &
                  'arange,  complex real128')
n = n + 1

tests(n) = assert(all(arange(cmplx(1, 1), cmplx(3, 5), cmplx(1, 2))&
                  == [cmplx(1, 1), cmplx(2, 3), cmplx(3, 5)]), &
                  'arange,  incrementing both parts of complex numbers')
n = n + 1

tests(n) = assert(all(arange(1, 10) == arange(1, 10, 1)), &
                  'arange increment equals 1 when ommited')
n = n + 1

tests(n) = assert(all(arange(1., 10.) == real(arange(1, 10, 1))), &
                  'integer and real arange variants produce same values')
n = n + 1

tests(n) = assert(all(arange(0., 2.4, 0.8) == [0., 0.8, 1.6, 2.4]), &
                  'custom increment value')
n = n + 1

tests(n) = assert(all(arange(3, -1, -1) == [3, 2, 1, 0, -1]), &
                  'negative increment value')
n = n + 1

tests(n) = assert(size(arange(1.0, 1.4, 0.1)) == 5, &
                  'real32-typed arange returns array of expected size')
n = n + 1

tests(n) = assert(size(arange(1.0_real64, 1.4_real64, 0.1_real64)) == 5, &
                  'real64-typed arange returns array of expected size')
n = n + 1

tests(n) = assert(size(arange(1.0_real128, 1.4_real128, 0.1_real128)) == 5, &
                  'real128-typed arange returns array of expected size')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_arange


program i
  real ::b=10.0 * (4+4) * ( 4 ** 2)
  real  ::c=(4.0 ** 2)
  real :: a
  a =  ((b * c) / (b * c))
end program i


c Multiply a float vector by a scalar
c     Replace single precision sx by single precision sa*sx.
c     for i = 0 to n-1, replace sx(1+i*incx) with  sa * sx(1+i*incx)

	subroutine  sscal(n, sa, sx, incx)

	implicit none

c	Parameters:
	integer	n
	integer	incx
	real	sa, sx(1+(n-1)*incx)

c	Local variables:
	integer	i
	integer	m
	integer	mp1
	integer	ns

      if(n.le.0)return
      if(incx.eq.1)goto 20

c        code for increments not equal to 1.

      ns = n*incx
          do 10 i = 1,ns,incx
          sx(i) = sa*sx(i)
   10     continue
      return

c        code for increments equal to 1.

c        clean-up loop so remaining vector length is a multiple of 5.

   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sx(i) = sa*sx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        sx(i) = sa*sx(i)
        sx(i + 1) = sa*sx(i + 1)
        sx(i + 2) = sa*sx(i + 2)
        sx(i + 3) = sa*sx(i + 3)
        sx(i + 4) = sa*sx(i + 4)
   50 continue
      return
      end


!
! 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
!

program testieee1
use ieee_exceptions
logical l1(32), l2(32)
real*4 a
real*8 d
type(ieee_flag_type) :: ie1, ie2, ie3, ie4, ie5, ie6
a = 1.0
d = 1.0d0
print *,"Test ieee_support_flag"
ie1 = ieee_underflow
ie2 = ieee_overflow
ie3 = ieee_divide_by_zero
ie4 = ieee_inexact
ie5 = ieee_invalid
ie6 = ieee_denorm
l1 = .true.
l2 = .true.
l1(2 ) = ieee_support_flag(ieee_underflow, a)
l1(3 ) = ieee_support_flag(ieee_underflow, d)
l1(4 ) = ieee_support_flag(ieee_overflow, a)
l1(5 ) = ieee_support_flag(ieee_overflow, d)
l1(6 ) = ieee_support_flag(ieee_divide_by_zero, a)
l1(7 ) = ieee_support_flag(ieee_divide_by_zero, d)
l1(8 ) = ieee_support_flag(ieee_inexact, a)
l1(9 ) = ieee_support_flag(ieee_inexact, d)
l1(10) = ieee_support_flag(ieee_invalid, a)
l1(11) = ieee_support_flag(ieee_invalid, d)
l1(12) = ieee_support_flag(ieee_denorm, a)
l1(13) = ieee_support_flag(ieee_denorm, d)
l1(14) = ieee_support_flag(ie1, a)
l1(15) = ieee_support_flag(ie1, d)
l1(16) = ieee_support_flag(ie2, a)
l1(17) = ieee_support_flag(ie2, d)
l1(18) = ieee_support_flag(ie3, a)
l1(19) = ieee_support_flag(ie3, d)
l1(20) = ieee_support_flag(ie4, a)
l1(21) = ieee_support_flag(ie4, d)
l1(22) = ieee_support_flag(ie5, a)
l1(23) = ieee_support_flag(ie5, d)
l1(24) = ieee_support_flag(ie6, a)
l1(25) = ieee_support_flag(ie6, d)
l1(26) = ieee_support_flag(ieee_underflow)
l1(27) = ieee_support_flag(ieee_overflow)
l1(28) = ieee_support_flag(ieee_divide_by_zero)
l1(29) = ieee_support_flag(ieee_inexact)
l1(30) = ieee_support_flag(ieee_invalid)
l1(31) = ieee_support_flag(ieee_denorm)

call check(l1, l2, 32)
end


      SUBROUTINE SB03MU( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
     $                   LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in
C
C            ISGN*op(TL)*X*op(TR) - X = SCALE*B,
C
C     where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1
C     or -1.  op(T) = T or T', where T' denotes the transpose of T.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LTRANL  LOGICAL
C             Specifies the form of op(TL) to be used, as follows:
C             = .FALSE.:  op(TL) = TL,
C             = .TRUE. :  op(TL) = TL'.
C
C     LTRANR  LOGICAL
C             Specifies the form of op(TR) to be used, as follows:
C             = .FALSE.:  op(TR) = TR,
C             = .TRUE. :  op(TR) = TR'.
C
C     ISGN    INTEGER
C             Specifies the sign of the equation as described before.
C             ISGN may only be 1 or -1.
C
C     Input/Output Parameters
C
C     N1      (input) INTEGER
C             The order of matrix TL.  N1 may only be 0, 1 or 2.
C
C     N2      (input) INTEGER
C             The order of matrix TR.  N2 may only be 0, 1 or 2.
C
C     TL      (input) DOUBLE PRECISION array, dimension (LDTL,2)
C             The leading N1-by-N1 part of this array must contain the
C             matrix TL.
C
C     LDTL    INTEGER
C             The leading dimension of array TL.  LDTL >= MAX(1,N1).
C
C     TR      (input) DOUBLE PRECISION array, dimension (LDTR,2)
C             The leading N2-by-N2 part of this array must contain the
C             matrix TR.
C
C     LDTR    INTEGER
C             The leading dimension of array TR.  LDTR >= MAX(1,N2).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,2)
C             The leading N1-by-N2 part of this array must contain the
C             right-hand side of the equation.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N1).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor. SCALE is chosen less than or equal to 1
C             to prevent the solution overflowing.
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N2)
C             The leading N1-by-N2 part of this array contains the
C             solution of the equation.
C             Note that X may be identified with B in the calling
C             statement.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N1).
C
C     XNORM   (output) DOUBLE PRECISION
C             The infinity-norm of the solution.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if TL and TR have almost reciprocal eigenvalues, so
C                   TL or TR is perturbed to get a nonsingular equation.
C
C             NOTE: In the interests of speed, this routine does not
C                   check the inputs for errors.
C
C     METHOD
C
C     The equivalent linear algebraic system of equations is formed and
C     solved using Gaussian elimination with complete pivoting.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is stable and reliable, since Gaussian elimination
C     with complete pivoting is used.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Based on DLASD2 by P. Petkov, Tech. University of Sofia, September
C     1993.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, May 1999.
C
C     KEYWORDS
C
C     Discrete-time system, Sylvester equation, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, HALF, EIGHT
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
     $                     TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 )
C     ..
C     .. Scalar Arguments ..
      LOGICAL            LTRANL, LTRANR
      INTEGER            INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
      DOUBLE PRECISION   SCALE, XNORM
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
     $                   X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            BSWAP, XSWAP
      INTEGER            I, IP, IPIV, IPSV, J, JP, JPSV, K
      DOUBLE PRECISION   BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1,
     $                   TEMP, U11, U12, U22, XMAX
C     ..
C     .. Local Arrays ..
      LOGICAL            BSWPIV( 4 ), XSWPIV( 4 )
      INTEGER            JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ),
     $                   LOCU22( 4 )
      DOUBLE PRECISION   BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSWAP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
C     ..
C     .. Data statements ..
      DATA               LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / ,
     $                   LOCU22 / 4, 3, 2, 1 /
      DATA               XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
      DATA               BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
C     ..
C     .. Executable Statements ..
C
C     Do not check the input parameters for errors.
C
      INFO  = 0
      SCALE = ONE
C
C     Quick return if possible.
C
      IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN
         XNORM = ZERO
         RETURN
      END IF
C
C     Set constants to control overflow.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      SGN = ISGN
C
      K = N1 + N1 + N2 - 2
      GO TO ( 10, 20, 30, 50 )K
C
C     1-by-1: SGN*TL11*X*TR11 - X = B11.
C
   10 CONTINUE
      TAU1 = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE
      BET = ABS( TAU1 )
      IF( BET.LE.SMLNUM ) THEN
         TAU1 = SMLNUM
         BET = SMLNUM
         INFO = 1
      END IF
C
      GAM = ABS( B( 1, 1 ) )
      IF( SMLNUM*GAM.GT.BET )
     $   SCALE = ONE / GAM
C
      X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
      XNORM = ABS( X( 1, 1 ) )
      RETURN
C
C     1-by-2:
C     ISGN*TL11*[X11 X12]*op[TR11 TR12]  = [B11 B12].
C                           [TR21 TR22]
C
   20 CONTINUE
C
      SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
     $                 ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
     $                *ABS( TL( 1, 1 ) )*EPS,
     $            SMLNUM )
      TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE
      TMP( 4 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE
      IF( LTRANR ) THEN
         TMP( 2 ) = SGN*TL( 1, 1 )*TR( 2, 1 )
         TMP( 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 )
      ELSE
         TMP( 2 ) = SGN*TL( 1, 1 )*TR( 1, 2 )
         TMP( 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 )
      END IF
      BTMP( 1 ) = B( 1, 1 )
      BTMP( 2 ) = B( 1, 2 )
      GO TO 40
C
C     2-by-1:
C     ISGN*op[TL11 TL12]*[X11]*TR11  = [B11].
C            [TL21 TL22] [X21]         [B21]
C
   30 CONTINUE
      SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
     $                 ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
     $                *ABS( TR( 1, 1 ) )*EPS,
     $            SMLNUM )
      TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE
      TMP( 4 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE
      IF( LTRANL ) THEN
         TMP( 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 )
         TMP( 3 ) = SGN*TL( 2, 1 )*TR( 1, 1 )
      ELSE
         TMP( 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 )
         TMP( 3 ) = SGN*TL( 1, 2 )*TR( 1, 1 )
      END IF
      BTMP( 1 ) = B( 1, 1 )
      BTMP( 2 ) = B( 2, 1 )
   40 CONTINUE
C
C     Solve 2-by-2 system using complete pivoting.
C     Set pivots less than SMIN to SMIN.
C
      IPIV = IDAMAX( 4, TMP, 1 )
      U11 = TMP( IPIV )
      IF( ABS( U11 ).LE.SMIN ) THEN
         INFO = 1
         U11 = SMIN
      END IF
      U12 = TMP( LOCU12( IPIV ) )
      L21 = TMP( LOCL21( IPIV ) ) / U11
      U22 = TMP( LOCU22( IPIV ) ) - U12*L21
      XSWAP = XSWPIV( IPIV )
      BSWAP = BSWPIV( IPIV )
      IF( ABS( U22 ).LE.SMIN ) THEN
         INFO = 1
         U22 = SMIN
      END IF
      IF( BSWAP ) THEN
         TEMP = BTMP( 2 )
         BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
         BTMP( 1 ) = TEMP
      ELSE
         BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
      END IF
      IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR.
     $    ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
         SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
         BTMP( 1 ) = BTMP( 1 )*SCALE
         BTMP( 2 ) = BTMP( 2 )*SCALE
      END IF
      X2( 2 ) = BTMP( 2 ) / U22
      X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
      IF( XSWAP ) THEN
         TEMP = X2( 2 )
         X2( 2 ) = X2( 1 )
         X2( 1 ) = TEMP
      END IF
      X( 1, 1 ) = X2( 1 )
      IF( N1.EQ.1 ) THEN
         X( 1, 2 ) = X2( 2 )
         XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) )
      ELSE
         X( 2, 1 ) = X2( 2 )
         XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) )
      END IF
      RETURN
C
C     2-by-2:
C     ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12].
C            [TL21 TL22] [X21 X22]   [TR21 TR22] [X21 X22]   [B21 B22]
C
C     Solve equivalent 4-by-4 system using complete pivoting.
C     Set pivots less than SMIN to SMIN.
C
   50 CONTINUE
      SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
     $            ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
      SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
     $            ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN
      SMIN = MAX( EPS*SMIN, SMLNUM )
      T16( 1, 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE
      T16( 2, 2 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE
      T16( 3, 3 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE
      T16( 4, 4 ) = SGN*TL( 2, 2 )*TR( 2, 2 ) - ONE
      IF( LTRANL ) THEN
         T16( 1, 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 )
         T16( 2, 1 ) = SGN*TL( 1, 2 )*TR( 1, 1 )
         T16( 3, 4 ) = SGN*TL( 2, 1 )*TR( 2, 2 )
         T16( 4, 3 ) = SGN*TL( 1, 2 )*TR( 2, 2 )
      ELSE
         T16( 1, 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 )
         T16( 2, 1 ) = SGN*TL( 2, 1 )*TR( 1, 1 )
         T16( 3, 4 ) = SGN*TL( 1, 2 )*TR( 2, 2 )
         T16( 4, 3 ) = SGN*TL( 2, 1 )*TR( 2, 2 )
      END IF
      IF( LTRANR ) THEN
         T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 )
         T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 1, 2 )
         T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 2, 1 )
         T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 2, 1 )
      ELSE
         T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 )
         T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 2, 1 )
         T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 1, 2 )
         T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 1, 2 )
      END IF
      IF( LTRANL .AND. LTRANR ) THEN
         T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 1, 2 )
         T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 1, 2 )
         T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 2, 1 )
         T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 2, 1 )
      ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN
         T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 2, 1 )
         T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 2, 1 )
         T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 1, 2 )
         T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 1, 2 )
      ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN
          T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 1, 2 )
          T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 1, 2 )
          T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 2, 1 )
          T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 2, 1 )
      ELSE
          T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 2, 1 )
          T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 2, 1 )
          T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 1, 2 )
          T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 1, 2 )
      END IF
      BTMP( 1 ) = B( 1, 1 )
      BTMP( 2 ) = B( 2, 1 )
      BTMP( 3 ) = B( 1, 2 )
      BTMP( 4 ) = B( 2, 2 )
C
C     Perform elimination
C
      DO 100 I = 1, 3
         XMAX = ZERO
C
         DO 70 IP = I, 4
C
            DO 60 JP = I, 4
               IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
                  XMAX = ABS( T16( IP, JP ) )
                  IPSV = IP
                  JPSV = JP
               END IF
   60       CONTINUE
C
   70    CONTINUE
C
         IF( IPSV.NE.I ) THEN
            CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
            TEMP = BTMP( I )
            BTMP( I ) = BTMP( IPSV )
            BTMP( IPSV ) = TEMP
         END IF
         IF( JPSV.NE.I )
     $      CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
         JPIV( I ) = JPSV
         IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
            INFO = 1
            T16( I, I ) = SMIN
         END IF
C
         DO 90 J = I + 1, 4
            T16( J, I ) = T16( J, I ) / T16( I, I )
            BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
C
            DO 80 K = I + 1, 4
               T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
   80       CONTINUE
C
   90    CONTINUE
C
  100 CONTINUE
C
      IF( ABS( T16( 4, 4 ) ).LT.SMIN )
     $   T16( 4, 4 ) = SMIN
      IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR.
     $    ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR.
     $    ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR.
     $    ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
         SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ),
     $                ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ),
     $                ABS( BTMP( 4 ) ) )
         BTMP( 1 ) = BTMP( 1 )*SCALE
         BTMP( 2 ) = BTMP( 2 )*SCALE
         BTMP( 3 ) = BTMP( 3 )*SCALE
         BTMP( 4 ) = BTMP( 4 )*SCALE
      END IF
C
      DO 120 I = 1, 4
         K = 5 - I
         TEMP = ONE / T16( K, K )
         TMP( K ) = BTMP( K )*TEMP
C
         DO 110 J = K + 1, 4
            TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
  110    CONTINUE
C
  120 CONTINUE
C
      DO 130 I = 1, 3
         IF( JPIV( 4-I ).NE.4-I ) THEN
            TEMP = TMP( 4-I )
            TMP( 4-I ) = TMP( JPIV( 4-I ) )
            TMP( JPIV( 4-I ) ) = TEMP
         END IF
  130 CONTINUE
C
      X( 1, 1 ) = TMP( 1 )
      X( 2, 1 ) = TMP( 2 )
      X( 1, 2 ) = TMP( 3 )
      X( 2, 2 ) = TMP( 4 )
      XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ),
     $             ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) )
C
      RETURN
C *** Last line of SB03MU ***
      END


module szelliptic
  use precision1, only : dp
  use constants
  use utils, only : fcubic_roots,zbrent, &
                    rj,rd,rf,rc
  implicit none

  real(dp), parameter :: ztol=1.e-12_dp

  type szcmplx
      real(dp) :: p !cubic coefficient
      real(dp) :: q
      complex(dp), dimension(3) :: roots
      complex(dp), dimension(3) :: roots_inv
      complex(dp), dimension(3) :: f
      real(dp) :: prd_roots !x1.x2.x3
      real(dp) :: xi !sqrt(-x1.x2.x3)
      real(dp) :: p3 !1/sqrt(-x1.x2.x3)
  end type szcmplx

  interface szellip_1111
      module procedure szellip_1111
      module procedure szellip_1111_roots
  end interface szellip_1111

  private ! szellip_113_,szellip_115_
  public :: szcmplx,init_szcmplx,szellip_1111, &
          szellip_1311,szellip_1131,szellip_1113, &
          szellip_1511,szellip_1151,szellip_1115, &
          szellip_3333,szellip_1333, &
          szellip_5555,szellip_3555,szellip_1555

contains

    subroutine init_szcmplx(p,q,szc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Computes common complex quantities needed to evaluate   !
! certain formulas involving Carlson R-functions.         !
!                                                         !
! Checks for unphysical case: Rdot^2 is non-negative the  !
! quantities k and M in the equation                      !
!                                                         !
!   Rdot^2 = 2M/R - k + Lambda * R^2/3                    !
!                                                         !
! must be such that it is also non-negative.              !
! Alternatively, the square root of the RHS must be real. !
! This is certain when the discriminant -4p^3-27q^2 of    !
! the depressed cubic                                     !
!                                                         !
!   R^3 + p * R + q                                       !
!                                                         !
!     p = -k / (Omegal*H0^2)                              !
!     q = 2M / (Omegal*H0^2)                              !
!                                                         !
! is negative and the real root is negative. The real     !
! root R1 is given by                                     !
!                                                         !
!   R1 = S + T                                            !
!                                                         !
!     S = (-q/2 + sqrt(D))^1/3                            !
!     T = (-q/2 - sqrt(D))^1/3                            !
!                                                         !
! where D = -Discriminant/108. Note R1 > 0 when           !
!                                                         !
!   k^3 < 27 * Omegal * H0^2 * M^2                        !
!                                                         !
! Given that M >= 0 and for a void almost always          !
! k < 0 this mostly hold                                  !
!                                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: p,q
        type(szcmplx), intent(out) :: szc
        complex(dp), dimension(3) :: rts !roots
        real(dp) :: prd
! Clear cache for every new r (or p and q)
        if (allocated(cache)) deallocate(cache)
        call fcubic_roots(p,q,rts)
! Should be one real root only and less than 0
        if (real(rts(1)) > 0._dp) then
            write(*,'(A,X,A,X,A,X,A)') &
              'warning: real root > 0.', &
              'Root should be negative to ensure', &
              'square roots in integrands', &
              'are real valued'
        end if
        szc%p=p
        szc%q=q
        szc%roots=rts
        szc%roots_inv=1._dp/szc%roots
        szc%f(1)=1._dp/((rts(1)-rts(2))*(rts(1)-rts(3)))
        szc%f(2)=1._dp/((rts(2)-rts(1))*(rts(2)-rts(3)))
        szc%f(3)=1._dp/((rts(3)-rts(1))*(rts(3)-rts(2)))
        prd=real(product(szc%roots))
        if (prd < 0._dp) then
            szc%prd_roots=prd
            szc%xi=sqrt(abs(prd))
            szc%p3=1._dp/szc%xi
        else
            STOP 'init_szcmplx: sqrt(-x1.x2.x3) is imag'
        end if
    end subroutine init_szcmplx

    real(dp) function szellip_1111_roots(roots,ulim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the integral from 0 to ulim of                          !
!                                                                 !
!    x^1/2 . (x-x1)^{-1/2} . (x-x2)^{-1/2} . (x-x3)^{-1/2} dx     !
!                                                                 !
! normalised by 1 / sqrt(Omegal * H0^2)                           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        complex(dp), dimension(3), &
                intent(in) :: roots
        real(dp), intent(in) :: ulim
        complex(dp), dimension(3) :: x
        complex(dp) :: ulim_inv
        real(dp) :: w,f
! Carlson arguments are of form:  1/ulim - 1/root
        ulim_inv=dcmplx(1._dp/ulim)
        x=ulim_inv-1._dp/roots
        w=real(product(roots))
        f=TWOTHIRD/sqrt(abs(w))
        szellip_1111_roots=f*real(rj(x(1),x(2),x(3),ulim_inv))
    end function szellip_1111_roots

    real(dp) function szellip_1111(szc,ulim)
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        complex(dp), dimension(3) :: x
        complex(dp) :: ulim_inv
        real(dp) :: f
        ulim_inv=dcmplx(1._dp/ulim)
        x=ulim_inv-szc%roots_inv
        f=TWOTHIRD*szc%p3
        szellip_1111=f*real(rj(x(1),x(2),x(3),ulim_inv))
    end function szellip_1111

    real(dp) function I3prime(a1,a4,b1,b4,f,g,h,x,y)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the integral in terms of Carlson R-functions of             !
!                                                                     !
!    I3'=[1,-1,-1,-1]                                                 !
!       =\int_y^x (f+g t+h t^2) (a_1+b_1 t)^{-1/2} (a_4+b_4 t)^{-1/2} !
!                                                                     !
! where f+g t+ h t^2 > 0 and x-y > 0    [Carlson (1991) eq (2.17)]    !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        real(dp), intent(in) :: a1,a4,b1,b4
        real(dp), intent(in) :: f,g,h
        real(dp), intent(in) :: x,y
        real(dp), parameter :: TWO=2._dp,THREE=3._dp,FOUR=4._dp
        real(dp), parameter :: SIX=6._dp,NINE=9._dp
        real(dp) :: X1,X4,Y1,Y4,d14,beta1
        real(dp) :: c112,c442,c142,c11,c44,xi,eta
        real(dp) :: M2,Lp2,Lm2,U,U2,W12
        real(dp) :: Q12,P12,rho,rj_,rf_,rc_
! Carlson 1991 (2.1)
        X1=sqrt(a1+b1*x)
        X4=sqrt(a4+b4*x)
        Y1=sqrt(a1+b1*y)
        Y4=sqrt(a4+b4*y)
        d14=a1*b4-a4*b1
! Carlson 1991 (2.2)
        beta1=g*b1-TWO*h*a1
! Carlson 1991 (2.3)
        c112=TWO*f*b1*b1-g*(a1*b1+a1*b1)+TWO*h*a1*a1
        c442=TWO*f*b4*b4-g*(a4*b4+a4*b4)+TWO*h*a4*a4
        c142=TWO*f*b1*b4-g*(a1*b4+a4*b1)+TWO*h*a1*a4
        c11=sqrt(c112)
        c44=sqrt(c442)
! (2.4)
        xi=sqrt(f+x*(g+h*x))
        eta=sqrt(f+y*(g+h*y))
! (2.6) xi,eta,x,y,f,g,h all > 0
        M2=(TWO*xi*eta+TWO*f+g*(x+y)+TWO*h*x*y) &
            *((X1*Y4+Y1*X4)/(x-y))**2
! (2.7)
        Lp2=M2+c142+c11*c44
        Lm2=M2+c142-c11*c44
! (2.8)
        U=(X1*X4*eta+Y1*Y4*xi)/(x-y)
        U2=U**2
! (2.10)
        W12=U2-c112*b4/(TWO*b1)
        Q12=W12/(X1*Y1)**2
        P12=Q12+h*b4/b1
! (2.11)
        rho=d14*(beta1-sqrt(TWO*h)*c11)/b1
        rj_=FOUR*rho*rj(M2,Lm2,Lp2,M2+rho)
        rf_=-SIX*rf(M2,Lm2,Lp2)
        rc_=THREE*rc(U2,W12)
        I3prime=sqrt(TWO*c112/(NINE*h))*(rj_+rf_+rc_) &
                +TWO*rc(P12,Q12)
    end function I3prime

    complex(dp) function szellip_1311(szc,ulim) result(y)
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, dimension(3) :: p_ind
        complex(dp) :: val
        logical exists
        p_ind=(/-3,-1,-1/)
        call search_cache(ulim,p_ind,val,exists)
        if (exists) then
            y=val
            return
        else
            y=szellip_113_(szc,ulim,(/2,3,1/))
            call update_cache(ulim,p_ind,y)
            return
        end if
    end function szellip_1311

    complex(dp) function szellip_1131(szc,ulim) result(y)
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, dimension(3) :: p_ind
        complex(dp) :: val
        logical exists
        p_ind=(/-1,-3,-1/)
        call search_cache(ulim,p_ind,val,exists)
        if (exists) then
            y=val
            return
        else
            y=szellip_113_(szc,ulim,(/3,1,2/))
            call update_cache(ulim,p_ind,y)
            return
        end if
    end function szellip_1131

    complex(dp) function szellip_1113(szc,ulim) result(y)
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, dimension(3) :: p_ind
        complex(dp) :: val
        logical exists
        p_ind=(/-1,-1,-3/)
        call search_cache(ulim,p_ind,val,exists)
        if (exists) then
            y=val
            return
        else
            y=szellip_113_(szc,ulim,(/1,2,3/))
            call update_cache(ulim,p_ind,y)
            return
        end if
    end function szellip_1113

    complex(dp) function szellip_113_(szc,ulim,perm)
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, intent(in), dimension(3) :: perm
        complex(dp) :: ulim_inv,x2,x3,x4,xi,a2,a3,a4
        x2=szc%roots(perm(1))
        x3=szc%roots(perm(2))
        x4=szc%roots(perm(3))
        ulim_inv=dcmplx(1._dp/ulim)
        xi=szc%xi
        a2=ulim_inv-1._dp/x2
        a3=ulim_inv-1._dp/x3
        a4=ulim_inv-1._dp/x4
        szellip_113_=-TWOTHIRD/(x4*xi)*rd(a2,a3,a4)
    end function szellip_113_

    complex(dp) function szellip_1511(szc,ulim) result(y)
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, dimension(3) :: p_ind
        complex(dp) :: val
        logical exists
        p_ind=(/-5,-1,-1/)
        call search_cache(ulim,p_ind,val,exists)
        if (exists) then
            y=val
            return
        else
            y=szellip_115_(szc,ulim,(/2,3,1/))
            call update_cache(ulim,p_ind,y)
            return
        end if
    end function szellip_1511

    complex(dp) function szellip_1151(szc,ulim) result(y)
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, dimension(3) :: p_ind
        complex(dp) :: val
        logical exists
        p_ind=(/-1,-5,-1/)
        call search_cache(ulim,p_ind,val,exists)
        if (exists) then
            y=val
            return
        else
            y=szellip_115_(szc,ulim,(/3,1,2/))
            call update_cache(ulim,p_ind,y)
            return
        end if
    end function szellip_1151

    complex(dp) function szellip_1115(szc,ulim) result(y)
        use elliptic_cache
        implicit none
        real(dp), intent(in) :: ulim
        type(szcmplx), intent(in) :: szc
        integer, dimension(3) :: p_ind
        complex(dp) :: val
        logical exists
        p_ind=(/-1,-1,-5/)
        call search_cache(ulim,p_ind,val,exists)
        if (exists) then
            y=val
            return
        else
            y=szellip_115_(szc,ulim,(/1,2,3/))
            call update_cache(ulim,p_ind,y)
            return
        end if
    end function szellip_1115

    complex(dp) function szellip_115_(szc,ulim,perm)
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        integer, intent(in), dimension(3) :: perm
        complex(dp) :: ulim_inv,x2,x3,x4,a2,a3,a4
        complex(dp) :: s,t1,t2,t3
        real(dp) :: xi
        x2=szc%roots(perm(1))
        x3=szc%roots(perm(2))
        x4=szc%roots(perm(3))
        ulim_inv=dcmplx(1._dp/ulim)
        a2=ulim_inv-1._dp/x2
        a3=ulim_inv-1._dp/x3
        a4=ulim_inv-1._dp/x4
        xi=szc%xi
        s=TWOTHIRD*xi*szc%f(perm(3))/x4**2
        t1=THIRD*(1._dp/x2+1._dp/x3+1._dp/x4 &
                -3._dp*x4/(x2*x3))*rd(a2,a3,a4)
        t2=rf(a2,a3,a4)
        t3=-sqrt(a2)*sqrt(a3)/sqrt(a4)**3
        szellip_115_=s*(t1+t2+t3)
    end function szellip_115_

    real(dp) function szellip_3333(szc,ulim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the REAL integral from 0 to ulim of                      !
!                                                                  !
!    x^3/2 . (x-x1)^{-3/2} . (x-x2)^{-3/2} . (x-x3)^{-3/2} dx      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        complex(dp), dimension(3) :: ell,coeff
        complex(dp) :: s1
        ell(1)=szellip_1311(szc,ulim)
        ell(2)=szellip_1131(szc,ulim)
        ell(3)=szellip_1113(szc,ulim)
        coeff=szc%roots*szc%f
        s1=sum(coeff*ell)
        if (abs(aimag(s1)/s1) < ztol) then
            szellip_3333=real(s1)
        else
            STOP 'szellip_3333: result should be REAL'
        end if
    end function szellip_3333

    real(dp) function szellip_1333(szc,ulim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the REAL integral from 0 to ulim of                      !
!                                                                  !
!    x^1/2 . (x-x1)^{-3/2} . (x-x2)^{-3/2} . (x-x3)^{-3/2} dx      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        complex(dp), dimension(3) :: ell,coeff
        complex(dp) :: s1
        ell(1)=szellip_1311(szc,ulim)
        ell(2)=szellip_1131(szc,ulim)
        ell(3)=szellip_1113(szc,ulim)
        coeff=szc%f
        s1=sum(coeff*ell)
        if (abs(aimag(s1)/s1) < ztol) then
            szellip_1333=real(s1)
        else
            STOP 'szellip_1333: result should be REAL'
        end if
    end function szellip_1333

    real(dp) function szellip_5555(szc,ulim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Computes  the elliptic integral [p]=[3,-5,-5,-5]   !
! by decomposing into 6 smaller integrals:           !
!                                                    !
! [p1,p2,p3,p4] = c1 . [1,-3,-1,-1]                  !
!               + c2 . [1,-1,-3,-1]                  !
!               + c3 . [1,-1,-1,-3]                  !
!               + c4 . [1,-5,-1,-1]                  !
!               + c5 . [1,-1,-5,-1]                  !
!               + c6 . [1,-1,-1,-5]                  !
! where                                              !
!                                                    !
!   [p1,p2,p3,p4] = integral from 0 to ulim of       !
!          x^p1/2 . (x-x2)^p2/2 . (x-x3)^p3/2        !
!                 . (x-x3)^p3/2 . (x-x4)^p4/2 dx     !
! and                                                !
!                                                    !
!    c1 = 2(x2.x3.x4 - x2^3)                         !
!                / ((x2 - x3) (x2 - x4))^3           !
!                                                    !
!    c2 = 2(x2.x3.x4 - x3^3)                         !
!                / ((x3 - x2) (x3 - x4))^3           !
!                                                    !
!    c3 = 2(x2.x3.x4 - x4^3)                         !
!                / ((x4 - x2) (x4 - x3))^3           !
!                                                    !
!    c4 = x2 / ((x2 - x3) (x2 - x4))^2               !
!                                                    !
!    c5 = x3 / ((x3 - x2) (x3 - x4))^2               !
!                                                    !
!    c6 = x4 / ((x4 - x2) (x4 - x3))^2               !
!                                                    !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        complex(dp), dimension(6) :: c,y
        complex(dp) :: x2,x3,x4,prx,z
        x2=szc%roots(1)
        x3=szc%roots(2)
        x4=szc%roots(3)
        prx=dcmplx(szc%prd_roots)
        c(1)=2._dp*szc%f(1)**3*(prx-x2**3)
        c(2)=2._dp*szc%f(2)**3*(prx-x3**3)
        c(3)=2._dp*szc%f(3)**3*(prx-x4**3)
        c(4)=(x2*szc%f(1))**2
        c(5)=(x3*szc%f(2))**2
        c(6)=(x4*szc%f(3))**2
! Use simplified formula (faster)
        y(1)=c(1)*szellip_1311(szc,ulim)
        y(2)=c(2)*szellip_1131(szc,ulim)
        y(3)=c(3)*szellip_1113(szc,ulim)
        y(4)=c(4)*szellip_1511(szc,ulim)
        y(5)=c(5)*szellip_1151(szc,ulim)
        y(6)=c(6)*szellip_1115(szc,ulim)
        z=sum(y)
        if (aimag(z)/abs(z) < ztol) then
            szellip_5555 = real(z)
        else
            STOP 'szellip_5555: integral not real'
        end if
    end function szellip_5555

    real(dp) function szellip_3555(szc,ulim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! **Differs from szellip_5555 in coefficients only** !
! Computes  the elliptic integral [p]=[3,-5,-5,-5]   !
! by decomposing into 6 smaller integrals:           !
!                                                    !
! [p1,p2,p3,p4] = c1 . [1,-3,-1,-1]                  !
!               + c2 . [1,-1,-3,-1]                  !
!               + c3 . [1,-1,-1,-3]                  !
!               + c4 . [1,-5,-1,-1]                  !
!               + c5 . [1,-1,-5,-1]                  !
!               + c6 . [1,-1,-1,-5]                  !
! where                                              !
!                                                    !
!   [p1,p2,p3,p4] = integral from 0 to ulim of       !
!          x^p1/2 . (x-x2)^p2/2 . (x-x3)^p3/2        !
!                 . (x-x3)^p3/2 . (x-x4)^p4/2 dx     !
! and                                                !
!                                                    !
!    c1 = (x2.x3 + x2.x4 + x3.x4 - 3.x2^3)           !
!                / ((x2 - x3) (x2 - x4))^3           !
!                                                    !
!    c2 = (x2.x3 + x2.x4 + x3.x4 - 3.x3^3)           !
!                / ((x3 - x2) (x3 - x4))^3           !
!                                                    !
!    c3 = (x2.x3 + x2.x4 + x3.x4 - 3.x4^3)           !
!                / ((x4 - x2) (x4 - x3))^3           !
!                                                    !
!    c4 = x2 / ((x2 - x3) (x2 - x4))^2               !
!                                                    !
!    c5 = x3 / ((x3 - x2) (x3 - x4))^2               !
!                                                    !
!    c6 = x4 / ((x4 - x2) (x4 - x3))^2               !
!                                                    !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        complex(dp), dimension(6) :: c,y
        complex(dp) :: x2,x3,x4,prx,z
        x2=szc%roots(1)
        x3=szc%roots(2)
        x4=szc%roots(3)
        prx=x2*x3+x2*x4+x3*x4
        c(1)=szc%f(1)**3*(prx-3._dp*x2**2)
        c(2)=szc%f(2)**3*(prx-3._dp*x3**2)
        c(3)=szc%f(3)**3*(prx-3._dp*x4**2)
        c(4)=x2*szc%f(1)**2
        c(5)=x3*szc%f(2)**2
        c(6)=x4*szc%f(3)**2
! Use simplified formula (faster)
        y(1)=c(1)*szellip_1311(szc,ulim)
        y(2)=c(2)*szellip_1131(szc,ulim)
        y(3)=c(3)*szellip_1113(szc,ulim)
        y(4)=c(4)*szellip_1511(szc,ulim)
        y(5)=c(5)*szellip_1151(szc,ulim)
        y(6)=c(6)*szellip_1115(szc,ulim)
        z=sum(y)
        if (aimag(z)/abs(z) < ztol) then
            szellip_3555 = real(z)
        else
            STOP 'szellip_3555: integral not real'
        end if
    end function szellip_3555

    real(dp) function szellip_1555(szc,ulim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! **Differs from szellip_5555 in coefficients only** !
! Computes  the elliptic integral [p]=[3,-5,-5,-5]   !
! by decomposing into 6 smaller integrals:           !
!                                                    !
! [p1,p2,p3,p4] = c1 . [1,-3,-1,-1]                  !
!               + c2 . [1,-1,-3,-1]                  !
!               + c3 . [1,-1,-1,-3]                  !
!               + c4 . [1,-5,-1,-1]                  !
!               + c5 . [1,-1,-5,-1]                  !
!               + c6 . [1,-1,-1,-5]                  !
! where                                              !
!                                                    !
!   [p1,p2,p3,p4] = integral from 0 to ulim of       !
!          x^p1/2 . (x-x2)^p2/2 . (x-x3)^p3/2        !
!                 . (x-x3)^p3/2 . (x-x4)^p4/2 dx     !
! and                                                !
!                                                    !
!    c1 = 2(x2 + x3 + x4 - 3.x2)                     !
!                / ((x2 - x3) (x2 - x4))^3           !
!                                                    !
!    c2 = 2(x2 + x3 + x4 - 3.x3)                     !
!                / ((x3 - x2) (x3 - x4))^3           !
!                                                    !
!    c3 = 2(x2 + x3 + x4 - 3.x4)                     !
!                / ((x4 - x2) (x4 - x3))^3           !
!                                                    !
!    c4 = x2 / ((x2 - x3) (x2 - x4))^2               !
!                                                    !
!    c5 = x3 / ((x3 - x2) (x3 - x4))^2               !
!                                                    !
!    c6 = x4 / ((x4 - x2) (x4 - x3))^2               !
!                                                    !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        type(szcmplx), intent(in) :: szc
        real(dp), intent(in) :: ulim
        complex(dp), dimension(6) :: c,y
        complex(dp) :: x2,x3,x4,sumx,z
        x2=szc%roots(1)
        x3=szc%roots(2)
        x4=szc%roots(3)
        sumx=x2+x3+x4
        c(1)=szc%f(1)**3*(sumx-3._dp*x2)*2._dp
        c(2)=szc%f(2)**3*(sumx-3._dp*x3)*2._dp
        c(3)=szc%f(3)**3*(sumx-3._dp*x4)*2._dp
        c(4)=szc%f(1)**2
        c(5)=szc%f(2)**2
        c(6)=szc%f(3)**2
! Use simplified formula (faster)
        y(1)=c(1)*szellip_1311(szc,ulim)
        y(2)=c(2)*szellip_1131(szc,ulim)
        y(3)=c(3)*szellip_1113(szc,ulim)
        y(4)=c(4)*szellip_1511(szc,ulim)
        y(5)=c(5)*szellip_1151(szc,ulim)
        y(6)=c(6)*szellip_1115(szc,ulim)
        z=sum(y)
        if (aimag(z)/abs(z) < ztol) then
            szellip_1555 = real(z)
        else
            STOP 'szellip_1555: integral not real'
        end if

    end function szellip_1555

end module szelliptic


**==taup.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION TAUP(W,It)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER It
      REAL RF , TAU , TAUhe , TAUP , TPLus , W
C*** End of declarations inserted by SPAG
      COMMON /PT    / RF(500) , TAU(150) , TAUhe(150) , TPLus(150)
      TAUP = 1.E-8
      IF ( W.GT.912. ) RETURN
      TAUP = TAUP + TAU(It)*(W/912.)**3
      IF ( W.LT.504.6 ) TAUP = TAUP + TAUhe(It)
     &                         *(.763*(W/504.6)**1.99+.237*(W/504.6)
     &                         **2.99)
      IF ( W.LT.228. ) TAUP = TAUP + TPLus(It)*(W/228.)**3
      RETURN
      END


      SUBROUTINE SETUP2
*
*
*       Initial conditions in astrophysical units (#22 = -1).
*       -----------------------------------------------------
*
      INCLUDE 'common6.h'
*
*
*       Define GM & PC in cgs units and AU in pc (if preferred).
      GM = 6.67D-08*1.989D+33
      PC = 3.0857D+18
      AU = 2.0627E+05
*       Define RBAR (use appropriate value if N-body units skipped in SCALE).
      RBAR = 1.0
*
*       Read initial conditions from unit #10.
      ZMASS = 0.0
      DO 10 I = 1,N
          READ (10,*)  BODY(I), (X(K,I),K=1,3), (XDOT(K,I),K=1,3)
          ZMASS = ZMASS + BODY(I)
   10 CONTINUE
*
*       Form velocity scale in km/sec from mass in Msun & X,Y,Z in pc.
      VSTAR = 1.0D-05*SQRT(GM/PC)
      VSTAR = VSTAR*SQRT(ZMASS/RBAR)
*
*       Convert to N-body units before optional virial theorem scaling.
      DO 20 I = 1,N
          BODY(I) = BODY(I)/ZMASS
          DO 15 K = 1,3
              X(K,I) = X(K,I)/RBAR
              XDOT(K,I) = XDOT(K,I)/VSTAR
   15     CONTINUE
   20 CONTINUE
*       Note: setting KZ(5) = 3 skips scaling to N-body units (ensure RBAR).
*
      RETURN
*
      END


!WRF:MODEL_LAYER:CONSTANTS
!

 MODULE module_model_constants

   !  2. Following are constants for use in defining real number bounds.

   !  A really small number.

   REAL    , PARAMETER :: epsilon         = 1.E-15

   !  4. Following is information related to the physical constants.

   !  These are the physical constants used within the model.

! JM NOTE -- can we name this grav instead?
   REAL    , PARAMETER :: g = 9.81  ! acceleration due to gravity (m {s}^-2)

!KiD
!#if ( NMM_CORE == 1 )
   REAL    , PARAMETER :: r_d          = 287.04
   REAL    , PARAMETER :: cp           = 1004.6
!#else
!   REAL    , PARAMETER :: r_d          = 287.
!   REAL    , PARAMETER :: cp           = 7.*r_d/2.
!#endif
!/KiD
   REAL    , PARAMETER :: r_v          = 461.6
   REAL    , PARAMETER :: cv           = cp-r_d
   REAL    , PARAMETER :: cpv          = 4.*r_v
   REAL    , PARAMETER :: cvv          = cpv-r_v
   REAL    , PARAMETER :: cvpm         = -cv/cp
   REAL    , PARAMETER :: cliq         = 4190.
   REAL    , PARAMETER :: cice         = 2106.
   REAL    , PARAMETER :: psat         = 610.78
   REAL    , PARAMETER :: rcv          = r_d/cv
   REAL    , PARAMETER :: rcp          = r_d/cp
   REAL    , PARAMETER :: rovg         = r_d/g
   REAL    , PARAMETER :: c2           = cp * rcv
   real    , parameter :: mwdry        = 28.966 ! molecular weight of dry air (g/mole)

   REAL    , PARAMETER :: p1000mb      = 100000.
   REAL    , PARAMETER :: t0           = 300.
   REAL    , PARAMETER :: p0           = p1000mb
   REAL    , PARAMETER :: cpovcv       = cp/(cp-r_d)
   REAL    , PARAMETER :: cvovcp       = 1./cpovcv
   REAL    , PARAMETER :: rvovrd       = r_v/r_d

   REAL    , PARAMETER :: reradius     = 1./6370.0e03

   REAL    , PARAMETER :: asselin      = .025
!   REAL    , PARAMETER :: asselin      = .0
   REAL    , PARAMETER :: cb           = 25.

   REAL    , PARAMETER :: XLV0         = 3.15E6
   REAL    , PARAMETER :: XLV1         = 2370.
   REAL    , PARAMETER :: XLS0         = 2.905E6
   REAL    , PARAMETER :: XLS1         = 259.532

   REAL    , PARAMETER :: XLS          = 2.85E6
   REAL    , PARAMETER :: XLV          = 2.5E6
   REAL    , PARAMETER :: XLF          = 3.50E5

   REAL    , PARAMETER :: rhowater     = 1000.
   REAL    , PARAMETER :: rhosnow      = 100.
   REAL    , PARAMETER :: rhoair0      = 1.28

   REAL    , PARAMETER :: DEGRAD       = 3.1415926/180.
   REAL    , PARAMETER :: DPD          = 360./365.

   REAL    , PARAMETER ::  SVP1=0.6112
   REAL    , PARAMETER ::  SVP2=17.67
   REAL    , PARAMETER ::  SVP3=29.65
   REAL    , PARAMETER ::  SVPT0=273.15
   REAL    , PARAMETER ::  EP_1=R_v/R_d-1.
   REAL    , PARAMETER ::  EP_2=R_d/R_v
   REAL    , PARAMETER ::  KARMAN=0.4
   REAL    , PARAMETER ::  EOMEG=7.2921E-5
   REAL    , PARAMETER ::  STBOLT=5.67051E-8

   REAL    , PARAMETER ::  prandtl = 1./3.0
                                         ! constants for w-damping option
   REAL    , PARAMETER ::  w_alpha = 0.3 ! strength m/s/s
   REAL    , PARAMETER ::  w_beta  = 1.0 ! activation cfl number

       REAL , PARAMETER ::  pq0=379.90516
       REAL , PARAMETER ::  epsq2=0.2
!      REAL , PARAMETER ::  epsq2=0.02
       REAL , PARAMETER ::  a2=17.2693882
       REAL , PARAMETER ::  a3=273.16
       REAL , PARAMETER ::  a4=35.86
       REAL , PARAMETER ::  epsq=1.e-12
       REAL , PARAMETER ::  p608=rvovrd-1.
!#if ( NMM_CORE == 1 )
       REAL , PARAMETER ::  climit=1.e-20
       REAL , PARAMETER ::  cm1=2937.4
       REAL , PARAMETER ::  cm2=4.9283
       REAL , PARAMETER ::  cm3=23.5518
!       REAL , PARAMETER ::  defc=8.0
!       REAL , PARAMETER ::  defm=32.0
       REAL , PARAMETER ::  defc=0.0
       REAL , PARAMETER ::  defm=99999.0
       REAL , PARAMETER ::  epsfc=1./1.05
       REAL , PARAMETER ::  epswet=0.0
       REAL , PARAMETER ::  fcdif=1./3.
       REAL , PARAMETER ::  fcm=0.00003
       REAL , PARAMETER ::  gma=-r_d*(1.-rcp)*0.5
       REAL , PARAMETER ::  p400=40000.0
       REAL , PARAMETER ::  phitp=15000.0
       REAL , PARAMETER ::  pi2=2.*3.1415926
       REAL , PARAMETER ::  plbtm=105000.0
       REAL , PARAMETER ::  plomd=64200.0
       REAL , PARAMETER ::  pmdhi=35000.0
       REAL , PARAMETER ::  q2ini=0.50
       REAL , PARAMETER ::  rfcp=0.25/cp
       REAL , PARAMETER ::  rhcrit_land=0.75
       REAL , PARAMETER ::  rhcrit_sea=0.80
       REAL , PARAMETER ::  rlag=14.8125
       REAL , PARAMETER ::  rlx=0.90
       REAL , PARAMETER ::  scq2=50.0
       REAL , PARAMETER ::  slopht=0.001
       REAL , PARAMETER ::  tlc=2.*0.703972477
       REAL , PARAMETER ::  wa=0.15
       REAL , PARAMETER ::  wght=0.35
       REAL , PARAMETER ::  wpc=0.075
       REAL , PARAMETER ::  z0land=0.10
       REAL , PARAMETER ::  z0max=0.008
       REAL , PARAMETER ::  z0sea=0.001
!#endif

   !  Earth

   !  The value for P2SI *must* be set to 1.0 for Earth
   !  Although, now we may not need this declaration here (see above)
   !REAL    , PARAMETER :: P2SI         = 1.0

   !  Orbital constants:

   INTEGER , PARAMETER :: PLANET_YEAR = 365
   REAL , PARAMETER :: OBLIQUITY = 23.5
   REAL , PARAMETER :: ECCENTRICITY = 0.014
   REAL , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU
   ! Don't know the following values, so we'll fake them for now
   REAL , PARAMETER :: zero_date = 0.0   ! Time of perihelion passage
   !  Fraction into the year (from perhelion) of the
   !  occurrence of the Northern Spring Equinox
   REAL , PARAMETER :: EQUINOX_FRACTION= 0.0

 CONTAINS
   SUBROUTINE init_module_model_constants
   END SUBROUTINE init_module_model_constants
 END MODULE module_model_constants


      program DRMATP
c>> 2001-05-22 DRMATP Krogh Minor change for making .f90 version.
c>> 1992-04-22 CLL
c>> 1987-12-09 DRMATP Lawson  Initial Code.
c
      integer I, J, M, N
c
      integer A(4,3)
      real B(4,3)
      double precision C(4,3)
      data ((A(I,J),J=1,3),I=1,4) / 1,2,3,4,5,6,7,8,9,10,11,12 /
      data ((B(I,J),J=1,3),I=1,4) / 1.,2.,3.,4.,5.,6.,7.,8.,9.,
     *                              10.,11.,12. /
      data ((C(I,J),J=1,3),I=1,4) / 1.D0,2.D0,3.D0,4.D0,5.D0,
     *                              6.D0,7.D0,8.D0,9.D0,10.D0,
     *                              11.D0,12.D0 /
      data M / 4 /
      data N / 3 /
c
      call IMATP (A,M,M,N,'0 IMATP.. A(,)=')
      call SMATP (B,M,M,N,'0 SMATP.. B(,)=')
      call DMATP (C,M,M,N,'0 DMATP.. C(,)=')
c
      end


c     program DRSNLSGB
c>> 2001-05-24 DRSNLSGB Krogh Minor change for making .f90 version.
c>> 1997-06-18 DRSNLSGB Krogh  Changes to improve C portability.
c>> 1994-11-02 DRSNLSGB Krogh  Changes to use M77CON
c>> 1994-09-14 DRSNLSGB CLL Set IV(OUTLEV) = 0 for comparing output.
c>> 1992-04-13 CLL Rename and reorder common block [D/S]KEY.
c>> 1992-02-03 CLL @ JPL
c>> 1990-07-02 CLL @ JPL
c>> 1990-06-27 CLL @ JPL
c>> 1990-04-05 CLL @ JPL
c>> 1990-03-29 CLL @ JPL
c     Demo driver for SNLSGB. A variant of the nonlinear LS code NL2SOL.
c     SNLSGB solves the "separable" problem.
c     SNLSGB handles bounds on the nonlinear variables.
c     SNLSGB requires values of the function and the Jacobian matrix.
c     Note:  MDER is the number of ones in the array IND().
c     ------------------------------------------------------------------
c--S replaces "?": DR?NLSGB, ?NLSGB, ?CALCA, ?CALCB, ?IVSET, ?KEY
c     ------------------------------------------------------------------
      external SCALCA, SCALCB
      integer  J,IVAR,ITERM,LIV,LV,MA,MB,MDATA,MDER,NA,NB,NDATA
      parameter(MDATA = 30, MA = 2, MB = 5)
      parameter(MDER = 4)
      parameter(LIV = 115 + 4*MA + MB + 2*MDER)
      parameter(LV = 105 + MDATA*(MB+MDER+MA+3) +
     *               (MB*(MB+3))/2 + MA*(2*MA+21))
      integer IND(MB+1,MA), IV(LIV)
      integer F, OUTLEV, SOLPRT, STATPR, X0PRT
      parameter(F=10, OUTLEV=19, SOLPRT=22, STATPR=23, X0PRT=24)
      real             ALF(MA), BET(MB), BND(2,MA)
      real             DOF, V(LV), YDATA(MDATA)
      data (BND(1,J),J=1,2) /  2*5.0e0 /
      data (BND(2,J),J=1,2) / 2*10.0e0 /
      data ((IND(ITERM,IVAR),IVAR = 1,2),ITERM = 1,6)/
     *     0, 0,
     *     1, 0,
     *     1, 0,
     *     0, 1,
     *     0, 1,
     *     0, 0/
      data YDATA /
     *     1.700641e0, 1.793512e0, 1.838309e0, 1.838416e0, 1.792204e0,
     *     1.700501e0, 1.579804e0, 1.426268e0, 1.260724e0, 1.084901e0,
     *     0.917094e0, 0.761920e0, 0.627304e0, 0.522146e0, 0.446645e0,
     *     0.404920e0, 0.392033e0, 0.409622e0, 0.453045e0, 0.510765e0,
     *     0.584554e0, 0.663109e0, 0.747613e0, 0.829439e0, 0.908496e0,
     *     0.983178e0, 1.051046e0, 1.114072e0, 1.171746e0, 1.227823e0/
c     ------------------------------------------------------------------
      NDATA = MDATA
      NA = MA
      NB = MB
      ALF(1) =    5.0e0
      ALF(2) =   10.0e0
      IV(1) = 0

      print'(1x,a)',
     * 'Program DRSNLSGB.. Demo driver for SNLSGB.',
     * '   A variant of NL2SOL.',
     * '   SNLSGB handles the Separable problem.',
     * '   SNLSGB requires values of the function and the Jacobian.',
     * '   SNLSGB handles bounds on the nonlinear variables.',
     * ' ',
     * 'Sample problem is a nonlinear curve fit to data.',
     * 'Model function is B1 + B2 * cos(A1*t) + B3 * sin(A1*t) +',
     * '                       B4 * cos(A2*t) + B5 * sin(A2*t) + Noise',
     * 'Data generated using',
     * '(A1, A2, B1, ..., B5) = (6, 9, 1, 0.5, 0.4, 0.2, 0.1)',
     * 'and Gaussian noise with mean 0 and',
     * 'sample standard deviation 0.001',
     * ' '

      call SIVSET(1, IV, LIV, LV, V)
      IV( X0PRT) = 1
      IV(OUTLEV) = 0
      IV(STATPR) = 1
      IV(SOLPRT) = 1

      call SNLSGB(NDATA, NA, NB, ALF, BND, BET, YDATA, SCALCA, SCALCB,
     *         IND, NB+1, IV, LIV, LV, V)

      DOF = max(NDATA - NA - NB, 1)
      print'(1x/1x,a,g12.4)',
     *    'SIGFAC: sqrt((2 * V(F))/DOF) =',
     *             sqrt(2.0e0 * V(F)/DOF)
      stop
      end
c     ==================================================================
      subroutine SCALCA(NDATA, NA, NB, ALF, NCOUNT, PHI)
c     Test case for separable nonlinear least squares computation.
c     Computes MDATA x NB matrix PHI as a function of the
c     nonlinear parameters ALF().
c     For J .le. NB the (I,J) term of PHI is the coefficient of the
c     linear coefficient B(J) in row I of the model.
c     In this example the model does not have a term that is not
c     multiplied by a linear coefficient.  If such a term is present
c     then PHI must have an (NB+1)st column to hold this term.
c     This code Illustrates saving results in common between SCALCA and
c     SCALCB to avoid recalculation of common subexpressions.
c     ------------------------------------------------------------------
      common/SKEY/C1, C2, S1, S2, KEY
      save  /SKEY/
      integer I, KEY, MDATA, NA, NB, NCOUNT, NDATA
      parameter(MDATA = 30)
      real             ALF(NA), C1(MDATA), C2(MDATA)
      real             DEL, PHI(NDATA,NB)
      real             S1(MDATA), S2(MDATA), T
c     ------------------------------------------------------------------
      T = 0.0E0
      DEL = 1.0E0 / 29.0E0
      KEY = NCOUNT
      do 10 I = 1,NDATA
         C1(I) = cos(ALF(1)*T)
         S1(I) = sin(ALF(1)*T)
         C2(I) = cos(ALF(2)*T)
         S2(I) = sin(ALF(2)*T)
         PHI(I,1) = 1.0E0
         PHI(I,2) = C1(I)
         PHI(I,3) = S1(I)
         PHI(I,4) = C2(I)
         PHI(I,5) = S2(I)
         T = T + DEL
   10 continue
      return
      end
c     ==================================================================
      subroutine SCALCB(NDATA, NA, NB, ALF, NCOUNT, DER)
c     Test case for separable nonlinear least squares computation.
c     Computes the NDATA x NDER matrix DER.  Here NDER is the number of
c     ones in the indicator array IND().  The columns of DER correspond
c     to nonzero entries of IND() traversed columnwise.
c     In this example NDER is 4 and the correspondence is as follows:
c         Col of DER:         1       2       3       4
c         Element of IND(): (2,1)   (3,1)   (4,2)   (5,2)
c     In this example Row I of DER will be set to contain the values
c     of the four partial derivatives:
c         Partial of PHI(I,2) with respect to ALP(1)
c         Partial of PHI(I,3) with respect to ALP(1)
c         Partial of PHI(I,4) with respect to ALP(2)
c         Partial of PHI(I,5) with respect to ALP(2)
c     ------------------------------------------------------------------
      common/SKEY/C1, C2, S1, S2, KEY
      save  /SKEY/
      integer I, KEY, MDATA, NCOUNT, NDATA, NA, NB, NDER
      parameter(MDATA = 30, NDER = 4)
      real             ALF(NA), C1(MDATA), C2(MDATA)
      real             DEL, DER(NDATA,NDER), S1(MDATA), S2(MDATA), T
c     ------------------------------------------------------------------
      T = 0.0E0
      DEL = 1.0E0 / 29.0E0
      if(NCOUNT .eq. KEY) then
         do 10 I = 1,NDATA
            DER(I,1) = -S1(I)*T
            DER(I,2) =  C1(I)*T
            DER(I,3) = -S2(I)*T
            DER(I,4) =  C2(I)*T
            T = T + DEL
   10    continue
      else
         do 20 I = 1,NDATA
            DER(I,1) = -sin(ALF(1)*T)*T
            DER(I,2) =  cos(ALF(1)*T)*T
            DER(I,3) = -sin(ALF(2)*T)*T
            DER(I,4) =  cos(ALF(2)*T)*T
            T = T + DEL
   20    continue
      endif
      return
      end


program arrayprog
real :: number(5)
integer:: matrix (3,3)
do i = 1,5
number(i) =i*2.0
end do
do i = 1,5
print*, number(i)
end do
do i =1,3
do j = 1,3
matrix (i,j) = i+j
end do
end do
do i =1,3
do j =1,3
print*,matrix(i,j)
end do
end do
numbers = (/1.5,3.2,4.5,5.0,9,7.2/)
do i =1,5
print*,number(i)
end do
end program arrayprog


! { dg-do run }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

module SIMD3_mod
contains
  subroutine work( a, b, n, sum )
     implicit none
     integer :: i, n
     double precision :: a(n), b(n), sum, tmp

     sum = 0.0d0
     call init(a, b, n)
     !$omp simd private(tmp) reduction(+:sum)
     do i = 1,n
        tmp = a(i) + b(i)
        sum = sum + tmp
     end do

  end subroutine work

  subroutine work_ref( a, b, n, sum )
     implicit none
     integer :: i, n
     double precision :: a(n), b(n), sum, tmp

     sum = 0.0d0
     call init(a, b, n)
     do i = 1,n
        tmp = a(i) + b(i)
        sum = sum + tmp
     end do

  end subroutine work_ref

  subroutine init (a, b, n)
    double precision :: a(*), b(*)
    integer          :: n, i, s

    s = -1
    do i = 1, n
      a(i) = i * i * s
      b(i) = i + i
      s = -s
    end do

  end subroutine
end module

program SIMD3
  use SIMD3_mod
  double precision :: a(128), b(128), sum, sum_ref, diff
  double precision, parameter :: EPS = 0.0000000000000001

  call  work(a, b, 128, sum)
  call  work_ref(a, b, 128, sum_ref)

  diff = sum - sum_ref

  if (diff > EPS .or. -diff > EPS) call abort

end program


SUBROUTINE ksone(data,n,func,d,prob)
INTEGER*4 n
REAL*8 d,data(n),func,prob
EXTERNAL func
!USES probks,sort
INTEGER*4 j
REAL*8 dt,en,ff,fn,fo,probks
call sort(n,data)
en=n
d=0.
fo=0.
do j=1,n
	fn=j/en
	ff=func(data(j))
	dt=max(abs(fo-ff),abs(fn-ff))
	if(dt.gt.d)d=dt
	fo=fn
enddo
en=sqrt(en)
prob=probks((en+0.12+0.11/en)*d)
return
END


!
! Tuned Fortran 77 version
! Optimizations:
! - Rather than four separate arrays, one 4D array is allocated.  This
!   allows P1, P2, P3, and C to be interlaced in memory, improving data
!   locality
! - The stencil is tiled to improve cache usage
! - Instead of copying, the indices into the 4D array are shuffled.

!      INTEGER N, iters
!      REAL check

!      N = 112
!      iters = 210
!      CALL acoustic3d_f77Tuned(N,iters,check)
!      PRINT *, check
!      END

      SUBROUTINE acoustic3d_f77Tuned(N, niters, check)
      INTEGER N, niters, iter
      REAL check
      REAL P1(N,N,N), P2(N,N,N), P3(N,N,N), C(N,N,N)

      CALL acoust3d_f77Tuned_setup(P1,P2,P3,C,N)

      DO iter = 1, niters, 3
        CALL acoustic3d_f77Tuned_stencil(P1,P2,P3,C,N)
        CALL acoustic3d_f77Tuned_stencil(P2,P3,P1,C,N)
        CALL acoustic3d_f77Tuned_stencil(P3,P1,P2,C,N)
      END DO

      check = P1(N/2,N/2,N/2)

      RETURN
      END

      SUBROUTINE acoustic3d_f77Tuned_stencil(P1,P2,P3,C,N)
      INTEGER N
      REAL P1(N,N,N), P2(N,N,N), P3(N,N,N), C(N,N,N)
      INTEGER i,j,k
      INTEGER bi,bj,bk,ni,nj,nk,blockSize

      blockSize = 8

      DO bk=2,N-1,blockSize
        nk = min(bk+blockSize-1,N-1)
        DO bj=2,N-1,blockSize
          nj = min(bj+blockSize-1,N-1)
          DO bi=2,N-1,blockSize
            ni = min(bi+blockSize-1,N-1)
            DO k=bk,nk
              DO j=bj,nj
                DO i=bi,ni
                  P3(i,j,k) = (2-6*C(i,j,k))*P2(i,j,k)
     .              + C(i,j,k) * (P2(i,j-1,k) + P2(i,j+1,k)
     .              + P2(i-1,j,k) + P2(i+1,j,k) + P2(i,j,k-1)
     .              + P2(i,j,k+1)) - P1(i,j,k)
                END DO
              END DO
            END DO
          END DO
        END DO
      END DO

      RETURN
      END

      SUBROUTINE acoust3d_f77Tuned_setup(P1, P2, P3, c, N)
      INTEGER N
      REAL P1(N,N,N), P2(N,N,N), P3(N,N,N), c(N,N,N)
      INTEGER i, j, k
      INTEGER cavityLeft, cavityRight, cavityFront, cavityBack,
     .        cavityTop, cavityBottom, cavityTop2, cavityBottom2
      REAL ci, cj, ck, s2

!     Set up velocity field

      DO k=1,N
        DO j=1,N
          DO i=1,N/2
            c(i,j,k) = 0.05
          END DO
          DO i=N/2+1,N
            c(i,j,k) = 0.3
          END DO
        END DO
      END DO

!     Cavities

      cavityLeft = 3 * N / 7.0
      cavityRight = 4 * N / 7.0
      cavityFront = 3 * N / 7.0
      cavityBack = 4 * N / 7.0
      cavityTop = 5 * N / 7.0
      cavityBottom = 6 * N / 7.0
      cavityTop2 = 1 * N / 7.0
      cavityBottom2 = 2 * N / 7.0

      DO k=cavityFront, cavityBack
        DO j=cavityLeft, cavityRight
          DO i=cavityTop, cavityBottom
            c(i,j,k) = 0.02
          END DO
          DO i=cavityTop2, cavityBottom2
            c(i,j,k) = 0.001
          END DO
        END DO
      END DO

!     Initial pressure distribution

      ci = N/2.0
      cj = N/2.0
      ck = N/2.0
      s2 = 64.0 * 9.0 / ((N/2.0) ** 2)

      DO k=1,N
        DO j=1,N
          DO i=1,N
            P1(i,j,k) = 0.0
            P2(i,j,k) = exp(- ((i-ci)**2+(j-cj)**2+(k-ck)**2) * s2)
            P3(i,j,k) = 0.0
          END DO
        END DO
      END DO

      CALL acoust3d_f77Tuned_setup_check(P2, N)
      CALL acoust3d_f77Tuned_setup_check(c, N)

      RETURN
      END

      SUBROUTINE acoust3d_f77Tuned_setup_check(P, N)
      INTEGER N
      REAL P(N,N,N)
      INTEGER i, j, k
      REAL check

      check = 0.0
      DO k=1,N
        DO j=1,N
          DO i=1,N
            check = check + P(i,j,k) * (i+N*j+N*N*k)
          END DO
        END DO
      END DO

      PRINT *, 'Array check: ', check

      RETURN
      END


      subroutine array_args(nx, ny, int_arr_in,
     \                      cmplx_arr_inout,
     \                      real_arr_out)

          integer nx, ny
          integer int_arr_in(nx, ny)
          complex cmplx_arr_inout(nx, ny)
          real real_arr_out(nx, ny)

Cf2py intent(in) nx, ny
Cf2py intent(in) int_arr_in
Cf2py intent(inout) cmplx_arr_inout
Cf2py intent(out) real_arr_out

C ... body of subroutine unchanged ...

        integer i, j

        do j = 1, ny
            do i = 1, nx
                cmplx_arr_inout(i,j) = cmplx(int_arr_in(i,j),
   \                   int_arr_in(i,j))
                real_arr_out(i,j) = real(int_arr_in(i,j))
            enddo
        enddo

      end subroutine array_args


CU    SUBROUTINE shoot(n2,v,f) is named "funcv" for use with "newt"
      SUBROUTINE funcv(n2,v,f)
      INTEGER n2,nvar,kmax,kount,KMAXX,NMAX
      REAL f(n2),v(n2),x1,x2,dxsav,xp,yp,EPS
      PARAMETER (NMAX=50,KMAXX=200,EPS=1.e-6)
      COMMON /caller/ x1,x2,nvar
      COMMON /path/ kmax,kount,dxsav,xp(KMAXX),yp(NMAX,KMAXX)
CU    USES derivs,load,odeint,rkqs,score
      INTEGER nbad,nok
      REAL h1,hmin,y(NMAX)
      EXTERNAL derivs,rkqs
      kmax=0
      h1=(x2-x1)/100.
      hmin=0.
      call load(x1,v,y)
      call odeint(y,nvar,x1,x2,EPS,h1,hmin,nok,nbad,derivs,rkqs)
      call score(x2,y,f)
      return
      END

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


c=============================================================================c
        program pcurve
c=============================================================================c
c
c  Purpose:  Compute the "optimal" streamwise point distribution based on the
c            curvature of the parabolic cylinder.
c
c  Author:   S. Scott Collis
c
c  Revised:  7-15-96
c
c=============================================================================c
        implicit double precision (a-h,o-z)

        parameter (mx=5000)
        dimension eta(mx), s(mx), ds1(mx), dss1(mx)
        common /path/ eta, s

        common /xloc/ s1

        common /stuff/ c1, c2, dsmin, xmax, smax, nx

        external derivs, func, rtflsp, func2

        parameter (zero=0.0d0,    pt5=0.5d0,  one=1.0d0,
     &             onept5=1.5d0,  two=2.0d0,  twopt5=2.5d0,
     &             three=3.0d0)

c.... fourth order central difference ( 1 2 x 4 5 )

        parameter ( ga1 =  8.333333333333333333333E-02 )
        parameter ( ga2 = -6.666666666666666666667E-01 )
        parameter ( ga3 =  6.666666666666666666667E-01 )
        parameter ( ga4 = -8.333333333333333333333E-02 )

c.... fourth order one-sided ( x 2 3 4 5 )

        parameter ( gc1 = -2.083333333333333333333E+00 )
        parameter ( gc2 =  4.000000000000000000000E+00 )
        parameter ( gc3 = -3.000000000000000000000E+00 )
        parameter ( gc4 =  1.333333333333333333333E+00 )
        parameter ( gc5 = -2.500000000000000000000E-01 )

c.... fourth order biased difference ( 1 x 2 3 4 5 )

        parameter ( gb1 = -2.500000000000000000000E-01 )
        parameter ( gb2 = -8.333333333333333333333E-01 )
        parameter ( gb3 =  1.500000000000000000000E+00 )
        parameter ( gb4 = -5.000000000000000000000E-01 )
        parameter ( gb5 =  8.333333333333333333333E-02 )
c=============================================================================c
        s(1) = 0.0
        eta1 = 0.0
        eta2 = 1.0

        dsmin = 0.05
        dsmax = 2.0

        write(*,"('Enter nx1, dsmin, Lx ==> ',$)")
        read(*,*) nx, dsmin, xmax
        if (nx .gt. mx) then
          write(*,*) 'ERROR: nx > mx in pcurve'
          call exit(1)
        endif
        smax  = sloc(xmax)
        dsmax = rtflsp( func2, 0.1d0, 5.0d0, 1.0d-14 )
        write(*,*) 'smax = ',smax,' dsmax = ',dsmax

        c2 = (1.0 / dsmax) / real(nx-1)
        c1 = (1.0 / dsmin) / real(nx-1) - c2

        write(*,"('Enter nx2 ==> ',$)")
        read(*,*) nx
        if (nx .gt. mx) then
          write(*,*) 'ERROR: nx > mx in pcurve'
          call exit(1)
        endif

        call RUNGE( s(1), 1, eta1, eta2, nx-1, derivs )
c
c.... compute the derivative of the mapping function and spline it
c
c       do i = 1, nx
c         if (i.eq.1) then
c           dsl = (s(i+1)-s(i))/(eta(i+1)-eta(i))
c           dssl = (ds1(i+1)-ds1(i))/(eta(i+1)-eta(i))
c         else if (i.eq.nx) then
c           dsl = (s(i)-s(i-1))/(eta(i)-eta(i-1))
c           dssl = (ds1(i)-ds1(i-1))/(eta(i)-eta(i-1))
c         else
c           dsl = (s(i+1)-s(i-1))/(eta(i+1)-eta(i-1))
c           dssl = (ds1(i+1)-ds1(i-1))/(eta(i+1)-eta(i-1))
c         end if
c       end do

        ds = one / real(nx-1)

        ds1(1) = ( gc1 * s(1) + gc2 * s(2) + gc3 * s(3) +
     &             gc4 * s(4) + gc5 * s(5) ) / ds
        ds1(2) = ( gb1 * s(1) + gb2 * s(2) + gb3 * s(3) +
     &             gb4 * s(4) + gb5 * s(5) ) / ds
        do i = 3, nx-2
           ds1(i) = ( ga1 * s(i-2) + ga2 * s(i-1) +
     &                ga3 * s(i+1) + ga4 * s(i+2) ) / ds
        end do
        ds1(nx-1) = -( gb1 * s(nx) + gb2 * s(nx-1) +
     &                 gb3 * s(nx-2) +
     &                 gb4 * s(nx-3) + gb5 * s(nx-4) ) / ds
        ds1(nx) = -( gc1 * s(nx) + gc2 * s(nx-1) +
     &               gc3 * s(nx-2) +
     &               gc4 * s(nx-3) + gc5 * s(nx-4) ) / ds
c       do i = 1, nx
c          ds1(i) = 1.0 / ds1(i)
c       end do
c
c.... compute the second derivative of the mapping function
c
        dss1(1) = ( gc1 * ds1(1) + gc2 * ds1(2) + gc3 * ds1(3) +
     &              gc4 * ds1(4) + gc5 * ds1(5) ) / ds
        dss1(2) = ( gb1 * ds1(1) + gb2 * ds1(2) + gb3 * ds1(3) +
     &              gb4 * ds1(4) + gb5 * ds1(5) ) / ds
        do i = 3, nx-2
           dss1(i) = ( ga1 * ds1(i-2) + ga2 * ds1(i-1) +
     &                 ga3 * ds1(i+1) + ga4 * ds1(i+2) ) / ds
        end do
        dss1(nx-1) = -( gb1 * ds1(nx) + gb2 * ds1(nx-1) +
     &                  gb3 * ds1(nx-2) + gb4 * ds1(nx-3) +
     &                  gb5 * ds1(nx-4) ) / ds
        dss1(nx) = -( gc1 * ds1(nx) + gc2 * ds1(nx-1) +
     &                gc3 * ds1(nx-2) +
     &                gc4 * ds1(nx-3) + gc5 * ds1(nx-4) ) / ds
c       do i = 1, nx
c          dss1(i) = dss1(i) * ds1(i)
c       end do

        open(10,file='tangent.map',status='unknown')
        do i = 1, nx
          s1 = s(i)
          x = rtflsp( func, 0.0d0, 1000.0d0, 1.0d-14)
          write(10,10) eta(i), s(i), ds1(i), dss1(i)
 10       format(8(1pe13.6,1x))
        end do
        close(10)

        stop
        end
c=============================================================================c
        function func2(dsmax)
c=============================================================================c
        implicit double precision (a-h,o-z)

        parameter (mx=5000)
        dimension eta(mx), s(mx)
        common /path/ eta, s

        common /stuff/ c1, c2, dsmin, xmax, smax, nx

        external derivs
c=============================================================================c
        s(1) = 0.0
        eta1 = 0.0
        eta2 = 1.0

        c2 = (1.0 / dsmax) / real(nx-1)
        c1 = (1.0 / dsmin) / real(nx-1) - c2

        call RUNGE( s(1), 1, eta1, eta2, nx-1, derivs )

        func2 = smax - s(nx)

        return
        end
c=============================================================================c
        subroutine derivs(eta, s, ds)
c=============================================================================c
        implicit double precision (a-h,o-z)
        external rtflsp, func

        common /xloc/ s1
        common /stuff/ c1, c2, dsmin, xmax, smax, nx
c=============================================================================c
        s1 = s
        x  = rtflsp( func, 0.0d0, s1, 1.0d-14)

        rk = -(2.0 * x + 1.0)**(-1.5)

        ds = 1.0 / ( c1 * abs(rk) + c2 )

        return
        end
c=============================================================================c
        function func(x)
c=============================================================================c
        implicit double precision (a-h,o-z)
        common /xloc/ s
c=============================================================================c
        y = sqrt(2.0 * x)
        func = s - 0.5 * (y  * sqrt(1.0 + y**2) +
     &                    log( abs(y + sqrt(1.0 + y**2)) ) )

        return
        end
c=============================================================================c
        function sloc(x)
c=============================================================================c
        implicit double precision (a-h,o-z)
c------------------------------------------------------------------------------
        y = sqrt(2.0 * x)
        sloc =  0.5 * (y  * sqrt(1.0 + y**2) +
     &                 log( abs(y + sqrt(1.0 + y**2)) ) )

        return
        end


PROGRAM fptest
  !--------- -------- --------- --------- --------- --------- --------- --------- -----
  !
  ! Example program 1 for using the function parser module
  !
  !--------- -------- --------- --------- --------- --------- --------- --------- -----
  USE parameters, ONLY: rn
  USE fparser,    ONLY: initf, parsef, evalf, EvalErrType, EvalErrMsg
  IMPLICIT NONE
  INTEGER,                             PARAMETER :: nfunc = 4
  CHARACTER (LEN=*), DIMENSION(nfunc), PARAMETER :: func = (/ '-1.0*x        ',  &
                                                              '-x            ',  &
                                                              'A*COS(B*x)+5  ',  &
                                                              'A*COS(B*x)+5.0' /)
  INTEGER,                             PARAMETER :: nvar = 3
  CHARACTER (LEN=*), DIMENSION(nvar),  PARAMETER :: var  = (/ 'x', &
                                                              'A', &
                                                              'B'  /)
  REAL(rn),          DIMENSION(nvar),  PARAMETER :: val  = (/  2., 3., 4. /)
  REAL(rn)                                       :: res
  INTEGER                                        :: i
  REAL(rn)                                       :: x,A,B
  !--------- -------- --------- --------- --------- --------- --------- --------- -----
  !
  CALL initf (nfunc)                      ! Initialize function parser for nfunc functions
  DO i=1,nfunc
     CALL parsef (i, func(i), var)        ! Parse and bytecompile ith function string
  END DO
  WRITE(*,*)'-----------------------------------------------------------------------------'
  WRITE(*,*)'==> Bytecode evaluation:'
  DO i=1,nfunc
     res = evalf (i, val)                 ! Interprete bytecode representation of ith function
     IF (EvalErrType > 0) WRITE(*,*)'*** Error: ',EvalErrMsg ()
     WRITE(*,*) func(i),'=',res
  END DO
  WRITE(*,*)'==> Direct evaluation:'
  x  = val(1)
  A  = val(2)
  B  = val(3)
  WRITE(*,*)'-1.0*x        =',-1.0*x
  WRITE(*,*)'-x            =',-x
  WRITE(*,*)'A*COS(B*x)+5  =',A*COS(B*x)+5
  WRITE(*,*)'A*COS(B*X)+5.0=',A*COS(B*X)+5.0
  !
END PROGRAM fptest


!>
subroutine myfunc(x, z)
implicit none
! Use somemodule
real*8 :: temp1      !>
real*8, intent(in) :: x      !>
real*8, dimension(:), intent(out) :: z      !>
!
! Doc example. Chapter 4.
! $Revision: 1.1 $
temp1 = x .* 10 .* sin(x)
z = anint(temp1)
end subroutine  myfunc


      REAL*8 FUNCTION dsgamma(a)
c mods by ML. double precision,
	IMPLICIT INTEGER (I-N), REAL*8 (A-H, O-Z)

C**********************************************************************C
C                                                                      C
C                                                                      C
C     (STANDARD-)  G A M M A  DISTRIBUTION                             C
C                                                                      C
C                                                                      C
C**********************************************************************C
C**********************************************************************C
C                                                                      C
C               PARAMETER  A >= 1.0  !                                 C
C                                                                      C
C**********************************************************************C
C                                                                      C
C     FOR DETAILS SEE:                                                 C
C                                                                      C
C               AHRENS, J.H. AND DIETER, U.                            C
C               GENERATING GAMMA VARIATES BY A                         C
C               MODIFIED REJECTION TECHNIQUE.                          C
C               COMM. ACM, 25,1 (JAN. 1982), 47 - 54.                  C
C                                                                      C
C     STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER     C
C                                 (STRAIGHTFORWARD IMPLEMENTATION)     C
C                                                                      C
C     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
C     SUNIF.  The argument IR thus goes away.                          C
C                                                                      C
C**********************************************************************C
C                                                                      C
C               PARAMETER  0.0 < A < 1.0  !                            C
C                                                                      C
C**********************************************************************C
C                                                                      C
C     FOR DETAILS SEE:                                                 C
C                                                                      C
C               AHRENS, J.H. AND DIETER, U.                            C
C               COMPUTER METHODS FOR SAMPLING FROM GAMMA,              C
C               BETA, POISSON AND BINOMIAL DISTRIBUTIONS.              C
C               COMPUTING, 12 (1974), 223 - 246.                       C
C                                                                      C
C     (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER)    C
C                                                                      C
C**********************************************************************C
C
C
C     INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION
C     OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION
C
C     COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K))
C     COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K)
C     COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K)
C
      DATA q1,q2,q3,q4,q5,q6,q7/.04166669,.02083148,.00801191,.00144121,
     +     -.00007388,.00024511,.00024240/
      DATA a1,a2,a3,a4,a5,a6,a7/.3333333,-.2500030,.2000062,-.1662921,
     +     .1423657,-.1367177,.1233795/
      DATA e1,e2,e3,e4,e5/1.,.4999897,.1668290,.0407753,.0102930/
C
C     PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A"
C     SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380
C
      DATA aa/0.0/,aaa/0.0/,sqrt32/5.656854/
C
C     SAVE STATEMENTS
C
      SAVE aa,aaa,s2,s,d,q0,b,si,c
C
      IF (a.EQ.aa) GO TO 10
      IF (a.LT.1.0) GO TO 140
C
C     STEP  1:  RECALCULATIONS OF S2,S,D IF A HAS CHANGED
C
      aa = a
      s2 = a - 0.5
      s = sqrt(s2)
      d = sqrt32 - 12.0*s
C
C     STEP  2:  T=STANDARD NORMAL DEVIATE,
C               X=(S,1/2)-NORMAL DEVIATE.
C               IMMEDIATE ACCEPTANCE (I)
C
   10 t = dsnorm()
      x = s + 0.5*t
      dsgamma = x*x
      IF (t.GE.0.0) RETURN
C
C     STEP  3:  U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S)
C
      u = dranf()
      IF (d*u.LE.t*t*t) RETURN
C
C     STEP  4:  RECALCULATIONS OF Q0,B,SI,C IF NECESSARY
C
      IF (a.EQ.aaa) GO TO 40
      aaa = a
      r = 1.0/a
      q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r
C
C               APPROXIMATION DEPENDING ON SIZE OF PARAMETER A
C               THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND
C               C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS
C
      IF (a.LE.3.686) GO TO 30
      IF (a.LE.13.022) GO TO 20
C
C               CASE 3:  A .GT. 13.022
C
      b = 1.77
      si = .75
      c = .1515/s
      GO TO 40
C
C               CASE 2:  3.686 .LT. A .LE. 13.022
C
   20 b = 1.654 + .0076*s2
      si = 1.68/s + .275
      c = .062/s + .024
      GO TO 40
C
C               CASE 1:  A .LE. 3.686
C
   30 b = .463 + s + .178*s2
      si = 1.235
      c = .195/s - .079 + .16*s
C
C     STEP  5:  NO QUOTIENT TEST IF X NOT POSITIVE
C
   40 IF (x.LE.0.0) GO TO 70
C
C     STEP  6:  CALCULATION OF V AND QUOTIENT Q
C
      v = t/ (s+s)
      IF (abs(v).LE.0.25) GO TO 50
      q = q0 - s*t + 0.25*t*t + (s2+s2)*log(1.0+v)
      GO TO 60

   50 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
C
C     STEP  7:  QUOTIENT ACCEPTANCE (Q)
C
   60 IF (log(1.0-u).LE.q) RETURN
C
C     STEP  8:  E=STANDARD EXPONENTIAL DEVIATE
C               U= 0,1 -UNIFORM DEVIATE
C               T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE
C
   70 e = dsexpo()
      u = dranf()
      u = u + u - 1.0
      t = b + sign(si*e,u)
      IF (.NOT. (u.GE.0.0)) GO TO 80
      t = b + si*e
      GO TO 90

   80 t = b - si*e

C
C     STEP  9:  REJECTION IF T .LT. TAU(1) = -.71874483771719
C
   90 IF (t.LT. (-.7187449)) GO TO 70
C
C     STEP 10:  CALCULATION OF V AND QUOTIENT Q
C
      v = t/ (s+s)
      IF (abs(v).LE.0.25) GO TO 100
      q = q0 - s*t + 0.25*t*t + (s2+s2)*log(1.0+v)
      GO TO 110

  100 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
C
C     STEP 11:  HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8)
C
  110 IF (q.LE.0.0) GO TO 70
      IF (q.LE.0.5) GO TO 120
      w = exp(q) - 1.0
      GO TO 130

  120 w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q
C
C               IF T IS REJECTED, SAMPLE AGAIN AT STEP 8
C
  130 IF (c*abs(u).GT.w*exp(e-0.5*t*t)) GO TO 70
      x = s + 0.5*t
      dsgamma = x*x
      RETURN
C
C     ALTERNATE METHOD FOR PARAMETERS A BELOW 1  (.3678794=EXP(-1.))
C
  140 aa = 0.0
      b = 1.0 + .3678794*a
  150 p = b*dranf()
      IF (p.GE.1.0) GO TO 160
      dsgamma = exp(log(p)/a)
      IF (dsexpo().LT.dsgamma) GO TO 150
      RETURN

  160 dsgamma = -log((b-p)/a)
      IF (dsexpo().LT. (1.0-a)*log(dsgamma)) GO TO 150
      RETURN

      END


!
!   FnVFFRetJ.f90
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFFRetJ(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

cons=gliq-FnQb(bsav,0.0d0)*bsav

if(cons .GT. cmin) then

    FnVFFRetJ = -1.0d0*(urent(cons,GridHR(1),gij)-xi+ubequest(bsav))

else

FnVFFRetJ = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFFRetJ


subroutine SHBiasK(tapers, lwin, numk, incspectra, ldata, outcspectra, taper_wt, save_cg)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will compute the expected multitaper windowed (cross-)power spectra
!	using the first K tpaers of the spherical cap concentration problem for a given input
!	(cross-)power spectrum. Note that this routine makes the assumption that
!	the known spectra can be described as a random variable. If the input
!	spectra is a cross-power spectra, then it is assumed that the two
!	fields are linearly related. The default is to apply an equal weight to each expected
!	spectrum, but this can be changed by specifying the optional arguement taper_wt.
!	The sum of taper_wt will be normalized to unity.
!
!	Calling Parameteters
!		IN
!			tapers		The coefficients of the tapers (lwin+1, >=numk) corresponding to the
!					spherical cap concentration problem, where each column corresponds
!					to the coefficients for a given value of m. Note the the exact value
!					of m is not important for this routine.
!			lwin		Maximum spherical harmonic degree of the window coefficients.
!			incspectra	Knonw input (cross-)power spectrum as a function of degree.
!			ldata		Maximum degree of incspectra. Beyong this degree
!					incspectra is assumed to be zero.
!		IN (Optional)
!			taper_wt	Vector of length numk corresponding to the weights applied
!					to each spectal estimate. The sum of taper_wt will be normalized
!					to unity.
!			save_cg		If 1, the Clebsch-Gordon coefficients will be calculated
!					and saved, and then used in all subsequent calls (if lwin
!					and ldata are not changed).
!					If -1, the allocated memory for these terms will be deallocated.
!		OUT
!			outcspectra	Biassed estimate of the windowed
!					power spectra. Maximum degree calculated is equal
!					to lwin + ldata, or the dimension of outspectra.
!
!	Dependencies: Wigner3j
!
!	Written by Mark Wieczorek, June 2006.
!
!	Modified May 5 2009 in oder to allow the Clebsch-Gordon coefficients to be precomputed and saved.
!	November 5 (2009). Fixed a major bug that would give wrong answers when SAVE_CG=1.
!
!	Copyright (c) 2006-2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: Wigner3j
	implicit none

	real*8, intent(in) ::	tapers(:,:), incspectra(:)
	real*8, intent(out) ::	outcspectra(:)
	integer, intent(in) ::	lwin, ldata, numk
	real*8, intent(in), optional :: taper_wt(:)
	integer, intent(in), optional :: save_cg
	integer ::	l, i, j, lmax, imin, imax, k, astat
	real*8 :: 	wig(2*lwin+ldata+1)
	real*8, allocatable, save ::	cg2(:,:,:)

	lmax = ldata + lwin
	outcspectra = 0.0d0

	if (size(tapers(:,1)) < lwin+1 .or. size(tapers(1,:)) < numk) then
		print*, "Error --- SHBiasK"
		print*, "TAPERS must be dimensioned as (LWIN+1, NUMK) where LWIN and NUMK are ", LWIN, NUMK
		print*, "Input array is dimensioned ", size(tapers(:,1)), size(tapers(1,:))
		stop
	elseif (size(incspectra) < ldata +1) then
		print*, "Error --- SHBiasK"
		print*, "INCSPECTRA must be dimensioned as (LDATA+1) where LDATA is ", ldata
		print*, "Input array is dimensioned ", size(incspectra)
		stop
	endif

	if (present(taper_wt)) then
		if (size(taper_wt) < numk) then
			print*, "Error --- SHBiasK"
			print*, "TAPER_WT must be dimensioned as (NUMK) where NUMK is ", numk
			print*, "Input array is dimensioned as ", size(taper_wt)
			stop
		elseif (sum(taper_wt(1:numk)) /= 1.0d0) then
			print*, "Error --- SHBiasK"
			print*, "TAPER_WT must sum to unity."
			print*, "Input array sums to ", sum(taper_wt(1:numk))
			stop
		endif
	endif

	if (present(save_cg)) then
		if (save_cg /= 1 .and. save_cg /= -1 .and. save_cg /= 0) then
			print*, "Error --- SHBiasK"
			print*, "SAVE_CG must be 1 (to save the Clebsch-Gordon coefficients), -1 (to deallocate the memory)"
			print*, "or 0 (to do nothing)."
			print*, "Input value is ", save_cg
			stop
		endif
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate the biassed power spectrum
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(save_cg)) then

		if (save_cg == -1) then

			if (allocated(cg2)) deallocate(cg2)
			return

		elseif (save_cg == 0) then

			if (present(taper_wt)) then
				do l=0, min(lmax, size(outcspectra)-1)
					do j=0, lwin
						call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
						do i=imin, min(imax,ldata), 2
							do k=1, numk
								outcspectra(l+1) = outcspectra(l+1) + taper_wt(k) * tapers(j+1,k)**2 * &
									incspectra(i+1) * (2.0d0*l+1.0d0) * wig(i-imin+1)**2
							enddo
						enddo
					enddo
				enddo

			else

				do l=0, min(lmax, size(outcspectra)-1)
					do j=0, lwin
						call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
						do i=imin, min(imax,ldata), 2
							do k=1, numk
								outcspectra(l+1) = outcspectra(l+1) + tapers(j+1,k)**2 * &
									incspectra(i+1) * (2.0d0*l+1.0d0) * wig(i-imin+1)**2
							enddo
						enddo
					enddo
				enddo

				outcspectra = outcspectra / dble(numk)

			endif

			return

		endif

		if (allocated(cg2) .and. (size(cg2(:,1,1)) /= lmax+1 .or. size(cg2(1,:,1)) /= lwin+1 .or. &
			size(cg2(1,1,:)) /= lmax+lwin+1) ) deallocate(cg2)

		if (.not.allocated(cg2)) then
			allocate(cg2(lmax+1, lwin+1, lmax+lwin+1), stat = astat)
			if (astat /= 0) then
				print*, "Error --- SHBiasK"
				print*, "Problem allocating internal array CG2"
				stop
			endif

			cg2 = 0.0d0

			do l=0, lmax
				do j=0, lwin
					call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
					cg2(l+1,j+1,1:imax-imin+1) = (2.0d0*l+1.0d0) * wig(1:imax-imin+1)**2
				enddo
			enddo

		endif

		if (present(taper_wt)) then
			do l=0, min(lmax, size(outcspectra)-1)
				do j=0, lwin
					imin = abs(j-l)
					imax = j+l
					do i=imin, min(imax,ldata), 2
						do k=1, numk
							outcspectra(l+1) = outcspectra(l+1) + taper_wt(k) * tapers(j+1,k)**2 * &
								incspectra(i+1) * cg2(l+1,j+1,i-imin+1)
						enddo
					enddo
				enddo
			enddo

		else

			do l=0, min(lmax, size(outcspectra)-1)
				do j=0, lwin
					imin = abs(j-l)
					imax = j+l
					do i=imin, min(imax,ldata), 2
						do k=1, numk
							outcspectra(l+1) = outcspectra(l+1) + tapers(j+1,k)**2 * &
								incspectra(i+1) * cg2(l+1,j+1,i-imin+1)
						enddo
					enddo
				enddo
			enddo

			outcspectra = outcspectra / dble(numk)

		endif

	else

		if (present(taper_wt)) then
			do l=0, min(lmax, size(outcspectra)-1)
				do j=0, lwin
					call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
					do i=imin, min(imax,ldata), 2
						do k=1, numk
							outcspectra(l+1) = outcspectra(l+1) + taper_wt(k) * tapers(j+1,k)**2 * &
								incspectra(i+1) * (2.0d0*l+1.0d0) * wig(i-imin+1)**2
						enddo
					enddo
				enddo
			enddo

		else

			do l=0, min(lmax, size(outcspectra)-1)
				do j=0, lwin
					call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
					do i=imin, min(imax,ldata), 2
						do k=1, numk
							outcspectra(l+1) = outcspectra(l+1) + tapers(j+1,k)**2 * &
								incspectra(i+1) * (2.0d0*l+1.0d0) * wig(i-imin+1)**2
						enddo
					enddo
				enddo
			enddo

			outcspectra = outcspectra / dble(numk)

		endif

	endif

end subroutine SHBiasK