├── .github ├── ISSUE_TEMPLATE.md └── PULL_REQUEST_TEMPLATE.md ├── .travis.yml ├── .travis └── test-coverage.sh ├── README.md ├── airy.go ├── airy_test.go ├── beta.go ├── beta_test.go ├── betainc.go ├── betainc_test.go ├── digamma.go ├── digamma_test.go ├── doc.go ├── erf.go ├── erf_test.go ├── gamma_inc.go ├── gamma_inc_inv.go ├── gamma_inc_test.go ├── internal ├── amos │ ├── amos.go │ ├── amos_test.go │ ├── amoslib │ │ ├── Make.files │ │ ├── d1mach.f │ │ ├── dgamln.f │ │ ├── fortran.go │ │ ├── i1mach.f │ │ ├── myabs.f │ │ ├── myatan.f │ │ ├── mycos.f │ │ ├── myexp.f │ │ ├── mylog.f │ │ ├── mymax.f │ │ ├── mymin.f │ │ ├── mysin.f │ │ ├── mysqrt.f │ │ ├── mytan.f │ │ ├── xerror.f │ │ ├── zabs.f │ │ ├── zacai.f │ │ ├── zacon.f │ │ ├── zairy.f │ │ ├── zasyi.f │ │ ├── zbesh.f │ │ ├── zbesi.f │ │ ├── zbesj.f │ │ ├── zbesk.f │ │ ├── zbesy.f │ │ ├── zbinu.f │ │ ├── zbiry.f │ │ ├── zbknu.f │ │ ├── zbuni.f │ │ ├── zbunk.f │ │ ├── zdiv.f │ │ ├── zexp.f │ │ ├── zkscl.f │ │ ├── zlog.f │ │ ├── zmlri.f │ │ ├── zmlt.f │ │ ├── zrati.f │ │ ├── zs1s2.f │ │ ├── zseri.f │ │ ├── zshch.f │ │ ├── zsqrt.f │ │ ├── zuchk.f │ │ ├── zunhj.f │ │ ├── zuni1.f │ │ ├── zuni2.f │ │ ├── zunik.f │ │ ├── zunk1.f │ │ ├── zunk2.f │ │ ├── zuoik.f │ │ └── zwrsk.f │ ├── doc.go │ └── origcode_test.go ├── cephes │ ├── cephes.go │ ├── doc.go │ ├── igam.go │ ├── igami.go │ ├── incbeta.go │ ├── incbi.go │ ├── lanczos.go │ ├── ndtri.go │ ├── polevl.go │ ├── unity.go │ └── zeta.go └── gonum │ ├── beta.go │ ├── doc.go │ └── gonum.go ├── mvgamma.go ├── mvgamma_test.go ├── roots.go ├── zeta.go └── zeta_test.go /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | ### This repository is no longer actively maintained. 2 | 3 | Development of the packages in this repository has moved to https://github.com/gonum/gonum. 4 | Please file issues [there](https://github.com/gonum/gonum/issues) after having checked that your issue has not been fixed. 5 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | ### This repository is no longer actively maintained. 2 | 3 | Development of the packages in this repository has moved to https://github.com/gonum/gonum. 4 | Please send pull requests [there](https://github.com/gonum/gonum/pulls) after having checked that your addition has not already been made. 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | language: go 4 | 5 | # Versions of go that are explicitly supported by gonum. 6 | go: 7 | - 1.5.4 8 | - 1.6.3 9 | - 1.7.3 10 | 11 | # Required for coverage. 12 | before_install: 13 | - go get golang.org/x/tools/cmd/cover 14 | - go get github.com/mattn/goveralls 15 | 16 | # Get deps, build, test, and ensure the code is gofmt'ed. 17 | # If we are building as gonum, then we have access to the coveralls api key, so we can run coverage as well. 18 | script: 19 | - go get -d -t -v ./... 20 | - go build -v ./... 21 | - go test -v ./... 22 | - test -z "$(gofmt -d .)" 23 | - if [[ $TRAVIS_SECURE_ENV_VARS = "true" ]]; then bash ./.travis/test-coverage.sh; fi 24 | -------------------------------------------------------------------------------- /.travis/test-coverage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | PROFILE_OUT=$PWD/profile.out 4 | ACC_OUT=$PWD/acc.out 5 | 6 | testCover() { 7 | # set the return value to 0 (succesful) 8 | retval=0 9 | # get the directory to check from the parameter. Default to '.' 10 | d=${1:-.} 11 | # skip if there are no Go files here 12 | ls $d/*.go &> /dev/null || return $retval 13 | # switch to the directory to check 14 | pushd $d > /dev/null 15 | # create the coverage profile 16 | coverageresult=`go test -v -coverprofile=$PROFILE_OUT` 17 | # output the result so we can check the shell output 18 | echo ${coverageresult} 19 | # append the results to acc.out if coverage didn't fail, else set the retval to 1 (failed) 20 | ( [[ ${coverageresult} == *FAIL* ]] && retval=1 ) || ( [ -f $PROFILE_OUT ] && grep -v "mode: set" $PROFILE_OUT >> $ACC_OUT ) 21 | # return to our working dir 22 | popd > /dev/null 23 | # return our return value 24 | return $retval 25 | } 26 | 27 | # Init acc.out 28 | echo "mode: set" > $ACC_OUT 29 | 30 | # Run test coverage on all directories containing go files 31 | find . -maxdepth 10 -type d | while read d; do testCover $d || exit; done 32 | 33 | # Upload the coverage profile to coveralls.io 34 | [ -n "$COVERALLS_TOKEN" ] && goveralls -coverprofile=$ACC_OUT -service=travis-ci -repotoken $COVERALLS_TOKEN 35 | 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mathext [![Build Status](https://travis-ci.org/gonum/mathext.svg?branch=master)](https://travis-ci.org/gonum/mathext) [![Coverage Status](https://coveralls.io/repos/github/gonum/mathext/badge.svg?branch=master)](https://coveralls.io/github/gonum/mathext?branch=master) [![GoDoc](https://godoc.org/github.com/gonum/mathext?status.svg)](https://godoc.org/github.com/gonum/mathext) 2 | 3 | # This repository is no longer maintained. Development has moved to https://github.com/gonum/gonum. 4 | 5 | mathext implements basic elementary functions not included in the Go standard library 6 | 7 | ## Issues 8 | 9 | If you find any bugs, feel free to file an issue on the github [issue tracker for gonum/gonum](https://github.com/gonum/gonum/issues) if the bug exists in that reposity; no code changes will be made to this repository. Other dicussions should be taken to the gonum-dev Google Group. 10 | 11 | https://groups.google.com/forum/#!forum/gonum-dev 12 | -------------------------------------------------------------------------------- /airy.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import "github.com/gonum/mathext/internal/amos" 8 | 9 | // AiryAi returns the value of the Airy function at z. The Airy function here, 10 | // Ai(z), is one of the two linearly independent solutions to 11 | // y'' - y*z = 0. 12 | // See http://mathworld.wolfram.com/AiryFunctions.html for more detailed information. 13 | func AiryAi(z complex128) complex128 { 14 | // id specifies the order of the derivative to compute, 15 | // 0 for the function itself and 1 for the derivative. 16 | // kode specifies the scaling option. See the function 17 | // documentation for the exact behavior. 18 | id := 0 19 | kode := 1 20 | air, aii, _ := amos.Zairy(real(z), imag(z), id, kode) 21 | return complex(air, aii) 22 | } 23 | 24 | // AiryAiDeriv returns the value of the derivative of the Airy function at z. The 25 | // Airy function here, Ai(z), is one of the two linearly independent solutions to 26 | // y'' - y*z = 0. 27 | // See http://mathworld.wolfram.com/AiryFunctions.html for more detailed information. 28 | func AiryAiDeriv(z complex128) complex128 { 29 | // id specifies the order of the derivative to compute, 30 | // 0 for the function itself and 1 for the derivative. 31 | // kode specifies the scaling option. See the function 32 | // documentation for the exact behavior. 33 | id := 1 34 | kode := 1 35 | air, aii, _ := amos.Zairy(real(z), imag(z), id, kode) 36 | return complex(air, aii) 37 | } 38 | -------------------------------------------------------------------------------- /airy_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "math" 9 | "testing" 10 | ) 11 | 12 | func TestAiry(t *testing.T) { 13 | for _, test := range []struct { 14 | z, ans complex128 15 | }{ 16 | // Results computed using Octave. 17 | {5, 1.08344428136074e-04}, 18 | {5i, 29.9014823980070 + 21.6778315987835i}, 19 | } { 20 | ans := AiryAi(test.z) 21 | if math.Abs(real(ans)-real(test.ans)) > 1e-10 { 22 | t.Errorf("Real part mismatch. Got %v, want %v", real(ans), real(test.ans)) 23 | } 24 | if math.Abs(imag(ans)-imag(test.ans)) > 1e-10 { 25 | t.Errorf("Imaginary part mismatch. Got %v, want %v", imag(ans), imag(test.ans)) 26 | } 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /beta.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import "github.com/gonum/mathext/internal/gonum" 8 | 9 | // Beta returns the value of the complete beta function B(a, b). It is defined as 10 | // Γ(a)Γ(b) / Γ(a+b) 11 | // Special cases are: 12 | // B(a,b) returns NaN if a or b is Inf 13 | // B(a,b) returns NaN if a and b are 0 14 | // B(a,b) returns NaN if a or b is NaN 15 | // B(a,b) returns NaN if a or b is < 0 16 | // B(a,b) returns +Inf if a xor b is 0. 17 | // 18 | // See http://mathworld.wolfram.com/BetaFunction.html for more detailed informations. 19 | func Beta(a, b float64) float64 { 20 | return gonum.Beta(a, b) 21 | } 22 | 23 | // Lbeta returns the natural logarithm of the complete beta function B(a,b). 24 | // Lbeta is defined as: 25 | // Ln(Γ(a)Γ(b)/Γ(a+b)) 26 | // Special cases are: 27 | // Lbeta(a,b) returns NaN if a or b is Inf 28 | // Lbeta(a,b) returns NaN if a and b are 0 29 | // Lbeta(a,b) returns NaN if a or b is NaN 30 | // Lbeta(a,b) returns NaN if a or b is < 0 31 | // Lbeta(a,b) returns +Inf if a xor b is 0. 32 | func Lbeta(a, b float64) float64 { 33 | return gonum.Lbeta(a, b) 34 | } 35 | -------------------------------------------------------------------------------- /beta_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext_test 6 | 7 | import ( 8 | "math" 9 | "testing" 10 | 11 | "github.com/gonum/floats" 12 | "github.com/gonum/mathext" 13 | ) 14 | 15 | var betaTests = []struct { 16 | p, q float64 17 | want float64 18 | }{ 19 | { 20 | p: 1, 21 | q: 2, 22 | want: 0.5, // obtained from scipy.special.beta(1,2) (version=0.18.0) 23 | }, 24 | { 25 | p: 10, 26 | q: 20, 27 | want: 4.9925087406346778e-09, // obtained from scipy.special.beta(10,20) (version=0.18.0) 28 | }, 29 | { 30 | p: +0, 31 | q: 10, 32 | want: math.Inf(+1), 33 | }, 34 | { 35 | p: -0, 36 | q: 10, 37 | want: math.Inf(+1), 38 | }, 39 | { 40 | p: 0, 41 | q: 0, 42 | want: math.NaN(), 43 | }, 44 | { 45 | p: 0, 46 | q: math.Inf(-1), 47 | want: math.NaN(), 48 | }, 49 | { 50 | p: 10, 51 | q: math.Inf(-1), 52 | want: math.NaN(), 53 | }, 54 | { 55 | p: 0, 56 | q: math.Inf(+1), 57 | want: math.NaN(), 58 | }, 59 | { 60 | p: 10, 61 | q: math.Inf(+1), 62 | want: math.NaN(), 63 | }, 64 | { 65 | p: math.NaN(), 66 | q: 10, 67 | want: math.NaN(), 68 | }, 69 | { 70 | p: math.NaN(), 71 | q: 0, 72 | want: math.NaN(), 73 | }, 74 | { 75 | p: -1, 76 | q: 0, 77 | want: math.NaN(), 78 | }, 79 | { 80 | p: -1, 81 | q: +1, 82 | want: math.NaN(), 83 | }, 84 | } 85 | 86 | func TestBeta(t *testing.T) { 87 | for i, test := range betaTests { 88 | v := mathext.Beta(test.p, test.q) 89 | testOK := func(x float64) bool { 90 | return floats.EqualWithinAbsOrRel(x, test.want, 1e-15, 1e-15) || (math.IsNaN(test.want) && math.IsNaN(x)) 91 | } 92 | if !testOK(v) { 93 | t.Errorf("test #%d: Beta(%v, %v)=%v. want=%v\n", 94 | i, test.p, test.q, v, test.want, 95 | ) 96 | } 97 | 98 | u := mathext.Beta(test.q, test.p) 99 | if !testOK(u) { 100 | t.Errorf("test #%[1]d: Beta(%[2]v, %[3]v)=%[4]v != Beta(%[3]v, %[2]v)=%[5]v)\n", 101 | i, test.p, test.q, v, u, 102 | ) 103 | } 104 | 105 | if math.IsInf(v, +1) || math.IsNaN(v) { 106 | continue 107 | } 108 | 109 | vv := mathext.Beta(test.p, test.q+1) 110 | uu := mathext.Beta(test.p+1, test.q) 111 | if !floats.EqualWithinAbsOrRel(v, vv+uu, 1e-15, 1e-15) { 112 | t.Errorf( 113 | "test #%[1]d: Beta(%[2]v, %[3]v)=%[4]v != Beta(%[2]v+1, %[3]v) + Beta(%[2]v, %[3]v+1) (=%[5]v + %[6]v = %[7]v)\n", 114 | i, test.p, test.q, v, uu, vv, uu+vv, 115 | ) 116 | } 117 | 118 | vbeta2 := beta2(test.p, test.q) 119 | if !floats.EqualWithinAbsOrRel(v, vbeta2, 1e-15, 1e-15) { 120 | t.Errorf( 121 | "test #%[1]d: Beta(%[2]v, %[3]v) != Γ(p)Γ(q) / Γ(p+q) (v=%[4]v u=%[5]v)\n", 122 | i, test.p, test.q, v, vbeta2, 123 | ) 124 | } 125 | } 126 | } 127 | 128 | func beta2(x, y float64) float64 { 129 | return math.Gamma(x) * math.Gamma(y) / math.Gamma(x+y) 130 | } 131 | 132 | func BenchmarkBeta(b *testing.B) { 133 | for i := 0; i < b.N; i++ { 134 | _ = mathext.Beta(10, 20) 135 | } 136 | } 137 | 138 | func BenchmarkBeta2(b *testing.B) { 139 | for i := 0; i < b.N; i++ { 140 | _ = math.Gamma(10) * math.Gamma(20) / math.Gamma(10+20) 141 | } 142 | } 143 | 144 | func TestLbeta(t *testing.T) { 145 | for i, test := range betaTests { 146 | want := math.Log(test.want) 147 | v := mathext.Lbeta(test.p, test.q) 148 | 149 | testOK := func(x float64) bool { 150 | return floats.EqualWithinAbsOrRel(x, want, 1e-15, 1e-15) || (math.IsNaN(want) && math.IsNaN(x)) 151 | } 152 | if !testOK(v) { 153 | t.Errorf("test #%d: Lbeta(%v, %v)=%v. want=%v\n", 154 | i, test.p, test.q, v, want, 155 | ) 156 | } 157 | 158 | u := mathext.Lbeta(test.q, test.p) 159 | if !testOK(u) { 160 | t.Errorf("test #%[1]d: Lbeta(%[2]v, %[3]v)=%[4]v != Lbeta(%[3]v, %[2]v)=%[5]v)\n", 161 | i, test.p, test.q, v, u, 162 | ) 163 | } 164 | 165 | if math.IsInf(v, +1) || math.IsNaN(v) { 166 | continue 167 | } 168 | 169 | vbeta2 := math.Log(beta2(test.p, test.q)) 170 | if !floats.EqualWithinAbsOrRel(v, vbeta2, 1e-15, 1e-15) { 171 | t.Errorf( 172 | "test #%[1]d: Lbeta(%[2]v, %[3]v) != Log(Γ(p)Γ(q) / Γ(p+q)) (v=%[4]v u=%[5]v)\n", 173 | i, test.p, test.q, v, vbeta2, 174 | ) 175 | } 176 | } 177 | } 178 | -------------------------------------------------------------------------------- /betainc.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import "github.com/gonum/mathext/internal/cephes" 8 | 9 | // RegIncBeta returns the value of the regularized incomplete beta function 10 | // I(x;a,b). It is defined as 11 | // I(x;a,b) = B(x;a,b) / B(a,b) 12 | // = Γ(a+b) / (Γ(a)*Γ(b)) * int_0^x u^(a-1) * (1-u)^(b-1) du. 13 | // The domain of definition is 0 <= x <= 1, and the parameters a and b must be positive. 14 | // For other values of x, a, and b RegIncBeta will panic. 15 | func RegIncBeta(a, b float64, x float64) float64 { 16 | return cephes.Incbet(a, b, x) 17 | } 18 | 19 | // InvRegIncBeta computes the inverse of the regularized incomplete beta function. 20 | // It returns the x for which 21 | // y = I(x;a,b) 22 | // The domain of definition is 0 <= y <= 1, and the parameters a and b must be 23 | // positive. For other values of x, a, and b InvRegIncBeta will panic. 24 | func InvRegIncBeta(a, b float64, y float64) float64 { 25 | if y < 0 || y > 1 { 26 | panic("mathext: parameter out of range") 27 | } 28 | return cephes.Incbi(a, b, y) 29 | } 30 | -------------------------------------------------------------------------------- /betainc_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "testing" 9 | 10 | "github.com/gonum/floats" 11 | ) 12 | 13 | func TestIncBeta(t *testing.T) { 14 | tol := 1e-14 15 | tol2 := 1e-10 16 | // Test against values from scipy 17 | for i, test := range []struct { 18 | a, b, x, ans float64 19 | }{ 20 | {1, 1, 0.8, 0.8}, 21 | {1, 5, 0.8, 0.99968000000000001}, 22 | {10, 10, 0.8, 0.99842087945083291}, 23 | {10, 10, 0.1, 3.929882327128003e-06}, 24 | {10, 2, 0.4, 0.00073400320000000028}, 25 | {0.1, 0.2, 0.6, 0.69285678232066683}, 26 | {1, 10, 0.7489, 0.99999900352334858}, 27 | } { 28 | y := RegIncBeta(test.a, test.b, test.x) 29 | if !floats.EqualWithinAbsOrRel(y, test.ans, tol, tol) { 30 | t.Errorf("Incomplete beta mismatch. Case %v: Got %v, want %v", i, y, test.ans) 31 | } 32 | 33 | yc := 1 - RegIncBeta(test.b, test.a, 1-test.x) 34 | if !floats.EqualWithinAbsOrRel(y, yc, tol, tol) { 35 | t.Errorf("Incomplete beta complementary mismatch. Case %v: Got %v, want %v", i, y, yc) 36 | } 37 | 38 | x := InvRegIncBeta(test.a, test.b, y) 39 | if !floats.EqualWithinAbsOrRel(x, test.x, tol2, tol2) { 40 | t.Errorf("Inverse incomplete beta mismatch. Case %v: Got %v, want %v", i, x, test.x) 41 | } 42 | } 43 | 44 | // Confirm that Invincbeta and Incbeta agree. Sweep over a variety of 45 | // a, b, and y values. 46 | tol = 1e-6 47 | steps := 201 48 | ints := make([]float64, steps) 49 | floats.Span(ints, 0, 1) 50 | 51 | sz := 51 52 | min := 1e-2 53 | max := 1e2 54 | as := make([]float64, sz) 55 | floats.LogSpan(as, min, max) 56 | bs := make([]float64, sz) 57 | floats.LogSpan(bs, min, max) 58 | 59 | for _, a := range as { 60 | for _, b := range bs { 61 | for _, yr := range ints { 62 | x := InvRegIncBeta(a, b, yr) 63 | if x > 1-1e-6 { 64 | // Numerical error too large 65 | continue 66 | } 67 | y := RegIncBeta(a, b, x) 68 | if !floats.EqualWithinAbsOrRel(yr, y, tol, tol) { 69 | t.Errorf("Mismatch between inv inc beta and inc beta. a = %v, b = %v, x = %v, got %v, want %v.", a, b, x, y, yr) 70 | break 71 | } 72 | } 73 | } 74 | } 75 | } 76 | -------------------------------------------------------------------------------- /digamma.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "math" 9 | ) 10 | 11 | // Digamma returns the logorithmic derivative of the gamma function at x. 12 | // ψ(x) = d/dx (Ln (Γ(x)). 13 | // Note that if x is a negative integer in [-7, 0] this function will return 14 | // negative Inf. 15 | func Digamma(x float64) float64 { 16 | // This is adapted from 17 | // http://web.science.mq.edu.au/~mjohnson/code/digamma.c 18 | var result float64 19 | for ; x < 7.0; x++ { 20 | result -= 1 / x 21 | } 22 | x -= 1.0 / 2.0 23 | xx := 1.0 / x 24 | xx2 := xx * xx 25 | xx4 := xx2 * xx2 26 | result += math.Log(x) + (1./24.)*xx2 - (7.0/960.0)*xx4 + (31.0/8064.0)*xx4*xx2 - (127.0/30720.0)*xx4*xx4 27 | return result 28 | } 29 | -------------------------------------------------------------------------------- /digamma_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "math" 9 | "testing" 10 | ) 11 | 12 | func TestDigamma(t *testing.T) { 13 | for i, test := range []struct { 14 | x, want float64 15 | }{ 16 | // Results computed using WolframAlpha. 17 | {-100.5, 4.615124601338064117341315601525112558522917517910505881343}, 18 | {.5, -1.96351002602142347944097633299875556719315960466043}, 19 | {10, 2.251752589066721107647456163885851537211808918028330369448}, 20 | {math.Pow10(20), 46.05170185988091368035482909368728415202202143924212618733}, 21 | } { 22 | 23 | if got := Digamma(test.x); math.Abs(got-test.want) > 1e-10 { 24 | t.Errorf("test %d Digamma(%g) failed: got %g want %g", i, test.x, got, test.want) 25 | } 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /doc.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2018 The Gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | // This repository is no longer maintained. 6 | // Development has moved to https://github.com/gonum/gonum. 7 | package mathext 8 | -------------------------------------------------------------------------------- /erf.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2017 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import "math" 8 | 9 | /* 10 | Copyright (c) 2012 The Probab Authors. All rights reserved. 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions are 13 | met: 14 | * Redistributions of source code must retain the above copyright 15 | notice, this list of conditions and the following disclaimer. 16 | * Redistributions in binary form must reproduce the above 17 | copyright notice, this list of conditions and the following disclaimer 18 | in the documentation and/or other materials provided with the 19 | distribution. 20 | * Neither the name of Google Inc. nor the names of its 21 | contributors may be used to endorse or promote products derived from 22 | this software without specific prior written permission. 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 26 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 27 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 28 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 29 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 30 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 31 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 32 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 33 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 34 | */ 35 | 36 | // NormalQuantile computes the quantile function (inverse CDF) of the standard 37 | // normal. NormalQuantile panics if the input p is less than 0 or greater than 1. 38 | func NormalQuantile(p float64) float64 { 39 | switch { 40 | case p < 0 || 1 < p: 41 | panic("mathext: quantile out of bounds") 42 | case p == 1: 43 | return math.Inf(1) 44 | case p == 0: 45 | return math.Inf(-1) 46 | } 47 | // Compute rational approximation based on the value of p. 48 | 49 | dp := p - 0.5 50 | if math.Abs(dp) <= 0.425 { 51 | z := 0.180625 - dp*dp 52 | z1 := ((((((zQSA[0]*z+zQSA[1])*z+zQSA[2])*z+zQSA[3])*z+zQSA[4])*z+zQSA[5])*z+zQSA[6])*z + zQSA[7] 53 | z2 := ((((((zQSB[0]*z+zQSB[1])*z+zQSB[2])*z+zQSB[3])*z+zQSB[4])*z+zQSB[5])*z+zQSB[6])*z + zQSB[7] 54 | return dp * z1 / z2 55 | } 56 | 57 | if p < 0.5 { 58 | r := math.Sqrt(-math.Log(p)) 59 | if r <= 5.0 { 60 | z := r - 1.6 61 | z1 := ((((((zQIA[0]*z+zQIA[1])*z+zQIA[2])*z+zQIA[3])*z+zQIA[4])*z+zQIA[5])*z+zQIA[6])*z + zQIA[7] 62 | z2 := ((((((zQIB[0]*z+zQIB[1])*z+zQIB[2])*z+zQIB[3])*z+zQIB[4])*z+zQIB[5])*z+zQIB[6])*z + zQIB[7] 63 | return -z1 / z2 64 | } 65 | z := r - 5 66 | z1 := ((((((zQTA[0]*z+zQTA[1])*z+zQTA[2])*z+zQTA[3])*z+zQTA[4])*z+zQTA[5])*z+zQTA[6])*z + zQTA[7] 67 | z2 := ((((((zQTB[0]*z+zQTB[1])*z+zQTB[2])*z+zQTB[3])*z+zQTB[4])*z+zQTB[5])*z+zQTB[6])*z + zQTB[7] 68 | return -z1 / z2 69 | } 70 | r := math.Sqrt(-math.Log(1 - p)) 71 | if r <= 5.0 { 72 | z := r - 1.6 73 | z1 := ((((((zQIA[0]*z+zQIA[1])*z+zQIA[2])*z+zQIA[3])*z+zQIA[4])*z+zQIA[5])*z+zQIA[6])*z + zQIA[7] 74 | z2 := ((((((zQIB[0]*z+zQIB[1])*z+zQIB[2])*z+zQIB[3])*z+zQIB[4])*z+zQIB[5])*z+zQIB[6])*z + zQIB[7] 75 | return z1 / z2 76 | } 77 | 78 | z := r - 5 79 | z1 := ((((((zQTA[0]*z+zQTA[1])*z+zQTA[2])*z+zQTA[3])*z+zQTA[4])*z+zQTA[5])*z+zQTA[6])*z + zQTA[7] 80 | z2 := ((((((zQTB[0]*z+zQTB[1])*z+zQTB[2])*z+zQTB[3])*z+zQTB[4])*z+zQTB[5])*z+zQTB[6])*z + zQTB[7] 81 | return z1 / z2 82 | } 83 | 84 | var ( 85 | zQSA = [...]float64{2509.0809287301226727, 33430.575583588128105, 67265.770927008700853, 45921.953931549871457, 13731.693765509461125, 1971.5909503065514427, 133.14166789178437745, 3.387132872796366608} 86 | zQSB = [...]float64{5226.495278852854561, 28729.085735721942674, 39307.89580009271061, 21213.794301586595867, 5394.1960214247511077, 687.1870074920579083, 42.313330701600911252, 1.0} 87 | zQIA = [...]float64{7.7454501427834140764e-4, 0.0227238449892691845833, 0.24178072517745061177, 1.27045825245236838258, 3.64784832476320460504, 5.7694972214606914055, 4.6303378461565452959, 1.42343711074968357734} 88 | zQIB = [...]float64{1.05075007164441684324e-9, 5.475938084995344946e-4, 0.0151986665636164571966, 0.14810397642748007459, 0.68976733498510000455, 1.6763848301838038494, 2.05319162663775882187, 1.0} 89 | zQTA = [...]float64{2.01033439929228813265e-7, 2.71155556874348757815e-5, 0.0012426609473880784386, 0.026532189526576123093, 0.29656057182850489123, 1.7848265399172913358, 5.4637849111641143699, 6.6579046435011037772} 90 | zQTB = [...]float64{2.04426310338993978564e-15, 1.4215117583164458887e-7, 1.8463183175100546818e-5, 7.868691311456132591e-4, 0.0148753612908506148525, 0.13692988092273580531, 0.59983220655588793769, 1.0} 91 | ) 92 | -------------------------------------------------------------------------------- /erf_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2017 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "testing" 9 | 10 | "github.com/gonum/floats" 11 | ) 12 | 13 | func TestNormalQuantile(t *testing.T) { 14 | // Values from https://www.johndcook.com/blog/normal_cdf_inverse/ 15 | p := []float64{ 16 | 0.0000001, 17 | 0.00001, 18 | 0.001, 19 | 0.05, 20 | 0.15, 21 | 0.25, 22 | 0.35, 23 | 0.45, 24 | 0.55, 25 | 0.65, 26 | 0.75, 27 | 0.85, 28 | 0.95, 29 | 0.999, 30 | 0.99999, 31 | 0.9999999, 32 | } 33 | ans := []float64{ 34 | -5.199337582187471, 35 | -4.264890793922602, 36 | -3.090232306167813, 37 | -1.6448536269514729, 38 | -1.0364333894937896, 39 | -0.6744897501960817, 40 | -0.38532046640756773, 41 | -0.12566134685507402, 42 | 0.12566134685507402, 43 | 0.38532046640756773, 44 | 0.6744897501960817, 45 | 1.0364333894937896, 46 | 1.6448536269514729, 47 | 3.090232306167813, 48 | 4.264890793922602, 49 | 5.199337582187471, 50 | } 51 | for i, v := range p { 52 | got := NormalQuantile(v) 53 | if !floats.EqualWithinAbsOrRel(got, ans[i], 1e-10, 1e-10) { 54 | t.Errorf("Quantile mismatch. Case %d, want: %v, got: %v", i, ans[i], got) 55 | } 56 | } 57 | } 58 | 59 | var nqtmp float64 60 | 61 | func BenchmarkNormalQuantile(b *testing.B) { 62 | ps := make([]float64, 1000) // ensure there are small values 63 | floats.Span(ps, 0, 1) 64 | for i := 0; i < b.N; i++ { 65 | for _, v := range ps { 66 | nqtmp = NormalQuantile(v) 67 | } 68 | } 69 | } 70 | -------------------------------------------------------------------------------- /gamma_inc.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "github.com/gonum/mathext/internal/cephes" 9 | ) 10 | 11 | // GammaInc computes the incomplete Gamma integral. 12 | // GammaInc(a,x) = (1/ Γ(a)) \int_0^x e^{-t} t^{a-1} dt 13 | // The input argument a must be positive and x must be non-negative or GammaInc 14 | // will panic. 15 | // 16 | // See http://mathworld.wolfram.com/IncompleteGammaFunction.html 17 | // or https://en.wikipedia.org/wiki/Incomplete_gamma_function for more detailed 18 | // information. 19 | func GammaInc(a, x float64) float64 { 20 | return cephes.Igam(a, x) 21 | } 22 | 23 | // GammaIncComp computes the complemented incomplete Gamma integral. 24 | // GammaIncComp(a,x) = 1 - GammaInc(a,x) 25 | // = (1/ Γ(a)) \int_0^\infty e^{-t} t^{a-1} dt 26 | // The input argument a must be positive and x must be non-negative or 27 | // GammaIncComp will panic. 28 | func GammaIncComp(a, x float64) float64 { 29 | return cephes.IgamC(a, x) 30 | } 31 | 32 | // GammaIncInv computes the inverse of the incomplete Gamma integral. That is, 33 | // it returns the x such that: 34 | // GammaInc(a, x) = y 35 | // The input argument a must be positive and y must be between 0 and 1 36 | // inclusive or GammaIncInv will panic. GammaIncInv should return a positive 37 | // number, but can return NaN if there is a failure to converge. 38 | func GammaIncInv(a, y float64) float64 { 39 | return gammaIncInv(a, y) 40 | } 41 | 42 | // GammaIncCompInv computes the inverse of the complemented incomplete Gamma 43 | // integral. That is, it returns the x such that: 44 | // GammaIncComp(a, x) = y 45 | // The input argument a must be positive and y must be between 0 and 1 46 | // inclusive or GammaIncCompInv will panic. GammaIncCompInv should return a 47 | // positive number, but can return 0 even with non-zero y due to underflow. 48 | func GammaIncCompInv(a, y float64) float64 { 49 | return cephes.IgamI(a, y) 50 | } 51 | -------------------------------------------------------------------------------- /gamma_inc_inv.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/c_misc/gammaincinv.c 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/c_misc/gammaincinv.c 3 | 4 | // Copyright ©2017 The gonum Authors. All rights reserved. 5 | // Use of this source code is governed by a BSD-style 6 | // license that can be found in the LICENSE file. 7 | 8 | package mathext 9 | 10 | import ( 11 | "math" 12 | 13 | "github.com/gonum/mathext/internal/cephes" 14 | ) 15 | 16 | const ( 17 | allowedATol = 1e-306 18 | allowedRTol = 1e-6 19 | ) 20 | 21 | func gammaInc(x float64, params []float64) float64 { 22 | return cephes.Igam(params[0], x) - params[1] 23 | } 24 | 25 | // gammaIncInv is the inverse of the incomplete Gamma integral. That is, it 26 | // returns x such that: 27 | // Igam(a, x) = y 28 | // The input argument a must be positive and y must be between 0 and 1 29 | // inclusive or gammaIncInv will panic. gammaIncInv should return a 30 | // positive number, but can return NaN if there is a failure to converge. 31 | func gammaIncInv(a, y float64) float64 { 32 | // For y not small, we just use 33 | // IgamI(a, 1-y) 34 | // (inverse of the complemented incomplete Gamma integral). For y small, 35 | // however, 1-y is about 1, and we lose digits. 36 | if a <= 0 || y <= 0 || y >= 0.25 { 37 | return cephes.IgamI(a, 1-y) 38 | } 39 | 40 | lo := 0.0 41 | flo := -y 42 | hi := cephes.IgamI(a, 0.75) 43 | fhi := 0.25 - y 44 | 45 | params := []float64{a, y} 46 | 47 | // Also, after we generate a small interval by bisection above, false 48 | // position will do a large step from an interval of width ~1e-4 to ~1e-14 49 | // in one step (a=10, x=0.05, but similiar for other values). 50 | result, bestX, _, errEst := falsePosition(lo, hi, flo, fhi, 2*machEp, 2*machEp, 1e-2*a, gammaInc, params) 51 | if result == fSolveMaxIterations && errEst > allowedATol+allowedRTol*math.Abs(bestX) { 52 | bestX = math.NaN() 53 | } 54 | 55 | return bestX 56 | } 57 | -------------------------------------------------------------------------------- /gamma_inc_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "math" 9 | "testing" 10 | ) 11 | 12 | func TestGammaInc(t *testing.T) { 13 | for i, test := range []struct { 14 | a, x, want float64 15 | }{ 16 | // Results computed using scipy.special.gamminc 17 | {0, 0, 0}, 18 | {0.0001, 1, 0.99997805936186279}, 19 | {0.001, 0.005, 0.99528424172333985}, 20 | {0.01, 10, 0.99999995718295021}, 21 | {0.1, 10, 0.99999944520142825}, 22 | {0.25, 0.75, 0.89993651328449831}, 23 | {0.5, 0.5, 0.68268949213708596}, 24 | {0.5, 2, 0.95449973610364147}, 25 | {0.75, 2.5, 0.95053039734695643}, 26 | {1, 0.5, 0.39346934028736652}, 27 | {1, 1, 0.63212055882855778}, 28 | {1.5, 0.75, 0.31772966966378746}, 29 | {2.5, 1, 0.15085496391539038}, 30 | {3, 0.05, 2.0067493624397931e-05}, 31 | {3, 20, 0.99999954448504946}, 32 | {5, 50, 1}, 33 | {7, 10, 0.86985857911751696}, 34 | {10, 0.9, 4.2519575433351128e-08}, 35 | {10, 5, 0.031828057306204811}, 36 | {25, 10, 4.6949381426799868e-05}, 37 | } { 38 | if got := GammaInc(test.a, test.x); math.Abs(got-test.want) > 1e-10 { 39 | t.Errorf("test %d GammaInc(%g, %g) failed: got %g want %g", i, test.a, test.x, got, test.want) 40 | } 41 | } 42 | } 43 | 44 | func TestGammaIncComp(t *testing.T) { 45 | for i, test := range []struct { 46 | a, x, want float64 47 | }{ 48 | // Results computed using scipy.special.gammincc 49 | {0.00001, 0.075, 2.0866541002417804e-05}, 50 | {0.0001, 1, 2.1940638138146658e-05}, 51 | {0.001, 0.005, 0.0047157582766601536}, 52 | {0.01, 0.9, 0.0026263432520514662}, 53 | {0.25, 0.75, 0.10006348671550169}, 54 | {0.5, 0.5, 0.31731050786291404}, 55 | {0.75, 0.25, 0.65343980284081038}, 56 | {0.9, 0.01, 0.98359881081593148}, 57 | {1, 0, 1}, 58 | {1, 0.075, 0.92774348632855297}, 59 | {1, 1, 0.36787944117144233}, 60 | {1, 10, 4.5399929762484861e-05}, 61 | {1, math.Inf(1), 0}, 62 | {3, 20, 4.5551495055892125e-07}, 63 | {5, 10, 0.029252688076961127}, 64 | {10, 3, 0.99889751186988451}, 65 | {50, 25, 0.99999304669475242}, 66 | {100, 10, 1}, 67 | {500, 500, 0.49405285382921321}, 68 | {500, 550, 0.014614408126291296}, 69 | } { 70 | if got := GammaIncComp(test.a, test.x); math.Abs(got-test.want) > 1e-10 { 71 | t.Errorf("test %d GammaIncComp(%g, %g) failed: got %g want %g", i, test.a, test.x, got, test.want) 72 | } 73 | } 74 | } 75 | 76 | func TestGammaIncInv(t *testing.T) { 77 | for i, test := range []struct { 78 | a, x, want float64 79 | }{ 80 | // Results computed using scipy.special.gammincinv 81 | {0.001, 0.99, 2.4259428385570885e-05}, 82 | {0.01, 0.99, 0.26505255025157959}, 83 | {0.1, 0.5, 0.00059339110446022798}, 84 | {0.2, 0.8, 0.26354363204872067}, 85 | {0.25, 0.5, 0.043673802352873381}, 86 | {0.5, 0.25, 0.050765522133810789}, 87 | {0.5, 0.5, 0.22746821155978625}, 88 | {0.75, 0.25, 0.15340752707472377}, 89 | {1, 0, 0}, 90 | {1, 0.075, 0.077961541469711862}, 91 | {1, 1, math.Inf(1)}, 92 | {2.5, 0.99, 7.5431362346944937}, 93 | {10, 0.5, 9.6687146147141299}, 94 | {25, 0.01, 14.853341349420646}, 95 | {25, 0.99, 38.076945624506337}, 96 | {50, 0.75, 54.570620535040511}, 97 | {100, 0.25, 93.08583383712174}, 98 | {1000, 0.01, 927.90815979664251}, 99 | {1000, 0.99, 1075.0328320864389}, 100 | {10000, 0.5, 9999.6666686420485}, 101 | } { 102 | if got := GammaIncInv(test.a, test.x); math.Abs(got-test.want) > 1e-10 { 103 | t.Errorf("test %d GammaIncInv(%g, %g) failed: got %g want %g", i, test.a, test.x, got, test.want) 104 | } 105 | } 106 | } 107 | 108 | func TestGammaIncCompInv(t *testing.T) { 109 | for i, test := range []struct { 110 | a, x, want float64 111 | }{ 112 | // Results computed using scipy.special.gamminccinv 113 | {0.001, 0.01, 2.4259428385570885e-05}, 114 | {0.01, 0.01, 0.26505255025158292}, 115 | {0.03, 0.4, 2.316980536227699e-08}, 116 | {0.1, 0.5, 0.00059339110446022798}, 117 | {0.1, 0.75, 5.7917132949696076e-07}, 118 | {0.25, 0.25, 0.26062600197823282}, 119 | {0.5, 0.1, 1.3527717270477047}, 120 | {0.5, 0.5, 0.22746821155978625}, 121 | {0.75, 0.25, 1.0340914067758025}, 122 | {1, 0, math.Inf(1)}, 123 | {1, 0.5, 0.69314718055994529}, 124 | {1, 1, 0}, 125 | {3, 0.75, 1.727299417860519}, 126 | {25, 0.4, 25.945791937289371}, 127 | {25, 0.7, 22.156653488661991}, 128 | {10, 0.5, 9.6687146147141299}, 129 | {100, 0.25, 106.5510925269767}, 130 | {1000, 0.01, 1075.0328320864389}, 131 | {1000, 0.99, 927.90815979664251}, 132 | {10000, 0.5, 9999.6666686420485}, 133 | } { 134 | if got := GammaIncCompInv(test.a, test.x); math.Abs(got-test.want) > 1e-10 { 135 | t.Errorf("test %d GammaIncCompInv(%g, %g) failed: got %g want %g", i, test.a, test.x, got, test.want) 136 | } 137 | } 138 | } 139 | -------------------------------------------------------------------------------- /internal/amos/amoslib/Make.files: -------------------------------------------------------------------------------- 1 | $(CUR_SRCS) += d1mach.f zabs.f zasyi.f zbesk.f zbknu.f zexp.f zmlt.f zshch.f zuni1.f zunk2.f \ 2 | dgamln.f zacai.f zbesh.f zbesy.f zbuni.f zkscl.f zrati.f zsqrt.f zuni2.f zuoik.f \ 3 | i1mach.f zacon.f zbesi.f zbinu.f zbunk.f zlog.f zs1s2.f zuchk.f zunik.f zwrsk.f \ 4 | xerror.f zairy.f zbesj.f zbiry.f zdiv.f zmlri.f zseri.f zunhj.f zunk1.f 5 | 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/d1mach.f: -------------------------------------------------------------------------------- 1 | *DECK D1MACH 2 | DOUBLE PRECISION FUNCTION D1MACH(I) 3 | C***BEGIN PROLOGUE D1MACH 4 | C***DATE WRITTEN 750101 (YYMMDD) 5 | C***REVISION DATE 890213 (YYMMDD) 6 | C***CATEGORY NO. R1 7 | C***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D), 8 | C MACHINE CONSTANTS 9 | C***AUTHOR FOX, P. A., (BELL LABS) 10 | C HALL, A. D., (BELL LABS) 11 | C SCHRYER, N. L., (BELL LABS) 12 | C***PURPOSE Returns double precision machine dependent constants 13 | C***DESCRIPTION 14 | C 15 | C D1MACH can be used to obtain machine-dependent parameters 16 | C for the local machine environment. It is a function 17 | C subprogram with one (input) argument, and can be called 18 | C as follows, for example 19 | C 20 | C D = D1MACH(I) 21 | C 22 | C where I=1,...,5. The (output) value of D above is 23 | C determined by the (input) value of I. The results for 24 | C various values of I are discussed below. 25 | C 26 | C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. 27 | C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. 28 | C D1MACH( 3) = B**(-T), the smallest relative spacing. 29 | C D1MACH( 4) = B**(1-T), the largest relative spacing. 30 | C D1MACH( 5) = LOG10(B) 31 | C 32 | C Assume double precision numbers are represented in the T-digit, 33 | C base-B form 34 | C 35 | C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) 36 | C 37 | C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and 38 | C EMIN .LE. E .LE. EMAX. 39 | C 40 | C The values of B, T, EMIN and EMAX are provided in I1MACH as 41 | C follows: 42 | C I1MACH(10) = B, the base. 43 | C I1MACH(14) = T, the number of base-B digits. 44 | C I1MACH(15) = EMIN, the smallest exponent E. 45 | C I1MACH(16) = EMAX, the largest exponent E. 46 | C 47 | C To alter this function for a particular environment, 48 | C the desired set of DATA statements should be activated by 49 | C removing the C from column 1. Also, the values of 50 | C D1MACH(1) - D1MACH(4) should be checked for consistency 51 | C with the local operating system. 52 | C 53 | C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A 54 | C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL 55 | C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. 56 | C***ROUTINES CALLED XERROR 57 | C***END PROLOGUE D1MACH 58 | C 59 | INTEGER SMALL(4) 60 | INTEGER LARGE(4) 61 | INTEGER RIGHT(4) 62 | INTEGER DIVER(4) 63 | INTEGER LOG10(4) 64 | C 65 | DOUBLE PRECISION DMACH(5) 66 | SAVE DMACH 67 | C 68 | C EQUIVALENCE (DMACH(1),SMALL(1)) 69 | C EQUIVALENCE (DMACH(2),LARGE(1)) 70 | C EQUIVALENCE (DMACH(3),RIGHT(1)) 71 | C EQUIVALENCE (DMACH(4),DIVER(1)) 72 | C EQUIVALENCE (DMACH(5),LOG10(1)) 73 | C 74 | C MACHINE CONSTANTS FOR THE IBM PC 75 | C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION 76 | C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. 77 | C 78 | DATA DMACH(1) / 2.23D-308 / 79 | C DATA SMALL(1),SMALL(2) / 2002288515, 1050897 / 80 | DATA DMACH(2) / 1.79D-308 / 81 | C DATA LARGE(1),LARGE(2) / 1487780761, 2146426097 / 82 | DATA DMACH(3) / 1.11D-16 / 83 | C DATA RIGHT(1),RIGHT(2) / -1209488034, 1017118298 / 84 | DATA DMACH(4) / 2.22D-16 / 85 | C DATA DIVER(1),DIVER(2) / -1209488034, 1018166874 / 86 | DATA DMACH(5) / 0.3010299956639812 / 87 | C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / 88 | C 89 | C 90 | C***FIRST EXECUTABLE STATEMENT D1MACH 91 | IF (I .LT. 1 .OR. I .GT. 5) 92 | 1 CALL XERROR ('D1MACH -- I OUT OF BOUNDS', 25, 1, 2) 93 | C 94 | D1MACH = DMACH(I) 95 | RETURN 96 | C 97 | END 98 | -------------------------------------------------------------------------------- /internal/amos/amoslib/dgamln.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR) 2 | C***BEGIN PROLOGUE DGAMLN 3 | C***DATE WRITTEN 830501 (YYMMDD) 4 | C***REVISION DATE 830501 (YYMMDD) 5 | C***CATEGORY NO. B5F 6 | C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION 7 | C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES 8 | C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION 9 | C***DESCRIPTION 10 | C 11 | C **** A DOUBLE PRECISION ROUTINE **** 12 | C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR 13 | C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES 14 | C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION 15 | C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS 16 | C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE 17 | C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) 18 | C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. 19 | C 20 | C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 21 | C VALUES IS USED FOR SPEED OF EXECUTION. 22 | C 23 | C DESCRIPTION OF ARGUMENTS 24 | C 25 | C INPUT Z IS D0UBLE PRECISION 26 | C Z - ARGUMENT, Z.GT.0.0D0 27 | C 28 | C OUTPUT DGAMLN IS DOUBLE PRECISION 29 | C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 30 | C IERR - ERROR FLAG 31 | C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED 32 | C IERR=1, Z.LE.0.0D0, NO COMPUTATION 33 | C 34 | C 35 | C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT 36 | C BY D. E. AMOS, SAND83-0083, MAY, 1983. 37 | C***ROUTINES CALLED I1MACH,D1MACH 38 | C***END PROLOGUE DGAMLN 39 | DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, 40 | * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH 41 | INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH 42 | DIMENSION CF(22), GLN(100) 43 | C LNGAMMA(N), N=1,100 44 | DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), 45 | 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), 46 | 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), 47 | 3 GLN(21), GLN(22)/ 48 | 4 0.00000000000000000D+00, 0.00000000000000000D+00, 49 | 5 6.93147180559945309D-01, 1.79175946922805500D+00, 50 | 6 3.17805383034794562D+00, 4.78749174278204599D+00, 51 | 7 6.57925121201010100D+00, 8.52516136106541430D+00, 52 | 8 1.06046029027452502D+01, 1.28018274800814696D+01, 53 | 9 1.51044125730755153D+01, 1.75023078458738858D+01, 54 | A 1.99872144956618861D+01, 2.25521638531234229D+01, 55 | B 2.51912211827386815D+01, 2.78992713838408916D+01, 56 | C 3.06718601060806728D+01, 3.35050734501368889D+01, 57 | D 3.63954452080330536D+01, 3.93398841871994940D+01, 58 | E 4.23356164607534850D+01, 4.53801388984769080D+01/ 59 | DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), 60 | 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), 61 | 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), 62 | 3 GLN(41), GLN(42), GLN(43), GLN(44)/ 63 | 4 4.84711813518352239D+01, 5.16066755677643736D+01, 64 | 5 5.47847293981123192D+01, 5.80036052229805199D+01, 65 | 6 6.12617017610020020D+01, 6.45575386270063311D+01, 66 | 7 6.78897431371815350D+01, 7.12570389671680090D+01, 67 | 8 7.46582363488301644D+01, 7.80922235533153106D+01, 68 | 9 8.15579594561150372D+01, 8.50544670175815174D+01, 69 | A 8.85808275421976788D+01, 9.21361756036870925D+01, 70 | B 9.57196945421432025D+01, 9.93306124547874269D+01, 71 | C 1.02968198614513813D+02, 1.06631760260643459D+02, 72 | D 1.10320639714757395D+02, 1.14034211781461703D+02, 73 | E 1.17771881399745072D+02, 1.21533081515438634D+02/ 74 | DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), 75 | 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), 76 | 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), 77 | 3 GLN(63), GLN(64), GLN(65), GLN(66)/ 78 | 4 1.25317271149356895D+02, 1.29123933639127215D+02, 79 | 5 1.32952575035616310D+02, 1.36802722637326368D+02, 80 | 6 1.40673923648234259D+02, 1.44565743946344886D+02, 81 | 7 1.48477766951773032D+02, 1.52409592584497358D+02, 82 | 8 1.56360836303078785D+02, 1.60331128216630907D+02, 83 | 9 1.64320112263195181D+02, 1.68327445448427652D+02, 84 | A 1.72352797139162802D+02, 1.76395848406997352D+02, 85 | B 1.80456291417543771D+02, 1.84533828861449491D+02, 86 | C 1.88628173423671591D+02, 1.92739047287844902D+02, 87 | D 1.96866181672889994D+02, 2.01009316399281527D+02, 88 | E 2.05168199482641199D+02, 2.09342586752536836D+02/ 89 | DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), 90 | 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), 91 | 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), 92 | 3 GLN(85), GLN(86), GLN(87), GLN(88)/ 93 | 4 2.13532241494563261D+02, 2.17736934113954227D+02, 94 | 5 2.21956441819130334D+02, 2.26190548323727593D+02, 95 | 6 2.30439043565776952D+02, 2.34701723442818268D+02, 96 | 7 2.38978389561834323D+02, 2.43268849002982714D+02, 97 | 8 2.47572914096186884D+02, 2.51890402209723194D+02, 98 | 9 2.56221135550009525D+02, 2.60564940971863209D+02, 99 | A 2.64921649798552801D+02, 2.69291097651019823D+02, 100 | B 2.73673124285693704D+02, 2.78067573440366143D+02, 101 | C 2.82474292687630396D+02, 2.86893133295426994D+02, 102 | D 2.91323950094270308D+02, 2.95766601350760624D+02, 103 | E 3.00220948647014132D+02, 3.04686856765668715D+02/ 104 | DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), 105 | 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ 106 | 2 3.09164193580146922D+02, 3.13652829949879062D+02, 107 | 3 3.18152639620209327D+02, 3.22663499126726177D+02, 108 | 4 3.27185287703775217D+02, 3.31717887196928473D+02, 109 | 5 3.36261181979198477D+02, 3.40815058870799018D+02, 110 | 6 3.45379407062266854D+02, 3.49954118040770237D+02, 111 | 7 3.54539085519440809D+02, 3.59134205369575399D+02/ 112 | C COEFFICIENTS OF ASYMPTOTIC EXPANSION 113 | DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), 114 | 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), 115 | 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ 116 | 3 8.33333333333333333D-02, -2.77777777777777778D-03, 117 | 4 7.93650793650793651D-04, -5.95238095238095238D-04, 118 | 5 8.41750841750841751D-04, -1.91752691752691753D-03, 119 | 6 6.41025641025641026D-03, -2.95506535947712418D-02, 120 | 7 1.79644372368830573D-01, -1.39243221690590112D+00, 121 | 8 1.34028640441683920D+01, -1.56848284626002017D+02, 122 | 9 2.19310333333333333D+03, -3.61087712537249894D+04, 123 | A 6.91472268851313067D+05, -1.52382215394074162D+07, 124 | B 3.82900751391414141D+08, -1.08822660357843911D+10, 125 | C 3.47320283765002252D+11, -1.23696021422692745D+13, 126 | D 4.88788064793079335D+14, -2.13203339609193739D+16/ 127 | C 128 | C LN(2*PI) 129 | DATA CON / 1.83787706640934548D+00/ 130 | C 131 | C***FIRST EXECUTABLE STATEMENT DGAMLN 132 | IERR=0 133 | IF (Z.LE.0.0D0) GO TO 70 134 | IF (Z.GT.101.0D0) GO TO 10 135 | NZ = INT(SNGL(Z)) 136 | FZ = Z - FLOAT(NZ) 137 | IF (FZ.GT.0.0D0) GO TO 10 138 | IF (NZ.GT.100) GO TO 10 139 | DGAMLN = GLN(NZ) 140 | RETURN 141 | 10 CONTINUE 142 | WDTOL = D1MACH(4) 143 | WDTOL = DMAX1(WDTOL,0.5D-18) 144 | I1M = I1MACH(14) 145 | RLN = D1MACH(5)*FLOAT(I1M) 146 | FLN = DMIN1(RLN,20.0D0) 147 | FLN = DMAX1(FLN,3.0D0) 148 | FLN = FLN - 3.0D0 149 | ZM = 1.8000D0 + 0.3875D0*FLN 150 | MZ = INT(SNGL(ZM)) + 1 151 | ZMIN = FLOAT(MZ) 152 | ZDMY = Z 153 | ZINC = 0.0D0 154 | IF (Z.GE.ZMIN) GO TO 20 155 | ZINC = ZMIN - FLOAT(NZ) 156 | ZDMY = Z + ZINC 157 | 20 CONTINUE 158 | ZP = 1.0D0/ZDMY 159 | T1 = CF(1)*ZP 160 | S = T1 161 | IF (ZP.LT.WDTOL) GO TO 40 162 | ZSQ = ZP*ZP 163 | TST = T1*WDTOL 164 | DO 30 K=2,22 165 | ZP = ZP*ZSQ 166 | TRM = CF(K)*ZP 167 | IF (DABS(TRM).LT.TST) GO TO 40 168 | S = S + TRM 169 | 30 CONTINUE 170 | 40 CONTINUE 171 | IF (ZINC.NE.0.0D0) GO TO 50 172 | TLG = DLOG(Z) 173 | DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S 174 | RETURN 175 | 50 CONTINUE 176 | ZP = 1.0D0 177 | NZ = INT(SNGL(ZINC)) 178 | DO 60 I=1,NZ 179 | ZP = ZP*(Z+FLOAT(I-1)) 180 | 60 CONTINUE 181 | TLG = DLOG(ZDMY) 182 | DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S 183 | RETURN 184 | C 185 | C 186 | 70 CONTINUE 187 | IERR=1 188 | RETURN 189 | END 190 | -------------------------------------------------------------------------------- /internal/amos/amoslib/i1mach.f: -------------------------------------------------------------------------------- 1 | *DECK I1MACH 2 | INTEGER FUNCTION I1MACH(I) 3 | C***BEGIN PROLOGUE I1MACH 4 | C***DATE WRITTEN 750101 (YYMMDD) 5 | C***REVISION DATE 890213 (YYMMDD) 6 | C***CATEGORY NO. R1 7 | C***KEYWORDS LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS 8 | C***AUTHOR FOX, P. A., (BELL LABS) 9 | C HALL, A. D., (BELL LABS) 10 | C SCHRYER, N. L., (BELL LABS) 11 | C***PURPOSE Returns integer machine dependent constants 12 | C***DESCRIPTION 13 | C 14 | C I1MACH can be used to obtain machine-dependent parameters 15 | C for the local machine environment. It is a function 16 | C subroutine with one (input) argument, and can be called 17 | C as follows, for example 18 | C 19 | C K = I1MACH(I) 20 | C 21 | C where I=1,...,16. The (output) value of K above is 22 | C determined by the (input) value of I. The results for 23 | C various values of I are discussed below. 24 | C 25 | C I/O unit numbers. 26 | C I1MACH( 1) = the standard input unit. 27 | C I1MACH( 2) = the standard output unit. 28 | C I1MACH( 3) = the standard punch unit. 29 | C I1MACH( 4) = the standard error message unit. 30 | C 31 | C Words. 32 | C I1MACH( 5) = the number of bits per integer storage unit. 33 | C I1MACH( 6) = the number of characters per integer storage unit. 34 | C 35 | C Integers. 36 | C assume integers are represented in the S-digit, base-A form 37 | C 38 | C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) 39 | C 40 | C where 0 .LE. X(I) .LT. A for I=0,...,S-1. 41 | C I1MACH( 7) = A, the base. 42 | C I1MACH( 8) = S, the number of base-A digits. 43 | C I1MACH( 9) = A**S - 1, the largest magnitude. 44 | C 45 | C Floating-Point Numbers. 46 | C Assume floating-point numbers are represented in the T-digit, 47 | C base-B form 48 | C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) 49 | C 50 | C where 0 .LE. X(I) .LT. B for I=1,...,T, 51 | C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. 52 | C I1MACH(10) = B, the base. 53 | C 54 | C Single-Precision 55 | C I1MACH(11) = T, the number of base-B digits. 56 | C I1MACH(12) = EMIN, the smallest exponent E. 57 | C I1MACH(13) = EMAX, the largest exponent E. 58 | C 59 | C Double-Precision 60 | C I1MACH(14) = T, the number of base-B digits. 61 | C I1MACH(15) = EMIN, the smallest exponent E. 62 | C I1MACH(16) = EMAX, the largest exponent E. 63 | C 64 | C To alter this function for a particular environment, 65 | C the desired set of DATA statements should be activated by 66 | C removing the C from column 1. Also, the values of 67 | C I1MACH(1) - I1MACH(4) should be checked for consistency 68 | C with the local operating system. 69 | C 70 | C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A 71 | C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL 72 | C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. 73 | C***ROUTINES CALLED (NONE) 74 | C***END PROLOGUE I1MACH 75 | C 76 | INTEGER IMACH(16),OUTPUT 77 | SAVE IMACH 78 | EQUIVALENCE (IMACH(4),OUTPUT) 79 | C 80 | C MACHINE CONSTANTS FOR THE IBM PC 81 | C 82 | DATA IMACH( 1) / 5 / 83 | DATA IMACH( 2) / 6 / 84 | DATA IMACH( 3) / 0 / 85 | DATA IMACH( 4) / 0 / 86 | DATA IMACH( 5) / 32 / 87 | DATA IMACH( 6) / 4 / 88 | DATA IMACH( 7) / 2 / 89 | DATA IMACH( 8) / 31 / 90 | DATA IMACH( 9) / 2147483647 / 91 | DATA IMACH(10) / 2 / 92 | DATA IMACH(11) / 24 / 93 | DATA IMACH(12) / -125 / 94 | DATA IMACH(13) / 127 / 95 | DATA IMACH(14) / 53 / 96 | DATA IMACH(15) / -1021 / 97 | DATA IMACH(16) / 1023 / 98 | C 99 | C***FIRST EXECUTABLE STATEMENT I1MACH 100 | IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 101 | C 102 | I1MACH = IMACH(I) 103 | RETURN 104 | C 105 | 10 CONTINUE 106 | WRITE (UNIT = OUTPUT, FMT = 9000) 107 | 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') 108 | C 109 | C CALL FDUMP 110 | C 111 | C 112 | STOP 113 | END 114 | -------------------------------------------------------------------------------- /internal/amos/amoslib/myabs.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYABS(A) 2 | DOUBLE PRECISION A 3 | MYABS = DABS(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/myatan.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYATAN(A) 2 | DOUBLE PRECISION A 3 | MYATAN = DATAN(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mycos.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYCOS(A) 2 | DOUBLE PRECISION A 3 | MYCOS = DCOS(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/myexp.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYEXP(A) 2 | DOUBLE PRECISION A 3 | MYEXP = DEXP(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mylog.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYLOG(A) 2 | DOUBLE PRECISION A 3 | MYLOG = DLOG(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mymax.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYMAX(A, B) 2 | DOUBLE PRECISION A, B 3 | MYMAX = DMAX1(A,B) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mymin.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYMIN(A, B) 2 | DOUBLE PRECISION A, B 3 | MYMIN = DMIN1(A,B) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mysin.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYSIN(A) 2 | DOUBLE PRECISION A 3 | MYSIN = DSIN(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mysqrt.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYSQRT(A) 2 | DOUBLE PRECISION A 3 | MYSQRT = SQRT(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/mytan.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MYTAN(A) 2 | DOUBLE PRECISION A 3 | MYTAN = DTAN(A) 4 | RETURN 5 | END 6 | -------------------------------------------------------------------------------- /internal/amos/amoslib/xerror.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE XERROR(MESS,NMESS,L1,L2) 2 | C 3 | C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS 4 | C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL 5 | C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 6 | C ROUTINE. 7 | C 8 | CHARACTER*(*) MESS 9 | NN=NMESS/70 10 | NR=NMESS-70*NN 11 | IF(NR.NE.0) NN=NN+1 12 | K=1 13 | PRINT 900 14 | 900 FORMAT(/) 15 | DO 10 I=1,NN 16 | KMIN=MIN0(K+69,NMESS) 17 | PRINT *, MESS(K:KMIN) 18 | K=K+70 19 | 10 CONTINUE 20 | PRINT 900 21 | RETURN 22 | END 23 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zabs.f: -------------------------------------------------------------------------------- 1 | DOUBLE PRECISION FUNCTION MZABS(ZR, ZI) 2 | C***BEGIN PROLOGUE ZABS 3 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY 4 | C 5 | C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE 6 | C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) 7 | C 8 | C***ROUTINES CALLED (NONE) 9 | C***END PROLOGUE ZABS 10 | DOUBLE PRECISION ZR, ZI, U, V, Q, S 11 | 12 | MZABS = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 13 | RETURN 14 | END 15 | 16 | c U = DABS(ZR) 17 | c V = DABS(ZI) 18 | c S = U + V 19 | C----------------------------------------------------------------------- 20 | C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A 21 | C TRUE FLOATING ZERO 22 | C----------------------------------------------------------------------- 23 | c S = S*1.0D+0 24 | c IF (S.EQ.0.0D+0) GO TO 20 25 | c IF (U.GT.V) GO TO 10 26 | c Q = U/V 27 | c ZABS = V*DSQRT(1.D+0+Q*Q) 28 | c RETURN 29 | c 10 Q = V/U 30 | c ZABS = U*DSQRT(1.D+0+Q*Q) 31 | c RETURN 32 | c 20 ZABS = 0.0D+0 33 | c RETURN 34 | c END 35 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zacai.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, 2 | * ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZACAI 4 | C***REFER TO ZAIRY 5 | C 6 | C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA 7 | C 8 | C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) 9 | C MP=PI*MR*CMPLX(0.0,1.0) 10 | C 11 | C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT 12 | C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. 13 | C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND 14 | C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON 15 | C IS CALLED FROM ZAIRY. 16 | C 17 | C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS 18 | C***END PROLOGUE ZACAI 19 | C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY 20 | DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, 21 | * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, 22 | * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS 23 | INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ 24 | DIMENSION YR(N), YI(N), CYR(2), CYI(2) 25 | DATA PI / 3.14159265358979324D0 / 26 | NZ = 0 27 | ZNR = -ZR 28 | ZNI = -ZI 29 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 30 | NN = N 31 | DFNU = FNU + DBLE(FLOAT(N-1)) 32 | IF (AZ.LE.2.0D0) GO TO 10 33 | IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 34 | 10 CONTINUE 35 | C----------------------------------------------------------------------- 36 | C POWER SERIES FOR THE I FUNCTION 37 | C----------------------------------------------------------------------- 38 | CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) 39 | GO TO 40 40 | 20 CONTINUE 41 | IF (AZ.LT.RL) GO TO 30 42 | C----------------------------------------------------------------------- 43 | C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION 44 | C----------------------------------------------------------------------- 45 | CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, 46 | * ALIM) 47 | IF (NW.LT.0) GO TO 80 48 | GO TO 40 49 | 30 CONTINUE 50 | C----------------------------------------------------------------------- 51 | C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION 52 | C----------------------------------------------------------------------- 53 | CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) 54 | IF(NW.LT.0) GO TO 80 55 | 40 CONTINUE 56 | C----------------------------------------------------------------------- 57 | C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION 58 | C----------------------------------------------------------------------- 59 | CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) 60 | IF (NW.NE.0) GO TO 80 61 | FMR = DBLE(FLOAT(MR)) 62 | SGN = -DSIGN(PI,FMR) 63 | CSGNR = 0.0D0 64 | CSGNI = SGN 65 | IF (KODE.EQ.1) GO TO 50 66 | YY = -ZNI 67 | CSGNR = -CSGNI*DSIN(YY) 68 | CSGNI = CSGNI*DCOS(YY) 69 | 50 CONTINUE 70 | C----------------------------------------------------------------------- 71 | C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE 72 | C WHEN FNU IS LARGE 73 | C----------------------------------------------------------------------- 74 | INU = INT(SNGL(FNU)) 75 | ARG = (FNU-DBLE(FLOAT(INU)))*SGN 76 | CSPNR = DCOS(ARG) 77 | CSPNI = DSIN(ARG) 78 | IF (MOD(INU,2).EQ.0) GO TO 60 79 | CSPNR = -CSPNR 80 | CSPNI = -CSPNI 81 | 60 CONTINUE 82 | C1R = CYR(1) 83 | C1I = CYI(1) 84 | C2R = YR(1) 85 | C2I = YI(1) 86 | IF (KODE.EQ.1) GO TO 70 87 | IUF = 0 88 | ASCLE = 1.0D+3*D1MACH(1)/TOL 89 | CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 90 | NZ = NZ + NW 91 | 70 CONTINUE 92 | YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I 93 | YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R 94 | RETURN 95 | 80 CONTINUE 96 | NZ = -1 97 | IF(NW.EQ.(-2)) NZ=-2 98 | RETURN 99 | END 100 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zacon.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, 2 | * TOL, ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZACON 4 | C***REFER TO ZBESK,ZBESH 5 | C 6 | C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA 7 | C 8 | C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) 9 | C MP=PI*MR*CMPLX(0.0,1.0) 10 | C 11 | C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT 12 | C HALF Z PLANE 13 | C 14 | C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT 15 | C***END PROLOGUE ZACON 16 | C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, 17 | C *S1,S2,Y,Z,ZN 18 | DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, 19 | * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, 20 | * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, 21 | * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, 22 | * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, 23 | * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS 24 | INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ 25 | DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) 26 | DATA PI / 3.14159265358979324D0 / 27 | DATA ZEROR,CONER / 0.0D0,1.0D0 / 28 | NZ = 0 29 | ZNR = -ZR 30 | ZNI = -ZI 31 | NN = N 32 | CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, 33 | * ELIM, ALIM) 34 | IF (NW.LT.0) GO TO 90 35 | C----------------------------------------------------------------------- 36 | C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION 37 | C----------------------------------------------------------------------- 38 | NN = MIN0(2,N) 39 | CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) 40 | IF (NW.NE.0) GO TO 90 41 | S1R = CYR(1) 42 | S1I = CYI(1) 43 | FMR = DBLE(FLOAT(MR)) 44 | SGN = -DSIGN(PI,FMR) 45 | CSGNR = ZEROR 46 | CSGNI = SGN 47 | IF (KODE.EQ.1) GO TO 10 48 | YY = -ZNI 49 | CPN = DCOS(YY) 50 | SPN = DSIN(YY) 51 | CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) 52 | 10 CONTINUE 53 | C----------------------------------------------------------------------- 54 | C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE 55 | C WHEN FNU IS LARGE 56 | C----------------------------------------------------------------------- 57 | INU = INT(SNGL(FNU)) 58 | ARG = (FNU-DBLE(FLOAT(INU)))*SGN 59 | CPN = DCOS(ARG) 60 | SPN = DSIN(ARG) 61 | CSPNR = CPN 62 | CSPNI = SPN 63 | IF (MOD(INU,2).EQ.0) GO TO 20 64 | CSPNR = -CSPNR 65 | CSPNI = -CSPNI 66 | 20 CONTINUE 67 | IUF = 0 68 | C1R = S1R 69 | C1I = S1I 70 | C2R = YR(1) 71 | C2I = YI(1) 72 | ASCLE = 1.0D+3*D1MACH(1)/TOL 73 | IF (KODE.EQ.1) GO TO 30 74 | CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 75 | NZ = NZ + NW 76 | SC1R = C1R 77 | SC1I = C1I 78 | 30 CONTINUE 79 | CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) 80 | CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) 81 | YR(1) = STR + PTR 82 | YI(1) = STI + PTI 83 | IF (N.EQ.1) RETURN 84 | CSPNR = -CSPNR 85 | CSPNI = -CSPNI 86 | S2R = CYR(2) 87 | S2I = CYI(2) 88 | C1R = S2R 89 | C1I = S2I 90 | C2R = YR(2) 91 | C2I = YI(2) 92 | IF (KODE.EQ.1) GO TO 40 93 | CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 94 | NZ = NZ + NW 95 | SC2R = C1R 96 | SC2I = C1I 97 | 40 CONTINUE 98 | CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) 99 | CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) 100 | YR(2) = STR + PTR 101 | YI(2) = STI + PTI 102 | IF (N.EQ.2) RETURN 103 | CSPNR = -CSPNR 104 | CSPNI = -CSPNI 105 | AZN = ZABS(CMPLX(ZNR,ZNI,kind=KIND(1.0D0))) 106 | RAZN = 1.0D0/AZN 107 | STR = ZNR*RAZN 108 | STI = -ZNI*RAZN 109 | RZR = (STR+STR)*RAZN 110 | RZI = (STI+STI)*RAZN 111 | FN = FNU + 1.0D0 112 | CKR = FN*RZR 113 | CKI = FN*RZI 114 | C----------------------------------------------------------------------- 115 | C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS 116 | C----------------------------------------------------------------------- 117 | CSCL = 1.0D0/TOL 118 | CSCR = TOL 119 | CSSR(1) = CSCL 120 | CSSR(2) = CONER 121 | CSSR(3) = CSCR 122 | CSRR(1) = CSCR 123 | CSRR(2) = CONER 124 | CSRR(3) = CSCL 125 | BRY(1) = ASCLE 126 | BRY(2) = 1.0D0/ASCLE 127 | BRY(3) = D1MACH(2) 128 | AS2 = ZABS(CMPLX(S2R,S2I,kind=KIND(1.0D0))) 129 | KFLAG = 2 130 | IF (AS2.GT.BRY(1)) GO TO 50 131 | KFLAG = 1 132 | GO TO 60 133 | 50 CONTINUE 134 | IF (AS2.LT.BRY(2)) GO TO 60 135 | KFLAG = 3 136 | 60 CONTINUE 137 | BSCLE = BRY(KFLAG) 138 | S1R = S1R*CSSR(KFLAG) 139 | S1I = S1I*CSSR(KFLAG) 140 | S2R = S2R*CSSR(KFLAG) 141 | S2I = S2I*CSSR(KFLAG) 142 | CSR = CSRR(KFLAG) 143 | DO 80 I=3,N 144 | STR = S2R 145 | STI = S2I 146 | S2R = CKR*STR - CKI*STI + S1R 147 | S2I = CKR*STI + CKI*STR + S1I 148 | S1R = STR 149 | S1I = STI 150 | C1R = S2R*CSR 151 | C1I = S2I*CSR 152 | STR = C1R 153 | STI = C1I 154 | C2R = YR(I) 155 | C2I = YI(I) 156 | IF (KODE.EQ.1) GO TO 70 157 | IF (IUF.LT.0) GO TO 70 158 | CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 159 | NZ = NZ + NW 160 | SC1R = SC2R 161 | SC1I = SC2I 162 | SC2R = C1R 163 | SC2I = C1I 164 | IF (IUF.NE.3) GO TO 70 165 | IUF = -4 166 | S1R = SC1R*CSSR(KFLAG) 167 | S1I = SC1I*CSSR(KFLAG) 168 | S2R = SC2R*CSSR(KFLAG) 169 | S2I = SC2I*CSSR(KFLAG) 170 | STR = SC2R 171 | STI = SC2I 172 | 70 CONTINUE 173 | PTR = CSPNR*C1R - CSPNI*C1I 174 | PTI = CSPNR*C1I + CSPNI*C1R 175 | YR(I) = PTR + CSGNR*C2R - CSGNI*C2I 176 | YI(I) = PTI + CSGNR*C2I + CSGNI*C2R 177 | CKR = CKR + RZR 178 | CKI = CKI + RZI 179 | CSPNR = -CSPNR 180 | CSPNI = -CSPNI 181 | IF (KFLAG.GE.3) GO TO 80 182 | PTR = DABS(C1R) 183 | PTI = DABS(C1I) 184 | C1M = DMAX1(PTR,PTI) 185 | IF (C1M.LE.BSCLE) GO TO 80 186 | KFLAG = KFLAG + 1 187 | BSCLE = BRY(KFLAG) 188 | S1R = S1R*CSR 189 | S1I = S1I*CSR 190 | S2R = STR 191 | S2I = STI 192 | S1R = S1R*CSSR(KFLAG) 193 | S1I = S1I*CSSR(KFLAG) 194 | S2R = S2R*CSSR(KFLAG) 195 | S2I = S2I*CSSR(KFLAG) 196 | CSR = CSRR(KFLAG) 197 | 80 CONTINUE 198 | RETURN 199 | 90 CONTINUE 200 | NZ = -1 201 | IF(NW.EQ.(-2)) NZ=-2 202 | RETURN 203 | END 204 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zasyi.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, 2 | * ALIM) 3 | C***BEGIN PROLOGUE ZASYI 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY 7 | C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE 8 | C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. 9 | C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. 10 | C 11 | C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT 12 | C***END PROLOGUE ZASYI 13 | C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z 14 | DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, 15 | * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, 16 | * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, 17 | * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, 18 | * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS 19 | INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ 20 | DIMENSION YR(N), YI(N) 21 | DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / 22 | DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / 23 | C 24 | NZ = 0 25 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 26 | ARM = 1.0D+3*D1MACH(1) 27 | RTR1 = DSQRT(ARM) 28 | IL = MIN0(2,N) 29 | DFNU = FNU + DBLE(FLOAT(N-IL)) 30 | C----------------------------------------------------------------------- 31 | C OVERFLOW TEST 32 | C----------------------------------------------------------------------- 33 | RAZ = 1.0D0/AZ 34 | STR = ZR*RAZ 35 | STI = -ZI*RAZ 36 | AK1R = RTPI*STR*RAZ 37 | AK1I = RTPI*STI*RAZ 38 | CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) 39 | CZR = ZR 40 | CZI = ZI 41 | IF (KODE.NE.2) GO TO 10 42 | CZR = ZEROR 43 | CZI = ZI 44 | 10 CONTINUE 45 | IF (DABS(CZR).GT.ELIM) GO TO 100 46 | DNU2 = DFNU + DFNU 47 | KODED = 1 48 | IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 49 | KODED = 0 50 | CALL ZEXP(CZR, CZI, STR, STI) 51 | CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) 52 | 20 CONTINUE 53 | FDN = 0.0D0 54 | IF (DNU2.GT.RTR1) THEN 55 | FDN = DNU2*DNU2 56 | END IF 57 | EZR = ZR*8.0D0 58 | EZI = ZI*8.0D0 59 | C----------------------------------------------------------------------- 60 | C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE 61 | C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE 62 | C EXPANSION FOR THE IMAGINARY PART. 63 | C----------------------------------------------------------------------- 64 | AEZ = 8.0D0*AZ 65 | S = TOL/AEZ 66 | JL = INT(SNGL(RL+RL)) + 2 67 | P1R = ZEROR 68 | P1I = ZEROI 69 | IF (ZI.EQ.0.0D0) GO TO 30 70 | C----------------------------------------------------------------------- 71 | C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF 72 | C SIGNIFICANCE WHEN FNU OR N IS LARGE 73 | C----------------------------------------------------------------------- 74 | INU = INT(SNGL(FNU)) 75 | ARG = (FNU-DBLE(FLOAT(INU)))*PI 76 | INU = INU + N - IL 77 | AK = -DSIN(ARG) 78 | BK = DCOS(ARG) 79 | IF (ZI.LT.0.0D0) BK = -BK 80 | P1R = AK 81 | P1I = BK 82 | IF (MOD(INU,2).EQ.0) GO TO 30 83 | P1R = -P1R 84 | P1I = -P1I 85 | 30 CONTINUE 86 | DO 70 K=1,IL 87 | SQK = FDN - 1.0D0 88 | ATOL = S*DABS(SQK) 89 | SGN = 1.0D0 90 | CS1R = CONER 91 | CS1I = CONEI 92 | CS2R = CONER 93 | CS2I = CONEI 94 | CKR = CONER 95 | CKI = CONEI 96 | AK = 0.0D0 97 | AA = 1.0D0 98 | BB = AEZ 99 | DKR = EZR 100 | DKI = EZI 101 | DO 40 J=1,JL 102 | CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) 103 | CKR = STR*SQK 104 | CKI = STI*SQK 105 | CS2R = CS2R + CKR 106 | CS2I = CS2I + CKI 107 | SGN = -SGN 108 | CS1R = CS1R + CKR*SGN 109 | CS1I = CS1I + CKI*SGN 110 | DKR = DKR + EZR 111 | DKI = DKI + EZI 112 | AA = AA*DABS(SQK)/BB 113 | BB = BB + AEZ 114 | AK = AK + 8.0D0 115 | SQK = SQK - AK 116 | IF (AA.LE.ATOL) THEN 117 | GO TO 50 118 | END IF 119 | 40 CONTINUE 120 | GO TO 110 121 | 50 CONTINUE 122 | S2R = CS1R 123 | S2I = CS1I 124 | IF (ZR+ZR.GE.ELIM) GO TO 60 125 | TZR = ZR + ZR 126 | TZI = ZI + ZI 127 | CALL ZEXP(-TZR, -TZI, STR, STI) 128 | CALL ZMLT(STR, STI, P1R, P1I, STR, STI) 129 | CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) 130 | S2R = S2R + STR 131 | S2I = S2I + STI 132 | 60 CONTINUE 133 | FDN = FDN + 8.0D0*DFNU + 4.0D0 134 | P1R = -P1R 135 | P1I = -P1I 136 | M = N - IL + K 137 | YR(M) = S2R*AK1R - S2I*AK1I 138 | YI(M) = S2R*AK1I + S2I*AK1R 139 | 70 CONTINUE 140 | IF (N.LE.2) RETURN 141 | NN = N 142 | K = NN - 2 143 | AK = DBLE(FLOAT(K)) 144 | STR = ZR*RAZ 145 | STI = -ZI*RAZ 146 | RZR = (STR+STR)*RAZ 147 | RZI = (STI+STI)*RAZ 148 | IB = 3 149 | DO 80 I=IB,NN 150 | YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) 151 | YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) 152 | AK = AK - 1.0D0 153 | K = K - 1 154 | 80 CONTINUE 155 | IF (KODED.EQ.0) RETURN 156 | CALL ZEXP(CZR, CZI, CKR, CKI) 157 | DO 90 I=1,NN 158 | STR = YR(I)*CKR - YI(I)*CKI 159 | YI(I) = YR(I)*CKI + YI(I)*CKR 160 | YR(I) = STR 161 | 90 CONTINUE 162 | RETURN 163 | 100 CONTINUE 164 | NZ = -1 165 | RETURN 166 | 110 CONTINUE 167 | NZ=-2 168 | RETURN 169 | END 170 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zbesj.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) 2 | C***BEGIN PROLOGUE ZBESJ 3 | C***DATE WRITTEN 830501 (YYMMDD) 4 | C***REVISION DATE 890801 (YYMMDD) 5 | C***CATEGORY NO. B5K 6 | C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, 7 | C BESSEL FUNCTION OF FIRST KIND 8 | C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES 9 | C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT 10 | C***DESCRIPTION 11 | C 12 | C ***A DOUBLE PRECISION ROUTINE*** 13 | C ON KODE=1, CBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX 14 | C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE 15 | C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE 16 | C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED 17 | C FUNCTIONS 18 | C 19 | C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) 20 | C 21 | C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND 22 | C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION 23 | C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS 24 | C (REF. 1). 25 | C 26 | C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION 27 | C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI 28 | C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 29 | C KODE - A PARAMETER TO INDICATE THE SCALING OPTION 30 | C KODE= 1 RETURNS 31 | C CY(I)=J(FNU+I-1,Z), I=1,...,N 32 | C = 2 RETURNS 33 | C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N 34 | C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 35 | C 36 | C OUTPUT CYR,CYI ARE DOUBLE PRECISION 37 | C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS 38 | C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE 39 | C CY(I)=J(FNU+I-1,Z) OR 40 | C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N 41 | C DEPENDING ON KODE, Y=AIMAG(Z). 42 | C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, 43 | C NZ= 0 , NORMAL RETURN 44 | C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE 45 | C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), 46 | C I = N-NZ+1,...,N 47 | C IERR - ERROR FLAG 48 | C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED 49 | C IERR=1, INPUT ERROR - NO COMPUTATION 50 | C IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z) 51 | C TOO LARGE ON KODE=1 52 | C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE 53 | C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT 54 | C REDUCTION PRODUCE LESS THAN HALF OF MACHINE 55 | C ACCURACY 56 | C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- 57 | C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- 58 | C CANCE BY ARGUMENT REDUCTION 59 | C IERR=5, ERROR - NO COMPUTATION, 60 | C ALGORITHM TERMINATION CONDITION NOT MET 61 | C 62 | C***LONG DESCRIPTION 63 | C 64 | C THE COMPUTATION IS CARRIED OUT BY THE FORMULA 65 | C 66 | C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0 67 | C 68 | C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0 69 | C 70 | C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION. 71 | C 72 | C FOR NEGATIVE ORDERS,THE FORMULA 73 | C 74 | C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU) 75 | C 76 | C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE 77 | C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE 78 | C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A 79 | C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, 80 | C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF 81 | C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY 82 | C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN 83 | C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, 84 | C LARGE MEANS FNU.GT.CABS(Z). 85 | C 86 | C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- 87 | C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS 88 | C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. 89 | C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN 90 | C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG 91 | C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS 92 | C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 93 | C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS 94 | C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS 95 | C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE 96 | C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 97 | C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 98 | C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION 99 | C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION 100 | C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN 101 | C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT 102 | C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS 103 | C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. 104 | C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. 105 | C 106 | C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX 107 | C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT 108 | C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- 109 | C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE 110 | C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), 111 | C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF 112 | C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 113 | C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 114 | C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 115 | C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 116 | C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 117 | C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 118 | C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 119 | C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 120 | C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER 121 | C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE 122 | C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, 123 | C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, 124 | C OR -PI/2+P. 125 | C 126 | C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ 127 | C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF 128 | C COMMERCE, 1955. 129 | C 130 | C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT 131 | C BY D. E. AMOS, SAND83-0083, MAY, 1983. 132 | C 133 | C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT 134 | C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 135 | C 136 | C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX 137 | C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 138 | C 1018, MAY, 1985 139 | C 140 | C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX 141 | C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. 142 | C MATH. SOFTWARE, 1986 143 | C 144 | C***ROUTINES CALLED ZBINU,I1MACH,D1MACH 145 | C***END PROLOGUE ZBESJ 146 | C 147 | C COMPLEX CI,CSGN,CY,Z,ZN 148 | DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, 149 | * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, 150 | * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI 151 | INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH 152 | DIMENSION CYR(N), CYI(N) 153 | DATA HPI /1.57079632679489662D0/ 154 | C 155 | C***FIRST EXECUTABLE STATEMENT ZBESJ 156 | IERR = 0 157 | NZ=0 158 | IF (FNU.LT.0.0D0) IERR=1 159 | IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 160 | IF (N.LT.1) IERR=1 161 | IF (IERR.NE.0) RETURN 162 | C----------------------------------------------------------------------- 163 | C SET PARAMETERS RELATED TO MACHINE CONSTANTS. 164 | C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. 165 | C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. 166 | C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND 167 | C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR 168 | C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. 169 | C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 170 | C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). 171 | C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. 172 | C----------------------------------------------------------------------- 173 | TOL = DMAX1(D1MACH(4),1.0D-18) 174 | K1 = I1MACH(15) 175 | K2 = I1MACH(16) 176 | R1M5 = D1MACH(5) 177 | K = MIN0(IABS(K1),IABS(K2)) 178 | ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) 179 | K1 = I1MACH(14) - 1 180 | AA = R1M5*DBLE(FLOAT(K1)) 181 | DIG = DMIN1(AA,18.0D0) 182 | AA = AA*2.303D0 183 | ALIM = ELIM + DMAX1(-AA,-41.45D0) 184 | RL = 1.2D0*DIG + 3.0D0 185 | FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) 186 | C----------------------------------------------------------------------- 187 | C TEST FOR PROPER RANGE 188 | C----------------------------------------------------------------------- 189 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 190 | FN = FNU+DBLE(FLOAT(N-1)) 191 | AA = 0.5D0/TOL 192 | BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 193 | AA = DMIN1(AA,BB) 194 | IF (AZ.GT.AA) GO TO 260 195 | IF (FN.GT.AA) GO TO 260 196 | AA = DSQRT(AA) 197 | IF (AZ.GT.AA) IERR=3 198 | IF (FN.GT.AA) IERR=3 199 | C----------------------------------------------------------------------- 200 | C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE 201 | C WHEN FNU IS LARGE 202 | C----------------------------------------------------------------------- 203 | CII = 1.0D0 204 | INU = INT(SNGL(FNU)) 205 | INUH = INU/2 206 | IR = INU - 2*INUH 207 | ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI 208 | CSGNR = DCOS(ARG) 209 | CSGNI = DSIN(ARG) 210 | IF (MOD(INUH,2).EQ.0) GO TO 40 211 | CSGNR = -CSGNR 212 | CSGNI = -CSGNI 213 | 40 CONTINUE 214 | C----------------------------------------------------------------------- 215 | C ZN IS IN THE RIGHT HALF PLANE 216 | C----------------------------------------------------------------------- 217 | ZNR = ZI 218 | ZNI = -ZR 219 | IF (ZI.GE.0.0D0) GO TO 50 220 | ZNR = -ZNR 221 | ZNI = -ZNI 222 | CSGNI = -CSGNI 223 | CII = -CII 224 | 50 CONTINUE 225 | CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, 226 | * ELIM, ALIM) 227 | IF (NZ.LT.0) GO TO 130 228 | NL = N - NZ 229 | IF (NL.EQ.0) RETURN 230 | RTOL = 1.0D0/TOL 231 | ASCLE = D1MACH(1)*RTOL*1.0D+3 232 | DO 60 I=1,NL 233 | C STR = CYR(I)*CSGNR - CYI(I)*CSGNI 234 | C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR 235 | C CYR(I) = STR 236 | AA = CYR(I) 237 | BB = CYI(I) 238 | ATOL = 1.0D0 239 | IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 240 | AA = AA*RTOL 241 | BB = BB*RTOL 242 | ATOL = TOL 243 | 55 CONTINUE 244 | STR = AA*CSGNR - BB*CSGNI 245 | STI = AA*CSGNI + BB*CSGNR 246 | CYR(I) = STR*ATOL 247 | CYI(I) = STI*ATOL 248 | STR = -CSGNI*CII 249 | CSGNI = CSGNR*CII 250 | CSGNR = STR 251 | 60 CONTINUE 252 | RETURN 253 | 130 CONTINUE 254 | IF(NZ.EQ.(-2)) GO TO 140 255 | NZ = 0 256 | IERR = 2 257 | RETURN 258 | 140 CONTINUE 259 | NZ=0 260 | IERR=5 261 | RETURN 262 | 260 CONTINUE 263 | NZ=0 264 | IERR=4 265 | RETURN 266 | END 267 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zbesy.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI, 2 | * IERR) 3 | C***BEGIN PROLOGUE ZBESY 4 | C***DATE WRITTEN 830501 (YYMMDD) 5 | C***REVISION DATE 890801 (YYMMDD) 6 | C***CATEGORY NO. B5K 7 | C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, 8 | C BESSEL FUNCTION OF SECOND KIND 9 | C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES 10 | C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT 11 | C***DESCRIPTION 12 | C 13 | C ***A DOUBLE PRECISION ROUTINE*** 14 | C 15 | C ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX 16 | C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE 17 | C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE 18 | C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED 19 | C FUNCTIONS 20 | C 21 | C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) 22 | C 23 | C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND 24 | C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION 25 | C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS 26 | C (REF. 1). 27 | C 28 | C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION 29 | C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), 30 | C -PI.LT.ARG(Z).LE.PI 31 | C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 32 | C KODE - A PARAMETER TO INDICATE THE SCALING OPTION 33 | C KODE= 1 RETURNS 34 | C CY(I)=Y(FNU+I-1,Z), I=1,...,N 35 | C = 2 RETURNS 36 | C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N 37 | C WHERE Y=AIMAG(Z) 38 | C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 39 | C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT 40 | C CWRKI AT LEAST N 41 | C 42 | C OUTPUT CYR,CYI ARE DOUBLE PRECISION 43 | C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS 44 | C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE 45 | C CY(I)=Y(FNU+I-1,Z) OR 46 | C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N 47 | C DEPENDING ON KODE. 48 | C NZ - NZ=0 , A NORMAL RETURN 49 | C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO 50 | C UNDERFLOW (GENERALLY ON KODE=2) 51 | C IERR - ERROR FLAG 52 | C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED 53 | C IERR=1, INPUT ERROR - NO COMPUTATION 54 | C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS 55 | C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH 56 | C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE 57 | C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT 58 | C REDUCTION PRODUCE LESS THAN HALF OF MACHINE 59 | C ACCURACY 60 | C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- 61 | C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- 62 | C CANCE BY ARGUMENT REDUCTION 63 | C IERR=5, ERROR - NO COMPUTATION, 64 | C ALGORITHM TERMINATION CONDITION NOT MET 65 | C 66 | C***LONG DESCRIPTION 67 | C 68 | C THE COMPUTATION IS CARRIED OUT BY THE FORMULA 69 | C 70 | C Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I 71 | C 72 | C WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z) 73 | C AND H(2,FNU,Z) ARE CALCULATED IN CBESH. 74 | C 75 | C FOR NEGATIVE ORDERS,THE FORMULA 76 | C 77 | C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU) 78 | C 79 | C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD 80 | C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE 81 | C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)* 82 | C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS 83 | C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A 84 | C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM 85 | C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, 86 | C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF 87 | C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z). 88 | C 89 | C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- 90 | C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS 91 | C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. 92 | C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN 93 | C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG 94 | C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS 95 | C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 96 | C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS 97 | C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS 98 | C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE 99 | C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 100 | C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 101 | C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION 102 | C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION 103 | C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN 104 | C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT 105 | C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS 106 | C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. 107 | C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. 108 | C 109 | C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX 110 | C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT 111 | C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- 112 | C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE 113 | C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), 114 | C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF 115 | C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 116 | C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 117 | C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 118 | C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 119 | C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 120 | C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 121 | C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 122 | C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 123 | C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER 124 | C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE 125 | C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, 126 | C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, 127 | C OR -PI/2+P. 128 | C 129 | C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ 130 | C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF 131 | C COMMERCE, 1955. 132 | C 133 | C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT 134 | C BY D. E. AMOS, SAND83-0083, MAY, 1983. 135 | C 136 | C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT 137 | C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 138 | C 139 | C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX 140 | C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 141 | C 1018, MAY, 1985 142 | C 143 | C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX 144 | C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. 145 | C MATH. SOFTWARE, 1986 146 | C 147 | C***ROUTINES CALLED ZBESH,I1MACH,D1MACH 148 | C***END PROLOGUE ZBESY 149 | C 150 | C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV 151 | DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R, 152 | * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, DEXP, 153 | * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL 154 | INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH 155 | DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N) 156 | C***FIRST EXECUTABLE STATEMENT ZBESY 157 | IERR = 0 158 | NZ=0 159 | IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 160 | IF (FNU.LT.0.0D0) IERR=1 161 | IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 162 | IF (N.LT.1) IERR=1 163 | IF (IERR.NE.0) RETURN 164 | HCII = 0.5D0 165 | CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR) 166 | IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 167 | CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR) 168 | IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 169 | NZ = MIN0(NZ1,NZ2) 170 | IF (KODE.EQ.2) GO TO 60 171 | DO 50 I=1,N 172 | STR = CWRKR(I) - CYR(I) 173 | STI = CWRKI(I) - CYI(I) 174 | CYR(I) = -STI*HCII 175 | CYI(I) = STR*HCII 176 | 50 CONTINUE 177 | RETURN 178 | 60 CONTINUE 179 | TOL = DMAX1(D1MACH(4),1.0D-18) 180 | K1 = I1MACH(15) 181 | K2 = I1MACH(16) 182 | K = MIN0(IABS(K1),IABS(K2)) 183 | R1M5 = D1MACH(5) 184 | C----------------------------------------------------------------------- 185 | C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT 186 | C----------------------------------------------------------------------- 187 | ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) 188 | EXR = DCOS(ZR) 189 | EXI = DSIN(ZR) 190 | EY = 0.0D0 191 | TAY = DABS(ZI+ZI) 192 | IF (TAY.LT.ELIM) EY = DEXP(-TAY) 193 | IF (ZI.LT.0.0D0) GO TO 90 194 | C1R = EXR*EY 195 | C1I = EXI*EY 196 | C2R = EXR 197 | C2I = -EXI 198 | 70 CONTINUE 199 | NZ = 0 200 | RTOL = 1.0D0/TOL 201 | ASCLE = D1MACH(1)*RTOL*1.0D+3 202 | DO 80 I=1,N 203 | C STR = C1R*CYR(I) - C1I*CYI(I) 204 | C STI = C1R*CYI(I) + C1I*CYR(I) 205 | C STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) 206 | C STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) 207 | C CYR(I) = -STI*HCII 208 | C CYI(I) = STR*HCII 209 | AA = CWRKR(I) 210 | BB = CWRKI(I) 211 | ATOL = 1.0D0 212 | IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 75 213 | AA = AA*RTOL 214 | BB = BB*RTOL 215 | ATOL = TOL 216 | 75 CONTINUE 217 | STR = (AA*C2R - BB*C2I)*ATOL 218 | STI = (AA*C2I + BB*C2R)*ATOL 219 | AA = CYR(I) 220 | BB = CYI(I) 221 | ATOL = 1.0D0 222 | IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 85 223 | AA = AA*RTOL 224 | BB = BB*RTOL 225 | ATOL = TOL 226 | 85 CONTINUE 227 | STR = STR - (AA*C1R - BB*C1I)*ATOL 228 | STI = STI - (AA*C1I + BB*C1R)*ATOL 229 | CYR(I) = -STI*HCII 230 | CYI(I) = STR*HCII 231 | IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ 232 | * + 1 233 | 80 CONTINUE 234 | RETURN 235 | 90 CONTINUE 236 | C1R = EXR 237 | C1I = EXI 238 | C2R = EXR*EY 239 | C2I = -EXI*EY 240 | GO TO 70 241 | 170 CONTINUE 242 | NZ = 0 243 | RETURN 244 | END 245 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zbinu.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, 2 | * TOL, ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZBINU 4 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY 5 | C 6 | C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE 7 | C 8 | C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK 9 | C***END PROLOGUE ZBINU 10 | DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, 11 | * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS 12 | INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ 13 | DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) 14 | DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / 15 | C 16 | NZ = 0 17 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 18 | NN = N 19 | DFNU = FNU + DBLE(FLOAT(N-1)) 20 | IF (AZ.LE.2.0D0) GO TO 10 21 | IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 22 | 10 CONTINUE 23 | C----------------------------------------------------------------------- 24 | C POWER SERIES 25 | C----------------------------------------------------------------------- 26 | CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) 27 | INW = IABS(NW) 28 | NZ = NZ + INW 29 | NN = NN - INW 30 | IF (NN.EQ.0) RETURN 31 | IF (NW.GE.0) GO TO 120 32 | DFNU = FNU + DBLE(FLOAT(NN-1)) 33 | 20 CONTINUE 34 | IF (AZ.LT.RL) GO TO 40 35 | IF (DFNU.LE.1.0D0) GO TO 30 36 | IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 37 | C----------------------------------------------------------------------- 38 | C ASYMPTOTIC EXPANSION FOR LARGE Z 39 | C----------------------------------------------------------------------- 40 | 30 CONTINUE 41 | CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, 42 | * ALIM) 43 | IF (NW.LT.0) GO TO 130 44 | GO TO 120 45 | 40 CONTINUE 46 | IF (DFNU.LE.1.0D0) GO TO 70 47 | 50 CONTINUE 48 | C----------------------------------------------------------------------- 49 | C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM 50 | C----------------------------------------------------------------------- 51 | CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, 52 | * ALIM) 53 | IF (NW.LT.0) GO TO 130 54 | NZ = NZ + NW 55 | NN = NN - NW 56 | IF (NN.EQ.0) RETURN 57 | DFNU = FNU+DBLE(FLOAT(NN-1)) 58 | IF (DFNU.GT.FNUL) GO TO 110 59 | IF (AZ.GT.FNUL) GO TO 110 60 | 60 CONTINUE 61 | IF (AZ.GT.RL) GO TO 80 62 | 70 CONTINUE 63 | C----------------------------------------------------------------------- 64 | C MILLER ALGORITHM NORMALIZED BY THE SERIES 65 | C----------------------------------------------------------------------- 66 | CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) 67 | IF(NW.LT.0) GO TO 130 68 | GO TO 120 69 | 80 CONTINUE 70 | C----------------------------------------------------------------------- 71 | C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN 72 | C----------------------------------------------------------------------- 73 | C----------------------------------------------------------------------- 74 | C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN 75 | C----------------------------------------------------------------------- 76 | CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, 77 | * ALIM) 78 | IF (NW.GE.0) GO TO 100 79 | NZ = NN 80 | DO 90 I=1,NN 81 | CYR(I) = ZEROR 82 | CYI(I) = ZEROI 83 | 90 CONTINUE 84 | RETURN 85 | 100 CONTINUE 86 | IF (NW.GT.0) GO TO 130 87 | CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, 88 | * ELIM, ALIM) 89 | IF (NW.LT.0) GO TO 130 90 | GO TO 120 91 | 110 CONTINUE 92 | C----------------------------------------------------------------------- 93 | C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD 94 | C----------------------------------------------------------------------- 95 | NUI = INT(SNGL(FNUL-DFNU)) + 1 96 | NUI = MAX0(NUI,0) 97 | CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, 98 | * TOL, ELIM, ALIM) 99 | IF (NW.LT.0) GO TO 130 100 | NZ = NZ + NW 101 | IF (NLAST.EQ.0) GO TO 120 102 | NN = NLAST 103 | GO TO 60 104 | 120 CONTINUE 105 | RETURN 106 | 130 CONTINUE 107 | NZ = -1 108 | IF(NW.EQ.(-2)) NZ=-2 109 | RETURN 110 | END 111 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zbuni.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, 2 | * FNUL, TOL, ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZBUNI 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. 7 | C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM 8 | C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING 9 | C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) 10 | C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 11 | C 12 | C***ROUTINES CALLED ZUNI1,ZUNI2,ZABS,D1MACH 13 | C***END PROLOGUE ZBUNI 14 | C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z 15 | DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, 16 | * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, 17 | * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, 18 | * D1MACH 19 | INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ 20 | DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) 21 | NZ = 0 22 | AX = DABS(ZR)*1.7321D0 23 | AY = DABS(ZI) 24 | IFORM = 1 25 | IF (AY.GT.AX) IFORM = 2 26 | IF (NUI.EQ.0) GO TO 60 27 | FNUI = DBLE(FLOAT(NUI)) 28 | DFNU = FNU + DBLE(FLOAT(N-1)) 29 | GNU = DFNU + FNUI 30 | IF (IFORM.EQ.2) GO TO 10 31 | C----------------------------------------------------------------------- 32 | C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN 33 | C -PI/3.LE.ARG(Z).LE.PI/3 34 | C----------------------------------------------------------------------- 35 | CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, 36 | * ELIM, ALIM) 37 | GO TO 20 38 | 10 CONTINUE 39 | C----------------------------------------------------------------------- 40 | C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU 41 | C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I 42 | C AND HPI=PI/2 43 | C----------------------------------------------------------------------- 44 | CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, 45 | * ELIM, ALIM) 46 | 20 CONTINUE 47 | IF (NW.LT.0) GO TO 50 48 | IF (NW.NE.0) GO TO 90 49 | STR = ZABS(CMPLX(CYR(1),CYI(1),kind=KIND(1.0D0))) 50 | C---------------------------------------------------------------------- 51 | C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED 52 | C---------------------------------------------------------------------- 53 | BRY(1)=1.0D+3*D1MACH(1)/TOL 54 | BRY(2) = 1.0D0/BRY(1) 55 | BRY(3) = BRY(2) 56 | IFLAG = 2 57 | ASCLE = BRY(2) 58 | CSCLR = 1.0D0 59 | IF (STR.GT.BRY(1)) GO TO 21 60 | IFLAG = 1 61 | ASCLE = BRY(1) 62 | CSCLR = 1.0D0/TOL 63 | GO TO 25 64 | 21 CONTINUE 65 | IF (STR.LT.BRY(2)) GO TO 25 66 | IFLAG = 3 67 | ASCLE=BRY(3) 68 | CSCLR = TOL 69 | 25 CONTINUE 70 | CSCRR = 1.0D0/CSCLR 71 | S1R = CYR(2)*CSCLR 72 | S1I = CYI(2)*CSCLR 73 | S2R = CYR(1)*CSCLR 74 | S2I = CYI(1)*CSCLR 75 | RAZ = 1.0D0/ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 76 | STR = ZR*RAZ 77 | STI = -ZI*RAZ 78 | RZR = (STR+STR)*RAZ 79 | RZI = (STI+STI)*RAZ 80 | DO 30 I=1,NUI 81 | STR = S2R 82 | STI = S2I 83 | S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R 84 | S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I 85 | S1R = STR 86 | S1I = STI 87 | FNUI = FNUI - 1.0D0 88 | IF (IFLAG.GE.3) GO TO 30 89 | STR = S2R*CSCRR 90 | STI = S2I*CSCRR 91 | C1R = DABS(STR) 92 | C1I = DABS(STI) 93 | C1M = DMAX1(C1R,C1I) 94 | IF (C1M.LE.ASCLE) GO TO 30 95 | IFLAG = IFLAG+1 96 | ASCLE = BRY(IFLAG) 97 | S1R = S1R*CSCRR 98 | S1I = S1I*CSCRR 99 | S2R = STR 100 | S2I = STI 101 | CSCLR = CSCLR*TOL 102 | CSCRR = 1.0D0/CSCLR 103 | S1R = S1R*CSCLR 104 | S1I = S1I*CSCLR 105 | S2R = S2R*CSCLR 106 | S2I = S2I*CSCLR 107 | 30 CONTINUE 108 | YR(N) = S2R*CSCRR 109 | YI(N) = S2I*CSCRR 110 | IF (N.EQ.1) RETURN 111 | NL = N - 1 112 | FNUI = DBLE(FLOAT(NL)) 113 | K = NL 114 | DO 40 I=1,NL 115 | STR = S2R 116 | STI = S2I 117 | S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R 118 | S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I 119 | S1R = STR 120 | S1I = STI 121 | STR = S2R*CSCRR 122 | STI = S2I*CSCRR 123 | YR(K) = STR 124 | YI(K) = STI 125 | FNUI = FNUI - 1.0D0 126 | K = K - 1 127 | IF (IFLAG.GE.3) GO TO 40 128 | C1R = DABS(STR) 129 | C1I = DABS(STI) 130 | C1M = DMAX1(C1R,C1I) 131 | IF (C1M.LE.ASCLE) GO TO 40 132 | IFLAG = IFLAG+1 133 | ASCLE = BRY(IFLAG) 134 | S1R = S1R*CSCRR 135 | S1I = S1I*CSCRR 136 | S2R = STR 137 | S2I = STI 138 | CSCLR = CSCLR*TOL 139 | CSCRR = 1.0D0/CSCLR 140 | S1R = S1R*CSCLR 141 | S1I = S1I*CSCLR 142 | S2R = S2R*CSCLR 143 | S2I = S2I*CSCLR 144 | 40 CONTINUE 145 | RETURN 146 | 50 CONTINUE 147 | NZ = -1 148 | IF(NW.EQ.(-2)) NZ=-2 149 | RETURN 150 | 60 CONTINUE 151 | IF (IFORM.EQ.2) GO TO 70 152 | C----------------------------------------------------------------------- 153 | C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN 154 | C -PI/3.LE.ARG(Z).LE.PI/3 155 | C----------------------------------------------------------------------- 156 | CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, 157 | * ELIM, ALIM) 158 | GO TO 80 159 | 70 CONTINUE 160 | C----------------------------------------------------------------------- 161 | C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU 162 | C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I 163 | C AND HPI=PI/2 164 | C----------------------------------------------------------------------- 165 | CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, 166 | * ELIM, ALIM) 167 | 80 CONTINUE 168 | IF (NW.LT.0) GO TO 50 169 | NZ = NW 170 | RETURN 171 | 90 CONTINUE 172 | NLAST = N 173 | RETURN 174 | END 175 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zbunk.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, 2 | * ALIM) 3 | C***BEGIN PROLOGUE ZBUNK 4 | C***REFER TO ZBESK,ZBESH 5 | C 6 | C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. 7 | C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) 8 | C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 9 | C 10 | C***ROUTINES CALLED ZUNK1,ZUNK2 11 | C***END PROLOGUE ZBUNK 12 | C COMPLEX Y,Z 13 | DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR 14 | INTEGER KODE, MR, N, NZ 15 | DIMENSION YR(N), YI(N) 16 | NZ = 0 17 | AX = DABS(ZR)*1.7321D0 18 | AY = DABS(ZI) 19 | IF (AY.GT.AX) GO TO 10 20 | C----------------------------------------------------------------------- 21 | C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN 22 | C -PI/3.LE.ARG(Z).LE.PI/3 23 | C----------------------------------------------------------------------- 24 | CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) 25 | GO TO 20 26 | 10 CONTINUE 27 | C----------------------------------------------------------------------- 28 | C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU 29 | C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I 30 | C AND HPI=PI/2 31 | C----------------------------------------------------------------------- 32 | CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) 33 | 20 CONTINUE 34 | RETURN 35 | END 36 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zdiv.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI) 2 | C***BEGIN PROLOGUE ZDIV 3 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY 4 | C 5 | C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. 6 | C 7 | C***ROUTINES CALLED ZABS 8 | C***END PROLOGUE ZDIV 9 | DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD 10 | DOUBLE PRECISION ZABS 11 | BM = 1.0D0/ZABS(CMPLX(BR,BI,kind=KIND(1.0D0))) 12 | CC = BR*BM 13 | CD = BI*BM 14 | CA = (AR*CC+AI*CD)*BM 15 | CB = (AI*CC-AR*CD)*BM 16 | CR = CA 17 | CI = CB 18 | RETURN 19 | END 20 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zexp.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZEXP(AR, AI, BR, BI) 2 | C***BEGIN PROLOGUE ZEXP 3 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY 4 | C 5 | C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) 6 | C 7 | C***ROUTINES CALLED (NONE) 8 | C***END PROLOGUE ZEXP 9 | DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB 10 | ZM = DEXP(AR) 11 | CA = ZM*DCOS(AI) 12 | CB = ZM*DSIN(AI) 13 | BR = CA 14 | BI = CB 15 | RETURN 16 | END 17 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zkscl.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) 2 | C***BEGIN PROLOGUE ZKSCL 3 | C***REFER TO ZBESK 4 | C 5 | C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE 6 | C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN 7 | C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. 8 | C 9 | C***ROUTINES CALLED ZUCHK,ZABS,ZLOG 10 | C***END PROLOGUE ZKSCL 11 | C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM 12 | DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, 13 | * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, 14 | * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, 15 | * ZDR, ZDI, CELMR, ELM, HELIM, ALAS 16 | INTEGER I, IC, IDUM, KK, N, NN, NW, NZ 17 | DIMENSION YR(N), YI(N), CYR(2), CYI(2) 18 | DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / 19 | C 20 | NZ = 0 21 | IC = 0 22 | NN = MIN0(2,N) 23 | DO 10 I=1,NN 24 | S1R = YR(I) 25 | S1I = YI(I) 26 | CYR(I) = S1R 27 | CYI(I) = S1I 28 | AS = ZABS(CMPLX(S1R,S1I,kind=KIND(1.0D0))) 29 | ACS = -ZRR + DLOG(AS) 30 | NZ = NZ + 1 31 | YR(I) = ZEROR 32 | YI(I) = ZEROI 33 | IF (ACS.LT.(-ELIM)) GO TO 10 34 | CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) 35 | CSR = CSR - ZRR 36 | CSI = CSI - ZRI 37 | STR = DEXP(CSR)/TOL 38 | CSR = STR*DCOS(CSI) 39 | CSI = STR*DSIN(CSI) 40 | CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) 41 | IF (NW.NE.0) GO TO 10 42 | YR(I) = CSR 43 | YI(I) = CSI 44 | IC = I 45 | NZ = NZ - 1 46 | 10 CONTINUE 47 | IF (N.EQ.1) RETURN 48 | IF (IC.GT.1) GO TO 20 49 | YR(1) = ZEROR 50 | YI(1) = ZEROI 51 | NZ = 2 52 | 20 CONTINUE 53 | IF (N.EQ.2) RETURN 54 | IF (NZ.EQ.0) RETURN 55 | FN = FNU + 1.0D0 56 | CKR = FN*RZR 57 | CKI = FN*RZI 58 | S1R = CYR(1) 59 | S1I = CYI(1) 60 | S2R = CYR(2) 61 | S2I = CYI(2) 62 | HELIM = 0.5D0*ELIM 63 | ELM = DEXP(-ELIM) 64 | CELMR = ELM 65 | ZDR = ZRR 66 | ZDI = ZRI 67 | C 68 | C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF 69 | C S2 GETS LARGER THAN EXP(ELIM/2) 70 | C 71 | DO 30 I=3,N 72 | KK = I 73 | CSR = S2R 74 | CSI = S2I 75 | S2R = CKR*CSR - CKI*CSI + S1R 76 | S2I = CKI*CSR + CKR*CSI + S1I 77 | S1R = CSR 78 | S1I = CSI 79 | CKR = CKR + RZR 80 | CKI = CKI + RZI 81 | AS = ZABS(CMPLX(S2R,S2I,kind=KIND(1.0D0))) 82 | ALAS = DLOG(AS) 83 | ACS = -ZDR + ALAS 84 | NZ = NZ + 1 85 | YR(I) = ZEROR 86 | YI(I) = ZEROI 87 | IF (ACS.LT.(-ELIM)) GO TO 25 88 | CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) 89 | CSR = CSR - ZDR 90 | CSI = CSI - ZDI 91 | STR = DEXP(CSR)/TOL 92 | CSR = STR*DCOS(CSI) 93 | CSI = STR*DSIN(CSI) 94 | CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) 95 | IF (NW.NE.0) GO TO 25 96 | YR(I) = CSR 97 | YI(I) = CSI 98 | NZ = NZ - 1 99 | IF (IC.EQ.KK-1) GO TO 40 100 | IC = KK 101 | GO TO 30 102 | 25 CONTINUE 103 | IF(ALAS.LT.HELIM) GO TO 30 104 | ZDR = ZDR - ELIM 105 | S1R = S1R*CELMR 106 | S1I = S1I*CELMR 107 | S2R = S2R*CELMR 108 | S2I = S2I*CELMR 109 | 30 CONTINUE 110 | NZ = N 111 | IF(IC.EQ.N) NZ=N-1 112 | GO TO 45 113 | 40 CONTINUE 114 | NZ = KK - 2 115 | 45 CONTINUE 116 | DO 50 I=1,NZ 117 | YR(I) = ZEROR 118 | YI(I) = ZEROI 119 | 50 CONTINUE 120 | RETURN 121 | END 122 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zlog.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZLOG(AR, AI, BR, BI, IERR) 2 | C***BEGIN PROLOGUE ZLOG 3 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY 4 | C 5 | C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) 6 | C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) 7 | C***ROUTINES CALLED ZABS 8 | C***END PROLOGUE ZLOG 9 | DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI 10 | DOUBLE PRECISION ZABS 11 | DATA DPI , DHPI / 3.141592653589793238462643383D+0, 12 | 1 1.570796326794896619231321696D+0/ 13 | C 14 | IERR=0 15 | IF (AR.EQ.0.0D+0) GO TO 10 16 | IF (AI.EQ.0.0D+0) GO TO 20 17 | DTHETA = DATAN(AI/AR) 18 | IF (DTHETA.LE.0.0D+0) GO TO 40 19 | IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI 20 | GO TO 50 21 | 10 IF (AI.EQ.0.0D+0) GO TO 60 22 | BI = DHPI 23 | BR = DLOG(DABS(AI)) 24 | IF (AI.LT.0.0D+0) BI = -BI 25 | RETURN 26 | 20 IF (AR.GT.0.0D+0) GO TO 30 27 | BR = DLOG(DABS(AR)) 28 | BI = DPI 29 | RETURN 30 | 30 BR = DLOG(AR) 31 | BI = 0.0D+0 32 | RETURN 33 | 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI 34 | 50 ZM = ZABS(CMPLX(AR,AI,kind=KIND(1.0D0))) 35 | BR = DLOG(ZM) 36 | BI = DTHETA 37 | RETURN 38 | 60 CONTINUE 39 | IERR=1 40 | RETURN 41 | END 42 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zmlri.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) 2 | C***BEGIN PROLOGUE ZMLRI 3 | C***REFER TO ZBESI,ZBESK 4 | C 5 | C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE 6 | C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. 7 | C 8 | C***ROUTINES CALLED DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT 9 | C***END PROLOGUE ZMLRI 10 | C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z 11 | DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, 12 | * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, 13 | * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, 14 | * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, 15 | * D1MACH, ZABS 16 | INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ 17 | DIMENSION YR(N), YI(N) 18 | DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / 19 | SCLE = D1MACH(1)/TOL 20 | NZ=0 21 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 22 | IAZ = INT(SNGL(AZ)) 23 | IFNU = INT(SNGL(FNU)) 24 | INU = IFNU + N - 1 25 | AT = DBLE(FLOAT(IAZ)) + 1.0D0 26 | RAZ = 1.0D0/AZ 27 | STR = ZR*RAZ 28 | STI = -ZI*RAZ 29 | CKR = STR*AT*RAZ 30 | CKI = STI*AT*RAZ 31 | RZR = (STR+STR)*RAZ 32 | RZI = (STI+STI)*RAZ 33 | P1R = ZEROR 34 | P1I = ZEROI 35 | P2R = CONER 36 | P2I = CONEI 37 | ACK = (AT+1.0D0)*RAZ 38 | RHO = ACK + DSQRT(ACK*ACK-1.0D0) 39 | RHO2 = RHO*RHO 40 | TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) 41 | TST = TST/TOL 42 | C----------------------------------------------------------------------- 43 | C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES 44 | C----------------------------------------------------------------------- 45 | AK = AT 46 | DO 10 I=1,80 47 | PTR = P2R 48 | PTI = P2I 49 | P2R = P1R - (CKR*PTR-CKI*PTI) 50 | P2I = P1I - (CKI*PTR+CKR*PTI) 51 | P1R = PTR 52 | P1I = PTI 53 | CKR = CKR + RZR 54 | CKI = CKI + RZI 55 | AP = ZABS(CMPLX(P2R,P2I,kind=KIND(1.0D0))) 56 | IF (AP.GT.TST*AK*AK) THEN 57 | GO TO 20 58 | END IF 59 | AK = AK + 1.0D0 60 | 10 CONTINUE 61 | GO TO 110 62 | 20 CONTINUE 63 | I = I + 1 64 | K = 0 65 | IF (INU.LT.IAZ) GO TO 40 66 | C----------------------------------------------------------------------- 67 | C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS 68 | C----------------------------------------------------------------------- 69 | P1R = ZEROR 70 | P1I = ZEROI 71 | P2R = CONER 72 | P2I = CONEI 73 | AT = DBLE(FLOAT(INU)) + 1.0D0 74 | STR = ZR*RAZ 75 | STI = -ZI*RAZ 76 | CKR = STR*AT*RAZ 77 | CKI = STI*AT*RAZ 78 | ACK = AT*RAZ 79 | TST = DSQRT(ACK/TOL) 80 | ITIME = 1 81 | DO 30 K=1,80 82 | PTR = P2R 83 | PTI = P2I 84 | P2R = P1R - (CKR*PTR-CKI*PTI) 85 | P2I = P1I - (CKR*PTI+CKI*PTR) 86 | P1R = PTR 87 | P1I = PTI 88 | CKR = CKR + RZR 89 | CKI = CKI + RZI 90 | AP = ZABS(CMPLX(P2R,P2I,kind=KIND(1.0D0))) 91 | IF (AP.LT.TST) GO TO 30 92 | IF (ITIME.EQ.2) GO TO 40 93 | ACK = ZABS(CMPLX(CKR,CKI,kind=KIND(1.0D0))) 94 | FLAM = ACK + DSQRT(ACK*ACK-1.0D0) 95 | FKAP = AP/ZABS(CMPLX(P1R,P1I,kind=KIND(1.0D0))) 96 | RHO = DMIN1(FLAM,FKAP) 97 | TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0)) 98 | ITIME = 2 99 | 30 CONTINUE 100 | GO TO 110 101 | 40 CONTINUE 102 | C----------------------------------------------------------------------- 103 | C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION 104 | C----------------------------------------------------------------------- 105 | K = K + 1 106 | KK = MAX0(I+IAZ,K+INU) 107 | FKK = DBLE(FLOAT(KK)) 108 | P1R = ZEROR 109 | P1I = ZEROI 110 | C----------------------------------------------------------------------- 111 | C SCALE P2 AND SUM BY SCLE 112 | C----------------------------------------------------------------------- 113 | P2R = SCLE 114 | P2I = ZEROI 115 | FNF = FNU - DBLE(FLOAT(IFNU)) 116 | TFNF = FNF + FNF 117 | BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - 118 | * DGAMLN(TFNF+1.0D0,IDUM) 119 | BK = DEXP(BK) 120 | SUMR = ZEROR 121 | SUMI = ZEROI 122 | KM = KK - INU 123 | DO 50 I=1,KM 124 | PTR = P2R 125 | PTI = P2I 126 | P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) 127 | P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) 128 | P1R = PTR 129 | P1I = PTI 130 | AK = 1.0D0 - TFNF/(FKK+TFNF) 131 | ACK = BK*AK 132 | SUMR = SUMR + (ACK+BK)*P1R 133 | SUMI = SUMI + (ACK+BK)*P1I 134 | BK = ACK 135 | FKK = FKK - 1.0D0 136 | 50 CONTINUE 137 | YR(N) = P2R 138 | YI(N) = P2I 139 | IF (N.EQ.1) GO TO 70 140 | DO 60 I=2,N 141 | PTR = P2R 142 | PTI = P2I 143 | P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) 144 | P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) 145 | P1R = PTR 146 | P1I = PTI 147 | AK = 1.0D0 - TFNF/(FKK+TFNF) 148 | ACK = BK*AK 149 | SUMR = SUMR + (ACK+BK)*P1R 150 | SUMI = SUMI + (ACK+BK)*P1I 151 | BK = ACK 152 | FKK = FKK - 1.0D0 153 | M = N - I + 1 154 | YR(M) = P2R 155 | YI(M) = P2I 156 | 60 CONTINUE 157 | 70 CONTINUE 158 | IF (IFNU.LE.0) GO TO 90 159 | DO 80 I=1,IFNU 160 | PTR = P2R 161 | PTI = P2I 162 | P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) 163 | P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) 164 | P1R = PTR 165 | P1I = PTI 166 | AK = 1.0D0 - TFNF/(FKK+TFNF) 167 | ACK = BK*AK 168 | SUMR = SUMR + (ACK+BK)*P1R 169 | SUMI = SUMI + (ACK+BK)*P1I 170 | BK = ACK 171 | FKK = FKK - 1.0D0 172 | 80 CONTINUE 173 | 90 CONTINUE 174 | PTR = ZR 175 | PTI = ZI 176 | IF (KODE.EQ.2) PTR = ZEROR 177 | CALL ZLOG(RZR, RZI, STR, STI, IDUM) 178 | P1R = -FNF*STR + PTR 179 | P1I = -FNF*STI + PTI 180 | AP = DGAMLN(1.0D0+FNF,IDUM) 181 | PTR = P1R - AP 182 | PTI = P1I 183 | C----------------------------------------------------------------------- 184 | C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW 185 | C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES 186 | C----------------------------------------------------------------------- 187 | P2R = P2R + SUMR 188 | P2I = P2I + SUMI 189 | AP = ZABS(CMPLX(P2R,P2I,kind=KIND(1.0D0))) 190 | P1R = 1.0D0/AP 191 | CALL ZEXP(PTR, PTI, STR, STI) 192 | CKR = STR*P1R 193 | CKI = STI*P1R 194 | PTR = P2R*P1R 195 | PTI = -P2I*P1R 196 | CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) 197 | DO 100 I=1,N 198 | STR = YR(I)*CNORMR - YI(I)*CNORMI 199 | YI(I) = YR(I)*CNORMI + YI(I)*CNORMR 200 | YR(I) = STR 201 | 100 CONTINUE 202 | RETURN 203 | 110 CONTINUE 204 | NZ=-2 205 | RETURN 206 | END 207 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zmlt.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI) 2 | C***BEGIN PROLOGUE ZMLT 3 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY 4 | C 5 | C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. 6 | C 7 | C***ROUTINES CALLED (NONE) 8 | C***END PROLOGUE ZMLT 9 | DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB 10 | CA = AR*BR - AI*BI 11 | CB = AR*BI + AI*BR 12 | CR = CA 13 | CI = CB 14 | RETURN 15 | END 16 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zrati.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL) 2 | C***BEGIN PROLOGUE ZRATI 3 | C***REFER TO ZBESI,ZBESK,ZBESH 4 | C 5 | C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD 6 | C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD 7 | C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, 8 | C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, 9 | C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, 10 | C BY D. J. SOOKNE. 11 | C 12 | C***ROUTINES CALLED ZABS,ZDIV 13 | C***END PROLOGUE ZRATI 14 | C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU 15 | DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, 16 | * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, 17 | * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, 18 | * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS 19 | INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N 20 | DIMENSION CYR(N), CYI(N) 21 | DATA CZEROR,CZEROI,CONER,CONEI,RT2/ 22 | 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / 23 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 24 | INU = INT(SNGL(FNU)) 25 | IDNU = INU + N - 1 26 | MAGZ = INT(SNGL(AZ)) 27 | AMAGZ = DBLE(FLOAT(MAGZ+1)) 28 | FDNU = DBLE(FLOAT(IDNU)) 29 | FNUP = DMAX1(AMAGZ,FDNU) 30 | ID = IDNU - MAGZ - 1 31 | ITIME = 1 32 | K = 1 33 | PTR = 1.0D0/AZ 34 | RZR = PTR*(ZR+ZR)*PTR 35 | RZI = -PTR*(ZI+ZI)*PTR 36 | T1R = RZR*FNUP 37 | T1I = RZI*FNUP 38 | P2R = -T1R 39 | P2I = -T1I 40 | P1R = CONER 41 | P1I = CONEI 42 | T1R = T1R + RZR 43 | T1I = T1I + RZI 44 | IF (ID.GT.0) ID = 0 45 | AP2 = ZABS(CMPLX(P2R,P2I,kind=KIND(1.0D0))) 46 | AP1 = ZABS(CMPLX(P1R,P1I,kind=KIND(1.0D0))) 47 | C----------------------------------------------------------------------- 48 | C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU 49 | C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT 50 | C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR 51 | C PREMATURELY. 52 | C----------------------------------------------------------------------- 53 | ARG = (AP2+AP2)/(AP1*TOL) 54 | TEST1 = DSQRT(ARG) 55 | TEST = TEST1 56 | RAP1 = 1.0D0/AP1 57 | P1R = P1R*RAP1 58 | P1I = P1I*RAP1 59 | P2R = P2R*RAP1 60 | P2I = P2I*RAP1 61 | AP2 = AP2*RAP1 62 | 10 CONTINUE 63 | K = K + 1 64 | AP1 = AP2 65 | PTR = P2R 66 | PTI = P2I 67 | P2R = P1R - (T1R*PTR-T1I*PTI) 68 | P2I = P1I - (T1R*PTI+T1I*PTR) 69 | P1R = PTR 70 | P1I = PTI 71 | T1R = T1R + RZR 72 | T1I = T1I + RZI 73 | AP2 = ZABS(CMPLX(P2R,P2I,kind=KIND(1.0D0))) 74 | IF (AP1.LE.TEST) GO TO 10 75 | IF (ITIME.EQ.2) GO TO 20 76 | AK = ZABS(CMPLX(T1R,T1I,kind=KIND(1.0D0))*0.5D0) 77 | FLAM = AK + DSQRT(AK*AK-1.0D0) 78 | RHO = DMIN1(AP2/AP1,FLAM) 79 | TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0)) 80 | ITIME = 2 81 | GO TO 10 82 | 20 CONTINUE 83 | KK = K + 1 - ID 84 | AK = DBLE(FLOAT(KK)) 85 | T1R = AK 86 | T1I = CZEROI 87 | DFNU = FNU + DBLE(FLOAT(N-1)) 88 | P1R = 1.0D0/AP2 89 | P1I = CZEROI 90 | P2R = CZEROR 91 | P2I = CZEROI 92 | DO 30 I=1,KK 93 | PTR = P1R 94 | PTI = P1I 95 | RAP1 = DFNU + T1R 96 | TTR = RZR*RAP1 97 | TTI = RZI*RAP1 98 | P1R = (PTR*TTR-PTI*TTI) + P2R 99 | P1I = (PTR*TTI+PTI*TTR) + P2I 100 | P2R = PTR 101 | P2I = PTI 102 | T1R = T1R - CONER 103 | 30 CONTINUE 104 | IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 105 | P1R = TOL 106 | P1I = TOL 107 | 40 CONTINUE 108 | CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) 109 | IF (N.EQ.1) RETURN 110 | K = N - 1 111 | AK = DBLE(FLOAT(K)) 112 | T1R = AK 113 | T1I = CZEROI 114 | CDFNUR = FNU*RZR 115 | CDFNUI = FNU*RZI 116 | DO 60 I=2,N 117 | PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) 118 | PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) 119 | AK = ZABS(CMPLX(PTR,PTI,kind=KIND(1.0D0))) 120 | IF (AK.NE.CZEROR) GO TO 50 121 | PTR = TOL 122 | PTI = TOL 123 | AK = TOL*RT2 124 | 50 CONTINUE 125 | RAK = CONER/AK 126 | CYR(K) = RAK*PTR*RAK 127 | CYI(K) = -RAK*PTI*RAK 128 | T1R = T1R - CONER 129 | K = K - 1 130 | 60 CONTINUE 131 | RETURN 132 | END 133 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zs1s2.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, 2 | * IUF) 3 | C***BEGIN PROLOGUE ZS1S2 4 | C***REFER TO ZBESK,ZAIRY 5 | C 6 | C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE 7 | C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- 8 | C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. 9 | C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF 10 | C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER 11 | C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE 12 | C PRECISION ABOVE THE UNDERFLOW LIMIT. 13 | C 14 | C***ROUTINES CALLED ZABS,ZEXP,ZLOG 15 | C***END PROLOGUE ZS1S2 16 | C COMPLEX CZERO,C1,S1,S1D,S2,ZR 17 | DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, 18 | * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS 19 | INTEGER IUF, IDUM, NZ 20 | DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / 21 | NZ = 0 22 | AS1 = ZABS(CMPLX(S1R,S1I,kind=KIND(1.0D0))) 23 | AS2 = ZABS(CMPLX(S2R,S2I,kind=KIND(1.0D0))) 24 | IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 25 | IF (AS1.EQ.0.0D0) GO TO 10 26 | ALN = -ZRR - ZRR + DLOG(AS1) 27 | S1DR = S1R 28 | S1DI = S1I 29 | S1R = ZEROR 30 | S1I = ZEROI 31 | AS1 = ZEROR 32 | IF (ALN.LT.(-ALIM)) GO TO 10 33 | CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) 34 | C1R = C1R - ZRR - ZRR 35 | C1I = C1I - ZRI - ZRI 36 | CALL ZEXP(C1R, C1I, S1R, S1I) 37 | AS1 = ZABS(CMPLX(S1R,S1I,kind=KIND(1.0D0))) 38 | IUF = IUF + 1 39 | 10 CONTINUE 40 | AA = DMAX1(AS1,AS2) 41 | IF (AA.GT.ASCLE) THEN 42 | RETURN 43 | END IF 44 | S1R = ZEROR 45 | S1I = ZEROI 46 | S2R = ZEROR 47 | S2I = ZEROI 48 | NZ = 1 49 | IUF = 0 50 | RETURN 51 | END 52 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zseri.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, 2 | * ALIM) 3 | C***BEGIN PROLOGUE ZSERI 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY 7 | C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE 8 | C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. 9 | C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO 10 | C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE 11 | C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE 12 | C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). 13 | C 14 | C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT 15 | C***END PROLOGUE ZSERI 16 | C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z 17 | DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, 18 | * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, 19 | * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, 20 | * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, 21 | * ZR, DGAMLN, D1MACH, ZABS 22 | INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW 23 | DIMENSION YR(N), YI(N), WR(2), WI(2) 24 | DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / 25 | C 26 | 27 | NZ = 0 28 | AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 29 | IF (AZ.EQ.0.0D0) GO TO 160 30 | ARM = 1.0D+3*D1MACH(1) 31 | RTR1 = DSQRT(ARM) 32 | CRSCR = 1.0D0 33 | IFLAG = 0 34 | IF (AZ.LT.ARM) THEN 35 | GO TO 150 36 | END IF 37 | HZR = 0.5D0*ZR 38 | HZI = 0.5D0*ZI 39 | CZR = ZEROR 40 | CZI = ZEROI 41 | IF (AZ.LE.RTR1) GO TO 10 42 | CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) 43 | 10 CONTINUE 44 | ACZ = ZABS(CMPLX(CZR,CZI,kind=KIND(1.0D0))) 45 | NN = N 46 | CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) 47 | 20 CONTINUE 48 | DFNU = FNU + DBLE(FLOAT(NN-1)) 49 | FNUP = DFNU + 1.0D0 50 | C----------------------------------------------------------------------- 51 | C UNDERFLOW TEST 52 | C----------------------------------------------------------------------- 53 | AK1R = CKR*DFNU 54 | AK1I = CKI*DFNU 55 | AK = DGAMLN(FNUP,IDUM) 56 | AK1R = AK1R - AK 57 | IF (KODE.EQ.2) AK1R = AK1R - ZR 58 | IF (AK1R.GT.(-ELIM)) GO TO 40 59 | 30 CONTINUE 60 | NZ = NZ + 1 61 | YR(NN) = ZEROR 62 | YI(NN) = ZEROI 63 | IF (ACZ.GT.DFNU) GO TO 190 64 | NN = NN - 1 65 | IF (NN.EQ.0) RETURN 66 | GO TO 20 67 | 40 CONTINUE 68 | IF (AK1R.GT.(-ALIM)) GO TO 50 69 | IFLAG = 1 70 | SS = 1.0D0/TOL 71 | CRSCR = TOL 72 | ASCLE = ARM*SS 73 | 50 CONTINUE 74 | AA = DEXP(AK1R) 75 | IF (IFLAG.EQ.1) AA = AA*SS 76 | COEFR = AA*DCOS(AK1I) 77 | COEFI = AA*DSIN(AK1I) 78 | ATOL = TOL*ACZ/FNUP 79 | IL = MIN0(2,NN) 80 | DO 90 I=1,IL 81 | DFNU = FNU + DBLE(FLOAT(NN-I)) 82 | FNUP = DFNU + 1.0D0 83 | S1R = CONER 84 | S1I = CONEI 85 | IF (ACZ.LT.TOL*FNUP) GO TO 70 86 | AK1R = CONER 87 | AK1I = CONEI 88 | AK = FNUP + 2.0D0 89 | S = FNUP 90 | AA = 2.0D0 91 | 60 CONTINUE 92 | RS = 1.0D0/S 93 | STR = AK1R*CZR - AK1I*CZI 94 | STI = AK1R*CZI + AK1I*CZR 95 | AK1R = STR*RS 96 | AK1I = STI*RS 97 | S1R = S1R + AK1R 98 | S1I = S1I + AK1I 99 | S = S + AK 100 | AK = AK + 2.0D0 101 | AA = AA*ACZ*RS 102 | IF (AA.GT.ATOL) GO TO 60 103 | 70 CONTINUE 104 | S2R = S1R*COEFR - S1I*COEFI 105 | S2I = S1R*COEFI + S1I*COEFR 106 | WR(I) = S2R 107 | WI(I) = S2I 108 | IF (IFLAG.EQ.0) GO TO 80 109 | CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) 110 | IF (NW.NE.0) GO TO 30 111 | 80 CONTINUE 112 | M = NN - I + 1 113 | YR(M) = S2R*CRSCR 114 | YI(M) = S2I*CRSCR 115 | IF (I.EQ.IL) GO TO 90 116 | CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) 117 | COEFR = STR*DFNU 118 | COEFI = STI*DFNU 119 | 90 CONTINUE 120 | IF (NN.LE.2) THEN 121 | RETURN 122 | END IF 123 | K = NN - 2 124 | AK = DBLE(FLOAT(K)) 125 | RAZ = 1.0D0/AZ 126 | STR = ZR*RAZ 127 | STI = -ZI*RAZ 128 | RZR = (STR+STR)*RAZ 129 | RZI = (STI+STI)*RAZ 130 | IF (IFLAG.EQ.1) GO TO 120 131 | IB = 3 132 | 100 CONTINUE 133 | DO 110 I=IB,NN 134 | YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) 135 | YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) 136 | AK = AK - 1.0D0 137 | K = K - 1 138 | 110 CONTINUE 139 | RETURN 140 | C----------------------------------------------------------------------- 141 | C RECUR BACKWARD WITH SCALED VALUES 142 | C----------------------------------------------------------------------- 143 | 120 CONTINUE 144 | C----------------------------------------------------------------------- 145 | C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE 146 | C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 147 | C----------------------------------------------------------------------- 148 | S1R = WR(1) 149 | S1I = WI(1) 150 | S2R = WR(2) 151 | S2I = WI(2) 152 | DO 130 L=3,NN 153 | CKR = S2R 154 | CKI = S2I 155 | S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) 156 | S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) 157 | S1R = CKR 158 | S1I = CKI 159 | CKR = S2R*CRSCR 160 | CKI = S2I*CRSCR 161 | YR(K) = CKR 162 | YI(K) = CKI 163 | AK = AK - 1.0D0 164 | K = K - 1 165 | IF (ZABS(CMPLX(CKR,CKI,kind=KIND(1.0D0))).GT.ASCLE) GO TO 140 166 | 130 CONTINUE 167 | RETURN 168 | 140 CONTINUE 169 | IB = L + 1 170 | IF (IB.GT.NN) RETURN 171 | GO TO 100 172 | 150 CONTINUE 173 | NZ = N 174 | IF (FNU.EQ.0.0D0) NZ = NZ - 1 175 | 160 CONTINUE 176 | YR(1) = ZEROR 177 | YI(1) = ZEROI 178 | IF (FNU.NE.0.0D0) GO TO 170 179 | YR(1) = CONER 180 | YI(1) = CONEI 181 | 170 CONTINUE 182 | IF (N.EQ.1) RETURN 183 | DO 180 I=2,N 184 | YR(I) = ZEROR 185 | YI(I) = ZEROI 186 | 180 CONTINUE 187 | RETURN 188 | C----------------------------------------------------------------------- 189 | C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE 190 | C THE CALCULATION IN CBINU WITH N=N-IABS(NZ) 191 | C----------------------------------------------------------------------- 192 | 190 CONTINUE 193 | NZ = -NZ 194 | RETURN 195 | END 196 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zshch.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI) 2 | C***BEGIN PROLOGUE ZSHCH 3 | C***REFER TO ZBESK,ZBESH 4 | C 5 | C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) 6 | C AND CCH=COSH(X+I*Y), WHERE I**2=-1. 7 | C 8 | C***ROUTINES CALLED (NONE) 9 | C***END PROLOGUE ZSHCH 10 | C 11 | DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, 12 | * DCOSH, DSINH 13 | SH = DSINH(ZR) 14 | CH = DCOSH(ZR) 15 | SN = DSIN(ZI) 16 | CN = DCOS(ZI) 17 | CSHR = SH*CN 18 | CSHI = CH*SN 19 | CCHR = CH*CN 20 | CCHI = SH*SN 21 | RETURN 22 | END 23 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zsqrt.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZSQRT(AR, AI, BR, BI) 2 | C***BEGIN PROLOGUE ZSQRT 3 | C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY 4 | C 5 | C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) 6 | C 7 | C***ROUTINES CALLED ZABS 8 | C***END PROLOGUE ZSQRT 9 | DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT 10 | DOUBLE PRECISION ZABS 11 | 12 | DATA DRT , DPI / 7.071067811865475244008443621D-1, 13 | 1 3.141592653589793238462643383D+0/ 14 | ZM = ZABS(CMPLX(AR,AI,kind=KIND(1.0D0))) 15 | ZM = DSQRT(ZM) 16 | IF (AR.EQ.0.0D+0) GO TO 10 17 | IF (AI.EQ.0.0D+0) GO TO 20 18 | DTHETA = DATAN(AI/AR) 19 | IF (DTHETA.LE.0.0D+0) GO TO 40 20 | IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI 21 | GO TO 50 22 | 10 IF (AI.GT.0.0D+0) GO TO 60 23 | IF (AI.LT.0.0D+0) GO TO 70 24 | BR = 0.0D+0 25 | BI = 0.0D+0 26 | RETURN 27 | 20 IF (AR.GT.0.0D+0) GO TO 30 28 | BR = 0.0D+0 29 | BI = DSQRT(DABS(AR)) 30 | RETURN 31 | 30 BR = DSQRT(AR) 32 | BI = 0.0D+0 33 | RETURN 34 | 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI 35 | 50 DTHETA = DTHETA*0.5D+0 36 | BR = ZM*DCOS(DTHETA) 37 | BI = ZM*DSIN(DTHETA) 38 | RETURN 39 | 60 BR = ZM*DRT 40 | BI = ZM*DRT 41 | RETURN 42 | 70 BR = ZM*DRT 43 | BI = -ZM*DRT 44 | RETURN 45 | END 46 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zuchk.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL) 2 | C***BEGIN PROLOGUE ZUCHK 3 | C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL 4 | C 5 | C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN 6 | C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE 7 | C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW 8 | C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED 9 | C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE 10 | C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE 11 | C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. 12 | C 13 | C***ROUTINES CALLED (NONE) 14 | C***END PROLOGUE ZUCHK 15 | C 16 | C COMPLEX Y 17 | DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI 18 | INTEGER NZ 19 | NZ = 0 20 | WR = DABS(YR) 21 | WI = DABS(YI) 22 | ST = DMIN1(WR,WI) 23 | IF (ST.GT.ASCLE) RETURN 24 | SS = DMAX1(WR,WI) 25 | ST = ST/TOL 26 | IF (SS.LT.ST) NZ = 1 27 | RETURN 28 | END 29 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zuni1.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, 2 | * TOL, ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZUNI1 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC 7 | C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. 8 | C 9 | C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC 10 | C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. 11 | C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER 12 | C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. 13 | C Y(I)=CZERO FOR I=NLAST+1,N 14 | C 15 | C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS 16 | C***END PROLOGUE ZUNI1 17 | C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, 18 | C *S2,Y,Z,ZETA1,ZETA2 19 | DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, 20 | * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, 21 | * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, 22 | * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, 23 | * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS 24 | INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ 25 | DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), 26 | * CSRR(3), CYR(2), CYI(2) 27 | DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / 28 | C 29 | NZ = 0 30 | ND = N 31 | NLAST = 0 32 | C----------------------------------------------------------------------- 33 | C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- 34 | C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, 35 | C EXP(ALIM)=EXP(ELIM)*TOL 36 | C----------------------------------------------------------------------- 37 | CSCL = 1.0D0/TOL 38 | CRSC = TOL 39 | CSSR(1) = CSCL 40 | CSSR(2) = CONER 41 | CSSR(3) = CRSC 42 | CSRR(1) = CRSC 43 | CSRR(2) = CONER 44 | CSRR(3) = CSCL 45 | BRY(1) = 1.0D+3*D1MACH(1)/TOL 46 | C----------------------------------------------------------------------- 47 | C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER 48 | C----------------------------------------------------------------------- 49 | FN = DMAX1(FNU,1.0D0) 50 | INIT = 0 51 | CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, 52 | * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) 53 | IF (KODE.EQ.1) GO TO 10 54 | STR = ZR + ZETA2R 55 | STI = ZI + ZETA2I 56 | RAST = FN/ZABS(CMPLX(STR,STI,kind=KIND(1.0D0))) 57 | STR = STR*RAST*RAST 58 | STI = -STI*RAST*RAST 59 | S1R = -ZETA1R + STR 60 | S1I = -ZETA1I + STI 61 | GO TO 20 62 | 10 CONTINUE 63 | S1R = -ZETA1R + ZETA2R 64 | S1I = -ZETA1I + ZETA2I 65 | 20 CONTINUE 66 | RS1 = S1R 67 | IF (DABS(RS1).GT.ELIM) GO TO 130 68 | 30 CONTINUE 69 | NN = MIN0(2,ND) 70 | DO 80 I=1,NN 71 | FN = FNU + DBLE(FLOAT(ND-I)) 72 | INIT = 0 73 | CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, 74 | * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) 75 | IF (KODE.EQ.1) GO TO 40 76 | STR = ZR + ZETA2R 77 | STI = ZI + ZETA2I 78 | RAST = FN/ZABS(CMPLX(STR,STI,kind=KIND(1.0D0))) 79 | STR = STR*RAST*RAST 80 | STI = -STI*RAST*RAST 81 | S1R = -ZETA1R + STR 82 | S1I = -ZETA1I + STI + ZI 83 | GO TO 50 84 | 40 CONTINUE 85 | S1R = -ZETA1R + ZETA2R 86 | S1I = -ZETA1I + ZETA2I 87 | 50 CONTINUE 88 | C----------------------------------------------------------------------- 89 | C TEST FOR UNDERFLOW AND OVERFLOW 90 | C----------------------------------------------------------------------- 91 | RS1 = S1R 92 | IF (DABS(RS1).GT.ELIM) GO TO 110 93 | IF (I.EQ.1) IFLAG = 2 94 | IF (DABS(RS1).LT.ALIM) GO TO 60 95 | C----------------------------------------------------------------------- 96 | C REFINE TEST AND SCALE 97 | C----------------------------------------------------------------------- 98 | APHI = ZABS(CMPLX(PHIR,PHII,kind=KIND(1.0D0))) 99 | RS1 = RS1 + DLOG(APHI) 100 | IF (DABS(RS1).GT.ELIM) GO TO 110 101 | IF (I.EQ.1) IFLAG = 1 102 | IF (RS1.LT.0.0D0) GO TO 60 103 | IF (I.EQ.1) IFLAG = 3 104 | 60 CONTINUE 105 | C----------------------------------------------------------------------- 106 | C SCALE S1 IF CABS(S1).LT.ASCLE 107 | C----------------------------------------------------------------------- 108 | S2R = PHIR*SUMR - PHII*SUMI 109 | S2I = PHIR*SUMI + PHII*SUMR 110 | STR = DEXP(S1R)*CSSR(IFLAG) 111 | S1R = STR*DCOS(S1I) 112 | S1I = STR*DSIN(S1I) 113 | STR = S2R*S1R - S2I*S1I 114 | S2I = S2R*S1I + S2I*S1R 115 | S2R = STR 116 | IF (IFLAG.NE.1) GO TO 70 117 | CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) 118 | IF (NW.NE.0) GO TO 110 119 | 70 CONTINUE 120 | CYR(I) = S2R 121 | CYI(I) = S2I 122 | M = ND - I + 1 123 | YR(M) = S2R*CSRR(IFLAG) 124 | YI(M) = S2I*CSRR(IFLAG) 125 | 80 CONTINUE 126 | IF (ND.LE.2) GO TO 100 127 | RAST = 1.0D0/ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 128 | STR = ZR*RAST 129 | STI = -ZI*RAST 130 | RZR = (STR+STR)*RAST 131 | RZI = (STI+STI)*RAST 132 | BRY(2) = 1.0D0/BRY(1) 133 | BRY(3) = D1MACH(2) 134 | S1R = CYR(1) 135 | S1I = CYI(1) 136 | S2R = CYR(2) 137 | S2I = CYI(2) 138 | C1R = CSRR(IFLAG) 139 | ASCLE = BRY(IFLAG) 140 | K = ND - 2 141 | FN = DBLE(FLOAT(K)) 142 | DO 90 I=3,ND 143 | C2R = S2R 144 | C2I = S2I 145 | S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) 146 | S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) 147 | S1R = C2R 148 | S1I = C2I 149 | C2R = S2R*C1R 150 | C2I = S2I*C1R 151 | YR(K) = C2R 152 | YI(K) = C2I 153 | K = K - 1 154 | FN = FN - 1.0D0 155 | IF (IFLAG.GE.3) GO TO 90 156 | STR = DABS(C2R) 157 | STI = DABS(C2I) 158 | C2M = DMAX1(STR,STI) 159 | IF (C2M.LE.ASCLE) GO TO 90 160 | IFLAG = IFLAG + 1 161 | ASCLE = BRY(IFLAG) 162 | S1R = S1R*C1R 163 | S1I = S1I*C1R 164 | S2R = C2R 165 | S2I = C2I 166 | S1R = S1R*CSSR(IFLAG) 167 | S1I = S1I*CSSR(IFLAG) 168 | S2R = S2R*CSSR(IFLAG) 169 | S2I = S2I*CSSR(IFLAG) 170 | C1R = CSRR(IFLAG) 171 | 90 CONTINUE 172 | 100 CONTINUE 173 | RETURN 174 | C----------------------------------------------------------------------- 175 | C SET UNDERFLOW AND UPDATE PARAMETERS 176 | C----------------------------------------------------------------------- 177 | 110 CONTINUE 178 | IF (RS1.GT.0.0D0) GO TO 120 179 | YR(ND) = ZEROR 180 | YI(ND) = ZEROI 181 | NZ = NZ + 1 182 | ND = ND - 1 183 | IF (ND.EQ.0) GO TO 100 184 | CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) 185 | IF (NUF.LT.0) GO TO 120 186 | ND = ND - NUF 187 | NZ = NZ + NUF 188 | IF (ND.EQ.0) GO TO 100 189 | FN = FNU + DBLE(FLOAT(ND-1)) 190 | IF (FN.GE.FNUL) GO TO 30 191 | NLAST = ND 192 | RETURN 193 | 120 CONTINUE 194 | NZ = -1 195 | RETURN 196 | 130 CONTINUE 197 | IF (RS1.GT.0.0D0) GO TO 120 198 | NZ = N 199 | DO 140 I=1,N 200 | YR(I) = ZEROR 201 | YI(I) = ZEROI 202 | 140 CONTINUE 203 | RETURN 204 | END 205 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zuni2.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, 2 | * TOL, ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZUNI2 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF 7 | C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I 8 | C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. 9 | C 10 | C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC 11 | C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. 12 | C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER 13 | C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. 14 | C Y(I)=CZERO FOR I=NLAST+1,N 15 | C 16 | C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS 17 | C***END PROLOGUE ZUNI2 18 | C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, 19 | C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN 20 | DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, 21 | * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, 22 | * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, 23 | * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, 24 | * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, 25 | * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, 26 | * CYI, D1MACH, ZABS, CAR, SAR 27 | INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, 28 | * NN, NUF, NW, NZ, IDUM 29 | DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), 30 | * CSRR(3), CYR(2), CYI(2) 31 | DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / 32 | DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), 33 | * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ 34 | DATA HPI, AIC / 35 | 1 1.57079632679489662D+00, 1.265512123484645396D+00/ 36 | C 37 | NZ = 0 38 | ND = N 39 | NLAST = 0 40 | C----------------------------------------------------------------------- 41 | C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- 42 | C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, 43 | C EXP(ALIM)=EXP(ELIM)*TOL 44 | C----------------------------------------------------------------------- 45 | CSCL = 1.0D0/TOL 46 | CRSC = TOL 47 | CSSR(1) = CSCL 48 | CSSR(2) = CONER 49 | CSSR(3) = CRSC 50 | CSRR(1) = CRSC 51 | CSRR(2) = CONER 52 | CSRR(3) = CSCL 53 | BRY(1) = 1.0D+3*D1MACH(1)/TOL 54 | C----------------------------------------------------------------------- 55 | C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI 56 | C----------------------------------------------------------------------- 57 | ZNR = ZI 58 | ZNI = -ZR 59 | ZBR = ZR 60 | ZBI = ZI 61 | CIDI = -CONER 62 | INU = INT(SNGL(FNU)) 63 | ANG = HPI*(FNU-DBLE(FLOAT(INU))) 64 | C2R = DCOS(ANG) 65 | C2I = DSIN(ANG) 66 | CAR = C2R 67 | SAR = C2I 68 | IN = INU + N - 1 69 | IN = MOD(IN,4) + 1 70 | STR = C2R*CIPR(IN) - C2I*CIPI(IN) 71 | C2I = C2R*CIPI(IN) + C2I*CIPR(IN) 72 | C2R = STR 73 | IF (ZI.GT.0.0D0) GO TO 10 74 | ZNR = -ZNR 75 | ZBI = -ZBI 76 | CIDI = -CIDI 77 | C2I = -C2I 78 | 10 CONTINUE 79 | C----------------------------------------------------------------------- 80 | C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER 81 | C----------------------------------------------------------------------- 82 | FN = DMAX1(FNU,1.0D0) 83 | CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, 84 | * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) 85 | IF (KODE.EQ.1) GO TO 20 86 | STR = ZBR + ZETA2R 87 | STI = ZBI + ZETA2I 88 | RAST = FN/ZABS(CMPLX(STR,STI,kind=KIND(1.0D0))) 89 | STR = STR*RAST*RAST 90 | STI = -STI*RAST*RAST 91 | S1R = -ZETA1R + STR 92 | S1I = -ZETA1I + STI 93 | GO TO 30 94 | 20 CONTINUE 95 | S1R = -ZETA1R + ZETA2R 96 | S1I = -ZETA1I + ZETA2I 97 | 30 CONTINUE 98 | RS1 = S1R 99 | IF (DABS(RS1).GT.ELIM) GO TO 150 100 | 40 CONTINUE 101 | NN = MIN0(2,ND) 102 | DO 90 I=1,NN 103 | FN = FNU + DBLE(FLOAT(ND-I)) 104 | CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, 105 | * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) 106 | IF (KODE.EQ.1) GO TO 50 107 | STR = ZBR + ZETA2R 108 | STI = ZBI + ZETA2I 109 | RAST = FN/ZABS(CMPLX(STR,STI,kind=KIND(1.0D0))) 110 | STR = STR*RAST*RAST 111 | STI = -STI*RAST*RAST 112 | S1R = -ZETA1R + STR 113 | S1I = -ZETA1I + STI + DABS(ZI) 114 | GO TO 60 115 | 50 CONTINUE 116 | S1R = -ZETA1R + ZETA2R 117 | S1I = -ZETA1I + ZETA2I 118 | 60 CONTINUE 119 | C----------------------------------------------------------------------- 120 | C TEST FOR UNDERFLOW AND OVERFLOW 121 | C----------------------------------------------------------------------- 122 | RS1 = S1R 123 | IF (DABS(RS1).GT.ELIM) GO TO 120 124 | IF (I.EQ.1) IFLAG = 2 125 | IF (DABS(RS1).LT.ALIM) GO TO 70 126 | C----------------------------------------------------------------------- 127 | C REFINE TEST AND SCALE 128 | C----------------------------------------------------------------------- 129 | C----------------------------------------------------------------------- 130 | APHI = ZABS(CMPLX(PHIR,PHII,kind=KIND(1.0D0))) 131 | AARG = ZABS(CMPLX(ARGR,ARGI,kind=KIND(1.0D0))) 132 | RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC 133 | IF (DABS(RS1).GT.ELIM) GO TO 120 134 | IF (I.EQ.1) IFLAG = 1 135 | IF (RS1.LT.0.0D0) GO TO 70 136 | IF (I.EQ.1) IFLAG = 3 137 | 70 CONTINUE 138 | C----------------------------------------------------------------------- 139 | C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR 140 | C EXPONENT EXTREMES 141 | C----------------------------------------------------------------------- 142 | CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) 143 | CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) 144 | STR = DAIR*BSUMR - DAII*BSUMI 145 | STI = DAIR*BSUMI + DAII*BSUMR 146 | STR = STR + (AIR*ASUMR-AII*ASUMI) 147 | STI = STI + (AIR*ASUMI+AII*ASUMR) 148 | S2R = PHIR*STR - PHII*STI 149 | S2I = PHIR*STI + PHII*STR 150 | STR = DEXP(S1R)*CSSR(IFLAG) 151 | S1R = STR*DCOS(S1I) 152 | S1I = STR*DSIN(S1I) 153 | STR = S2R*S1R - S2I*S1I 154 | S2I = S2R*S1I + S2I*S1R 155 | S2R = STR 156 | IF (IFLAG.NE.1) GO TO 80 157 | CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) 158 | IF (NW.NE.0) GO TO 120 159 | 80 CONTINUE 160 | IF (ZI.LE.0.0D0) S2I = -S2I 161 | STR = S2R*C2R - S2I*C2I 162 | S2I = S2R*C2I + S2I*C2R 163 | S2R = STR 164 | CYR(I) = S2R 165 | CYI(I) = S2I 166 | J = ND - I + 1 167 | YR(J) = S2R*CSRR(IFLAG) 168 | YI(J) = S2I*CSRR(IFLAG) 169 | STR = -C2I*CIDI 170 | C2I = C2R*CIDI 171 | C2R = STR 172 | 90 CONTINUE 173 | IF (ND.LE.2) GO TO 110 174 | RAZ = 1.0D0/ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0))) 175 | STR = ZR*RAZ 176 | STI = -ZI*RAZ 177 | RZR = (STR+STR)*RAZ 178 | RZI = (STI+STI)*RAZ 179 | BRY(2) = 1.0D0/BRY(1) 180 | BRY(3) = D1MACH(2) 181 | S1R = CYR(1) 182 | S1I = CYI(1) 183 | S2R = CYR(2) 184 | S2I = CYI(2) 185 | C1R = CSRR(IFLAG) 186 | ASCLE = BRY(IFLAG) 187 | K = ND - 2 188 | FN = DBLE(FLOAT(K)) 189 | DO 100 I=3,ND 190 | C2R = S2R 191 | C2I = S2I 192 | S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) 193 | S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) 194 | S1R = C2R 195 | S1I = C2I 196 | C2R = S2R*C1R 197 | C2I = S2I*C1R 198 | YR(K) = C2R 199 | YI(K) = C2I 200 | K = K - 1 201 | FN = FN - 1.0D0 202 | IF (IFLAG.GE.3) GO TO 100 203 | STR = DABS(C2R) 204 | STI = DABS(C2I) 205 | C2M = DMAX1(STR,STI) 206 | IF (C2M.LE.ASCLE) GO TO 100 207 | IFLAG = IFLAG + 1 208 | ASCLE = BRY(IFLAG) 209 | S1R = S1R*C1R 210 | S1I = S1I*C1R 211 | S2R = C2R 212 | S2I = C2I 213 | S1R = S1R*CSSR(IFLAG) 214 | S1I = S1I*CSSR(IFLAG) 215 | S2R = S2R*CSSR(IFLAG) 216 | S2I = S2I*CSSR(IFLAG) 217 | C1R = CSRR(IFLAG) 218 | 100 CONTINUE 219 | 110 CONTINUE 220 | RETURN 221 | 120 CONTINUE 222 | IF (RS1.GT.0.0D0) GO TO 140 223 | C----------------------------------------------------------------------- 224 | C SET UNDERFLOW AND UPDATE PARAMETERS 225 | C----------------------------------------------------------------------- 226 | YR(ND) = ZEROR 227 | YI(ND) = ZEROI 228 | NZ = NZ + 1 229 | ND = ND - 1 230 | IF (ND.EQ.0) GO TO 110 231 | CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) 232 | IF (NUF.LT.0) GO TO 140 233 | ND = ND - NUF 234 | NZ = NZ + NUF 235 | IF (ND.EQ.0) GO TO 110 236 | FN = FNU + DBLE(FLOAT(ND-1)) 237 | IF (FN.LT.FNUL) GO TO 130 238 | C FN = CIDI 239 | C J = NUF + 1 240 | C K = MOD(J,4) + 1 241 | C S1R = CIPR(K) 242 | C S1I = CIPI(K) 243 | C IF (FN.LT.0.0D0) S1I = -S1I 244 | C STR = C2R*S1R - C2I*S1I 245 | C C2I = C2R*S1I + C2I*S1R 246 | C C2R = STR 247 | IN = INU + ND - 1 248 | IN = MOD(IN,4) + 1 249 | C2R = CAR*CIPR(IN) - SAR*CIPI(IN) 250 | C2I = CAR*CIPI(IN) + SAR*CIPR(IN) 251 | IF (ZI.LE.0.0D0) C2I = -C2I 252 | GO TO 40 253 | 130 CONTINUE 254 | NLAST = ND 255 | RETURN 256 | 140 CONTINUE 257 | NZ = -1 258 | RETURN 259 | 150 CONTINUE 260 | IF (RS1.GT.0.0D0) GO TO 140 261 | NZ = N 262 | DO 160 I=1,N 263 | YR(I) = ZEROR 264 | YI(I) = ZEROI 265 | 160 CONTINUE 266 | RETURN 267 | END 268 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zunik.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, 2 | * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) 3 | C***BEGIN PROLOGUE ZUNIK 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC 7 | C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 8 | C RESPECTIVELY BY 9 | C 10 | C W(FNU,ZR) = PHI*EXP(ZETA)*SUM 11 | C 12 | C WHERE ZETA=-ZETA1 + ZETA2 OR 13 | C ZETA1 - ZETA2 14 | C 15 | C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE 16 | C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= 17 | C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK 18 | C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, 19 | C ZETA1,ZETA2. 20 | C 21 | C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH 22 | C***END PROLOGUE ZUNIK 23 | C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, 24 | C *ZETA2,ZN,ZR 25 | DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, 26 | * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, 27 | * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, 28 | * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH 29 | INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L 30 | DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) 31 | DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / 32 | DATA CON(1), CON(2) / 33 | 1 3.98942280401432678D-01, 1.25331413731550025D+00 / 34 | DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 35 | 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 36 | 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 37 | 3 1.00000000000000000D+00, -2.08333333333333333D-01, 38 | 4 1.25000000000000000D-01, 3.34201388888888889D-01, 39 | 5 -4.01041666666666667D-01, 7.03125000000000000D-02, 40 | 6 -1.02581259645061728D+00, 1.84646267361111111D+00, 41 | 7 -8.91210937500000000D-01, 7.32421875000000000D-02, 42 | 8 4.66958442342624743D+00, -1.12070026162229938D+01, 43 | 9 8.78912353515625000D+00, -2.36408691406250000D+00, 44 | A 1.12152099609375000D-01, -2.82120725582002449D+01, 45 | B 8.46362176746007346D+01, -9.18182415432400174D+01, 46 | C 4.25349987453884549D+01, -7.36879435947963170D+00, 47 | D 2.27108001708984375D-01, 2.12570130039217123D+02, 48 | E -7.65252468141181642D+02, 1.05999045252799988D+03/ 49 | DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 50 | 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 51 | 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 52 | 3 -6.99579627376132541D+02, 2.18190511744211590D+02, 53 | 4 -2.64914304869515555D+01, 5.72501420974731445D-01, 54 | 5 -1.91945766231840700D+03, 8.06172218173730938D+03, 55 | 6 -1.35865500064341374D+04, 1.16553933368645332D+04, 56 | 7 -5.30564697861340311D+03, 1.20090291321635246D+03, 57 | 8 -1.08090919788394656D+02, 1.72772750258445740D+00, 58 | 9 2.02042913309661486D+04, -9.69805983886375135D+04, 59 | A 1.92547001232531532D+05, -2.03400177280415534D+05, 60 | B 1.22200464983017460D+05, -4.11926549688975513D+04, 61 | C 7.10951430248936372D+03, -4.93915304773088012D+02, 62 | D 6.07404200127348304D+00, -2.42919187900551333D+05, 63 | E 1.31176361466297720D+06, -2.99801591853810675D+06/ 64 | DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 65 | 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 66 | 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ 67 | 3 3.76327129765640400D+06, -2.81356322658653411D+06, 68 | 4 1.26836527332162478D+06, -3.31645172484563578D+05, 69 | 5 4.52187689813627263D+04, -2.49983048181120962D+03, 70 | 6 2.43805296995560639D+01, 3.28446985307203782D+06, 71 | 7 -1.97068191184322269D+07, 5.09526024926646422D+07, 72 | 8 -7.41051482115326577D+07, 6.63445122747290267D+07, 73 | 9 -3.75671766607633513D+07, 1.32887671664218183D+07, 74 | A -2.78561812808645469D+06, 3.08186404612662398D+05, 75 | B -1.38860897537170405D+04, 1.10017140269246738D+02, 76 | C -4.93292536645099620D+07, 3.25573074185765749D+08, 77 | D -9.39462359681578403D+08, 1.55359689957058006D+09, 78 | E -1.62108055210833708D+09, 1.10684281682301447D+09/ 79 | DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), 80 | 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), 81 | 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ 82 | 3 -4.95889784275030309D+08, 1.42062907797533095D+08, 83 | 4 -2.44740627257387285D+07, 2.24376817792244943D+06, 84 | 5 -8.40054336030240853D+04, 5.51335896122020586D+02, 85 | 6 8.14789096118312115D+08, -5.86648149205184723D+09, 86 | 7 1.86882075092958249D+10, -3.46320433881587779D+10, 87 | 8 4.12801855797539740D+10, -3.30265997498007231D+10, 88 | 9 1.79542137311556001D+10, -6.56329379261928433D+09, 89 | A 1.55927986487925751D+09, -2.25105661889415278D+08, 90 | B 1.73951075539781645D+07, -5.49842327572288687D+05, 91 | C 3.03809051092238427D+03, -1.46792612476956167D+10, 92 | D 1.14498237732025810D+11, -3.99096175224466498D+11, 93 | E 8.19218669548577329D+11, -1.09837515608122331D+12/ 94 | DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), 95 | 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), 96 | 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ 97 | 3 1.00815810686538209D+12, -6.45364869245376503D+11, 98 | 4 2.87900649906150589D+11, -8.78670721780232657D+10, 99 | 5 1.76347306068349694D+10, -2.16716498322379509D+09, 100 | 6 1.43157876718888981D+08, -3.87183344257261262D+06, 101 | 7 1.82577554742931747D+04, 2.86464035717679043D+11, 102 | 8 -2.40629790002850396D+12, 9.10934118523989896D+12, 103 | 9 -2.05168994109344374D+13, 3.05651255199353206D+13, 104 | A -3.16670885847851584D+13, 2.33483640445818409D+13, 105 | B -1.23204913055982872D+13, 4.61272578084913197D+12, 106 | C -1.19655288019618160D+12, 2.05914503232410016D+11, 107 | D -2.18229277575292237D+10, 1.24700929351271032D+09/ 108 | DATA C(119), C(120)/ 109 | 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ 110 | C 111 | IF (INIT.NE.0) GO TO 40 112 | C----------------------------------------------------------------------- 113 | C INITIALIZE ALL VARIABLES 114 | C----------------------------------------------------------------------- 115 | RFN = 1.0D0/FNU 116 | C----------------------------------------------------------------------- 117 | C OVERFLOW TEST (ZR/FNU TOO SMALL) 118 | C----------------------------------------------------------------------- 119 | TEST = D1MACH(1)*1.0D+3 120 | AC = FNU*TEST 121 | IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15 122 | ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU 123 | ZETA1I = 0.0D0 124 | ZETA2R = FNU 125 | ZETA2I = 0.0D0 126 | PHIR = 1.0D0 127 | PHII = 0.0D0 128 | RETURN 129 | 15 CONTINUE 130 | TR = ZRR*RFN 131 | TI = ZRI*RFN 132 | SR = CONER + (TR*TR-TI*TI) 133 | SI = CONEI + (TR*TI+TI*TR) 134 | CALL ZSQRT(SR, SI, SRR, SRI) 135 | STR = CONER + SRR 136 | STI = CONEI + SRI 137 | CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) 138 | CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) 139 | ZETA1R = FNU*STR 140 | ZETA1I = FNU*STI 141 | ZETA2R = FNU*SRR 142 | ZETA2I = FNU*SRI 143 | CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) 144 | SRR = TR*RFN 145 | SRI = TI*RFN 146 | CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) 147 | PHIR = CWRKR(16)*CON(IKFLG) 148 | PHII = CWRKI(16)*CON(IKFLG) 149 | IF (IPMTR.NE.0) RETURN 150 | CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) 151 | CWRKR(1) = CONER 152 | CWRKI(1) = CONEI 153 | CRFNR = CONER 154 | CRFNI = CONEI 155 | AC = 1.0D0 156 | L = 1 157 | DO 20 K=2,15 158 | SR = ZEROR 159 | SI = ZEROI 160 | DO 10 J=1,K 161 | L = L + 1 162 | STR = SR*T2R - SI*T2I + C(L) 163 | SI = SR*T2I + SI*T2R 164 | SR = STR 165 | 10 CONTINUE 166 | STR = CRFNR*SRR - CRFNI*SRI 167 | CRFNI = CRFNR*SRI + CRFNI*SRR 168 | CRFNR = STR 169 | CWRKR(K) = CRFNR*SR - CRFNI*SI 170 | CWRKI(K) = CRFNR*SI + CRFNI*SR 171 | AC = AC*RFN 172 | TEST = DABS(CWRKR(K)) + DABS(CWRKI(K)) 173 | IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 174 | 20 CONTINUE 175 | K = 15 176 | 30 CONTINUE 177 | INIT = K 178 | 40 CONTINUE 179 | IF (IKFLG.EQ.2) GO TO 60 180 | C----------------------------------------------------------------------- 181 | C COMPUTE SUM FOR THE I FUNCTION 182 | C----------------------------------------------------------------------- 183 | SR = ZEROR 184 | SI = ZEROI 185 | DO 50 I=1,INIT 186 | SR = SR + CWRKR(I) 187 | SI = SI + CWRKI(I) 188 | 50 CONTINUE 189 | SUMR = SR 190 | SUMI = SI 191 | PHIR = CWRKR(16)*CON(1) 192 | PHII = CWRKI(16)*CON(1) 193 | RETURN 194 | 60 CONTINUE 195 | C----------------------------------------------------------------------- 196 | C COMPUTE SUM FOR THE K FUNCTION 197 | C----------------------------------------------------------------------- 198 | SR = ZEROR 199 | SI = ZEROI 200 | TR = CONER 201 | DO 70 I=1,INIT 202 | SR = SR + TR*CWRKR(I) 203 | SI = SI + TR*CWRKI(I) 204 | TR = -TR 205 | 70 CONTINUE 206 | SUMR = SR 207 | SUMI = SI 208 | PHIR = CWRKR(16)*CON(2) 209 | PHII = CWRKI(16)*CON(2) 210 | RETURN 211 | END 212 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zuoik.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, 2 | * ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZUOIK 4 | C***REFER TO ZBESI,ZBESK,ZBESH 5 | C 6 | C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC 7 | C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM 8 | C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW 9 | C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING 10 | C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN 11 | C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER 12 | C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE 13 | C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= 14 | C EXP(-ELIM)/TOL 15 | C 16 | C IKFLG=1 MEANS THE I SEQUENCE IS TESTED 17 | C =2 MEANS THE K SEQUENCE IS TESTED 18 | C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE 19 | C =-1 MEANS AN OVERFLOW WOULD OCCUR 20 | C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO 21 | C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE 22 | C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO 23 | C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY 24 | C ANOTHER ROUTINE 25 | C 26 | C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG 27 | C***END PROLOGUE ZUOIK 28 | C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, 29 | C *ZR 30 | DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, 31 | * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, 32 | * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, 33 | * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, 34 | * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS 35 | INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW 36 | DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) 37 | DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / 38 | DATA AIC / 1.265512123484645396D+00 / 39 | NUF = 0 40 | NN = N 41 | ZRR = ZR 42 | ZRI = ZI 43 | IF (ZR.GE.0.0D0) GO TO 10 44 | ZRR = -ZR 45 | ZRI = -ZI 46 | 10 CONTINUE 47 | ZBR = ZRR 48 | ZBI = ZRI 49 | AX = DABS(ZR)*1.7321D0 50 | AY = DABS(ZI) 51 | IFORM = 1 52 | IF (AY.GT.AX) IFORM = 2 53 | GNU = DMAX1(FNU,1.0D0) 54 | IF (IKFLG.EQ.1) GO TO 20 55 | FNN = DBLE(FLOAT(NN)) 56 | GNN = FNU + FNN - 1.0D0 57 | GNU = DMAX1(GNN,FNN) 58 | 20 CONTINUE 59 | C----------------------------------------------------------------------- 60 | C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE 61 | C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET 62 | C THE SIGN OF THE IMAGINARY PART CORRECT. 63 | C----------------------------------------------------------------------- 64 | IF (IFORM.EQ.2) GO TO 30 65 | INIT = 0 66 | CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, 67 | * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) 68 | CZR = -ZETA1R + ZETA2R 69 | CZI = -ZETA1I + ZETA2I 70 | GO TO 50 71 | 30 CONTINUE 72 | ZNR = ZRI 73 | ZNI = -ZRR 74 | IF (ZI.GT.0.0D0) GO TO 40 75 | ZNR = -ZNR 76 | 40 CONTINUE 77 | CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, 78 | * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) 79 | CZR = -ZETA1R + ZETA2R 80 | CZI = -ZETA1I + ZETA2I 81 | AARG = ZABS(CMPLX(ARGR,ARGI,kind=KIND(1.0D0))) 82 | 50 CONTINUE 83 | IF (KODE.EQ.1) GO TO 60 84 | CZR = CZR - ZBR 85 | CZI = CZI - ZBI 86 | 60 CONTINUE 87 | IF (IKFLG.EQ.1) GO TO 70 88 | CZR = -CZR 89 | CZI = -CZI 90 | 70 CONTINUE 91 | APHI = ZABS(CMPLX(PHIR,PHII,kind=KIND(1.0D0))) 92 | RCZ = CZR 93 | C----------------------------------------------------------------------- 94 | C OVERFLOW TEST 95 | C----------------------------------------------------------------------- 96 | IF (RCZ.GT.ELIM) GO TO 210 97 | IF (RCZ.LT.ALIM) GO TO 80 98 | RCZ = RCZ + DLOG(APHI) 99 | IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC 100 | IF (RCZ.GT.ELIM) GO TO 210 101 | GO TO 130 102 | 80 CONTINUE 103 | C----------------------------------------------------------------------- 104 | C UNDERFLOW TEST 105 | C----------------------------------------------------------------------- 106 | IF (RCZ.LT.(-ELIM)) GO TO 90 107 | IF (RCZ.GT.(-ALIM)) GO TO 130 108 | RCZ = RCZ + DLOG(APHI) 109 | IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC 110 | IF (RCZ.GT.(-ELIM)) GO TO 110 111 | 90 CONTINUE 112 | DO 100 I=1,NN 113 | YR(I) = ZEROR 114 | YI(I) = ZEROI 115 | 100 CONTINUE 116 | NUF = NN 117 | RETURN 118 | 110 CONTINUE 119 | ASCLE = 1.0D+3*D1MACH(1)/TOL 120 | CALL ZLOG(PHIR, PHII, STR, STI, IDUM) 121 | CZR = CZR + STR 122 | CZI = CZI + STI 123 | IF (IFORM.EQ.1) GO TO 120 124 | CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) 125 | CZR = CZR - 0.25D0*STR - AIC 126 | CZI = CZI - 0.25D0*STI 127 | 120 CONTINUE 128 | AX = DEXP(RCZ)/TOL 129 | AY = CZI 130 | CZR = AX*DCOS(AY) 131 | CZI = AX*DSIN(AY) 132 | CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) 133 | IF (NW.NE.0) GO TO 90 134 | 130 CONTINUE 135 | IF (IKFLG.EQ.2) RETURN 136 | IF (N.EQ.1) RETURN 137 | C----------------------------------------------------------------------- 138 | C SET UNDERFLOWS ON I SEQUENCE 139 | C----------------------------------------------------------------------- 140 | 140 CONTINUE 141 | GNU = FNU + DBLE(FLOAT(NN-1)) 142 | IF (IFORM.EQ.2) GO TO 150 143 | INIT = 0 144 | CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, 145 | * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) 146 | CZR = -ZETA1R + ZETA2R 147 | CZI = -ZETA1I + ZETA2I 148 | GO TO 160 149 | 150 CONTINUE 150 | CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, 151 | * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) 152 | CZR = -ZETA1R + ZETA2R 153 | CZI = -ZETA1I + ZETA2I 154 | AARG = ZABS(CMPLX(ARGR,ARGI,kind=KIND(1.0D0))) 155 | 160 CONTINUE 156 | IF (KODE.EQ.1) GO TO 170 157 | CZR = CZR - ZBR 158 | CZI = CZI - ZBI 159 | 170 CONTINUE 160 | APHI = ZABS(CMPLX(PHIR,PHII,kind=KIND(1.0D0))) 161 | RCZ = CZR 162 | IF (RCZ.LT.(-ELIM)) GO TO 180 163 | IF (RCZ.GT.(-ALIM)) RETURN 164 | RCZ = RCZ + DLOG(APHI) 165 | IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC 166 | IF (RCZ.GT.(-ELIM)) GO TO 190 167 | 180 CONTINUE 168 | YR(NN) = ZEROR 169 | YI(NN) = ZEROI 170 | NN = NN - 1 171 | NUF = NUF + 1 172 | IF (NN.EQ.0) RETURN 173 | GO TO 140 174 | 190 CONTINUE 175 | ASCLE = 1.0D+3*D1MACH(1)/TOL 176 | CALL ZLOG(PHIR, PHII, STR, STI, IDUM) 177 | CZR = CZR + STR 178 | CZI = CZI + STI 179 | IF (IFORM.EQ.1) GO TO 200 180 | CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) 181 | CZR = CZR - 0.25D0*STR - AIC 182 | CZI = CZI - 0.25D0*STI 183 | 200 CONTINUE 184 | AX = DEXP(RCZ)/TOL 185 | AY = CZI 186 | CZR = AX*DCOS(AY) 187 | CZI = AX*DSIN(AY) 188 | CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) 189 | IF (NW.NE.0) GO TO 180 190 | RETURN 191 | 210 CONTINUE 192 | NUF = -1 193 | RETURN 194 | END 195 | -------------------------------------------------------------------------------- /internal/amos/amoslib/zwrsk.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, 2 | * TOL, ELIM, ALIM) 3 | C***BEGIN PROLOGUE ZWRSK 4 | C***REFER TO ZBESI,ZBESK 5 | C 6 | C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY 7 | C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN 8 | C 9 | C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS 10 | C***END PROLOGUE ZWRSK 11 | C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR 12 | DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, 13 | * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, 14 | * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH 15 | INTEGER I, KODE, N, NW, NZ 16 | DIMENSION YR(N), YI(N), CWR(2), CWI(2) 17 | C----------------------------------------------------------------------- 18 | C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS 19 | C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE 20 | C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. 21 | C----------------------------------------------------------------------- 22 | NZ = 0 23 | CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) 24 | IF (NW.NE.0) GO TO 50 25 | CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) 26 | C----------------------------------------------------------------------- 27 | C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), 28 | C R(FNU+J-1,Z)=Y(J), J=1,...,N 29 | C----------------------------------------------------------------------- 30 | CINUR = 1.0D0 31 | CINUI = 0.0D0 32 | IF (KODE.EQ.1) GO TO 10 33 | CINUR = DCOS(ZRI) 34 | CINUI = DSIN(ZRI) 35 | 10 CONTINUE 36 | C----------------------------------------------------------------------- 37 | C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH 38 | C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE 39 | C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT 40 | C THE RESULT IS ON SCALE. 41 | C----------------------------------------------------------------------- 42 | ACW = ZABS(CMPLX(CWR(2),CWI(2),kind=KIND(1.0D0))) 43 | ASCLE = 1.0D+3*D1MACH(1)/TOL 44 | CSCLR = 1.0D0 45 | IF (ACW.GT.ASCLE) GO TO 20 46 | CSCLR = 1.0D0/TOL 47 | GO TO 30 48 | 20 CONTINUE 49 | ASCLE = 1.0D0/ASCLE 50 | IF (ACW.LT.ASCLE) GO TO 30 51 | CSCLR = TOL 52 | 30 CONTINUE 53 | C1R = CWR(1)*CSCLR 54 | C1I = CWI(1)*CSCLR 55 | C2R = CWR(2)*CSCLR 56 | C2I = CWI(2)*CSCLR 57 | STR = YR(1) 58 | STI = YI(1) 59 | C----------------------------------------------------------------------- 60 | C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS 61 | C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) 62 | C----------------------------------------------------------------------- 63 | PTR = STR*C1R - STI*C1I 64 | PTI = STR*C1I + STI*C1R 65 | PTR = PTR + C2R 66 | PTI = PTI + C2I 67 | CTR = ZRR*PTR - ZRI*PTI 68 | CTI = ZRR*PTI + ZRI*PTR 69 | ACT = ZABS(CMPLX(CTR,CTI,kind=KIND(1.0D0))) 70 | RACT = 1.0D0/ACT 71 | CTR = CTR*RACT 72 | CTI = -CTI*RACT 73 | PTR = CINUR*RACT 74 | PTI = CINUI*RACT 75 | CINUR = PTR*CTR - PTI*CTI 76 | CINUI = PTR*CTI + PTI*CTR 77 | YR(1) = CINUR*CSCLR 78 | YI(1) = CINUI*CSCLR 79 | IF (N.EQ.1) RETURN 80 | DO 40 I=2,N 81 | PTR = STR*CINUR - STI*CINUI 82 | CINUI = STR*CINUI + STI*CINUR 83 | CINUR = PTR 84 | STR = YR(I) 85 | STI = YI(I) 86 | YR(I) = CINUR*CSCLR 87 | YI(I) = CINUI*CSCLR 88 | 40 CONTINUE 89 | RETURN 90 | 50 CONTINUE 91 | NZ = -1 92 | IF(NW.EQ.(-2)) NZ=-2 93 | RETURN 94 | END 95 | -------------------------------------------------------------------------------- /internal/amos/doc.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2018 The Gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | // This repository is no longer maintained. 6 | // Development has moved to https://github.com/gonum/gonum. 7 | package amos 8 | -------------------------------------------------------------------------------- /internal/cephes/cephes.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | // Package cephes implements functions originally in the Netlib code by Stephen Mosher. 6 | package cephes 7 | 8 | import "math" 9 | 10 | /* 11 | Additional copyright information: 12 | 13 | Code in this package is adapted from the Cephes library (http://www.netlib.org/cephes/). 14 | There is no explicit licence on Netlib, but the author has agreed to a BSD release. 15 | See https://github.com/deepmind/torch-cephes/blob/master/LICENSE.txt and 16 | https://lists.debian.org/debian-legal/2004/12/msg00295.html 17 | */ 18 | 19 | var ( 20 | badParamOutOfBounds = "cephes: parameter out of bounds" 21 | badParamFunctionSingularity = "cephes: function singularity" 22 | ) 23 | 24 | const ( 25 | machEp = 1.0 / (1 << 53) 26 | maxLog = 1024 * math.Ln2 27 | minLog = -1075 * math.Ln2 28 | maxIter = 2000 29 | ) 30 | -------------------------------------------------------------------------------- /internal/cephes/doc.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2018 The Gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | // This repository is no longer maintained. 6 | // Development has moved to https://github.com/gonum/gonum. 7 | package cephes 8 | -------------------------------------------------------------------------------- /internal/cephes/igami.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/cephes/igami.c 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/cephes/igami.c 3 | // Made freely available by Stephen L. Moshier without support or guarantee. 4 | 5 | // Use of this source code is governed by a BSD-style 6 | // license that can be found in the LICENSE file. 7 | // Copyright ©1984, ©1987, ©1995 by Stephen L. Moshier 8 | // Portions Copyright ©2017 The gonum Authors. All rights reserved. 9 | 10 | package cephes 11 | 12 | import "math" 13 | 14 | // IgamI computes the inverse of the incomplete Gamma function. That is, it 15 | // returns the x such that: 16 | // IgamC(a, x) = p 17 | // The input argument a must be positive and p must be between 0 and 1 18 | // inclusive or IgamI will panic. IgamI should return a positive number, but 19 | // can return 0 even with non-zero y due to underflow. 20 | func IgamI(a, p float64) float64 { 21 | // Bound the solution 22 | x0 := math.MaxFloat64 23 | yl := 0.0 24 | x1 := 0.0 25 | yh := 1.0 26 | dithresh := 5.0 * machEp 27 | 28 | if p < 0 || p > 1 || a <= 0 { 29 | panic(badParamOutOfBounds) 30 | } 31 | 32 | if p == 0 { 33 | return math.Inf(1) 34 | } 35 | 36 | if p == 1 { 37 | return 0.0 38 | } 39 | 40 | // Starting with the approximate value 41 | // x = a y^3 42 | // where 43 | // y = 1 - d - ndtri(p) sqrt(d) 44 | // and 45 | // d = 1/9a 46 | // the routine performs up to 10 Newton iterations to find the root of 47 | // IgamC(a, x) - p = 0 48 | d := 1.0 / (9.0 * a) 49 | y := 1.0 - d - Ndtri(p)*math.Sqrt(d) 50 | x := a * y * y * y 51 | 52 | lgm := lgam(a) 53 | 54 | for i := 0; i < 10; i++ { 55 | if x > x0 || x < x1 { 56 | break 57 | } 58 | 59 | y = IgamC(a, x) 60 | 61 | if y < yl || y > yh { 62 | break 63 | } 64 | 65 | if y < p { 66 | x0 = x 67 | yl = y 68 | } else { 69 | x1 = x 70 | yh = y 71 | } 72 | 73 | // Compute the derivative of the function at this point 74 | d = (a-1)*math.Log(x) - x - lgm 75 | if d < -maxLog { 76 | break 77 | } 78 | d = -math.Exp(d) 79 | 80 | // Compute the step to the next approximation of x 81 | d = (y - p) / d 82 | if math.Abs(d/x) < machEp { 83 | return x 84 | } 85 | x = x - d 86 | } 87 | 88 | d = 0.0625 89 | if x0 == math.MaxFloat64 { 90 | if x <= 0 { 91 | x = 1 92 | } 93 | for x0 == math.MaxFloat64 { 94 | x = (1 + d) * x 95 | y = IgamC(a, x) 96 | if y < p { 97 | x0 = x 98 | yl = y 99 | break 100 | } 101 | d = d + d 102 | } 103 | } 104 | 105 | d = 0.5 106 | dir := 0 107 | for i := 0; i < 400; i++ { 108 | x = x1 + d*(x0-x1) 109 | y = IgamC(a, x) 110 | 111 | lgm = (x0 - x1) / (x1 + x0) 112 | if math.Abs(lgm) < dithresh { 113 | break 114 | } 115 | 116 | lgm = (y - p) / p 117 | if math.Abs(lgm) < dithresh { 118 | break 119 | } 120 | 121 | if x <= 0 { 122 | break 123 | } 124 | 125 | if y >= p { 126 | x1 = x 127 | yh = y 128 | if dir < 0 { 129 | dir = 0 130 | d = 0.5 131 | } else if dir > 1 { 132 | d = 0.5*d + 0.5 133 | } else { 134 | d = (p - yl) / (yh - yl) 135 | } 136 | dir++ 137 | } else { 138 | x0 = x 139 | yl = y 140 | if dir > 0 { 141 | dir = 0 142 | d = 0.5 143 | } else if dir < -1 { 144 | d = 0.5 * d 145 | } else { 146 | d = (p - yl) / (yh - yl) 147 | } 148 | dir-- 149 | } 150 | } 151 | 152 | return x 153 | } 154 | -------------------------------------------------------------------------------- /internal/cephes/incbeta.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | /* 6 | * Cephes Math Library, Release 2.3: March, 1995 7 | * Copyright 1984, 1995 by Stephen L. Moshier 8 | */ 9 | 10 | package cephes 11 | 12 | import ( 13 | "math" 14 | 15 | "github.com/gonum/mathext/internal/gonum" 16 | ) 17 | 18 | const ( 19 | maxGam = 171.624376956302725 20 | big = 4.503599627370496e15 21 | biginv = 2.22044604925031308085e-16 22 | ) 23 | 24 | // Incbet computes the regularized incomplete beta function. 25 | func Incbet(aa, bb, xx float64) float64 { 26 | if aa <= 0 || bb <= 0 { 27 | panic(badParamOutOfBounds) 28 | } 29 | if xx <= 0 || xx >= 1 { 30 | if xx == 0 { 31 | return 0 32 | } 33 | if xx == 1 { 34 | return 1 35 | } 36 | panic(badParamOutOfBounds) 37 | } 38 | 39 | var flag int 40 | if bb*xx <= 1 && xx <= 0.95 { 41 | t := pseries(aa, bb, xx) 42 | return transformT(t, flag) 43 | } 44 | 45 | w := 1 - xx 46 | 47 | // Reverse a and b if x is greater than the mean. 48 | var a, b, xc, x float64 49 | if xx > aa/(aa+bb) { 50 | flag = 1 51 | a = bb 52 | b = aa 53 | xc = xx 54 | x = w 55 | } else { 56 | a = aa 57 | b = bb 58 | xc = w 59 | x = xx 60 | } 61 | 62 | if flag == 1 && (b*x) <= 1.0 && x <= 0.95 { 63 | t := pseries(a, b, x) 64 | return transformT(t, flag) 65 | } 66 | 67 | // Choose expansion for better convergence. 68 | y := x*(a+b-2.0) - (a - 1.0) 69 | if y < 0.0 { 70 | w = incbcf(a, b, x) 71 | } else { 72 | w = incbd(a, b, x) / xc 73 | } 74 | 75 | // Multiply w by the factor 76 | // x^a * (1-x)^b * Γ(a+b) / (a*Γ(a)*Γ(b)) 77 | var t float64 78 | y = a * math.Log(x) 79 | t = b * math.Log(xc) 80 | if (a+b) < maxGam && math.Abs(y) < maxLog && math.Abs(t) < maxLog { 81 | t = math.Pow(xc, b) 82 | t *= math.Pow(x, a) 83 | t /= a 84 | t *= w 85 | t *= 1.0 / gonum.Beta(a, b) 86 | return transformT(t, flag) 87 | } 88 | 89 | // Resort to logarithms. 90 | y += t - gonum.Lbeta(a, b) 91 | y += math.Log(w / a) 92 | if y < minLog { 93 | t = 0.0 94 | } else { 95 | t = math.Exp(y) 96 | } 97 | 98 | return transformT(t, flag) 99 | } 100 | 101 | func transformT(t float64, flag int) float64 { 102 | if flag == 1 { 103 | if t <= machEp { 104 | t = 1.0 - machEp 105 | } else { 106 | t = 1.0 - t 107 | } 108 | } 109 | return t 110 | } 111 | 112 | // incbcf returns the incomplete beta integral evaluated by a continued fraction 113 | // expansion. 114 | func incbcf(a, b, x float64) float64 { 115 | var xk, pk, pkm1, pkm2, qk, qkm1, qkm2 float64 116 | var k1, k2, k3, k4, k5, k6, k7, k8 float64 117 | var r, t, ans, thresh float64 118 | var n int 119 | 120 | k1 = a 121 | k2 = a + b 122 | k3 = a 123 | k4 = a + 1.0 124 | k5 = 1.0 125 | k6 = b - 1.0 126 | k7 = k4 127 | k8 = a + 2.0 128 | 129 | pkm2 = 0.0 130 | qkm2 = 1.0 131 | pkm1 = 1.0 132 | qkm1 = 1.0 133 | ans = 1.0 134 | r = 1.0 135 | thresh = 3.0 * machEp 136 | 137 | for n = 0; n <= 300; n++ { 138 | 139 | xk = -(x * k1 * k2) / (k3 * k4) 140 | pk = pkm1 + pkm2*xk 141 | qk = qkm1 + qkm2*xk 142 | pkm2 = pkm1 143 | pkm1 = pk 144 | qkm2 = qkm1 145 | qkm1 = qk 146 | 147 | xk = (x * k5 * k6) / (k7 * k8) 148 | pk = pkm1 + pkm2*xk 149 | qk = qkm1 + qkm2*xk 150 | pkm2 = pkm1 151 | pkm1 = pk 152 | qkm2 = qkm1 153 | qkm1 = qk 154 | 155 | if qk != 0 { 156 | r = pk / qk 157 | } 158 | if r != 0 { 159 | t = math.Abs((ans - r) / r) 160 | ans = r 161 | } else { 162 | t = 1.0 163 | } 164 | 165 | if t < thresh { 166 | return ans 167 | } 168 | 169 | k1 += 1.0 170 | k2 += 1.0 171 | k3 += 2.0 172 | k4 += 2.0 173 | k5 += 1.0 174 | k6 -= 1.0 175 | k7 += 2.0 176 | k8 += 2.0 177 | 178 | if (math.Abs(qk) + math.Abs(pk)) > big { 179 | pkm2 *= biginv 180 | pkm1 *= biginv 181 | qkm2 *= biginv 182 | qkm1 *= biginv 183 | } 184 | if (math.Abs(qk) < biginv) || (math.Abs(pk) < biginv) { 185 | pkm2 *= big 186 | pkm1 *= big 187 | qkm2 *= big 188 | qkm1 *= big 189 | } 190 | } 191 | 192 | return ans 193 | } 194 | 195 | // incbd returns the incomplete beta integral evaluated by a continued fraction 196 | // expansion. 197 | func incbd(a, b, x float64) float64 { 198 | var xk, pk, pkm1, pkm2, qk, qkm1, qkm2 float64 199 | var k1, k2, k3, k4, k5, k6, k7, k8 float64 200 | var r, t, ans, z, thresh float64 201 | var n int 202 | 203 | k1 = a 204 | k2 = b - 1.0 205 | k3 = a 206 | k4 = a + 1.0 207 | k5 = 1.0 208 | k6 = a + b 209 | k7 = a + 1.0 210 | k8 = a + 2.0 211 | 212 | pkm2 = 0.0 213 | qkm2 = 1.0 214 | pkm1 = 1.0 215 | qkm1 = 1.0 216 | z = x / (1.0 - x) 217 | ans = 1.0 218 | r = 1.0 219 | thresh = 3.0 * machEp 220 | for n = 0; n <= 300; n++ { 221 | 222 | xk = -(z * k1 * k2) / (k3 * k4) 223 | pk = pkm1 + pkm2*xk 224 | qk = qkm1 + qkm2*xk 225 | pkm2 = pkm1 226 | pkm1 = pk 227 | qkm2 = qkm1 228 | qkm1 = qk 229 | 230 | xk = (z * k5 * k6) / (k7 * k8) 231 | pk = pkm1 + pkm2*xk 232 | qk = qkm1 + qkm2*xk 233 | pkm2 = pkm1 234 | pkm1 = pk 235 | qkm2 = qkm1 236 | qkm1 = qk 237 | 238 | if qk != 0 { 239 | r = pk / qk 240 | } 241 | if r != 0 { 242 | t = math.Abs((ans - r) / r) 243 | ans = r 244 | } else { 245 | t = 1.0 246 | } 247 | 248 | if t < thresh { 249 | return ans 250 | } 251 | 252 | k1 += 1.0 253 | k2 -= 1.0 254 | k3 += 2.0 255 | k4 += 2.0 256 | k5 += 1.0 257 | k6 += 1.0 258 | k7 += 2.0 259 | k8 += 2.0 260 | 261 | if (math.Abs(qk) + math.Abs(pk)) > big { 262 | pkm2 *= biginv 263 | pkm1 *= biginv 264 | qkm2 *= biginv 265 | qkm1 *= biginv 266 | } 267 | if (math.Abs(qk) < biginv) || (math.Abs(pk) < biginv) { 268 | pkm2 *= big 269 | pkm1 *= big 270 | qkm2 *= big 271 | qkm1 *= big 272 | } 273 | } 274 | return ans 275 | } 276 | 277 | // pseries returns the incomplete beta integral evaluated by a power series. Use 278 | // when b*x is small and x not too close to 1. 279 | func pseries(a, b, x float64) float64 { 280 | var s, t, u, v, n, t1, z, ai float64 281 | ai = 1.0 / a 282 | u = (1.0 - b) * x 283 | v = u / (a + 1.0) 284 | t1 = v 285 | t = u 286 | n = 2.0 287 | s = 0.0 288 | z = machEp * ai 289 | for math.Abs(v) > z { 290 | u = (n - b) * x / n 291 | t *= u 292 | v = t / (a + n) 293 | s += v 294 | n += 1.0 295 | } 296 | s += t1 297 | s += ai 298 | 299 | u = a * math.Log(x) 300 | if (a+b) < maxGam && math.Abs(u) < maxLog { 301 | t = 1.0 / gonum.Beta(a, b) 302 | s = s * t * math.Pow(x, a) 303 | } else { 304 | t = -gonum.Lbeta(a, b) + u + math.Log(s) 305 | if t < minLog { 306 | s = 0.0 307 | } else { 308 | s = math.Exp(t) 309 | } 310 | } 311 | return (s) 312 | } 313 | -------------------------------------------------------------------------------- /internal/cephes/incbi.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | /* 6 | * Cephes Math Library Release 2.4: March,1996 7 | * Copyright 1984, 1996 by Stephen L. Moshier 8 | */ 9 | 10 | package cephes 11 | 12 | import "math" 13 | 14 | // Incbi computes the inverse of the regularized incomplete beta integral. 15 | func Incbi(aa, bb, yy0 float64) float64 { 16 | var a, b, y0, d, y, x, x0, x1, lgm, yp, di, dithresh, yl, yh, xt float64 17 | var i, rflg, dir, nflg int 18 | 19 | i = 0 20 | if yy0 <= 0 { 21 | return (0.0) 22 | } 23 | if yy0 >= 1.0 { 24 | return (1.0) 25 | } 26 | x0 = 0.0 27 | yl = 0.0 28 | x1 = 1.0 29 | yh = 1.0 30 | nflg = 0 31 | 32 | if aa <= 1.0 || bb <= 1.0 { 33 | dithresh = 1.0e-6 34 | rflg = 0 35 | a = aa 36 | b = bb 37 | y0 = yy0 38 | x = a / (a + b) 39 | y = Incbet(a, b, x) 40 | goto ihalve 41 | } else { 42 | dithresh = 1.0e-4 43 | } 44 | // Approximation to inverse function 45 | yp = -Ndtri(yy0) 46 | 47 | if yy0 > 0.5 { 48 | rflg = 1 49 | a = bb 50 | b = aa 51 | y0 = 1.0 - yy0 52 | yp = -yp 53 | } else { 54 | rflg = 0 55 | a = aa 56 | b = bb 57 | y0 = yy0 58 | } 59 | 60 | lgm = (yp*yp - 3.0) / 6.0 61 | x = 2.0 / (1.0/(2.0*a-1.0) + 1.0/(2.0*b-1.0)) 62 | d = yp*math.Sqrt(x+lgm)/x - (1.0/(2.0*b-1.0)-1.0/(2.0*a-1.0))*(lgm+5.0/6.0-2.0/(3.0*x)) 63 | d = 2.0 * d 64 | if d < minLog { 65 | // mtherr("incbi", UNDERFLOW) 66 | x = 0 67 | goto done 68 | } 69 | x = a / (a + b*math.Exp(d)) 70 | y = Incbet(a, b, x) 71 | yp = (y - y0) / y0 72 | if math.Abs(yp) < 0.2 { 73 | goto newt 74 | } 75 | 76 | /* Resort to interval halving if not close enough. */ 77 | ihalve: 78 | 79 | dir = 0 80 | di = 0.5 81 | for i = 0; i < 100; i++ { 82 | if i != 0 { 83 | x = x0 + di*(x1-x0) 84 | if x == 1.0 { 85 | x = 1.0 - machEp 86 | } 87 | if x == 0.0 { 88 | di = 0.5 89 | x = x0 + di*(x1-x0) 90 | if x == 0.0 { 91 | // mtherr("incbi", UNDERFLOW) 92 | goto done 93 | } 94 | } 95 | y = Incbet(a, b, x) 96 | yp = (x1 - x0) / (x1 + x0) 97 | if math.Abs(yp) < dithresh { 98 | goto newt 99 | } 100 | yp = (y - y0) / y0 101 | if math.Abs(yp) < dithresh { 102 | goto newt 103 | } 104 | } 105 | if y < y0 { 106 | x0 = x 107 | yl = y 108 | if dir < 0 { 109 | dir = 0 110 | di = 0.5 111 | } else if dir > 3 { 112 | di = 1.0 - (1.0-di)*(1.0-di) 113 | } else if dir > 1 { 114 | di = 0.5*di + 0.5 115 | } else { 116 | di = (y0 - y) / (yh - yl) 117 | } 118 | dir += 1 119 | if x0 > 0.75 { 120 | if rflg == 1 { 121 | rflg = 0 122 | a = aa 123 | b = bb 124 | y0 = yy0 125 | } else { 126 | rflg = 1 127 | a = bb 128 | b = aa 129 | y0 = 1.0 - yy0 130 | } 131 | x = 1.0 - x 132 | y = Incbet(a, b, x) 133 | x0 = 0.0 134 | yl = 0.0 135 | x1 = 1.0 136 | yh = 1.0 137 | goto ihalve 138 | } 139 | } else { 140 | x1 = x 141 | if rflg == 1 && x1 < machEp { 142 | x = 0.0 143 | goto done 144 | } 145 | yh = y 146 | if dir > 0 { 147 | dir = 0 148 | di = 0.5 149 | } else if dir < -3 { 150 | di = di * di 151 | } else if dir < -1 { 152 | di = 0.5 * di 153 | } else { 154 | di = (y - y0) / (yh - yl) 155 | } 156 | dir -= 1 157 | } 158 | } 159 | // mtherr("incbi", PLOSS) 160 | if x0 >= 1.0 { 161 | x = 1.0 - machEp 162 | goto done 163 | } 164 | if x <= 0.0 { 165 | // mtherr("incbi", UNDERFLOW) 166 | x = 0.0 167 | goto done 168 | } 169 | 170 | newt: 171 | if nflg > 0 { 172 | goto done 173 | } 174 | nflg = 1 175 | lgm = lgam(a+b) - lgam(a) - lgam(b) 176 | 177 | for i = 0; i < 8; i++ { 178 | /* Compute the function at this point. */ 179 | if i != 0 { 180 | y = Incbet(a, b, x) 181 | } 182 | if y < yl { 183 | x = x0 184 | y = yl 185 | } else if y > yh { 186 | x = x1 187 | y = yh 188 | } else if y < y0 { 189 | x0 = x 190 | yl = y 191 | } else { 192 | x1 = x 193 | yh = y 194 | } 195 | if x == 1.0 || x == 0.0 { 196 | break 197 | } 198 | /* Compute the derivative of the function at this point. */ 199 | d = (a-1.0)*math.Log(x) + (b-1.0)*math.Log(1.0-x) + lgm 200 | if d < minLog { 201 | goto done 202 | } 203 | if d > maxLog { 204 | break 205 | } 206 | d = math.Exp(d) 207 | /* Compute the step to the next approximation of x. */ 208 | d = (y - y0) / d 209 | xt = x - d 210 | if xt <= x0 { 211 | y = (x - x0) / (x1 - x0) 212 | xt = x0 + 0.5*y*(x-x0) 213 | if xt <= 0.0 { 214 | break 215 | } 216 | } 217 | if xt >= x1 { 218 | y = (x1 - x) / (x1 - x0) 219 | xt = x1 - 0.5*y*(x1-x) 220 | if xt >= 1.0 { 221 | break 222 | } 223 | } 224 | x = xt 225 | if math.Abs(d/x) < 128.0*machEp { 226 | goto done 227 | } 228 | } 229 | /* Did not converge. */ 230 | dithresh = 256.0 * machEp 231 | goto ihalve 232 | 233 | done: 234 | 235 | if rflg > 0 { 236 | if x <= machEp { 237 | x = 1.0 - machEp 238 | } else { 239 | x = 1.0 - x 240 | } 241 | } 242 | return (x) 243 | } 244 | 245 | func lgam(a float64) float64 { 246 | lg, _ := math.Lgamma(a) 247 | return lg 248 | } 249 | -------------------------------------------------------------------------------- /internal/cephes/lanczos.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/cephes/lanczos.c 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/cephes/lanczos.c 3 | 4 | // Use of this source code is governed by a BSD-style 5 | // license that can be found in the LICENSE file. 6 | // Copyright ©2006 John Maddock 7 | // Portions Copyright ©2003 Boost 8 | // Portions Copyright ©2016 The gonum Authors. All rights reserved. 9 | 10 | package cephes 11 | 12 | // Optimal values for G for each N are taken from 13 | // http://web.mala.bc.ca/pughg/phdThesis/phdThesis.pdf, 14 | // as are the theoretical error bounds. 15 | 16 | // Constants calculated using the method described by Godfrey 17 | // http://my.fit.edu/~gabdo/gamma.txt and elaborated by Toth at 18 | // http://www.rskey.org/gamma.htm using NTL::RR at 1000 bit precision. 19 | 20 | var lanczosNum = [...]float64{ 21 | 2.506628274631000270164908177133837338626, 22 | 210.8242777515793458725097339207133627117, 23 | 8071.672002365816210638002902272250613822, 24 | 186056.2653952234950402949897160456992822, 25 | 2876370.628935372441225409051620849613599, 26 | 31426415.58540019438061423162831820536287, 27 | 248874557.8620541565114603864132294232163, 28 | 1439720407.311721673663223072794912393972, 29 | 6039542586.35202800506429164430729792107, 30 | 17921034426.03720969991975575445893111267, 31 | 35711959237.35566804944018545154716670596, 32 | 42919803642.64909876895789904700198885093, 33 | 23531376880.41075968857200767445163675473, 34 | } 35 | 36 | var lanczosDenom = [...]float64{ 37 | 1, 38 | 66, 39 | 1925, 40 | 32670, 41 | 357423, 42 | 2637558, 43 | 13339535, 44 | 45995730, 45 | 105258076, 46 | 150917976, 47 | 120543840, 48 | 39916800, 49 | 0, 50 | } 51 | 52 | var lanczosSumExpgScaledNum = [...]float64{ 53 | 0.006061842346248906525783753964555936883222, 54 | 0.5098416655656676188125178644804694509993, 55 | 19.51992788247617482847860966235652136208, 56 | 449.9445569063168119446858607650988409623, 57 | 6955.999602515376140356310115515198987526, 58 | 75999.29304014542649875303443598909137092, 59 | 601859.6171681098786670226533699352302507, 60 | 3481712.15498064590882071018964774556468, 61 | 14605578.08768506808414169982791359218571, 62 | 43338889.32467613834773723740590533316085, 63 | 86363131.28813859145546927288977868422342, 64 | 103794043.1163445451906271053616070238554, 65 | 56906521.91347156388090791033559122686859, 66 | } 67 | 68 | var lanczosSumExpgScaledDenom = [...]float64{ 69 | 1, 70 | 66, 71 | 1925, 72 | 32670, 73 | 357423, 74 | 2637558, 75 | 13339535, 76 | 45995730, 77 | 105258076, 78 | 150917976, 79 | 120543840, 80 | 39916800, 81 | 0, 82 | } 83 | 84 | var lanczosSumNear1D = [...]float64{ 85 | 0.3394643171893132535170101292240837927725e-9, 86 | -0.2499505151487868335680273909354071938387e-8, 87 | 0.8690926181038057039526127422002498960172e-8, 88 | -0.1933117898880828348692541394841204288047e-7, 89 | 0.3075580174791348492737947340039992829546e-7, 90 | -0.2752907702903126466004207345038327818713e-7, 91 | -0.1515973019871092388943437623825208095123e-5, 92 | 0.004785200610085071473880915854204301886437, 93 | -0.1993758927614728757314233026257810172008, 94 | 1.483082862367253753040442933770164111678, 95 | -3.327150580651624233553677113928873034916, 96 | 2.208709979316623790862569924861841433016, 97 | } 98 | 99 | var lanczosSumNear2D = [...]float64{ 100 | 0.1009141566987569892221439918230042368112e-8, 101 | -0.7430396708998719707642735577238449585822e-8, 102 | 0.2583592566524439230844378948704262291927e-7, 103 | -0.5746670642147041587497159649318454348117e-7, 104 | 0.9142922068165324132060550591210267992072e-7, 105 | -0.8183698410724358930823737982119474130069e-7, 106 | -0.4506604409707170077136555010018549819192e-5, 107 | 0.01422519127192419234315002746252160965831, 108 | -0.5926941084905061794445733628891024027949, 109 | 4.408830289125943377923077727900630927902, 110 | -9.8907772644920670589288081640128194231, 111 | 6.565936202082889535528455955485877361223, 112 | } 113 | 114 | const lanczosG = 6.024680040776729583740234375 115 | 116 | func lanczosSum(x float64) float64 { 117 | return ratevl(x, 118 | lanczosNum[:], 119 | len(lanczosNum)-1, 120 | lanczosDenom[:], 121 | len(lanczosDenom)-1) 122 | } 123 | 124 | func lanczosSumExpgScaled(x float64) float64 { 125 | return ratevl(x, 126 | lanczosSumExpgScaledNum[:], 127 | len(lanczosSumExpgScaledNum)-1, 128 | lanczosSumExpgScaledDenom[:], 129 | len(lanczosSumExpgScaledDenom)-1) 130 | } 131 | 132 | func lanczosSumNear1(dx float64) float64 { 133 | var result float64 134 | 135 | for i, val := range lanczosSumNear1D { 136 | k := float64(i + 1) 137 | result += (-val * dx) / (k*dx + k*k) 138 | } 139 | 140 | return result 141 | } 142 | 143 | func lanczosSumNear2(dx float64) float64 { 144 | var result float64 145 | x := dx + 2 146 | 147 | for i, val := range lanczosSumNear2D { 148 | k := float64(i + 1) 149 | result += (-val * dx) / (x + k*x + k*k - 1) 150 | } 151 | 152 | return result 153 | } 154 | -------------------------------------------------------------------------------- /internal/cephes/ndtri.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | /* 6 | * Cephes Math Library Release 2.1: January, 1989 7 | * Copyright 1984, 1987, 1989 by Stephen L. Moshier 8 | * Direct inquiries to 30 Frost Street, Cambridge, MA 02140 9 | */ 10 | 11 | package cephes 12 | 13 | import "math" 14 | 15 | // TODO(btracey): There is currently an implementation of this functionality 16 | // in gonum/stat/distuv. Find out which implementation is better, and rectify 17 | // by having distuv call this, or moving this implementation into 18 | // gonum/mathext/internal/gonum. 19 | 20 | // math.Sqrt(2*pi) 21 | const s2pi = 2.50662827463100050242E0 22 | 23 | // approximation for 0 <= |y - 0.5| <= 3/8 24 | var P0 = [5]float64{ 25 | -5.99633501014107895267E1, 26 | 9.80010754185999661536E1, 27 | -5.66762857469070293439E1, 28 | 1.39312609387279679503E1, 29 | -1.23916583867381258016E0, 30 | } 31 | 32 | var Q0 = [8]float64{ 33 | /* 1.00000000000000000000E0, */ 34 | 1.95448858338141759834E0, 35 | 4.67627912898881538453E0, 36 | 8.63602421390890590575E1, 37 | -2.25462687854119370527E2, 38 | 2.00260212380060660359E2, 39 | -8.20372256168333339912E1, 40 | 1.59056225126211695515E1, 41 | -1.18331621121330003142E0, 42 | } 43 | 44 | // Approximation for interval z = math.Sqrt(-2 log y ) between 2 and 8 45 | // i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. 46 | var P1 = [9]float64{ 47 | 4.05544892305962419923E0, 48 | 3.15251094599893866154E1, 49 | 5.71628192246421288162E1, 50 | 4.40805073893200834700E1, 51 | 1.46849561928858024014E1, 52 | 2.18663306850790267539E0, 53 | -1.40256079171354495875E-1, 54 | -3.50424626827848203418E-2, 55 | -8.57456785154685413611E-4, 56 | } 57 | 58 | var Q1 = [8]float64{ 59 | /* 1.00000000000000000000E0, */ 60 | 1.57799883256466749731E1, 61 | 4.53907635128879210584E1, 62 | 4.13172038254672030440E1, 63 | 1.50425385692907503408E1, 64 | 2.50464946208309415979E0, 65 | -1.42182922854787788574E-1, 66 | -3.80806407691578277194E-2, 67 | -9.33259480895457427372E-4, 68 | } 69 | 70 | // Approximation for interval z = math.Sqrt(-2 log y ) between 8 and 64 71 | // i.e., y between exp(-32) = 1.27e-14 and exp(-2048) = 3.67e-890. 72 | var P2 = [9]float64{ 73 | 3.23774891776946035970E0, 74 | 6.91522889068984211695E0, 75 | 3.93881025292474443415E0, 76 | 1.33303460815807542389E0, 77 | 2.01485389549179081538E-1, 78 | 1.23716634817820021358E-2, 79 | 3.01581553508235416007E-4, 80 | 2.65806974686737550832E-6, 81 | 6.23974539184983293730E-9, 82 | } 83 | 84 | var Q2 = [8]float64{ 85 | /* 1.00000000000000000000E0, */ 86 | 6.02427039364742014255E0, 87 | 3.67983563856160859403E0, 88 | 1.37702099489081330271E0, 89 | 2.16236993594496635890E-1, 90 | 1.34204006088543189037E-2, 91 | 3.28014464682127739104E-4, 92 | 2.89247864745380683936E-6, 93 | 6.79019408009981274425E-9, 94 | } 95 | 96 | // Ndtri returns the argument, x, for which the area under the 97 | // Gaussian probability density function (integrated from 98 | // minus infinity to x) is equal to y. 99 | func Ndtri(y0 float64) float64 { 100 | // For small arguments 0 < y < exp(-2), the program computes 101 | // z = math.Sqrt( -2.0 * math.Log(y) ); then the approximation is 102 | // x = z - math.Log(z)/z - (1/z) P(1/z) / Q(1/z). 103 | // There are two rational functions P/Q, one for 0 < y < exp(-32) 104 | // and the other for y up to exp(-2). For larger arguments, 105 | // w = y - 0.5, and x/math.Sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). 106 | var x, y, z, y2, x0, x1 float64 107 | var code int 108 | 109 | if y0 <= 0.0 { 110 | if y0 < 0 { 111 | panic(badParamOutOfBounds) 112 | } 113 | return math.Inf(-1) 114 | } 115 | if y0 >= 1.0 { 116 | if y0 > 1 { 117 | panic(badParamOutOfBounds) 118 | } 119 | return math.Inf(1) 120 | } 121 | code = 1 122 | y = y0 123 | if y > (1.0 - 0.13533528323661269189) { /* 0.135... = exp(-2) */ 124 | y = 1.0 - y 125 | code = 0 126 | } 127 | 128 | if y > 0.13533528323661269189 { 129 | y = y - 0.5 130 | y2 = y * y 131 | x = y + y*(y2*polevl(y2, P0[:], 4)/p1evl(y2, Q0[:], 8)) 132 | x = x * s2pi 133 | return (x) 134 | } 135 | 136 | x = math.Sqrt(-2.0 * math.Log(y)) 137 | x0 = x - math.Log(x)/x 138 | 139 | z = 1.0 / x 140 | if x < 8.0 { /* y > exp(-32) = 1.2664165549e-14 */ 141 | x1 = z * polevl(z, P1[:], 8) / p1evl(z, Q1[:], 8) 142 | } else { 143 | x1 = z * polevl(z, P2[:], 8) / p1evl(z, Q2[:], 8) 144 | } 145 | x = x0 - x1 146 | if code != 0 { 147 | x = -x 148 | } 149 | return (x) 150 | } 151 | -------------------------------------------------------------------------------- /internal/cephes/polevl.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/cephes/polevl.h 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/cephes/polevl.h 3 | // Made freely available by Stephen L. Moshier without support or guarantee. 4 | 5 | // Use of this source code is governed by a BSD-style 6 | // license that can be found in the LICENSE file. 7 | // Copyright ©1984, ©1987, ©1988 by Stephen L. Moshier 8 | // Portions Copyright ©2016 The gonum Authors. All rights reserved. 9 | 10 | package cephes 11 | 12 | import "math" 13 | 14 | // polevl evaluates a polynomial of degree N 15 | // y = c_0 + c_1 x_1 + c_2 x_2^2 ... 16 | // where the coefficients are stored in reverse order, i.e. coef[0] = c_n and 17 | // coef[n] = c_0. 18 | func polevl(x float64, coef []float64, n int) float64 { 19 | ans := coef[0] 20 | for i := 1; i <= n; i++ { 21 | ans = ans*x + coef[i] 22 | } 23 | return ans 24 | } 25 | 26 | // p1evl is the same as polevl, except c_n is assumed to be 1 and is not included 27 | // in the slice. 28 | func p1evl(x float64, coef []float64, n int) float64 { 29 | ans := x + coef[0] 30 | for i := 1; i <= n-1; i++ { 31 | ans = ans*x + coef[i] 32 | } 33 | return ans 34 | } 35 | 36 | // ratevl evaluates a rational function 37 | func ratevl(x float64, num []float64, m int, denom []float64, n int) float64 { 38 | // Source: Holin et. al., "Polynomial and Rational Function Evaluation", 39 | // http://www.boost.org/doc/libs/1_61_0/libs/math/doc/html/math_toolkit/roots/rational.html 40 | absx := math.Abs(x) 41 | 42 | var dir, idx int 43 | var y float64 44 | if absx > 1 { 45 | // Evaluate as a polynomial in 1/x 46 | dir = -1 47 | idx = m 48 | y = 1 / x 49 | } else { 50 | dir = 1 51 | idx = 0 52 | y = x 53 | } 54 | 55 | // Evaluate the numerator 56 | numAns := num[idx] 57 | idx += dir 58 | for i := 0; i < m; i++ { 59 | numAns = numAns*y + num[idx] 60 | idx += dir 61 | } 62 | 63 | // Evaluate the denominator 64 | if absx > 1 { 65 | idx = n 66 | } else { 67 | idx = 0 68 | } 69 | 70 | denomAns := denom[idx] 71 | idx += dir 72 | for i := 0; i < n; i++ { 73 | denomAns = denomAns*y + denom[idx] 74 | idx += dir 75 | } 76 | 77 | if absx > 1 { 78 | pow := float64(n - m) 79 | return math.Pow(x, pow) * numAns / denomAns 80 | } 81 | return numAns / denomAns 82 | } 83 | -------------------------------------------------------------------------------- /internal/cephes/unity.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/cephes/unity.c 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/cephes/unity.c 3 | // Made freely available by Stephen L. Moshier without support or guarantee. 4 | 5 | // Use of this source code is governed by a BSD-style 6 | // license that can be found in the LICENSE file. 7 | // Copyright ©1984, ©1996 by Stephen L. Moshier 8 | // Portions Copyright ©2016 The gonum Authors. All rights reserved. 9 | 10 | package cephes 11 | 12 | import "math" 13 | 14 | // Relative error approximations for function arguments near unity. 15 | // log1p(x) = log(1+x) 16 | // expm1(x) = exp(x) - 1 17 | // cosm1(x) = cos(x) - 1 18 | // lgam1p(x) = lgam(1+x) 19 | 20 | const ( 21 | invSqrt2 = 1 / math.Sqrt2 22 | pi4 = math.Pi / 4 23 | euler = 0.577215664901532860606512090082402431 // Euler constant 24 | ) 25 | 26 | // Coefficients for 27 | // log(1+x) = x - \frac{x^2}{2} + \frac{x^3 lP(x)}{lQ(x)} 28 | // for 29 | // \frac{1}{\sqrt{2}} <= x < \sqrt{2} 30 | // Theoretical peak relative error = 2.32e-20 31 | var lP = [...]float64{ 32 | 4.5270000862445199635215E-5, 33 | 4.9854102823193375972212E-1, 34 | 6.5787325942061044846969E0, 35 | 2.9911919328553073277375E1, 36 | 6.0949667980987787057556E1, 37 | 5.7112963590585538103336E1, 38 | 2.0039553499201281259648E1, 39 | } 40 | 41 | var lQ = [...]float64{ 42 | 1.5062909083469192043167E1, 43 | 8.3047565967967209469434E1, 44 | 2.2176239823732856465394E2, 45 | 3.0909872225312059774938E2, 46 | 2.1642788614495947685003E2, 47 | 6.0118660497603843919306E1, 48 | } 49 | 50 | // log1p computes 51 | // log(1 + x) 52 | func log1p(x float64) float64 { 53 | z := 1 + x 54 | if z < invSqrt2 || z > math.Sqrt2 { 55 | return math.Log(z) 56 | } 57 | z = x * x 58 | z = -0.5*z + x*(z*polevl(x, lP[:], 6)/p1evl(x, lQ[:], 6)) 59 | return x + z 60 | } 61 | 62 | // log1pmx computes 63 | // log(1 + x) - x 64 | func log1pmx(x float64) float64 { 65 | if math.Abs(x) < 0.5 { 66 | xfac := x 67 | res := 0.0 68 | 69 | var term float64 70 | for n := 2; n < maxIter; n++ { 71 | xfac *= -x 72 | term = xfac / float64(n) 73 | res += term 74 | if math.Abs(term) < machEp*math.Abs(res) { 75 | break 76 | } 77 | } 78 | return res 79 | } 80 | return log1p(x) - x 81 | } 82 | 83 | // Coefficients for 84 | // e^x = 1 + \frac{2x eP(x^2)}{eQ(x^2) - eP(x^2)} 85 | // for 86 | // -0.5 <= x <= 0.5 87 | var eP = [...]float64{ 88 | 1.2617719307481059087798E-4, 89 | 3.0299440770744196129956E-2, 90 | 9.9999999999999999991025E-1, 91 | } 92 | 93 | var eQ = [...]float64{ 94 | 3.0019850513866445504159E-6, 95 | 2.5244834034968410419224E-3, 96 | 2.2726554820815502876593E-1, 97 | 2.0000000000000000000897E0, 98 | } 99 | 100 | // expm1 computes 101 | // expm1(x) = e^x - 1 102 | func expm1(x float64) float64 { 103 | if math.IsInf(x, 0) { 104 | if math.IsNaN(x) || x > 0 { 105 | return x 106 | } 107 | return -1 108 | } 109 | if x < -0.5 || x > 0.5 { 110 | return math.Exp(x) - 1 111 | } 112 | xx := x * x 113 | r := x * polevl(xx, eP[:], 2) 114 | r = r / (polevl(xx, eQ[:], 3) - r) 115 | return r + r 116 | } 117 | 118 | var coscof = [...]float64{ 119 | 4.7377507964246204691685E-14, 120 | -1.1470284843425359765671E-11, 121 | 2.0876754287081521758361E-9, 122 | -2.7557319214999787979814E-7, 123 | 2.4801587301570552304991E-5, 124 | -1.3888888888888872993737E-3, 125 | 4.1666666666666666609054E-2, 126 | } 127 | 128 | // cosm1 computes 129 | // cosm1(x) = cos(x) - 1 130 | func cosm1(x float64) float64 { 131 | if x < -pi4 || x > pi4 { 132 | return math.Cos(x) - 1 133 | } 134 | xx := x * x 135 | xx = -0.5*xx + xx*xx*polevl(xx, coscof[:], 6) 136 | return xx 137 | } 138 | 139 | // lgam1pTayler computes 140 | // lgam(x + 1) 141 | //around x = 0 using its Taylor series. 142 | func lgam1pTaylor(x float64) float64 { 143 | if x == 0 { 144 | return 0 145 | } 146 | res := -euler * x 147 | xfac := -x 148 | for n := 2; n < 42; n++ { 149 | nf := float64(n) 150 | xfac *= -x 151 | coeff := Zeta(nf, 1) * xfac / nf 152 | res += coeff 153 | if math.Abs(coeff) < machEp*math.Abs(res) { 154 | break 155 | } 156 | } 157 | 158 | return res 159 | } 160 | 161 | // lgam1p computes 162 | // lgam(x + 1) 163 | func lgam1p(x float64) float64 { 164 | if math.Abs(x) <= 0.5 { 165 | return lgam1pTaylor(x) 166 | } else if math.Abs(x-1) < 0.5 { 167 | return math.Log(x) + lgam1pTaylor(x-1) 168 | } 169 | return lgam(x + 1) 170 | } 171 | -------------------------------------------------------------------------------- /internal/cephes/zeta.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/cephes/zeta.c 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/cephes/zeta.c 3 | // Made freely available by Stephen L. Moshier without support or guarantee. 4 | 5 | // Use of this source code is governed by a BSD-style 6 | // license that can be found in the LICENSE file. 7 | // Copyright ©1984, ©1987 by Stephen L. Moshier 8 | // Portions Copyright ©2016 The gonum Authors. All rights reserved. 9 | 10 | package cephes 11 | 12 | import "math" 13 | 14 | // zetaCoegs are the expansion coefficients for Euler-Maclaurin summation 15 | // formula: 16 | // \frac{(2k)!}{B_{2k}} 17 | // where 18 | // B_{2k} 19 | // are Bernoulli numbers. 20 | var zetaCoefs = [...]float64{ 21 | 12.0, 22 | -720.0, 23 | 30240.0, 24 | -1209600.0, 25 | 47900160.0, 26 | -1.307674368e12 / 691, 27 | 7.47242496e10, 28 | -1.067062284288e16 / 3617, 29 | 5.109094217170944e18 / 43867, 30 | -8.028576626982912e20 / 174611, 31 | 1.5511210043330985984e23 / 854513, 32 | -1.6938241367317436694528e27 / 236364091, 33 | } 34 | 35 | // Zeta computes the Riemann zeta function of two arguments. 36 | // Zeta(x,q) = \sum_{k=0}^{\infty} (k+q)^{-x} 37 | // Note that Zeta returns +Inf if x is 1 and will panic if x is less than 1, 38 | // q is either zero or a negative integer, or q is negative and x is not an 39 | // integer. 40 | // 41 | // Note that: 42 | // zeta(x,1) = zetac(x) + 1 43 | func Zeta(x, q float64) float64 { 44 | // REFERENCE: Gradshteyn, I. S., and I. M. Ryzhik, Tables of Integrals, Series, 45 | // and Products, p. 1073; Academic Press, 1980. 46 | if x == 1 { 47 | return math.Inf(1) 48 | } 49 | 50 | if x < 1 { 51 | panic(badParamOutOfBounds) 52 | } 53 | 54 | if q <= 0 { 55 | if q == math.Floor(q) { 56 | panic(badParamFunctionSingularity) 57 | } 58 | if x != math.Floor(x) { 59 | panic(badParamOutOfBounds) // Because q^-x not defined 60 | } 61 | } 62 | 63 | // Asymptotic expansion: http://dlmf.nist.gov/25.11#E43 64 | if q > 1e8 { 65 | return (1/(x-1) + 1/(2*q)) * math.Pow(q, 1-x) 66 | } 67 | 68 | // The Euler-Maclaurin summation formula is used to obtain the expansion: 69 | // Zeta(x,q) = \sum_{k=1}^n (k+q)^{-x} + \frac{(n+q)^{1-x}}{x-1} - \frac{1}{2(n+q)^x} + \sum_{j=1}^{\infty} \frac{B_{2j}x(x+1)...(x+2j)}{(2j)! (n+q)^{x+2j+1}} 70 | // where 71 | // B_{2j} 72 | // are Bernoulli numbers. 73 | // Permit negative q but continue sum until n+q > 9. This case should be 74 | // handled by a reflection formula. If q<0 and x is an integer, there is a 75 | // relation to the polyGamma function. 76 | s := math.Pow(q, -x) 77 | a := q 78 | i := 0 79 | b := 0.0 80 | for i < 9 || a <= 9 { 81 | i++ 82 | a += 1.0 83 | b = math.Pow(a, -x) 84 | s += b 85 | if math.Abs(b/s) < machEp { 86 | return s 87 | } 88 | } 89 | 90 | w := a 91 | s += b * w / (x - 1) 92 | s -= 0.5 * b 93 | a = 1.0 94 | k := 0.0 95 | for _, coef := range zetaCoefs { 96 | a *= x + k 97 | b /= w 98 | t := a * b / coef 99 | s = s + t 100 | t = math.Abs(t / s) 101 | if t < machEp { 102 | return s 103 | } 104 | k += 1.0 105 | a *= x + k 106 | b /= w 107 | k += 1.0 108 | } 109 | return s 110 | } 111 | -------------------------------------------------------------------------------- /internal/gonum/beta.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package gonum 6 | 7 | import ( 8 | "math" 9 | ) 10 | 11 | // Beta returns the value of the complete beta function B(a, b). It is defined as 12 | // Γ(a)Γ(b) / Γ(a+b) 13 | // Special cases are: 14 | // B(a,b) returns NaN if a or b is Inf 15 | // B(a,b) returns NaN if a and b are 0 16 | // B(a,b) returns NaN if a or b is NaN 17 | // B(a,b) returns NaN if a or b is < 0 18 | // B(a,b) returns +Inf if a xor b is 0. 19 | // 20 | // See http://mathworld.wolfram.com/BetaFunction.html for more detailed information. 21 | func Beta(a, b float64) float64 { 22 | return math.Exp(Lbeta(a, b)) 23 | } 24 | 25 | // Lbeta returns the natural logarithm of the complete beta function B(a,b). 26 | // Lbeta is defined as: 27 | // Ln(Γ(a)Γ(b)/Γ(a+b)) 28 | // Special cases are: 29 | // Lbeta(a,b) returns NaN if a or b is Inf 30 | // Lbeta(a,b) returns NaN if a and b are 0 31 | // Lbeta(a,b) returns NaN if a or b is NaN 32 | // Lbeta(a,b) returns NaN if a or b is < 0 33 | // Lbeta(a,b) returns +Inf if a xor b is 0. 34 | func Lbeta(a, b float64) float64 { 35 | switch { 36 | case math.IsInf(a, +1) || math.IsInf(b, +1): 37 | return math.NaN() 38 | case a == 0 && b == 0: 39 | return math.NaN() 40 | case a < 0 || b < 0: 41 | return math.NaN() 42 | case math.IsNaN(a) || math.IsNaN(b): 43 | return math.NaN() 44 | case a == 0 || b == 0: 45 | return math.Inf(+1) 46 | } 47 | 48 | la, _ := math.Lgamma(a) 49 | lb, _ := math.Lgamma(b) 50 | lab, _ := math.Lgamma(a + b) 51 | return la + lb - lab 52 | } 53 | -------------------------------------------------------------------------------- /internal/gonum/doc.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2018 The Gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | // This repository is no longer maintained. 6 | // Development has moved to https://github.com/gonum/gonum. 7 | package gonum 8 | -------------------------------------------------------------------------------- /internal/gonum/gonum.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | // package gonum contains functions implemented by the gonum team. It is here to 6 | // avoid circular imports and/or double coding of functions. 7 | package gonum 8 | -------------------------------------------------------------------------------- /mvgamma.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import "math" 8 | 9 | const ( 10 | logPi = 1.14472988584940017414342735135305871164729481 // http://oeis.org/A053510 11 | ) 12 | 13 | // MvLgamma returns the log of the multivariate Gamma function. Dim 14 | // must be greater than zero, and MvLgamma will return NaN if v < (dim-1)/2. 15 | // 16 | // See https://en.wikipedia.org/wiki/Multivariate_gamma_function for more 17 | // information. 18 | func MvLgamma(v float64, dim int) float64 { 19 | if dim < 1 { 20 | panic("mathext: negative dimension") 21 | } 22 | df := float64(dim) 23 | if v < (df-1)*0.5 { 24 | return math.NaN() 25 | } 26 | ans := df * (df - 1) * 0.25 * logPi 27 | for i := 1; i <= dim; i++ { 28 | lg, _ := math.Lgamma(v + float64(1-i)*0.5) 29 | ans += lg 30 | } 31 | return ans 32 | } 33 | -------------------------------------------------------------------------------- /mvgamma_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "math" 9 | "testing" 10 | ) 11 | 12 | func TestMvLgamma(t *testing.T) { 13 | // Values compared with scipy 14 | for i, test := range []struct { 15 | v float64 16 | dim int 17 | ans float64 18 | }{ 19 | {10, 5, 58.893841851237397}, 20 | {3, 1, 0.69314718055994529}, 21 | } { 22 | ans := MvLgamma(test.v, test.dim) 23 | if math.Abs(test.ans-ans) > 1e-14 { 24 | t.Errorf("Case %v. got=%v want=%v.", i, ans, test.ans) 25 | } 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /roots.go: -------------------------------------------------------------------------------- 1 | // Derived from SciPy's special/c_misc/fsolve.c and special/c_misc/misc.h 2 | // https://github.com/scipy/scipy/blob/master/scipy/special/c_misc/fsolve.c 3 | // https://github.com/scipy/scipy/blob/master/scipy/special/c_misc/misc.h 4 | 5 | // Copyright ©2017 The gonum Authors. All rights reserved. 6 | // Use of this source code is governed by a BSD-style 7 | // license that can be found in the LICENSE file. 8 | 9 | package mathext 10 | 11 | import "math" 12 | 13 | type objectiveFunc func(float64, []float64) float64 14 | 15 | type fSolveResult uint8 16 | 17 | const ( 18 | // An exact solution was found, in which case the first point on the 19 | // interval is the value 20 | fSolveExact fSolveResult = iota + 1 21 | // Interval width is less than the tolerance 22 | fSolveConverged 23 | // Root-finding didn't converge in a set number of iterations 24 | fSolveMaxIterations 25 | ) 26 | 27 | const ( 28 | machEp = 1.0 / (1 << 53) 29 | ) 30 | 31 | // falsePosition uses a combination of bisection and false position to find a 32 | // root of a function within a given interval. This is guaranteed to converge, 33 | // and always keeps a bounding interval, unlike Newton's method. Inputs are: 34 | // x1, x2: initial bounding interval 35 | // f1, f2: value of f() at x1 and x2 36 | // absErr, relErr: absolute and relative errors on the bounding interval 37 | // bisectTil: if > 0.0, perform bisection until the width of the bounding 38 | // interval is less than this 39 | // f, fExtra: function to find root of is f(x, fExtra) 40 | // Returns: 41 | // result: whether an exact root was found, the process converged to a 42 | // bounding interval small than the required error, or the max number 43 | // of iterations was hit 44 | // bestX: best root approximation 45 | // bestF: function value at bestX 46 | // errEst: error estimation 47 | func falsePosition(x1, x2, f1, f2, absErr, relErr, bisectTil float64, f objectiveFunc, fExtra []float64) (fSolveResult, float64, float64, float64) { 48 | // The false position steps are either unmodified, or modified with the 49 | // Anderson-Bjorck method as appropiate. Theoretically, this has a "speed of 50 | // convergence" of 1.7 (bisection is 1, Newton is 2). 51 | // Note that this routine was designed initially to work with gammaincinv, so 52 | // it may not be tuned right for other problems. Don't use it blindly. 53 | 54 | if f1*f2 >= 0 { 55 | panic("Initial interval is not a bounding interval") 56 | } 57 | 58 | const ( 59 | maxIterations = 100 60 | bisectIter = 4 61 | bisectWidth = 4.0 62 | ) 63 | 64 | const ( 65 | bisect = iota + 1 66 | falseP 67 | ) 68 | 69 | var state uint8 70 | if bisectTil > 0 { 71 | state = bisect 72 | } else { 73 | state = falseP 74 | } 75 | 76 | gamma := 1.0 77 | 78 | w := math.Abs(x2 - x1) 79 | lastBisectWidth := w 80 | 81 | var nFalseP int 82 | var x3, f3, bestX, bestF float64 83 | for i := 0; i < maxIterations; i++ { 84 | switch state { 85 | case bisect: 86 | x3 = 0.5 * (x1 + x2) 87 | if x3 == x1 || x3 == x2 { 88 | // i.e., x1 and x2 are successive floating-point numbers 89 | bestX = x3 90 | if x3 == x1 { 91 | bestF = f1 92 | } else { 93 | bestF = f2 94 | } 95 | return fSolveConverged, bestX, bestF, w 96 | } 97 | 98 | f3 = f(x3, fExtra) 99 | if f3 == 0 { 100 | return fSolveExact, x3, f3, w 101 | } 102 | 103 | if f3*f2 < 0 { 104 | x1 = x2 105 | f1 = f2 106 | } 107 | x2 = x3 108 | f2 = f3 109 | w = math.Abs(x2 - x1) 110 | lastBisectWidth = w 111 | if bisectTil > 0 { 112 | if w < bisectTil { 113 | bisectTil = -1.0 114 | gamma = 1.0 115 | nFalseP = 0 116 | state = falseP 117 | } 118 | } else { 119 | gamma = 1.0 120 | nFalseP = 0 121 | state = falseP 122 | } 123 | case falseP: 124 | s12 := (f2 - gamma*f1) / (x2 - x1) 125 | x3 = x2 - f2/s12 126 | f3 = f(x3, fExtra) 127 | if f3 == 0 { 128 | return fSolveExact, x3, f3, w 129 | } 130 | 131 | nFalseP++ 132 | if f3*f2 < 0 { 133 | gamma = 1.0 134 | x1 = x2 135 | f1 = f2 136 | } else { 137 | // Anderson-Bjorck method 138 | g := 1.0 - f3/f2 139 | if g <= 0 { 140 | g = 0.5 141 | } 142 | gamma *= g 143 | } 144 | x2 = x3 145 | f2 = f3 146 | w = math.Abs(x2 - x1) 147 | 148 | // Sanity check. For every 4 false position checks, see if we really are 149 | // decreasing the interval by comparing to what bisection would have 150 | // achieved (or, rather, a bit more lenient than that -- interval 151 | // decreased by 4 instead of by 16, as the fp could be decreasing gamma 152 | // for a bit). Note that this should guarantee convergence, as it makes 153 | // sure that we always end up decreasing the interval width with a 154 | // bisection. 155 | if nFalseP > bisectIter { 156 | if w*bisectWidth > lastBisectWidth { 157 | state = bisect 158 | } 159 | nFalseP = 0 160 | lastBisectWidth = w 161 | } 162 | } 163 | 164 | tol := absErr + relErr*math.Max(math.Max(math.Abs(x1), math.Abs(x2)), 1.0) 165 | if w <= tol { 166 | if math.Abs(f1) < math.Abs(f2) { 167 | bestX = x1 168 | bestF = f1 169 | } else { 170 | bestX = x2 171 | bestF = f2 172 | } 173 | return fSolveConverged, bestX, bestF, w 174 | } 175 | } 176 | 177 | return fSolveMaxIterations, x3, f3, w 178 | } 179 | -------------------------------------------------------------------------------- /zeta.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import "github.com/gonum/mathext/internal/cephes" 8 | 9 | // Zeta computes the Riemann zeta function of two arguments. 10 | // Zeta(x,q) = \sum_{k=0}^{\infty} (k+q)^{-x} 11 | // Note that Zeta returns +Inf if x is 1 and will panic if x is less than 1, 12 | // q is either zero or a negative integer, or q is negative and x is not an 13 | // integer. 14 | // 15 | // See http://mathworld.wolfram.com/HurwitzZetaFunction.html 16 | // or https://en.wikipedia.org/wiki/Multiple_zeta_function#Two_parameters_case 17 | // for more detailed information. 18 | func Zeta(x, q float64) float64 { 19 | return cephes.Zeta(x, q) 20 | } 21 | -------------------------------------------------------------------------------- /zeta_test.go: -------------------------------------------------------------------------------- 1 | // Copyright ©2016 The gonum Authors. All rights reserved. 2 | // Use of this source code is governed by a BSD-style 3 | // license that can be found in the LICENSE file. 4 | 5 | package mathext 6 | 7 | import ( 8 | "math" 9 | "testing" 10 | ) 11 | 12 | func TestZeta(t *testing.T) { 13 | for i, test := range []struct { 14 | x, q, want float64 15 | }{ 16 | // Results computed using scipy.special.zeta 17 | {1, 1, math.Inf(1)}, 18 | {1.00001, 0.5, 100001.96352290553}, 19 | {1.0001, 25, 9996.8017690244506}, 20 | {1.001, 1, 1000.5772884760117}, 21 | {1.01, 10, 97.773405639173305}, 22 | {1.5, 2, 1.6123753486854886}, 23 | {1.5, 20, 0.45287361712938717}, 24 | {2, -0.7, 14.28618087263834}, 25 | {2.5, 0.5, 6.2471106345688137}, 26 | {5, 2.5, 0.013073166646113805}, 27 | {7.5, 5, 7.9463377443314306e-06}, 28 | {10, -0.5, 2048.0174503557578}, 29 | {10, 0.5, 1024.0174503557578}, 30 | {10, 7.5, 2.5578265694201971e-9}, 31 | {12, 2.5, 1.7089167198843551e-5}, 32 | {17, 0.5, 131072.00101513157}, 33 | {20, -2.5, 2097152.0006014798}, 34 | {20, 0.75, 315.3368689825316}, 35 | {25, 0.25, 1125899906842624.0}, 36 | {30, 1, 1.0000000009313275}, 37 | } { 38 | if got := Zeta(test.x, test.q); math.Abs(got-test.want) > 1e-10 { 39 | t.Errorf("test %d Zeta(%g, %g) failed: got %g want %g", i, test.x, test.q, got, test.want) 40 | } 41 | } 42 | } 43 | --------------------------------------------------------------------------------