lxsd / fvn

Download as
Browse Code ยป

Commit 81b5d24e17fc293b8cec1a36d024a68e6e6a4c26

Authored by daniau
1 parent 38581db0c3
Exists in master and in 3 other branches geevx, geevx_2020, multi

git-svn-id: https://lxsd.femto-st.fr/svn/fvn@31 b657c933-2333-4658-acf2-d3c7c2708721

Showing 4 changed files with 592 additions and 591 deletions Inline Diff

No preview for this file type
%\documentclass[a4paper,10pt]{article} 1 1 %\documentclass[a4paper,10pt]{article}
\documentclass[a4paper,english]{article} 2 2 \documentclass[a4paper,english]{article}
3 3
\usepackage[utf8]{inputenc} 4 4 \usepackage[utf8]{inputenc}
\usepackage{a4wide} 5 5 \usepackage{a4wide}
\usepackage{eurosym} 6 6 \usepackage{eurosym}
\usepackage{url} 7 7 \usepackage{url}
\usepackage[colorlinks=true,hyperfigures=true]{hyperref} 8 8 \usepackage[colorlinks=true,hyperfigures=true]{hyperref}
%\usepackage{aeguill} 9 9 %\usepackage{aeguill}
10 10
\usepackage{graphicx} 11 11 \usepackage{graphicx}
\usepackage{babel} 12 12 \usepackage{babel}
\makeatother 13 13 \makeatother
14 14
15 15
%opening 16 16 %opening
\title{FVN Documentation} 17 17 \title{FVN Documentation}
\author{William Daniau} 18 18 \author{William Daniau}
19 19
20 20
\begin{document} 21 21 \begin{document}
22 22
\maketitle 23 23 \maketitle
24 24
%\begin{abstract} 25 25 %\begin{abstract}
26 26
%\end{abstract} 27 27 %\end{abstract}
\tableofcontents 28 28 \tableofcontents
29 29
\section{Whatis fvn,licence,disclaimer etc} 30 30 \section{Whatis fvn,licence,disclaimer etc}
\subsection{Whatis fvn} 31 31 \subsection{Whatis fvn}
fvn is a Fortran95 mathematical module. It provides various usefull subroutine covering linear algebra, numerical integration, least square polynomial, spline interpolation, zero finding, special functions etc. 32 32 fvn is a Fortran95 mathematical module. It provides various usefull subroutine covering linear algebra, numerical integration, least square polynomial, spline interpolation, zero finding, special functions etc.
33 33
Most of the work is done by interfacing Lapack \url{http://www.netlib.org/lapack} which means that Lapack and Blas \url{http://www.netlib.org/blas} must be available on your system for linking fvn. If you use an AMD microprocessor, the good idea is to use ACML ( AMD Core Math Library \url{http://developer.amd.com/acml.jsp} which contains an optimized Blas/Lapack. Fvn also contains a slightly modified version of Quadpack \url{http://www.netlib.org/quadpack} for performing the numerical integration tasks. Finally the fnlib library \url{http://www.netlib.org/fn} has been added for special functions. 34 34 Most of the work is done by interfacing Lapack \url{http://www.netlib.org/lapack} which means that Lapack and Blas \url{http://www.netlib.org/blas} must be available on your system for linking fvn. If you use an AMD microprocessor, the good idea is to use ACML ( AMD Core Math Library \url{http://developer.amd.com/acml.jsp} which contains an optimized Blas/Lapack. Fvn also contains a slightly modified version of Quadpack \url{http://www.netlib.org/quadpack} for performing the numerical integration tasks. Finally the fnlib library \url{http://www.netlib.org/fn} has been added for special functions.
35 35
This module has been initially written for the use of the ``Acoustic and microsonic'' group leaded by Sylvain Ballandras in the Time and Frequency Department of institute Femto-ST \url{http://www.femto-st.fr/}. 36 36 This module has been initially written for the use of the ``Acoustic and microsonic'' group leaded by Sylvain Ballandras in the Time and Frequency Department of institute Femto-ST \url{http://www.femto-st.fr/}.
37 37
\subsection{Licence} 38 38 \subsection{Licence}
The licence of fvn is free. You can do whatever you want with this code as far as you credit the authors. 39 39 The licence of fvn is free. You can do whatever you want with this code as far as you credit the authors.
40 40
\subsubsection*{Authors} 41 41 \subsubsection*{Authors}
As of the day this manuel is written there's only one author of fvn :\newline 42 42 As of the day this manuel is written there's only one author of fvn :\newline
William Daniau\newline 43 43 William Daniau\newline
william.daniau@femto-st.fr\newline 44 44 william.daniau@femto-st.fr\newline
45 45
\subsection{Disclaimer} 46 46 \subsection{Disclaimer}
The usual disclaimer applied : This software is provided AS IS in the hope it will be usefull. Use it at your own risks. The authors should not be taken responsible of anything that may result by the use of this software. 47 47 The usual disclaimer applied : This software is provided AS IS in the hope it will be usefull. Use it at your own risks. The authors should not be taken responsible of anything that may result by the use of this software.
48 48
\section{Naming scheme and convention} 49 49 \section{Naming scheme and convention}
The naming scheme of the routines is as follow : 50 50 The naming scheme of the routines is as follow :
\begin{verbatim} 51 51 \begin{verbatim}
fvn_*_name() 52 52 fvn_*_name()
\end{verbatim} 53 53 \end{verbatim}
where * can be s,d,c or z. 54 54 where * can be s,d,c or z.
\begin{itemize} 55 55 \begin{itemize}
\item s is for single precision real (real,real*4,real(4),real(kind=4)) 56 56 \item s is for single precision real (real,real*4,real(4),real(kind=4))
\item d for double precision real (double precision,real*8,real(8),real(kind=8)) 57 57 \item d for double precision real (double precision,real*8,real(8),real(kind=8))
\item c for single precision complex (complex,complex*8,complex(4),complex(kind=4)) 58 58 \item c for single precision complex (complex,complex*8,complex(4),complex(kind=4))
\item z for double precision complex (double complex,complex*16,complex(8),complex(kind=8)) 59 59 \item z for double precision complex (double complex,complex*16,complex(8),complex(kind=8))
\end{itemize} 60 60 \end{itemize}
In the following description of subroutines parameters, input parameters are followed by (in), output parameters by (out) and parameters which are used as input and modified by the subroutine are followed by (inout). 61 61 In the following description of subroutines parameters, input parameters are followed by (in), output parameters by (out) and parameters which are used as input and modified by the subroutine are followed by (inout).
62 62
For each routine, there is a generic interface (simply remove \verb'_*' in the name), so using the specific routine is not mandatory. 63 63 For each routine, there is a generic interface (simply remove \verb'_*' in the name), so using the specific routine is not mandatory.
64 64
\section{Linear algebra} 65 65 \section{Linear algebra}
The linear algebra routines of fvn are an interface to lapack, which make it easier to use. 66 66 The linear algebra routines of fvn are an interface to lapack, which make it easier to use.
\subsection{Matrix inversion} 67 67 \subsection{Matrix inversion}
\begin{verbatim} 68 68 \begin{verbatim}
call fvn_matinv(d,a,inva,status) 69 69 call fvn_matinv(d,a,inva,status)
\end{verbatim} 70 70 \end{verbatim}
\begin{itemize} 71 71 \begin{itemize}
\item d (in) is an integer equal to the matrix rank 72 72 \item d (in) is an integer equal to the matrix rank
\item a (in) is a real or complex matrix. It will remain untouched. 73 73 \item a (in) is a real or complex matrix. It will remain untouched.
\item inva (out) is a real or complex matrix which contain the inverse of a at the end of the routine 74 74 \item inva (out) is a real or complex matrix which contain the inverse of a at the end of the routine
\item status (out) is an optional integer equal to zero if something went wrong 75 75 \item status (out) is an optional integer equal to zero if something went wrong
\end{itemize} 76 76 \end{itemize}
77 77
\subsubsection*{Example} 78 78 \subsubsection*{Example}
\begin{verbatim} 79 79 \begin{verbatim}
program inv 80 80 program inv
use fvn 81 81 use fvn
implicit none 82 82 implicit none
83 83
real(8),dimension(3,3) :: a,inva 84 84 real(8),dimension(3,3) :: a,inva
85 85
call random_number(a) 86 86 call random_number(a)
a=a*100 87 87 a=a*100
88 88
call fvn_matinv(3,a,inva) 89 89 call fvn_matinv(3,a,inva)
write (*,*) a 90 90 write (*,*) a
write (*,*) 91 91 write (*,*)
write (*,*) inva 92 92 write (*,*) inva
write (*,*) 93 93 write (*,*)
write (*,*) matmul(a,inva) 94 94 write (*,*) matmul(a,inva)
end program 95 95 end program
\end{verbatim} 96 96 \end{verbatim}
97 97
98 98
99 99
\subsection{Matrix determinants} 100 100 \subsection{Matrix determinants}
\begin{verbatim} 101 101 \begin{verbatim}
det=fvn_det(d,a,status) 102 102 det=fvn_det(d,a,status)
\end{verbatim} 103 103 \end{verbatim}
\begin{itemize} 104 104 \begin{itemize}
\item d (in) is an integer equal to the matrix rank 105 105 \item d (in) is an integer equal to the matrix rank
\item a (in) is a real or complex matrix. It will remain untouched. 106 106 \item a (in) is a real or complex matrix. It will remain untouched.
\item status (out) is an optional integer equal to zero if something went wrong 107 107 \item status (out) is an optional integer equal to zero if something went wrong
\end{itemize} 108 108 \end{itemize}
109 109
\subsubsection*{Example} 110 110 \subsubsection*{Example}
\begin{verbatim} 111 111 \begin{verbatim}
program det 112 112 program det
use fvn 113 113 use fvn
implicit none 114 114 implicit none
115 115
real(8),dimension(3,3) :: a 116 116 real(8),dimension(3,3) :: a
real(8) :: deta 117 117 real(8) :: deta
integer :: status 118 118 integer :: status
119 119
call random_number(a) 120 120 call random_number(a)
a=a*100 121 121 a=a*100
122 122
deta=fvn_det(3,a,status) 123 123 deta=fvn_det(3,a,status)
write (*,*) a 124 124 write (*,*) a
write (*,*) 125 125 write (*,*)
write (*,*) "Det = ",deta 126 126 write (*,*) "Det = ",deta
end program 127 127 end program
128 128
\end{verbatim} 129 129 \end{verbatim}
130 130
131 131
132 132
\subsection{Matrix condition} 133 133 \subsection{Matrix condition}
\begin{verbatim} 134 134 \begin{verbatim}
call fvn_matcon(d,a,rcond,status) 135 135 call fvn_matcon(d,a,rcond,status)
\end{verbatim} 136 136 \end{verbatim}
\begin{itemize} 137 137 \begin{itemize}
\item d (in) is an integer equal to the matrix rank 138 138 \item d (in) is an integer equal to the matrix rank
\item a (in) is a real or complex matrix. It will remain untouched. 139 139 \item a (in) is a real or complex matrix. It will remain untouched.
\item rcond (out) is a real of same kind as matrix a, it will contain the reciprocal condition number of the matrix 140 140 \item rcond (out) is a real of same kind as matrix a, it will contain the reciprocal condition number of the matrix
\item status (out) is an optional integer equal to zero if something went wrong 141 141 \item status (out) is an optional integer equal to zero if something went wrong
\end{itemize} 142 142 \end{itemize}
143 143
The reciprocal condition number is evaluated using the 1-norm and is define as in equation \ref{rconddef} 144 144 The reciprocal condition number is evaluated using the 1-norm and is define as in equation \ref{rconddef}
\begin{equation} 145 145 \begin{equation}
R = \frac{1}{norm(A)*norm(invA)} 146 146 R = \frac{1}{norm(A)*norm(invA)}
\label{rconddef} 147 147 \label{rconddef}
\end{equation} 148 148 \end{equation}
149 149
The 1-norm itself is defined as the maximum value of the columns absolute values (modulus for complex) sum as in equation \ref{l1norm} 150 150 The 1-norm itself is defined as the maximum value of the columns absolute values (modulus for complex) sum as in equation \ref{l1norm}
\begin{equation} 151 151 \begin{equation}
L1 = max_j ( \sum_i{\mid A(i,j)\mid} ) 152 152 L1 = max_j ( \sum_i{\mid A(i,j)\mid} )
\label{l1norm} 153 153 \label{l1norm}
\end{equation} 154 154 \end{equation}
155 155
\subsubsection*{Example} 156 156 \subsubsection*{Example}
\begin{verbatim} 157 157 \begin{verbatim}
program cond 158 158 program cond
use fvn 159 159 use fvn
implicit none 160 160 implicit none
161 161
real(8),dimension(3,3) :: a 162 162 real(8),dimension(3,3) :: a
real(8) :: rcond 163 163 real(8) :: rcond
integer :: status 164 164 integer :: status
165 165
call random_number(a) 166 166 call random_number(a)
a=a*100 167 167 a=a*100
168 168
call fvn_d_matcon(3,a,rcond,status) 169 169 call fvn_d_matcon(3,a,rcond,status)
write (*,*) a 170 170 write (*,*) a
write (*,*) 171 171 write (*,*)
write (*,*) "Cond = ",rcond 172 172 write (*,*) "Cond = ",rcond
end program 173 173 end program
174 174
\end{verbatim} 175 175 \end{verbatim}
176 176
177 177
\subsection{Eigenvalues/Eigenvectors} 178 178 \subsection{Eigenvalues/Eigenvectors}
\begin{verbatim} 179 179 \begin{verbatim}
call fvn_matev(d,a,evala,eveca,status) 180 180 call fvn_matev(d,a,evala,eveca,status)
\end{verbatim} 181 181 \end{verbatim}
\begin{itemize} 182 182 \begin{itemize}
\item d (in) is an integer equal to the matrix rank 183 183 \item d (in) is an integer equal to the matrix rank
\item a (in) is a real or complex matrix. It will remain untouched. 184 184 \item a (in) is a real or complex matrix. It will remain untouched.
\item evala (out) is a complex array of same kind as a. It contains the eigenvalues of matrix a 185 185 \item evala (out) is a complex array of same kind as a. It contains the eigenvalues of matrix a
\item eveca (out) is a complex matrix of same kind as a. Its columns are the eigenvectors of matrix a : eveca(:,j)=jth eigenvector associated with eigenvalue evala(j). 186 186 \item eveca (out) is a complex matrix of same kind as a. Its columns are the eigenvectors of matrix a : eveca(:,j)=jth eigenvector associated with eigenvalue evala(j).
\item status (out) is an optional integer equal to zero if something went wrong 187 187 \item status (out) is an optional integer equal to zero if something went wrong
\end{itemize} 188 188 \end{itemize}
189 189
\subsubsection*{Example} 190 190 \subsubsection*{Example}
\begin{verbatim} 191 191 \begin{verbatim}
program eigen 192 192 program eigen
use fvn 193 193 use fvn
implicit none 194 194 implicit none
195 195
real(8),dimension(3,3) :: a 196 196 real(8),dimension(3,3) :: a
complex(8),dimension(3) :: evala 197 197 complex(8),dimension(3) :: evala
complex(8),dimension(3,3) :: eveca 198 198 complex(8),dimension(3,3) :: eveca
integer :: status,i,j 199 199 integer :: status,i,j
200 200
call random_number(a) 201 201 call random_number(a)
a=a*100 202 202 a=a*100
203 203
call fvn_matev(3,a,evala,eveca,status) 204 204 call fvn_matev(3,a,evala,eveca,status)
write (*,*) a 205 205 write (*,*) a
write (*,*) 206 206 write (*,*)
do i=1,3 207 207 do i=1,3
write(*,*) "Eigenvalue ",i,evala(i) 208 208 write(*,*) "Eigenvalue ",i,evala(i)
write(*,*) "Associated Eigenvector :" 209 209 write(*,*) "Associated Eigenvector :"
do j=1,3 210 210 do j=1,3
write(*,*) eveca(j,i) 211 211 write(*,*) eveca(j,i)
end do 212 212 end do
write(*,*) 213 213 write(*,*)
end do 214 214 end do
215 215
end program 216 216 end program
217 217
\end{verbatim} 218 218 \end{verbatim}
219 219
220 220
\subsection{Sparse solving} 221 221 \subsection{Sparse solving}
By interfacing Tim Davis's SuiteSparse from university of Florida \url{http://www.cise.ufl.edu/research/sparse/SuiteSparse/} which is a reference for this kind of problems, fvn provides simple subroutines for solving linear sparse systems. 222 222 By interfacing Tim Davis's SuiteSparse from university of Florida \url{http://www.cise.ufl.edu/research/sparse/SuiteSparse/} which is a reference for this kind of problems, fvn provides simple subroutines for solving linear sparse systems.
223 223
The provided routines solves the equation $Ax=B$ where A is sparse and given in its triplet form. 224 224 The provided routines solves the equation $Ax=B$ where A is sparse and given in its triplet form.
225 225
\begin{verbatim} 226 226 \begin{verbatim}
call fvn_sparse_solve(n,nz,T,Ti,Tj,B,x,status) 227 227 call fvn_sparse_solve(n,nz,T,Ti,Tj,B,x,status)
\end{verbatim} 228 228 \end{verbatim}
\begin{itemize} 229 229 \begin{itemize}
\item For this family of subroutine the two letters (zl,zi,dl,di) of the specific interface name decribe the arguments's type. z is for complex(8), d for real(8), l for integer(8) and i for integer(4) 230 230 \item For this family of subroutine the two letters (zl,zi,dl,di) of the specific interface name decribe the arguments's type. z is for complex(8), d for real(8), l for integer(8) and i for integer(4)
\item n (in) is an integer equal to the matrix rank 231 231 \item n (in) is an integer equal to the matrix rank
\item nz (in) is an integer equal to the number of non-zero elements 232 232 \item nz (in) is an integer equal to the number of non-zero elements
\item T(nz) (in) is a complex/real array containing the non-zero elements 233 233 \item T(nz) (in) is a complex/real array containing the non-zero elements
\item Ti(nz),Tj(nz) (in) are the indexes of the corresponding element of T in the original matrix. 234 234 \item Ti(nz),Tj(nz) (in) are the indexes of the corresponding element of T in the original matrix.
\item B(n) (in) is a complex/real array containing the second member of the equation. 235 235 \item B(n) (in) is a complex/real array containing the second member of the equation.
\item x(n) (out) is a complex/real array containing the solution 236 236 \item x(n) (out) is a complex/real array containing the solution
\item status (out) is an integer which contain non-zero is something went wrong 237 237 \item status (out) is an integer which contain non-zero is something went wrong
\end{itemize} 238 238 \end{itemize}
239 239
\subsubsection*{Example} 240 240 \subsubsection*{Example}
\begin{verbatim} 241 241 \begin{verbatim}
program test_sparse 242 242 program test_sparse
243 243
use fvn 244 244 use fvn
implicit none 245 245 implicit none
246 246
integer(8), parameter :: nz=12 247 247 integer(8), parameter :: nz=12
integer(8), parameter :: n=5 248 248 integer(8), parameter :: n=5
complex(8),dimension(nz) :: A 249 249 complex(8),dimension(nz) :: A
integer(8),dimension(nz) :: Ti,Tj 250 250 integer(8),dimension(nz) :: Ti,Tj
complex(8),dimension(n) :: B,x 251 251 complex(8),dimension(n) :: B,x
integer(8) :: status 252 252 integer(8) :: status
253 253
A = (/ (2.,0.),(3.,0.),(3.,0.),(-1.,0.),(4.,0.),(4.,0.),(-3.,0.),& 254 254 A = (/ (2.,0.),(3.,0.),(3.,0.),(-1.,0.),(4.,0.),(4.,0.),(-3.,0.),&
(1.,0.),(2.,0.),(2.,0.),(6.,0.),(1.,0.) /) 255 255 (1.,0.),(2.,0.),(2.,0.),(6.,0.),(1.,0.) /)
B = (/ (8.,0.), (45.,0.), (-3.,0.), (3.,0.), (19.,0.)/) 256 256 B = (/ (8.,0.), (45.,0.), (-3.,0.), (3.,0.), (19.,0.)/)
Ti = (/ 1,2,1,3,5,2,3,4,5,3,2,5 /) 257 257 Ti = (/ 1,2,1,3,5,2,3,4,5,3,2,5 /)
Tj = (/ 1,1,2,2,2,3,3,3,3,4,5,5 /) 258 258 Tj = (/ 1,1,2,2,2,3,3,3,3,4,5,5 /)
259 259
!specific routine that will be used here 260 260 !specific routine that will be used here
!call fvn_zl_sparse_solve(n,nz,A,Ti,Tj,B,x,status) 261 261 !call fvn_zl_sparse_solve(n,nz,A,Ti,Tj,B,x,status)
call fvn_sparse_solve(n,nz,A,Ti,Tj,B,x,status) 262 262 call fvn_sparse_solve(n,nz,A,Ti,Tj,B,x,status)
write(*,*) x 263 263 write(*,*) x
264 264
end program 265 265 end program
266 266
267 267
program test_sparse 268 268 program test_sparse
269 269
use fvn 270 270 use fvn
implicit none 271 271 implicit none
272 272
integer(4), parameter :: nz=12 273 273 integer(4), parameter :: nz=12
integer(4), parameter :: n=5 274 274 integer(4), parameter :: n=5
real(8),dimension(nz) :: A 275 275 real(8),dimension(nz) :: A
integer(4),dimension(nz) :: Ti,Tj 276 276 integer(4),dimension(nz) :: Ti,Tj
real(8),dimension(n) :: B,x 277 277 real(8),dimension(n) :: B,x
integer(4) :: status 278 278 integer(4) :: status
279 279
A = (/ 2.,3.,3.,-1.,4.,4.,-3.,1.,2.,2.,6.,1. /) 280 280 A = (/ 2.,3.,3.,-1.,4.,4.,-3.,1.,2.,2.,6.,1. /)
B = (/ 8., 45., -3., 3., 19./) 281 281 B = (/ 8., 45., -3., 3., 19./)
Ti = (/ 1,2,1,3,5,2,3,4,5,3,2,5 /) 282 282 Ti = (/ 1,2,1,3,5,2,3,4,5,3,2,5 /)
Tj = (/ 1,1,2,2,2,3,3,3,3,4,5,5 /) 283 283 Tj = (/ 1,1,2,2,2,3,3,3,3,4,5,5 /)
284 284
!specific routine that will be used here 285 285 !specific routine that will be used here
!call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status) 286 286 !call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status)
call fvn_sparse_solve(n,nz,A,Ti,Tj,B,x,status) 287 287 call fvn_sparse_solve(n,nz,A,Ti,Tj,B,x,status)
write(*,*) x 288 288 write(*,*) x
289 289
end program 290 290 end program
291 291
292 292
293 293
\end{verbatim} 294 294 \end{verbatim}
295 295
\subsection{Identity matrix} 296 296 \subsection{Identity matrix}
\begin{verbatim} 297 297 \begin{verbatim}
I=fvn_ident(n) 298 298 I=fvn_*_ident(n) (*=s,d,c,z)
\end{verbatim} 299 299 \end{verbatim}
\begin{itemize} 300 300 \begin{itemize}
\item n (in) is an integer equal to the matrix rank 301 301 \item n (in) is an integer equal to the matrix rank
\end{itemize} 302 302 \end{itemize}
This function return the identity matrix of rank n, in the type of the left hand side. 303 303 This function return the identity matrix of rank n, in the type of the left hand side. No generic interface for this one.
304 304
305 305
306 306
\section{Interpolation} 307 307 \section{Interpolation}
308 308
\subsection{Quadratic Interpolation} 309 309 \subsection{Quadratic Interpolation}
fvn provide function for interpolating values of a tabulated function of 1, 2 or 3 variables, for both single and double precision. 310 310 fvn provide function for interpolating values of a tabulated function of 1, 2 or 3 variables, for both single and double precision.
\subsubsection{One variable function} 311 311 \subsubsection{One variable function}
\begin{verbatim} 312 312 \begin{verbatim}
value=fvn_quad_interpol(x,n,xdata,ydata) 313 313 value=fvn_quad_interpol(x,n,xdata,ydata)
\end{verbatim} 314 314 \end{verbatim}
\begin{itemize} 315 315 \begin{itemize}
\item x is the real where we want to evaluate the function 316 316 \item x is the real where we want to evaluate the function
\item n is the number of tabulated values 317 317 \item n is the number of tabulated values
\item xdata(n) contains the tabulated coordinates 318 318 \item xdata(n) contains the tabulated coordinates
\item ydata(n) contains the tabulated function values ydata(i)=y(xdata(i)) 319 319 \item ydata(n) contains the tabulated function values ydata(i)=y(xdata(i))
\end{itemize} 320 320 \end{itemize}
xdata must be strictly increasingly ordered. 321 321 xdata must be strictly increasingly ordered.
x must be within the range of xdata to actually perform an interpolation, otherwise the resulting value is an extrapolation 322 322 x must be within the range of xdata to actually perform an interpolation, otherwise the resulting value is an extrapolation
\paragraph*{Example} 323 323 \paragraph*{Example}
\begin{verbatim} 324 324 \begin{verbatim}
program inter1d 325 325 program inter1d
326 326
use fvn 327 327 use fvn
implicit none 328 328 implicit none
329 329
integer(kind=4),parameter :: ndata=33 330 330 integer(kind=4),parameter :: ndata=33
integer(kind=4) :: i,nout 331 331 integer(kind=4) :: i,nout
real(kind=8) :: f,fdata(ndata),h,pi,q,sin,x,xdata(ndata) 332 332 real(kind=8) :: f,fdata(ndata),h,pi,q,sin,x,xdata(ndata)
real(kind=8) ::tv 333 333 real(kind=8) ::tv
334 334
intrinsic sin 335 335 intrinsic sin
336 336
f(x)=sin(x) 337 337 f(x)=sin(x)
338 338
xdata(1)=0. 339 339 xdata(1)=0.
fdata(1)=f(xdata(1)) 340 340 fdata(1)=f(xdata(1))
h=1./32. 341 341 h=1./32.
do i=2,ndata 342 342 do i=2,ndata
xdata(i)=xdata(i-1)+h 343 343 xdata(i)=xdata(i-1)+h
fdata(i)=f(xdata(i)) 344 344 fdata(i)=f(xdata(i))
end do 345 345 end do
call random_seed() 346 346 call random_seed()
call random_number(x) 347 347 call random_number(x)
348 348
q=fvn_d_quad_interpol(x,ndata,xdata,fdata) 349 349 q=fvn_d_quad_interpol(x,ndata,xdata,fdata)
350 350
tv=f(x) 351 351 tv=f(x)
write(*,*) "x ",x 352 352 write(*,*) "x ",x
write(*,*) "Calculated (real) value :",tv 353 353 write(*,*) "Calculated (real) value :",tv
write(*,*) "fvn interpolation :",q 354 354 write(*,*) "fvn interpolation :",q
write(*,*) "Relative fvn error :",abs((q-tv)/tv) 355 355 write(*,*) "Relative fvn error :",abs((q-tv)/tv)
356 356
end program 357 357 end program
358 358
\end{verbatim} 359 359 \end{verbatim}
360 360
361 361
\subsubsection{Two variables function} 362 362 \subsubsection{Two variables function}
\begin{verbatim} 363 363 \begin{verbatim}
value=fvn_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata) 364 364 value=fvn_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata)
\end{verbatim} 365 365 \end{verbatim}
\begin{itemize} 366 366 \begin{itemize}
\item x,y are the real coordinates where we want to evaluate the function 367 367 \item x,y are the real coordinates where we want to evaluate the function
\item nx is the number of tabulated values along x axis 368 368 \item nx is the number of tabulated values along x axis
\item xdata(nx) contains the tabulated x 369 369 \item xdata(nx) contains the tabulated x
\item ny is the number of tabulated values along y axis 370 370 \item ny is the number of tabulated values along y axis
\item ydata(ny) contains the tabulated y 371 371 \item ydata(ny) contains the tabulated y
\item zdata(nx,ny) contains the tabulated function values zdata(i,j)=z(xdata(i),ydata(j)) 372 372 \item zdata(nx,ny) contains the tabulated function values zdata(i,j)=z(xdata(i),ydata(j))
\end{itemize} 373 373 \end{itemize}
xdata and ydata must be strictly increasingly ordered. 374 374 xdata and ydata must be strictly increasingly ordered.
(x,y) must be within the range of xdata and ydata to actually perform an interpolation, otherwise the resulting value is an extrapolation 375 375 (x,y) must be within the range of xdata and ydata to actually perform an interpolation, otherwise the resulting value is an extrapolation
376 376
\paragraph*{Example} 377 377 \paragraph*{Example}
378 378
\begin{verbatim} 379 379 \begin{verbatim}
program inter2d 380 380 program inter2d
use fvn 381 381 use fvn
implicit none 382 382 implicit none
383 383
integer(kind=4),parameter :: nx=21,ny=42 384 384 integer(kind=4),parameter :: nx=21,ny=42
integer(kind=4) :: i,j 385 385 integer(kind=4) :: i,j
real(kind=8) :: f,fdata(nx,ny),dble,pi,q,sin,x,xdata(nx),y,ydata(ny) 386 386 real(kind=8) :: f,fdata(nx,ny),dble,pi,q,sin,x,xdata(nx),y,ydata(ny)
real(kind=8) :: tv 387 387 real(kind=8) :: tv
388 388
intrinsic dble,sin 389 389 intrinsic dble,sin
390 390
f(x,y)=sin(x+2.*y) 391 391 f(x,y)=sin(x+2.*y)
do i=1,nx 392 392 do i=1,nx
xdata(i)=dble(i-1)/dble(nx-1) 393 393 xdata(i)=dble(i-1)/dble(nx-1)
end do 394 394 end do
do i=1,ny 395 395 do i=1,ny
ydata(i)=dble(i-1)/dble(ny-1) 396 396 ydata(i)=dble(i-1)/dble(ny-1)
end do 397 397 end do
do i=1,nx 398 398 do i=1,nx
do j=1,ny 399 399 do j=1,ny
fdata(i,j)=f(xdata(i),ydata(j)) 400 400 fdata(i,j)=f(xdata(i),ydata(j))
end do 401 401 end do
end do 402 402 end do
call random_seed() 403 403 call random_seed()
call random_number(x) 404 404 call random_number(x)
call random_number(y) 405 405 call random_number(y)
406 406
q=fvn_d_quad_2d_interpol(x,y,nx,xdata,ny,ydata,fdata) 407 407 q=fvn_d_quad_2d_interpol(x,y,nx,xdata,ny,ydata,fdata)
tv=f(x,y) 408 408 tv=f(x,y)
409 409
write(*,*) "x y",x,y 410 410 write(*,*) "x y",x,y
write(*,*) "Calculated (real) value :",tv 411 411 write(*,*) "Calculated (real) value :",tv
write(*,*) "fvn interpolation :",q 412 412 write(*,*) "fvn interpolation :",q
write(*,*) "Relative fvn error :",abs((q-tv)/tv) 413 413 write(*,*) "Relative fvn error :",abs((q-tv)/tv)
414 414
end program 415 415 end program
416 416
\end{verbatim} 417 417 \end{verbatim}
418 418
419 419
420 420
\subsubsection{Three variables function} 421 421 \subsubsection{Three variables function}
\begin{verbatim} 422 422 \begin{verbatim}
value=fvn_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata) 423 423 value=fvn_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata)
\end{verbatim} 424 424 \end{verbatim}
\begin{itemize} 425 425 \begin{itemize}
\item x,y,z are the real coordinates where we want to evaluate the function 426 426 \item x,y,z are the real coordinates where we want to evaluate the function
\item nx is the number of tabulated values along x axis 427 427 \item nx is the number of tabulated values along x axis
\item xdata(nx) contains the tabulated x 428 428 \item xdata(nx) contains the tabulated x
\item ny is the number of tabulated values along y axis 429 429 \item ny is the number of tabulated values along y axis
\item ydata(ny) contains the tabulated y 430 430 \item ydata(ny) contains the tabulated y
\item nz is the number of tabulated values along z axis 431 431 \item nz is the number of tabulated values along z axis
\item zdata(ny) contains the tabulated z 432 432 \item zdata(ny) contains the tabulated z
\item tdata(nx,ny,nz) contains the tabulated function values tdata(i,j,k)=t(xdata(i),ydata(j),zdata(k)) 433 433 \item tdata(nx,ny,nz) contains the tabulated function values tdata(i,j,k)=t(xdata(i),ydata(j),zdata(k))
\end{itemize} 434 434 \end{itemize}
xdata, ydata and zdata must be strictly increasingly ordered. 435 435 xdata, ydata and zdata must be strictly increasingly ordered.
(x,y,z) must be within the range of xdata and ydata to actually perform an interpolation, otherwise the resulting value is an extrapolation 436 436 (x,y,z) must be within the range of xdata and ydata to actually perform an interpolation, otherwise the resulting value is an extrapolation
437 437
\paragraph*{Example} 438 438 \paragraph*{Example}
\begin{verbatim} 439 439 \begin{verbatim}
program inter3d 440 440 program inter3d
use fvn 441 441 use fvn
442 442
implicit none 443 443 implicit none
444 444
integer(kind=4),parameter :: nx=21,ny=42,nz=18 445 445 integer(kind=4),parameter :: nx=21,ny=42,nz=18
integer(kind=4) :: i,j,k 446 446 integer(kind=4) :: i,j,k
real(kind=8) :: f,fdata(nx,ny,nz),dble,pi,q,sin,x,xdata(nx),y,ydata(ny),z,zdata(nz) 447 447 real(kind=8) :: f,fdata(nx,ny,nz),dble,pi,q,sin,x,xdata(nx),y,ydata(ny),z,zdata(nz)
real(kind=8) :: tv 448 448 real(kind=8) :: tv
449 449
intrinsic dble,sin 450 450 intrinsic dble,sin
451 451
f(x,y,z)=sin(x+2.*y+3.*z) 452 452 f(x,y,z)=sin(x+2.*y+3.*z)
do i=1,nx 453 453 do i=1,nx
xdata(i)=2.*(dble(i-1)/dble(nx-1)) 454 454 xdata(i)=2.*(dble(i-1)/dble(nx-1))
end do 455 455 end do
do i=1,ny 456 456 do i=1,ny
ydata(i)=2.*(dble(i-1)/dble(ny-1)) 457 457 ydata(i)=2.*(dble(i-1)/dble(ny-1))
end do 458 458 end do
do i=1,nz 459 459 do i=1,nz
zdata(i)=2.*(dble(i-1)/dble(nz-1)) 460 460 zdata(i)=2.*(dble(i-1)/dble(nz-1))
end do 461 461 end do
do i=1,nx 462 462 do i=1,nx
do j=1,ny 463 463 do j=1,ny
do k=1,nz 464 464 do k=1,nz
fdata(i,j,k)=f(xdata(i),ydata(j),zdata(k)) 465 465 fdata(i,j,k)=f(xdata(i),ydata(j),zdata(k))
end do 466 466 end do
end do 467 467 end do
end do 468 468 end do
call random_seed() 469 469 call random_seed()
call random_number(x) 470 470 call random_number(x)
call random_number(y) 471 471 call random_number(y)
call random_number(z) 472 472 call random_number(z)
473 473
q=fvn_d_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,fdata) 474 474 q=fvn_d_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,fdata)
tv=f(x,y,z) 475 475 tv=f(x,y,z)
476 476
write(*,*) "x y z",x,y,z 477 477 write(*,*) "x y z",x,y,z
write(*,*) "Calculated (real) value :",tv 478 478 write(*,*) "Calculated (real) value :",tv
write(*,*) "fvn interpolation :",q 479 479 write(*,*) "fvn interpolation :",q
write(*,*) "Relative fvn error :",abs((q-tv)/tv) 480 480 write(*,*) "Relative fvn error :",abs((q-tv)/tv)
481 481
end program 482 482 end program
483 483
\end{verbatim} 484 484 \end{verbatim}
485 485
\subsubsection{Utility procedure} 486 486 \subsubsection{Utility procedure}
fvn provides a simple utility procedure to locate the interval in which a value is located in an increasingly ordered array. 487 487 fvn provides a simple utility procedure to locate the interval in which a value is located in an increasingly ordered array.
\begin{verbatim} 488 488 \begin{verbatim}
call fvn_find_interval(x,i,xdata,n) 489 489 call fvn_find_interval(x,i,xdata,n)
\end{verbatim} 490 490 \end{verbatim}
\begin{itemize} 491 491 \begin{itemize}
\item x (in) the real value to locate 492 492 \item x (in) the real value to locate
\item i (out) the resulting indice 493 493 \item i (out) the resulting indice
\item xdata(n) (in) increasingly ordered array 494 494 \item xdata(n) (in) increasingly ordered array
\item n (in) size of the array 495 495 \item n (in) size of the array
\end{itemize} 496 496 \end{itemize}
The resulting integer i is as : $xdata(i) <= x < xdata(i+1)$. If $x < xdata(1)$ then $i=0$ is returned. If $x > xdata(n)$ then $i=n$ is returned. Finally if $x=xdata(n)$ then $i=n-1$ is returned. 497 497 The resulting integer i is as : $xdata(i) <= x < xdata(i+1)$. If $x < xdata(1)$ then $i=0$ is returned. If $x > xdata(n)$ then $i=n$ is returned. Finally if $x=xdata(n)$ then $i=n-1$ is returned.
498 498
499 499
500 500
\subsection{Akima spline} 501 501 \subsection{Akima spline}
fvn provides Akima spline interpolation and evaluation for both single and double precision real. 502 502 fvn provides Akima spline interpolation and evaluation for both single and double precision real.
\subsubsection{Interpolation} 503 503 \subsubsection{Interpolation}
\begin{verbatim} 504 504 \begin{verbatim}
call fvn_akima(n,x,y,br,co) 505 505 call fvn_akima(n,x,y,br,co)
\end{verbatim} 506 506 \end{verbatim}
\begin{itemize} 507 507 \begin{itemize}
\item n (in) is an integer equal to the number of points 508 508 \item n (in) is an integer equal to the number of points
\item x(n) (in) ,y(n) (in) are the known couples of coordinates 509 509 \item x(n) (in) ,y(n) (in) are the known couples of coordinates
\item br (out) on output contains a copy of x 510 510 \item br (out) on output contains a copy of x
\item co(4,n) (out) is a real matrix containing the 4 coefficients of the Akima interpolation spline for a given interval. 511 511 \item co(4,n) (out) is a real matrix containing the 4 coefficients of the Akima interpolation spline for a given interval.
\end{itemize} 512 512 \end{itemize}
513 513
\subsubsection{Evaluation} 514 514 \subsubsection{Evaluation}
\begin{verbatim} 515 515 \begin{verbatim}
y=fvn_spline_eval(x,n,br,co) 516 516 y=fvn_spline_eval(x,n,br,co)
\end{verbatim} 517 517 \end{verbatim}
\begin{itemize} 518 518 \begin{itemize}
\item x (in) is the point where we want to evaluate 519 519 \item x (in) is the point where we want to evaluate
\item n (in) is the number of known points and br(n) (in), co(4,n) (in) \\ 520 520 \item n (in) is the number of known points and br(n) (in), co(4,n) (in) \\
are the outputs of fvn\_x\_akima(n,x,y,br,co) 521 521 are the outputs of fvn\_x\_akima(n,x,y,br,co)
\end{itemize} 522 522 \end{itemize}
523 523
\subsubsection{Example} 524 524 \subsubsection{Example}
In the following example we will use Akima splines to interpolate a sinus function with 30 points between -10 and 10. We then use the evaluation function to calculate the coordinates of 1000 points between -11 and 11, and write a 3 columns file containing : x, calculated sin(x), interpolation evaluation of sin(x). 525 525 In the following example we will use Akima splines to interpolate a sinus function with 30 points between -10 and 10. We then use the evaluation function to calculate the coordinates of 1000 points between -11 and 11, and write a 3 columns file containing : x, calculated sin(x), interpolation evaluation of sin(x).
526 526
One can see that the interpolation is very efficient even with only 30 points. Of course as soon as we leave the -10 to 10 interval, the values are extrapolated and thus can lead to very inacurrate values. 527 527 One can see that the interpolation is very efficient even with only 30 points. Of course as soon as we leave the -10 to 10 interval, the values are extrapolated and thus can lead to very inacurrate values.
528 528
\begin{verbatim} 529 529 \begin{verbatim}
program akima 530 530 program akima
use fvn 531 531 use fvn
implicit none 532 532 implicit none
533 533
integer :: nbpoints,nppoints,i 534 534 integer :: nbpoints,nppoints,i
real(8),dimension(:),allocatable :: x_d,y_d,breakpoints_d 535 535 real(8),dimension(:),allocatable :: x_d,y_d,breakpoints_d
real(8),dimension(:,:),allocatable :: coeff_fvn_d 536 536 real(8),dimension(:,:),allocatable :: coeff_fvn_d
real(8) :: xstep_d,xp_d,ty_d,fvn_y_d 537 537 real(8) :: xstep_d,xp_d,ty_d,fvn_y_d
538 538
open(2,file='fvn_akima_double.dat') 539 539 open(2,file='fvn_akima_double.dat')
open(3,file='fvn_akima_breakpoints_double.dat') 540 540 open(3,file='fvn_akima_breakpoints_double.dat')
nbpoints=30 541 541 nbpoints=30
allocate(x_d(nbpoints)) 542 542 allocate(x_d(nbpoints))
allocate(y_d(nbpoints)) 543 543 allocate(y_d(nbpoints))
allocate(breakpoints_d(nbpoints)) 544 544 allocate(breakpoints_d(nbpoints))
allocate(coeff_fvn_d(4,nbpoints)) 545 545 allocate(coeff_fvn_d(4,nbpoints))
546 546
xstep_d=20./dfloat(nbpoints) 547 547 xstep_d=20./dfloat(nbpoints)
do i=1,nbpoints 548 548 do i=1,nbpoints
x_d(i)=-10.+dfloat(i)*xstep_d 549 549 x_d(i)=-10.+dfloat(i)*xstep_d
y_d(i)=dsin(x_d(i)) 550 550 y_d(i)=dsin(x_d(i))
write(3,44) (x_d(i),y_d(i)) 551 551 write(3,44) (x_d(i),y_d(i))
end do 552 552 end do
close(3) 553 553 close(3)
554 554
call fvn_d_akima(nbpoints,x_d,y_d,breakpoints_d,coeff_fvn_d) 555 555 call fvn_d_akima(nbpoints,x_d,y_d,breakpoints_d,coeff_fvn_d)
556 556
nppoints=1000 557 557 nppoints=1000
xstep_d=22./dfloat(nppoints) 558 558 xstep_d=22./dfloat(nppoints)
do i=1,nppoints 559 559 do i=1,nppoints
xp_d=-11.+dfloat(i)*xstep_d 560 560 xp_d=-11.+dfloat(i)*xstep_d
ty_d=dsin(xp_d) 561 561 ty_d=dsin(xp_d)
fvn_y_d=fvn_d_spline_eval(xp_d,nbpoints-1,breakpoints_d,coeff_fvn_d) 562 562 fvn_y_d=fvn_d_spline_eval(xp_d,nbpoints-1,breakpoints_d,coeff_fvn_d)
write(2,44) (xp_d,ty_d,fvn_y_d) 563 563 write(2,44) (xp_d,ty_d,fvn_y_d)
end do 564 564 end do
565 565
close(2) 566 566 close(2)
567 567
44 FORMAT(4(1X,1PE22.14)) 568 568 44 FORMAT(4(1X,1PE22.14))
569 569
end program 570 570 end program
571 571
\end{verbatim} 572 572 \end{verbatim}
Results are plotted on figure \ref{akima} 573 573 Results are plotted on figure \ref{akima}
574 574
\begin{figure} 575 575 \begin{figure}
\begin{center} 576 576 \begin{center}
\includegraphics[width=0.9\textwidth]{akima.pdf} 577 577 \includegraphics[width=0.9\textwidth]{akima.pdf}
% akima.pdf: 504x720 pixel, 72dpi, 17.78x25.40 cm, bb=0 0 504 720 578 578 % akima.pdf: 504x720 pixel, 72dpi, 17.78x25.40 cm, bb=0 0 504 720
\caption{Akima Spline Interpolation} 579 579 \caption{Akima Spline Interpolation}
\label{akima} 580 580 \label{akima}
\end{center} 581 581 \end{center}
582 582
\end{figure} 583 583 \end{figure}
584 584
585 585
586 586
\section{Least square polynomial} 587 587 \section{Least square polynomial}
fvn provide a function to find a least square polynomial of a given degree, for real in single or double precision. It is performed using Lapack subroutine sgelss (dgelss), which solve this problem using singular value decomposition. 588 588 fvn provide a function to find a least square polynomial of a given degree, for real in single or double precision. It is performed using Lapack subroutine sgelss (dgelss), which solve this problem using singular value decomposition.
589 589
\begin{verbatim} 590 590 \begin{verbatim}
call fvn_lspoly(np,x,y,deg,coeff,status) 591 591 call fvn_lspoly(np,x,y,deg,coeff,status)
\end{verbatim} 592 592 \end{verbatim}
\begin{itemize} 593 593 \begin{itemize}
\item np (in) is an integer equal to the number of points 594 594 \item np (in) is an integer equal to the number of points
\item x(np) (in),y(np) (in) are the known coordinates 595 595 \item x(np) (in),y(np) (in) are the known coordinates
\item deg (in) is an integer equal to the degree of the desired polynomial, it must be lower than np. 596 596 \item deg (in) is an integer equal to the degree of the desired polynomial, it must be lower than np.
\item coeff(deg+1) (out) on output contains the polynomial coefficients 597 597 \item coeff(deg+1) (out) on output contains the polynomial coefficients
\item status (out) is an integer containing 0 if a problem occured. 598 598 \item status (out) is an integer containing 0 if a problem occured.
\end{itemize} 599 599 \end{itemize}
600 600
\subsection*{Example} 601 601 \subsection*{Example}
Here's a simple example : we've got 13 measurement points and we want to find the least square degree 3 polynomial for these points : 602 602 Here's a simple example : we've got 13 measurement points and we want to find the least square degree 3 polynomial for these points :
\begin{verbatim} 603 603 \begin{verbatim}
program lsp 604 604 program lsp
use fvn 605 605 use fvn
implicit none 606 606 implicit none
607 607
integer,parameter :: npoints=13,deg=3 608 608 integer,parameter :: npoints=13,deg=3
integer :: status,i 609 609 integer :: status,i
real(kind=8) :: xm(npoints),ym(npoints),xstep,xc,yc 610 610 real(kind=8) :: xm(npoints),ym(npoints),xstep,xc,yc
real(kind=8) :: coeff(deg+1) 611 611 real(kind=8) :: coeff(deg+1)
612 612
xm = (/ -3.8,-2.7,-2.2,-1.9,-1.1,-0.7,0.5,1.7,2.,2.8,3.2,3.8,4. /) 613 613 xm = (/ -3.8,-2.7,-2.2,-1.9,-1.1,-0.7,0.5,1.7,2.,2.8,3.2,3.8,4. /)
ym = (/ -3.1,-2.,-0.9,0.8,1.8,0.4,2.1,1.8,3.2,2.8,3.9,5.2,7.5 /) 614 614 ym = (/ -3.1,-2.,-0.9,0.8,1.8,0.4,2.1,1.8,3.2,2.8,3.9,5.2,7.5 /)
615 615
open(2,file='fvn_lsp_double_mesure.dat') 616 616 open(2,file='fvn_lsp_double_mesure.dat')
open(3,file='fvn_lsp_double_poly.dat') 617 617 open(3,file='fvn_lsp_double_poly.dat')
618 618
do i=1,npoints 619 619 do i=1,npoints
write(2,44) xm(i),ym(i) 620 620 write(2,44) xm(i),ym(i)
end do 621 621 end do
close(2) 622 622 close(2)
623 623
624 624
call fvn_d_lspoly(npoints,xm,ym,deg,coeff,status) 625 625 call fvn_d_lspoly(npoints,xm,ym,deg,coeff,status)
626 626
xstep=(xm(npoints)-xm(1))/1000. 627 627 xstep=(xm(npoints)-xm(1))/1000.
do i=1,1000 628 628 do i=1,1000
xc=xm(1)+(i-1)*xstep 629 629 xc=xm(1)+(i-1)*xstep
yc=poly(xc,coeff) 630 630 yc=poly(xc,coeff)
write(3,44) xc,yc 631 631 write(3,44) xc,yc
end do 632 632 end do
close(3) 633 633 close(3)
634 634
44 FORMAT(4(1X,1PE22.14)) 635 635 44 FORMAT(4(1X,1PE22.14))
636 636
contains 637 637 contains
function poly(x,coeff) 638 638 function poly(x,coeff)
implicit none 639 639 implicit none
real(8) :: x 640 640 real(8) :: x
real(8) :: coeff(deg+1) 641 641 real(8) :: coeff(deg+1)
real(8) :: poly 642 642 real(8) :: poly
integer :: i 643 643 integer :: i
644 644
poly=0. 645 645 poly=0.
646 646
do i=1,deg+1 647 647 do i=1,deg+1
poly=poly+coeff(i)*x**(i-1) 648 648 poly=poly+coeff(i)*x**(i-1)
end do 649 649 end do
650 650
end function 651 651 end function
end program 652 652 end program
\end{verbatim} 653 653 \end{verbatim}
The results are plotted on figure \ref{lsp} . 654 654 The results are plotted on figure \ref{lsp} .
655 655
\begin{figure} 656 656 \begin{figure}
\begin{center} 657 657 \begin{center}
\includegraphics[width=0.9\textwidth]{lsp.pdf} 658 658 \includegraphics[width=0.9\textwidth]{lsp.pdf}
\caption{Least Square Polynomial} 659 659 \caption{Least Square Polynomial}
\label{lsp} 660 660 \label{lsp}
\end{center} 661 661 \end{center}
\end{figure} 662 662 \end{figure}
663 663
664 664
665 665
\section{Zero finding} 666 666 \section{Zero finding}
fvn provide a routine for finding zeros of a complex function using Muller algorithm (only for double complex type). It is based on a version provided on the web by Hans D Mittelmann \url{http://plato.asu.edu/ftp/other\_software/muller.f}. 667 667 fvn provide a routine for finding zeros of a complex function using Muller algorithm (only for double complex type). It is based on a version provided on the web by Hans D Mittelmann \url{http://plato.asu.edu/ftp/other\_software/muller.f}.
668 668
\begin{verbatim} 669 669 \begin{verbatim}
call fvn_muller(f,eps,eps1,kn,nguess,n,x,itmax,infer,ier) 670 670 call fvn_muller(f,eps,eps1,kn,nguess,n,x,itmax,infer,ier)
\end{verbatim} 671 671 \end{verbatim}
\begin{itemize} 672 672 \begin{itemize}
\item f (in) is the complex function (kind=8) for which we search zeros 673 673 \item f (in) is the complex function (kind=8) for which we search zeros
\item eps (in) is a real(8) corresponding to the first stopping criterion : let fp(z)=f(z)/p where p = (z-z(1))*(z-z(2))*,,,*(z-z(k-1)) and z(1),...,z(k-1) are previously found roots. if ((cdabs(f(z)).le.eps) .and. (cdabs(fp(z)).le.eps)), then z is accepted as a root. 674 674 \item eps (in) is a real(8) corresponding to the first stopping criterion : let fp(z)=f(z)/p where p = (z-z(1))*(z-z(2))*,,,*(z-z(k-1)) and z(1),...,z(k-1) are previously found roots. if ((cdabs(f(z)).le.eps) .and. (cdabs(fp(z)).le.eps)), then z is accepted as a root.
\item eps1 (in) is a real(8) corresponding to the second stopping criterion : a root is accepted if two successive approximations to a given root agree within eps1. Note that if either or both of the stopping criteria are fulfilled, the root is accepted. 675 675 \item eps1 (in) is a real(8) corresponding to the second stopping criterion : a root is accepted if two successive approximations to a given root agree within eps1. Note that if either or both of the stopping criteria are fulfilled, the root is accepted.
\item kn (in) is an integer equal to the number of known roots, which must be stored in x(1),...,x(kn), prior to entry in the subroutine. 676 676 \item kn (in) is an integer equal to the number of known roots, which must be stored in x(1),...,x(kn), prior to entry in the subroutine.
\item nguess (in) is the number of initial guesses provided. These guesses must be stored in x(kn+1),...,x(kn+nguess). nguess must be set equal to zero if no guesses are provided. 677 677 \item nguess (in) is the number of initial guesses provided. These guesses must be stored in x(kn+1),...,x(kn+nguess). nguess must be set equal to zero if no guesses are provided.
\item n (in) is an integer equal to the number of new roots to be found. 678 678 \item n (in) is an integer equal to the number of new roots to be found.
\item x (inout) is a complex(8) vector of length kn+n. x(1),...,x(kn) on input must contain any known roots. x(kn+1),..., x(kn+n) on input may, on user option, contain initial guesses for the n new roots which are to be computed. If the user does not provide an initial guess, zero is used. On output, x(kn+1),...,x(kn+n) contain the approximate roots found by the subroutine. 679 679 \item x (inout) is a complex(8) vector of length kn+n. x(1),...,x(kn) on input must contain any known roots. x(kn+1),..., x(kn+n) on input may, on user option, contain initial guesses for the n new roots which are to be computed. If the user does not provide an initial guess, zero is used. On output, x(kn+1),...,x(kn+n) contain the approximate roots found by the subroutine.
\item itmax (in) is an integer equal to the maximum allowable number of iterations per root. 680 680 \item itmax (in) is an integer equal to the maximum allowable number of iterations per root.
\item infer (out) is an integer vector of size kn+n. On output infer(j) contains the number of iterations used in finding the j-th root when convergence was achieved. If convergence was not obtained in itmax iterations, infer(j) will be greater than itmax 681 681 \item infer (out) is an integer vector of size kn+n. On output infer(j) contains the number of iterations used in finding the j-th root when convergence was achieved. If convergence was not obtained in itmax iterations, infer(j) will be greater than itmax
\item ier (out) is an integer used as an error parameter. ier = 33 indicates failure to converge within itmax iterations for at least one of the (n) new roots. 682 682 \item ier (out) is an integer used as an error parameter. ier = 33 indicates failure to converge within itmax iterations for at least one of the (n) new roots.
\end{itemize} 683 683 \end{itemize}
This subroutine always returns the last approximation for root j in x(j). if the convergence criterion is satisfied, then infer(j) is less than or equal to itmax. if the convergence criterion is not satisified, then infer(j) is set to either itmax+1 or itmax+k, with k greater than 1. infer(j) = itmax+1 indicates that muller did not obtain convergence in the allowed number of iterations. in this case, the user may wish to set itmax to a larger value. infer(j) = itmax+k means that convergence was obtained (on iteration k) for the deflated function fp(z) = f(z)/((z-z(1)...(z-z(j-1))) but failed for f(z). in this case, better initial guesses might help or, it might be necessary to relax the convergence criterion. 684 684 This subroutine always returns the last approximation for root j in x(j). if the convergence criterion is satisfied, then infer(j) is less than or equal to itmax. if the convergence criterion is not satisified, then infer(j) is set to either itmax+1 or itmax+k, with k greater than 1. infer(j) = itmax+1 indicates that muller did not obtain convergence in the allowed number of iterations. in this case, the user may wish to set itmax to a larger value. infer(j) = itmax+k means that convergence was obtained (on iteration k) for the deflated function fp(z) = f(z)/((z-z(1)...(z-z(j-1))) but failed for f(z). in this case, better initial guesses might help or, it might be necessary to relax the convergence criterion.
685 685
\subsection*{Example} 686 686 \subsection*{Example}
Example to find the ten roots of $x^{10}-1$ 687 687 Example to find the ten roots of $x^{10}-1$
\begin{verbatim} 688 688 \begin{verbatim}
program muller 689 689 program muller
use fvn 690 690 use fvn
implicit none 691 691 implicit none
692 692
integer :: i,info 693 693 integer :: i,info
complex(8),dimension(10) :: roots 694 694 complex(8),dimension(10) :: roots
integer,dimension(10) :: infer 695 695 integer,dimension(10) :: infer
complex(8), external :: f 696 696 complex(8), external :: f
697 697
call fvn_z_muller(f,1.d-12,1.d-10,0,0,10,roots,200,infer,info) 698 698 call fvn_z_muller(f,1.d-12,1.d-10,0,0,10,roots,200,infer,info)
699 699
write(*,*) "Error code :",info 700 700 write(*,*) "Error code :",info
do i=1,10 701 701 do i=1,10
write(*,*) roots(i),infer(i) 702 702 write(*,*) roots(i),infer(i)
enddo 703 703 enddo
end program 704 704 end program
705 705
function f(x) 706 706 function f(x)
complex(8) :: x,f 707 707 complex(8) :: x,f
f=x**10-1 708 708 f=x**10-1
end function 709 709 end function
710 710
\end{verbatim} 711 711 \end{verbatim}
712 712
713 713
714 714
\section{Numerical integration} 715 715 \section{Numerical integration}
Using an integrated slightly modified version of quadpack \url{http://www.netlib.org/quadpack}, fvn provide adaptative numerical integration (Gauss Kronrod) of real functions of 1 and 2 variables. fvn also provide a function to calculate Gauss-Legendre abscissas and weight, and a simple non adaptative integration subroutine. All routines exists only in fvn for double precision real. 716 716 Using an integrated slightly modified version of quadpack \url{http://www.netlib.org/quadpack}, fvn provide adaptative numerical integration (Gauss Kronrod) of real functions of 1 and 2 variables. fvn also provide a function to calculate Gauss-Legendre abscissas and weight, and a simple non adaptative integration subroutine. All routines exists only in fvn for double precision real.
717 717
\subsection{Gauss Legendre Abscissas and Weigth} 718 718 \subsection{Gauss Legendre Abscissas and Weigth}
This subroutine was inspired by Numerical Recipes routine gauleg. 719 719 This subroutine was inspired by Numerical Recipes routine gauleg.
\begin{verbatim} 720 720 \begin{verbatim}
call fvn_gauss_legendre(n,qx,qw) 721 721 call fvn_gauss_legendre(n,qx,qw)
\end{verbatim} 722 722 \end{verbatim}
\begin{itemize} 723 723 \begin{itemize}
\item n (in) is an integer equal to the number of Gauss Legendre points 724 724 \item n (in) is an integer equal to the number of Gauss Legendre points
\item qx (out) is a real(8) vector of length n containing the abscissas. 725 725 \item qx (out) is a real(8) vector of length n containing the abscissas.
\item qw (out) is a real(8) vector of length n containing the weigths. 726 726 \item qw (out) is a real(8) vector of length n containing the weigths.
\end{itemize} 727 727 \end{itemize}
This subroutine computes n Gauss-Legendre abscissas and weigths 728 728 This subroutine computes n Gauss-Legendre abscissas and weigths
729 729
\subsection{Gauss Legendre Numerical Integration} 730 730 \subsection{Gauss Legendre Numerical Integration}
\begin{verbatim} 731 731 \begin{verbatim}
call fvn_gl_integ(f,a,b,n,res) 732 732 call fvn_gl_integ(f,a,b,n,res)
\end{verbatim} 733 733 \end{verbatim}
\begin{itemize} 734 734 \begin{itemize}
\item f (in) is a real(8) function to integrate 735 735 \item f (in) is a real(8) function to integrate
\item a (in) and b (in) are real(8) respectively lower and higher bound of integration 736 736 \item a (in) and b (in) are real(8) respectively lower and higher bound of integration
\item n (in) is an integer equal to the number of Gauss Legendre points to use 737 737 \item n (in) is an integer equal to the number of Gauss Legendre points to use
\item res (out) is a real(8) containing the result 738 738 \item res (out) is a real(8) containing the result
\end{itemize} 739 739 \end{itemize}
This function is a simple Gauss Legendre integration subroutine, which evaluate the integral of function f as in equation \ref{intsple} using n Gauss-Legendre pairs. 740 740 This function is a simple Gauss Legendre integration subroutine, which evaluate the integral of function f as in equation \ref{intsple} using n Gauss-Legendre pairs.
741 741
\subsection{Gauss Kronrod Adaptative Integration} 742 742 \subsection{Gauss Kronrod Adaptative Integration}
This kind of numerical integration is an iterative procedure which try to achieve a given precision. 743 743 This kind of numerical integration is an iterative procedure which try to achieve a given precision.
\subsubsection{Numerical integration of a one variable function} 744 744 \subsubsection{Numerical integration of a one variable function}
\begin{verbatim} 745 745 \begin{verbatim}
call fvn_integ_1_gk(f,a,b,epsabs,epsrel,key,res,abserr,ier,limit) 746 746 call fvn_integ_1_gk(f,a,b,epsabs,epsrel,key,res,abserr,ier,limit)
\end{verbatim} 747 747 \end{verbatim}
This routine evaluate the integral of function f as in equation \ref{intsple} 748 748 This routine evaluate the integral of function f as in equation \ref{intsple}
\begin{itemize} 749 749 \begin{itemize}
\item f (in) is an external real(8) function of one variable 750 750 \item f (in) is an external real(8) function of one variable
\item a (in) and b (in) are real(8) respectively lower an higher bound of integration 751 751 \item a (in) and b (in) are real(8) respectively lower an higher bound of integration
\item epsabs (in) and epsrel (in) are real(8) respectively desired absolute and relative error 752 752 \item epsabs (in) and epsrel (in) are real(8) respectively desired absolute and relative error
\item key (in) is an integer between 1 and 6 correspondind to the Gauss-Kronrod rule to use : 753 753 \item key (in) is an integer between 1 and 6 correspondind to the Gauss-Kronrod rule to use :
\begin{itemize} 754 754 \begin{itemize}
\item 1 : 7 - 15 points 755 755 \item 1 : 7 - 15 points
\item 2 : 10 - 21 points 756 756 \item 2 : 10 - 21 points
\item 3 : 15 - 31 points 757 757 \item 3 : 15 - 31 points
\item 4 : 20 - 41 points 758 758 \item 4 : 20 - 41 points
\item 5 : 25 - 51 points 759 759 \item 5 : 25 - 51 points
\item 6 : 30 - 61 points 760 760 \item 6 : 30 - 61 points
\end{itemize} 761 761 \end{itemize}
\item res (out) is a real(8) containing the estimation of the integration. 762 762 \item res (out) is a real(8) containing the estimation of the integration.
\item abserr (out) is a real(8) equal to the estimated absolute error 763 763 \item abserr (out) is a real(8) equal to the estimated absolute error
\item ier (out) is an integer used as an error flag 764 764 \item ier (out) is an integer used as an error flag
\begin{itemize} 765 765 \begin{itemize}
\item 0 : no error 766 766 \item 0 : no error
\item 1 : maximum number of subdivisions allowed has been achieved. one can allow more subdivisions by increasing the value of limit (and taking the according dimension adjustments into account). however, if this yield no improvement it is advised to analyze the integrand in order to determine the integration difficulaties. If the position of a local difficulty can be determined (i.e.singularity, discontinuity within the interval) one will probably gain from splitting up the interval at this point and calling the integrator on the subranges. If possible, an appropriate special-purpose integrator should be used which is designed for handling the type of difficulty involved. 767 767 \item 1 : maximum number of subdivisions allowed has been achieved. one can allow more subdivisions by increasing the value of limit (and taking the according dimension adjustments into account). however, if this yield no improvement it is advised to analyze the integrand in order to determine the integration difficulaties. If the position of a local difficulty can be determined (i.e.singularity, discontinuity within the interval) one will probably gain from splitting up the interval at this point and calling the integrator on the subranges. If possible, an appropriate special-purpose integrator should be used which is designed for handling the type of difficulty involved.
\item 2 : the occurrence of roundoff error is detected, which prevents the requested tolerance from being achieved. 768 768 \item 2 : the occurrence of roundoff error is detected, which prevents the requested tolerance from being achieved.
\item 3 : extremely bad integrand behaviour occurs at some points of the integration interval. 769 769 \item 3 : extremely bad integrand behaviour occurs at some points of the integration interval.
\item 6 : the input is invalid, because (epsabs.le.0 and epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) or limit.lt.1 or lenw.lt.limit*4. result, abserr, neval, last are set to zero. Except when lenw is invalid, iwork(1), work(limit*2+1) and work(limit*3+1) are set to zero, work(1) is set to a and work(limit+1) to b. 770 770 \item 6 : the input is invalid, because (epsabs.le.0 and epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) or limit.lt.1 or lenw.lt.limit*4. result, abserr, neval, last are set to zero. Except when lenw is invalid, iwork(1), work(limit*2+1) and work(limit*3+1) are set to zero, work(1) is set to a and work(limit+1) to b.
\end{itemize} 771 771 \end{itemize}
\item limit (in) is an integer equal to maximum number of subintervals in the partition of the given integration interval (a,b). A value of 500 will usually give good results. 772 772 \item limit (in) is an integer equal to maximum number of subintervals in the partition of the given integration interval (a,b). A value of 500 will usually give good results.
\end{itemize} 773 773 \end{itemize}
774 774
\begin{equation} 775 775 \begin{equation}
\int_a^b f(x)~dx 776 776 \int_a^b f(x)~dx
\label{intsple} 777 777 \label{intsple}
\end{equation} 778 778 \end{equation}
779 779
780 780
781 781
782 782
\subsubsection{Numerical integration of a two variable function} 783 783 \subsubsection{Numerical integration of a two variable function}
\begin{verbatim} 784 784 \begin{verbatim}
call fvn_integ_2_gk(f,a,b,g,h,epsabs,epsrel,key,res,abserr,ier,limit) 785 785 call fvn_integ_2_gk(f,a,b,g,h,epsabs,epsrel,key,res,abserr,ier,limit)
\end{verbatim} 786 786 \end{verbatim}
This function evaluate the integral of a function f(x,y) as defined in equation \ref{intdble}. The parameters of same name as in the previous paragraph have exactly the same function and behaviour thus only what differs is decribed here 787 787 This function evaluate the integral of a function f(x,y) as defined in equation \ref{intdble}. The parameters of same name as in the previous paragraph have exactly the same function and behaviour thus only what differs is decribed here
\begin{itemize} 788 788 \begin{itemize}
\item a (in) and b (in) are real(8) corresponding respectively to lower and higher bound of integration for the x variable. 789 789 \item a (in) and b (in) are real(8) corresponding respectively to lower and higher bound of integration for the x variable.
\item g(x) (in) and h(x) (in) are external functions describing the lower and higher bound of integration for the y variable as a function of x. 790 790 \item g(x) (in) and h(x) (in) are external functions describing the lower and higher bound of integration for the y variable as a function of x.
\end{itemize} 791 791 \end{itemize}
792 792
\begin{equation} 793 793 \begin{equation}
\int_a^b \int_{g(x)}^{h(x)} f(x,y)~dy~dx 794 794 \int_a^b \int_{g(x)}^{h(x)} f(x,y)~dy~dx
\label{intdble} 795 795 \label{intdble}
\end{equation} 796 796 \end{equation}
797 797
\subsubsection*{Example} 798 798 \subsubsection*{Example}
\begin{verbatim} 799 799 \begin{verbatim}
program integ 800 800 program integ
use fvn 801 801 use fvn
implicit none 802 802 implicit none
803 803
real(8), external :: f1,f2,g,h 804 804 real(8), external :: f1,f2,g,h
real(8) :: a,b,epsabs,epsrel,abserr,res 805 805 real(8) :: a,b,epsabs,epsrel,abserr,res
integer :: key,ier 806 806 integer :: key,ier
807 807
a=0. 808 808 a=0.
b=1. 809 809 b=1.
epsabs=1d-8 810 810 epsabs=1d-8
epsrel=1d-8 811 811 epsrel=1d-8
key=2 812 812 key=2
call fvn_d_integ_1_gk(f1,a,b,epsabs,epsrel,key,res,abserr,ier,500) 813 813 call fvn_d_integ_1_gk(f1,a,b,epsabs,epsrel,key,res,abserr,ier,500)
write(*,*) "Integration of x*x between 0 and 1 : " 814 814 write(*,*) "Integration of x*x between 0 and 1 : "
write(*,*) res 815 815 write(*,*) res
816 816
call fvn_d_integ_2_gk(f2,a,b,g,h,epsabs,epsrel,key,res,abserr,ier,500) 817 817 call fvn_d_integ_2_gk(f2,a,b,g,h,epsabs,epsrel,key,res,abserr,ier,500)
write(*,*) "Integration of x*y between 0 and 1 on both x and y : " 818 818 write(*,*) "Integration of x*y between 0 and 1 on both x and y : "
write(*,*) res 819 819 write(*,*) res
820 820
821 821
end program 822 822 end program
823 823
function f1(x) 824 824 function f1(x)
implicit none 825 825 implicit none
real(8) :: x,f1 826 826 real(8) :: x,f1
f1=x*x 827 827 f1=x*x
end function 828 828 end function
829 829
function f2(x,y) 830 830 function f2(x,y)
implicit none 831 831 implicit none
real(8) :: x,y,f2 832 832 real(8) :: x,y,f2
f2=x*y 833 833 f2=x*y
end function 834 834 end function
835 835
function g(x) 836 836 function g(x)
implicit none 837 837 implicit none
real(8) :: x,g 838 838 real(8) :: x,g
g=0. 839 839 g=0.
end function 840 840 end function
841 841
function h(x) 842 842 function h(x)
implicit none 843 843 implicit none
real(8) :: x,h 844 844 real(8) :: x,h
h=1. 845 845 h=1.
end function 846 846 end function
\end{verbatim} 847 847 \end{verbatim}
848 848
849 849
\section{Special functions} 850 850 \section{Special functions}
Specials functions are available in fvn by using an implementation of fnlib \url{http://www.netlib.org/fn}. This can be used separatly from the rest of fvn by using the module \verb'fvn_fnlib' and linking the library \verb'libfvn_fnlib.a' . The module provides a generic interfaces to all the routines. Specific names of the routines are given in the description. The double complex versions of the routines are not present in the web version of fnlib, so these have been added, but not intensely tested. 851 851 Specials functions are available in fvn by using an implementation of fnlib \url{http://www.netlib.org/fn}. This can be used separatly from the rest of fvn by using the module \verb'fvn_fnlib' and linking the library \verb'libfvn_fnlib.a' . The module provides a generic interfaces to all the routines. Specific names of the routines are given in the description. The double complex versions of the routines are not present in the web version of fnlib, so these have been added, but not intensely tested.
852 852
\paragraph{Important Note} 853 853 \paragraph{Important Note}
Due to the addition of fnlib to fvn, some functions that were in fvn and are redondant will be removed from fvn, so update your code now and replace them with the fnlib version. These are listed here after : 854 854 Due to the addition of fnlib to fvn, some functions that were in fvn and are redondant will be removed from fvn, so update your code now and replace them with the fnlib version. These are listed here after :
\begin{itemize} 855 855 \begin{itemize}
\item \verb'fvn_z_acos' replaced by \verb'acos' 856 856 \item \verb'fvn_z_acos' replaced by \verb'acos'
\item \verb'fvn_z_asin' replaced by \verb'asin' 857 857 \item \verb'fvn_z_asin' replaced by \verb'asin'
\item \verb'fvn_d_asinh' replaced by \verb'asinh' 858 858 \item \verb'fvn_d_asinh' replaced by \verb'asinh'
\item \verb'fvn_d_acosh' replaced by \verb'acosh' 859 859 \item \verb'fvn_d_acosh' replaced by \verb'acosh'
\item \verb'fvn_s_csevl' replaced by \verb'csevl' 860 860 \item \verb'fvn_s_csevl' replaced by \verb'csevl'
\item \verb'fvn_d_csevl' replaced by \verb'csevl' 861 861 \item \verb'fvn_d_csevl' replaced by \verb'csevl'
\item \verb'fvn_d_factorial' replaced by \verb'fac' 862 862 \item \verb'fvn_d_factorial' replaced by \verb'fac'
\item \verb'fvn_d_lngamma' replaced by \verb'alngam' 863 863 \item \verb'fvn_d_lngamma' replaced by \verb'alngam'
\end{itemize} 864 864 \end{itemize}
865 865
866 866
\subsection{Elementary functions} 867 867 \subsection{Elementary functions}
\subsubsection{carg} 868 868 \subsubsection{carg}
\begin{verbatim} 869 869 \begin{verbatim}
carg(z) 870 870 carg(z)
\end{verbatim} 871 871 \end{verbatim}
\begin{itemize} 872 872 \begin{itemize}
\item z (in) is a complex 873 873 \item z (in) is a complex
\end{itemize} 874 874 \end{itemize}
This function evaluates the argument of the complex z. That is $\theta$ for $z=\rho e^{i\theta}$. 875 875 This function evaluates the argument of the complex z. That is $\theta$ for $z=\rho e^{i\theta}$.
876 876
Specific interfaces : \verb'carg,zarg' 877 877 Specific interfaces : \verb'carg,zarg'
878 878
879 879
\subsubsection{cbrt} 880 880 \subsubsection{cbrt}
\begin{verbatim} 881 881 \begin{verbatim}
cbrt(x) 882 882 cbrt(x)
\end{verbatim} 883 883 \end{verbatim}
\begin{itemize} 884 884 \begin{itemize}
\item x is a real or complex 885 885 \item x is a real or complex
\end{itemize} 886 886 \end{itemize}
This function evaluates the cubic root of the argument x. 887 887 This function evaluates the cubic root of the argument x.
888 888
Specific interfaces : \verb'cbrt,dcbrt,ccbrt,zcbrt' 889 889 Specific interfaces : \verb'cbrt,dcbrt,ccbrt,zcbrt'
890 890
891 891
\subsubsection{exprl} 892 892 \subsubsection{exprl}
\begin{verbatim} 893 893 \begin{verbatim}
exprl(x) 894 894 exprl(x)
\end{verbatim} 895 895 \end{verbatim}
\begin{itemize} 896 896 \begin{itemize}
\item x is a real or complex 897 897 \item x is a real or complex
\end{itemize} 898 898 \end{itemize}
This function evaluates ${e^x-1}\over x$. 899 899 This function evaluates ${e^x-1}\over x$.
900 900
Specific interfaces : \verb'exprel,dexprl,cexprl,zexprl' 901 901 Specific interfaces : \verb'exprel,dexprl,cexprl,zexprl'
902 902
\subsubsection{log10} 903 903 \subsubsection{log10}
\begin{verbatim} 904 904 \begin{verbatim}
log10(x) 905 905 log10(x)
\end{verbatim} 906 906 \end{verbatim}
\begin{itemize} 907 907 \begin{itemize}
\item x is a real or complex 908 908 \item x is a real or complex
\end{itemize} 909 909 \end{itemize}
This function is an extension of the intrinsic function log10 to complex arguments. 910 910 This function is an extension of the intrinsic function log10 to complex arguments.
911 911
Specific interfaces : \verb'clog10,zlog10' 912 912 Specific interfaces : \verb'clog10,zlog10'
913 913
914 914
\subsubsection{alnrel} 915 915 \subsubsection{alnrel}
\begin{verbatim} 916 916 \begin{verbatim}
alnrel(x) 917 917 alnrel(x)
\end{verbatim} 918 918 \end{verbatim}
\begin{itemize} 919 919 \begin{itemize}
\item x is a real or complex 920 920 \item x is a real or complex
\end{itemize} 921 921 \end{itemize}
This function evaluates $ln(1+x)$. 922 922 This function evaluates $ln(1+x)$.
923 923
Specific interfaces : \verb'alnrel,dlnrel,clnrel,zlnrel' 924 924 Specific interfaces : \verb'alnrel,dlnrel,clnrel,zlnrel'
925 925
926 926
\subsection{Trigonometry} 927 927 \subsection{Trigonometry}
\subsubsection{tan} 928 928 \subsubsection{tan}
\begin{verbatim} 929 929 \begin{verbatim}
tan(x) 930 930 tan(x)
\end{verbatim} 931 931 \end{verbatim}
\begin{itemize} 932 932 \begin{itemize}
\item x is a real or complex 933 933 \item x is a real or complex
\end{itemize} 934 934 \end{itemize}
This function evaluates the tangent of the argument. It is an extension of the intrinsic function tan to complex arguments. 935 935 This function evaluates the tangent of the argument. It is an extension of the intrinsic function tan to complex arguments.
936 936
Specific interfaces : \verb'ctan,ztan' 937 937 Specific interfaces : \verb'ctan,ztan'
938 938
939 939
\subsubsection{cot} 940 940 \subsubsection{cot}
\begin{verbatim} 941 941 \begin{verbatim}
cot(x) 942 942 cot(x)
\end{verbatim} 943 943 \end{verbatim}
\begin{itemize} 944 944 \begin{itemize}
\item x is a real or complex 945 945 \item x is a real or complex
\end{itemize} 946 946 \end{itemize}
This function evaluate the cotangent of the argument. 947 947 This function evaluate the cotangent of the argument.
948 948
Specific interfaces : \verb'cot,dcot,ccot,zcot' 949 949 Specific interfaces : \verb'cot,dcot,ccot,zcot'
950 950
\subsubsection{sindg} 951 951 \subsubsection{sindg}
\begin{verbatim} 952 952 \begin{verbatim}
sindg(x) 953 953 sindg(x)
\end{verbatim} 954 954 \end{verbatim}
\begin{itemize} 955 955 \begin{itemize}
\item x is a real 956 956 \item x is a real
\end{itemize} 957 957 \end{itemize}
This function evaluate the sinus of the argument expressed in degrees. 958 958 This function evaluate the sinus of the argument expressed in degrees.
959 959
Specific interfaces : \verb'sindg,dsindg' 960 960 Specific interfaces : \verb'sindg,dsindg'
961 961
962 962
\subsubsection{cosdg} 963 963 \subsubsection{cosdg}
\begin{verbatim} 964 964 \begin{verbatim}
cosdg(x) 965 965 cosdg(x)
\end{verbatim} 966 966 \end{verbatim}
\begin{itemize} 967 967 \begin{itemize}
\item x is a real 968 968 \item x is a real
\end{itemize} 969 969 \end{itemize}
This function evaluate the cosinus of the argument expressed in degrees. 970 970 This function evaluate the cosinus of the argument expressed in degrees.
971 971
Specific interfaces : \verb'cosdg,dcosdg' 972 972 Specific interfaces : \verb'cosdg,dcosdg'
973 973
974 974
\subsubsection{asin} 975 975 \subsubsection{asin}
\begin{verbatim} 976 976 \begin{verbatim}
asin(x) 977 977 asin(x)
\end{verbatim} 978 978 \end{verbatim}
\begin{itemize} 979 979 \begin{itemize}
\item x is a real or complex 980 980 \item x is a real or complex
\end{itemize} 981 981 \end{itemize}
This function evaluates the arc sine of the argument. It is an extension of the intrinsic function asin to complex arguments. 982 982 This function evaluates the arc sine of the argument. It is an extension of the intrinsic function asin to complex arguments.
983 983
Specific interfaces : \verb'casin,zasin' 984 984 Specific interfaces : \verb'casin,zasin'
985 985
\subsubsection{acos} 986 986 \subsubsection{acos}
\begin{verbatim} 987 987 \begin{verbatim}
acos(x) 988 988 acos(x)
\end{verbatim} 989 989 \end{verbatim}
\begin{itemize} 990 990 \begin{itemize}
\item x is a real or complex 991 991 \item x is a real or complex
\end{itemize} 992 992 \end{itemize}
This function evaluates the arc cosine of the argument. It is an extension of the intrinsic function acos to complex arguments. 993 993 This function evaluates the arc cosine of the argument. It is an extension of the intrinsic function acos to complex arguments.
994 994
Specific interfaces : \verb'cacos,zacos' 995 995 Specific interfaces : \verb'cacos,zacos'
996 996
997 997
\subsubsection{atan} 998 998 \subsubsection{atan}
\begin{verbatim} 999 999 \begin{verbatim}
atan(x) 1000 1000 atan(x)
\end{verbatim} 1001 1001 \end{verbatim}
\begin{itemize} 1002 1002 \begin{itemize}
\item x is a real or complex 1003 1003 \item x is a real or complex
\end{itemize} 1004 1004 \end{itemize}
This function evaluates the arc tangent of the argument. It is an extension of the intrinsic function atan to complex arguments. 1005 1005 This function evaluates the arc tangent of the argument. It is an extension of the intrinsic function atan to complex arguments.
1006 1006
Specific interfaces : \verb'catan,zatan' 1007 1007 Specific interfaces : \verb'catan,zatan'
1008 1008
\subsubsection{atan2} 1009 1009 \subsubsection{atan2}
\begin{verbatim} 1010 1010 \begin{verbatim}
atan2(x,y) 1011 1011 atan2(x,y)
\end{verbatim} 1012 1012 \end{verbatim}
\begin{itemize} 1013 1013 \begin{itemize}
\item x,y are real or complex 1014 1014 \item x,y are real or complex
\end{itemize} 1015 1015 \end{itemize}
This function evaluates the arc tangent of $x \over y$. It is an extension of the intrinsic function atan2 to complex arguments. 1016 1016 This function evaluates the arc tangent of $x \over y$. It is an extension of the intrinsic function atan2 to complex arguments.
1017 1017
Specific interfaces : \verb'catan2,zatan2' 1018 1018 Specific interfaces : \verb'catan2,zatan2'
1019 1019
\subsubsection{sinh} 1020 1020 \subsubsection{sinh}
\begin{verbatim} 1021 1021 \begin{verbatim}
sinh(x) 1022 1022 sinh(x)
\end{verbatim} 1023 1023 \end{verbatim}
\begin{itemize} 1024 1024 \begin{itemize}
\item x is a real or complex 1025 1025 \item x is a real or complex
\end{itemize} 1026 1026 \end{itemize}
This function evaluates the hyperbolic sine of the argument. It is an extension of the intrinsic function sinh to complex arguments. 1027 1027 This function evaluates the hyperbolic sine of the argument. It is an extension of the intrinsic function sinh to complex arguments.
1028 1028
Specific interfaces : \verb'csinh,zsinh' 1029 1029 Specific interfaces : \verb'csinh,zsinh'
1030 1030
1031 1031
\subsubsection{cosh} 1032 1032 \subsubsection{cosh}
\begin{verbatim} 1033 1033 \begin{verbatim}
cosh(x) 1034 1034 cosh(x)
\end{verbatim} 1035 1035 \end{verbatim}
\begin{itemize} 1036 1036 \begin{itemize}
\item x is a real or complex 1037 1037 \item x is a real or complex
\end{itemize} 1038 1038 \end{itemize}
This function evaluates the hyperbolic cosine of the argument. It is an extension of the intrinsic function cosh to complex arguments. 1039 1039 This function evaluates the hyperbolic cosine of the argument. It is an extension of the intrinsic function cosh to complex arguments.
1040 1040
Specific interfaces : \verb'ccosh,zcosh' 1041 1041 Specific interfaces : \verb'ccosh,zcosh'
1042 1042
\subsubsection{tanh} 1043 1043 \subsubsection{tanh}
\begin{verbatim} 1044 1044 \begin{verbatim}
tanh(x) 1045 1045 tanh(x)
\end{verbatim} 1046 1046 \end{verbatim}
This function evaluates the hyperbolic tangent of the argument. It is an extension of the intrinsic function tanh to complex arguments. 1047 1047 This function evaluates the hyperbolic tangent of the argument. It is an extension of the intrinsic function tanh to complex arguments.
1048 1048
Specific interfaces : \verb'ctanh,ztanh' 1049 1049 Specific interfaces : \verb'ctanh,ztanh'
1050 1050
\subsubsection{asinh} 1051 1051 \subsubsection{asinh}
\begin{verbatim} 1052 1052 \begin{verbatim}
asinh(x) 1053 1053 asinh(x)
\end{verbatim} 1054 1054 \end{verbatim}
\begin{itemize} 1055 1055 \begin{itemize}
\item x is a real or complex 1056 1056 \item x is a real or complex
\end{itemize} 1057 1057 \end{itemize}
This function evaluates the arc hyperbolic sine of the argument. 1058 1058 This function evaluates the arc hyperbolic sine of the argument.
1059 1059
Specific interfaces : \verb'asinh,dasinh,casinh,zasinh' 1060 1060 Specific interfaces : \verb'asinh,dasinh,casinh,zasinh'
1061 1061
\subsubsection{acosh} 1062 1062 \subsubsection{acosh}
\begin{verbatim} 1063 1063 \begin{verbatim}
acosh(x) 1064 1064 acosh(x)
\end{verbatim} 1065 1065 \end{verbatim}
\begin{itemize} 1066 1066 \begin{itemize}
\item x is a real or complex 1067 1067 \item x is a real or complex
\end{itemize} 1068 1068 \end{itemize}
This function evaluates the arc hyperbolic cosine of the argument. 1069 1069 This function evaluates the arc hyperbolic cosine of the argument.
1070 1070
Specific interfaces : \verb'acosh,dacosh,cacosh,zacosh' 1071 1071 Specific interfaces : \verb'acosh,dacosh,cacosh,zacosh'
1072 1072
\subsubsection{atanh} 1073 1073 \subsubsection{atanh}
\begin{verbatim} 1074 1074 \begin{verbatim}
atanh(x) 1075 1075 atanh(x)
\end{verbatim} 1076 1076 \end{verbatim}
\begin{itemize} 1077 1077 \begin{itemize}
\item x is a real or complex 1078 1078 \item x is a real or complex
\end{itemize} 1079 1079 \end{itemize}
This function evaluates the arc hyperbolic tangent of the argument. 1080 1080 This function evaluates the arc hyperbolic tangent of the argument.
1081 1081
Specific interfaces : \verb'atanh,datanh,catanh,zatanh' 1082 1082 Specific interfaces : \verb'atanh,datanh,catanh,zatanh'
1083 1083
\subsection{Exponential Integral and related} 1084 1084 \subsection{Exponential Integral and related}
\subsubsection{ei} 1085 1085 \subsubsection{ei}
\begin{verbatim} 1086 1086 \begin{verbatim}
ei(x) 1087 1087 ei(x)
\end{verbatim} 1088 1088 \end{verbatim}
\begin{itemize} 1089 1089 \begin{itemize}
\item x is a real 1090 1090 \item x is a real
\end{itemize} 1091 1091 \end{itemize}
This function evaluates the exponential integral for argument greater then 0 and the Cauchy principal value for argument less than 0. It is define by equation \ref{ei} for $x \neq 0$. 1092 1092 This function evaluates the exponential integral for argument greater then 0 and the Cauchy principal value for argument less than 0. It is define by equation \ref{ei} for $x \neq 0$.
\begin{equation} 1093 1093 \begin{equation}
\label{ei} 1094 1094 \label{ei}
ei(x)= - \int _{-x} ^\infty {e^{-t}\over t}dt 1095 1095 ei(x)= - \int _{-x} ^\infty {e^{-t}\over t}dt
\end{equation} 1096 1096 \end{equation}
1097 1097
Specific interfaces : \verb'ei,dei' 1098 1098 Specific interfaces : \verb'ei,dei'
1099 1099
1100 1100
\subsubsection{e1} 1101 1101 \subsubsection{e1}
\begin{verbatim} 1102 1102 \begin{verbatim}
e1(x) 1103 1103 e1(x)
\end{verbatim} 1104 1104 \end{verbatim}
\begin{itemize} 1105 1105 \begin{itemize}
\item x is a real 1106 1106 \item x is a real
\end{itemize} 1107 1107 \end{itemize}
This function evaluates the exponential integral for argument greater than 0 and the Cauchy principal value for argument less than 0. It is define by equation \ref{e1} for $x \neq 0$. 1108 1108 This function evaluates the exponential integral for argument greater than 0 and the Cauchy principal value for argument less than 0. It is define by equation \ref{e1} for $x \neq 0$.
\begin{equation} 1109 1109 \begin{equation}
\label{e1} 1110 1110 \label{e1}
e1(x)= \int _{x} ^\infty {e^{-t}\over t}dt 1111 1111 e1(x)= \int _{x} ^\infty {e^{-t}\over t}dt
\end{equation} 1112 1112 \end{equation}
1113 1113
Specific interfaces : \verb'e1,de1' 1114 1114 Specific interfaces : \verb'e1,de1'
1115 1115
\subsubsection{ali} 1116 1116 \subsubsection{ali}
\begin{verbatim} 1117 1117 \begin{verbatim}
ali(x) 1118 1118 ali(x)
\end{verbatim} 1119 1119 \end{verbatim}
\begin{itemize} 1120 1120 \begin{itemize}
\item x is a real 1121 1121 \item x is a real
\end{itemize} 1122 1122 \end{itemize}
This function evaluates the logarithm integral. it is define by equation \ref{ali} for $x > 0$ and $x \neq 1$. 1123 1123 This function evaluates the logarithm integral. it is define by equation \ref{ali} for $x > 0$ and $x \neq 1$.
\begin{equation} 1124 1124 \begin{equation}
\label{ali} 1125 1125 \label{ali}
ali(x)= - \int _0 ^x {dt \over ln(x)} 1126 1126 ali(x)= - \int _0 ^x {dt \over ln(x)}
\end{equation} 1127 1127 \end{equation}
1128 1128
Specific interfaces : \verb'ali,dli' 1129 1129 Specific interfaces : \verb'ali,dli'
1130 1130
\subsubsection{si} 1131 1131 \subsubsection{si}
\begin{verbatim} 1132 1132 \begin{verbatim}
si(x) 1133 1133 si(x)
\end{verbatim} 1134 1134 \end{verbatim}
\begin{itemize} 1135 1135 \begin{itemize}
\item x is a real 1136 1136 \item x is a real
\end{itemize} 1137 1137 \end{itemize}
This function evaluates the sine integral defined by equation \ref{si}. 1138 1138 This function evaluates the sine integral defined by equation \ref{si}.
\begin{equation} 1139 1139 \begin{equation}
\label{si} 1140 1140 \label{si}
si(x)= \int _0 ^x {sin(t) \over t }dt 1141 1141 si(x)= \int _0 ^x {sin(t) \over t }dt
\end{equation} 1142 1142 \end{equation}
1143 1143
Specific interfaces : \verb'si,dsi' 1144 1144 Specific interfaces : \verb'si,dsi'
1145 1145
1146 1146
\subsubsection{ci} 1147 1147 \subsubsection{ci}
\begin{verbatim} 1148 1148 \begin{verbatim}
ci(x) 1149 1149 ci(x)
\end{verbatim} 1150 1150 \end{verbatim}
\begin{itemize} 1151 1151 \begin{itemize}
\item x is a real 1152 1152 \item x is a real
\end{itemize} 1153 1153 \end{itemize}
This function evaluates the cosine integral defined by equation \ref{ci} where $\gamma \approx 0.57721566$ represent Euler's constant. 1154 1154 This function evaluates the cosine integral defined by equation \ref{ci} where $\gamma \approx 0.57721566$ represent Euler's constant.
\begin{equation} 1155 1155 \begin{equation}
\label{ci} 1156 1156 \label{ci}
ci(x)= \gamma + ln(x) + \int _0 ^x {{1-cos(t)} \over t} dt 1157 1157 ci(x)= \gamma + ln(x) + \int _0 ^x {{1-cos(t)} \over t} dt
\end{equation} 1158 1158 \end{equation}
1159 1159
Specific interfaces : \verb'ci,dci' 1160 1160 Specific interfaces : \verb'ci,dci'
1161 1161
\subsubsection{cin} 1162 1162 \subsubsection{cin}
\begin{verbatim} 1163 1163 \begin{verbatim}
cin(x) 1164 1164 cin(x)
\end{verbatim} 1165 1165 \end{verbatim}
\begin{itemize} 1166 1166 \begin{itemize}
\item x is a real 1167 1167 \item x is a real
\end{itemize} 1168 1168 \end{itemize}
This function evaluates the cosine integral alternate definition given by equation \ref{cin}. 1169 1169 This function evaluates the cosine integral alternate definition given by equation \ref{cin}.
\begin{equation} 1170 1170 \begin{equation}
\label{cin} 1171 1171 \label{cin}
cin(x)= \int _0 ^x {{1-cos(t)} \over t} dt 1172 1172 cin(x)= \int _0 ^x {{1-cos(t)} \over t} dt
\end{equation} 1173 1173 \end{equation}
1174 1174
Specific interface : \verb'cin,dcin' 1175 1175 Specific interface : \verb'cin,dcin'
1176 1176
\subsubsection{shi} 1177 1177 \subsubsection{shi}
\begin{equation} 1178 1178 \begin{equation}
shi(x) 1179 1179 shi(x)
\end{equation} 1180 1180 \end{equation}
\begin{itemize} 1181 1181 \begin{itemize}
\item x is a real 1182 1182 \item x is a real
\end{itemize} 1183 1183 \end{itemize}
This function evaluates the hyperbolic sine integral defined by equation \ref{shi}. 1184 1184 This function evaluates the hyperbolic sine integral defined by equation \ref{shi}.
\begin{equation} 1185 1185 \begin{equation}
\label{shi} 1186 1186 \label{shi}
shi(x) = \int _0 ^x {sinh(t) \over t}dt 1187 1187 shi(x) = \int _0 ^x {sinh(t) \over t}dt
\end{equation} 1188 1188 \end{equation}
1189 1189
Specific interfaces : \verb'shi,dshi' 1190 1190 Specific interfaces : \verb'shi,dshi'
1191 1191
\subsubsection{chi} 1192 1192 \subsubsection{chi}
\begin{verbatim} 1193 1193 \begin{verbatim}
chi(x) 1194 1194 chi(x)
\end{verbatim} 1195 1195 \end{verbatim}
\begin{itemize} 1196 1196 \begin{itemize}
\item x is a real 1197 1197 \item x is a real
\end{itemize} 1198 1198 \end{itemize}
This function evaluates the hyperbolic cosine integral defined by equation \ref{chi} where $\gamma \approx 0.57721566$ represent Euler's constant. 1199 1199 This function evaluates the hyperbolic cosine integral defined by equation \ref{chi} where $\gamma \approx 0.57721566$ represent Euler's constant.
\begin{equation} 1200 1200 \begin{equation}
\label{chi} 1201 1201 \label{chi}
chi(x)= \gamma + ln(x) + \int _0 ^x {{cosh(t) -1} \over t}dt 1202 1202 chi(x)= \gamma + ln(x) + \int _0 ^x {{cosh(t) -1} \over t}dt
\end{equation} 1203 1203 \end{equation}
1204 1204
Specific interfaces : chi,dchi 1205 1205 Specific interfaces : chi,dchi
1206 1206
1207 1207
\subsubsection{cinh} 1208 1208 \subsubsection{cinh}
\begin{verbatim} 1209 1209 \begin{verbatim}
cinh(x) 1210 1210 cinh(x)
\end{verbatim} 1211 1211 \end{verbatim}
\begin{itemize} 1212 1212 \begin{itemize}
\item x is a real 1213 1213 \item x is a real
\end{itemize} 1214 1214 \end{itemize}
This function evaluates the hyperbolic cosine integral alternate definition given by equation \ref{cinh}. 1215 1215 This function evaluates the hyperbolic cosine integral alternate definition given by equation \ref{cinh}.
\begin{equation} 1216 1216 \begin{equation}
\label{cinh} 1217 1217 \label{cinh}
cinh(x) = \int _0 ^x {{cosh(t) -1} \over t}dt 1218 1218 cinh(x) = \int _0 ^x {{cosh(t) -1} \over t}dt
\end{equation} 1219 1219 \end{equation}
1220 1220
Specific interfaces : cinh,dcinh 1221 1221 Specific interfaces : cinh,dcinh
1222 1222
1223 1223
\subsection{Gamma function and related} 1224 1224 \subsection{Gamma function and related}
\subsubsection{fac} 1225 1225 \subsubsection{fac}
\begin{verbatim} 1226 1226 \begin{verbatim}
fac(n) 1227 1227 fac(n)
1228 dfac(n)
\end{verbatim} 1228 1229 \end{verbatim}
\begin{itemize} 1229 1230 \begin{itemize}
\item n is an integer 1230 1231 \item n is an integer
\end{itemize} 1231 1232 \end{itemize}
This function return $n!$ as a real. 1232 1233 This function return $n!$ as a real(4) or real(8) for dfac. There's no generic interface for this one.
1233 1234
Specific interfaces : \verb'fac,dfac' 1234 1235 Specific interfaces : \verb'fac,dfac'
1235 1236
\subsubsection{binom} 1236 1237 \subsubsection{binom}
\begin{verbatim} 1237 1238 \begin{verbatim}
binom(n,m) 1238 1239 binom(n,m)
1240 dbinom(n,m)
\end{verbatim} 1239 1241 \end{verbatim}
\begin{itemize} 1240 1242 \begin{itemize}
\item n,m are integers 1241 1243 \item n,m are integers
\end{itemize} 1242 1244 \end{itemize}
This function return the binomial coefficient defined by equation \ref{binom} with $n \geq m \geq 0$. 1243 1245 This function return the binomial coefficient defined by equation \ref{binom} with $n \geq m \geq 0$. binom returns a real(4), dbinom a real(8). There's no generic interface for this one.
\begin{equation} 1244 1246 \begin{equation}
\label{binom} 1245 1247 \label{binom}
binom(n,m) = C_n^m = {{n!} \over {m!(n-m)!}} 1246 1248 binom(n,m) = C_n^m = {{n!} \over {m!(n-m)!}}
\end{equation} 1247 1249 \end{equation}
1248 1250
Specific interfaces : \verb'binom,dbinom' 1249 1251 Specific interfaces : \verb'binom,dbinom'
1250 1252
1251 1253
\subsubsection{gamma} 1252 1254 \subsubsection{gamma}
\begin{verbatim} 1253 1255 \begin{verbatim}
gamma(x) 1254 1256 gamma(x)
\end{verbatim} 1255 1257 \end{verbatim}
\begin{itemize} 1256 1258 \begin{itemize}
\item x is a real or complex 1257 1259 \item x is a real or complex
\end{itemize} 1258 1260 \end{itemize}
This function evaluates $ \Gamma (x) $ defined by equation \ref{gamma}. 1259 1261 This function evaluates $ \Gamma (x) $ defined by equation \ref{gamma}.
\begin{equation} 1260 1262 \begin{equation}
\label{gamma} 1261 1263 \label{gamma}
\Gamma (x) = \int _0 ^{\infty} t^{x-1}e^{-t}dt 1262 1264 \Gamma (x) = \int _0 ^{\infty} t^{x-1}e^{-t}dt
\end{equation} 1263 1265 \end{equation}
Note that $n!=\Gamma (n+1)$. 1264 1266 Note that $n!=\Gamma (n+1)$.
1265 1267
Specific interfaces :\verb'gamma,dgamma,cgamma,zgamm' 1266 1268 Specific interfaces :\verb'gamma,dgamma,cgamma,zgamm'
1267 1269
\subsubsection{gamr} 1268 1270 \subsubsection{gamr}
\begin{verbatim} 1269 1271 \begin{verbatim}
gamr(x) 1270 1272 gamr(x)
\end{verbatim} 1271 1273 \end{verbatim}
\begin{itemize} 1272 1274 \begin{itemize}
\item x is a real or complex 1273 1275 \item x is a real or complex
\end{itemize} 1274 1276 \end{itemize}
This function evaluates the reciprocal gamma function $gamr(x)= {1 \over \Gamma(x)}$ 1275 1277 This function evaluates the reciprocal gamma function $gamr(x)= {1 \over \Gamma(x)}$
1276 1278
1277 1279
\subsubsection{alngam} 1278 1280 \subsubsection{alngam}
\begin{verbatim} 1279 1281 \begin{verbatim}
alngam(x) 1280 1282 alngam(x)
\end{verbatim} 1281 1283 \end{verbatim}
\begin{itemize} 1282 1284 \begin{itemize}
\item x is a real or complex 1283 1285 \item x is a real or complex
\end{itemize} 1284 1286 \end{itemize}
This function evaluates $ln(|\Gamma(x)|)$ 1285 1287 This function evaluates $ln(|\Gamma(x)|)$
1286 1288
Specific interfaces : \verb'alngam,dlngam,clngam,zlngam' 1287 1289 Specific interfaces : \verb'alngam,dlngam,clngam,zlngam'
1288 1290
1289 1291
\subsubsection{algams} 1290 1292 \subsubsection{algams}
\begin{verbatim} 1291 1293 \begin{verbatim}
call algams(x,algam,sgngam) 1292 1294 call algams(x,algam,sgngam)
\end{verbatim} 1293 1295 \end{verbatim}
\begin{itemize} 1294 1296 \begin{itemize}
\item x (in) is a real 1295 1297 \item x (in) is a real
\item algam (out) is a real 1296 1298 \item algam (out) is a real
\item sgngam (out) is a real 1297 1299 \item sgngam (out) is a real
\end{itemize} 1298 1300 \end{itemize}
This subroutine evaluates the logarithm of the absolute value of gamma and the sign of gamma. 1299 1301 This subroutine evaluates the logarithm of the absolute value of gamma and the sign of gamma.
$algam=ln(|\Gamma(x)|)$ and $sgngam=1.0$ or $-1.0$ according to the sign of $\Gamma(x)$. 1300 1302 $algam=ln(|\Gamma(x)|)$ and $sgngam=1.0$ or $-1.0$ according to the sign of $\Gamma(x)$.
1301 1303
Specific interfaces : \verb'algams,dlgams' 1302 1304 Specific interfaces : \verb'algams,dlgams'
1303 1305
\subsubsection{gami} 1304 1306 \subsubsection{gami}
\begin{verbatim} 1305 1307 \begin{verbatim}
gami(a,x) 1306 1308 gami(a,x)
\end{verbatim} 1307 1309 \end{verbatim}
\begin{itemize} 1308 1310 \begin{itemize}
\item x is a positive real 1309 1311 \item x is a positive real
\item a is a strictly positive real 1310 1312 \item a is a strictly positive real
\end{itemize} 1311 1313 \end{itemize}
This function evaluates the incomplete gamma function defined by equation \ref{gami}. 1312 1314 This function evaluates the incomplete gamma function defined by equation \ref{gami}.
\begin{equation} 1313 1315 \begin{equation}
\label{gami} 1314 1316 \label{gami}
gami(a,x)=\gamma(a,x)=\int _0 ^x t^{a-1} e^{-t}dt 1315 1317 gami(a,x)=\gamma(a,x)=\int _0 ^x t^{a-1} e^{-t}dt
\end{equation} 1316 1318 \end{equation}
1317 1319
Specific interfaces : \verb'gami,dgami' 1318 1320 Specific interfaces : \verb'gami,dgami'
1319 1321
\subsubsection{gamic} 1320 1322 \subsubsection{gamic}
\begin{verbatim} 1321 1323 \begin{verbatim}
gamic(a,x) 1322 1324 gamic(a,x)
\end{verbatim} 1323 1325 \end{verbatim}
\begin{itemize} 1324 1326 \begin{itemize}
\item x is a positive real 1325 1327 \item x is a positive real
\item a is a real 1326 1328 \item a is a real
\end{itemize} 1327 1329 \end{itemize}
This function evaluates the complementary incomplete gamma function defined by equation \ref{gamic}. 1328 1330 This function evaluates the complementary incomplete gamma function defined by equation \ref{gamic}.
\begin{equation} 1329 1331 \begin{equation}
\label{gamic} 1330 1332 \label{gamic}
gamic(a,x)=\Gamma(a,x)=\int _x ^\infty t^{a-1} e^{-t}dt 1331 1333 gamic(a,x)=\Gamma(a,x)=\int _x ^\infty t^{a-1} e^{-t}dt
\end{equation} 1332 1334 \end{equation}
1333 1335
Specific interfaces : \verb'gamic,dgamic' 1334 1336 Specific interfaces : \verb'gamic,dgamic'
1335 1337
\subsubsection{gamit} 1336 1338 \subsubsection{gamit}
\begin{verbatim} 1337 1339 \begin{verbatim}
gamit(a,x) 1338 1340 gamit(a,x)
\end{verbatim} 1339 1341 \end{verbatim}
\begin{itemize} 1340 1342 \begin{itemize}
\item x is a positive real 1341 1343 \item x is a positive real
\item a is a real 1342 1344 \item a is a real
\end{itemize} 1343 1345 \end{itemize}
This function evaluates the Tricomi's incomplete gamma function defined by equation \ref{gamit}. 1344 1346 This function evaluates the Tricomi's incomplete gamma function defined by equation \ref{gamit}.
\begin{equation} 1345 1347 \begin{equation}
\label{gamit} 1346 1348 \label{gamit}
gamit(a,x)=\gamma^* (a,x)= {{x^{-a}\gamma(a,x)}\over \Gamma(a)} 1347 1349 gamit(a,x)=\gamma^* (a,x)= {{x^{-a}\gamma(a,x)}\over \Gamma(a)}
\end{equation} 1348 1350 \end{equation}
1349 1351
Specific interfaces : \verb'gamit,dgamit' 1350 1352 Specific interfaces : \verb'gamit,dgamit'
1351 1353
1352 1354
\subsubsection{psi} 1353 1355 \subsubsection{psi}
\begin{verbatim} 1354 1356 \begin{verbatim}
psi(x) 1355 1357 psi(x)
\end{verbatim} 1356 1358 \end{verbatim}
\begin{itemize} 1357 1359 \begin{itemize}
\item x is a real or complex 1358 1360 \item x is a real or complex
\end{itemize} 1359 1361 \end{itemize}
This function evaluates the psi function which is the logarithm derivative of the gamma function as defined in equation \ref{psi}. 1360 1362 This function evaluates the psi function which is the logarithm derivative of the gamma function as defined in equation \ref{psi}.
\begin{equation} 1361 1363 \begin{equation}
\label{psi} 1362 1364 \label{psi}
psi(x)= \psi(x) = {d\over dx} ln(\Gamma(x)) 1363 1365 psi(x)= \psi(x) = {d\over dx} ln(\Gamma(x))
\end{equation} 1364 1366 \end{equation}
x must not be zero or a negative integer. 1365 1367 x must not be zero or a negative integer.
1366 1368
Specific interfaces : \verb'psi,dpsi,cpsi,zpsi' 1367 1369 Specific interfaces : \verb'psi,dpsi,cpsi,zpsi'
1368 1370
1369 1371
\subsubsection{poch} 1370 1372 \subsubsection{poch}
\begin{verbatim} 1371 1373 \begin{verbatim}
poch(a,x) 1372 1374 poch(a,x)
\end{verbatim} 1373 1375 \end{verbatim}
\begin{itemize} 1374 1376 \begin{itemize}
\item x is a real 1375 1377 \item x is a real
\item a is a real 1376 1378 \item a is a real
\end{itemize} 1377 1379 \end{itemize}
This function evaluates a generalization of Pochhammer's symbol. 1378 1380 This function evaluates a generalization of Pochhammer's symbol.
1379 1381
Pochhammer's symbol for n a positive integer is given by equation \ref{poch_int} 1380 1382 Pochhammer's symbol for n a positive integer is given by equation \ref{poch_int}
\begin{equation} 1381 1383 \begin{equation}
\label{poch_int} 1382 1384 \label{poch_int}
(a)_n = a(a-1)(a-2)...(a-n+1) 1383 1385 (a)_n = a(a-1)(a-2)...(a-n+1)
\end{equation} 1384 1386 \end{equation}
1385 1387
The generalization of Pochhammer's symbol is given by equation \ref{poch} 1386 1388 The generalization of Pochhammer's symbol is given by equation \ref{poch}
\begin{equation} 1387 1389 \begin{equation}
\label{poch} 1388 1390 \label{poch}
poch(a,x)= (a)_x = {\Gamma(a+x) \over \Gamma(a)} 1389 1391 poch(a,x)= (a)_x = {\Gamma(a+x) \over \Gamma(a)}
\end{equation} 1390 1392 \end{equation}
1391 1393
Specific interfaces : \verb'poch,dpoch' 1392 1394 Specific interfaces : \verb'poch,dpoch'
1393 1395
1394 1396
\subsubsection{poch1} 1395 1397 \subsubsection{poch1}
\begin{verbatim} 1396 1398 \begin{verbatim}
poch1(a,x) 1397 1399 poch1(a,x)
\end{verbatim} 1398 1400 \end{verbatim}
\begin{itemize} 1399 1401 \begin{itemize}
\item x is a real 1400 1402 \item x is a real
\item a is a real 1401 1403 \item a is a real
\end{itemize} 1402 1404 \end{itemize}
This function is defined by equation \ref{poch1}. It is usefull for certains situations, especially when x is small. 1403 1405 This function is defined by equation \ref{poch1}. It is usefull for certains situations, especially when x is small.
1404 1406
\begin{equation} 1405 1407 \begin{equation}
\label{poch1} 1406 1408 \label{poch1}
poch1(a,x)={{(a)_x-1} \over x} 1407 1409 poch1(a,x)={{(a)_x-1} \over x}
\end{equation} 1408 1410 \end{equation}
1409 1411
Specific interfaces : \verb'poch1,dpoch1' 1410 1412 Specific interfaces : \verb'poch1,dpoch1'
1411 1413
\subsubsection{beta} 1412 1414 \subsubsection{beta}
\begin{verbatim} 1413 1415 \begin{verbatim}
beta(a,b) 1414 1416 beta(a,b)
\end{verbatim} 1415 1417 \end{verbatim}
\begin{itemize} 1416 1418 \begin{itemize}
\item a,b are real positive or complex 1417 1419 \item a,b are real positive or complex
\end{itemize} 1418 1420 \end{itemize}
This function evaluates $\beta$ function defined by equation \ref{beta}. 1419 1421 This function evaluates $\beta$ function defined by equation \ref{beta}.
\begin{equation} 1420 1422 \begin{equation}
\label{beta} 1421 1423 \label{beta}
beta(a,b)=\beta(a,b)={ {\Gamma(a) \Gamma(b)} \over \Gamma(a+b) } 1422 1424 beta(a,b)=\beta(a,b)={ {\Gamma(a) \Gamma(b)} \over \Gamma(a+b) }
\end{equation} 1423 1425 \end{equation}
1424 1426
Specific interfaces : \verb'beta,dbeta,cbeta,zbeta' 1425 1427 Specific interfaces : \verb'beta,dbeta,cbeta,zbeta'
1426 1428
1427 1429
\subsubsection{albeta} 1428 1430 \subsubsection{albeta}
\begin{verbatim} 1429 1431 \begin{verbatim}
albeta(a,b) 1430 1432 albeta(a,b)
\end{verbatim} 1431 1433 \end{verbatim}
\begin{itemize} 1432 1434 \begin{itemize}
\item a,b are real positive or complex 1433 1435 \item a,b are real positive or complex
\end{itemize} 1434 1436 \end{itemize}
This function evaluates the natural logarithm of beta function : $ln(\beta(a,b))$ 1435 1437 This function evaluates the natural logarithm of beta function : $ln(\beta(a,b))$
1436 1438
Specific interfaces : \verb'albeta,dlbeta,clbeta,zlbeta' 1437 1439 Specific interfaces : \verb'albeta,dlbeta,clbeta,zlbeta'
1438 1440
\subsubsection{betai} 1439 1441 \subsubsection{betai}
\begin{verbatim} 1440 1442 \begin{verbatim}
betai(x,pin,qin) 1441 1443 betai(x,pin,qin)
\end{verbatim} 1442 1444 \end{verbatim}
\begin{itemize} 1443 1445 \begin{itemize}
\item x is a real in [0,1] 1444 1446 \item x is a real in [0,1]
\item pin and qin are strictly positive real 1445 1447 \item pin and qin are strictly positive real
\end{itemize} 1446 1448 \end{itemize}
This function evaluates the incomplete beta function ratio, that is the probability that a random variable from a beta distribution having parameters pin and qin will be less than or equal to x. It is defined by equation \ref{betai}. 1447 1449 This function evaluates the incomplete beta function ratio, that is the probability that a random variable from a beta distribution having parameters pin and qin will be less than or equal to x. It is defined by equation \ref{betai}.
1448 1450
\begin{equation} 1449 1451 \begin{equation}
\label{betai} 1450 1452 \label{betai}
betai(x,pin,qin)=I_x(pin,qin)={1 \over \beta(pin,qin)} \int _0 ^x t^{pin-1}(1-t)^{qin-1}dt 1451 1453 betai(x,pin,qin)=I_x(pin,qin)={1 \over \beta(pin,qin)} \int _0 ^x t^{pin-1}(1-t)^{qin-1}dt
\end{equation} 1452 1454 \end{equation}
1453 1455
Specific interfaces : \verb'betai,dbetai' 1454 1456 Specific interfaces : \verb'betai,dbetai'
1455 1457
\subsection{Error function and related} 1456 1458 \subsection{Error function and related}
\subsubsection{erf} 1457 1459 \subsubsection{erf}
\begin{verbatim} 1458 1460 \begin{verbatim}
erf(x) 1459 1461 erf(x)
\end{verbatim} 1460 1462 \end{verbatim}
\begin{itemize} 1461 1463 \begin{itemize}
\item x is a real 1462 1464 \item x is a real
\end{itemize} 1463 1465 \end{itemize}
This function evaluates the error function defined by equation \ref{erf}. 1464 1466 This function evaluates the error function defined by equation \ref{erf}.
\begin{equation} 1465 1467 \begin{equation}
\label{erf} 1466 1468 \label{erf}
erf(x)={2\over \sqrt{ \pi}} \int _0 ^x e^{-t^2}dt 1467 1469 erf(x)={2\over \sqrt{ \pi}} \int _0 ^x e^{-t^2}dt
\end{equation} 1468 1470 \end{equation}
1469 1471
Specific interfaces : \verb'erf,derf' 1470 1472 Specific interfaces : \verb'erf,derf'
1471 1473
\subsubsection{erfc} 1472 1474 \subsubsection{erfc}
\begin{verbatim} 1473 1475 \begin{verbatim}
erfc(x) 1474 1476 erfc(x)
\end{verbatim} 1475 1477 \end{verbatim}
\begin{itemize} 1476 1478 \begin{itemize}
\item x is a real 1477 1479 \item x is a real
\end{itemize} 1478 1480 \end{itemize}
This function evaluates the complimentary error function defined by equation \ref{erfc}. 1479 1481 This function evaluates the complimentary error function defined by equation \ref{erfc}.
\begin{equation} 1480 1482 \begin{equation}
\label{erfc} 1481 1483 \label{erfc}
erfc(x)={2\over \sqrt{ \pi}} \int _x ^\infty e^{-t^2}dt 1482 1484 erfc(x)={2\over \sqrt{ \pi}} \int _x ^\infty e^{-t^2}dt
\end{equation} 1483 1485 \end{equation}
1484 1486
Specific interfaces : \verb'erfc,derfc' 1485 1487 Specific interfaces : \verb'erfc,derfc'
1486 1488
1487 1489
\subsubsection{daws} 1488 1490 \subsubsection{daws}
\begin{verbatim} 1489 1491 \begin{verbatim}
daws(x) 1490 1492 daws(x)
\end{verbatim} 1491 1493 \end{verbatim}
\begin{itemize} 1492 1494 \begin{itemize}
\item x is a real 1493 1495 \item x is a real
\end{itemize} 1494 1496 \end{itemize}
This function evaluates Dawson's function defined by equation \ref{daws}. 1495 1497 This function evaluates Dawson's function defined by equation \ref{daws}.
\begin{equation} 1496 1498 \begin{equation}
\label{daws} 1497 1499 \label{daws}
daws(x)=e^{-x^2} \int _0 ^x e^{t^2}dt 1498 1500 daws(x)=e^{-x^2} \int _0 ^x e^{t^2}dt
\end{equation} 1499 1501 \end{equation}
1500 1502
Specific interfaces : \verb'daws,ddaws' 1501 1503 Specific interfaces : \verb'daws,ddaws'
1502 1504
\subsection{Bessel functions and related} 1503 1505 \subsection{Bessel functions and related}
\subsubsection{bsj0} 1504 1506 \subsubsection{bsj0}
\begin{verbatim} 1505 1507 \begin{verbatim}
bsj0(x) 1506 1508 bsj0(x)
\end{verbatim} 1507 1509 \end{verbatim}
\begin{itemize} 1508 1510 \begin{itemize}
\item x is a real 1509 1511 \item x is a real
\end{itemize} 1510 1512 \end{itemize}
This function evaluates Bessel function of the first kind of order 0 defined by equation \ref{bsj0}. 1511 1513 This function evaluates Bessel function of the first kind of order 0 defined by equation \ref{bsj0}.
\begin{equation} 1512 1514 \begin{equation}
\label{bsj0} 1513 1515 \label{bsj0}
bsj0(x)=J_0(x)= {1 \over \pi} \int _0 ^\pi cos(x sin(\theta)) d\theta 1514 1516 bsj0(x)=J_0(x)= {1 \over \pi} \int _0 ^\pi cos(x sin(\theta)) d\theta
fvn_fnlib/fvn_fnlib.f90
Diff comments   View file @ 81b5d24
module fvn_fnlib 1 1 module fvn_fnlib
2 2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3 3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This module is a generic interface for fn library 4 4 ! This module is a generic interface for fn library
! http://www.netlib.org/fn 5 5 ! http://www.netlib.org/fn
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 6 6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7 7
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Elementary Functions 9 9 ! Elementary Functions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 10 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
11 11
! Argument 12 12 ! Argument
interface carg 13 13 interface carg
real(4) function carg(z) 14 14 real(4) function carg(z)
complex(4) :: z 15 15 complex(4) :: z
end function carg 16 16 end function carg
real(8) function zarg(z) 17 17 real(8) function zarg(z)
complex(8) :: z 18 18 complex(8) :: z
end function zarg 19 19 end function zarg
end interface carg 20 20 end interface carg
21 21
! Cubic root 22 22 ! Cubic root
interface cbrt 23 23 interface cbrt
real(4) function cbrt(x) 24 24 real(4) function cbrt(x)
real(4) :: x 25 25 real(4) :: x
end function cbrt 26 26 end function cbrt
real(8) function dcbrt(x) 27 27 real(8) function dcbrt(x)
real(8) :: x 28 28 real(8) :: x
end function dcbrt 29 29 end function dcbrt
complex(4) function ccbrt(z) 30 30 complex(4) function ccbrt(z)
complex(4) :: z 31 31 complex(4) :: z
end function ccbrt 32 32 end function ccbrt
complex(8) function zcbrt(z) 33 33 complex(8) function zcbrt(z)
complex(8) :: z 34 34 complex(8) :: z
end function zcbrt 35 35 end function zcbrt
end interface cbrt 36 36 end interface cbrt
37 37
! (exp(x) -1)/x 38 38 ! (exp(x) -1)/x
interface exprl 39 39 interface exprl
real(4) function exprel(x) 40 40 real(4) function exprel(x)
real(4) :: x 41 41 real(4) :: x
end function exprel 42 42 end function exprel
real(8) function dexprl(x) 43 43 real(8) function dexprl(x)
real(8) :: x 44 44 real(8) :: x
end function dexprl 45 45 end function dexprl
complex(4) function cexprl(z) 46 46 complex(4) function cexprl(z)
complex(4) :: z 47 47 complex(4) :: z
end function cexprl 48 48 end function cexprl
complex(8) function zexprl(z) 49 49 complex(8) function zexprl(z)
complex(8) :: z 50 50 complex(8) :: z
end function zexprl 51 51 end function zexprl
end interface exprl 52 52 end interface exprl
53 53
! log10 extension to complex arguments 54 54 ! log10 extension to complex arguments
interface log10 55 55 interface log10
complex(4) function clog10(z) 56 56 complex(4) function clog10(z)
complex(4) :: z 57 57 complex(4) :: z
end function clog10 58 58 end function clog10
complex(8) function zlog10(z) 59 59 complex(8) function zlog10(z)
complex(8) :: z 60 60 complex(8) :: z
end function zlog10 61 61 end function zlog10
end interface log10 62 62 end interface log10
63 63
! ln(x+1) 64 64 ! ln(x+1)
interface alnrel 65 65 interface alnrel
real(4) function alnrel(x) 66 66 real(4) function alnrel(x)
real(4) :: x 67 67 real(4) :: x
end function alnrel 68 68 end function alnrel
real(8) function dlnrel(x) 69 69 real(8) function dlnrel(x)
real(8) :: x 70 70 real(8) :: x
end function dlnrel 71 71 end function dlnrel
complex(4) function clnrel(z) 72 72 complex(4) function clnrel(z)
complex(4) :: z 73 73 complex(4) :: z
end function clnrel 74 74 end function clnrel
complex(8) function zlnrel(z) 75 75 complex(8) function zlnrel(z)
complex(8) :: z 76 76 complex(8) :: z
end function zlnrel 77 77 end function zlnrel
end interface alnrel 78 78 end interface alnrel
79 79
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 80 80 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Elementary Functions 81 81 ! END Elementary Functions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 82 82 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
83 83
84 84
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 85 85 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Trigonometry 86 86 ! Trigonometry
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 87 87 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
88 88
! Extension de la tangente aux arguments complexes 89 89 ! Extension de la tangente aux arguments complexes
interface tan 90 90 interface tan
complex(4) function ctan(z) 91 91 complex(4) function ctan(z)
complex(4) :: z 92 92 complex(4) :: z
end function ctan 93 93 end function ctan
complex(8) function ztan(z) 94 94 complex(8) function ztan(z)
complex(8) :: z 95 95 complex(8) :: z
end function ztan 96 96 end function ztan
end interface tan 97 97 end interface tan
98 98
! Cotangente 99 99 ! Cotangente
interface cot 100 100 interface cot
real(4) function cot(x) 101 101 real(4) function cot(x)
real(4) :: x 102 102 real(4) :: x
end function cot 103 103 end function cot
real(8) function dcot(x) 104 104 real(8) function dcot(x)
real(8) :: x 105 105 real(8) :: x
end function dcot 106 106 end function dcot
complex(4) function ccot(z) 107 107 complex(4) function ccot(z)
complex(4) :: z 108 108 complex(4) :: z
end function ccot 109 109 end function ccot
complex(8) function zcot(z) 110 110 complex(8) function zcot(z)
complex(8) :: z 111 111 complex(8) :: z
end function zcot 112 112 end function zcot
end interface cot 113 113 end interface cot
114 114
! Sinus in degree 115 115 ! Sinus in degree
interface sindg 116 116 interface sindg
real(4) function sindg(x) 117 117 real(4) function sindg(x)
real(4) :: x 118 118 real(4) :: x
end function sindg 119 119 end function sindg
real(8) function dsindg(x) 120 120 real(8) function dsindg(x)
real(8) :: x 121 121 real(8) :: x
end function dsindg 122 122 end function dsindg
end interface sindg 123 123 end interface sindg
124 124
! Cosinus in degree 125 125 ! Cosinus in degree
interface cosdg 126 126 interface cosdg
real(4) function cosdg(x) 127 127 real(4) function cosdg(x)
real(4) :: x 128 128 real(4) :: x
end function cosdg 129 129 end function cosdg
real(8) function dcosdg(x) 130 130 real(8) function dcosdg(x)
real(8) :: x 131 131 real(8) :: x
end function dcosdg 132 132 end function dcosdg
end interface cosdg 133 133 end interface cosdg
134 134
135 135
! Extension de l'arcsinus aux arguments complexes 136 136 ! Extension de l'arcsinus aux arguments complexes
interface asin 137 137 interface asin
complex(4) function casin(z) 138 138 complex(4) function casin(z)
complex(4) :: z 139 139 complex(4) :: z
end function casin 140 140 end function casin
complex(8) function zasin(z) 141 141 complex(8) function zasin(z)
complex(8) :: z 142 142 complex(8) :: z
end function zasin 143 143 end function zasin
end interface asin 144 144 end interface asin
145 145
! Extension de l'arccosinus aux arguments complexes 146 146 ! Extension de l'arccosinus aux arguments complexes
interface acos 147 147 interface acos
complex(4) function cacos(z) 148 148 complex(4) function cacos(z)
complex(4) :: z 149 149 complex(4) :: z
end function cacos 150 150 end function cacos
complex(8) function zacos(z) 151 151 complex(8) function zacos(z)
complex(8) :: z 152 152 complex(8) :: z
end function zacos 153 153 end function zacos
end interface acos 154 154 end interface acos
155 155
! Extension de l'arctangente aux arguments complexes 156 156 ! Extension de l'arctangente aux arguments complexes
interface atan 157 157 interface atan
complex(4) function catan(z) 158 158 complex(4) function catan(z)
complex(4) :: z 159 159 complex(4) :: z
end function catan 160 160 end function catan
complex(8) function zatan(z) 161 161 complex(8) function zatan(z)
complex(8) :: z 162 162 complex(8) :: z
end function zatan 163 163 end function zatan
end interface atan 164 164 end interface atan
165 165
! Extension de atan2 aux arguments complexes 166 166 ! Extension de atan2 aux arguments complexes
interface atan2 167 167 interface atan2
complex(4) function catan2(csn,ccs) 168 168 complex(4) function catan2(csn,ccs)
complex(4) :: csn,ccs 169 169 complex(4) :: csn,ccs
end function catan2 170 170 end function catan2
complex(8) function zatan2(csn,ccs) 171 171 complex(8) function zatan2(csn,ccs)
complex(8) :: csn,ccs 172 172 complex(8) :: csn,ccs
end function zatan2 173 173 end function zatan2
end interface atan2 174 174 end interface atan2
175 175
176 176
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 177 177 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Hyperbolic Trigonometry 178 178 ! Hyperbolic Trigonometry
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 179 179 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Extension du Sinus hyperbolique aux arguments complexes 180 180 ! Extension du Sinus hyperbolique aux arguments complexes
interface sinh 181 181 interface sinh
complex(4) function csinh(z) 182 182 complex(4) function csinh(z)
complex(4) :: z 183 183 complex(4) :: z
end function csinh 184 184 end function csinh
complex(8) function zsinh(z) 185 185 complex(8) function zsinh(z)
complex(8) :: z 186 186 complex(8) :: z
end function zsinh 187 187 end function zsinh
end interface sinh 188 188 end interface sinh
189 189
! Extension du Cosinus hyperbolique aux arguments complexes 190 190 ! Extension du Cosinus hyperbolique aux arguments complexes
interface cosh 191 191 interface cosh
complex(4) function ccosh(z) 192 192 complex(4) function ccosh(z)
complex(4) :: z 193 193 complex(4) :: z
end function ccosh 194 194 end function ccosh
complex(8) function zcosh(z) 195 195 complex(8) function zcosh(z)
complex(8) :: z 196 196 complex(8) :: z
end function zcosh 197 197 end function zcosh
end interface cosh 198 198 end interface cosh
199 199
! Extension de la tangente hyperbolique aux arguments complexes 200 200 ! Extension de la tangente hyperbolique aux arguments complexes
interface tanh 201 201 interface tanh
complex(4) function ctanh(z) 202 202 complex(4) function ctanh(z)
complex(4) :: z 203 203 complex(4) :: z
end function ctanh 204 204 end function ctanh
complex(8) function ztanh(z) 205 205 complex(8) function ztanh(z)
complex(8) :: z 206 206 complex(8) :: z
end function ztanh 207 207 end function ztanh
end interface tanh 208 208 end interface tanh
209 209
! Arc sinus hyperbolique 210 210 ! Arc sinus hyperbolique
interface asinh 211 211 interface asinh
real(4) function asinh(x) 212 212 real(4) function asinh(x)
real(4) :: x 213 213 real(4) :: x
end function asinh 214 214 end function asinh
real(8) function dasinh(x) 215 215 real(8) function dasinh(x)
real(8) :: x 216 216 real(8) :: x
end function dasinh 217 217 end function dasinh
complex(4) function casinh(z) 218 218 complex(4) function casinh(z)
complex(4) :: z 219 219 complex(4) :: z
end function casinh 220 220 end function casinh
complex(8) function zasinh(z) 221 221 complex(8) function zasinh(z)
complex(8) :: z 222 222 complex(8) :: z
end function zasinh 223 223 end function zasinh
end interface asinh 224 224 end interface asinh
225 225
! Arc cosinus hyperbolique 226 226 ! Arc cosinus hyperbolique
interface acosh 227 227 interface acosh
real(4) function acosh(x) 228 228 real(4) function acosh(x)
real(4) :: x 229 229 real(4) :: x
end function acosh 230 230 end function acosh
real(8) function dacosh(x) 231 231 real(8) function dacosh(x)
real(8) :: x 232 232 real(8) :: x
end function dacosh 233 233 end function dacosh
complex(4) function cacosh(z) 234 234 complex(4) function cacosh(z)
complex(4) :: z 235 235 complex(4) :: z
end function cacosh 236 236 end function cacosh
complex(8) function zacosh(z) 237 237 complex(8) function zacosh(z)
238 complex(8) :: z
end function zacosh 238 239 end function zacosh
end interface acosh 239 240 end interface acosh
240 241
! Arc tangente hyperbolique 241 242 ! Arc tangente hyperbolique
interface atanh 242 243 interface atanh
real(4) function atanh(x) 243 244 real(4) function atanh(x)
real(4) :: x 244 245 real(4) :: x
end function atanh 245 246 end function atanh
real(8) function datanh(x) 246 247 real(8) function datanh(x)
real(8) :: x 247 248 real(8) :: x
end function datanh 248 249 end function datanh
complex(4) function catanh(z) 249 250 complex(4) function catanh(z)
complex(4) :: z 250 251 complex(4) :: z
end function catanh 251 252 end function catanh
complex(8) function zatanh(z) 252 253 complex(8) function zatanh(z)
complex(8) :: z 253 254 complex(8) :: z
end function zatanh 254 255 end function zatanh
end interface atanh 255 256 end interface atanh
256 257
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 257 258 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Trigonometry 258 259 ! END Trigonometry
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 259 260 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
260 261
261 262
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 262 263 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Exponential integral and related 263 264 ! Exponential integral and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 264 265 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
265 266
! Exponential integral ei(x) 266 267 ! Exponential integral ei(x)
interface ei 267 268 interface ei
real(4) function ei(x) 268 269 real(4) function ei(x)
real(4) :: x 269 270 real(4) :: x
end function ei 270 271 end function ei
real(8) function dei(x) 271 272 real(8) function dei(x)
real(8) :: x 272 273 real(8) :: x
end function dei 273 274 end function dei
end interface ei 274 275 end interface ei
275 276
! Exponential integral e1(x) 276 277 ! Exponential integral e1(x)
interface e1 277 278 interface e1
real(4) function e1(x) 278 279 real(4) function e1(x)
real(4) :: x 279 280 real(4) :: x
end function e1 280 281 end function e1
real(8) function de1(x) 281 282 real(8) function de1(x)
real(8) :: x 282 283 real(8) :: x
end function de1 283 284 end function de1
end interface e1 284 285 end interface e1
285 286
!!!!!!!!!!!!!!! 286 287 !!!!!!!!!!!!!!!
! MISSING ENE 287 288 ! MISSING ENE
!!!!!!!!!!!!!!! 288 289 !!!!!!!!!!!!!!!
289 290
! Logarithm integral 290 291 ! Logarithm integral
interface ali 291 292 interface ali
real(4) function ali(x) 292 293 real(4) function ali(x)
real(4) :: x 293 294 real(4) :: x
end function ali 294 295 end function ali
real(8) function dli(x) 295 296 real(8) function dli(x)
real(8) :: x 296 297 real(8) :: x
end function dli 297 298 end function dli
end interface ali 298 299 end interface ali
299 300
! Sine integral 300 301 ! Sine integral
interface si 301 302 interface si
real(4) function si(x) 302 303 real(4) function si(x)
real(4) :: x 303 304 real(4) :: x
end function si 304 305 end function si
real(8) function dsi(x) 305 306 real(8) function dsi(x)
real(8) :: x 306 307 real(8) :: x
end function dsi 307 308 end function dsi
end interface si 308 309 end interface si
309 310
! Cosine integral 310 311 ! Cosine integral
interface ci 311 312 interface ci
real(4) function ci(x) 312 313 real(4) function ci(x)
real(4) :: x 313 314 real(4) :: x
end function ci 314 315 end function ci
real(8) function dci(x) 315 316 real(8) function dci(x)
real(8) :: x 316 317 real(8) :: x
end function dci 317 318 end function dci
end interface ci 318 319 end interface ci
319 320
! Cosine integral alternate definition 320 321 ! Cosine integral alternate definition
interface cin 321 322 interface cin
real(4) function cin(x) 322 323 real(4) function cin(x)
real(4) :: x 323 324 real(4) :: x
end function cin 324 325 end function cin
real(8) function dcin(x) 325 326 real(8) function dcin(x)
real(8) :: x 326 327 real(8) :: x
end function dcin 327 328 end function dcin
end interface cin 328 329 end interface cin
329 330
! Hyperbolic sine integral 330 331 ! Hyperbolic sine integral
interface shi 331 332 interface shi
real(4) function shi(x) 332 333 real(4) function shi(x)
real(4) :: x 333 334 real(4) :: x
end function shi 334 335 end function shi
real(8) function dshi(x) 335 336 real(8) function dshi(x)
real(8) :: x 336 337 real(8) :: x
end function dshi 337 338 end function dshi
end interface shi 338 339 end interface shi
339 340
! Hyperbolic cosine integral 340 341 ! Hyperbolic cosine integral
interface chi 341 342 interface chi
real(4) function chi(x) 342 343 real(4) function chi(x)
real(4) :: x 343 344 real(4) :: x
end function chi 344 345 end function chi
real(8) function dchi(x) 345 346 real(8) function dchi(x)
real(8) :: x 346 347 real(8) :: x
end function dchi 347 348 end function dchi
end interface chi 348 349 end interface chi
349 350
! Hyperbolic cosine integral alternate definition 350 351 ! Hyperbolic cosine integral alternate definition
interface cinh 351 352 interface cinh
real(4) function cinh(x) 352 353 real(4) function cinh(x)
real(4) :: x 353 354 real(4) :: x
end function cinh 354 355 end function cinh
real(8) function dcinh(x) 355 356 real(8) function dcinh(x)
real(8) :: x 356 357 real(8) :: x
end function dcinh 357 358 end function dcinh
end interface cinh 358 359 end interface cinh
359 360
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 360 361 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Exponential integral and related 361 362 ! END Exponential integral and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 362 363 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
363 364
364 365
365 366
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 366 367 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Gamma family 367 368 ! Gamma family
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 368 369 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
369 370
371 ! No generic interface for fac and binom but we still
372 ! define their prototypes
! Factorial 370 373 ! Factorial
interface fac 371 374 interface
real(4) function fac(n) 372 375 real(4) function fac(n)
integer(4) :: n 373 376 integer(4) :: n
end function fac 374 377 end function fac
real(8) function dfac(n) 375 378 real(8) function dfac(n)
integer(4) :: n 376 379 integer(4) :: n
end function dfac 377 380 end function dfac
end interface fac 378
379
! Binomial coefficient 380 381 ! Binomial coefficient
interface binom 381
real(4) function binom(n,m) 382 382 real(4) function binom(n,m)
integer(4) :: n,m 383 383 integer(4) :: n,m
end function binom 384 384 end function binom
real(8) function dbinom(n,m) 385 385 real(8) function dbinom(n,m)
integer(4) :: n,m 386 386 integer(4) :: n,m
end function dbinom 387 387 end function dbinom
end interface binom 388 388 end interface
389 389
! Gamma function 390 390 ! Gamma function
interface gamma 391 391 interface gamma
real(4) function gamma(x) 392 392 real(4) function gamma(x)
real(4) :: x 393 393 real(4) :: x
end function gamma 394 394 end function gamma
real(8) function dgamma(x) 395 395 real(8) function dgamma(x)
real(8) :: x 396 396 real(8) :: x
end function dgamma 397 397 end function dgamma
complex(4) function cgamma(z) 398 398 complex(4) function cgamma(z)
complex(4) :: z 399 399 complex(4) :: z
end function cgamma 400 400 end function cgamma
complex(8) function zgamma(z) 401 401 complex(8) function zgamma(z)
complex(8) :: z 402 402 complex(8) :: z
end function zgamma 403 403 end function zgamma
end interface gamma 404 404 end interface gamma
405 405
! Reciprocal of gamma function 406 406 ! Reciprocal of gamma function
interface gamr 407 407 interface gamr
real(4) function gamr(x) 408 408 real(4) function gamr(x)
real(4) :: x 409 409 real(4) :: x
end function gamr 410 410 end function gamr
real(8) function dgamr(x) 411 411 real(8) function dgamr(x)
real(8) :: x 412 412 real(8) :: x
end function dgamr 413 413 end function dgamr
complex(4) function cgamr(z) 414 414 complex(4) function cgamr(z)
complex(4) :: z 415 415 complex(4) :: z
end function cgamr 416 416 end function cgamr
complex(8) function zgamr(z) 417 417 complex(8) function zgamr(z)
complex(8) :: z 418 418 complex(8) :: z
end function zgamr 419 419 end function zgamr
end interface gamr 420 420 end interface gamr
421 421
! natural log of abs(gamma) 422 422 ! natural log of abs(gamma)
interface alngam 423 423 interface alngam
real(4) function alngam(x) 424 424 real(4) function alngam(x)
real(4) :: x 425 425 real(4) :: x
end function alngam 426 426 end function alngam
real(8) function dlngam(x) 427 427 real(8) function dlngam(x)
real(8) :: x 428 428 real(8) :: x
end function dlngam 429 429 end function dlngam
complex(4) function clngam(z) 430 430 complex(4) function clngam(z)
complex(4) :: z 431 431 complex(4) :: z
end function clngam 432 432 end function clngam
complex(8) function zlngam(z) 433 433 complex(8) function zlngam(z)
complex(8) :: z 434 434 complex(8) :: z
end function zlngam 435 435 end function zlngam
end interface alngam 436 436 end interface alngam
437 437
! log abs gamma and sign 438 438 ! log abs gamma and sign
interface algams 439 439 interface algams
subroutine algams(x,algam,sgngam) 440 440 subroutine algams(x,algam,sgngam)
real(4) :: x 441 441 real(4) :: x
end subroutine algams 442 442 end subroutine algams
subroutine dlgams(x,algam,sgngam) 443 443 subroutine dlgams(x,algam,sgngam)
real(8) :: x 444 444 real(8) :: x
end subroutine dlgams 445 445 end subroutine dlgams
end interface algams 446 446 end interface algams
447 447
! Incomplete gamma function 448 448 ! Incomplete gamma function
interface gami 449 449 interface gami
real(4) function gami(a,x) 450 450 real(4) function gami(a,x)
real(4) :: a,x 451 451 real(4) :: a,x
end function gami 452 452 end function gami
real(8) function dgami(a,x) 453 453 real(8) function dgami(a,x)
real(8) :: a,x 454 454 real(8) :: a,x
end function dgami 455 455 end function dgami
end interface gami 456 456 end interface gami
457 457
! Complementary incomplete gamma function 458 458 ! Complementary incomplete gamma function
interface gamic 459 459 interface gamic
real(4) function gamic(a,x) 460 460 real(4) function gamic(a,x)
real(4) :: a,x 461 461 real(4) :: a,x
end function gamic 462 462 end function gamic
real(8) function dgamic(a,x) 463 463 real(8) function dgamic(a,x)
real(8) :: a,x 464 464 real(8) :: a,x
end function dgamic 465 465 end function dgamic
end interface gamic 466 466 end interface gamic
467 467
! Tricomi's incomplete gamma function 468 468 ! Tricomi's incomplete gamma function
interface gamit 469 469 interface gamit
real(4) function gamit(a,x) 470 470 real(4) function gamit(a,x)
real(4) :: a,x 471 471 real(4) :: a,x
end function gamit 472 472 end function gamit
real(8) function dgamit(a,x) 473 473 real(8) function dgamit(a,x)
real(8) :: a,x 474 474 real(8) :: a,x
end function dgamit 475 475 end function dgamit
end interface gamit 476 476 end interface gamit
477 477
! Psi function 478 478 ! Psi function
interface psi 479 479 interface psi
real(4) function psi(x) 480 480 real(4) function psi(x)
real(4) :: x 481 481 real(4) :: x
end function psi 482 482 end function psi
real(8) function dpsi(x) 483 483 real(8) function dpsi(x)
real(8) :: x 484 484 real(8) :: x
end function dpsi 485 485 end function dpsi
complex(4) function cpsi(z) 486 486 complex(4) function cpsi(z)
complex(4) :: z 487 487 complex(4) :: z
end function cpsi 488 488 end function cpsi
complex(8) function zpsi(z) 489 489 complex(8) function zpsi(z)
complex(8) :: z 490 490 complex(8) :: z
end function zpsi 491 491 end function zpsi
end interface psi 492 492 end interface psi
493 493
! Pochhammer 494 494 ! Pochhammer
interface poch 495 495 interface poch
real(4) function poch(a,x) 496 496 real(4) function poch(a,x)
real(4) :: a,x 497 497 real(4) :: a,x
end function poch 498 498 end function poch
real(8) function dpoch(a,x) 499 499 real(8) function dpoch(a,x)
real(8) :: a,x 500 500 real(8) :: a,x
end function dpoch 501 501 end function dpoch
end interface poch 502 502 end interface poch
503 503
! Pochhammer first order 504 504 ! Pochhammer first order
interface poch1 505 505 interface poch1
real(4) function poch1(a,x) 506 506 real(4) function poch1(a,x)
real(4) :: a,x 507 507 real(4) :: a,x
end function poch1 508 508 end function poch1
real(8) function dpoch1(a,x) 509 509 real(8) function dpoch1(a,x)
real(8) :: a,x 510 510 real(8) :: a,x
end function dpoch1 511 511 end function dpoch1
end interface poch1 512 512 end interface poch1
513 513
! Beta function 514 514 ! Beta function
interface beta 515 515 interface beta
real(4) function beta(a,b) 516 516 real(4) function beta(a,b)
real(4) :: a,b 517 517 real(4) :: a,b
end function beta 518 518 end function beta
real(8) function dbeta(a,b) 519 519 real(8) function dbeta(a,b)
real(8) :: a,b 520 520 real(8) :: a,b
end function dbeta 521 521 end function dbeta
complex(4) function cbeta(a,b) 522 522 complex(4) function cbeta(a,b)
complex(4) :: a,b 523 523 complex(4) :: a,b
end function cbeta 524 524 end function cbeta
complex(8) function zbeta(a,b) 525 525 complex(8) function zbeta(a,b)
complex(8) :: a,b 526 526 complex(8) :: a,b
end function zbeta 527 527 end function zbeta
end interface beta 528 528 end interface beta
529 529
! natural log of beta 530 530 ! natural log of beta
interface albeta 531 531 interface albeta
real(4) function albeta(a,b) 532 532 real(4) function albeta(a,b)
real(4) :: a,b 533 533 real(4) :: a,b
end function albeta 534 534 end function albeta
real(8) function dlbeta(a,b) 535 535 real(8) function dlbeta(a,b)
real(8) :: a,b 536 536 real(8) :: a,b
end function dlbeta 537 537 end function dlbeta
complex(4) function clbeta(a,b) 538 538 complex(4) function clbeta(a,b)
complex(4) :: a,b 539 539 complex(4) :: a,b
end function clbeta 540 540 end function clbeta
complex(8) function zlbeta(a,b) 541 541 complex(8) function zlbeta(a,b)
complex(8) :: a,b 542 542 complex(8) :: a,b
end function zlbeta 543 543 end function zlbeta
end interface albeta 544 544 end interface albeta
545 545
! Incomplete beta function 546 546 ! Incomplete beta function
interface betai 547 547 interface betai
real(4) function betai(x,pin,qin) 548 548 real(4) function betai(x,pin,qin)
real(4) :: x,pin,qin 549 549 real(4) :: x,pin,qin
end function betai 550 550 end function betai
real(8) function dbetai(x,pin,qin) 551 551 real(8) function dbetai(x,pin,qin)
real(8) :: x,pin,qin 552 552 real(8) :: x,pin,qin
end function dbetai 553 553 end function dbetai
end interface betai 554 554 end interface betai
555 555
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 556 556 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Gamma family 557 557 ! END Gamma family
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 558 558 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
559 559
560 560
561 561
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 562 562 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Error function and related 563 563 ! Error function and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 564 564 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
565 565
! Error function 566 566 ! Error function
interface erf 567 567 interface erf
real(4) function erf(x) 568 568 real(4) function erf(x)
real(4) :: x 569 569 real(4) :: x
end function erf 570 570 end function erf
real(8) function derf(x) 571 571 real(8) function derf(x)
real(8) :: x 572 572 real(8) :: x
end function derf 573 573 end function derf
end interface erf 574 574 end interface erf
575 575
! Complementary error function 576 576 ! Complementary error function
interface erfc 577 577 interface erfc
real(4) function erfc(x) 578 578 real(4) function erfc(x)
real(4) :: x 579 579 real(4) :: x
end function erfc 580 580 end function erfc
real(8) function derfc(x) 581 581 real(8) function derfc(x)
real(8) :: x 582 582 real(8) :: x
end function derfc 583 583 end function derfc
end interface erfc 584 584 end interface erfc
585 585
!!!!!!!!!!! 586 586 !!!!!!!!!!!
! MISSING ERFCE 587 587 ! MISSING ERFCE
! MISSING CERFI 588 588 ! MISSING CERFI
! MISSING ERFI 589 589 ! MISSING ERFI
! MISSING ERFCI 590 590 ! MISSING ERFCI
!!!!!!!!!!!!!! 591 591 !!!!!!!!!!!!!!
592 592
! Dawson's function 593 593 ! Dawson's function
interface daws 594 594 interface daws
real(4) function daws(x) 595 595 real(4) function daws(x)
real(4) :: x 596 596 real(4) :: x
end function daws 597 597 end function daws
real(8) function ddaws(x) 598 598 real(8) function ddaws(x)
real(8) :: x 599 599 real(8) :: x
end function ddaws 600 600 end function ddaws
end interface daws 601 601 end interface daws
602 602
!!!!!!!!!!!!!!!!! 603 603 !!!!!!!!!!!!!!!!!
! MISSING FRESC 604 604 ! MISSING FRESC
! MISSING FRESS 605 605 ! MISSING FRESS
!!!!!!!!!!!!!!!!! 606 606 !!!!!!!!!!!!!!!!!
607 607
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 608 608 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Error function and related 609 609 ! END Error function and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 610 610 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
611 611
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 612 612 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Bessel functions and related 613 613 ! Bessel functions and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 614 614 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
615 615
!J0(x) 616 616 !J0(x)
interface bsj0 617 617 interface bsj0
real(4) function besj0(x) 618 618 real(4) function besj0(x)
real(4) :: x 619 619 real(4) :: x
end function besj0 620 620 end function besj0
real(8) function dbesj0(x) 621 621 real(8) function dbesj0(x)
real(8) :: x 622 622 real(8) :: x
end function dbesj0 623 623 end function dbesj0
end interface bsj0 624 624 end interface bsj0
625 625
!J1(x) 626 626 !J1(x)
interface bsj1 627 627 interface bsj1
real(4) function besj1(x) 628 628 real(4) function besj1(x)
real(4) :: x 629 629 real(4) :: x
end function besj1 630 630 end function besj1
real(8) function dbesj1(x) 631 631 real(8) function dbesj1(x)
real(8) :: x 632 632 real(8) :: x
end function dbesj1 633 633 end function dbesj1
end interface bsj1 634 634 end interface bsj1
635 635
!Y0(x) 636 636 !Y0(x)
interface bsy0 637 637 interface bsy0
real(4) function besy0(x) 638 638 real(4) function besy0(x)
real(4) :: x 639 639 real(4) :: x
end function besy0 640 640 end function besy0
real(8) function dbesy0(x) 641 641 real(8) function dbesy0(x)
real(8) x 642 642 real(8) x
end function dbesy0 643 643 end function dbesy0
end interface bsy0 644 644 end interface bsy0
645 645
!Y1(x) 646 646 !Y1(x)
interface bsy1 647 647 interface bsy1
real(4) function besy1(x) 648 648 real(4) function besy1(x)
real(4) :: x 649 649 real(4) :: x
end function besy1 650 650 end function besy1
real(8) function dbesy1(x) 651 651 real(8) function dbesy1(x)
real(8) x 652 652 real(8) x
end function dbesy1 653 653 end function dbesy1
end interface bsy1 654 654 end interface bsy1
655 655
!I0(x) 656 656 !I0(x)
interface bsi0 657 657 interface bsi0
real(4) function besi0(x) 658 658 real(4) function besi0(x)
real(4) :: x 659 659 real(4) :: x
end function besi0 660 660 end function besi0
real(8) function dbesi0(x) 661 661 real(8) function dbesi0(x)
real(8) x 662 662 real(8) x
end function dbesi0 663 663 end function dbesi0
end interface bsi0 664 664 end interface bsi0
665 665
!I1(x) 666 666 !I1(x)
interface bsi1 667 667 interface bsi1
real(4) function besi1(x) 668 668 real(4) function besi1(x)
real(4) :: x 669 669 real(4) :: x
end function besi1 670 670 end function besi1
real(8) function dbesi1(x) 671 671 real(8) function dbesi1(x)
real(8) x 672 672 real(8) x
end function dbesi1 673 673 end function dbesi1
end interface bsi1 674 674 end interface bsi1
675 675
!K0(x) 676 676 !K0(x)
interface bsk0 677 677 interface bsk0
real(4) function besk0(x) 678 678 real(4) function besk0(x)
real(4) :: x 679 679 real(4) :: x
end function besk0 680 680 end function besk0
real(8) function dbesk0(x) 681 681 real(8) function dbesk0(x)
real(8) x 682 682 real(8) x
end function dbesk0 683 683 end function dbesk0
end interface bsk0 684 684 end interface bsk0
685 685
!K1(x) 686 686 !K1(x)
interface bsk1 687 687 interface bsk1
real(4) function besk1(x) 688 688 real(4) function besk1(x)
real(4) :: x 689 689 real(4) :: x
end function besk1 690 690 end function besk1
real(8) function dbesk1(x) 691 691 real(8) function dbesk1(x)
real(8) x 692 692 real(8) x
end function dbesk1 693 693 end function dbesk1
end interface bsk1 694 694 end interface bsk1
695 695
! Exponentially scaled I0 696 696 ! Exponentially scaled I0
interface bsi0e 697 697 interface bsi0e
real(4) function besi0e(x) 698 698 real(4) function besi0e(x)
real(4) :: x 699 699 real(4) :: x
end function besi0e 700 700 end function besi0e
real(8) function dbsi0e(x) 701 701 real(8) function dbsi0e(x)
real(8) :: x 702 702 real(8) :: x
end function dbsi0e 703 703 end function dbsi0e
end interface bsi0e 704 704 end interface bsi0e
705 705
! Exponentially scaled I1 706 706 ! Exponentially scaled I1
interface bsi1e 707 707 interface bsi1e
real(4) function besi1e(x) 708 708 real(4) function besi1e(x)
real(4) :: x 709 709 real(4) :: x
end function besi1e 710 710 end function besi1e
real(8) function dbsi1e(x) 711 711 real(8) function dbsi1e(x)
real(8) :: x 712 712 real(8) :: x
end function dbsi1e 713 713 end function dbsi1e
end interface bsi1e 714 714 end interface bsi1e
715 715
! Exponentially scaled K0 716 716 ! Exponentially scaled K0
interface bsk0e 717 717 interface bsk0e
real(4) function besk0e(x) 718 718 real(4) function besk0e(x)
real(4) :: x 719 719 real(4) :: x
end function besk0e 720 720 end function besk0e
real(8) function dbsk0e(x) 721 721 real(8) function dbsk0e(x)
real(8) :: x 722 722 real(8) :: x
end function dbsk0e 723 723 end function dbsk0e
end interface bsk0e 724 724 end interface bsk0e
725 725
! Exponentially scaled K1 726 726 ! Exponentially scaled K1
interface bsk1e 727 727 interface bsk1e
real(4) function besk1e(x) 728 728 real(4) function besk1e(x)
real(4) :: x 729 729 real(4) :: x
end function besk1e 730 730 end function besk1e
real(8) function dbsk1e(x) 731 731 real(8) function dbsk1e(x)
real(8) :: x 732 732 real(8) :: x
end function dbsk1e 733 733 end function dbsk1e
end interface bsk1e 734 734 end interface bsk1e
735 735
!!!!!!!!!!!!!!!!!!!!! 736 736 !!!!!!!!!!!!!!!!!!!!!
! MISSING BSJNS 737 737 ! MISSING BSJNS
! MISSING BSINS 738 738 ! MISSING BSINS
! MISSING BSJS 739 739 ! MISSING BSJS
! MISSING BSYS 740 740 ! MISSING BSYS
! MISSING BSIS 741 741 ! MISSING BSIS
! MISSING BSIES 742 742 ! MISSING BSIES
!!!!!!!!!!!!!!!!!!!!! 743 743 !!!!!!!!!!!!!!!!!!!!!
744 744
! K nu + k 745 745 ! K nu + k
interface bsks 746 746 interface bsks
subroutine besks(xnu,x,nin,bk) 747 747 subroutine besks(xnu,x,nin,bk)
real(4) :: xnu,x 748 748 real(4) :: xnu,x
integer :: nin 749 749 integer :: nin
real(4), dimension(nin) :: bk 750 750 real(4), dimension(nin) :: bk
end subroutine besks 751 751 end subroutine besks
subroutine dbesks(xnu,x,nin,bk) 752 752 subroutine dbesks(xnu,x,nin,bk)
real(8) :: xnu,x 753 753 real(8) :: xnu,x
integer :: nin 754 754 integer :: nin
real(8), dimension(nin) :: bk 755 755 real(8), dimension(nin) :: bk
end subroutine dbesks 756 756 end subroutine dbesks
end interface bsks 757 757 end interface bsks
758 758
! Exponentially scaled K nu + k 759 759 ! Exponentially scaled K nu + k
interface bskes 760 760 interface bskes
subroutine beskes(xnu,x,nin,bke) 761 761 subroutine beskes(xnu,x,nin,bke)
real(4) :: xnu,x 762 762 real(4) :: xnu,x
integer :: nin 763 763 integer :: nin
real(4),dimension(nin) :: bke 764 764 real(4),dimension(nin) :: bke
end subroutine beskes 765 765 end subroutine beskes
subroutine dbskes(xnu,x,nin,bke) 766 766 subroutine dbskes(xnu,x,nin,bke)
real(8) :: xnu,x 767 767 real(8) :: xnu,x
integer :: nin 768 768 integer :: nin
real(8),dimension(nin) :: bke 769 769 real(8),dimension(nin) :: bke
end subroutine dbskes 770 770 end subroutine dbskes
end interface bskes 771 771 end interface bskes
772 772
!!!!!!!!!!!!!!!!!! 773 773 !!!!!!!!!!!!!!!!!!
! MISSING CBJS 774 774 ! MISSING CBJS
! MISSING CBYS 775 775 ! MISSING CBYS
! MISSING CBIS 776 776 ! MISSING CBIS
!!!!!!!!!!!!!!!!!! 777 777 !!!!!!!!!!!!!!!!!!
778 778
779 779
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 780 780 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Bessel functions and related 781 781 ! END Bessel functions and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 782 782 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
783 783
784 784
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 785 785 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Airy functions and related 786 786 ! Airy functions and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 787 787 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
788 788
!ai(x) 789 789 !ai(x)
interface ai 790 790 interface ai
real(4) function ai(x) 791 791 real(4) function ai(x)
real(4) :: x 792 792 real(4) :: x
end function ai 793 793 end function ai
real(8) function dai(x) 794 794 real(8) function dai(x)
real(8) :: x 795 795 real(8) :: x
end function dai 796 796 end function dai
end interface ai 797 797 end interface ai
798 798
!bi(x) 799 799 !bi(x)
interface bi 800 800 interface bi
real(4) function bi(x) 801 801 real(4) function bi(x)
real(4) :: x 802 802 real(4) :: x
end function bi 803 803 end function bi
real(8) function dbi(x) 804 804 real(8) function dbi(x)
real(8) :: x 805 805 real(8) :: x
end function dbi 806 806 end function dbi
end interface bi 807 807 end interface bi
808 808
!ai'(x) 809 809 !ai'(x)
interface aid 810 810 interface aid
real(4) function aid(x) 811 811 real(4) function aid(x)
real(4) :: x 812 812 real(4) :: x
end function aid 813 813 end function aid
real(8) function daid(x) 814 814 real(8) function daid(x)
real(8) :: x 815 815 real(8) :: x
end function daid 816 816 end function daid
end interface aid 817 817 end interface aid
818 818
!bi'(x) 819 819 !bi'(x)
interface bid 820 820 interface bid
real(4) function bid(x) 821 821 real(4) function bid(x)
real(4) :: x 822 822 real(4) :: x
end function bid 823 823 end function bid
1 1
module fvn 2 2 module fvn
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3 3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 4 4 !
! fvn : a f95 module replacement for some imsl routines 5 5 ! fvn : a f95 module replacement for some imsl routines
! it uses lapack for linear algebra 6 6 ! it uses lapack for linear algebra
! it uses modified quadpack for integration 7 7 ! it uses modified quadpack for integration
! 8 8 !
! William Daniau 2007->today 9 9 ! William Daniau 2007->today
! william.daniau@femto-st.fr 10 10 ! william.daniau@femto-st.fr
! 11 11 !
! Routines naming scheme : 12 12 ! Routines naming scheme :
! 13 13 !
! fvn_x_name 14 14 ! fvn_x_name
! where x can be s : real 15 15 ! where x can be s : real
! d : real double precision 16 16 ! d : real double precision
! c : complex 17 17 ! c : complex
! z : double complex 18 18 ! z : double complex
! 19 19 !
! 20 20 !
! This piece of code is totally free! Do whatever you want with it. However 21 21 ! This piece of code is totally free! Do whatever you want with it. However
! if you find it usefull it would be kind to give credits ;-) 22 22 ! if you find it usefull it would be kind to give credits ;-)
! 23 23 !
! svn version 24 24 ! svn version
! February 2008 : added fnlib to repository so there's no use to have 25 25 ! February 2008 : added fnlib to repository so there's no use to have
! special functions and trigonometry here. Some functions 26 26 ! special functions and trigonometry here. Some functions
! are then removed 27 27 ! are then removed
! January 2008 : added quadratic interpolation, gamma/factorial function, 28 28 ! January 2008 : added quadratic interpolation, gamma/factorial function,
! a function which return identity matrix, 29 29 ! a function which return identity matrix,
! evaluation of nterm chebyshev series 30 30 ! evaluation of nterm chebyshev series
! September 2007 : added sparse system solving by interfacing umfpack 31 31 ! September 2007 : added sparse system solving by interfacing umfpack
! June 2007 : added some complex trigonometric functions 32 32 ! June 2007 : added some complex trigonometric functions
! 33 33 !
! TO DO LIST : 34 34 ! TO DO LIST :
! + Order eigenvalues and vectors in decreasing eigenvalue's modulus order -> atm 35 35 ! + Order eigenvalues and vectors in decreasing eigenvalue's modulus order -> atm
! eigenvalues are given with no particular order. 36 36 ! eigenvalues are given with no particular order.
! + Generic interface for fvn_x_name family -> fvn_name 37 37 ! + Generic interface for fvn_x_name family -> fvn_name
! + Make some parameters optional, status for example 38 38 ! + Make some parameters optional, status for example
! + use f95 kinds "double complex" -> complex(kind=8) 39 39 ! + use f95 kinds "double complex" -> complex(kind=8)
! + unify quadpack routines 40 40 ! + unify quadpack routines
! + ... 41 41 ! + ...
! 42 42 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 43 43 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
44 44
implicit none 45 45 implicit none
! We define pi and i for the module 46 46 ! We define pi and i for the module
real(kind=8),parameter :: fvn_pi = 3.141592653589793_8 47 47 real(kind=8),parameter :: fvn_pi = 3.141592653589793_8
complex(kind=8),parameter :: fvn_i = (0._8,1._8) 48 48 complex(kind=8),parameter :: fvn_i = (0._8,1._8)
49 49
50 50
! All quadpack routines are private to the module 51 51 ! All quadpack routines are private to the module
private :: d1mach,dqag,dqag_2d_inner,dqag_2d_outer,dqage,dqage_2d_inner, & 52 52 private :: d1mach,dqag,dqag_2d_inner,dqag_2d_outer,dqage,dqage_2d_inner, &
dqage_2d_outer,dqk15,dqk15_2d_inner,dqk15_2d_outer,dqk21,dqk21_2d_inner,dqk21_2d_outer, & 53 53 dqage_2d_outer,dqk15,dqk15_2d_inner,dqk15_2d_outer,dqk21,dqk21_2d_inner,dqk21_2d_outer, &
dqk31,dqk31_2d_inner,dqk31_2d_outer,dqk41,dqk41_2d_inner,dqk41_2d_outer, & 54 54 dqk31,dqk31_2d_inner,dqk31_2d_outer,dqk41,dqk41_2d_inner,dqk41_2d_outer, &
dqk51,dqk51_2d_inner,dqk51_2d_outer,dqk61,dqk61_2d_inner,dqk61_2d_outer,dqpsrt 55 55 dqk51,dqk51_2d_inner,dqk51_2d_outer,dqk61,dqk61_2d_inner,dqk61_2d_outer,dqpsrt
56 56
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 57 57 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 58 58 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generic interface Definition 59 59 ! Generic interface Definition
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 60 60 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 61 61 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
62 62
! Identity Matrix 63
interface fvn_ident 64
module procedure fvn_s_ident,fvn_d_ident,fvn_c_ident,fvn_z_ident 65
end interface fvn_ident 66
67 63
! Matrix inversion 68 64 ! Matrix inversion
interface fvn_matinv 69 65 interface fvn_matinv
module procedure fvn_s_matinv,fvn_d_matinv,fvn_c_matinv,fvn_z_matinv 70 66 module procedure fvn_s_matinv,fvn_d_matinv,fvn_c_matinv,fvn_z_matinv
end interface fvn_matinv 71 67 end interface fvn_matinv
72 68
! Determinant 73 69 ! Determinant
interface fvn_det 74 70 interface fvn_det
module procedure fvn_s_det,fvn_d_det,fvn_c_det,fvn_z_det 75 71 module procedure fvn_s_det,fvn_d_det,fvn_c_det,fvn_z_det
end interface fvn_det 76 72 end interface fvn_det
77 73
! Condition 78 74 ! Condition
interface fvn_matcon 79 75 interface fvn_matcon
module procedure fvn_s_matcon,fvn_d_matcon,fvn_c_matcon,fvn_z_matcon 80 76 module procedure fvn_s_matcon,fvn_d_matcon,fvn_c_matcon,fvn_z_matcon
end interface fvn_matcon 81 77 end interface fvn_matcon
82 78
! Eigen 83 79 ! Eigen
interface fvn_matev 84 80 interface fvn_matev
module procedure fvn_s_matev,fvn_d_matev,fvn_c_matev,fvn_z_matev 85 81 module procedure fvn_s_matev,fvn_d_matev,fvn_c_matev,fvn_z_matev
end interface fvn_matev 86 82 end interface fvn_matev
87 83
! Utility procedure find interval 88 84 ! Utility procedure find interval
interface fvn_find_interval 89 85 interface fvn_find_interval
module procedure fvn_s_find_interval,fvn_d_find_interval 90 86 module procedure fvn_s_find_interval,fvn_d_find_interval
end interface fvn_find_interval 91 87 end interface fvn_find_interval
92 88
! Quadratic 1D interpolation 93 89 ! Quadratic 1D interpolation
interface fvn_quad_interpol 94 90 interface fvn_quad_interpol
module procedure fvn_s_quad_interpol,fvn_d_quad_interpol 95 91 module procedure fvn_s_quad_interpol,fvn_d_quad_interpol
end interface fvn_quad_interpol 96 92 end interface fvn_quad_interpol
97 93
! Quadratic 2D interpolation 98 94 ! Quadratic 2D interpolation
interface fvn_quad_2d_interpol 99 95 interface fvn_quad_2d_interpol
module procedure fvn_s_quad_2d_interpol,fvn_d_quad_2d_interpol 100 96 module procedure fvn_s_quad_2d_interpol,fvn_d_quad_2d_interpol
end interface fvn_quad_2d_interpol 101 97 end interface fvn_quad_2d_interpol
102 98
! Quadratic 3D interpolation 103 99 ! Quadratic 3D interpolation
interface fvn_quad_3d_interpol 104 100 interface fvn_quad_3d_interpol
module procedure fvn_s_quad_3d_interpol,fvn_d_quad_3d_interpol 105 101 module procedure fvn_s_quad_3d_interpol,fvn_d_quad_3d_interpol
end interface fvn_quad_3d_interpol 106 102 end interface fvn_quad_3d_interpol
107 103
! Akima interpolation 108 104 ! Akima interpolation
interface fvn_akima 109 105 interface fvn_akima
module procedure fvn_s_akima,fvn_d_akima 110 106 module procedure fvn_s_akima,fvn_d_akima
end interface fvn_akima 111 107 end interface fvn_akima
112 108
! Akima evaluation 113 109 ! Akima evaluation
interface fvn_spline_eval 114 110 interface fvn_spline_eval
module procedure fvn_s_spline_eval,fvn_d_spline_eval 115 111 module procedure fvn_s_spline_eval,fvn_d_spline_eval
end interface fvn_spline_eval 116 112 end interface fvn_spline_eval
117 113
! Least square polynomial 118 114 ! Least square polynomial
interface fvn_lspoly 119 115 interface fvn_lspoly
module procedure fvn_s_lspoly,fvn_d_lspoly 120 116 module procedure fvn_s_lspoly,fvn_d_lspoly
end interface fvn_lspoly 121 117 end interface fvn_lspoly
122 118
! Muller 123 119 ! Muller
interface fvn_muller 124 120 interface fvn_muller
module procedure fvn_z_muller 125 121 module procedure fvn_z_muller
end interface fvn_muller 126 122 end interface fvn_muller
127 123
! Gauss legendre 128 124 ! Gauss legendre
interface fvn_gauss_legendre 129 125 interface fvn_gauss_legendre
module procedure fvn_d_gauss_legendre 130 126 module procedure fvn_d_gauss_legendre
end interface fvn_gauss_legendre 131 127 end interface fvn_gauss_legendre
132 128
! Simple Gauss Legendre integration 133 129 ! Simple Gauss Legendre integration
interface fvn_gl_integ 134 130 interface fvn_gl_integ
module procedure fvn_d_gl_integ 135 131 module procedure fvn_d_gl_integ
end interface fvn_gl_integ 136 132 end interface fvn_gl_integ
137 133
! Adaptative Gauss Kronrod integration f(x) 138 134 ! Adaptative Gauss Kronrod integration f(x)
interface fvn_integ_1_gk 139 135 interface fvn_integ_1_gk
module procedure fvn_d_integ_1_gk 140 136 module procedure fvn_d_integ_1_gk
end interface fvn_integ_1_gk 141 137 end interface fvn_integ_1_gk
142 138
! Adaptative Gauss Kronrod integration f(x,y) 143 139 ! Adaptative Gauss Kronrod integration f(x,y)
interface fvn_integ_2_gk 144 140 interface fvn_integ_2_gk
module procedure fvn_d_integ_2_gk 145 141 module procedure fvn_d_integ_2_gk
end interface fvn_integ_2_gk 146 142 end interface fvn_integ_2_gk
147 143
! Sparse solving 148 144 ! Sparse solving
interface fvn_sparse_solve 149 145 interface fvn_sparse_solve
module procedure fvn_zl_sparse_solve,fvn_zi_sparse_solve,fvn_dl_sparse_solve,fvn_di_sparse_solve 150 146 module procedure fvn_zl_sparse_solve,fvn_zi_sparse_solve,fvn_dl_sparse_solve,fvn_di_sparse_solve
end interface fvn_sparse_solve 151 147 end interface fvn_sparse_solve
152 148
153 149
contains 154 150 contains
155 151
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 156 152 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 157 153 !
! Identity Matrix 158 154 ! Identity Matrix
! 159 155 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 160 156 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function fvn_d_ident(n) 161 157 function fvn_d_ident(n)
implicit none 162 158 implicit none
integer(kind=4) :: n 163 159 integer(kind=4) :: n
real(kind=8), dimension(n,n) :: fvn_d_ident 164 160 real(kind=8), dimension(n,n) :: fvn_d_ident
165 161
real(kind=8),dimension(n*n) :: vect 166 162 real(kind=8),dimension(n*n) :: vect
integer(kind=4) :: i 167 163 integer(kind=4) :: i
168 164
vect=0._8 169 165 vect=0._8
vect(1:n*n:n+1) = 1._8 170 166 vect(1:n*n:n+1) = 1._8
fvn_d_ident=reshape(vect, shape = (/ n,n /)) 171 167 fvn_d_ident=reshape(vect, shape = (/ n,n /))
end function 172 168 end function
173 169
function fvn_s_ident(n) 174 170 function fvn_s_ident(n)
implicit none 175 171 implicit none
integer(kind=4) :: n 176 172 integer(kind=4) :: n
real(kind=4), dimension(n,n) :: fvn_s_ident 177 173 real(kind=4), dimension(n,n) :: fvn_s_ident
178 174
real(kind=4),dimension(n*n) :: vect 179 175 real(kind=4),dimension(n*n) :: vect
integer(kind=4) :: i 180 176 integer(kind=4) :: i
181 177
vect=0._4 182 178 vect=0._4
vect(1:n*n:n+1) = 1._4 183 179 vect(1:n*n:n+1) = 1._4
fvn_s_ident=reshape(vect, shape = (/ n,n /)) 184 180 fvn_s_ident=reshape(vect, shape = (/ n,n /))
end function 185 181 end function
186 182
function fvn_c_ident(n) 187 183 function fvn_c_ident(n)
implicit none 188 184 implicit none
integer(kind=4) :: n 189 185 integer(kind=4) :: n
complex(kind=4), dimension(n,n) :: fvn_c_ident 190 186 complex(kind=4), dimension(n,n) :: fvn_c_ident
191 187
complex(kind=4),dimension(n*n) :: vect 192 188 complex(kind=4),dimension(n*n) :: vect
integer(kind=4) :: i 193 189 integer(kind=4) :: i
194 190
vect=(0._4,0._4) 195 191 vect=(0._4,0._4)
vect(1:n*n:n+1) = (1._4,0._4) 196 192 vect(1:n*n:n+1) = (1._4,0._4)
fvn_c_ident=reshape(vect, shape = (/ n,n /)) 197 193 fvn_c_ident=reshape(vect, shape = (/ n,n /))
end function 198 194 end function
199 195
function fvn_z_ident(n) 200 196 function fvn_z_ident(n)
implicit none 201 197 implicit none
integer(kind=4) :: n 202 198 integer(kind=4) :: n
complex(kind=8), dimension(n,n) :: fvn_z_ident 203 199 complex(kind=8), dimension(n,n) :: fvn_z_ident
204 200
complex(kind=8),dimension(n*n) :: vect 205 201 complex(kind=8),dimension(n*n) :: vect
integer(kind=4) :: i 206 202 integer(kind=4) :: i
207 203
vect=(0._8,0._8) 208 204 vect=(0._8,0._8)
vect(1:n*n:n+1) = (1._8,0._8) 209 205 vect(1:n*n:n+1) = (1._8,0._8)
fvn_z_ident=reshape(vect, shape = (/ n,n /)) 210 206 fvn_z_ident=reshape(vect, shape = (/ n,n /))
end function 211 207 end function
212 208
213 209
214 210
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 215 211 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 216 212 !
! Matrix inversion subroutines 217 213 ! Matrix inversion subroutines
! 218 214 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 219 215 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
220 216
subroutine fvn_s_matinv(d,a,inva,status) 221 217 subroutine fvn_s_matinv(d,a,inva,status)
! 222 218 !
! Matrix inversion of a real matrix using BLAS and LAPACK 223 219 ! Matrix inversion of a real matrix using BLAS and LAPACK
! 224 220 !
! d (in) : matrix rank 225 221 ! d (in) : matrix rank
! a (in) : input matrix 226 222 ! a (in) : input matrix
! inva (out) : inversed matrix 227 223 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 228 224 ! status (ou) : =0 if something failed
! 229 225 !
implicit none 230 226 implicit none
integer, intent(in) :: d 231 227 integer, intent(in) :: d
real, intent(in) :: a(d,d) 232 228 real, intent(in) :: a(d,d)
real, intent(out) :: inva(d,d) 233 229 real, intent(out) :: inva(d,d)
integer, intent(out),optional :: status 234 230 integer, intent(out),optional :: status
235 231
integer, allocatable :: ipiv(:) 236 232 integer, allocatable :: ipiv(:)
real, allocatable :: work(:) 237 233 real, allocatable :: work(:)
real twork(1) 238 234 real twork(1)
integer :: info 239 235 integer :: info
integer :: lwork 240 236 integer :: lwork
241 237
if (present(status)) status=1 242 238 if (present(status)) status=1
243 239
allocate(ipiv(d)) 244 240 allocate(ipiv(d))
! copy a into inva using BLAS 245 241 ! copy a into inva using BLAS
!call scopy(d*d,a,1,inva,1) 246 242 !call scopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 247 243 inva(:,:)=a(:,:)
! LU factorization using LAPACK 248 244 ! LU factorization using LAPACK
call sgetrf(d,d,inva,d,ipiv,info) 249 245 call sgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 250 246 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 251 247 if (info /= 0) then
if (present(status)) status=0 252 248 if (present(status)) status=0
deallocate(ipiv) 253 249 deallocate(ipiv)
return 254 250 return
end if 255 251 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 256 252 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call sgetri(d,inva,d,ipiv,twork,-1,info) 257 253 call sgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 258 254 lwork=int(twork(1))
allocate(work(lwork)) 259 255 allocate(work(lwork))
! Matrix inversion using LAPACK 260 256 ! Matrix inversion using LAPACK
call sgetri(d,inva,d,ipiv,work,lwork,info) 261 257 call sgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 262 258 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 263 259 if (info /= 0) then
if (present(status)) status=0 264 260 if (present(status)) status=0
end if 265 261 end if
deallocate(work) 266 262 deallocate(work)
deallocate(ipiv) 267 263 deallocate(ipiv)
end subroutine 268 264 end subroutine
269 265
subroutine fvn_d_matinv(d,a,inva,status) 270 266 subroutine fvn_d_matinv(d,a,inva,status)
! 271 267 !
! Matrix inversion of a double precision matrix using BLAS and LAPACK 272 268 ! Matrix inversion of a double precision matrix using BLAS and LAPACK
! 273 269 !
! d (in) : matrix rank 274 270 ! d (in) : matrix rank
! a (in) : input matrix 275 271 ! a (in) : input matrix
! inva (out) : inversed matrix 276 272 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 277 273 ! status (ou) : =0 if something failed
! 278 274 !
implicit none 279 275 implicit none
integer, intent(in), optional :: d 280 276 integer, intent(in) :: d
double precision, intent(in) :: a(d,d) 281 277 double precision, intent(in) :: a(d,d)
double precision, intent(out) :: inva(d,d) 282 278 double precision, intent(out) :: inva(d,d)
integer, intent(out),optional :: status 283 279 integer, intent(out),optional :: status
284 280
integer, allocatable :: ipiv(:) 285 281 integer, allocatable :: ipiv(:)
double precision, allocatable :: work(:) 286 282 double precision, allocatable :: work(:)
double precision :: twork(1) 287 283 double precision :: twork(1)
integer :: info 288 284 integer :: info
integer :: lwork 289 285 integer :: lwork
290 286
if (present(status)) status=1 291 287 if (present(status)) status=1
292 288
allocate(ipiv(d)) 293 289 allocate(ipiv(d))
! copy a into inva using BLAS 294 290 ! copy a into inva using BLAS
!call dcopy(d*d,a,1,inva,1) 295 291 !call dcopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 296 292 inva(:,:)=a(:,:)
! LU factorization using LAPACK 297 293 ! LU factorization using LAPACK
call dgetrf(d,d,inva,d,ipiv,info) 298 294 call dgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 299 295 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 300 296 if (info /= 0) then
if (present(status)) status=0 301 297 if (present(status)) status=0
deallocate(ipiv) 302 298 deallocate(ipiv)
return 303 299 return
end if 304 300 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 305 301 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call dgetri(d,inva,d,ipiv,twork,-1,info) 306 302 call dgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 307 303 lwork=int(twork(1))
allocate(work(lwork)) 308 304 allocate(work(lwork))
! Matrix inversion using LAPACK 309 305 ! Matrix inversion using LAPACK
call dgetri(d,inva,d,ipiv,work,lwork,info) 310 306 call dgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 311 307 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 312 308 if (info /= 0) then
if (present(status)) status=0 313 309 if (present(status)) status=0
end if 314 310 end if
deallocate(work) 315 311 deallocate(work)
deallocate(ipiv) 316 312 deallocate(ipiv)
end subroutine 317 313 end subroutine
318 314
subroutine fvn_c_matinv(d,a,inva,status) 319 315 subroutine fvn_c_matinv(d,a,inva,status)
! 320 316 !
! Matrix inversion of a complex matrix using BLAS and LAPACK 321 317 ! Matrix inversion of a complex matrix using BLAS and LAPACK
! 322 318 !
! d (in) : matrix rank 323 319 ! d (in) : matrix rank
! a (in) : input matrix 324 320 ! a (in) : input matrix
! inva (out) : inversed matrix 325 321 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 326 322 ! status (ou) : =0 if something failed
! 327 323 !
implicit none 328 324 implicit none
integer, intent(in) :: d 329 325 integer, intent(in) :: d
complex, intent(in) :: a(d,d) 330 326 complex, intent(in) :: a(d,d)
complex, intent(out) :: inva(d,d) 331 327 complex, intent(out) :: inva(d,d)
integer, intent(out),optional :: status 332 328 integer, intent(out),optional :: status
333 329
integer, allocatable :: ipiv(:) 334 330 integer, allocatable :: ipiv(:)
complex, allocatable :: work(:) 335 331 complex, allocatable :: work(:)
complex :: twork(1) 336 332 complex :: twork(1)
integer :: info 337 333 integer :: info
integer :: lwork 338 334 integer :: lwork
339 335
if (present(status)) status=1 340 336 if (present(status)) status=1
341 337
allocate(ipiv(d)) 342 338 allocate(ipiv(d))
! copy a into inva using BLAS 343 339 ! copy a into inva using BLAS
!call ccopy(d*d,a,1,inva,1) 344 340 !call ccopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 345 341 inva(:,:)=a(:,:)
346 342
! LU factorization using LAPACK 347 343 ! LU factorization using LAPACK
call cgetrf(d,d,inva,d,ipiv,info) 348 344 call cgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 349 345 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 350 346 if (info /= 0) then
if (present(status)) status=0 351 347 if (present(status)) status=0
deallocate(ipiv) 352 348 deallocate(ipiv)
return 353 349 return
end if 354 350 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 355 351 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call cgetri(d,inva,d,ipiv,twork,-1,info) 356 352 call cgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 357 353 lwork=int(twork(1))
allocate(work(lwork)) 358 354 allocate(work(lwork))
! Matrix inversion using LAPACK 359 355 ! Matrix inversion using LAPACK
call cgetri(d,inva,d,ipiv,work,lwork,info) 360 356 call cgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 361 357 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 362 358 if (info /= 0) then
if (present(status)) status=0 363 359 if (present(status)) status=0
end if 364 360 end if
deallocate(work) 365 361 deallocate(work)
deallocate(ipiv) 366 362 deallocate(ipiv)
end subroutine 367 363 end subroutine
368 364
subroutine fvn_z_matinv(d,a,inva,status) 369 365 subroutine fvn_z_matinv(d,a,inva,status)
! 370 366 !
! Matrix inversion of a double complex matrix using BLAS and LAPACK 371 367 ! Matrix inversion of a double complex matrix using BLAS and LAPACK
! 372 368 !
! d (in) : matrix rank 373 369 ! d (in) : matrix rank
! a (in) : input matrix 374 370 ! a (in) : input matrix
! inva (out) : inversed matrix 375 371 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 376 372 ! status (ou) : =0 if something failed
! 377 373 !
implicit none 378 374 implicit none
integer, intent(in) :: d 379 375 integer, intent(in) :: d
double complex, intent(in) :: a(d,d) 380 376 double complex, intent(in) :: a(d,d)
double complex, intent(out) :: inva(d,d) 381 377 double complex, intent(out) :: inva(d,d)
integer, intent(out),optional :: status 382 378 integer, intent(out),optional :: status
383 379
integer, allocatable :: ipiv(:) 384 380 integer, allocatable :: ipiv(:)
double complex, allocatable :: work(:) 385 381 double complex, allocatable :: work(:)
double complex :: twork(1) 386 382 double complex :: twork(1)
integer :: info 387 383 integer :: info
integer :: lwork 388 384 integer :: lwork
389 385
if (present(status)) status=1 390 386 if (present(status)) status=1
391 387
allocate(ipiv(d)) 392 388 allocate(ipiv(d))
! copy a into inva using BLAS 393 389 ! copy a into inva using BLAS
!call zcopy(d*d,a,1,inva,1) 394 390 !call zcopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 395 391 inva(:,:)=a(:,:)
396 392
! LU factorization using LAPACK 397 393 ! LU factorization using LAPACK
call zgetrf(d,d,inva,d,ipiv,info) 398 394 call zgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 399 395 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 400 396 if (info /= 0) then
if (present(status)) status=0 401 397 if (present(status)) status=0
deallocate(ipiv) 402 398 deallocate(ipiv)
return 403 399 return
end if 404 400 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 405 401 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call zgetri(d,inva,d,ipiv,twork,-1,info) 406 402 call zgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 407 403 lwork=int(twork(1))
allocate(work(lwork)) 408 404 allocate(work(lwork))
! Matrix inversion using LAPACK 409 405 ! Matrix inversion using LAPACK
call zgetri(d,inva,d,ipiv,work,lwork,info) 410 406 call zgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 411 407 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 412 408 if (info /= 0) then
if (present(status)) status=0 413 409 if (present(status)) status=0
end if 414 410 end if
deallocate(work) 415 411 deallocate(work)
deallocate(ipiv) 416 412 deallocate(ipiv)
end subroutine 417 413 end subroutine
418 414
419 415
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 420 416 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 421 417 !
! Determinants 422 418 ! Determinants
! 423 419 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 424 420 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function fvn_s_det(d,a,status) 425 421 function fvn_s_det(d,a,status)
! 426 422 !
! Evaluate the determinant of a square matrix using lapack LU factorization 427 423 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 428 424 !
! d (in) : matrix rank 429 425 ! d (in) : matrix rank
! a (in) : The Matrix 430 426 ! a (in) : The Matrix
! status (out) : =0 if LU factorization failed 431 427 ! status (out) : =0 if LU factorization failed
! 432 428 !
implicit none 433 429 implicit none
integer, intent(in) :: d 434 430 integer, intent(in) :: d
real, intent(in) :: a(d,d) 435 431 real, intent(in) :: a(d,d)
integer, intent(out), optional :: status 436 432 integer, intent(out), optional :: status
real :: fvn_s_det 437 433 real :: fvn_s_det
438 434
real, allocatable :: wc_a(:,:) 439 435 real, allocatable :: wc_a(:,:)
integer, allocatable :: ipiv(:) 440 436 integer, allocatable :: ipiv(:)
integer :: info,i 441 437 integer :: info,i
442 438
if (present(status)) status=1 443 439 if (present(status)) status=1
allocate(wc_a(d,d)) 444 440 allocate(wc_a(d,d))
allocate(ipiv(d)) 445 441 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 446 442 wc_a(:,:)=a(:,:)
call sgetrf(d,d,wc_a,d,ipiv,info) 447 443 call sgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 448 444 if (info/= 0) then
if (present(status)) status=0 449 445 if (present(status)) status=0
fvn_s_det=0.e0 450 446 fvn_s_det=0.e0
deallocate(ipiv) 451 447 deallocate(ipiv)
deallocate(wc_a) 452 448 deallocate(wc_a)
return 453 449 return
end if 454 450 end if
fvn_s_det=1.e0 455 451 fvn_s_det=1.e0
do i=1,d 456 452 do i=1,d
if (ipiv(i)==i) then 457 453 if (ipiv(i)==i) then
fvn_s_det=fvn_s_det*wc_a(i,i) 458 454 fvn_s_det=fvn_s_det*wc_a(i,i)
else 459 455 else
fvn_s_det=-fvn_s_det*wc_a(i,i) 460 456 fvn_s_det=-fvn_s_det*wc_a(i,i)
end if 461 457 end if
end do 462 458 end do
deallocate(ipiv) 463 459 deallocate(ipiv)
deallocate(wc_a) 464 460 deallocate(wc_a)
465 461
end function 466 462 end function
467 463
function fvn_d_det(d,a,status) 468 464 function fvn_d_det(d,a,status)
! 469 465 !
! Evaluate the determinant of a square matrix using lapack LU factorization 470 466 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 471 467 !
! d (in) : matrix rank 472 468 ! d (in) : matrix rank
! a (in) : The Matrix 473 469 ! a (in) : The Matrix
! status (out) : =0 if LU factorization failed 474 470 ! status (out) : =0 if LU factorization failed
! 475 471 !
implicit none 476 472 implicit none
integer, intent(in) :: d 477 473 integer, intent(in) :: d
double precision, intent(in) :: a(d,d) 478 474 double precision, intent(in) :: a(d,d)
integer, intent(out), optional :: status 479 475 integer, intent(out), optional :: status
double precision :: fvn_d_det 480 476 double precision :: fvn_d_det
481 477
double precision, allocatable :: wc_a(:,:) 482 478 double precision, allocatable :: wc_a(:,:)
integer, allocatable :: ipiv(:) 483 479 integer, allocatable :: ipiv(:)
integer :: info,i 484 480 integer :: info,i
485 481
if (present(status)) status=1 486 482 if (present(status)) status=1
allocate(wc_a(d,d)) 487 483 allocate(wc_a(d,d))
allocate(ipiv(d)) 488 484 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 489 485 wc_a(:,:)=a(:,:)
call dgetrf(d,d,wc_a,d,ipiv,info) 490 486 call dgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 491 487 if (info/= 0) then
if (present(status)) status=0 492 488 if (present(status)) status=0
fvn_d_det=0.d0 493 489 fvn_d_det=0.d0
deallocate(ipiv) 494 490 deallocate(ipiv)
deallocate(wc_a) 495 491 deallocate(wc_a)
return 496 492 return
end if 497 493 end if
fvn_d_det=1.d0 498 494 fvn_d_det=1.d0
do i=1,d 499 495 do i=1,d
if (ipiv(i)==i) then 500 496 if (ipiv(i)==i) then
fvn_d_det=fvn_d_det*wc_a(i,i) 501 497 fvn_d_det=fvn_d_det*wc_a(i,i)
else 502 498 else
fvn_d_det=-fvn_d_det*wc_a(i,i) 503 499 fvn_d_det=-fvn_d_det*wc_a(i,i)
end if 504 500 end if
end do 505 501 end do
deallocate(ipiv) 506 502 deallocate(ipiv)
deallocate(wc_a) 507 503 deallocate(wc_a)
508 504
end function 509 505 end function
510 506
function fvn_c_det(d,a,status) ! 511 507 function fvn_c_det(d,a,status) !
! Evaluate the determinant of a square matrix using lapack LU factorization 512 508 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 513 509 !
! d (in) : matrix rank 514 510 ! d (in) : matrix rank
! a (in) : The Matrix 515 511 ! a (in) : The Matrix
! status (out) : =0 if LU factorization failed 516 512 ! status (out) : =0 if LU factorization failed
! 517 513 !
implicit none 518 514 implicit none
integer, intent(in) :: d 519 515 integer, intent(in) :: d
complex, intent(in) :: a(d,d) 520 516 complex, intent(in) :: a(d,d)
integer, intent(out), optional :: status 521 517 integer, intent(out), optional :: status
complex :: fvn_c_det 522 518 complex :: fvn_c_det
523 519
complex, allocatable :: wc_a(:,:) 524 520 complex, allocatable :: wc_a(:,:)
integer, allocatable :: ipiv(:) 525 521 integer, allocatable :: ipiv(:)
integer :: info,i 526 522 integer :: info,i
527 523
if (present(status)) status=1 528 524 if (present(status)) status=1
allocate(wc_a(d,d)) 529 525 allocate(wc_a(d,d))
allocate(ipiv(d)) 530 526 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 531 527 wc_a(:,:)=a(:,:)
call cgetrf(d,d,wc_a,d,ipiv,info) 532 528 call cgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 533 529 if (info/= 0) then
if (present(status)) status=0 534 530 if (present(status)) status=0
fvn_c_det=(0.e0,0.e0) 535 531 fvn_c_det=(0.e0,0.e0)
deallocate(ipiv) 536 532 deallocate(ipiv)
deallocate(wc_a) 537 533 deallocate(wc_a)
return 538 534 return
end if 539 535 end if
fvn_c_det=(1.e0,0.e0) 540 536 fvn_c_det=(1.e0,0.e0)
do i=1,d 541 537 do i=1,d
if (ipiv(i)==i) then 542 538 if (ipiv(i)==i) then
fvn_c_det=fvn_c_det*wc_a(i,i) 543 539 fvn_c_det=fvn_c_det*wc_a(i,i)
else 544 540 else
fvn_c_det=-fvn_c_det*wc_a(i,i) 545 541 fvn_c_det=-fvn_c_det*wc_a(i,i)
end if 546 542 end if
end do 547 543 end do
deallocate(ipiv) 548 544 deallocate(ipiv)
deallocate(wc_a) 549 545 deallocate(wc_a)
550 546
end function 551 547 end function
552 548
function fvn_z_det(d,a,status) 553 549 function fvn_z_det(d,a,status)
! 554 550 !
! Evaluate the determinant of a square matrix using lapack LU factorization 555 551 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 556 552 !
! d (in) : matrix rank 557 553 ! d (in) : matrix rank
! a (in) : The Matrix 558 554 ! a (in) : The Matrix
! det (out) : determinant 559 555 ! det (out) : determinant
! status (out) : =0 if LU factorization failed 560 556 ! status (out) : =0 if LU factorization failed
! 561 557 !
implicit none 562 558 implicit none
integer, intent(in) :: d 563 559 integer, intent(in) :: d
double complex, intent(in) :: a(d,d) 564 560 double complex, intent(in) :: a(d,d)
integer, intent(out), optional :: status 565 561 integer, intent(out), optional :: status
double complex :: fvn_z_det 566 562 double complex :: fvn_z_det
567 563
double complex, allocatable :: wc_a(:,:) 568 564 double complex, allocatable :: wc_a(:,:)
integer, allocatable :: ipiv(:) 569 565 integer, allocatable :: ipiv(:)
integer :: info,i 570 566 integer :: info,i
571 567
if (present(status)) status=1 572 568 if (present(status)) status=1
allocate(wc_a(d,d)) 573 569 allocate(wc_a(d,d))
allocate(ipiv(d)) 574 570 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 575 571 wc_a(:,:)=a(:,:)
call zgetrf(d,d,wc_a,d,ipiv,info) 576 572 call zgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 577 573 if (info/= 0) then
if (present(status)) status=0 578 574 if (present(status)) status=0
fvn_z_det=(0.d0,0.d0) 579 575 fvn_z_det=(0.d0,0.d0)
deallocate(ipiv) 580 576 deallocate(ipiv)
deallocate(wc_a) 581 577 deallocate(wc_a)
return 582 578 return
end if 583 579 end if
fvn_z_det=(1.d0,0.d0) 584 580 fvn_z_det=(1.d0,0.d0)
do i=1,d 585 581 do i=1,d
if (ipiv(i)==i) then 586 582 if (ipiv(i)==i) then
fvn_z_det=fvn_z_det*wc_a(i,i) 587 583 fvn_z_det=fvn_z_det*wc_a(i,i)
else 588 584 else
fvn_z_det=-fvn_z_det*wc_a(i,i) 589 585 fvn_z_det=-fvn_z_det*wc_a(i,i)
end if 590 586 end if
end do 591 587 end do
deallocate(ipiv) 592 588 deallocate(ipiv)
deallocate(wc_a) 593 589 deallocate(wc_a)
594 590
end function 595 591 end function
596 592
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 597 593 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 598 594 !
! Condition test 599 595 ! Condition test
! 600 596 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 601 597 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1-norm 602 598 ! 1-norm
! fonction lapack slange,dlange,clange,zlange pour obtenir la 1-norm 603 599 ! fonction lapack slange,dlange,clange,zlange pour obtenir la 1-norm
! fonction lapack sgecon,dgecon,cgecon,zgecon pour calculer la rcond 604 600 ! fonction lapack sgecon,dgecon,cgecon,zgecon pour calculer la rcond
! 605 601 !
subroutine fvn_s_matcon(d,a,rcond,status) 606 602 subroutine fvn_s_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 607 603 ! Matrix condition (reciprocal of condition number)
! 608 604 !
! d (in) : matrix rank 609 605 ! d (in) : matrix rank
! a (in) : The Matrix 610 606 ! a (in) : The Matrix
! rcond (out) : guess what 611 607 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 612 608 ! status (out) : =0 if something went wrong
! 613 609 !
implicit none 614 610 implicit none
integer, intent(in) :: d 615 611 integer, intent(in) :: d
real, intent(in) :: a(d,d) 616 612 real, intent(in) :: a(d,d)
real, intent(out) :: rcond 617 613 real, intent(out) :: rcond
integer, intent(out), optional :: status 618 614 integer, intent(out), optional :: status
619 615
real, allocatable :: work(:) 620 616 real, allocatable :: work(:)
integer, allocatable :: iwork(:) 621 617 integer, allocatable :: iwork(:)
real :: anorm 622 618 real :: anorm
real, allocatable :: wc_a(:,:) ! working copy of a 623 619 real, allocatable :: wc_a(:,:) ! working copy of a
integer :: info 624 620 integer :: info
integer, allocatable :: ipiv(:) 625 621 integer, allocatable :: ipiv(:)
626 622
real, external :: slange 627 623 real, external :: slange
628 624
629 625
if (present(status)) status=1 630 626 if (present(status)) status=1
631 627
anorm=slange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm 632 628 anorm=slange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm
633 629
allocate(wc_a(d,d)) 634 630 allocate(wc_a(d,d))
!call scopy(d*d,a,1,wc_a,1) 635 631 !call scopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 636 632 wc_a(:,:)=a(:,:)
637 633
allocate(ipiv(d)) 638 634 allocate(ipiv(d))
call sgetrf(d,d,wc_a,d,ipiv,info) 639 635 call sgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 640 636 if (info /= 0) then
if (present(status)) status=0 641 637 if (present(status)) status=0
deallocate(ipiv) 642 638 deallocate(ipiv)
deallocate(wc_a) 643 639 deallocate(wc_a)
return 644 640 return
end if 645 641 end if
allocate(work(4*d)) 646 642 allocate(work(4*d))
allocate(iwork(d)) 647 643 allocate(iwork(d))
call sgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info) 648 644 call sgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info)
if (info /= 0) then 649 645 if (info /= 0) then
if (present(status)) status=0 650 646 if (present(status)) status=0
end if 651 647 end if
deallocate(iwork) 652 648 deallocate(iwork)
deallocate(work) 653 649 deallocate(work)
deallocate(ipiv) 654 650 deallocate(ipiv)
deallocate(wc_a) 655 651 deallocate(wc_a)
656 652
end subroutine 657 653 end subroutine
658 654
subroutine fvn_d_matcon(d,a,rcond,status) 659 655 subroutine fvn_d_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 660 656 ! Matrix condition (reciprocal of condition number)
! 661 657 !
! d (in) : matrix rank 662 658 ! d (in) : matrix rank
! a (in) : The Matrix 663 659 ! a (in) : The Matrix
! rcond (out) : guess what 664 660 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 665 661 ! status (out) : =0 if something went wrong
! 666 662 !
implicit none 667 663 implicit none
integer, intent(in) :: d 668 664 integer, intent(in) :: d
double precision, intent(in) :: a(d,d) 669 665 double precision, intent(in) :: a(d,d)
double precision, intent(out) :: rcond 670 666 double precision, intent(out) :: rcond
integer, intent(out), optional :: status 671 667 integer, intent(out), optional :: status
672 668
double precision, allocatable :: work(:) 673 669 double precision, allocatable :: work(:)
integer, allocatable :: iwork(:) 674 670 integer, allocatable :: iwork(:)
double precision :: anorm 675 671 double precision :: anorm
double precision, allocatable :: wc_a(:,:) ! working copy of a 676 672 double precision, allocatable :: wc_a(:,:) ! working copy of a
integer :: info 677 673 integer :: info
integer, allocatable :: ipiv(:) 678 674 integer, allocatable :: ipiv(:)
679 675
double precision, external :: dlange 680 676 double precision, external :: dlange
681 677
682 678
if (present(status)) status=1 683 679 if (present(status)) status=1
684 680
anorm=dlange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm 685 681 anorm=dlange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm
686 682
allocate(wc_a(d,d)) 687 683 allocate(wc_a(d,d))
!call dcopy(d*d,a,1,wc_a,1) 688 684 !call dcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 689 685 wc_a(:,:)=a(:,:)
690 686
allocate(ipiv(d)) 691 687 allocate(ipiv(d))
call dgetrf(d,d,wc_a,d,ipiv,info) 692 688 call dgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 693 689 if (info /= 0) then
if (present(status)) status=0 694 690 if (present(status)) status=0
deallocate(ipiv) 695 691 deallocate(ipiv)
deallocate(wc_a) 696 692 deallocate(wc_a)
return 697 693 return
end if 698 694 end if
699 695
allocate(work(4*d)) 700 696 allocate(work(4*d))
allocate(iwork(d)) 701 697 allocate(iwork(d))
call dgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info) 702 698 call dgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info)
if (info /= 0) then 703 699 if (info /= 0) then
if (present(status)) status=0 704 700 if (present(status)) status=0
end if 705 701 end if
deallocate(iwork) 706 702 deallocate(iwork)
deallocate(work) 707 703 deallocate(work)
deallocate(ipiv) 708 704 deallocate(ipiv)
deallocate(wc_a) 709 705 deallocate(wc_a)
710 706
end subroutine 711 707 end subroutine
712 708
subroutine fvn_c_matcon(d,a,rcond,status) 713 709 subroutine fvn_c_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 714 710 ! Matrix condition (reciprocal of condition number)
! 715 711 !
! d (in) : matrix rank 716 712 ! d (in) : matrix rank
! a (in) : The Matrix 717 713 ! a (in) : The Matrix
! rcond (out) : guess what 718 714 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 719 715 ! status (out) : =0 if something went wrong
! 720 716 !
implicit none 721 717 implicit none
integer, intent(in) :: d 722 718 integer, intent(in) :: d
complex, intent(in) :: a(d,d) 723 719 complex, intent(in) :: a(d,d)
real, intent(out) :: rcond 724 720 real, intent(out) :: rcond
integer, intent(out), optional :: status 725 721 integer, intent(out), optional :: status
726 722
real, allocatable :: rwork(:) 727 723 real, allocatable :: rwork(:)
complex, allocatable :: work(:) 728 724 complex, allocatable :: work(:)
integer, allocatable :: iwork(:) 729 725 integer, allocatable :: iwork(:)
real :: anorm 730 726 real :: anorm
complex, allocatable :: wc_a(:,:) ! working copy of a 731 727 complex, allocatable :: wc_a(:,:) ! working copy of a
integer :: info 732 728 integer :: info
integer, allocatable :: ipiv(:) 733 729 integer, allocatable :: ipiv(:)
734 730
real, external :: clange 735 731 real, external :: clange
736 732
737 733
if (present(status)) status=1 738 734 if (present(status)) status=1
739 735
anorm=clange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm 740 736 anorm=clange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm
741 737
allocate(wc_a(d,d)) 742 738 allocate(wc_a(d,d))
!call ccopy(d*d,a,1,wc_a,1) 743 739 !call ccopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 744 740 wc_a(:,:)=a(:,:)
745 741
allocate(ipiv(d)) 746 742 allocate(ipiv(d))
call cgetrf(d,d,wc_a,d,ipiv,info) 747 743 call cgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 748 744 if (info /= 0) then
if (present(status)) status=0 749 745 if (present(status)) status=0
deallocate(ipiv) 750 746 deallocate(ipiv)
deallocate(wc_a) 751 747 deallocate(wc_a)
return 752 748 return
end if 753 749 end if
allocate(work(2*d)) 754 750 allocate(work(2*d))
allocate(rwork(2*d)) 755 751 allocate(rwork(2*d))
call cgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info) 756 752 call cgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info)
if (info /= 0) then 757 753 if (info /= 0) then
if (present(status)) status=0 758 754 if (present(status)) status=0
end if 759 755 end if
deallocate(rwork) 760 756 deallocate(rwork)
deallocate(work) 761 757 deallocate(work)
deallocate(ipiv) 762 758 deallocate(ipiv)
deallocate(wc_a) 763 759 deallocate(wc_a)
end subroutine 764 760 end subroutine
765 761
subroutine fvn_z_matcon(d,a,rcond,status) 766 762 subroutine fvn_z_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 767 763 ! Matrix condition (reciprocal of condition number)
! 768 764 !
! d (in) : matrix rank 769 765 ! d (in) : matrix rank
! a (in) : The Matrix 770 766 ! a (in) : The Matrix
! rcond (out) : guess what 771 767 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 772 768 ! status (out) : =0 if something went wrong
! 773 769 !
implicit none 774 770 implicit none
integer, intent(in) :: d 775 771 integer, intent(in) :: d
double complex, intent(in) :: a(d,d) 776 772 double complex, intent(in) :: a(d,d)
double precision, intent(out) :: rcond 777 773 double precision, intent(out) :: rcond
integer, intent(out), optional :: status 778 774 integer, intent(out), optional :: status
779 775
double complex, allocatable :: work(:) 780 776 double complex, allocatable :: work(:)
double precision, allocatable :: rwork(:) 781 777 double precision, allocatable :: rwork(:)
double precision :: anorm 782 778 double precision :: anorm
double complex, allocatable :: wc_a(:,:) ! working copy of a 783 779 double complex, allocatable :: wc_a(:,:) ! working copy of a
integer :: info 784 780 integer :: info
integer, allocatable :: ipiv(:) 785 781 integer, allocatable :: ipiv(:)
786 782
double precision, external :: zlange 787 783 double precision, external :: zlange
788 784
789 785
if (present(status)) status=1 790 786 if (present(status)) status=1
791 787
anorm=zlange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm 792 788 anorm=zlange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm
793 789
allocate(wc_a(d,d)) 794 790 allocate(wc_a(d,d))
!call zcopy(d*d,a,1,wc_a,1) 795 791 !call zcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 796 792 wc_a(:,:)=a(:,:)
797 793
allocate(ipiv(d)) 798 794 allocate(ipiv(d))
call zgetrf(d,d,wc_a,d,ipiv,info) 799 795 call zgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 800 796 if (info /= 0) then
if (present(status)) status=0 801 797 if (present(status)) status=0
deallocate(ipiv) 802 798 deallocate(ipiv)
deallocate(wc_a) 803 799 deallocate(wc_a)
return 804 800 return
end if 805 801 end if
806 802
allocate(work(2*d)) 807 803 allocate(work(2*d))
allocate(rwork(2*d)) 808 804 allocate(rwork(2*d))
call zgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info) 809 805 call zgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info)
if (info /= 0) then 810 806 if (info /= 0) then
if (present(status)) status=0 811 807 if (present(status)) status=0
end if 812 808 end if
deallocate(rwork) 813 809 deallocate(rwork)
deallocate(work) 814 810 deallocate(work)
deallocate(ipiv) 815 811 deallocate(ipiv)
deallocate(wc_a) 816 812 deallocate(wc_a)
end subroutine 817 813 end subroutine
818 814
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 819 815 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 820 816 !
! Valeurs propres/ Vecteurs propre 821 817 ! Valeurs propres/ Vecteurs propre
! 822 818 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 823 819 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
824 820
subroutine fvn_s_matev(d,a,evala,eveca,status) 825 821 subroutine fvn_s_matev(d,a,evala,eveca,status)
! 826 822 !
! integer d (in) : matrice rank 827 823 ! integer d (in) : matrice rank
! real a(d,d) (in) : The Matrix 828 824 ! real a(d,d) (in) : The Matrix
! complex evala(d) (out) : eigenvalues 829 825 ! complex evala(d) (out) : eigenvalues
! complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector 830 826 ! complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer (out) : status =0 if something went wrong 831 827 ! integer (out) : status =0 if something went wrong
! 832 828 !
! interfacing Lapack routine SGEEV 833 829 ! interfacing Lapack routine SGEEV
implicit none 834 830 implicit none
integer, intent(in) :: d 835 831 integer, intent(in) :: d
real, intent(in) :: a(d,d) 836 832 real, intent(in) :: a(d,d)
complex, intent(out) :: evala(d) 837 833 complex, intent(out) :: evala(d)
complex, intent(out) :: eveca(d,d) 838 834 complex, intent(out) :: eveca(d,d)
integer, intent(out), optional :: status 839 835 integer, intent(out), optional :: status
840 836
real, allocatable :: wc_a(:,:) ! a working copy of a 841 837 real, allocatable :: wc_a(:,:) ! a working copy of a
integer :: info 842 838 integer :: info
integer :: lwork 843 839 integer :: lwork
real, allocatable :: wr(:),wi(:) 844 840 real, allocatable :: wr(:),wi(:)
real :: vl ! unused but necessary for the call 845 841 real :: vl ! unused but necessary for the call
real, allocatable :: vr(:,:) 846 842 real, allocatable :: vr(:,:)
real, allocatable :: work(:) 847 843 real, allocatable :: work(:)
real :: twork(1) 848 844 real :: twork(1)
integer i 849 845 integer i
integer j 850 846 integer j
851 847
if (present(status)) status=1 852 848 if (present(status)) status=1
853 849
! making a working copy of a 854 850 ! making a working copy of a
allocate(wc_a(d,d)) 855 851 allocate(wc_a(d,d))
!call scopy(d*d,a,1,wc_a,1) 856 852 !call scopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 857 853 wc_a(:,:)=a(:,:)
858 854
allocate(wr(d)) 859 855 allocate(wr(d))
allocate(wi(d)) 860 856 allocate(wi(d))
allocate(vr(d,d)) 861 857 allocate(vr(d,d))
! query optimal work size 862 858 ! query optimal work size
call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info) 863 859 call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
lwork=int(twork(1)) 864 860 lwork=int(twork(1))
allocate(work(lwork)) 865 861 allocate(work(lwork))
call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info) 866 862 call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
867 863
if (info /= 0) then 868 864 if (info /= 0) then
if (present(status)) status=0 869 865 if (present(status)) status=0
deallocate(work) 870 866 deallocate(work)
deallocate(vr) 871 867 deallocate(vr)
deallocate(wi) 872 868 deallocate(wi)
deallocate(wr) 873 869 deallocate(wr)
deallocate(wc_a) 874 870 deallocate(wc_a)
return 875 871 return
end if 876 872 end if
877 873
! now fill in the results 878 874 ! now fill in the results
i=1 879 875 i=1
do while(i<=d) 880 876 do while(i<=d)
evala(i)=cmplx(wr(i),wi(i)) 881 877 evala(i)=cmplx(wr(i),wi(i))
if (wi(i) == 0.) then ! eigenvalue is real 882 878 if (wi(i) == 0.) then ! eigenvalue is real
eveca(:,i)=cmplx(vr(:,i),0.) 883 879 eveca(:,i)=cmplx(vr(:,i),0.)
else ! eigenvalue is complex 884 880 else ! eigenvalue is complex
evala(i+1)=cmplx(wr(i+1),wi(i+1)) 885 881 evala(i+1)=cmplx(wr(i+1),wi(i+1))
eveca(:,i)=cmplx(vr(:,i),vr(:,i+1)) 886 882 eveca(:,i)=cmplx(vr(:,i),vr(:,i+1))
eveca(:,i+1)=cmplx(vr(:,i),-vr(:,i+1)) 887 883 eveca(:,i+1)=cmplx(vr(:,i),-vr(:,i+1))
i=i+1 888 884 i=i+1
end if 889 885 end if
i=i+1 890 886 i=i+1
enddo 891 887 enddo
deallocate(work) 892 888 deallocate(work)
deallocate(vr) 893 889 deallocate(vr)
deallocate(wi) 894 890 deallocate(wi)
deallocate(wr) 895 891 deallocate(wr)
deallocate(wc_a) 896 892 deallocate(wc_a)
897 893
end subroutine 898 894 end subroutine
899 895
subroutine fvn_d_matev(d,a,evala,eveca,status) 900 896 subroutine fvn_d_matev(d,a,evala,eveca,status)
! 901 897 !
! integer d (in) : matrice rank 902 898 ! integer d (in) : matrice rank
! double precision a(d,d) (in) : The Matrix 903 899 ! double precision a(d,d) (in) : The Matrix
! double complex evala(d) (out) : eigenvalues 904 900 ! double complex evala(d) (out) : eigenvalues
! double complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector 905 901 ! double complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer (out) : status =0 if something went wrong 906 902 ! integer (out) : status =0 if something went wrong
! 907 903 !
! interfacing Lapack routine DGEEV 908 904 ! interfacing Lapack routine DGEEV
implicit none 909 905 implicit none
integer, intent(in) :: d 910 906 integer, intent(in) :: d
double precision, intent(in) :: a(d,d) 911 907 double precision, intent(in) :: a(d,d)
double complex, intent(out) :: evala(d) 912 908 double complex, intent(out) :: evala(d)
double complex, intent(out) :: eveca(d,d) 913 909 double complex, intent(out) :: eveca(d,d)
integer, intent(out), optional :: status 914 910 integer, intent(out), optional :: status
915 911
double precision, allocatable :: wc_a(:,:) ! a working copy of a 916 912 double precision, allocatable :: wc_a(:,:) ! a working copy of a
integer :: info 917 913 integer :: info
integer :: lwork 918 914 integer :: lwork
double precision, allocatable :: wr(:),wi(:) 919 915 double precision, allocatable :: wr(:),wi(:)
double precision :: vl ! unused but necessary for the call 920 916 double precision :: vl ! unused but necessary for the call
double precision, allocatable :: vr(:,:) 921 917 double precision, allocatable :: vr(:,:)
double precision, allocatable :: work(:) 922 918 double precision, allocatable :: work(:)
double precision :: twork(1) 923 919 double precision :: twork(1)
integer i 924 920 integer i
integer j 925 921 integer j
926 922
if (present(status)) status=1 927 923 if (present(status)) status=1
928 924
! making a working copy of a 929 925 ! making a working copy of a
allocate(wc_a(d,d)) 930 926 allocate(wc_a(d,d))
!call dcopy(d*d,a,1,wc_a,1) 931 927 !call dcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 932 928 wc_a(:,:)=a(:,:)
933 929
allocate(wr(d)) 934 930 allocate(wr(d))
allocate(wi(d)) 935 931 allocate(wi(d))
allocate(vr(d,d)) 936 932 allocate(vr(d,d))
! query optimal work size 937 933 ! query optimal work size
call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info) 938 934 call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
lwork=int(twork(1)) 939 935 lwork=int(twork(1))
allocate(work(lwork)) 940 936 allocate(work(lwork))
call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info) 941 937 call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
942 938
if (info /= 0) then 943 939 if (info /= 0) then
if (present(status)) status=0 944 940 if (present(status)) status=0
deallocate(work) 945 941 deallocate(work)
deallocate(vr) 946 942 deallocate(vr)
deallocate(wi) 947 943 deallocate(wi)
deallocate(wr) 948 944 deallocate(wr)
deallocate(wc_a) 949 945 deallocate(wc_a)
return 950 946 return
end if 951 947 end if
952 948
! now fill in the results 953 949 ! now fill in the results
i=1 954 950 i=1
do while(i<=d) 955 951 do while(i<=d)
evala(i)=dcmplx(wr(i),wi(i)) 956 952 evala(i)=dcmplx(wr(i),wi(i))
if (wi(i) == 0.) then ! eigenvalue is real 957 953 if (wi(i) == 0.) then ! eigenvalue is real
eveca(:,i)=dcmplx(vr(:,i),0.) 958 954 eveca(:,i)=dcmplx(vr(:,i),0.)
else ! eigenvalue is complex 959 955 else ! eigenvalue is complex
evala(i+1)=dcmplx(wr(i+1),wi(i+1)) 960 956 evala(i+1)=dcmplx(wr(i+1),wi(i+1))
eveca(:,i)=dcmplx(vr(:,i),vr(:,i+1)) 961 957 eveca(:,i)=dcmplx(vr(:,i),vr(:,i+1))
eveca(:,i+1)=dcmplx(vr(:,i),-vr(:,i+1)) 962 958 eveca(:,i+1)=dcmplx(vr(:,i),-vr(:,i+1))
i=i+1 963 959 i=i+1
end if 964 960 end if
i=i+1 965 961 i=i+1
enddo 966 962 enddo
967 963
deallocate(work) 968 964 deallocate(work)
deallocate(vr) 969 965 deallocate(vr)
deallocate(wi) 970 966 deallocate(wi)
deallocate(wr) 971 967 deallocate(wr)
deallocate(wc_a) 972 968 deallocate(wc_a)
973 969
end subroutine 974 970 end subroutine
975 971
subroutine fvn_c_matev(d,a,evala,eveca,status) 976 972 subroutine fvn_c_matev(d,a,evala,eveca,status)
! 977 973 !
! integer d (in) : matrice rank 978 974 ! integer d (in) : matrice rank
! complex a(d,d) (in) : The Matrix 979 975 ! complex a(d,d) (in) : The Matrix
! complex evala(d) (out) : eigenvalues 980 976 ! complex evala(d) (out) : eigenvalues
! complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector 981 977 ! complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer (out) : status =0 if something went wrong 982 978 ! integer (out) : status =0 if something went wrong
! 983 979 !
! interfacing Lapack routine CGEEV 984 980 ! interfacing Lapack routine CGEEV
implicit none 985 981 implicit none
integer, intent(in) :: d 986 982 integer, intent(in) :: d
complex, intent(in) :: a(d,d) 987 983 complex, intent(in) :: a(d,d)
complex, intent(out) :: evala(d) 988 984 complex, intent(out) :: evala(d)
complex, intent(out) :: eveca(d,d) 989 985 complex, intent(out) :: eveca(d,d)
integer, intent(out), optional :: status 990 986 integer, intent(out), optional :: status
991 987
complex, allocatable :: wc_a(:,:) ! a working copy of a 992 988 complex, allocatable :: wc_a(:,:) ! a working copy of a
integer :: info 993 989 integer :: info
integer :: lwork 994 990 integer :: lwork
complex, allocatable :: work(:) 995 991 complex, allocatable :: work(:)
complex :: twork(1) 996 992 complex :: twork(1)
real, allocatable :: rwork(:) 997 993 real, allocatable :: rwork(:)
complex :: vl ! unused but necessary for the call 998 994 complex :: vl ! unused but necessary for the call
999 995
if (present(status)) status=1 1000 996 if (present(status)) status=1
1001 997
! making a working copy of a 1002 998 ! making a working copy of a
allocate(wc_a(d,d)) 1003 999 allocate(wc_a(d,d))
!call ccopy(d*d,a,1,wc_a,1) 1004 1000 !call ccopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1005 1001 wc_a(:,:)=a(:,:)
1006 1002
1007 1003
! query optimal work size 1008 1004 ! query optimal work size
call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info) 1009 1005 call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
lwork=int(twork(1)) 1010 1006 lwork=int(twork(1))
allocate(work(lwork)) 1011 1007 allocate(work(lwork))
allocate(rwork(2*d)) 1012 1008 allocate(rwork(2*d))
call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info) 1013 1009 call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
1014 1010
if (info /= 0) then 1015 1011 if (info /= 0) then
if (present(status)) status=0 1016 1012 if (present(status)) status=0
end if 1017 1013 end if
deallocate(rwork) 1018 1014 deallocate(rwork)
deallocate(work) 1019 1015 deallocate(work)
deallocate(wc_a) 1020 1016 deallocate(wc_a)
1021 1017
end subroutine 1022 1018 end subroutine
1023 1019
subroutine fvn_z_matev(d,a,evala,eveca,status) 1024 1020 subroutine fvn_z_matev(d,a,evala,eveca,status)
! 1025 1021 !
! integer d (in) : matrice rank 1026 1022 ! integer d (in) : matrice rank
! double complex a(d,d) (in) : The Matrix 1027 1023 ! double complex a(d,d) (in) : The Matrix
! double complex evala(d) (out) : eigenvalues 1028 1024 ! double complex evala(d) (out) : eigenvalues
! double complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector 1029 1025 ! double complex eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer (out) : status =0 if something went wrong 1030 1026 ! integer (out) : status =0 if something went wrong
! 1031 1027 !
! interfacing Lapack routine ZGEEV 1032 1028 ! interfacing Lapack routine ZGEEV
implicit none 1033 1029 implicit none
integer, intent(in) :: d 1034 1030 integer, intent(in) :: d
double complex, intent(in) :: a(d,d) 1035 1031 double complex, intent(in) :: a(d,d)
double complex, intent(out) :: evala(d) 1036 1032 double complex, intent(out) :: evala(d)
double complex, intent(out) :: eveca(d,d) 1037 1033 double complex, intent(out) :: eveca(d,d)
integer, intent(out), optional :: status 1038 1034 integer, intent(out), optional :: status
1039 1035
double complex, allocatable :: wc_a(:,:) ! a working copy of a 1040 1036 double complex, allocatable :: wc_a(:,:) ! a working copy of a
integer :: info 1041 1037 integer :: info
integer :: lwork 1042 1038 integer :: lwork
double complex, allocatable :: work(:) 1043 1039 double complex, allocatable :: work(:)
double complex :: twork(1) 1044 1040 double complex :: twork(1)
double precision, allocatable :: rwork(:) 1045 1041 double precision, allocatable :: rwork(:)
double complex :: vl ! unused but necessary for the call 1046 1042 double complex :: vl ! unused but necessary for the call
1047 1043
if (present(status)) status=1 1048 1044 if (present(status)) status=1
1049 1045
! making a working copy of a 1050 1046 ! making a working copy of a
allocate(wc_a(d,d)) 1051 1047 allocate(wc_a(d,d))
!call zcopy(d*d,a,1,wc_a,1) 1052 1048 !call zcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1053 1049 wc_a(:,:)=a(:,:)
1054 1050
! query optimal work size 1055 1051 ! query optimal work size
call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info) 1056 1052 call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
lwork=int(twork(1)) 1057 1053 lwork=int(twork(1))
allocate(work(lwork)) 1058 1054 allocate(work(lwork))
allocate(rwork(2*d)) 1059 1055 allocate(rwork(2*d))
call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info) 1060 1056 call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
1061 1057
if (info /= 0) then 1062 1058 if (info /= 0) then
if (present(status)) status=0 1063 1059 if (present(status)) status=0
end if 1064 1060 end if
deallocate(rwork) 1065 1061 deallocate(rwork)
deallocate(work) 1066 1062 deallocate(work)
deallocate(wc_a) 1067 1063 deallocate(wc_a)
1068 1064
end subroutine 1069 1065 end subroutine
1070 1066
1071 1067
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1072 1068 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1073 1069 !
! Quadratic interpolation of tabulated function of 1,2 or 3 variables 1074 1070 ! Quadratic interpolation of tabulated function of 1,2 or 3 variables
! 1075 1071 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1076 1072 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1077 1073
subroutine fvn_s_find_interval(x,i,xdata,n) 1078 1074 subroutine fvn_s_find_interval(x,i,xdata,n)
implicit none 1079 1075 implicit none
! This routine find the indice i where xdata(i) <= x < xdata(i+1) 1080 1076 ! This routine find the indice i where xdata(i) <= x < xdata(i+1)
! xdata(n) must contains a set of increasingly ordered values 1081 1077 ! xdata(n) must contains a set of increasingly ordered values
! if x < xdata(1) i=0 is returned 1082 1078 ! if x < xdata(1) i=0 is returned
! if x > xdata(n) i=n is returned 1083 1079 ! if x > xdata(n) i=n is returned
! special case is where x=xdata(n) then n-1 is returned so 1084 1080 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 1085 1081 ! we will not exclude the upper limit
! a simple dichotomy method is used 1086 1082 ! a simple dichotomy method is used
1087 1083
real(kind=4), intent(in) :: x 1088 1084 real(kind=4), intent(in) :: x
real(kind=4), intent(in), dimension(n) :: xdata 1089 1085 real(kind=4), intent(in), dimension(n) :: xdata
integer(kind=4), intent(in) :: n 1090 1086 integer(kind=4), intent(in) :: n
integer(kind=4), intent(out) :: i 1091 1087 integer(kind=4), intent(out) :: i
1092 1088
integer(kind=4) :: imin,imax,imoyen 1093 1089 integer(kind=4) :: imin,imax,imoyen
1094 1090
! special case is where x=xdata(n) then n-1 is returned so 1095 1091 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 1096 1092 ! we will not exclude the upper limit
if (x == xdata(n)) then 1097 1093 if (x == xdata(n)) then
i=n-1 1098 1094 i=n-1
return 1099 1095 return
end if 1100 1096 end if
1101 1097
! if x < xdata(1) i=0 is returned 1102 1098 ! if x < xdata(1) i=0 is returned
if (x < xdata(1)) then 1103 1099 if (x < xdata(1)) then
i=0 1104 1100 i=0
return 1105 1101 return
end if 1106 1102 end if
1107 1103
! if x > xdata(n) i=n is returned 1108 1104 ! if x > xdata(n) i=n is returned
if (x > xdata(n)) then 1109 1105 if (x > xdata(n)) then
i=n 1110 1106 i=n
return 1111 1107 return
end if 1112 1108 end if
1113 1109
! here xdata(1) <= x <= xdata(n) 1114 1110 ! here xdata(1) <= x <= xdata(n)
imin=0 1115 1111 imin=0
imax=n+1 1116 1112 imax=n+1
1117 1113
do while((imax-imin) > 1) 1118 1114 do while((imax-imin) > 1)
imoyen=(imax+imin)/2 1119 1115 imoyen=(imax+imin)/2
if (x >= xdata(imoyen)) then 1120 1116 if (x >= xdata(imoyen)) then
imin=imoyen 1121 1117 imin=imoyen
else 1122 1118 else
imax=imoyen 1123 1119 imax=imoyen
end if 1124 1120 end if
end do 1125 1121 end do
1126 1122
i=imin 1127 1123 i=imin
1128 1124
end subroutine 1129 1125 end subroutine
1130 1126
1131 1127
subroutine fvn_d_find_interval(x,i,xdata,n) 1132 1128 subroutine fvn_d_find_interval(x,i,xdata,n)
implicit none 1133 1129 implicit none
! This routine find the indice i where xdata(i) <= x < xdata(i+1) 1134 1130 ! This routine find the indice i where xdata(i) <= x < xdata(i+1)
! xdata(n) must contains a set of increasingly ordered values 1135 1131 ! xdata(n) must contains a set of increasingly ordered values
! if x < xdata(1) i=0 is returned 1136 1132 ! if x < xdata(1) i=0 is returned
! if x > xdata(n) i=n is returned 1137 1133 ! if x > xdata(n) i=n is returned
! special case is where x=xdata(n) then n-1 is returned so 1138 1134 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 1139 1135 ! we will not exclude the upper limit
! a simple dichotomy method is used 1140 1136 ! a simple dichotomy method is used
1141 1137
real(kind=8), intent(in) :: x 1142 1138 real(kind=8), intent(in) :: x
real(kind=8), intent(in), dimension(n) :: xdata 1143 1139 real(kind=8), intent(in), dimension(n) :: xdata
integer(kind=4), intent(in) :: n 1144 1140 integer(kind=4), intent(in) :: n
integer(kind=4), intent(out) :: i 1145 1141 integer(kind=4), intent(out) :: i
1146 1142
integer(kind=4) :: imin,imax,imoyen 1147 1143 integer(kind=4) :: imin,imax,imoyen
1148 1144
! special case is where x=xdata(n) then n-1 is returned so 1149 1145 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 1150 1146 ! we will not exclude the upper limit
if (x == xdata(n)) then 1151 1147 if (x == xdata(n)) then
i=n-1 1152 1148 i=n-1
return 1153 1149 return
end if 1154 1150 end if
1155 1151
! if x < xdata(1) i=0 is returned 1156 1152 ! if x < xdata(1) i=0 is returned
if (x < xdata(1)) then 1157 1153 if (x < xdata(1)) then
i=0 1158 1154 i=0
return 1159 1155 return
end if 1160 1156 end if
1161 1157
! if x > xdata(n) i=n is returned 1162 1158 ! if x > xdata(n) i=n is returned
if (x > xdata(n)) then 1163 1159 if (x > xdata(n)) then
i=n 1164 1160 i=n
return 1165 1161 return
end if 1166 1162 end if
1167 1163
! here xdata(1) <= x <= xdata(n) 1168 1164 ! here xdata(1) <= x <= xdata(n)
imin=0 1169 1165 imin=0
imax=n+1 1170 1166 imax=n+1
1171 1167
do while((imax-imin) > 1) 1172 1168 do while((imax-imin) > 1)
imoyen=(imax+imin)/2 1173 1169 imoyen=(imax+imin)/2
if (x >= xdata(imoyen)) then 1174 1170 if (x >= xdata(imoyen)) then
imin=imoyen 1175 1171 imin=imoyen
else 1176 1172 else
imax=imoyen 1177 1173 imax=imoyen
end if 1178 1174 end if
end do 1179 1175 end do
1180 1176
i=imin 1181 1177 i=imin
1182 1178
end subroutine 1183 1179 end subroutine
1184 1180
1185 1181
function fvn_s_quad_interpol(x,n,xdata,ydata) 1186 1182 function fvn_s_quad_interpol(x,n,xdata,ydata)
implicit none 1187 1183 implicit none
! This function evaluate the value of a function defined by a set of points 1188 1184 ! This function evaluate the value of a function defined by a set of points
! and values, using a quadratic interpolation 1189 1185 ! and values, using a quadratic interpolation
! xdata must be increasingly ordered 1190 1186 ! xdata must be increasingly ordered
! x must be within xdata(1) and xdata(n) to actually do interpolation 1191 1187 ! x must be within xdata(1) and xdata(n) to actually do interpolation
! otherwise extrapolation is done 1192 1188 ! otherwise extrapolation is done
integer(kind=4), intent(in) :: n 1193 1189 integer(kind=4), intent(in) :: n
real(kind=4), intent(in), dimension(n) :: xdata,ydata 1194 1190 real(kind=4), intent(in), dimension(n) :: xdata,ydata
real(kind=4), intent(in) :: x 1195 1191 real(kind=4), intent(in) :: x
real(kind=4) :: fvn_s_quad_interpol 1196 1192 real(kind=4) :: fvn_s_quad_interpol
1197 1193
integer(kind=4) :: iinf,base,i,j 1198 1194 integer(kind=4) :: iinf,base,i,j
real(kind=4) :: p 1199 1195 real(kind=4) :: p
1200 1196
call fvn_s_find_interval(x,iinf,xdata,n) 1201 1197 call fvn_s_find_interval(x,iinf,xdata,n)
1202 1198
! Settings for extrapolation 1203 1199 ! Settings for extrapolation
if (iinf==0) then 1204 1200 if (iinf==0) then
! TODO -> Lower bound extrapolation warning 1205 1201 ! TODO -> Lower bound extrapolation warning
iinf=1 1206 1202 iinf=1
end if 1207 1203 end if
1208 1204
if (iinf==n) then 1209 1205 if (iinf==n) then
! TODO -> Higher bound extrapolation warning 1210 1206 ! TODO -> Higher bound extrapolation warning
iinf=n-1 1211 1207 iinf=n-1
end if 1212 1208 end if
1213 1209
! The three points we will use are iinf-1,iinf and iinf+1 with the 1214 1210 ! The three points we will use are iinf-1,iinf and iinf+1 with the
! exception of the first interval, where iinf=1 we will use 1,2 and 3 1215 1211 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (iinf==1) then 1216 1212 if (iinf==1) then
base=0 1217 1213 base=0
else 1218 1214 else
base=iinf-2 1219 1215 base=iinf-2
end if 1220 1216 end if
1221 1217
! The three points we will use are : 1222 1218 ! The three points we will use are :
! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3) 1223 1219 ! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3)
1224 1220
! Straight forward Lagrange polynomial 1225 1221 ! Straight forward Lagrange polynomial
fvn_s_quad_interpol=0. 1226 1222 fvn_s_quad_interpol=0.
do i=1,3 1227 1223 do i=1,3
! polynome i 1228 1224 ! polynome i
p=ydata(base+i) 1229 1225 p=ydata(base+i)
do j=1,3 1230 1226 do j=1,3
if (j /= i) then 1231 1227 if (j /= i) then
p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j)) 1232 1228 p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j))
end if 1233 1229 end if
end do 1234 1230 end do
fvn_s_quad_interpol=fvn_s_quad_interpol+p 1235 1231 fvn_s_quad_interpol=fvn_s_quad_interpol+p
end do 1236 1232 end do
1237 1233
end function 1238 1234 end function
1239 1235
1240 1236
function fvn_d_quad_interpol(x,n,xdata,ydata) 1241 1237 function fvn_d_quad_interpol(x,n,xdata,ydata)
implicit none 1242 1238 implicit none
! This function evaluate the value of a function defined by a set of points 1243 1239 ! This function evaluate the value of a function defined by a set of points
! and values, using a quadratic interpolation 1244 1240 ! and values, using a quadratic interpolation
! xdata must be increasingly ordered 1245 1241 ! xdata must be increasingly ordered
! x must be within xdata(1) and xdata(n) to actually do interpolation 1246 1242 ! x must be within xdata(1) and xdata(n) to actually do interpolation
! otherwise extrapolation is done 1247 1243 ! otherwise extrapolation is done
integer(kind=4), intent(in) :: n 1248 1244 integer(kind=4), intent(in) :: n
real(kind=8), intent(in), dimension(n) :: xdata,ydata 1249 1245 real(kind=8), intent(in), dimension(n) :: xdata,ydata
real(kind=8), intent(in) :: x 1250 1246 real(kind=8), intent(in) :: x
real(kind=8) :: fvn_d_quad_interpol 1251 1247 real(kind=8) :: fvn_d_quad_interpol
1252 1248
integer(kind=4) :: iinf,base,i,j 1253 1249 integer(kind=4) :: iinf,base,i,j
real(kind=8) :: p 1254 1250 real(kind=8) :: p
1255 1251
call fvn_d_find_interval(x,iinf,xdata,n) 1256 1252 call fvn_d_find_interval(x,iinf,xdata,n)
1257 1253
! Settings for extrapolation 1258 1254 ! Settings for extrapolation
if (iinf==0) then 1259 1255 if (iinf==0) then
! TODO -> Lower bound extrapolation warning 1260 1256 ! TODO -> Lower bound extrapolation warning
iinf=1 1261 1257 iinf=1
end if 1262 1258 end if
1263 1259
if (iinf==n) then 1264 1260 if (iinf==n) then
! TODO Higher bound extrapolation warning 1265 1261 ! TODO Higher bound extrapolation warning
iinf=n-1 1266 1262 iinf=n-1
end if 1267 1263 end if
1268 1264
! The three points we will use are iinf-1,iinf and iinf+1 with the 1269 1265 ! The three points we will use are iinf-1,iinf and iinf+1 with the
! exception of the first interval, where iinf=1 we will use 1,2 and 3 1270 1266 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (iinf==1) then 1271 1267 if (iinf==1) then
base=0 1272 1268 base=0
else 1273 1269 else
base=iinf-2 1274 1270 base=iinf-2
end if 1275 1271 end if
1276 1272
! The three points we will use are : 1277 1273 ! The three points we will use are :
! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3) 1278 1274 ! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3)
1279 1275
! Straight forward Lagrange polynomial 1280 1276 ! Straight forward Lagrange polynomial
fvn_d_quad_interpol=0. 1281 1277 fvn_d_quad_interpol=0.
do i=1,3 1282 1278 do i=1,3
! polynome i 1283 1279 ! polynome i
p=ydata(base+i) 1284 1280 p=ydata(base+i)
do j=1,3 1285 1281 do j=1,3
if (j /= i) then 1286 1282 if (j /= i) then
p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j)) 1287 1283 p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j))
end if 1288 1284 end if
end do 1289 1285 end do
fvn_d_quad_interpol=fvn_d_quad_interpol+p 1290 1286 fvn_d_quad_interpol=fvn_d_quad_interpol+p
end do 1291 1287 end do
1292 1288
end function 1293 1289 end function
1294 1290
1295 1291
function fvn_s_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata) 1296 1292 function fvn_s_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata)
implicit none 1297 1293 implicit none
! This function evaluate the value of a two variable function defined by a 1298 1294 ! This function evaluate the value of a two variable function defined by a
! set of points and values, using a quadratic interpolation 1299 1295 ! set of points and values, using a quadratic interpolation
! xdata and ydata must be increasingly ordered 1300 1296 ! xdata and ydata must be increasingly ordered
! the couple (x,y) must be as x within xdata(1) and xdata(nx) and 1301 1297 ! the couple (x,y) must be as x within xdata(1) and xdata(nx) and
! y within ydata(1) and ydata(ny) to actually do interpolation 1302 1298 ! y within ydata(1) and ydata(ny) to actually do interpolation
! otherwise extrapolation is done 1303 1299 ! otherwise extrapolation is done
integer(kind=4), intent(in) :: nx,ny 1304 1300 integer(kind=4), intent(in) :: nx,ny
real(kind=4), intent(in) :: x,y 1305 1301 real(kind=4), intent(in) :: x,y
real(kind=4), intent(in), dimension(nx) :: xdata 1306 1302 real(kind=4), intent(in), dimension(nx) :: xdata
real(kind=4), intent(in), dimension(ny) :: ydata 1307 1303 real(kind=4), intent(in), dimension(ny) :: ydata
real(kind=4), intent(in), dimension(nx,ny) :: zdata 1308 1304 real(kind=4), intent(in), dimension(nx,ny) :: zdata
real(kind=4) :: fvn_s_quad_2d_interpol 1309 1305 real(kind=4) :: fvn_s_quad_2d_interpol
1310 1306
integer(kind=4) :: ixinf,iyinf,basex,basey,i 1311 1307 integer(kind=4) :: ixinf,iyinf,basex,basey,i
real(kind=4),dimension(3) :: ztmp 1312 1308 real(kind=4),dimension(3) :: ztmp
!real(kind=4), external :: fvn_s_quad_interpol 1313 1309 !real(kind=4), external :: fvn_s_quad_interpol
1314 1310
call fvn_s_find_interval(x,ixinf,xdata,nx) 1315 1311 call fvn_s_find_interval(x,ixinf,xdata,nx)
call fvn_s_find_interval(y,iyinf,ydata,ny) 1316 1312 call fvn_s_find_interval(y,iyinf,ydata,ny)
1317 1313
! Settings for extrapolation 1318 1314 ! Settings for extrapolation
if (ixinf==0) then 1319 1315 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 1320 1316 ! TODO -> Lower x bound extrapolation warning
ixinf=1 1321 1317 ixinf=1
end if 1322 1318 end if
1323 1319
if (ixinf==nx) then 1324 1320 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 1325 1321 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 1326 1322 ixinf=nx-1
end if 1327 1323 end if
1328 1324
if (iyinf==0) then 1329 1325 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 1330 1326 ! TODO -> Lower y bound extrapolation warning
iyinf=1 1331 1327 iyinf=1
end if 1332 1328 end if
1333 1329
if (iyinf==ny) then 1334 1330 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 1335 1331 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 1336 1332 iyinf=ny-1
end if 1337 1333 end if
1338 1334
! The three points we will use are iinf-1,iinf and iinf+1 with the 1339 1335 ! The three points we will use are iinf-1,iinf and iinf+1 with the
! exception of the first interval, where iinf=1 we will use 1,2 and 3 1340 1336 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 1341 1337 if (ixinf==1) then
basex=0 1342 1338 basex=0
else 1343 1339 else
basex=ixinf-2 1344 1340 basex=ixinf-2
end if 1345 1341 end if
1346 1342
if (iyinf==1) then 1347 1343 if (iyinf==1) then
basey=0 1348 1344 basey=0
else 1349 1345 else
basey=iyinf-2 1350 1346 basey=iyinf-2
end if 1351 1347 end if
1352 1348
! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3) 1353 1349 ! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3)
! stored in ztmp(1:3) 1354 1350 ! stored in ztmp(1:3)
do i=1,3 1355 1351 do i=1,3
ztmp(i)=fvn_s_quad_interpol(x,nx,xdata,zdata(:,basey+i)) 1356 1352 ztmp(i)=fvn_s_quad_interpol(x,nx,xdata,zdata(:,basey+i))
end do 1357 1353 end do
1358 1354
! Then we make an interpolation for y using previous interpolations 1359 1355 ! Then we make an interpolation for y using previous interpolations
fvn_s_quad_2d_interpol=fvn_s_quad_interpol(y,3,ydata(basey+1:basey+3),ztmp) 1360 1356 fvn_s_quad_2d_interpol=fvn_s_quad_interpol(y,3,ydata(basey+1:basey+3),ztmp)
end function 1361 1357 end function
1362 1358
1363 1359
function fvn_d_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata) 1364 1360 function fvn_d_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata)
implicit none 1365 1361 implicit none
! This function evaluate the value of a two variable function defined by a 1366 1362 ! This function evaluate the value of a two variable function defined by a
! set of points and values, using a quadratic interpolation 1367 1363 ! set of points and values, using a quadratic interpolation
! xdata and ydata must be increasingly ordered 1368 1364 ! xdata and ydata must be increasingly ordered
! the couple (x,y) must be as x within xdata(1) and xdata(nx) and 1369 1365 ! the couple (x,y) must be as x within xdata(1) and xdata(nx) and
! y within ydata(1) and ydata(ny) to actually do interpolation 1370 1366 ! y within ydata(1) and ydata(ny) to actually do interpolation
! otherwise extrapolation is done 1371 1367 ! otherwise extrapolation is done
integer(kind=4), intent(in) :: nx,ny 1372 1368 integer(kind=4), intent(in) :: nx,ny
real(kind=8), intent(in) :: x,y 1373 1369 real(kind=8), intent(in) :: x,y
real(kind=8), intent(in), dimension(nx) :: xdata 1374 1370 real(kind=8), intent(in), dimension(nx) :: xdata
real(kind=8), intent(in), dimension(ny) :: ydata 1375 1371 real(kind=8), intent(in), dimension(ny) :: ydata
real(kind=8), intent(in), dimension(nx,ny) :: zdata 1376 1372 real(kind=8), intent(in), dimension(nx,ny) :: zdata
real(kind=8) :: fvn_d_quad_2d_interpol 1377 1373 real(kind=8) :: fvn_d_quad_2d_interpol
1378 1374
integer(kind=4) :: ixinf,iyinf,basex,basey,i 1379 1375 integer(kind=4) :: ixinf,iyinf,basex,basey,i
real(kind=8),dimension(3) :: ztmp 1380 1376 real(kind=8),dimension(3) :: ztmp
!real(kind=8), external :: fvn_d_quad_interpol 1381 1377 !real(kind=8), external :: fvn_d_quad_interpol
1382 1378
call fvn_d_find_interval(x,ixinf,xdata,nx) 1383 1379 call fvn_d_find_interval(x,ixinf,xdata,nx)
call fvn_d_find_interval(y,iyinf,ydata,ny) 1384 1380 call fvn_d_find_interval(y,iyinf,ydata,ny)
1385 1381
! Settings for extrapolation 1386 1382 ! Settings for extrapolation
if (ixinf==0) then 1387 1383 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 1388 1384 ! TODO -> Lower x bound extrapolation warning
ixinf=1 1389 1385 ixinf=1
end if 1390 1386 end if
1391 1387
if (ixinf==nx) then 1392 1388 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 1393 1389 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 1394 1390 ixinf=nx-1
end if 1395 1391 end if
1396 1392
if (iyinf==0) then 1397 1393 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 1398 1394 ! TODO -> Lower y bound extrapolation warning
iyinf=1 1399 1395 iyinf=1
end if 1400 1396 end if
1401 1397
if (iyinf==ny) then 1402 1398 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 1403 1399 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 1404 1400 iyinf=ny-1
end if 1405 1401 end if
1406 1402
! The three points we will use are iinf-1,iinf and iinf+1 with the 1407 1403 ! The three points we will use are iinf-1,iinf and iinf+1 with the
! exception of the first interval, where iinf=1 we will use 1,2 and 3 1408 1404 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 1409 1405 if (ixinf==1) then
basex=0 1410 1406 basex=0
else 1411 1407 else
basex=ixinf-2 1412 1408 basex=ixinf-2
end if 1413 1409 end if
1414 1410
if (iyinf==1) then 1415 1411 if (iyinf==1) then
basey=0 1416 1412 basey=0
else 1417 1413 else
basey=iyinf-2 1418 1414 basey=iyinf-2
end if 1419 1415 end if
1420 1416
! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3) 1421 1417 ! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3)
! stored in ztmp(1:3) 1422 1418 ! stored in ztmp(1:3)
do i=1,3 1423 1419 do i=1,3
ztmp(i)=fvn_d_quad_interpol(x,nx,xdata,zdata(:,basey+i)) 1424 1420 ztmp(i)=fvn_d_quad_interpol(x,nx,xdata,zdata(:,basey+i))
end do 1425 1421 end do
1426 1422
! Then we make an interpolation for y using previous interpolations 1427 1423 ! Then we make an interpolation for y using previous interpolations
fvn_d_quad_2d_interpol=fvn_d_quad_interpol(y,3,ydata(basey+1:basey+3),ztmp) 1428 1424 fvn_d_quad_2d_interpol=fvn_d_quad_interpol(y,3,ydata(basey+1:basey+3),ztmp)
end function 1429 1425 end function
1430 1426
1431 1427
function fvn_s_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata) 1432 1428 function fvn_s_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata)
implicit none 1433 1429 implicit none
! This function evaluate the value of a 3 variables function defined by a 1434 1430 ! This function evaluate the value of a 3 variables function defined by a
! set of points and values, using a quadratic interpolation 1435 1431 ! set of points and values, using a quadratic interpolation
! xdata, ydata and zdata must be increasingly ordered 1436 1432 ! xdata, ydata and zdata must be increasingly ordered
! The triplet (x,y,z) must be within xdata,ydata and zdata to actually 1437 1433 ! The triplet (x,y,z) must be within xdata,ydata and zdata to actually
! perform an interpolation, otherwise extrapolation is done 1438 1434 ! perform an interpolation, otherwise extrapolation is done
integer(kind=4), intent(in) :: nx,ny,nz 1439 1435 integer(kind=4), intent(in) :: nx,ny,nz
real(kind=4), intent(in) :: x,y,z 1440 1436 real(kind=4), intent(in) :: x,y,z
real(kind=4), intent(in), dimension(nx) :: xdata 1441 1437 real(kind=4), intent(in), dimension(nx) :: xdata
real(kind=4), intent(in), dimension(ny) :: ydata 1442 1438 real(kind=4), intent(in), dimension(ny) :: ydata
real(kind=4), intent(in), dimension(nz) :: zdata 1443 1439 real(kind=4), intent(in), dimension(nz) :: zdata
real(kind=4), intent(in), dimension(nx,ny,nz) :: tdata 1444 1440 real(kind=4), intent(in), dimension(nx,ny,nz) :: tdata
real(kind=4) :: fvn_s_quad_3d_interpol 1445 1441 real(kind=4) :: fvn_s_quad_3d_interpol
1446 1442
integer(kind=4) :: ixinf,iyinf,izinf,basex,basey,basez,i,j 1447 1443 integer(kind=4) :: ixinf,iyinf,izinf,basex,basey,basez,i,j
!real(kind=4), external :: fvn_s_quad_interpol,fvn_s_quad_2d_interpol 1448 1444 !real(kind=4), external :: fvn_s_quad_interpol,fvn_s_quad_2d_interpol
real(kind=4),dimension(3,3) :: ttmp 1449 1445 real(kind=4),dimension(3,3) :: ttmp
1450 1446
call fvn_s_find_interval(x,ixinf,xdata,nx) 1451 1447 call fvn_s_find_interval(x,ixinf,xdata,nx)
call fvn_s_find_interval(y,iyinf,ydata,ny) 1452 1448 call fvn_s_find_interval(y,iyinf,ydata,ny)
call fvn_s_find_interval(z,izinf,zdata,nz) 1453 1449 call fvn_s_find_interval(z,izinf,zdata,nz)
1454 1450
! Settings for extrapolation 1455 1451 ! Settings for extrapolation
if (ixinf==0) then 1456 1452 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 1457 1453 ! TODO -> Lower x bound extrapolation warning
ixinf=1 1458 1454 ixinf=1
end if 1459 1455 end if
1460 1456
if (ixinf==nx) then 1461 1457 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 1462 1458 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 1463 1459 ixinf=nx-1
end if 1464 1460 end if
1465 1461
if (iyinf==0) then 1466 1462 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 1467 1463 ! TODO -> Lower y bound extrapolation warning
iyinf=1 1468 1464 iyinf=1
end if 1469 1465 end if
1470 1466
if (iyinf==ny) then 1471 1467 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 1472 1468 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 1473 1469 iyinf=ny-1
end if 1474 1470 end if
1475 1471
if (izinf==0) then 1476 1472 if (izinf==0) then
! TODO -> Lower z bound extrapolation warning 1477 1473 ! TODO -> Lower z bound extrapolation warning
izinf=1 1478 1474 izinf=1
end if 1479 1475 end if
1480 1476
if (izinf==nz) then 1481 1477 if (izinf==nz) then
! TODO -> Higher z bound extrapolation warning 1482 1478 ! TODO -> Higher z bound extrapolation warning
izinf=nz-1 1483 1479 izinf=nz-1
end if 1484 1480 end if
1485 1481
! The three points we will use are iinf-1,iinf and iinf+1 with the 1486 1482 ! The three points we will use are iinf-1,iinf and iinf+1 with the
! exception of the first interval, where iinf=1 we will use 1,2 and 3 1487 1483 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 1488 1484 if (ixinf==1) then
basex=0 1489 1485 basex=0
else 1490 1486 else
basex=ixinf-2 1491 1487 basex=ixinf-2
end if 1492 1488 end if
1493 1489
if (iyinf==1) then 1494 1490 if (iyinf==1) then
basey=0 1495 1491 basey=0
else 1496 1492 else
basey=iyinf-2 1497 1493 basey=iyinf-2
end if 1498 1494 end if
1499 1495
if (izinf==1) then 1500 1496 if (izinf==1) then
basez=0 1501 1497 basez=0
else 1502 1498 else
basez=izinf-2 1503 1499 basez=izinf-2
end if 1504 1500 end if
1505 1501
! We first make 9 one dimensional interpolation on variable x. 1506 1502 ! We first make 9 one dimensional interpolation on variable x.
! results are stored in ttmp 1507 1503 ! results are stored in ttmp
do i=1,3 1508 1504 do i=1,3
do j=1,3 1509 1505 do j=1,3
ttmp(i,j)=fvn_s_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j)) 1510 1506 ttmp(i,j)=fvn_s_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j))
end do 1511 1507 end do
end do 1512 1508 end do
1513 1509
! We then make a 2 dimensionnal interpolation on variables y and z 1514 1510 ! We then make a 2 dimensionnal interpolation on variables y and z
fvn_s_quad_3d_interpol=fvn_s_quad_2d_interpol(y,z, & 1515 1511 fvn_s_quad_3d_interpol=fvn_s_quad_2d_interpol(y,z, &
3,ydata(basey+1:basey+3),3,zdata(basez+1:basez+3),ttmp) 1516 1512 3,ydata(basey+1:basey+3),3,zdata(basez+1:basez+3),ttmp)
end function 1517 1513 end function
1518 1514
1519 1515
function fvn_d_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata) 1520 1516 function fvn_d_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata)
implicit none 1521 1517 implicit none
! This function evaluate the value of a 3 variables function defined by a 1522 1518 ! This function evaluate the value of a 3 variables function defined by a
! set of points and values, using a quadratic interpolation 1523 1519 ! set of points and values, using a quadratic interpolation
! xdata, ydata and zdata must be increasingly ordered 1524 1520 ! xdata, ydata and zdata must be increasingly ordered
! The triplet (x,y,z) must be within xdata,ydata and zdata to actually 1525 1521 ! The triplet (x,y,z) must be within xdata,ydata and zdata to actually
! perform an interpolation, otherwise extrapolation is done 1526 1522 ! perform an interpolation, otherwise extrapolation is done
integer(kind=4), intent(in) :: nx,ny,nz 1527 1523 integer(kind=4), intent(in) :: nx,ny,nz
real(kind=8), intent(in) :: x,y,z 1528 1524 real(kind=8), intent(in) :: x,y,z
real(kind=8), intent(in), dimension(nx) :: xdata 1529 1525 real(kind=8), intent(in), dimension(nx) :: xdata
real(kind=8), intent(in), dimension(ny) :: ydata 1530 1526 real(kind=8), intent(in), dimension(ny) :: ydata
real(kind=8), intent(in), dimension(nz) :: zdata 1531 1527 real(kind=8), intent(in), dimension(nz) :: zdata
real(kind=8), intent(in), dimension(nx,ny,nz) :: tdata 1532 1528 real(kind=8), intent(in), dimension(nx,ny,nz) :: tdata
real(kind=8) :: fvn_d_quad_3d_interpol 1533 1529 real(kind=8) :: fvn_d_quad_3d_interpol
1534 1530
integer(kind=4) :: ixinf,iyinf,izinf,basex,basey,basez,i,j 1535 1531 integer(kind=4) :: ixinf,iyinf,izinf,basex,basey,basez,i,j
!real(kind=8), external :: fvn_d_quad_interpol,fvn_d_quad_2d_interpol 1536 1532 !real(kind=8), external :: fvn_d_quad_interpol,fvn_d_quad_2d_interpol
real(kind=8),dimension(3,3) :: ttmp 1537 1533 real(kind=8),dimension(3,3) :: ttmp
1538 1534
call fvn_d_find_interval(x,ixinf,xdata,nx) 1539 1535 call fvn_d_find_interval(x,ixinf,xdata,nx)
call fvn_d_find_interval(y,iyinf,ydata,ny) 1540 1536 call fvn_d_find_interval(y,iyinf,ydata,ny)
call fvn_d_find_interval(z,izinf,zdata,nz) 1541 1537 call fvn_d_find_interval(z,izinf,zdata,nz)
1542 1538
! Settings for extrapolation 1543 1539 ! Settings for extrapolation
if (ixinf==0) then 1544 1540 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 1545 1541 ! TODO -> Lower x bound extrapolation warning
ixinf=1 1546 1542 ixinf=1
end if 1547 1543 end if
1548 1544
if (ixinf==nx) then 1549 1545 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 1550 1546 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 1551 1547 ixinf=nx-1
end if 1552 1548 end if
1553 1549
if (iyinf==0) then 1554 1550 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 1555 1551 ! TODO -> Lower y bound extrapolation warning
iyinf=1 1556 1552 iyinf=1
end if 1557 1553 end if
1558 1554
if (iyinf==ny) then 1559 1555 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 1560 1556 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 1561 1557 iyinf=ny-1
end if 1562 1558 end if
1563 1559
if (izinf==0) then 1564 1560 if (izinf==0) then
! TODO -> Lower z bound extrapolation warning 1565 1561 ! TODO -> Lower z bound extrapolation warning
izinf=1 1566 1562 izinf=1
end if 1567 1563 end if
1568 1564
if (izinf==nz) then 1569 1565 if (izinf==nz) then
! TODO -> Higher z bound extrapolation warning 1570 1566 ! TODO -> Higher z bound extrapolation warning
izinf=nz-1 1571 1567 izinf=nz-1
end if 1572 1568 end if
1573 1569
! The three points we will use are iinf-1,iinf and iinf+1 with the 1574 1570 ! The three points we will use are iinf-1,iinf and iinf+1 with the
! exception of the first interval, where iinf=1 we will use 1,2 and 3 1575 1571 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 1576 1572 if (ixinf==1) then
basex=0 1577 1573 basex=0
else 1578 1574 else
basex=ixinf-2 1579 1575 basex=ixinf-2
end if 1580 1576 end if
1581 1577
if (iyinf==1) then 1582 1578 if (iyinf==1) then
basey=0 1583 1579 basey=0
else 1584 1580 else
basey=iyinf-2 1585 1581 basey=iyinf-2
end if 1586 1582 end if
1587 1583
if (izinf==1) then 1588 1584 if (izinf==1) then
basez=0 1589 1585 basez=0
else 1590 1586 else
basez=izinf-2 1591 1587 basez=izinf-2
end if 1592 1588 end if
1593 1589
! We first make 9 one dimensional interpolation on variable x. 1594 1590 ! We first make 9 one dimensional interpolation on variable x.
! results are stored in ttmp 1595 1591 ! results are stored in ttmp
do i=1,3 1596 1592 do i=1,3
do j=1,3 1597 1593 do j=1,3
ttmp(i,j)=fvn_d_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j)) 1598 1594 ttmp(i,j)=fvn_d_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j))
end do 1599 1595 end do
end do 1600 1596 end do
1601 1597
! We then make a 2 dimensionnal interpolation on variables y and z 1602 1598 ! We then make a 2 dimensionnal interpolation on variables y and z
fvn_d_quad_3d_interpol=fvn_d_quad_2d_interpol(y,z, & 1603 1599 fvn_d_quad_3d_interpol=fvn_d_quad_2d_interpol(y,z, &
3,ydata(basey+1:basey+3),3,zdata(basez+1:basez+3),ttmp) 1604 1600 3,ydata(basey+1:basey+3),3,zdata(basez+1:basez+3),ttmp)
end function 1605 1601 end function
1606 1602
1607 1603
1608 1604
1609 1605
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1610 1606 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1611 1607 !
! Akima spline interpolation and spline evaluation 1612 1608 ! Akima spline interpolation and spline evaluation
! 1613 1609 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1614 1610 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1615 1611
! Single precision 1616 1612 ! Single precision
subroutine fvn_s_akima(n,x,y,br,co) 1617 1613 subroutine fvn_s_akima(n,x,y,br,co)
implicit none 1618 1614 implicit none
integer, intent(in) :: n 1619 1615 integer, intent(in) :: n
real, intent(in) :: x(n) 1620 1616 real, intent(in) :: x(n)
real, intent(in) :: y(n) 1621 1617 real, intent(in) :: y(n)
real, intent(out) :: br(n) 1622 1618 real, intent(out) :: br(n)
real, intent(out) :: co(4,n) 1623 1619 real, intent(out) :: co(4,n)
1624 1620
real, allocatable :: var(:),z(:) 1625 1621 real, allocatable :: var(:),z(:)
real :: wi_1,wi 1626 1622 real :: wi_1,wi
integer :: i 1627 1623 integer :: i
real :: dx,a,b 1628 1624 real :: dx,a,b
1629 1625
! br is just a copy of x 1630 1626 ! br is just a copy of x
br(:)=x(:) 1631 1627 br(:)=x(:)
1632 1628
allocate(var(n)) 1633 1629 allocate(var(n))
allocate(z(n)) 1634 1630 allocate(z(n))
! evaluate the variations 1635 1631 ! evaluate the variations
do i=1, n-1 1636 1632 do i=1, n-1
var(i+2)=(y(i+1)-y(i))/(x(i+1)-x(i)) 1637 1633 var(i+2)=(y(i+1)-y(i))/(x(i+1)-x(i))
end do 1638 1634 end do
var(n+2)=2.e0*var(n+1)-var(n) 1639 1635 var(n+2)=2.e0*var(n+1)-var(n)
var(n+3)=2.e0*var(n+2)-var(n+1) 1640 1636 var(n+3)=2.e0*var(n+2)-var(n+1)
var(2)=2.e0*var(3)-var(4) 1641 1637 var(2)=2.e0*var(3)-var(4)
var(1)=2.e0*var(2)-var(3) 1642 1638 var(1)=2.e0*var(2)-var(3)
1643 1639
do i = 1, n 1644 1640 do i = 1, n
wi_1=abs(var(i+3)-var(i+2)) 1645 1641 wi_1=abs(var(i+3)-var(i+2))
wi=abs(var(i+1)-var(i)) 1646 1642 wi=abs(var(i+1)-var(i))
if ((wi_1+wi).eq.0.e0) then 1647 1643 if ((wi_1+wi).eq.0.e0) then
z(i)=(var(i+2)+var(i+1))/2.e0 1648 1644 z(i)=(var(i+2)+var(i+1))/2.e0
else 1649 1645 else
z(i)=(wi_1*var(i+1)+wi*var(i+2))/(wi_1+wi) 1650 1646 z(i)=(wi_1*var(i+1)+wi*var(i+2))/(wi_1+wi)
end if 1651 1647 end if
end do 1652 1648 end do
1653 1649
do i=1, n-1 1654 1650 do i=1, n-1
dx=x(i+1)-x(i) 1655 1651 dx=x(i+1)-x(i)
a=(z(i+1)-z(i))*dx ! coeff intermediaires pour calcul wd 1656 1652 a=(z(i+1)-z(i))*dx ! coeff intermediaires pour calcul wd
b=y(i+1)-y(i)-z(i)*dx ! coeff intermediaires pour calcul wd 1657 1653 b=y(i+1)-y(i)-z(i)*dx ! coeff intermediaires pour calcul wd
co(1,i)=y(i) 1658 1654 co(1,i)=y(i)
co(2,i)=z(i) 1659 1655 co(2,i)=z(i)
!co(3,i)=-(a-3.*b)/dx**2 ! mรฉthode wd 1660 1656 !co(3,i)=-(a-3.*b)/dx**2 ! mรฉthode wd
!co(4,i)=(a-2.*b)/dx**3 ! mรฉthode wd 1661 1657 !co(4,i)=(a-2.*b)/dx**3 ! mรฉthode wd
co(3,i)=(3.e0*var(i+2)-2.e0*z(i)-z(i+1))/dx ! mรฉthode JP Moreau 1662 1658 co(3,i)=(3.e0*var(i+2)-2.e0*z(i)-z(i+1))/dx ! mรฉthode JP Moreau
co(4,i)=(z(i)+z(i+1)-2.e0*var(i+2))/dx**2 ! 1663 1659 co(4,i)=(z(i)+z(i+1)-2.e0*var(i+2))/dx**2 !
! les coefficients donnรฉs par imsl sont co(3,i)*2 et co(4,i)*6 1664 1660 ! les coefficients donnรฉs par imsl sont co(3,i)*2 et co(4,i)*6
! etrangement la fonction csval corrige et donne la bonne valeur ... 1665 1661 ! etrangement la fonction csval corrige et donne la bonne valeur ...
end do 1666 1662 end do
co(1,n)=y(n) 1667 1663 co(1,n)=y(n)
co(2,n)=z(n) 1668 1664 co(2,n)=z(n)
co(3,n)=0.e0 1669 1665 co(3,n)=0.e0
co(4,n)=0.e0 1670 1666 co(4,n)=0.e0
1671 1667
deallocate(z) 1672 1668 deallocate(z)
deallocate(var) 1673 1669 deallocate(var)
1674 1670
end subroutine 1675 1671 end subroutine
1676 1672
! Double precision 1677 1673 ! Double precision
subroutine fvn_d_akima(n,x,y,br,co) 1678 1674 subroutine fvn_d_akima(n,x,y,br,co)
1679 1675
implicit none 1680 1676 implicit none
integer, intent(in) :: n 1681 1677 integer, intent(in) :: n
double precision, intent(in) :: x(n) 1682 1678 double precision, intent(in) :: x(n)
double precision, intent(in) :: y(n) 1683 1679 double precision, intent(in) :: y(n)
double precision, intent(out) :: br(n) 1684 1680 double precision, intent(out) :: br(n)
double precision, intent(out) :: co(4,n) 1685 1681 double precision, intent(out) :: co(4,n)
1686 1682
double precision, allocatable :: var(:),z(:) 1687 1683 double precision, allocatable :: var(:),z(:)
double precision :: wi_1,wi 1688 1684 double precision :: wi_1,wi
integer :: i 1689 1685 integer :: i
double precision :: dx,a,b 1690 1686 double precision :: dx,a,b
1691 1687
! br is just a copy of x 1692 1688 ! br is just a copy of x
br(:)=x(:) 1693 1689 br(:)=x(:)
1694 1690
allocate(var(n)) 1695 1691 allocate(var(n))
allocate(z(n)) 1696 1692 allocate(z(n))
! evaluate the variations 1697 1693 ! evaluate the variations
do i=1, n-1 1698 1694 do i=1, n-1
var(i+2)=(y(i+1)-y(i))/(x(i+1)-x(i)) 1699 1695 var(i+2)=(y(i+1)-y(i))/(x(i+1)-x(i))
end do 1700 1696 end do
var(n+2)=2.d0*var(n+1)-var(n) 1701 1697 var(n+2)=2.d0*var(n+1)-var(n)
var(n+3)=2.d0*var(n+2)-var(n+1) 1702 1698 var(n+3)=2.d0*var(n+2)-var(n+1)
var(2)=2.d0*var(3)-var(4) 1703 1699 var(2)=2.d0*var(3)-var(4)
var(1)=2.d0*var(2)-var(3) 1704 1700 var(1)=2.d0*var(2)-var(3)
1705 1701
do i = 1, n 1706 1702 do i = 1, n
wi_1=dabs(var(i+3)-var(i+2)) 1707 1703 wi_1=dabs(var(i+3)-var(i+2))
wi=dabs(var(i+1)-var(i)) 1708 1704 wi=dabs(var(i+1)-var(i))
if ((wi_1+wi).eq.0.d0) then 1709 1705 if ((wi_1+wi).eq.0.d0) then
z(i)=(var(i+2)+var(i+1))/2.d0 1710 1706 z(i)=(var(i+2)+var(i+1))/2.d0
else 1711 1707 else
z(i)=(wi_1*var(i+1)+wi*var(i+2))/(wi_1+wi) 1712 1708 z(i)=(wi_1*var(i+1)+wi*var(i+2))/(wi_1+wi)
end if 1713 1709 end if
end do 1714 1710 end do
1715 1711
do i=1, n-1 1716 1712 do i=1, n-1
dx=x(i+1)-x(i) 1717 1713 dx=x(i+1)-x(i)
a=(z(i+1)-z(i))*dx ! coeff intermediaires pour calcul wd 1718 1714 a=(z(i+1)-z(i))*dx ! coeff intermediaires pour calcul wd
b=y(i+1)-y(i)-z(i)*dx ! coeff intermediaires pour calcul wd 1719 1715 b=y(i+1)-y(i)-z(i)*dx ! coeff intermediaires pour calcul wd
co(1,i)=y(i) 1720 1716 co(1,i)=y(i)
co(2,i)=z(i) 1721 1717 co(2,i)=z(i)
!co(3,i)=-(a-3.*b)/dx**2 ! mรฉthode wd 1722 1718 !co(3,i)=-(a-3.*b)/dx**2 ! mรฉthode wd
!co(4,i)=(a-2.*b)/dx**3 ! mรฉthode wd 1723 1719 !co(4,i)=(a-2.*b)/dx**3 ! mรฉthode wd
co(3,i)=(3.d0*var(i+2)-2.d0*z(i)-z(i+1))/dx ! mรฉthode JP Moreau 1724 1720 co(3,i)=(3.d0*var(i+2)-2.d0*z(i)-z(i+1))/dx ! mรฉthode JP Moreau
co(4,i)=(z(i)+z(i+1)-2.d0*var(i+2))/dx**2 ! 1725 1721 co(4,i)=(z(i)+z(i+1)-2.d0*var(i+2))/dx**2 !
! les coefficients donnรฉs par imsl sont co(3,i)*2 et co(4,i)*6 1726 1722 ! les coefficients donnรฉs par imsl sont co(3,i)*2 et co(4,i)*6
! etrangement la fonction csval corrige et donne la bonne valeur ... 1727 1723 ! etrangement la fonction csval corrige et donne la bonne valeur ...
end do 1728 1724 end do
co(1,n)=y(n) 1729 1725 co(1,n)=y(n)
co(2,n)=z(n) 1730 1726 co(2,n)=z(n)
co(3,n)=0.d0 1731 1727 co(3,n)=0.d0
co(4,n)=0.d0 1732 1728 co(4,n)=0.d0
1733 1729
deallocate(z) 1734 1730 deallocate(z)
deallocate(var) 1735 1731 deallocate(var)
1736 1732
end subroutine 1737 1733 end subroutine
1738 1734
! 1739 1735 !
! Single precision spline evaluation 1740 1736 ! Single precision spline evaluation
! 1741 1737 !
function fvn_s_spline_eval(x,n,br,co) 1742 1738 function fvn_s_spline_eval(x,n,br,co)
implicit none 1743 1739 implicit none
real, intent(in) :: x ! x must be br(1)<= x <= br(n+1) otherwise value is extrapolated 1744 1740 real, intent(in) :: x ! x must be br(1)<= x <= br(n+1) otherwise value is extrapolated
integer, intent(in) :: n ! number of intervals 1745 1741 integer, intent(in) :: n ! number of intervals
real, intent(in) :: br(n+1) ! breakpoints 1746 1742 real, intent(in) :: br(n+1) ! breakpoints
real, intent(in) :: co(4,n+1) ! spline coeeficients 1747 1743 real, intent(in) :: co(4,n+1) ! spline coeeficients
real :: fvn_s_spline_eval 1748 1744 real :: fvn_s_spline_eval
1749 1745
integer :: i 1750 1746 integer :: i
real :: dx 1751 1747 real :: dx
1752 1748
if (x<=br(1)) then 1753 1749 if (x<=br(1)) then
i=1 1754 1750 i=1
else if (x>=br(n+1)) then 1755 1751 else if (x>=br(n+1)) then
i=n 1756 1752 i=n
else 1757 1753 else
i=1 1758 1754 i=1
do while(x>=br(i)) 1759 1755 do while(x>=br(i))
i=i+1 1760 1756 i=i+1
end do 1761 1757 end do
i=i-1 1762 1758 i=i-1
end if 1763 1759 end if
dx=x-br(i) 1764 1760 dx=x-br(i)
fvn_s_spline_eval=co(1,i)+co(2,i)*dx+co(3,i)*dx**2+co(4,i)*dx**3 1765 1761 fvn_s_spline_eval=co(1,i)+co(2,i)*dx+co(3,i)*dx**2+co(4,i)*dx**3
1766 1762
end function 1767 1763 end function
1768 1764
! Double precision spline evaluation 1769 1765 ! Double precision spline evaluation
function fvn_d_spline_eval(x,n,br,co) 1770 1766 function fvn_d_spline_eval(x,n,br,co)
implicit none 1771 1767 implicit none
double precision, intent(in) :: x ! x must be br(1)<= x <= br(n+1) otherwise value is extrapolated 1772 1768 double precision, intent(in) :: x ! x must be br(1)<= x <= br(n+1) otherwise value is extrapolated
integer, intent(in) :: n ! number of intervals 1773 1769 integer, intent(in) :: n ! number of intervals
double precision, intent(in) :: br(n+1) ! breakpoints 1774 1770 double precision, intent(in) :: br(n+1) ! breakpoints
double precision, intent(in) :: co(4,n+1) ! spline coeeficients 1775 1771 double precision, intent(in) :: co(4,n+1) ! spline coeeficients
double precision :: fvn_d_spline_eval 1776 1772 double precision :: fvn_d_spline_eval
1777 1773
integer :: i 1778 1774 integer :: i
double precision :: dx 1779 1775 double precision :: dx
1780 1776
1781 1777
if (x<=br(1)) then 1782 1778 if (x<=br(1)) then
i=1 1783 1779 i=1
else if (x>=br(n+1)) then 1784 1780 else if (x>=br(n+1)) then
i=n 1785 1781 i=n
else 1786 1782 else
i=1 1787 1783 i=1
do while(x>=br(i)) 1788 1784 do while(x>=br(i))
i=i+1 1789 1785 i=i+1
end do 1790 1786 end do
i=i-1 1791 1787 i=i-1
end if 1792 1788 end if
1793 1789
dx=x-br(i) 1794 1790 dx=x-br(i)
fvn_d_spline_eval=co(1,i)+co(2,i)*dx+co(3,i)*dx**2+co(4,i)*dx**3 1795 1791 fvn_d_spline_eval=co(1,i)+co(2,i)*dx+co(3,i)*dx**2+co(4,i)*dx**3
1796 1792
end function 1797 1793 end function
1798 1794
1799 1795
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1800 1796 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1801 1797 !
! Least square problem 1802 1798 ! Least square problem
! 1803 1799 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1804 1800 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1805 1801 !
! 1806 1802 !
1807 1803
1808 1804
1809 1805
1810 1806
subroutine fvn_d_lspoly(np,x,y,deg,coeff,status) 1811 1807 subroutine fvn_d_lspoly(np,x,y,deg,coeff,status)
! 1812 1808 !
! Least square polynomial fitting 1813 1809 ! Least square polynomial fitting
! 1814 1810 !
! Find the coefficients of the least square polynomial of a given degree 1815 1811 ! Find the coefficients of the least square polynomial of a given degree
! for a set of coordinates. 1816 1812 ! for a set of coordinates.
! 1817 1813 !
! The degree must be lower than the number of points 1818 1814 ! The degree must be lower than the number of points
! 1819 1815 !
! np (in) : number of points 1820 1816 ! np (in) : number of points
! x(np) (in) : x data 1821 1817 ! x(np) (in) : x data
! y(np) (in) : y data 1822 1818 ! y(np) (in) : y data
! deg (in) : polynomial's degree 1823 1819 ! deg (in) : polynomial's degree
! coeff(deg+1) (out) : polynomial coefficients 1824 1820 ! coeff(deg+1) (out) : polynomial coefficients
! status (out) : =0 if a problem occurs 1825 1821 ! status (out) : =0 if a problem occurs
! 1826 1822 !
implicit none 1827 1823 implicit none
1828 1824
integer, intent(in) :: np,deg 1829 1825 integer, intent(in) :: np,deg
real(kind=8), intent(in), dimension(np) :: x,y 1830 1826 real(kind=8), intent(in), dimension(np) :: x,y
real(kind=8), intent(out), dimension(deg+1) :: coeff 1831 1827 real(kind=8), intent(out), dimension(deg+1) :: coeff
integer, intent(out), optional :: status 1832 1828 integer, intent(out), optional :: status
1833 1829
real(kind=8), allocatable, dimension(:,:) :: mat,bmat 1834 1830 real(kind=8), allocatable, dimension(:,:) :: mat,bmat
real(kind=8),dimension(:),allocatable :: work 1835 1831 real(kind=8),dimension(:),allocatable :: work
real(kind=8),dimension(1) :: twork 1836 1832 real(kind=8),dimension(1) :: twork
integer :: lwork,info 1837 1833 integer :: lwork,info
1838 1834
integer :: i,j 1839 1835 integer :: i,j
1840 1836
if (present(status)) status=1 1841 1837 if (present(status)) status=1
allocate(mat(np,deg+1),bmat(np,1)) 1842 1838 allocate(mat(np,deg+1),bmat(np,1))
1843 1839
! Design matrix valorisation 1844 1840 ! Design matrix valorisation
mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) ) 1845 1841 mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
1846 1842
! second member valorisation 1847 1843 ! second member valorisation
bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /)) 1848 1844 bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
1849 1845
! query workspace size 1850 1846 ! query workspace size
call dgels('N',np,deg+1,1,mat,np,bmat,np,twork,-1,info) 1851 1847 call dgels('N',np,deg+1,1,mat,np,bmat,np,twork,-1,info)
lwork=twork(1) 1852 1848 lwork=twork(1)
allocate(work(int(lwork))) 1853 1849 allocate(work(int(lwork)))
! real call 1854 1850 ! real call
call dgels('N',np,deg+1,1,mat,np,bmat,np,work,lwork,info) 1855 1851 call dgels('N',np,deg+1,1,mat,np,bmat,np,work,lwork,info)
1856 1852
if (info /= 0) then 1857 1853 if (info /= 0) then
if (present(status)) status=0 1858 1854 if (present(status)) status=0
end if 1859 1855 end if
1860 1856
coeff = (/ (bmat(i,1),i=1,deg+1) /) 1861 1857 coeff = (/ (bmat(i,1),i=1,deg+1) /)
1862 1858
deallocate(work) 1863 1859 deallocate(work)
deallocate(mat,bmat) 1864 1860 deallocate(mat,bmat)
end subroutine 1865 1861 end subroutine
1866 1862
subroutine fvn_s_lspoly(np,x,y,deg,coeff,status) 1867 1863 subroutine fvn_s_lspoly(np,x,y,deg,coeff,status)
! 1868 1864 !
! Least square polynomial fitting 1869 1865 ! Least square polynomial fitting
! 1870 1866 !
! Find the coefficients of the least square polynomial of a given degree 1871 1867 ! Find the coefficients of the least square polynomial of a given degree
! for a set of coordinates. 1872 1868 ! for a set of coordinates.
! 1873 1869 !
! The degree must be lower than the number of points 1874 1870 ! The degree must be lower than the number of points
! 1875 1871 !
! np (in) : number of points 1876 1872 ! np (in) : number of points
! x(np) (in) : x data 1877 1873 ! x(np) (in) : x data
! y(np) (in) : y data 1878 1874 ! y(np) (in) : y data
! deg (in) : polynomial's degree 1879 1875 ! deg (in) : polynomial's degree
! coeff(deg+1) (out) : polynomial coefficients 1880 1876 ! coeff(deg+1) (out) : polynomial coefficients
! status (out) : =0 if a problem occurs 1881 1877 ! status (out) : =0 if a problem occurs
! 1882 1878 !
implicit none 1883 1879 implicit none
1884 1880
integer, intent(in) :: np,deg 1885 1881 integer, intent(in) :: np,deg
real(kind=4), intent(in), dimension(np) :: x,y 1886 1882 real(kind=4), intent(in), dimension(np) :: x,y
real(kind=4), intent(out), dimension(deg+1) :: coeff 1887 1883 real(kind=4), intent(out), dimension(deg+1) :: coeff
integer, intent(out), optional :: status 1888 1884 integer, intent(out), optional :: status
1889 1885
real(kind=4), allocatable, dimension(:,:) :: mat,bmat 1890 1886 real(kind=4), allocatable, dimension(:,:) :: mat,bmat
real(kind=4),dimension(:),allocatable :: work 1891 1887 real(kind=4),dimension(:),allocatable :: work
real(kind=4),dimension(1) :: twork 1892 1888 real(kind=4),dimension(1) :: twork
integer :: lwork,info 1893 1889 integer :: lwork,info
1894 1890
integer :: i,j 1895 1891 integer :: i,j
1896 1892
if (present(status)) status=1 1897 1893 if (present(status)) status=1
allocate(mat(np,deg+1),bmat(np,1)) 1898 1894 allocate(mat(np,deg+1),bmat(np,1))
1899 1895
! Design matrix valorisation 1900 1896 ! Design matrix valorisation
mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) ) 1901 1897 mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
1902 1898
! second member valorisation 1903 1899 ! second member valorisation
bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /)) 1904 1900 bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
1905 1901
! query workspace size 1906 1902 ! query workspace size
call sgels('N',np,deg+1,1,mat,np,bmat,np,twork,-1,info) 1907 1903 call sgels('N',np,deg+1,1,mat,np,bmat,np,twork,-1,info)
lwork=twork(1) 1908 1904 lwork=twork(1)
allocate(work(int(lwork))) 1909 1905 allocate(work(int(lwork)))
! real call 1910 1906 ! real call
call sgels('N',np,deg+1,1,mat,np,bmat,np,work,lwork,info) 1911 1907 call sgels('N',np,deg+1,1,mat,np,bmat,np,work,lwork,info)
1912 1908
if (info /= 0) then 1913 1909 if (info /= 0) then
if (present(status)) status=0 1914 1910 if (present(status)) status=0
end if 1915 1911 end if
1916 1912
coeff = (/ (bmat(i,1),i=1,deg+1) /) 1917 1913 coeff = (/ (bmat(i,1),i=1,deg+1) /)
1918 1914
deallocate(work) 1919 1915 deallocate(work)
deallocate(mat,bmat) 1920 1916 deallocate(mat,bmat)
end subroutine 1921 1917 end subroutine
1922 1918
1923 1919
1924 1920
1925 1921
1926 1922
1927 1923
1928 1924
1929 1925
subroutine fvn_d_lspoly_svd(np,x,y,deg,coeff,status) 1930 1926 subroutine fvn_d_lspoly_svd(np,x,y,deg,coeff,status)
! 1931 1927 !
! Least square polynomial fitting using singular value decomposition 1932 1928 ! Least square polynomial fitting using singular value decomposition
! 1933 1929 !
! Find the coefficients of the least square polynomial of a given degree 1934 1930 ! Find the coefficients of the least square polynomial of a given degree
! for a set of coordinates. 1935 1931 ! for a set of coordinates.
! 1936 1932 !
! The degree must be lower than the number of points 1937 1933 ! The degree must be lower than the number of points
! 1938 1934 !
! np (in) : number of points 1939 1935 ! np (in) : number of points
! x(np) (in) : x data 1940 1936 ! x(np) (in) : x data
! y(np) (in) : y data 1941 1937 ! y(np) (in) : y data
! deg (in) : polynomial's degree 1942 1938 ! deg (in) : polynomial's degree
! coeff(deg+1) (out) : polynomial coefficients 1943 1939 ! coeff(deg+1) (out) : polynomial coefficients
! status (out) : =0 if a problem occurs 1944 1940 ! status (out) : =0 if a problem occurs
! 1945 1941 !
implicit none 1946 1942 implicit none
1947 1943
integer, intent(in) :: np,deg 1948 1944 integer, intent(in) :: np,deg
real(kind=8), intent(in), dimension(np) :: x,y 1949 1945 real(kind=8), intent(in), dimension(np) :: x,y
real(kind=8), intent(out), dimension(deg+1) :: coeff 1950 1946 real(kind=8), intent(out), dimension(deg+1) :: coeff
integer, intent(out), optional :: status 1951 1947 integer, intent(out), optional :: status
1952 1948
real(kind=8), allocatable, dimension(:,:) :: mat,bmat 1953 1949 real(kind=8), allocatable, dimension(:,:) :: mat,bmat
real(kind=8),dimension(:),allocatable :: work,singval 1954 1950 real(kind=8),dimension(:),allocatable :: work,singval
real(kind=8),dimension(1) :: twork 1955 1951 real(kind=8),dimension(1) :: twork
integer :: lwork,info,rank 1956 1952 integer :: lwork,info,rank
1957 1953
integer :: i,j 1958 1954 integer :: i,j
1959 1955
if (present(status)) status=1 1960 1956 if (present(status)) status=1
allocate(mat(np,deg+1),bmat(np,1),singval(deg+1)) 1961 1957 allocate(mat(np,deg+1),bmat(np,1),singval(deg+1))
1962 1958
! Design matrix valorisation 1963 1959 ! Design matrix valorisation
mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) ) 1964 1960 mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
1965 1961
! second member valorisation 1966 1962 ! second member valorisation
bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /)) 1967 1963 bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
1968 1964
! query workspace size 1969 1965 ! query workspace size
call dgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,twork,-1,info) 1970 1966 call dgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,twork,-1,info)
lwork=twork(1) 1971 1967 lwork=twork(1)
allocate(work(int(lwork))) 1972 1968 allocate(work(int(lwork)))
! real call 1973 1969 ! real call
call dgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,work,lwork,info) 1974 1970 call dgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,work,lwork,info)
1975 1971
if (info /= 0) then 1976 1972 if (info /= 0) then
if (present(status)) status=0 1977 1973 if (present(status)) status=0
end if 1978 1974 end if
1979 1975
coeff = (/ (bmat(i,1),i=1,deg+1) /) 1980 1976 coeff = (/ (bmat(i,1),i=1,deg+1) /)
1981 1977
deallocate(work) 1982 1978 deallocate(work)
deallocate(mat,bmat,singval) 1983 1979 deallocate(mat,bmat,singval)
end subroutine 1984 1980 end subroutine
1985 1981
subroutine fvn_s_lspoly_svd(np,x,y,deg,coeff,status) 1986 1982 subroutine fvn_s_lspoly_svd(np,x,y,deg,coeff,status)
! 1987 1983 !
! Least square polynomial fitting using singular value decomposition 1988 1984 ! Least square polynomial fitting using singular value decomposition
! 1989 1985 !
! Find the coefficients of the least square polynomial of a given degree 1990 1986 ! Find the coefficients of the least square polynomial of a given degree
! for a set of coordinates. 1991 1987 ! for a set of coordinates.
! 1992 1988 !
! The degree must be lower than the number of points 1993 1989 ! The degree must be lower than the number of points
! 1994 1990 !
! np (in) : number of points 1995 1991 ! np (in) : number of points
! x(np) (in) : x data 1996 1992 ! x(np) (in) : x data
! y(np) (in) : y data 1997 1993 ! y(np) (in) : y data
! deg (in) : polynomial's degree 1998 1994 ! deg (in) : polynomial's degree
! coeff(deg+1) (out) : polynomial coefficients 1999 1995 ! coeff(deg+1) (out) : polynomial coefficients
! status (out) : =0 if a problem occurs 2000 1996 ! status (out) : =0 if a problem occurs
! 2001 1997 !
implicit none 2002 1998 implicit none
2003 1999
integer, intent(in) :: np,deg 2004 2000 integer, intent(in) :: np,deg
real(kind=4), intent(in), dimension(np) :: x,y 2005 2001 real(kind=4), intent(in), dimension(np) :: x,y
real(kind=4), intent(out), dimension(deg+1) :: coeff 2006 2002 real(kind=4), intent(out), dimension(deg+1) :: coeff
integer, intent(out), optional :: status 2007 2003 integer, intent(out), optional :: status
2008 2004
real(kind=4), allocatable, dimension(:,:) :: mat,bmat 2009 2005 real(kind=4), allocatable, dimension(:,:) :: mat,bmat
real(kind=4),dimension(:),allocatable :: work,singval 2010 2006 real(kind=4),dimension(:),allocatable :: work,singval
real(kind=4),dimension(1) :: twork 2011 2007 real(kind=4),dimension(1) :: twork
integer :: lwork,info,rank 2012 2008 integer :: lwork,info,rank
2013 2009
integer :: i,j 2014 2010 integer :: i,j
2015 2011
if (present(status)) status=1 2016 2012 if (present(status)) status=1
allocate(mat(np,deg+1),bmat(np,1),singval(deg+1)) 2017 2013 allocate(mat(np,deg+1),bmat(np,1),singval(deg+1))
2018 2014
! Design matrix valorisation 2019 2015 ! Design matrix valorisation
mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) ) 2020 2016 mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
2021 2017
! second member valorisation 2022 2018 ! second member valorisation
bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /)) 2023 2019 bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
2024 2020
! query workspace size 2025 2021 ! query workspace size
call sgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,twork,-1,info) 2026 2022 call sgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,twork,-1,info)
lwork=twork(1) 2027 2023 lwork=twork(1)
allocate(work(int(lwork))) 2028 2024 allocate(work(int(lwork)))
! real call 2029 2025 ! real call
call sgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,work,lwork,info) 2030 2026 call sgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,work,lwork,info)
2031 2027
if (info /= 0) then 2032 2028 if (info /= 0) then
if (present(status)) status=0 2033 2029 if (present(status)) status=0
end if 2034 2030 end if
2035 2031
coeff = (/ (bmat(i,1),i=1,deg+1) /) 2036 2032 coeff = (/ (bmat(i,1),i=1,deg+1) /)
2037 2033
deallocate(work) 2038 2034 deallocate(work)
deallocate(mat,bmat,singval) 2039 2035 deallocate(mat,bmat,singval)
end subroutine 2040 2036 end subroutine
2041 2037
2042 2038
! 2043 2039 !
! Muller 2044 2040 ! Muller
! 2045 2041 !
! 2046 2042 !
! 2047 2043 !
! William Daniau 2007 2048 2044 ! William Daniau 2007
! 2049 2045 !
! This routine is a fortran 90 port of Hans D. Mittelmann's routine muller.f 2050 2046 ! This routine is a fortran 90 port of Hans D. Mittelmann's routine muller.f
! http://plato.asu.edu/ftp/other_software/muller.f 2051 2047 ! http://plato.asu.edu/ftp/other_software/muller.f
! 2052 2048 !
! it can be used as a replacement for imsl routine dzanly with minor changes 2053 2049 ! it can be used as a replacement for imsl routine dzanly with minor changes
! 2054 2050 !
!----------------------------------------------------------------------- 2055 2051 !-----------------------------------------------------------------------
! 2056 2052 !
! purpose - zeros of an analytic complex function 2057 2053 ! purpose - zeros of an analytic complex function
! using the muller method with deflation 2058 2054 ! using the muller method with deflation
! 2059 2055 !
! usage - call fvn_z_muller (f,eps,eps1,kn,n,nguess,x,itmax, 2060 2056 ! usage - call fvn_z_muller (f,eps,eps1,kn,n,nguess,x,itmax,
! infer,ier) 2061 2057 ! infer,ier)
! 2062 2058 !
! arguments f - a complex function subprogram, f(z), written 2063 2059 ! arguments f - a complex function subprogram, f(z), written
! by the user specifying the equation whose 2064 2060 ! by the user specifying the equation whose
! roots are to be found. f must appear in 2065 2061 ! roots are to be found. f must appear in
! an external statement in the calling pro- 2066 2062 ! an external statement in the calling pro-
! gram. 2067 2063 ! gram.
! eps - 1st stopping criterion. let fp(z)=f(z)/p 2068 2064 ! eps - 1st stopping criterion. let fp(z)=f(z)/p
! where p = (z-z(1))*(z-z(2))*,,,*(z-z(k-1)) 2069 2065 ! where p = (z-z(1))*(z-z(2))*,,,*(z-z(k-1))
! and z(1),...,z(k-1) are previously found 2070 2066 ! and z(1),...,z(k-1) are previously found
! roots. if ((cdabs(f(z)).le.eps) .and. 2071 2067 ! roots. if ((cdabs(f(z)).le.eps) .and.
! (cdabs(fp(z)).le.eps)), then z is accepted 2072 2068 ! (cdabs(fp(z)).le.eps)), then z is accepted
! as a root. (input) 2073 2069 ! as a root. (input)
! eps1 - 2nd stopping criterion. a root is accepted 2074 2070 ! eps1 - 2nd stopping criterion. a root is accepted
! if two successive approximations to a given 2075 2071 ! if two successive approximations to a given
! root agree within eps1. (input) 2076 2072 ! root agree within eps1. (input)
! note. if either or both of the stopping 2077 2073 ! note. if either or both of the stopping
! criteria are fulfilled, the root is 2078 2074 ! criteria are fulfilled, the root is
! accepted. 2079 2075 ! accepted.
! kn - the number of known roots which must be stored 2080 2076 ! kn - the number of known roots which must be stored
! in x(1),...,x(kn), prior to entry to muller 2081 2077 ! in x(1),...,x(kn), prior to entry to muller
! nguess - the number of initial guesses provided. these 2082 2078 ! nguess - the number of initial guesses provided. these
! guesses must be stored in x(kn+1),..., 2083 2079 ! guesses must be stored in x(kn+1),...,
! x(kn+nguess). nguess must be set equal 2084 2080 ! x(kn+nguess). nguess must be set equal
! to zero if no guesses are provided. (input) 2085 2081 ! to zero if no guesses are provided. (input)
! n - the number of new roots to be found by 2086 2082 ! n - the number of new roots to be found by
! muller (input) 2087 2083 ! muller (input)
! x - a complex vector of length kn+n. x(1),..., 2088 2084 ! x - a complex vector of length kn+n. x(1),...,
! x(kn) on input must contain any known 2089 2085 ! x(kn) on input must contain any known
! roots. x(kn+1),..., x(kn+n) on input may, 2090 2086 ! roots. x(kn+1),..., x(kn+n) on input may,
! on user option, contain initial guesses for 2091 2087 ! on user option, contain initial guesses for
! the n new roots which are to be computed. 2092 2088 ! the n new roots which are to be computed.
! if the user does not provide an initial 2093 2089 ! if the user does not provide an initial
! guess, zero is used. 2094 2090 ! guess, zero is used.
! on output, x(kn+1),...,x(kn+n) contain the 2095 2091 ! on output, x(kn+1),...,x(kn+n) contain the
! approximate roots found by muller. 2096 2092 ! approximate roots found by muller.
! itmax - the maximum allowable number of iterations 2097 2093 ! itmax - the maximum allowable number of iterations
! per root (input) 2098 2094 ! per root (input)
! infer - an integer vector of length kn+n. on 2099 2095 ! infer - an integer vector of length kn+n. on
! output infer(j) contains the number of 2100 2096 ! output infer(j) contains the number of
! iterations used in finding the j-th root 2101 2097 ! iterations used in finding the j-th root
! when convergence was achieved. if 2102 2098 ! when convergence was achieved. if
! convergence was not obtained in itmax 2103 2099 ! convergence was not obtained in itmax
! iterations, infer(j) will be greater than 2104 2100 ! iterations, infer(j) will be greater than
! itmax (output). 2105 2101 ! itmax (output).
! ier - error parameter (output) 2106 2102 ! ier - error parameter (output)
! warning error 2107 2103 ! warning error
! ier = 33 indicates failure to converge with- 2108 2104 ! ier = 33 indicates failure to converge with-
! in itmax iterations for at least one of 2109 2105 ! in itmax iterations for at least one of
! the (n) new roots. 2110 2106 ! the (n) new roots.
! 2111 2107 !
! 2112 2108 !
! remarks muller always returns the last approximation for root j 2113 2109 ! remarks muller always returns the last approximation for root j
! in x(j). if the convergence criterion is satisfied, 2114 2110 ! in x(j). if the convergence criterion is satisfied,
! then infer(j) is less than or equal to itmax. if the 2115 2111 ! then infer(j) is less than or equal to itmax. if the
! convergence criterion is not satisified, then infer(j) 2116 2112 ! convergence criterion is not satisified, then infer(j)
! is set to either itmax+1 or itmax+k, with k greater 2117 2113 ! is set to either itmax+1 or itmax+k, with k greater
! than 1. infer(j) = itmax+1 indicates that muller did 2118 2114 ! than 1. infer(j) = itmax+1 indicates that muller did
! not obtain convergence in the allowed number of iter- 2119 2115 ! not obtain convergence in the allowed number of iter-
! ations. in this case, the user may wish to set itmax 2120 2116 ! ations. in this case, the user may wish to set itmax
! to a larger value. infer(j) = itmax+k means that con- 2121 2117 ! to a larger value. infer(j) = itmax+k means that con-
! vergence was obtained (on iteration k) for the defla- 2122 2118 ! vergence was obtained (on iteration k) for the defla-
! ted function 2123 2119 ! ted function
! fp(z) = f(z)/((z-z(1)...(z-z(j-1))) 2124 2120 ! fp(z) = f(z)/((z-z(1)...(z-z(j-1)))
! 2125 2121 !
! but failed for f(z). in this case, better initial 2126 2122 ! but failed for f(z). in this case, better initial
! guesses might help or, it might be necessary to relax 2127 2123 ! guesses might help or, it might be necessary to relax
! the convergence criterion. 2128 2124 ! the convergence criterion.
! 2129 2125 !
!----------------------------------------------------------------------- 2130 2126 !-----------------------------------------------------------------------
! 2131 2127 !
subroutine fvn_z_muller (f,eps,eps1,kn,nguess,n,x,itmax,infer,ier) 2132 2128 subroutine fvn_z_muller (f,eps,eps1,kn,nguess,n,x,itmax,infer,ier)
implicit none 2133 2129 implicit none
double precision :: rzero,rten,rhun,rp01,ax,eps1,qz,eps,tpq 2134 2130 double precision :: rzero,rten,rhun,rp01,ax,eps1,qz,eps,tpq
double complex :: d,dd,den,fprt,frt,h,rt,t1,t2,t3, & 2135 2131 double complex :: d,dd,den,fprt,frt,h,rt,t1,t2,t3, &
tem,z0,z1,z2,bi,xx,xl,y0,y1,y2,x0, & 2136 2132 tem,z0,z1,z2,bi,xx,xl,y0,y1,y2,x0, &
zero,p1,one,four,p5 2137 2133 zero,p1,one,four,p5
2138 2134
double complex, external :: f 2139 2135 double complex, external :: f
integer :: ickmax,kn,nguess,n,itmax,ier,knp1,knpn,i,l,ic, & 2140 2136 integer :: ickmax,kn,nguess,n,itmax,ier,knp1,knpn,i,l,ic, &
knpng,jk,ick,nn,lm1,errcode 2141 2137 knpng,jk,ick,nn,lm1,errcode
double complex :: x(kn+n) 2142 2138 double complex :: x(kn+n)
integer :: infer(kn+n) 2143 2139 integer :: infer(kn+n)
2144 2140
2145 2141
data zero/(0.0,0.0)/,p1/(0.1,0.0)/, & 2146 2142 data zero/(0.0,0.0)/,p1/(0.1,0.0)/, &
one/(1.0,0.0)/,four/(4.0,0.0)/, & 2147 2143 one/(1.0,0.0)/,four/(4.0,0.0)/, &
p5/(0.5,0.0)/, & 2148 2144 p5/(0.5,0.0)/, &
rzero/0.0/,rten/10.0/,rhun/100.0/, & 2149 2145 rzero/0.0/,rten/10.0/,rhun/100.0/, &
ax/0.1/,ickmax/3/,rp01/0.01/ 2150 2146 ax/0.1/,ickmax/3/,rp01/0.01/
2151 2147
ier = 0 2152 2148 ier = 0
if (n .lt. 1) then ! What the hell are doing here then ... 2153 2149 if (n .lt. 1) then ! What the hell are doing here then ...
return 2154 2150 return
end if 2155 2151 end if
!eps1 = rten **(-nsig) 2156 2152 !eps1 = rten **(-nsig)
eps1 = min(eps1,rp01) 2157 2153 eps1 = min(eps1,rp01)
2158 2154
knp1 = kn+1 2159 2155 knp1 = kn+1
knpn = kn+n 2160 2156 knpn = kn+n
knpng = kn+nguess 2161 2157 knpng = kn+nguess
do i=1,knpn 2162 2158 do i=1,knpn
infer(i) = 0 2163 2159 infer(i) = 0
if (i .gt. knpng) x(i) = zero 2164 2160 if (i .gt. knpng) x(i) = zero
end do 2165 2161 end do
l= knp1 2166 2162 l= knp1
2167 2163
ic=0 2168 2164 ic=0
rloop: do while (l<=knpn) ! Main loop over new roots 2169 2165 rloop: do while (l<=knpn) ! Main loop over new roots
jk = 0 2170 2166 jk = 0
ick = 0 2171 2167 ick = 0
xl = x(l) 2172 2168 xl = x(l)
icloop: do 2173 2169 icloop: do
ic = 0 2174 2170 ic = 0
h = ax 2175 2171 h = ax
h = p1*h 2176 2172 h = p1*h
if (cdabs(xl) .gt. ax) h = p1*xl 2177 2173 if (cdabs(xl) .gt. ax) h = p1*xl
! first three points are 2178 2174 ! first three points are
! xl+h, xl-h, xl 2179 2175 ! xl+h, xl-h, xl
rt = xl+h 2180 2176 rt = xl+h
call deflated_work(errcode) 2181 2177 call deflated_work(errcode)
if (errcode == 1) then 2182 2178 if (errcode == 1) then
exit icloop 2183 2179 exit icloop
end if 2184 2180 end if
2185 2181
z0 = fprt 2186 2182 z0 = fprt
y0 = frt 2187 2183 y0 = frt
x0 = rt 2188 2184 x0 = rt
rt = xl-h 2189 2185 rt = xl-h
call deflated_work(errcode) 2190 2186 call deflated_work(errcode)
if (errcode == 1) then 2191 2187 if (errcode == 1) then
exit icloop 2192 2188 exit icloop
end if 2193 2189 end if
2194 2190
z1 = fprt 2195 2191 z1 = fprt
y1 = frt 2196 2192 y1 = frt
h = xl-rt 2197 2193 h = xl-rt
d = h/(rt-x0) 2198 2194 d = h/(rt-x0)
rt = xl 2199 2195 rt = xl
2200 2196
call deflated_work(errcode) 2201 2197 call deflated_work(errcode)
if (errcode == 1) then 2202 2198 if (errcode == 1) then
exit icloop 2203 2199 exit icloop
end if 2204 2200 end if
2205 2201
2206 2202
z2 = fprt 2207 2203 z2 = fprt
y2 = frt 2208 2204 y2 = frt
! begin main algorithm 2209 2205 ! begin main algorithm
iloop: do 2210 2206 iloop: do
dd = one + d 2211 2207 dd = one + d
t1 = z0*d*d 2212 2208 t1 = z0*d*d
t2 = z1*dd*dd 2213 2209 t2 = z1*dd*dd
xx = z2*dd 2214 2210 xx = z2*dd
t3 = z2*d 2215 2211 t3 = z2*d
bi = t1-t2+xx+t3 2216 2212 bi = t1-t2+xx+t3
den = bi*bi-four*(xx*t1-t3*(t2-xx)) 2217 2213 den = bi*bi-four*(xx*t1-t3*(t2-xx))
! use denominator of maximum amplitude 2218 2214 ! use denominator of maximum amplitude
t1 = cdsqrt(den) 2219 2215 t1 = cdsqrt(den)
qz = rhun*max(cdabs(bi),cdabs(t1)) 2220 2216 qz = rhun*max(cdabs(bi),cdabs(t1))
t2 = bi + t1 2221 2217 t2 = bi + t1
tpq = cdabs(t2)+qz 2222 2218 tpq = cdabs(t2)+qz
if (tpq .eq. qz) t2 = zero 2223 2219 if (tpq .eq. qz) t2 = zero
t3 = bi - t1 2224 2220 t3 = bi - t1
tpq = cdabs(t3) + qz 2225 2221 tpq = cdabs(t3) + qz
if (tpq .eq. qz) t3 = zero 2226 2222 if (tpq .eq. qz) t3 = zero
den = t2 2227 2223 den = t2
qz = cdabs(t3)-cdabs(t2) 2228 2224 qz = cdabs(t3)-cdabs(t2)
if (qz .gt. rzero) den = t3 2229 2225 if (qz .gt. rzero) den = t3
! test for zero denominator 2230 2226 ! test for zero denominator
if (cdabs(den) .eq. rzero) then 2231 2227 if (cdabs(den) .eq. rzero) then
call trans_rt() 2232 2228 call trans_rt()
call deflated_work(errcode) 2233 2229 call deflated_work(errcode)
if (errcode == 1) then 2234 2230 if (errcode == 1) then
exit icloop 2235 2231 exit icloop
end if 2236 2232 end if
z2 = fprt 2237 2233 z2 = fprt
y2 = frt 2238 2234 y2 = frt
cycle iloop 2239 2235 cycle iloop
end if 2240 2236 end if
2241 2237
2242 2238
d = -xx/den 2243 2239 d = -xx/den
d = d+d 2244 2240 d = d+d
h = d*h 2245 2241 h = d*h
rt = rt + h 2246 2242 rt = rt + h
! check convergence of the first kind 2247 2243 ! check convergence of the first kind
if (cdabs(h) .le. eps1*max(cdabs(rt),ax)) then 2248 2244 if (cdabs(h) .le. eps1*max(cdabs(rt),ax)) then
if (ic .ne. 0) then 2249 2245 if (ic .ne. 0) then
exit icloop 2250 2246 exit icloop
end if 2251 2247 end if
ic = 1 2252 2248 ic = 1
z0 = y1 2253 2249 z0 = y1
z1 = y2 2254 2250 z1 = y2
z2 = f(rt) 2255 2251 z2 = f(rt)
xl = rt 2256 2252 xl = rt
ick = ick+1 2257 2253 ick = ick+1
if (ick .le. ickmax) then 2258 2254 if (ick .le. ickmax) then
cycle iloop 2259 2255 cycle iloop
end if 2260 2256 end if
! warning error, itmax = maximum 2261 2257 ! warning error, itmax = maximum
jk = itmax + jk 2262 2258 jk = itmax + jk
ier = 33 2263 2259 ier = 33
end if 2264 2260 end if
if (ic .ne. 0) then 2265 2261 if (ic .ne. 0) then
cycle icloop 2266 2262 cycle icloop
end if 2267 2263 end if
call deflated_work(errcode) 2268 2264 call deflated_work(errcode)
if (errcode == 1) then 2269 2265 if (errcode == 1) then
exit icloop 2270 2266 exit icloop
end if 2271 2267 end if
2272 2268
do while ( (cdabs(fprt)-cdabs(z2)*rten) .ge. rzero) 2273 2269 do while ( (cdabs(fprt)-cdabs(z2)*rten) .ge. rzero)
! take remedial action to induce 2274 2270 ! take remedial action to induce
! convergence 2275 2271 ! convergence
d = d*p5 2276 2272 d = d*p5
h = h*p5 2277 2273 h = h*p5
rt = rt-h 2278 2274 rt = rt-h
call deflated_work(errcode) 2279 2275 call deflated_work(errcode)
if (errcode == 1) then 2280 2276 if (errcode == 1) then
exit icloop 2281 2277 exit icloop
end if 2282 2278 end if
end do 2283 2279 end do
z0 = z1 2284 2280 z0 = z1
z1 = z2 2285 2281 z1 = z2
z2 = fprt 2286 2282 z2 = fprt
y0 = y1 2287 2283 y0 = y1
y1 = y2 2288 2284 y1 = y2
y2 = frt 2289 2285 y2 = frt
end do iloop 2290 2286 end do iloop
end do icloop 2291 2287 end do icloop
x(l) = rt 2292 2288 x(l) = rt
infer(l) = jk 2293 2289 infer(l) = jk
l = l+1 2294 2290 l = l+1
end do rloop 2295 2291 end do rloop
2296 2292
contains 2297 2293 contains
subroutine trans_rt() 2298 2294 subroutine trans_rt()
tem = rten*eps1 2299 2295 tem = rten*eps1
if (cdabs(rt) .gt. ax) tem = tem*rt 2300 2296 if (cdabs(rt) .gt. ax) tem = tem*rt
rt = rt+tem 2301 2297 rt = rt+tem
d = (h+tem)*d/h 2302 2298 d = (h+tem)*d/h
h = h+tem 2303 2299 h = h+tem
end subroutine trans_rt 2304 2300 end subroutine trans_rt
2305 2301
subroutine deflated_work(errcode) 2306 2302 subroutine deflated_work(errcode)
! errcode=0 => no errors 2307 2303 ! errcode=0 => no errors
! errcode=1 => jk>itmax or convergence of second kind achieved 2308 2304 ! errcode=1 => jk>itmax or convergence of second kind achieved
integer :: errcode,flag 2309 2305 integer :: errcode,flag
2310 2306
flag=1 2311 2307 flag=1
loop1: do while(flag==1) 2312 2308 loop1: do while(flag==1)
errcode=0 2313 2309 errcode=0
jk = jk+1 2314 2310 jk = jk+1
if (jk .gt. itmax) then 2315 2311 if (jk .gt. itmax) then
ier=33 2316 2312 ier=33
errcode=1 2317 2313 errcode=1
return 2318 2314 return
end if 2319 2315 end if
frt = f(rt) 2320 2316 frt = f(rt)
fprt = frt 2321 2317 fprt = frt
if (l /= 1) then 2322 2318 if (l /= 1) then
lm1 = l-1 2323 2319 lm1 = l-1
do i=1,lm1 2324 2320 do i=1,lm1
tem = rt - x(i) 2325 2321 tem = rt - x(i)
if (cdabs(tem) .eq. rzero) then 2326 2322 if (cdabs(tem) .eq. rzero) then
!if (ic .ne. 0) go to 15 !! ?? possible? 2327 2323 !if (ic .ne. 0) go to 15 !! ?? possible?
call trans_rt() 2328 2324 call trans_rt()
cycle loop1 2329 2325 cycle loop1
end if 2330 2326 end if
fprt = fprt/tem 2331 2327 fprt = fprt/tem
end do 2332 2328 end do
end if 2333 2329 end if
flag=0 2334 2330 flag=0
end do loop1 2335 2331 end do loop1
2336 2332
if (cdabs(fprt) .le. eps .and. cdabs(frt) .le. eps) then 2337 2333 if (cdabs(fprt) .le. eps .and. cdabs(frt) .le. eps) then
errcode=1 2338 2334 errcode=1
return 2339 2335 return
end if 2340 2336 end if
2341 2337
end subroutine deflated_work 2342 2338 end subroutine deflated_work
2343 2339
end subroutine 2344 2340 end subroutine
2345 2341
2346 2342
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2347 2343 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 2348 2344 !
! Integration 2349 2345 ! Integration
! 2350 2346 !
! Only double precision coded atm 2351 2347 ! Only double precision coded atm
! 2352 2348 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2353 2349 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2354 2350
2355 2351
subroutine fvn_d_gauss_legendre(n,qx,qw) 2356 2352 subroutine fvn_d_gauss_legendre(n,qx,qw)
! 2357 2353 !
! This routine compute the n Gauss Legendre abscissas and weights 2358 2354 ! This routine compute the n Gauss Legendre abscissas and weights
! Adapted from Numerical Recipes routine gauleg 2359 2355 ! Adapted from Numerical Recipes routine gauleg
! 2360 2356 !
! n (in) : number of points 2361 2357 ! n (in) : number of points
! qx(out) : abscissas 2362 2358 ! qx(out) : abscissas
! qw(out) : weights 2363 2359 ! qw(out) : weights
! 2364 2360 !
implicit none 2365 2361 implicit none
double precision,parameter :: pi=3.141592653589793d0 2366 2362 double precision,parameter :: pi=3.141592653589793d0
integer, intent(in) :: n 2367 2363 integer, intent(in) :: n
double precision, intent(out) :: qx(n),qw(n) 2368 2364 double precision, intent(out) :: qx(n),qw(n)
2369 2365
integer :: m,i,j 2370 2366 integer :: m,i,j
double precision :: z,z1,p1,p2,p3,pp 2371 2367 double precision :: z,z1,p1,p2,p3,pp
m=(n+1)/2 2372 2368 m=(n+1)/2
do i=1,m 2373 2369 do i=1,m
z=cos(pi*(dble(i)-0.25d0)/(dble(n)+0.5d0)) 2374 2370 z=cos(pi*(dble(i)-0.25d0)/(dble(n)+0.5d0))
iloop: do 2375 2371 iloop: do
p1=1.d0 2376 2372 p1=1.d0
p2=0.d0 2377 2373 p2=0.d0
do j=1,n 2378 2374 do j=1,n
p3=p2 2379 2375 p3=p2
p2=p1 2380 2376 p2=p1
p1=((2.d0*dble(j)-1.d0)*z*p2-(dble(j)-1.d0)*p3)/dble(j) 2381 2377 p1=((2.d0*dble(j)-1.d0)*z*p2-(dble(j)-1.d0)*p3)/dble(j)
end do 2382 2378 end do
pp=dble(n)*(z*p1-p2)/(z*z-1.d0) 2383 2379 pp=dble(n)*(z*p1-p2)/(z*z-1.d0)
z1=z 2384 2380 z1=z
z=z1-p1/pp 2385 2381 z=z1-p1/pp
if (dabs(z-z1)<=epsilon(z)) then 2386 2382 if (dabs(z-z1)<=epsilon(z)) then
exit iloop 2387 2383 exit iloop
end if 2388 2384 end if
end do iloop 2389 2385 end do iloop
qx(i)=-z 2390 2386 qx(i)=-z
qx(n+1-i)=z 2391 2387 qx(n+1-i)=z
qw(i)=2.d0/((1.d0-z*z)*pp*pp) 2392 2388 qw(i)=2.d0/((1.d0-z*z)*pp*pp)
qw(n+1-i)=qw(i) 2393 2389 qw(n+1-i)=qw(i)
end do 2394 2390 end do
end subroutine 2395 2391 end subroutine
2396 2392
2397 2393
2398 2394
subroutine fvn_d_gl_integ(f,a,b,n,res) 2399 2395 subroutine fvn_d_gl_integ(f,a,b,n,res)
! 2400 2396 !
! This is a simple non adaptative integration routine 2401 2397 ! This is a simple non adaptative integration routine
! using n gauss legendre abscissas and weights 2402 2398 ! using n gauss legendre abscissas and weights
! 2403 2399 !
! f(in) : the function to integrate 2404 2400 ! f(in) : the function to integrate
! a(in) : lower bound 2405 2401 ! a(in) : lower bound
! b(in) : higher bound 2406 2402 ! b(in) : higher bound
! n(in) : number of gauss legendre pairs 2407 2403 ! n(in) : number of gauss legendre pairs
! res(out): the evaluation of the integral 2408 2404 ! res(out): the evaluation of the integral
! 2409 2405 !
double precision,external :: f 2410 2406 double precision,external :: f
double precision, intent(in) :: a,b 2411 2407 double precision, intent(in) :: a,b
integer, intent(in):: n 2412 2408 integer, intent(in):: n
double precision, intent(out) :: res 2413 2409 double precision, intent(out) :: res
2414 2410
double precision, allocatable :: qx(:),qw(:) 2415 2411 double precision, allocatable :: qx(:),qw(:)
double precision :: xm,xr 2416 2412 double precision :: xm,xr
integer :: i 2417 2413 integer :: i
2418 2414
! First compute n gauss legendre abs and weight 2419 2415 ! First compute n gauss legendre abs and weight
allocate(qx(n)) 2420 2416 allocate(qx(n))
allocate(qw(n)) 2421 2417 allocate(qw(n))
call fvn_d_gauss_legendre(n,qx,qw) 2422 2418 call fvn_d_gauss_legendre(n,qx,qw)
2423 2419
xm=0.5d0*(b+a) 2424 2420 xm=0.5d0*(b+a)
xr=0.5d0*(b-a) 2425 2421 xr=0.5d0*(b-a)
2426 2422
res=0.d0 2427 2423 res=0.d0
2428 2424
do i=1,n 2429 2425 do i=1,n
res=res+qw(i)*f(xm+xr*qx(i)) 2430 2426 res=res+qw(i)*f(xm+xr*qx(i))
end do 2431 2427 end do
2432 2428
res=xr*res 2433 2429 res=xr*res
2434 2430
deallocate(qw) 2435 2431 deallocate(qw)
deallocate(qx) 2436 2432 deallocate(qx)
2437 2433
end subroutine 2438 2434 end subroutine
2439 2435
!!!!!!!!!!!!!!!!!!!!!!!! 2440 2436 !!!!!!!!!!!!!!!!!!!!!!!!
! 2441 2437 !
! Simple and double adaptative Gauss Kronrod integration based on 2442 2438 ! Simple and double adaptative Gauss Kronrod integration based on
! a modified version of quadpack ( http://www.netlib.org/quadpack 2443 2439 ! a modified version of quadpack ( http://www.netlib.org/quadpack
! 2444 2440 !
! Common parameters : 2445 2441 ! Common parameters :
! 2446 2442 !
! key (in) 2447 2443 ! key (in)
! epsabs 2448 2444 ! epsabs
! epsrel 2449 2445 ! epsrel
! 2450 2446 !
! 2451 2447 !
!!!!!!!!!!!!!!!!!!!!!!!! 2452 2448 !!!!!!!!!!!!!!!!!!!!!!!!
2453 2449
subroutine fvn_d_integ_1_gk(f,a,b,epsabs,epsrel,key,res,abserr,ier,limit) 2454 2450 subroutine fvn_d_integ_1_gk(f,a,b,epsabs,epsrel,key,res,abserr,ier,limit)
! 2455 2451 !
! Evaluate the integral of function f(x) between a and b 2456 2452 ! Evaluate the integral of function f(x) between a and b
! 2457 2453 !
! f(in) : the function 2458 2454 ! f(in) : the function
! a(in) : lower bound 2459 2455 ! a(in) : lower bound
! b(in) : higher bound 2460 2456 ! b(in) : higher bound
! epsabs(in) : desired absolute error 2461 2457 ! epsabs(in) : desired absolute error
! epsrel(in) : desired relative error 2462 2458 ! epsrel(in) : desired relative error
! key(in) : gauss kronrod rule 2463 2459 ! key(in) : gauss kronrod rule
! 1: 7 - 15 points 2464 2460 ! 1: 7 - 15 points
! 2: 10 - 21 points 2465 2461 ! 2: 10 - 21 points
! 3: 15 - 31 points 2466 2462 ! 3: 15 - 31 points
! 4: 20 - 41 points 2467 2463 ! 4: 20 - 41 points
! 5: 25 - 51 points 2468 2464 ! 5: 25 - 51 points
! 6: 30 - 61 points 2469 2465 ! 6: 30 - 61 points
! 2470 2466 !
! limit(in) : maximum number of subintervals in the partition of the 2471 2467 ! limit(in) : maximum number of subintervals in the partition of the
! given integration interval (a,b). A value of 500 will give the same 2472 2468 ! given integration interval (a,b). A value of 500 will give the same
! behaviour as the imsl routine dqdag 2473 2469 ! behaviour as the imsl routine dqdag
! 2474 2470 !
! res(out) : estimated integral value 2475 2471 ! res(out) : estimated integral value
! abserr(out) : estimated absolute error 2476 2472 ! abserr(out) : estimated absolute error
! ier(out) : error flag from quadpack routines 2477 2473 ! ier(out) : error flag from quadpack routines
! 0 : no error 2478 2474 ! 0 : no error
! 1 : maximum number of subdivisions allowed 2479 2475 ! 1 : maximum number of subdivisions allowed
! has been achieved. one can allow more 2480 2476 ! has been achieved. one can allow more
! subdivisions by increasing the value of 2481 2477 ! subdivisions by increasing the value of
! limit (and taking the according dimension 2482 2478 ! limit (and taking the according dimension
! adjustments into account). however, if 2483 2479 ! adjustments into account). however, if
! this yield no improvement it is advised 2484 2480 ! this yield no improvement it is advised
! to analyze the integrand in order to 2485 2481 ! to analyze the integrand in order to
! determine the integration difficulaties. 2486 2482 ! determine the integration difficulaties.
! if the position of a local difficulty can 2487 2483 ! if the position of a local difficulty can
! be determined (i.e.singularity, 2488 2484 ! be determined (i.e.singularity,
! discontinuity within the interval) one 2489 2485 ! discontinuity within the interval) one
! will probably gain from splitting up the 2490 2486 ! will probably gain from splitting up the
! interval at this point and calling the 2491 2487 ! interval at this point and calling the
! integrator on the subranges. if possible, 2492 2488 ! integrator on the subranges. if possible,
! an appropriate special-purpose integrator 2493 2489 ! an appropriate special-purpose integrator
! should be used which is designed for 2494 2490 ! should be used which is designed for
! handling the type of difficulty involved. 2495 2491 ! handling the type of difficulty involved.
! 2 : the occurrence of roundoff error is 2496 2492 ! 2 : the occurrence of roundoff error is
! detected, which prevents the requested 2497 2493 ! detected, which prevents the requested
! tolerance from being achieved. 2498 2494 ! tolerance from being achieved.
! 3 : extremely bad integrand behaviour occurs 2499 2495 ! 3 : extremely bad integrand behaviour occurs
! at some points of the integration 2500 2496 ! at some points of the integration
! interval. 2501 2497 ! interval.
! 6 : the input is invalid, because 2502 2498 ! 6 : the input is invalid, because
! (epsabs.le.0 and 2503 2499 ! (epsabs.le.0 and
! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) 2504 2500 ! epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
! or limit.lt.1 or lenw.lt.limit*4. 2505 2501 ! or limit.lt.1 or lenw.lt.limit*4.
! result, abserr, neval, last are set 2506 2502 ! result, abserr, neval, last are set
! to zero. 2507 2503 ! to zero.
! except when lenw is invalid, iwork(1), 2508 2504 ! except when lenw is invalid, iwork(1),
! work(limit*2+1) and work(limit*3+1) are 2509 2505 ! work(limit*2+1) and work(limit*3+1) are
! set to zero, work(1) is set to a and 2510 2506 ! set to zero, work(1) is set to a and
! work(limit+1) to b. 2511 2507 ! work(limit+1) to b.
2512 2508
implicit none 2513 2509 implicit none
double precision, external :: f 2514 2510 double precision, external :: f
double precision, intent(in) :: a,b,epsabs,epsrel 2515 2511 double precision, intent(in) :: a,b,epsabs,epsrel
integer, intent(in) :: key 2516 2512 integer, intent(in) :: key
integer, intent(in) :: limit 2517 2513 integer, intent(in) :: limit
double precision, intent(out) :: res,abserr 2518 2514 double precision, intent(out) :: res,abserr
integer, intent(out) :: ier 2519 2515 integer, intent(out) :: ier
2520 2516
double precision, allocatable :: work(:) 2521 2517 double precision, allocatable :: work(:)
integer, allocatable :: iwork(:) 2522 2518 integer, allocatable :: iwork(:)
integer :: lenw,neval,last 2523 2519 integer :: lenw,neval,last
2524 2520
! imsl value for limit is 500 2525 2521 ! imsl value for limit is 500
lenw=limit*4 2526 2522 lenw=limit*4
2527 2523
allocate(iwork(limit)) 2528 2524 allocate(iwork(limit))
allocate(work(lenw)) 2529 2525 allocate(work(lenw))
2530 2526
call dqag(f,a,b,epsabs,epsrel,key,res,abserr,neval,ier,limit,lenw,last,iwork,work) 2531 2527 call dqag(f,a,b,epsabs,epsrel,key,res,abserr,neval,ier,limit,lenw,last,iwork,work)
2532 2528
deallocate(work) 2533 2529 deallocate(work)
deallocate(iwork) 2534 2530 deallocate(iwork)
2535 2531
end subroutine 2536 2532 end subroutine
2537 2533
2538 2534
2539 2535
subroutine fvn_d_integ_2_gk(f,a,b,g,h,epsabs,epsrel,key,res,abserr,ier,limit) 2540 2536 subroutine fvn_d_integ_2_gk(f,a,b,g,h,epsabs,epsrel,key,res,abserr,ier,limit)
! 2541 2537 !
! Evaluate the double integral of function f(x,y) for x between a and b and y between g(x) and h(x) 2542 2538 ! Evaluate the double integral of function f(x,y) for x between a and b and y between g(x) and h(x)
! 2543 2539 !
! f(in) : the function 2544 2540 ! f(in) : the function
! a(in) : lower bound 2545 2541 ! a(in) : lower bound
! b(in) : higher bound 2546 2542 ! b(in) : higher bound
! g(in) : external function describing lower bound for y 2547 2543 ! g(in) : external function describing lower bound for y
! h(in) : external function describing higher bound for y 2548 2544 ! h(in) : external function describing higher bound for y
! epsabs(in) : desired absolute error 2549 2545 ! epsabs(in) : desired absolute error
! epsrel(in) : desired relative error 2550 2546 ! epsrel(in) : desired relative error
! key(in) : gauss kronrod rule 2551 2547 ! key(in) : gauss kronrod rule
! 1: 7 - 15 points 2552 2548 ! 1: 7 - 15 points
! 2: 10 - 21 points 2553 2549 ! 2: 10 - 21 points
! 3: 15 - 31 points 2554 2550 ! 3: 15 - 31 points
! 4: 20 - 41 points 2555 2551 ! 4: 20 - 41 points
! 5: 25 - 51 points 2556 2552 ! 5: 25 - 51 points
! 6: 30 - 61 points 2557 2553 ! 6: 30 - 61 points
! 2558 2554 !
! limit(in) : maximum number of subintervals in the partition of the 2559 2555 ! limit(in) : maximum number of subintervals in the partition of the
! given integration interval (a,b). A value of 500 will give the same 2560 2556 ! given integration interval (a,b). A value of 500 will give the same
! behaviour as the imsl routine dqdag 2561 2557 ! behaviour as the imsl routine dqdag
! 2562 2558 !
! res(out) : estimated integral value 2563 2559 ! res(out) : estimated integral value
! abserr(out) : estimated absolute error 2564 2560 ! abserr(out) : estimated absolute error
! ier(out) : error flag from quadpack routines 2565 2561 ! ier(out) : error flag from quadpack routines
! 0 : no error 2566 2562 ! 0 : no error
! 1 : maximum number of subdivisions allowed 2567 2563 ! 1 : maximum number of subdivisions allowed
! has been achieved. one can allow more 2568 2564 ! has been achieved. one can allow more
! subdivisions by increasing the value of 2569 2565 ! subdivisions by increasing the value of
! limit (and taking the according dimension 2570 2566 ! limit (and taking the according dimension
! adjustments into account). however, if 2571 2567 ! adjustments into account). however, if
! this yield no improvement it is advised 2572 2568 ! this yield no improvement it is advised
! to analyze the integrand in order to 2573 2569 ! to analyze the integrand in order to
! determine the integration difficulaties. 2574 2570 ! determine the integration difficulaties.
! if the position of a local difficulty can 2575 2571 ! if the position of a local difficulty can
! be determined (i.e.singularity, 2576 2572 ! be determined (i.e.singularity,
! discontinuity within the interval) one 2577 2573 ! discontinuity within the interval) one
! will probably gain from splitting up the 2578 2574 ! will probably gain from splitting up the
! interval at this point and calling the 2579 2575 ! interval at this point and calling the
! integrator on the subranges. if possible, 2580 2576 ! integrator on the subranges. if possible,
! an appropriate special-purpose integrator 2581 2577 ! an appropriate special-purpose integrator
! should be used which is designed for 2582 2578 ! should be used which is designed for
! handling the type of difficulty involved. 2583 2579 ! handling the type of difficulty involved.
! 2 : the occurrence of roundoff error is 2584 2580 ! 2 : the occurrence of roundoff error is
! detected, which prevents the requested 2585 2581 ! detected, which prevents the requested
! tolerance from being achieved. 2586 2582 ! tolerance from being achieved.
! 3 : extremely bad integrand behaviour occurs 2587 2583 ! 3 : extremely bad integrand behaviour occurs
! at some points of the integration 2588 2584 ! at some points of the integration
! interval. 2589 2585 ! interval.
! 6 : the input is invalid, because 2590 2586 ! 6 : the input is invalid, because
! (epsabs.le.0 and 2591 2587 ! (epsabs.le.0 and
! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) 2592 2588 ! epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
! or limit.lt.1 or lenw.lt.limit*4. 2593 2589 ! or limit.lt.1 or lenw.lt.limit*4.
! result, abserr, neval, last are set 2594 2590 ! result, abserr, neval, last are set
! to zero. 2595 2591 ! to zero.
! except when lenw is invalid, iwork(1), 2596 2592 ! except when lenw is invalid, iwork(1),
! work(limit*2+1) and work(limit*3+1) are 2597 2593 ! work(limit*2+1) and work(limit*3+1) are
! set to zero, work(1) is set to a and 2598 2594 ! set to zero, work(1) is set to a and
! work(limit+1) to b. 2599 2595 ! work(limit+1) to b.
2600 2596
implicit none 2601 2597 implicit none
double precision, external:: f,g,h 2602 2598 double precision, external:: f,g,h
double precision, intent(in) :: a,b,epsabs,epsrel 2603 2599 double precision, intent(in) :: a,b,epsabs,epsrel
integer, intent(in) :: key,limit 2604 2600 integer, intent(in) :: key,limit
integer, intent(out) :: ier 2605 2601 integer, intent(out) :: ier
double precision, intent(out) :: res,abserr 2606 2602 double precision, intent(out) :: res,abserr
2607 2603
2608 2604
double precision, allocatable :: work(:) 2609 2605 double precision, allocatable :: work(:)
integer, allocatable :: iwork(:) 2610 2606 integer, allocatable :: iwork(:)
integer :: lenw,neval,last 2611 2607 integer :: lenw,neval,last
2612 2608
! imsl value for limit is 500 2613 2609 ! imsl value for limit is 500
lenw=limit*4 2614 2610 lenw=limit*4
allocate(work(lenw)) 2615 2611 allocate(work(lenw))
allocate(iwork(limit)) 2616 2612 allocate(iwork(limit))
2617 2613
call dqag_2d_outer(f,a,b,g,h,epsabs,epsrel,key,res,abserr,neval,ier,limit,lenw,last,iwork,work) 2618 2614 call dqag_2d_outer(f,a,b,g,h,epsabs,epsrel,key,res,abserr,neval,ier,limit,lenw,last,iwork,work)
2619 2615
deallocate(iwork) 2620 2616 deallocate(iwork)
deallocate(work) 2621 2617 deallocate(work)
end subroutine 2622 2618 end subroutine
2623 2619
2624 2620
2625 2621
subroutine fvn_d_integ_2_inner_gk(f,x,a,b,epsabs,epsrel,key,res,abserr,ier,limit) 2626 2622 subroutine fvn_d_integ_2_inner_gk(f,x,a,b,epsabs,epsrel,key,res,abserr,ier,limit)
! 2627 2623 !
! Evaluate the single integral of function f(x,y) for y between a and b with a 2628 2624 ! Evaluate the single integral of function f(x,y) for y between a and b with a
! given x value 2629 2625 ! given x value
! 2630 2626 !
! This function is used for the evaluation of the double integral fvn_d_integ_2_gk 2631 2627 ! This function is used for the evaluation of the double integral fvn_d_integ_2_gk
! 2632 2628 !
! f(in) : the function 2633 2629 ! f(in) : the function
! x(in) : x 2634 2630 ! x(in) : x
! a(in) : lower bound 2635 2631 ! a(in) : lower bound
! b(in) : higher bound 2636 2632 ! b(in) : higher bound
! epsabs(in) : desired absolute error 2637 2633 ! epsabs(in) : desired absolute error
! epsrel(in) : desired relative error 2638 2634 ! epsrel(in) : desired relative error
! key(in) : gauss kronrod rule 2639 2635 ! key(in) : gauss kronrod rule
! 1: 7 - 15 points 2640 2636 ! 1: 7 - 15 points
! 2: 10 - 21 points 2641 2637 ! 2: 10 - 21 points
! 3: 15 - 31 points 2642 2638 ! 3: 15 - 31 points
! 4: 20 - 41 points 2643 2639 ! 4: 20 - 41 points
! 5: 25 - 51 points 2644 2640 ! 5: 25 - 51 points
! 6: 30 - 61 points 2645 2641 ! 6: 30 - 61 points
! 2646 2642 !
! limit(in) : maximum number of subintervals in the partition of the 2647 2643 ! limit(in) : maximum number of subintervals in the partition of the
! given integration interval (a,b). A value of 500 will give the same 2648 2644 ! given integration interval (a,b). A value of 500 will give the same
! behaviour as the imsl routine dqdag 2649 2645 ! behaviour as the imsl routine dqdag
! 2650 2646 !
! res(out) : estimated integral value 2651 2647 ! res(out) : estimated integral value
! abserr(out) : estimated absolute error 2652 2648 ! abserr(out) : estimated absolute error
! ier(out) : error flag from quadpack routines 2653 2649 ! ier(out) : error flag from quadpack routines
! 0 : no error 2654 2650 ! 0 : no error
! 1 : maximum number of subdivisions allowed 2655 2651 ! 1 : maximum number of subdivisions allowed
! has been achieved. one can allow more 2656 2652 ! has been achieved. one can allow more
! subdivisions by increasing the value of 2657 2653 ! subdivisions by increasing the value of
! limit (and taking the according dimension 2658 2654 ! limit (and taking the according dimension
! adjustments into account). however, if 2659 2655 ! adjustments into account). however, if
! this yield no improvement it is advised 2660 2656 ! this yield no improvement it is advised
! to analyze the integrand in order to 2661 2657 ! to analyze the integrand in order to
! determine the integration difficulaties. 2662 2658 ! determine the integration difficulaties.
! if the position of a local difficulty can 2663 2659 ! if the position of a local difficulty can
! be determined (i.e.singularity, 2664 2660 ! be determined (i.e.singularity,
! discontinuity within the interval) one 2665 2661 ! discontinuity within the interval) one
! will probably gain from splitting up the 2666 2662 ! will probably gain from splitting up the
! interval at this point and calling the 2667 2663 ! interval at this point and calling the
! integrator on the subranges. if possible, 2668 2664 ! integrator on the subranges. if possible,
! an appropriate special-purpose integrator 2669 2665 ! an appropriate special-purpose integrator
! should be used which is designed for 2670 2666 ! should be used which is designed for
! handling the type of difficulty involved. 2671 2667 ! handling the type of difficulty involved.
! 2 : the occurrence of roundoff error is 2672 2668 ! 2 : the occurrence of roundoff error is
! detected, which prevents the requested 2673 2669 ! detected, which prevents the requested
! tolerance from being achieved. 2674 2670 ! tolerance from being achieved.
! 3 : extremely bad integrand behaviour occurs 2675 2671 ! 3 : extremely bad integrand behaviour occurs
! at some points of the integration 2676 2672 ! at some points of the integration
! interval. 2677 2673 ! interval.
! 6 : the input is invalid, because 2678 2674 ! 6 : the input is invalid, because
! (epsabs.le.0 and 2679 2675 ! (epsabs.le.0 and
! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) 2680 2676 ! epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
! or limit.lt.1 or lenw.lt.limit*4. 2681 2677 ! or limit.lt.1 or lenw.lt.limit*4.
! result, abserr, neval, last are set 2682 2678 ! result, abserr, neval, last are set
! to zero. 2683 2679 ! to zero.
! except when lenw is invalid, iwork(1), 2684 2680 ! except when lenw is invalid, iwork(1),
! work(limit*2+1) and work(limit*3+1) are 2685 2681 ! work(limit*2+1) and work(limit*3+1) are
! set to zero, work(1) is set to a and 2686 2682 ! set to zero, work(1) is set to a and
! work(limit+1) to b. 2687 2683 ! work(limit+1) to b.
2688 2684
implicit none 2689 2685 implicit none
double precision, external:: f 2690 2686 double precision, external:: f
double precision, intent(in) :: x,a,b,epsabs,epsrel 2691 2687 double precision, intent(in) :: x,a,b,epsabs,epsrel
integer, intent(in) :: key,limit 2692 2688 integer, intent(in) :: key,limit
integer, intent(out) :: ier 2693 2689 integer, intent(out) :: ier
double precision, intent(out) :: res,abserr 2694 2690 double precision, intent(out) :: res,abserr
2695 2691
2696 2692
double precision, allocatable :: work(:) 2697 2693 double precision, allocatable :: work(:)
integer, allocatable :: iwork(:) 2698 2694 integer, allocatable :: iwork(:)
integer :: lenw,neval,last 2699 2695 integer :: lenw,neval,last
2700 2696
! imsl value for limit is 500 2701 2697 ! imsl value for limit is 500
lenw=limit*4 2702 2698 lenw=limit*4
allocate(work(lenw)) 2703 2699 allocate(work(lenw))
allocate(iwork(limit)) 2704 2700 allocate(iwork(limit))
2705 2701
call dqag_2d_inner(f,x,a,b,epsabs,epsrel,key,res,abserr,neval,ier,limit,lenw,last,iwork,work) 2706 2702 call dqag_2d_inner(f,x,a,b,epsabs,epsrel,key,res,abserr,neval,ier,limit,lenw,last,iwork,work)
2707 2703
deallocate(iwork) 2708 2704 deallocate(iwork)
deallocate(work) 2709 2705 deallocate(work)
end subroutine 2710 2706 end subroutine
2711 2707
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2712 2708 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Include the modified quadpack files 2713 2709 ! Include the modified quadpack files
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2714 2710 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
include "fvn_quadpack/dqag_2d_inner.f" 2715 2711 include "fvn_quadpack/dqag_2d_inner.f"
include "fvn_quadpack/dqk15_2d_inner.f" 2716 2712 include "fvn_quadpack/dqk15_2d_inner.f"
include "fvn_quadpack/dqk31_2d_outer.f" 2717 2713 include "fvn_quadpack/dqk31_2d_outer.f"
include "fvn_quadpack/d1mach.f" 2718 2714 include "fvn_quadpack/d1mach.f"
include "fvn_quadpack/dqk31_2d_inner.f" 2719 2715 include "fvn_quadpack/dqk31_2d_inner.f"
include "fvn_quadpack/dqage.f" 2720 2716 include "fvn_quadpack/dqage.f"
include "fvn_quadpack/dqk15.f" 2721 2717 include "fvn_quadpack/dqk15.f"
include "fvn_quadpack/dqk21.f" 2722 2718 include "fvn_quadpack/dqk21.f"
include "fvn_quadpack/dqk31.f" 2723 2719 include "fvn_quadpack/dqk31.f"
include "fvn_quadpack/dqk41.f" 2724 2720 include "fvn_quadpack/dqk41.f"
include "fvn_quadpack/dqk51.f" 2725 2721 include "fvn_quadpack/dqk51.f"
include "fvn_quadpack/dqk61.f" 2726 2722 include "fvn_quadpack/dqk61.f"
include "fvn_quadpack/dqk41_2d_outer.f" 2727 2723 include "fvn_quadpack/dqk41_2d_outer.f"
include "fvn_quadpack/dqk41_2d_inner.f" 2728 2724 include "fvn_quadpack/dqk41_2d_inner.f"
include "fvn_quadpack/dqag_2d_outer.f" 2729 2725 include "fvn_quadpack/dqag_2d_outer.f"
include "fvn_quadpack/dqpsrt.f" 2730 2726 include "fvn_quadpack/dqpsrt.f"
include "fvn_quadpack/dqag.f" 2731 2727 include "fvn_quadpack/dqag.f"
include "fvn_quadpack/dqage_2d_outer.f" 2732 2728 include "fvn_quadpack/dqage_2d_outer.f"
include "fvn_quadpack/dqage_2d_inner.f" 2733 2729 include "fvn_quadpack/dqage_2d_inner.f"
include "fvn_quadpack/dqk51_2d_outer.f" 2734 2730 include "fvn_quadpack/dqk51_2d_outer.f"
include "fvn_quadpack/dqk51_2d_inner.f" 2735 2731 include "fvn_quadpack/dqk51_2d_inner.f"
include "fvn_quadpack/dqk61_2d_outer.f" 2736 2732 include "fvn_quadpack/dqk61_2d_outer.f"
include "fvn_quadpack/dqk21_2d_outer.f" 2737 2733 include "fvn_quadpack/dqk21_2d_outer.f"
include "fvn_quadpack/dqk61_2d_inner.f" 2738 2734 include "fvn_quadpack/dqk61_2d_inner.f"
include "fvn_quadpack/dqk21_2d_inner.f" 2739 2735 include "fvn_quadpack/dqk21_2d_inner.f"
include "fvn_quadpack/dqk15_2d_outer.f" 2740 2736 include "fvn_quadpack/dqk15_2d_outer.f"
2741 2737
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2742 2738 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 2743 2739 !
! Trigonometric functions 2744 2740 ! Trigonometric functions
! 2745 2741 !
! fvn_z_acos, fvn_z_asin : complex arc cosine and sine 2746 2742 ! fvn_z_acos, fvn_z_asin : complex arc cosine and sine
! fvn_d_acosh : arc cosinus hyperbolic 2747 2743 ! fvn_d_acosh : arc cosinus hyperbolic
! fvn_d_asinh : arc sinus hyperbolic 2748 2744 ! fvn_d_asinh : arc sinus hyperbolic
! 2749 2745 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2750 2746 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! February 2008 2751 2747 ! February 2008
! All Trigonometric functions removed due to implementation of fnlib 2752 2748 ! All Trigonometric functions removed due to implementation of fnlib
2753 2749
function fvn_z_acos(z) 2754 2750 function fvn_z_acos(z)
! double complex arccos function adapted from 2755 2751 ! double complex arccos function adapted from
! the c gsl library 2756 2752 ! the c gsl library
! http://www.gnu.org/software/gsl/ 2757 2753 ! http://www.gnu.org/software/gsl/
implicit none 2758 2754 implicit none
complex(kind=8) :: fvn_z_acos 2759 2755 complex(kind=8) :: fvn_z_acos
complex(kind=8) :: z 2760 2756 complex(kind=8) :: z
real(kind=8) :: rz,iz,x,y,a,b,y2,r,s,d,apx,am1 2761 2757 real(kind=8) :: rz,iz,x,y,a,b,y2,r,s,d,apx,am1
real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8 2762 2758 real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8
complex(kind=8),parameter :: i=(0._8,1._8) 2763 2759 complex(kind=8),parameter :: i=(0._8,1._8)
real(kind=8) :: r_res,i_res 2764 2760 real(kind=8) :: r_res,i_res
2765 2761
rz=dreal(z) 2766 2762 rz=dreal(z)
iz=dimag(z) 2767 2763 iz=dimag(z)
if ( iz == 0._8 ) then 2768 2764 if ( iz == 0._8 ) then
fvn_z_acos=fvn_z_acos_real(rz) 2769 2765 fvn_z_acos=fvn_z_acos_real(rz)
return 2770 2766 return
end if 2771 2767 end if
2772 2768
x=dabs(rz) 2773 2769 x=dabs(rz)
y=dabs(iz) 2774 2770 y=dabs(iz)
r=fvn_d_hypot(x+1.,y) 2775 2771 r=fvn_d_hypot(x+1.,y)
s=fvn_d_hypot(x-1.,y) 2776 2772 s=fvn_d_hypot(x-1.,y)
a=0.5*(r + s) 2777 2773 a=0.5*(r + s)
b=x/a 2778 2774 b=x/a
y2=y*y 2779 2775 y2=y*y
2780 2776
if (b <= b_crossover) then 2781 2777 if (b <= b_crossover) then
r_res=dacos(b) 2782 2778 r_res=dacos(b)
else 2783 2779 else
if (x <= 1.) then 2784 2780 if (x <= 1.) then
d=0.5*(a+x)*(y2/(r+x+1)+(s + (1 - x))) 2785 2781 d=0.5*(a+x)*(y2/(r+x+1)+(s + (1 - x)))
r_res=datan(dsqrt(d)/x) 2786 2782 r_res=datan(dsqrt(d)/x)
else 2787 2783 else
apx=a+x 2788 2784 apx=a+x
d=0.5*(apx/(r+x+1)+apx/(s + (x - 1))) 2789 2785 d=0.5*(apx/(r+x+1)+apx/(s + (x - 1)))
r_res=datan((y*dsqrt(d))/x); 2790 2786 r_res=datan((y*dsqrt(d))/x);
end if 2791 2787 end if
end if 2792 2788 end if
2793 2789
if (a <= a_crossover) then 2794 2790 if (a <= a_crossover) then
if (x < 1.) then 2795 2791 if (x < 1.) then
am1=0.5*(y2 / (r + (x + 1)) + y2 / (s + (1 - x))) 2796 2792 am1=0.5*(y2 / (r + (x + 1)) + y2 / (s + (1 - x)))
else 2797 2793 else
am1=0.5*(y2 / (r + (x + 1)) + (s + (x - 1))) 2798 2794 am1=0.5*(y2 / (r + (x + 1)) + (s + (x - 1)))
end if 2799 2795 end if
i_res = dlog(1.+(am1 + sqrt (am1 * (a + 1)))); 2800 2796 i_res = dlog(1.+(am1 + sqrt (am1 * (a + 1))));
else 2801 2797 else
i_res = dlog (a + dsqrt (a*a - 1.)); 2802 2798 i_res = dlog (a + dsqrt (a*a - 1.));
end if 2803 2799 end if
if (rz <0.) then 2804 2800 if (rz <0.) then
r_res=fvn_pi-r_res 2805 2801 r_res=fvn_pi-r_res
end if 2806 2802 end if
i_res=-sign(1._8,iz)*i_res 2807 2803 i_res=-sign(1._8,iz)*i_res
fvn_z_acos=dcmplx(r_res)+fvn_i*dcmplx(i_res) 2808 2804 fvn_z_acos=dcmplx(r_res)+fvn_i*dcmplx(i_res)
2809 2805
end function fvn_z_acos 2810 2806 end function fvn_z_acos
2811 2807
function fvn_z_acos_real(r) 2812 2808 function fvn_z_acos_real(r)
! return the double complex arc cosinus for a 2813 2809 ! return the double complex arc cosinus for a
! double precision argument 2814 2810 ! double precision argument
implicit none 2815 2811 implicit none
real(kind=8) :: r 2816 2812 real(kind=8) :: r
complex(kind=8) :: fvn_z_acos_real 2817 2813 complex(kind=8) :: fvn_z_acos_real
2818 2814
if (dabs(r)<=1._8) then 2819 2815 if (dabs(r)<=1._8) then
fvn_z_acos_real=dcmplx(dacos(r)) 2820 2816 fvn_z_acos_real=dcmplx(dacos(r))
return 2821 2817 return
end if 2822 2818 end if
if (r < 0._8) then 2823 2819 if (r < 0._8) then
fvn_z_acos_real=dcmplx(fvn_pi)-fvn_i*dcmplx(fvn_d_acosh(-r)) 2824 2820 fvn_z_acos_real=dcmplx(fvn_pi)-fvn_i*dcmplx(fvn_d_acosh(-r))
else 2825 2821 else
fvn_z_acos_real=fvn_i*dcmplx(fvn_d_acosh(r)) 2826 2822 fvn_z_acos_real=fvn_i*dcmplx(fvn_d_acosh(r))
end if 2827 2823 end if
end function 2828 2824 end function
2829 2825
2830 2826
function fvn_z_asin(z) 2831 2827 function fvn_z_asin(z)
! double complex arcsin function derived from 2832 2828 ! double complex arcsin function derived from
! the c gsl library 2833 2829 ! the c gsl library
! http://www.gnu.org/software/gsl/ 2834 2830 ! http://www.gnu.org/software/gsl/
implicit none 2835 2831 implicit none
complex(kind=8) :: fvn_z_asin 2836 2832 complex(kind=8) :: fvn_z_asin
complex(kind=8) :: z 2837 2833 complex(kind=8) :: z
real(kind=8) :: rz,iz,x,y,a,b,y2,r,s,d,apx,am1 2838 2834 real(kind=8) :: rz,iz,x,y,a,b,y2,r,s,d,apx,am1
real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8 2839 2835 real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8
real(kind=8) :: r_res,i_res 2840 2836 real(kind=8) :: r_res,i_res
2841 2837
rz=dreal(z) 2842 2838 rz=dreal(z)
iz=dimag(z) 2843 2839 iz=dimag(z)
if ( iz == 0._8 ) then 2844 2840 if ( iz == 0._8 ) then
! z is real 2845 2841 ! z is real
fvn_z_asin=fvn_z_asin_real(rz) 2846 2842 fvn_z_asin=fvn_z_asin_real(rz)
return 2847 2843 return
end if 2848 2844 end if
2849 2845
x=dabs(rz) 2850 2846 x=dabs(rz)
y=dabs(iz) 2851 2847 y=dabs(iz)
r=fvn_d_hypot(x+1.,y) 2852 2848 r=fvn_d_hypot(x+1.,y)
s=fvn_d_hypot(x-1.,y) 2853 2849 s=fvn_d_hypot(x-1.,y)
a=0.5*(r + s) 2854 2850 a=0.5*(r + s)
b=x/a 2855 2851 b=x/a
y2=y*y 2856 2852 y2=y*y
2857 2853
if (b <= b_crossover) then 2858 2854 if (b <= b_crossover) then
r_res=dasin(b) 2859 2855 r_res=dasin(b)
else 2860 2856 else
if (x <= 1.) then 2861 2857 if (x <= 1.) then
d=0.5*(a+x)*(y2/(r+x+1)+(s + (1 - x))) 2862 2858 d=0.5*(a+x)*(y2/(r+x+1)+(s + (1 - x)))
r_res=datan(x/dsqrt(d)) 2863 2859 r_res=datan(x/dsqrt(d))
else 2864 2860 else
apx=a+x 2865 2861 apx=a+x
d=0.5*(apx/(r+x+1)+apx/(s + (x - 1))) 2866 2862 d=0.5*(apx/(r+x+1)+apx/(s + (x - 1)))
r_res=datan(x/(y*dsqrt(d))); 2867 2863 r_res=datan(x/(y*dsqrt(d)));
end if 2868 2864 end if
end if 2869 2865 end if
2870 2866
if (a <= a_crossover) then 2871 2867 if (a <= a_crossover) then
if (x < 1.) then 2872 2868 if (x < 1.) then
am1=0.5*(y2 / (r + (x + 1)) + y2 / (s + (1 - x))) 2873 2869 am1=0.5*(y2 / (r + (x + 1)) + y2 / (s + (1 - x)))
else 2874 2870 else
am1=0.5*(y2 / (r + (x + 1)) + (s + (x - 1))) 2875 2871 am1=0.5*(y2 / (r + (x + 1)) + (s + (x - 1)))
end if 2876 2872 end if
i_res = dlog(1.+(am1 + sqrt (am1 * (a + 1)))); 2877 2873 i_res = dlog(1.+(am1 + sqrt (am1 * (a + 1))));
else 2878 2874 else
i_res = dlog (a + dsqrt (a*a - 1.)); 2879 2875 i_res = dlog (a + dsqrt (a*a - 1.));
end if 2880 2876 end if
r_res=sign(1._8,rz)*r_res 2881 2877 r_res=sign(1._8,rz)*r_res
i_res=sign(1._8,iz)*i_res 2882 2878 i_res=sign(1._8,iz)*i_res
fvn_z_asin=dcmplx(r_res)+fvn_i*dcmplx(i_res) 2883 2879 fvn_z_asin=dcmplx(r_res)+fvn_i*dcmplx(i_res)
2884 2880
end function fvn_z_asin 2885 2881 end function fvn_z_asin
2886 2882
function fvn_z_asin_real(r) 2887 2883 function fvn_z_asin_real(r)
! return the double complex arc sinus for a 2888 2884 ! return the double complex arc sinus for a
! double precision argument 2889 2885 ! double precision argument
implicit none 2890 2886 implicit none
real(kind=8) :: r 2891 2887 real(kind=8) :: r
complex(kind=8) :: fvn_z_asin_real 2892 2888 complex(kind=8) :: fvn_z_asin_real
2893 2889
if (dabs(r)<=1._8) then 2894 2890 if (dabs(r)<=1._8) then
fvn_z_asin_real=dcmplx(dasin(r)) 2895 2891 fvn_z_asin_real=dcmplx(dasin(r))
return 2896 2892 return
end if 2897 2893 end if
if (r < 0._8) then 2898 2894 if (r < 0._8) then
fvn_z_asin_real=dcmplx(-fvn_pi/2._8)+fvn_i*dcmplx(fvn_d_acosh(-r)) 2899 2895 fvn_z_asin_real=dcmplx(-fvn_pi/2._8)+fvn_i*dcmplx(fvn_d_acosh(-r))
else 2900 2896 else
fvn_z_asin_real=dcmplx(fvn_pi/2._8)-fvn_i*dcmplx(fvn_d_acosh(r)) 2901 2897 fvn_z_asin_real=dcmplx(fvn_pi/2._8)-fvn_i*dcmplx(fvn_d_acosh(r))
end if 2902 2898 end if
end function fvn_z_asin_real 2903 2899 end function fvn_z_asin_real
2904 2900
function fvn_d_acosh(r) 2905 2901 function fvn_d_acosh(r)
! return the arc hyperbolic cosine 2906 2902 ! return the arc hyperbolic cosine
implicit none 2907 2903 implicit none
real(kind=8) :: r 2908 2904 real(kind=8) :: r
real(kind=8) :: fvn_d_acosh 2909 2905 real(kind=8) :: fvn_d_acosh
if (r >=1) then 2910 2906 if (r >=1) then
fvn_d_acosh=dlog(r+dsqrt(r*r-1)) 2911 2907 fvn_d_acosh=dlog(r+dsqrt(r*r-1))
else 2912 2908 else